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       evdw=0.0D0
2017 ccccc      energy_dec=.false.
2018 C      print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
2019       gg_lipi=0.0d0
2020       gg_lipj=0.0d0
2021       lprn=.false.
2022 c     if (icall.eq.0) lprn=.false.
2023       ind=0
2024 C the loop over all 27 posible neigbours (for xshift=0,yshift=0,zshift=0
2025 C we have the original box)
2026 C      do xshift=-1,1
2027 C      do yshift=-1,1
2028 C      do zshift=-1,1
2029 c      do i=iatsc_s,iatsc_e
2030       do ikont=g_listscsc_start,g_listscsc_end
2031         i=newcontlisti(ikont)
2032         j=newcontlistj(ikont)
2033         itypi=iabs(itype(i))
2034         if (itypi.eq.ntyp1) cycle
2035         itypi1=iabs(itype(i+1))
2036         xi=c(1,nres+i)
2037         yi=c(2,nres+i)
2038         zi=c(3,nres+i)
2039         call to_box(xi,yi,zi)
2040 C define scaling factor for lipids
2041
2042 C        if (positi.le.0) positi=positi+boxzsize
2043 C        print *,i
2044 C first for peptide groups
2045 c for each residue check if it is in lipid or lipid water border area
2046         call lipid_layer(xi,yi,zi,sslipi,ssgradlipi)
2047 C          xi=xi+xshift*boxxsize
2048 C          yi=yi+yshift*boxysize
2049 C          zi=zi+zshift*boxzsize
2050
2051         dxi=dc_norm(1,nres+i)
2052         dyi=dc_norm(2,nres+i)
2053         dzi=dc_norm(3,nres+i)
2054 c        dsci_inv=dsc_inv(itypi)
2055         dsci_inv=vbld_inv(i+nres)
2056 c        write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)
2057 c        write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi
2058 C
2059 C Calculate SC interaction energy.
2060 C
2061 c        do iint=1,nint_gr(i)
2062 c          do j=istart(i,iint),iend(i,iint)
2063             IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN
2064
2065 c              write(iout,*) "PRZED ZWYKLE", evdwij
2066               call dyn_ssbond_ene(i,j,evdwij)
2067 c              write(iout,*) "PO ZWYKLE", evdwij
2068 c              call flush(iout)
2069
2070               evdw=evdw+evdwij
2071               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)')
2072      &                        'evdw',i,j,evdwij,' ss'
2073 C triple bond artifac removal
2074 c              do k=j+1,iend(i,iint)
2075               do k=j+1,nct
2076 C search over all next residues
2077                 if (dyn_ss_mask(k)) then
2078 C check if they are cysteins
2079 C              write(iout,*) 'k=',k
2080
2081 c              write(iout,*) "PRZED TRI", evdwij
2082                   evdwij_przed_tri=evdwij
2083                   call triple_ssbond_ene(i,j,k,evdwij)
2084 c               if(evdwij_przed_tri.ne.evdwij) then
2085 c                 write (iout,*) "TRI:", evdwij, evdwij_przed_tri
2086 c               endif
2087
2088 c              write(iout,*) "PO TRI", evdwij
2089 C call the energy function that removes the artifical triple disulfide
2090 C bond the soubroutine is located in ssMD.F
2091                   evdw=evdw+evdwij
2092                   if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)')
2093      &                        'evdw',i,j,evdwij,'tss'
2094                 endif!dyn_ss_mask(k)
2095               enddo! k
2096             ELSE
2097               ind=ind+1
2098               itypj=iabs(itype(j))
2099               if (itypj.eq.ntyp1) cycle
2100 c            dscj_inv=dsc_inv(itypj)
2101               dscj_inv=vbld_inv(j+nres)
2102 c            write (iout,*) "j",j,dsc_inv(itypj),dscj_inv,
2103 c     &       1.0d0/vbld(j+nres)
2104 c            write (iout,*) "i",i," j", j," itype",itype(i),itype(j)
2105               sig0ij=sigma(itypi,itypj)
2106               chi1=chi(itypi,itypj)
2107               chi2=chi(itypj,itypi)
2108               chi12=chi1*chi2
2109               chip1=chip(itypi)
2110               chip2=chip(itypj)
2111               chip12=chip1*chip2
2112               alf1=alp(itypi)
2113               alf2=alp(itypj)
2114               alf12=0.5D0*(alf1+alf2)
2115 C For diagnostics only!!!
2116 c           chi1=0.0D0
2117 c           chi2=0.0D0
2118 c           chi12=0.0D0
2119 c           chip1=0.0D0
2120 c           chip2=0.0D0
2121 c           chip12=0.0D0
2122 c           alf1=0.0D0
2123 c           alf2=0.0D0
2124 c           alf12=0.0D0
2125               xj=c(1,nres+j)
2126               yj=c(2,nres+j)
2127               zj=c(3,nres+j)
2128               call to_box(xj,yj,zj)
2129               call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
2130               aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
2131      &          +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
2132               bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
2133      &          +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
2134 c            write (iout,*) "aa bb",aa_lip(itypi,itypj),
2135 c     &       bb_lip(itypi,itypj),aa_aq(itypi,itypj),
2136 c     &       bb_aq(itypi,itypj),aa,bb
2137 c            write (iout,*) (sslipi+sslipj)/2.0d0,
2138 c     &        (2.0d0-sslipi-sslipj)/2.0d0
2139
2140 c      write(iout,*) "tu,", i,j,aa_lip(itypi,itypj),bb_lip(itypi,itypj)
2141 c      if (aa.ne.aa_aq(itypi,itypj)) write(iout,'(2e15.5)')
2142 c     &(aa-aa_aq(itypi,itypj)),(bb-bb_aq(itypi,itypj))
2143 C      if (ssgradlipj.gt.0.0d0) print *,"??WTF??"
2144 C      print *,sslipi,sslipj,bordlipbot,zi,zj
2145               xj=boxshift(xj-xi,boxxsize)
2146               yj=boxshift(yj-yi,boxysize)
2147               zj=boxshift(zj-zi,boxzsize)
2148               dxj=dc_norm(1,nres+j)
2149               dyj=dc_norm(2,nres+j)
2150               dzj=dc_norm(3,nres+j)
2151 C            xj=xj-xi
2152 C            yj=yj-yi
2153 C            zj=zj-zi
2154 c            write (iout,*) "dcnorj",dxi*dxi+dyi*dyi+dzi*dzi
2155 c            write (iout,*) "j",j," dc_norm",
2156 c     &       dc_norm(1,nres+j),dc_norm(2,nres+j),dc_norm(3,nres+j)
2157               rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
2158               rij=dsqrt(rrij)
2159               sss=sscale(1.0d0/rij,r_cut_int)
2160 c            write (iout,'(a7,4f8.3)')
2161 c    &      "ssscale",sss,((1.0d0/rij)/sigma(itypi,itypj)),r_cut,rlamb
2162               if (sss.eq.0.0d0) cycle
2163               sssgrad=sscagrad(1.0d0/rij,r_cut_int)
2164 C Calculate angle-dependent terms of energy and contributions to their
2165 C derivatives.
2166               call sc_angular
2167               sigsq=1.0D0/sigsq
2168               sig=sig0ij*dsqrt(sigsq)
2169               rij_shift=1.0D0/rij-sig+sig0ij
2170 c              if (energy_dec)
2171 c     &        write (iout,*) "rij",1.0d0/rij," rij_shift",rij_shift,
2172 c     &       " sig",sig," sig0ij",sig0ij
2173 c for diagnostics; uncomment
2174 c            rij_shift=1.2*sig0ij
2175 C I hate to put IF's in the loops, but here don't have another choice!!!!
2176               if (rij_shift.le.0.0D0) then
2177                 evdw=1.0D20
2178 cd              write (iout,'(2(a3,i3,2x),17(0pf7.3))')
2179 cd     &        restyp(itypi),i,restyp(itypj),j,
2180 cd     &        rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq)
2181                 return
2182               endif
2183               sigder=-sig*sigsq
2184 c---------------------------------------------------------------
2185               rij_shift=1.0D0/rij_shift
2186               fac=rij_shift**expon
2187 C here to start with
2188 C            if (c(i,3).gt.
2189               faclip=fac
2190               e1=fac*fac*aa
2191               e2=fac*bb
2192               evdwij=eps1*eps2rt*eps3rt*(e1+e2)
2193               eps2der=evdwij*eps3rt
2194               eps3der=evdwij*eps2rt
2195 C       write(63,'(2i3,2e10.3,2f10.5)') i,j,aa,bb, evdwij,
2196 C     &((sslipi+sslipj)/2.0d0+
2197 C     &(2.0d0-sslipi-sslipj)/2.0d0)
2198 c            write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt,
2199 c     &        " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2
2200               evdwij=evdwij*eps2rt*eps3rt
2201               evdw=evdw+evdwij*sss
2202               if (lprn) then
2203                 sigm=dabs(aa/bb)**(1.0D0/6.0D0)
2204                 epsi=bb**2/aa
2205                 write (iout,'(2(a3,i3,2x),17(0pf7.3))')
2206      &           restyp(itypi),i,restyp(itypj),j,
2207      &           epsi,sigm,chi1,chi2,chip1,chip2,
2208      &           eps1,eps2rt**2,eps3rt**2,sig,sig0ij,
2209      &           om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
2210      &           evdwij
2211               endif
2212
2213               if (energy_dec) write (iout,'(a,2i5,4f10.5,e15.5)')
2214      &          'r sss evdw',i,j,1.0d0/rij,sss,sslipi,sslipj,evdwij
2215
2216 C Calculate gradient components.
2217               e1=e1*eps1*eps2rt**2*eps3rt**2
2218               fac=-expon*(e1+evdwij)*rij_shift
2219               sigder=fac*sigder
2220               fac=rij*fac
2221 c            print '(2i4,6f8.4)',i,j,sss,sssgrad*
2222 c     &      evdwij,fac,sigma(itypi,itypj),expon
2223               fac=fac+evdwij*sssgrad/sss*rij
2224 c            fac=0.0d0
2225 C Calculate the radial part of the gradient
2226               gg_lipi(3)=eps1*(eps2rt*eps2rt)
2227      &          *(eps3rt*eps3rt)*sss/2.0d0*(faclip*faclip*
2228      &           (aa_lip(itypi,itypj)-aa_aq(itypi,itypj))
2229      &          +faclip*(bb_lip(itypi,itypj)-bb_aq(itypi,itypj)))
2230               gg_lipj(3)=ssgradlipj*gg_lipi(3)
2231               gg_lipi(3)=gg_lipi(3)*ssgradlipi
2232 C            gg_lipi(3)=0.0d0
2233 C            gg_lipj(3)=0.0d0
2234               gg(1)=xj*fac
2235               gg(2)=yj*fac
2236               gg(3)=zj*fac
2237 C Calculate angular part of the gradient.
2238 c            call sc_grad_scale(sss)
2239               call sc_grad
2240             ENDIF    ! dyn_ss
2241 c          enddo      ! j
2242 c        enddo        ! iint
2243       enddo          ! i
2244 C      enddo          ! zshift
2245 C      enddo          ! yshift
2246 C      enddo          ! xshift
2247 c      write (iout,*) "Number of loop steps in EGB:",ind
2248 cccc      energy_dec=.false.
2249       return
2250       end
2251 C-----------------------------------------------------------------------------
2252       subroutine egbv(evdw)
2253 C
2254 C This subroutine calculates the interaction energy of nonbonded side chains
2255 C assuming the Gay-Berne-Vorobjev potential of interaction.
2256 C
2257       implicit none
2258       include 'DIMENSIONS'
2259       include 'COMMON.GEO'
2260       include 'COMMON.VAR'
2261       include 'COMMON.LOCAL'
2262       include 'COMMON.CHAIN'
2263       include 'COMMON.DERIV'
2264       include 'COMMON.NAMES'
2265       include 'COMMON.INTERACT'
2266       include 'COMMON.IOUNITS'
2267       include 'COMMON.CALC'
2268       include 'COMMON.SPLITELE'
2269       double precision boxshift
2270       integer icall
2271       common /srutu/ icall
2272       logical lprn
2273       double precision evdw
2274       integer itypi,itypj,itypi1,iint,ind,ikont
2275       double precision eps0ij,epsi,sigm,fac,e1,e2,rrij,r0ij,
2276      & xi,yi,zi,fac_augm,e_augm
2277       double precision fracinbuf,sslipi,evdwij_przed_tri,sig0ij,
2278      & sslipj,ssgradlipj,ssgradlipi,sig,rij_shift,faclip,sssgrad1
2279       double precision dist,sscale,sscagrad,sscagradlip,sscalelip
2280       evdw=0.0D0
2281 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
2282       gg_lipi=0.0d0
2283       gg_lipj=0.0d0
2284       lprn=.false.
2285 c     if (icall.eq.0) lprn=.true.
2286       ind=0
2287 c      do i=iatsc_s,iatsc_e
2288       do ikont=g_listscsc_start,g_listscsc_end
2289         i=newcontlisti(ikont)
2290         j=newcontlistj(ikont)
2291         itypi=iabs(itype(i))
2292         if (itypi.eq.ntyp1) cycle
2293         itypi1=iabs(itype(i+1))
2294         xi=c(1,nres+i)
2295         yi=c(2,nres+i)
2296         zi=c(3,nres+i)
2297         call to_box(xi,yi,zi)
2298 C define scaling factor for lipids
2299
2300 C        if (positi.le.0) positi=positi+boxzsize
2301 C        print *,i
2302 C first for peptide groups
2303 c for each residue check if it is in lipid or lipid water border area
2304         call lipid_layer(xi,yi,zi,sslipi,ssgradlipi)
2305         dxi=dc_norm(1,nres+i)
2306         dyi=dc_norm(2,nres+i)
2307         dzi=dc_norm(3,nres+i)
2308 c        dsci_inv=dsc_inv(itypi)
2309         dsci_inv=vbld_inv(i+nres)
2310 C
2311 C Calculate SC interaction energy.
2312 C
2313 c        do iint=1,nint_gr(i)
2314 c          do j=istart(i,iint),iend(i,iint)
2315             ind=ind+1
2316             itypj=iabs(itype(j))
2317             if (itypj.eq.ntyp1) cycle
2318 c            dscj_inv=dsc_inv(itypj)
2319             dscj_inv=vbld_inv(j+nres)
2320             sig0ij=sigma(itypi,itypj)
2321             r0ij=r0(itypi,itypj)
2322             chi1=chi(itypi,itypj)
2323             chi2=chi(itypj,itypi)
2324             chi12=chi1*chi2
2325             chip1=chip(itypi)
2326             chip2=chip(itypj)
2327             chip12=chip1*chip2
2328             alf1=alp(itypi)
2329             alf2=alp(itypj)
2330             alf12=0.5D0*(alf1+alf2)
2331 C For diagnostics only!!!
2332 c           chi1=0.0D0
2333 c           chi2=0.0D0
2334 c           chi12=0.0D0
2335 c           chip1=0.0D0
2336 c           chip2=0.0D0
2337 c           chip12=0.0D0
2338 c           alf1=0.0D0
2339 c           alf2=0.0D0
2340 c           alf12=0.0D0
2341            xj=c(1,nres+j)
2342            yj=c(2,nres+j)
2343            zj=c(3,nres+j)
2344            call to_box(xj,yj,zj)
2345            call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
2346            aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
2347      &       +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
2348            bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
2349      &       +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
2350 C      if (aa.ne.aa_aq(itypi,itypj)) write(63,'2e10.5')
2351 C     &(aa-aa_aq(itypi,itypj)),(bb-bb_aq(itypi,itypj))
2352 C      write(iout,*) "tu,", i,j,aa,bb,aa_lip(itypi,itypj),sslipi,sslipj
2353            xj=boxshift(xj-xi,boxxsize)
2354            yj=boxshift(yj-yi,boxysize)
2355            zj=boxshift(zj-zi,boxzsize)
2356            dxj=dc_norm(1,nres+j)
2357            dyj=dc_norm(2,nres+j)
2358            dzj=dc_norm(3,nres+j)
2359            rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
2360            rij=dsqrt(rrij)
2361            sss=sscale(1.0d0/rij,r_cut_int)
2362            if (sss.eq.0.0d0) cycle
2363            sssgrad=sscagrad(1.0d0/rij,r_cut_int)
2364 C Calculate angle-dependent terms of energy and contributions to their
2365 C derivatives.
2366            call sc_angular
2367            sigsq=1.0D0/sigsq
2368            sig=sig0ij*dsqrt(sigsq)
2369            rij_shift=1.0D0/rij-sig+r0ij
2370 C I hate to put IF's in the loops, but here don't have another choice!!!!
2371            if (rij_shift.le.0.0D0) then
2372              evdw=1.0D20
2373              return
2374            endif
2375            sigder=-sig*sigsq
2376 c---------------------------------------------------------------
2377            rij_shift=1.0D0/rij_shift
2378            fac=rij_shift**expon
2379            faclip=fac
2380            e1=fac*fac*aa
2381            e2=fac*bb
2382            evdwij=eps1*eps2rt*eps3rt*(e1+e2)
2383            eps2der=evdwij*eps3rt
2384            eps3der=evdwij*eps2rt
2385            fac_augm=rrij**expon
2386            e_augm=augm(itypi,itypj)*fac_augm
2387            evdwij=evdwij*eps2rt*eps3rt
2388            evdw=evdw+evdwij+e_augm
2389            if (lprn) then
2390              sigm=dabs(aa/bb)**(1.0D0/6.0D0)
2391              epsi=bb**2/aa
2392              write (iout,'(2(a3,i3,2x),17(0pf7.3))')
2393      &        restyp(itypi),i,restyp(itypj),j,
2394      &        epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),
2395      &        chi1,chi2,chip1,chip2,
2396      &        eps1,eps2rt**2,eps3rt**2,
2397      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
2398      &        evdwij+e_augm
2399            endif
2400 C Calculate gradient components.
2401            e1=e1*eps1*eps2rt**2*eps3rt**2
2402            fac=-expon*(e1+evdwij)*rij_shift
2403            sigder=fac*sigder
2404            fac=rij*fac-2*expon*rrij*e_augm
2405            fac=fac+(evdwij+e_augm)*sssgrad/sss*rij
2406 C Calculate the radial part of the gradient
2407            gg_lipi(3)=eps1*(eps2rt*eps2rt)
2408      &       *(eps3rt*eps3rt)*sss/2.0d0*(faclip*faclip*
2409      &       (aa_lip(itypi,itypj)-aa_aq(itypi,itypj))
2410      &       +faclip*(bb_lip(itypi,itypj)-bb_aq(itypi,itypj)))
2411            gg_lipj(3)=ssgradlipj*gg_lipi(3)
2412            gg_lipi(3)=gg_lipi(3)*ssgradlipi
2413            gg(1)=xj*fac
2414            gg(2)=yj*fac
2415            gg(3)=zj*fac
2416 C Calculate angular part of the gradient.
2417 c            call sc_grad_scale(sss)
2418            call sc_grad
2419 c          enddo      ! j
2420 c        enddo        ! iint
2421       enddo          ! i
2422       end
2423 C-----------------------------------------------------------------------------
2424       subroutine sc_angular
2425 C Calculate eps1,eps2,eps3,sigma, and parts of their derivatives in om1,om2,
2426 C om12. Called by ebp, egb, and egbv.
2427       implicit none
2428       include 'COMMON.CALC'
2429       include 'COMMON.IOUNITS'
2430       erij(1)=xj*rij
2431       erij(2)=yj*rij
2432       erij(3)=zj*rij
2433       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
2434       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
2435       om12=dxi*dxj+dyi*dyj+dzi*dzj
2436       chiom12=chi12*om12
2437 C Calculate eps1(om12) and its derivative in om12
2438       faceps1=1.0D0-om12*chiom12
2439       faceps1_inv=1.0D0/faceps1
2440       eps1=dsqrt(faceps1_inv)
2441 C Following variable is eps1*deps1/dom12
2442       eps1_om12=faceps1_inv*chiom12
2443 c diagnostics only
2444 c      faceps1_inv=om12
2445 c      eps1=om12
2446 c      eps1_om12=1.0d0
2447 c      write (iout,*) "om12",om12," eps1",eps1
2448 C Calculate sigma(om1,om2,om12) and the derivatives of sigma**2 in om1,om2,
2449 C and om12.
2450       om1om2=om1*om2
2451       chiom1=chi1*om1
2452       chiom2=chi2*om2
2453       facsig=om1*chiom1+om2*chiom2-2.0D0*om1om2*chiom12
2454       sigsq=1.0D0-facsig*faceps1_inv
2455       sigsq_om1=(chiom1-chiom12*om2)*faceps1_inv
2456       sigsq_om2=(chiom2-chiom12*om1)*faceps1_inv
2457       sigsq_om12=-chi12*(om1om2*faceps1-om12*facsig)*faceps1_inv**2
2458 c diagnostics only
2459 c      sigsq=1.0d0
2460 c      sigsq_om1=0.0d0
2461 c      sigsq_om2=0.0d0
2462 c      sigsq_om12=0.0d0
2463 c      write (iout,*) "chiom1",chiom1," chiom2",chiom2," chiom12",chiom12
2464 c      write (iout,*) "faceps1",faceps1," faceps1_inv",faceps1_inv,
2465 c     &    " eps1",eps1
2466 C Calculate eps2 and its derivatives in om1, om2, and om12.
2467       chipom1=chip1*om1
2468       chipom2=chip2*om2
2469       chipom12=chip12*om12
2470       facp=1.0D0-om12*chipom12
2471       facp_inv=1.0D0/facp
2472       facp1=om1*chipom1+om2*chipom2-2.0D0*om1om2*chipom12
2473 c      write (iout,*) "chipom1",chipom1," chipom2",chipom2,
2474 c     &  " chipom12",chipom12," facp",facp," facp_inv",facp_inv
2475 C Following variable is the square root of eps2
2476       eps2rt=1.0D0-facp1*facp_inv
2477 C Following three variables are the derivatives of the square root of eps
2478 C in om1, om2, and om12.
2479       eps2rt_om1=-4.0D0*(chipom1-chipom12*om2)*facp_inv
2480       eps2rt_om2=-4.0D0*(chipom2-chipom12*om1)*facp_inv
2481       eps2rt_om12=4.0D0*chip12*(om1om2*facp-om12*facp1)*facp_inv**2
2482 C Evaluate the "asymmetric" factor in the VDW constant, eps3
2483       eps3rt=1.0D0-alf1*om1+alf2*om2-alf12*om12
2484 c      write (iout,*) "eps2rt",eps2rt," eps3rt",eps3rt
2485 c      write (iout,*) "eps2rt_om1",eps2rt_om1," eps2rt_om2",eps2rt_om2,
2486 c     &  " eps2rt_om12",eps2rt_om12
2487 C Calculate whole angle-dependent part of epsilon and contributions
2488 C to its derivatives
2489       return
2490       end
2491 C----------------------------------------------------------------------------
2492       subroutine sc_grad
2493       implicit real*8 (a-h,o-z)
2494       include 'DIMENSIONS'
2495       include 'COMMON.CHAIN'
2496       include 'COMMON.DERIV'
2497       include 'COMMON.CALC'
2498       include 'COMMON.IOUNITS'
2499       double precision dcosom1(3),dcosom2(3)
2500 cc      print *,'sss=',sss
2501       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
2502       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
2503       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12
2504      &     -2.0D0*alf12*eps3der+sigder*sigsq_om12
2505 c diagnostics only
2506 c      eom1=0.0d0
2507 c      eom2=0.0d0
2508 c      eom12=evdwij*eps1_om12
2509 c end diagnostics
2510 c      write (iout,*) "eps2der",eps2der," eps3der",eps3der,
2511 c     &  " sigder",sigder
2512 c      write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12
2513 c      write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12
2514       do k=1,3
2515         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
2516         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
2517       enddo
2518       do k=1,3
2519         gg(k)=(gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k))*sss
2520       enddo
2521 c      write (iout,*) "gg",(gg(k),k=1,3)
2522       do k=1,3
2523         gvdwx(k,i)=gvdwx(k,i)-gg(k)+gg_lipi(k)
2524      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
2525      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv*sss
2526         gvdwx(k,j)=gvdwx(k,j)+gg(k)+gg_lipj(k)
2527      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
2528      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv*sss
2529 c        write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
2530 c     &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
2531 c        write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
2532 c     &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
2533       enddo
2534 C
2535 C Calculate the components of the gradient in DC and X
2536 C
2537 cgrad      do k=i,j-1
2538 cgrad        do l=1,3
2539 cgrad          gvdwc(l,k)=gvdwc(l,k)+gg(l)
2540 cgrad        enddo
2541 cgrad      enddo
2542       do l=1,3
2543         gvdwc(l,i)=gvdwc(l,i)-gg(l)+gg_lipi(l)
2544         gvdwc(l,j)=gvdwc(l,j)+gg(l)+gg_lipj(l)
2545       enddo
2546       return
2547       end
2548 C-----------------------------------------------------------------------
2549       subroutine e_softsphere(evdw)
2550 C
2551 C This subroutine calculates the interaction energy of nonbonded side chains
2552 C assuming the LJ potential of interaction.
2553 C
2554       implicit real*8 (a-h,o-z)
2555       include 'DIMENSIONS'
2556       parameter (accur=1.0d-10)
2557       include 'COMMON.GEO'
2558       include 'COMMON.VAR'
2559       include 'COMMON.LOCAL'
2560       include 'COMMON.CHAIN'
2561       include 'COMMON.DERIV'
2562       include 'COMMON.INTERACT'
2563       include 'COMMON.TORSION'
2564       include 'COMMON.SBRIDGE'
2565       include 'COMMON.NAMES'
2566       include 'COMMON.IOUNITS'
2567 c      include 'COMMON.CONTACTS'
2568       dimension gg(3)
2569       double precision boxshift
2570 cd    print *,'Entering Esoft_sphere nnt=',nnt,' nct=',nct
2571       evdw=0.0D0
2572 c      do i=iatsc_s,iatsc_e
2573       do ikont=g_listscsc_start,g_listscsc_end
2574         i=newcontlisti(ikont)
2575         j=newcontlistj(ikont)
2576         itypi=iabs(itype(i))
2577         if (itypi.eq.ntyp1) cycle
2578         itypi1=iabs(itype(i+1))
2579         xi=c(1,nres+i)
2580         yi=c(2,nres+i)
2581         zi=c(3,nres+i)
2582         call to_box(xi,yi,zi)
2583 C
2584 C Calculate SC interaction energy.
2585 C
2586 c        do iint=1,nint_gr(i)
2587 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
2588 cd   &                  'iend=',iend(i,iint)
2589 c          do j=istart(i,iint),iend(i,iint)
2590             itypj=iabs(itype(j))
2591             if (itypj.eq.ntyp1) cycle
2592             xj=boxshift(c(1,nres+j)-xi,boxxsize)
2593             yj=boxshift(c(2,nres+j)-yi,boxysize)
2594             zj=boxshift(c(3,nres+j)-zi,boxzsize)
2595             rij=xj*xj+yj*yj+zj*zj
2596 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
2597             r0ij=r0(itypi,itypj)
2598             r0ijsq=r0ij*r0ij
2599 c            print *,i,j,r0ij,dsqrt(rij)
2600             if (rij.lt.r0ijsq) then
2601               evdwij=0.25d0*(rij-r0ijsq)**2
2602               fac=rij-r0ijsq
2603             else
2604               evdwij=0.0d0
2605               fac=0.0d0
2606             endif
2607             evdw=evdw+evdwij
2608 C
2609 C Calculate the components of the gradient in DC and X
2610 C
2611             gg(1)=xj*fac
2612             gg(2)=yj*fac
2613             gg(3)=zj*fac
2614             do k=1,3
2615               gvdwx(k,i)=gvdwx(k,i)-gg(k)
2616               gvdwx(k,j)=gvdwx(k,j)+gg(k)
2617               gvdwc(k,i)=gvdwc(k,i)-gg(k)
2618               gvdwc(k,j)=gvdwc(k,j)+gg(k)
2619             enddo
2620 cgrad            do k=i,j-1
2621 cgrad              do l=1,3
2622 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
2623 cgrad              enddo
2624 cgrad            enddo
2625 c          enddo ! j
2626 c        enddo ! iint
2627       enddo ! i
2628       return
2629       end
2630 C--------------------------------------------------------------------------
2631       subroutine eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,
2632      &              eello_turn4)
2633 C
2634 C Soft-sphere potential of p-p interaction
2635 C
2636       implicit real*8 (a-h,o-z)
2637       include 'DIMENSIONS'
2638       include 'COMMON.CONTROL'
2639       include 'COMMON.IOUNITS'
2640       include 'COMMON.GEO'
2641       include 'COMMON.VAR'
2642       include 'COMMON.LOCAL'
2643       include 'COMMON.CHAIN'
2644       include 'COMMON.DERIV'
2645       include 'COMMON.INTERACT'
2646 c      include 'COMMON.CONTACTS'
2647       include 'COMMON.TORSION'
2648       include 'COMMON.VECTORS'
2649       include 'COMMON.FFIELD'
2650       dimension ggg(3)
2651       double precision boxshift
2652 C      write(iout,*) 'In EELEC_soft_sphere'
2653       ees=0.0D0
2654       evdw1=0.0D0
2655       eel_loc=0.0d0
2656       eello_turn3=0.0d0
2657       eello_turn4=0.0d0
2658       ind=0
2659       do i=iatel_s,iatel_e
2660         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
2661         dxi=dc(1,i)
2662         dyi=dc(2,i)
2663         dzi=dc(3,i)
2664         xmedi=c(1,i)+0.5d0*dxi
2665         ymedi=c(2,i)+0.5d0*dyi
2666         zmedi=c(3,i)+0.5d0*dzi
2667         call to_box(xmedi,ymedi,zmedi)
2668         num_conti=0
2669 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
2670         do j=ielstart(i),ielend(i)
2671           if (itype(j).eq.ntyp1 .or. itype(j+1).eq.ntyp1) cycle
2672           ind=ind+1
2673           iteli=itel(i)
2674           itelj=itel(j)
2675           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
2676           r0ij=rpp(iteli,itelj)
2677           r0ijsq=r0ij*r0ij
2678           dxj=dc(1,j)
2679           dyj=dc(2,j)
2680           dzj=dc(3,j)
2681           xj=c(1,j)+0.5D0*dxj
2682           yj=c(2,j)+0.5D0*dyj
2683           zj=c(3,j)+0.5D0*dzj
2684           call to_box(xj,yj,zj)
2685           xj=boxshift(xj-xmedi,boxxsize)
2686           yj=boxshift(yj-ymedi,boxysize)
2687           zj=boxshift(zj-zmedi,boxzsize)
2688           rij=xj*xj+yj*yj+zj*zj
2689             sss=sscale(sqrt(rij),r_cut_int)
2690             sssgrad=sscagrad(sqrt(rij),r_cut_int)
2691           if (rij.lt.r0ijsq) then
2692             evdw1ij=0.25d0*(rij-r0ijsq)**2
2693             fac=rij-r0ijsq
2694           else
2695             evdw1ij=0.0d0
2696             fac=0.0d0
2697           endif
2698           evdw1=evdw1+evdw1ij*sss
2699 C
2700 C Calculate contributions to the Cartesian gradient.
2701 C
2702           ggg(1)=fac*xj*sssgrad
2703           ggg(2)=fac*yj*sssgrad
2704           ggg(3)=fac*zj*sssgrad
2705           do k=1,3
2706             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
2707             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
2708           enddo
2709 *
2710 * Loop over residues i+1 thru j-1.
2711 *
2712 cgrad          do k=i+1,j-1
2713 cgrad            do l=1,3
2714 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
2715 cgrad            enddo
2716 cgrad          enddo
2717         enddo ! j
2718       enddo   ! i
2719 cgrad      do i=nnt,nct-1
2720 cgrad        do k=1,3
2721 cgrad          gelc(k,i)=gelc(k,i)+0.5d0*gelc(k,i)
2722 cgrad        enddo
2723 cgrad        do j=i+1,nct-1
2724 cgrad          do k=1,3
2725 cgrad            gelc(k,i)=gelc(k,i)+gelc(k,j)
2726 cgrad          enddo
2727 cgrad        enddo
2728 cgrad      enddo
2729       return
2730       end
2731 c------------------------------------------------------------------------------
2732       subroutine vec_and_deriv
2733       implicit real*8 (a-h,o-z)
2734       include 'DIMENSIONS'
2735 #ifdef MPI
2736       include 'mpif.h'
2737 #endif
2738       include 'COMMON.IOUNITS'
2739       include 'COMMON.GEO'
2740       include 'COMMON.VAR'
2741       include 'COMMON.LOCAL'
2742       include 'COMMON.CHAIN'
2743       include 'COMMON.VECTORS'
2744       include 'COMMON.SETUP'
2745       include 'COMMON.TIME1'
2746       dimension uyder(3,3,2),uzder(3,3,2),vbld_inv_temp(2)
2747 C Compute the local reference systems. For reference system (i), the
2748 C X-axis points from CA(i) to CA(i+1), the Y axis is in the
2749 C CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
2750 #ifdef PARVEC
2751       do i=ivec_start,ivec_end
2752 #else
2753       do i=1,nres-1
2754 #endif
2755           if (i.eq.nres-1) then
2756 C Case of the last full residue
2757 C Compute the Z-axis
2758             call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
2759             costh=dcos(pi-theta(nres))
2760             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2761             do k=1,3
2762               uz(k,i)=fac*uz(k,i)
2763             enddo
2764 C Compute the derivatives of uz
2765             uzder(1,1,1)= 0.0d0
2766             uzder(2,1,1)=-dc_norm(3,i-1)
2767             uzder(3,1,1)= dc_norm(2,i-1)
2768             uzder(1,2,1)= dc_norm(3,i-1)
2769             uzder(2,2,1)= 0.0d0
2770             uzder(3,2,1)=-dc_norm(1,i-1)
2771             uzder(1,3,1)=-dc_norm(2,i-1)
2772             uzder(2,3,1)= dc_norm(1,i-1)
2773             uzder(3,3,1)= 0.0d0
2774             uzder(1,1,2)= 0.0d0
2775             uzder(2,1,2)= dc_norm(3,i)
2776             uzder(3,1,2)=-dc_norm(2,i)
2777             uzder(1,2,2)=-dc_norm(3,i)
2778             uzder(2,2,2)= 0.0d0
2779             uzder(3,2,2)= dc_norm(1,i)
2780             uzder(1,3,2)= dc_norm(2,i)
2781             uzder(2,3,2)=-dc_norm(1,i)
2782             uzder(3,3,2)= 0.0d0
2783 C Compute the Y-axis
2784             facy=fac
2785             do k=1,3
2786               uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
2787             enddo
2788 C Compute the derivatives of uy
2789             do j=1,3
2790               do k=1,3
2791                 uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i)
2792      &                        -dc_norm(k,i)*dc_norm(j,i-1)
2793                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2794               enddo
2795               uyder(j,j,1)=uyder(j,j,1)-costh
2796               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2797             enddo
2798             do j=1,2
2799               do k=1,3
2800                 do l=1,3
2801                   uygrad(l,k,j,i)=uyder(l,k,j)
2802                   uzgrad(l,k,j,i)=uzder(l,k,j)
2803                 enddo
2804               enddo
2805             enddo
2806             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2807             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2808             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2809             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2810           else
2811 C Other residues
2812 C Compute the Z-axis
2813             call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
2814             costh=dcos(pi-theta(i+2))
2815             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2816             do k=1,3
2817               uz(k,i)=fac*uz(k,i)
2818             enddo
2819 C Compute the derivatives of uz
2820             uzder(1,1,1)= 0.0d0
2821             uzder(2,1,1)=-dc_norm(3,i+1)
2822             uzder(3,1,1)= dc_norm(2,i+1)
2823             uzder(1,2,1)= dc_norm(3,i+1)
2824             uzder(2,2,1)= 0.0d0
2825             uzder(3,2,1)=-dc_norm(1,i+1)
2826             uzder(1,3,1)=-dc_norm(2,i+1)
2827             uzder(2,3,1)= dc_norm(1,i+1)
2828             uzder(3,3,1)= 0.0d0
2829             uzder(1,1,2)= 0.0d0
2830             uzder(2,1,2)= dc_norm(3,i)
2831             uzder(3,1,2)=-dc_norm(2,i)
2832             uzder(1,2,2)=-dc_norm(3,i)
2833             uzder(2,2,2)= 0.0d0
2834             uzder(3,2,2)= dc_norm(1,i)
2835             uzder(1,3,2)= dc_norm(2,i)
2836             uzder(2,3,2)=-dc_norm(1,i)
2837             uzder(3,3,2)= 0.0d0
2838 C Compute the Y-axis
2839             facy=fac
2840             do k=1,3
2841               uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
2842             enddo
2843 C Compute the derivatives of uy
2844             do j=1,3
2845               do k=1,3
2846                 uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i)
2847      &                        -dc_norm(k,i)*dc_norm(j,i+1)
2848                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2849               enddo
2850               uyder(j,j,1)=uyder(j,j,1)-costh
2851               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2852             enddo
2853             do j=1,2
2854               do k=1,3
2855                 do l=1,3
2856                   uygrad(l,k,j,i)=uyder(l,k,j)
2857                   uzgrad(l,k,j,i)=uzder(l,k,j)
2858                 enddo
2859               enddo
2860             enddo
2861             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2862             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2863             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2864             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2865           endif
2866       enddo
2867       do i=1,nres-1
2868         vbld_inv_temp(1)=vbld_inv(i+1)
2869         if (i.lt.nres-1) then
2870           vbld_inv_temp(2)=vbld_inv(i+2)
2871           else
2872           vbld_inv_temp(2)=vbld_inv(i)
2873           endif
2874         do j=1,2
2875           do k=1,3
2876             do l=1,3
2877               uygrad(l,k,j,i)=vbld_inv_temp(j)*uygrad(l,k,j,i)
2878               uzgrad(l,k,j,i)=vbld_inv_temp(j)*uzgrad(l,k,j,i)
2879             enddo
2880           enddo
2881         enddo
2882       enddo
2883 #if defined(PARVEC) && defined(MPI)
2884       if (nfgtasks1.gt.1) then
2885         time00=MPI_Wtime()
2886 c        print *,"Processor",fg_rank1,kolor1," ivec_start",ivec_start,
2887 c     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks1-1),
2888 c     &   " ivec_count",(ivec_count(i),i=0,nfgtasks1-1)
2889         call MPI_Allgatherv(uy(1,ivec_start),ivec_count(fg_rank1),
2890      &   MPI_UYZ,uy(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
2891      &   FG_COMM1,IERR)
2892         call MPI_Allgatherv(uz(1,ivec_start),ivec_count(fg_rank1),
2893      &   MPI_UYZ,uz(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
2894      &   FG_COMM1,IERR)
2895         call MPI_Allgatherv(uygrad(1,1,1,ivec_start),
2896      &   ivec_count(fg_rank1),MPI_UYZGRAD,uygrad(1,1,1,1),ivec_count(0),
2897      &   ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2898         call MPI_Allgatherv(uzgrad(1,1,1,ivec_start),
2899      &   ivec_count(fg_rank1),MPI_UYZGRAD,uzgrad(1,1,1,1),ivec_count(0),
2900      &   ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2901         time_gather=time_gather+MPI_Wtime()-time00
2902       endif
2903 #endif
2904 #ifdef DEBUG
2905       if (fg_rank.eq.0) then
2906         write (iout,*) "Arrays UY and UZ"
2907         do i=1,nres-1
2908           write (iout,'(i5,3f10.5,5x,3f10.5)') i,(uy(k,i),k=1,3),
2909      &     (uz(k,i),k=1,3)
2910         enddo
2911       endif
2912 #endif
2913       return
2914       end
2915 C--------------------------------------------------------------------------
2916       subroutine set_matrices
2917       implicit real*8 (a-h,o-z)
2918       include 'DIMENSIONS'
2919 #ifdef MPI
2920       include "mpif.h"
2921       include "COMMON.SETUP"
2922       integer IERR
2923       integer status(MPI_STATUS_SIZE)
2924 #endif
2925       include 'COMMON.IOUNITS'
2926       include 'COMMON.GEO'
2927       include 'COMMON.VAR'
2928       include 'COMMON.LOCAL'
2929       include 'COMMON.CHAIN'
2930       include 'COMMON.DERIV'
2931       include 'COMMON.INTERACT'
2932       include 'COMMON.CORRMAT'
2933       include 'COMMON.TORSION'
2934       include 'COMMON.VECTORS'
2935       include 'COMMON.FFIELD'
2936       double precision auxvec(2),auxmat(2,2)
2937 C
2938 C Compute the virtual-bond-torsional-angle dependent quantities needed
2939 C to calculate the el-loc multibody terms of various order.
2940 C
2941 c      write(iout,*) 'nphi=',nphi,nres
2942 c      write(iout,*) "itype2loc",itype2loc
2943 #ifdef PARMAT
2944       do i=ivec_start+2,ivec_end+2
2945 #else
2946       do i=3,nres+1
2947 #endif
2948         ii=ireschain(i-2)
2949 c        write (iout,*) "i",i,i-2," ii",ii
2950         if (ii.eq.0) cycle
2951         innt=chain_border(1,ii)
2952         inct=chain_border(2,ii)
2953 c        write (iout,*) "i",i,i-2," ii",ii," innt",innt," inct",inct
2954 c        if (i.gt. nnt+2 .and. i.lt.nct+2) then
2955         if (i.gt. innt+2 .and. i.lt.inct+2) then
2956           iti = itype2loc(itype(i-2))
2957         else
2958           iti=nloctyp
2959         endif
2960 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2961         if (i.gt. innt+1 .and. i.lt.inct+1) then
2962           iti1 = itype2loc(itype(i-1))
2963         else
2964           iti1=nloctyp
2965         endif
2966 c        write(iout,*),"i",i,i-2," iti",itype(i-2),iti,
2967 c     &  " iti1",itype(i-1),iti1
2968 #ifdef NEWCORR
2969         cost1=dcos(theta(i-1))
2970         sint1=dsin(theta(i-1))
2971         sint1sq=sint1*sint1
2972         sint1cub=sint1sq*sint1
2973         sint1cost1=2*sint1*cost1
2974 c        write (iout,*) "bnew1",i,iti
2975 c        write (iout,*) (bnew1(k,1,iti),k=1,3)
2976 c        write (iout,*) (bnew1(k,2,iti),k=1,3)
2977 c        write (iout,*) "bnew2",i,iti
2978 c        write (iout,*) (bnew2(k,1,iti),k=1,3)
2979 c        write (iout,*) (bnew2(k,2,iti),k=1,3)
2980         do k=1,2
2981           b1k=bnew1(1,k,iti)+(bnew1(2,k,iti)+bnew1(3,k,iti)*cost1)*cost1
2982           b1(k,i-2)=sint1*b1k
2983           gtb1(k,i-2)=cost1*b1k-sint1sq*
2984      &              (bnew1(2,k,iti)+2*bnew1(3,k,iti)*cost1)
2985           b2k=bnew2(1,k,iti)+(bnew2(2,k,iti)+bnew2(3,k,iti)*cost1)*cost1
2986           b2(k,i-2)=sint1*b2k
2987           gtb2(k,i-2)=cost1*b2k-sint1sq*
2988      &              (bnew2(2,k,iti)+2*bnew2(3,k,iti)*cost1)
2989         enddo
2990         do k=1,2
2991           aux=ccnew(1,k,iti)+(ccnew(2,k,iti)+ccnew(3,k,iti)*cost1)*cost1
2992           cc(1,k,i-2)=sint1sq*aux
2993           gtcc(1,k,i-2)=sint1cost1*aux-sint1cub*
2994      &              (ccnew(2,k,iti)+2*ccnew(3,k,iti)*cost1)
2995           aux=ddnew(1,k,iti)+(ddnew(2,k,iti)+ddnew(3,k,iti)*cost1)*cost1
2996           dd(1,k,i-2)=sint1sq*aux
2997           gtdd(1,k,i-2)=sint1cost1*aux-sint1cub*
2998      &              (ddnew(2,k,iti)+2*ddnew(3,k,iti)*cost1)
2999         enddo
3000         cc(2,1,i-2)=cc(1,2,i-2)
3001         cc(2,2,i-2)=-cc(1,1,i-2)
3002         gtcc(2,1,i-2)=gtcc(1,2,i-2)
3003         gtcc(2,2,i-2)=-gtcc(1,1,i-2)
3004         dd(2,1,i-2)=dd(1,2,i-2)
3005         dd(2,2,i-2)=-dd(1,1,i-2)
3006         gtdd(2,1,i-2)=gtdd(1,2,i-2)
3007         gtdd(2,2,i-2)=-gtdd(1,1,i-2)
3008         do k=1,2
3009           do l=1,2
3010             aux=eenew(1,l,k,iti)+eenew(2,l,k,iti)*cost1
3011             EE(l,k,i-2)=sint1sq*aux
3012             gtEE(l,k,i-2)=sint1cost1*aux-sint1cub*eenew(2,l,k,iti)
3013           enddo
3014         enddo
3015         EE(1,1,i-2)=EE(1,1,i-2)+e0new(1,iti)*cost1
3016         EE(1,2,i-2)=EE(1,2,i-2)+e0new(2,iti)+e0new(3,iti)*cost1
3017         EE(2,1,i-2)=EE(2,1,i-2)+e0new(2,iti)*cost1+e0new(3,iti)
3018         EE(2,2,i-2)=EE(2,2,i-2)-e0new(1,iti)
3019         gtEE(1,1,i-2)=gtEE(1,1,i-2)-e0new(1,iti)*sint1
3020         gtEE(1,2,i-2)=gtEE(1,2,i-2)-e0new(3,iti)*sint1
3021         gtEE(2,1,i-2)=gtEE(2,1,i-2)-e0new(2,iti)*sint1
3022 c        b1tilde(1,i-2)=b1(1,i-2)
3023 c        b1tilde(2,i-2)=-b1(2,i-2)
3024 c        b2tilde(1,i-2)=b2(1,i-2)
3025 c        b2tilde(2,i-2)=-b2(2,i-2)
3026 #ifdef DEBUG
3027         write (iout,*) 'i=',i-2,gtb1(2,i-2),gtb1(1,i-2)
3028         write(iout,*)  'b1=',(b1(k,i-2),k=1,2)
3029         write(iout,*)  'b2=',(b2(k,i-2),k=1,2)
3030         write (iout,*) 'theta=', theta(i-1)
3031 #endif
3032 #else
3033         if (i.gt. innt+2 .and. i.lt.inct+2) then
3034 c        if (i.gt. nnt+2 .and. i.lt.nct+2) then
3035           iti = itype2loc(itype(i-2))
3036         else
3037           iti=nloctyp
3038         endif
3039 c        write (iout,*) "i",i-1," itype",itype(i-2)," iti",iti
3040 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
3041         if (i.gt. nnt+1 .and. i.lt.nct+1) then
3042           iti1 = itype2loc(itype(i-1))
3043         else
3044           iti1=nloctyp
3045         endif
3046         b1(1,i-2)=b(3,iti)
3047         b1(2,i-2)=b(5,iti)
3048         b2(1,i-2)=b(2,iti)
3049         b2(2,i-2)=b(4,iti)
3050         do k=1,2
3051           do l=1,2
3052            CC(k,l,i-2)=ccold(k,l,iti)
3053            DD(k,l,i-2)=ddold(k,l,iti)
3054            EE(k,l,i-2)=eeold(k,l,iti)
3055            gtEE(k,l,i-2)=0.0d0
3056           enddo
3057         enddo
3058 #endif
3059         b1tilde(1,i-2)= b1(1,i-2)
3060         b1tilde(2,i-2)=-b1(2,i-2)
3061         b2tilde(1,i-2)= b2(1,i-2)
3062         b2tilde(2,i-2)=-b2(2,i-2)
3063 c
3064         Ctilde(1,1,i-2)= CC(1,1,i-2)
3065         Ctilde(1,2,i-2)= CC(1,2,i-2)
3066         Ctilde(2,1,i-2)=-CC(2,1,i-2)
3067         Ctilde(2,2,i-2)=-CC(2,2,i-2)
3068 c
3069         Dtilde(1,1,i-2)= DD(1,1,i-2)
3070         Dtilde(1,2,i-2)= DD(1,2,i-2)
3071         Dtilde(2,1,i-2)=-DD(2,1,i-2)
3072         Dtilde(2,2,i-2)=-DD(2,2,i-2)
3073 #ifdef DEBUG
3074         write(iout,*) "i",i," iti",iti
3075         write(iout,*)  'b1=',(b1(k,i-2),k=1,2)
3076         write(iout,*)  'b2=',(b2(k,i-2),k=1,2)
3077 #endif
3078       enddo
3079       mu(:,:nres)=0.0d0
3080 #ifdef PARMAT
3081       do i=ivec_start+2,ivec_end+2
3082 #else
3083       do i=3,nres+1
3084 #endif
3085 c        if (itype(i-1).eq.ntyp1 .and. itype(i).eq.ntyp1) cycle
3086         if (i .lt. nres+1 .and. itype(i-1).lt.ntyp1) then
3087           sin1=dsin(phi(i))
3088           cos1=dcos(phi(i))
3089           sintab(i-2)=sin1
3090           costab(i-2)=cos1
3091           obrot(1,i-2)=cos1
3092           obrot(2,i-2)=sin1
3093           sin2=dsin(2*phi(i))
3094           cos2=dcos(2*phi(i))
3095           sintab2(i-2)=sin2
3096           costab2(i-2)=cos2
3097           obrot2(1,i-2)=cos2
3098           obrot2(2,i-2)=sin2
3099           Ug(1,1,i-2)=-cos1
3100           Ug(1,2,i-2)=-sin1
3101           Ug(2,1,i-2)=-sin1
3102           Ug(2,2,i-2)= cos1
3103           Ug2(1,1,i-2)=-cos2
3104           Ug2(1,2,i-2)=-sin2
3105           Ug2(2,1,i-2)=-sin2
3106           Ug2(2,2,i-2)= cos2
3107         else
3108           costab(i-2)=1.0d0
3109           sintab(i-2)=0.0d0
3110           obrot(1,i-2)=1.0d0
3111           obrot(2,i-2)=0.0d0
3112           obrot2(1,i-2)=0.0d0
3113           obrot2(2,i-2)=0.0d0
3114           Ug(1,1,i-2)=1.0d0
3115           Ug(1,2,i-2)=0.0d0
3116           Ug(2,1,i-2)=0.0d0
3117           Ug(2,2,i-2)=1.0d0
3118           Ug2(1,1,i-2)=0.0d0
3119           Ug2(1,2,i-2)=0.0d0
3120           Ug2(2,1,i-2)=0.0d0
3121           Ug2(2,2,i-2)=0.0d0
3122         endif
3123         if (i .gt. 3) then
3124           obrot_der(1,i-2)=-sin1
3125           obrot_der(2,i-2)= cos1
3126           Ugder(1,1,i-2)= sin1
3127           Ugder(1,2,i-2)=-cos1
3128           Ugder(2,1,i-2)=-cos1
3129           Ugder(2,2,i-2)=-sin1
3130           dwacos2=cos2+cos2
3131           dwasin2=sin2+sin2
3132           obrot2_der(1,i-2)=-dwasin2
3133           obrot2_der(2,i-2)= dwacos2
3134           Ug2der(1,1,i-2)= dwasin2
3135           Ug2der(1,2,i-2)=-dwacos2
3136           Ug2der(2,1,i-2)=-dwacos2
3137           Ug2der(2,2,i-2)=-dwasin2
3138         else
3139           obrot_der(1,i-2)=0.0d0
3140           obrot_der(2,i-2)=0.0d0
3141           Ugder(1,1,i-2)=0.0d0
3142           Ugder(1,2,i-2)=0.0d0
3143           Ugder(2,1,i-2)=0.0d0
3144           Ugder(2,2,i-2)=0.0d0
3145           obrot2_der(1,i-2)=0.0d0
3146           obrot2_der(2,i-2)=0.0d0
3147           Ug2der(1,1,i-2)=0.0d0
3148           Ug2der(1,2,i-2)=0.0d0
3149           Ug2der(2,1,i-2)=0.0d0
3150           Ug2der(2,2,i-2)=0.0d0
3151         endif
3152 c        if (i.gt. iatel_s+2 .and. i.lt.iatel_e+5) then
3153 c        if (i.gt. nnt+2 .and. i.lt.nct+2) then
3154         if (i.gt.nnt+2 .and.i.lt.nct+2) then
3155           iti = itype2loc(itype(i-2))
3156         else
3157           iti=nloctyp
3158         endif
3159 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
3160         if (i.gt. nnt+1 .and. i.lt.nct+1) then
3161           iti1 = itype2loc(itype(i-1))
3162         else
3163           iti1=nloctyp
3164         endif
3165 cd        write (iout,*) '*******i',i,' iti1',iti
3166 cd        write (iout,*) 'b1',b1(:,iti)
3167 cd        write (iout,*) 'b2',b2(:,iti)
3168 cd        write (iout,*) 'Ug',Ug(:,:,i-2)
3169 c        if (i .gt. iatel_s+2) then
3170         if (i .gt. nnt+2) then
3171           call matvec2(Ug(1,1,i-2),b2(1,i-2),Ub2(1,i-2))
3172 #ifdef NEWCORR
3173           call matvec2(Ug(1,1,i-2),gtb2(1,i-2),gUb2(1,i-2))
3174 c          write (iout,*) Ug(1,1,i-2),gtb2(1,i-2),gUb2(1,i-2),"chuj"
3175 #endif
3176 c          write(iout,*) "co jest kurwa", iti, EE(1,1,i),EE(2,1,i),
3177 c     &    EE(1,2,iti),EE(2,2,i)
3178           call matmat2(EE(1,1,i-2),Ug(1,1,i-2),EUg(1,1,i-2))
3179           call matmat2(gtEE(1,1,i-2),Ug(1,1,i-2),gtEUg(1,1,i-2))
3180 c          write(iout,*) "Macierz EUG",
3181 c     &    eug(1,1,i-2),eug(1,2,i-2),eug(2,1,i-2),
3182 c     &    eug(2,2,i-2)
3183 #ifdef FOURBODY
3184           if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
3185      &    then
3186           call matmat2(CC(1,1,i-2),Ug(1,1,i-2),CUg(1,1,i-2))
3187           call matmat2(DD(1,1,i-2),Ug(1,1,i-2),DUg(1,1,i-2))
3188           call matmat2(Dtilde(1,1,i-2),Ug2(1,1,i-2),DtUg2(1,1,i-2))
3189           call matvec2(Ctilde(1,1,i-1),obrot(1,i-2),Ctobr(1,i-2))
3190           call matvec2(Dtilde(1,1,i-2),obrot2(1,i-2),Dtobr2(1,i-2))
3191           endif
3192 #endif
3193         else
3194           do k=1,2
3195             Ub2(k,i-2)=0.0d0
3196             Ctobr(k,i-2)=0.0d0
3197             Dtobr2(k,i-2)=0.0d0
3198             do l=1,2
3199               EUg(l,k,i-2)=0.0d0
3200               CUg(l,k,i-2)=0.0d0
3201               DUg(l,k,i-2)=0.0d0
3202               DtUg2(l,k,i-2)=0.0d0
3203             enddo
3204           enddo
3205         endif
3206         call matvec2(Ugder(1,1,i-2),b2(1,i-2),Ub2der(1,i-2))
3207         call matmat2(EE(1,1,i-2),Ugder(1,1,i-2),EUgder(1,1,i-2))
3208         do k=1,2
3209           muder(k,i-2)=Ub2der(k,i-2)
3210         enddo
3211 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
3212         if (i.gt. nnt+1 .and. i.lt.nct+1) then
3213           if (itype(i-1).le.ntyp) then
3214             iti1 = itype2loc(itype(i-1))
3215           else
3216             iti1=nloctyp
3217           endif
3218         else
3219           iti1=nloctyp
3220         endif
3221         do k=1,2
3222           mu(k,i-2)=Ub2(k,i-2)+b1(k,i-1)
3223 c          mu(k,i-2)=b1(k,i-1)
3224 c          mu(k,i-2)=Ub2(k,i-2)
3225         enddo
3226 #ifdef MUOUT
3227         write (iout,'(2hmu,i3,3f8.1,12f10.5)') i-2,rad2deg*theta(i-1),
3228      &     rad2deg*theta(i),rad2deg*phi(i),mu(1,i-2),mu(2,i-2),
3229      &       -b2(1,i-2),b2(2,i-2),b1(1,i-2),b1(2,i-2),
3230      &       dsqrt(b2(1,i-1)**2+b2(2,i-1)**2)
3231      &      +dsqrt(b1(1,i-1)**2+b1(2,i-1)**2),
3232      &      ((ee(l,k,i-2),l=1,2),k=1,2)
3233 #endif
3234 cd        write (iout,*) 'mu1',mu1(:,i-2)
3235 cd        write (iout,*) 'mu2',mu2(:,i-2)
3236 cd        write (iout,*) 'mu',i-2,mu(:,i-2)
3237 #ifdef FOURBODY
3238         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
3239      &  then
3240         call matmat2(CC(1,1,i-1),Ugder(1,1,i-2),CUgder(1,1,i-2))
3241         call matmat2(DD(1,1,i-2),Ugder(1,1,i-2),DUgder(1,1,i-2))
3242         call matmat2(Dtilde(1,1,i-2),Ug2der(1,1,i-2),DtUg2der(1,1,i-2))
3243         call matvec2(Ctilde(1,1,i-1),obrot_der(1,i-2),Ctobrder(1,i-2))
3244         call matvec2(Dtilde(1,1,i-2),obrot2_der(1,i-2),Dtobr2der(1,i-2))
3245 C Vectors and matrices dependent on a single virtual-bond dihedral.
3246         call matvec2(DD(1,1,i-2),b1tilde(1,i-1),auxvec(1))
3247         call matvec2(Ug2(1,1,i-2),auxvec(1),Ug2Db1t(1,i-2))
3248         call matvec2(Ug2der(1,1,i-2),auxvec(1),Ug2Db1tder(1,i-2))
3249         call matvec2(CC(1,1,i-1),Ub2(1,i-2),CUgb2(1,i-2))
3250         call matvec2(CC(1,1,i-1),Ub2der(1,i-2),CUgb2der(1,i-2))
3251         call matmat2(EUg(1,1,i-2),CC(1,1,i-1),EUgC(1,1,i-2))
3252         call matmat2(EUgder(1,1,i-2),CC(1,1,i-1),EUgCder(1,1,i-2))
3253         call matmat2(EUg(1,1,i-2),DD(1,1,i-1),EUgD(1,1,i-2))
3254         call matmat2(EUgder(1,1,i-2),DD(1,1,i-1),EUgDder(1,1,i-2))
3255         endif
3256 #endif
3257       enddo
3258 #ifdef FOURBODY
3259 C Matrices dependent on two consecutive virtual-bond dihedrals.
3260 C The order of matrices is from left to right.
3261       if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
3262      &then
3263 c      do i=max0(ivec_start,2),ivec_end
3264       do i=2,nres-1
3265         call matmat2(DtUg2(1,1,i-1),EUg(1,1,i),DtUg2EUg(1,1,i))
3266         call matmat2(DtUg2der(1,1,i-1),EUg(1,1,i),DtUg2EUgder(1,1,1,i))
3267         call matmat2(DtUg2(1,1,i-1),EUgder(1,1,i),DtUg2EUgder(1,1,2,i))
3268         call transpose2(DtUg2(1,1,i-1),auxmat(1,1))
3269         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUg(1,1,i))
3270         call matmat2(auxmat(1,1),EUgder(1,1,i),Ug2DtEUgder(1,1,2,i))
3271         call transpose2(DtUg2der(1,1,i-1),auxmat(1,1))
3272         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUgder(1,1,1,i))
3273       enddo
3274       endif
3275 #endif
3276 #if defined(MPI) && defined(PARMAT)
3277 #ifdef DEBUG
3278 c      if (fg_rank.eq.0) then
3279         write (iout,*) "Arrays UG and UGDER before GATHER"
3280         do i=1,nres-1
3281           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3282      &     ((ug(l,k,i),l=1,2),k=1,2),
3283      &     ((ugder(l,k,i),l=1,2),k=1,2)
3284         enddo
3285         write (iout,*) "Arrays UG2 and UG2DER"
3286         do i=1,nres-1
3287           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3288      &     ((ug2(l,k,i),l=1,2),k=1,2),
3289      &     ((ug2der(l,k,i),l=1,2),k=1,2)
3290         enddo
3291         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
3292         do i=1,nres-1
3293           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3294      &     (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
3295      &     (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
3296         enddo
3297         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
3298         do i=1,nres-1
3299           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3300      &     costab(i),sintab(i),costab2(i),sintab2(i)
3301         enddo
3302         write (iout,*) "Array MUDER"
3303         do i=1,nres-1
3304           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
3305         enddo
3306 c      endif
3307 #endif
3308       if (nfgtasks.gt.1) then
3309         time00=MPI_Wtime()
3310 c        write(iout,*)"Processor",fg_rank,kolor," ivec_start",ivec_start,
3311 c     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks-1),
3312 c     &   " ivec_count",(ivec_count(i),i=0,nfgtasks-1)
3313 #ifdef MATGATHER
3314         call MPI_Allgatherv(Ub2(1,ivec_start),ivec_count(fg_rank1),
3315      &   MPI_MU,Ub2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3316      &   FG_COMM1,IERR)
3317         call MPI_Allgatherv(Ub2der(1,ivec_start),ivec_count(fg_rank1),
3318      &   MPI_MU,Ub2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3319      &   FG_COMM1,IERR)
3320         call MPI_Allgatherv(mu(1,ivec_start),ivec_count(fg_rank1),
3321      &   MPI_MU,mu(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3322      &   FG_COMM1,IERR)
3323         call MPI_Allgatherv(muder(1,ivec_start),ivec_count(fg_rank1),
3324      &   MPI_MU,muder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3325      &   FG_COMM1,IERR)
3326         call MPI_Allgatherv(Eug(1,1,ivec_start),ivec_count(fg_rank1),
3327      &   MPI_MAT1,Eug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3328      &   FG_COMM1,IERR)
3329         call MPI_Allgatherv(Eugder(1,1,ivec_start),ivec_count(fg_rank1),
3330      &   MPI_MAT1,Eugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3331      &   FG_COMM1,IERR)
3332         call MPI_Allgatherv(costab(ivec_start),ivec_count(fg_rank1),
3333      &   MPI_DOUBLE_PRECISION,costab(1),ivec_count(0),ivec_displ(0),
3334      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3335         call MPI_Allgatherv(sintab(ivec_start),ivec_count(fg_rank1),
3336      &   MPI_DOUBLE_PRECISION,sintab(1),ivec_count(0),ivec_displ(0),
3337      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3338         call MPI_Allgatherv(costab2(ivec_start),ivec_count(fg_rank1),
3339      &   MPI_DOUBLE_PRECISION,costab2(1),ivec_count(0),ivec_displ(0),
3340      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3341         call MPI_Allgatherv(sintab2(ivec_start),ivec_count(fg_rank1),
3342      &   MPI_DOUBLE_PRECISION,sintab2(1),ivec_count(0),ivec_displ(0),
3343      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3344 #ifdef FOURBODY
3345         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
3346      &  then
3347         call MPI_Allgatherv(Ctobr(1,ivec_start),ivec_count(fg_rank1),
3348      &   MPI_MU,Ctobr(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3349      &   FG_COMM1,IERR)
3350         call MPI_Allgatherv(Ctobrder(1,ivec_start),ivec_count(fg_rank1),
3351      &   MPI_MU,Ctobrder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3352      &   FG_COMM1,IERR)
3353         call MPI_Allgatherv(Dtobr2(1,ivec_start),ivec_count(fg_rank1),
3354      &   MPI_MU,Dtobr2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3355      &   FG_COMM1,IERR)
3356        call MPI_Allgatherv(Dtobr2der(1,ivec_start),ivec_count(fg_rank1),
3357      &   MPI_MU,Dtobr2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3358      &   FG_COMM1,IERR)
3359         call MPI_Allgatherv(Ug2Db1t(1,ivec_start),ivec_count(fg_rank1),
3360      &   MPI_MU,Ug2Db1t(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3361      &   FG_COMM1,IERR)
3362         call MPI_Allgatherv(Ug2Db1tder(1,ivec_start),
3363      &   ivec_count(fg_rank1),
3364      &   MPI_MU,Ug2Db1tder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3365      &   FG_COMM1,IERR)
3366         call MPI_Allgatherv(CUgb2(1,ivec_start),ivec_count(fg_rank1),
3367      &   MPI_MU,CUgb2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3368      &   FG_COMM1,IERR)
3369         call MPI_Allgatherv(CUgb2der(1,ivec_start),ivec_count(fg_rank1),
3370      &   MPI_MU,CUgb2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3371      &   FG_COMM1,IERR)
3372         call MPI_Allgatherv(Cug(1,1,ivec_start),ivec_count(fg_rank1),
3373      &   MPI_MAT1,Cug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3374      &   FG_COMM1,IERR)
3375         call MPI_Allgatherv(Cugder(1,1,ivec_start),ivec_count(fg_rank1),
3376      &   MPI_MAT1,Cugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3377      &   FG_COMM1,IERR)
3378         call MPI_Allgatherv(Dug(1,1,ivec_start),ivec_count(fg_rank1),
3379      &   MPI_MAT1,Dug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3380      &   FG_COMM1,IERR)
3381         call MPI_Allgatherv(Dugder(1,1,ivec_start),ivec_count(fg_rank1),
3382      &   MPI_MAT1,Dugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3383      &   FG_COMM1,IERR)
3384         call MPI_Allgatherv(Dtug2(1,1,ivec_start),ivec_count(fg_rank1),
3385      &   MPI_MAT1,Dtug2(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3386      &   FG_COMM1,IERR)
3387         call MPI_Allgatherv(Dtug2der(1,1,ivec_start),
3388      &   ivec_count(fg_rank1),
3389      &   MPI_MAT1,Dtug2der(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3390      &   FG_COMM1,IERR)
3391         call MPI_Allgatherv(EugC(1,1,ivec_start),ivec_count(fg_rank1),
3392      &   MPI_MAT1,EugC(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3393      &   FG_COMM1,IERR)
3394        call MPI_Allgatherv(EugCder(1,1,ivec_start),ivec_count(fg_rank1),
3395      &   MPI_MAT1,EugCder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3396      &   FG_COMM1,IERR)
3397         call MPI_Allgatherv(EugD(1,1,ivec_start),ivec_count(fg_rank1),
3398      &   MPI_MAT1,EugD(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3399      &   FG_COMM1,IERR)
3400        call MPI_Allgatherv(EugDder(1,1,ivec_start),ivec_count(fg_rank1),
3401      &   MPI_MAT1,EugDder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3402      &   FG_COMM1,IERR)
3403         call MPI_Allgatherv(DtUg2EUg(1,1,ivec_start),
3404      &   ivec_count(fg_rank1),
3405      &   MPI_MAT1,DtUg2EUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3406      &   FG_COMM1,IERR)
3407         call MPI_Allgatherv(Ug2DtEUg(1,1,ivec_start),
3408      &   ivec_count(fg_rank1),
3409      &   MPI_MAT1,Ug2DtEUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3410      &   FG_COMM1,IERR)
3411         call MPI_Allgatherv(DtUg2EUgder(1,1,1,ivec_start),
3412      &   ivec_count(fg_rank1),
3413      &   MPI_MAT2,DtUg2EUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
3414      &   MPI_MAT2,FG_COMM1,IERR)
3415         call MPI_Allgatherv(Ug2DtEUgder(1,1,1,ivec_start),
3416      &   ivec_count(fg_rank1),
3417      &   MPI_MAT2,Ug2DtEUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
3418      &   MPI_MAT2,FG_COMM1,IERR)
3419         endif
3420 #endif
3421 #else
3422 c Passes matrix info through the ring
3423       isend=fg_rank1
3424       irecv=fg_rank1-1
3425       if (irecv.lt.0) irecv=nfgtasks1-1
3426       iprev=irecv
3427       inext=fg_rank1+1
3428       if (inext.ge.nfgtasks1) inext=0
3429       do i=1,nfgtasks1-1
3430 c        write (iout,*) "isend",isend," irecv",irecv
3431 c        call flush(iout)
3432         lensend=lentyp(isend)
3433         lenrecv=lentyp(irecv)
3434 c        write (iout,*) "lensend",lensend," lenrecv",lenrecv
3435 c        call MPI_SENDRECV(ug(1,1,ivec_displ(isend)+1),1,
3436 c     &   MPI_ROTAT1(lensend),inext,2200+isend,
3437 c     &   ug(1,1,ivec_displ(irecv)+1),1,MPI_ROTAT1(lenrecv),
3438 c     &   iprev,2200+irecv,FG_COMM,status,IERR)
3439 c        write (iout,*) "Gather ROTAT1"
3440 c        call flush(iout)
3441 c        call MPI_SENDRECV(obrot(1,ivec_displ(isend)+1),1,
3442 c     &   MPI_ROTAT2(lensend),inext,3300+isend,
3443 c     &   obrot(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
3444 c     &   iprev,3300+irecv,FG_COMM,status,IERR)
3445 c        write (iout,*) "Gather ROTAT2"
3446 c        call flush(iout)
3447         call MPI_SENDRECV(costab(ivec_displ(isend)+1),1,
3448      &   MPI_ROTAT_OLD(lensend),inext,4400+isend,
3449      &   costab(ivec_displ(irecv)+1),1,MPI_ROTAT_OLD(lenrecv),
3450      &   iprev,4400+irecv,FG_COMM,status,IERR)
3451 c        write (iout,*) "Gather ROTAT_OLD"
3452 c        call flush(iout)
3453         call MPI_SENDRECV(mu(1,ivec_displ(isend)+1),1,
3454      &   MPI_PRECOMP11(lensend),inext,5500+isend,
3455      &   mu(1,ivec_displ(irecv)+1),1,MPI_PRECOMP11(lenrecv),
3456      &   iprev,5500+irecv,FG_COMM,status,IERR)
3457 c        write (iout,*) "Gather PRECOMP11"
3458 c        call flush(iout)
3459         call MPI_SENDRECV(Eug(1,1,ivec_displ(isend)+1),1,
3460      &   MPI_PRECOMP12(lensend),inext,6600+isend,
3461      &   Eug(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP12(lenrecv),
3462      &   iprev,6600+irecv,FG_COMM,status,IERR)
3463 c        write (iout,*) "Gather PRECOMP12"
3464 c        call flush(iout)
3465 #ifdef FOURBODY
3466         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
3467      &  then
3468         call MPI_SENDRECV(ug2db1t(1,ivec_displ(isend)+1),1,
3469      &   MPI_ROTAT2(lensend),inext,7700+isend,
3470      &   ug2db1t(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
3471      &   iprev,7700+irecv,FG_COMM,status,IERR)
3472 c        write (iout,*) "Gather PRECOMP21"
3473 c        call flush(iout)
3474         call MPI_SENDRECV(EUgC(1,1,ivec_displ(isend)+1),1,
3475      &   MPI_PRECOMP22(lensend),inext,8800+isend,
3476      &   EUgC(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP22(lenrecv),
3477      &   iprev,8800+irecv,FG_COMM,status,IERR)
3478 c        write (iout,*) "Gather PRECOMP22"
3479 c        call flush(iout)
3480         call MPI_SENDRECV(Ug2DtEUgder(1,1,1,ivec_displ(isend)+1),1,
3481      &   MPI_PRECOMP23(lensend),inext,9900+isend,
3482      &   Ug2DtEUgder(1,1,1,ivec_displ(irecv)+1),1,
3483      &   MPI_PRECOMP23(lenrecv),
3484      &   iprev,9900+irecv,FG_COMM,status,IERR)
3485 #endif
3486 c        write (iout,*) "Gather PRECOMP23"
3487 c        call flush(iout)
3488         endif
3489         isend=irecv
3490         irecv=irecv-1
3491         if (irecv.lt.0) irecv=nfgtasks1-1
3492       enddo
3493 #endif
3494         time_gather=time_gather+MPI_Wtime()-time00
3495       endif
3496 #ifdef DEBUG
3497 c      if (fg_rank.eq.0) then
3498         write (iout,*) "Arrays UG and UGDER"
3499         do i=1,nres-1
3500           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3501      &     ((ug(l,k,i),l=1,2),k=1,2),
3502      &     ((ugder(l,k,i),l=1,2),k=1,2)
3503         enddo
3504         write (iout,*) "Arrays UG2 and UG2DER"
3505         do i=1,nres-1
3506           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3507      &     ((ug2(l,k,i),l=1,2),k=1,2),
3508      &     ((ug2der(l,k,i),l=1,2),k=1,2)
3509         enddo
3510         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
3511         do i=1,nres-1
3512           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3513      &     (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
3514      &     (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
3515         enddo
3516         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
3517         do i=1,nres-1
3518           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3519      &     costab(i),sintab(i),costab2(i),sintab2(i)
3520         enddo
3521         write (iout,*) "Array MUDER"
3522         do i=1,nres-1
3523           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
3524         enddo
3525 c      endif
3526 #endif
3527 #endif
3528 cd      do i=1,nres
3529 cd        iti = itype2loc(itype(i))
3530 cd        write (iout,*) i
3531 cd        do j=1,2
3532 cd        write (iout,'(2f10.5,5x,2f10.5,5x,2f10.5)')
3533 cd     &  (EE(j,k,i),k=1,2),(Ug(j,k,i),k=1,2),(EUg(j,k,i),k=1,2)
3534 cd        enddo
3535 cd      enddo
3536       return
3537       end
3538 C-----------------------------------------------------------------------------
3539       subroutine eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
3540 C
3541 C This subroutine calculates the average interaction energy and its gradient
3542 C in the virtual-bond vectors between non-adjacent peptide groups, based on
3543 C the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
3544 C The potential depends both on the distance of peptide-group centers and on
3545 C the orientation of the CA-CA virtual bonds.
3546 C
3547       implicit real*8 (a-h,o-z)
3548 #ifdef MPI
3549       include 'mpif.h'
3550 #endif
3551       include 'DIMENSIONS'
3552       include 'COMMON.CONTROL'
3553       include 'COMMON.SETUP'
3554       include 'COMMON.IOUNITS'
3555       include 'COMMON.GEO'
3556       include 'COMMON.VAR'
3557       include 'COMMON.LOCAL'
3558       include 'COMMON.CHAIN'
3559       include 'COMMON.DERIV'
3560       include 'COMMON.INTERACT'
3561 #ifdef FOURBODY
3562       include 'COMMON.CONTACTS'
3563       include 'COMMON.CONTMAT'
3564 #endif
3565       include 'COMMON.CORRMAT'
3566       include 'COMMON.TORSION'
3567       include 'COMMON.VECTORS'
3568       include 'COMMON.FFIELD'
3569       include 'COMMON.TIME1'
3570       include 'COMMON.SPLITELE'
3571       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
3572      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
3573       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
3574      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4),gmuij(4)
3575       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3576      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3577      &    num_conti,j1,j2
3578       double precision sslipi,sslipj,ssgradlipi,ssgradlipj
3579       common /lipcalc/ sslipi,sslipj,ssgradlipi,ssgradlipj
3580 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
3581 #ifdef MOMENT
3582       double precision scal_el /1.0d0/
3583 #else
3584       double precision scal_el /0.5d0/
3585 #endif
3586 C 12/13/98
3587 C 13-go grudnia roku pamietnego...
3588       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
3589      &                   0.0d0,1.0d0,0.0d0,
3590      &                   0.0d0,0.0d0,1.0d0/
3591 cd      write(iout,*) 'In EELEC'
3592 cd      do i=1,nloctyp
3593 cd        write(iout,*) 'Type',i
3594 cd        write(iout,*) 'B1',B1(:,i)
3595 cd        write(iout,*) 'B2',B2(:,i)
3596 cd        write(iout,*) 'CC',CC(:,:,i)
3597 cd        write(iout,*) 'DD',DD(:,:,i)
3598 cd        write(iout,*) 'EE',EE(:,:,i)
3599 cd      enddo
3600 cd      call check_vecgrad
3601 cd      stop
3602       if (icheckgrad.eq.1) then
3603         do i=1,nres-1
3604           fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
3605           do k=1,3
3606             dc_norm(k,i)=dc(k,i)*fac
3607           enddo
3608 c          write (iout,*) 'i',i,' fac',fac
3609         enddo
3610       endif
3611       if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
3612      &    .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or.
3613      &    wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
3614 c        call vec_and_deriv
3615 #ifdef TIMING
3616         time01=MPI_Wtime()
3617 #endif
3618         call set_matrices
3619 #ifdef TIMING
3620         time_mat=time_mat+MPI_Wtime()-time01
3621 #endif
3622       endif
3623 cd      do i=1,nres-1
3624 cd        write (iout,*) 'i=',i
3625 cd        do k=1,3
3626 cd        write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
3627 cd        enddo
3628 cd        do k=1,3
3629 cd          write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
3630 cd     &     uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
3631 cd        enddo
3632 cd      enddo
3633       t_eelecij=0.0d0
3634       ees=0.0D0
3635       evdw1=0.0D0
3636       eel_loc=0.0d0
3637       eello_turn3=0.0d0
3638       eello_turn4=0.0d0
3639       ind=0
3640 #ifdef FOURBODY
3641       do i=1,nres
3642         num_cont_hb(i)=0
3643       enddo
3644 #endif
3645 cd      print '(a)','Enter EELEC'
3646 cd      write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
3647       do i=1,nres
3648         gel_loc_loc(i)=0.0d0
3649         gcorr_loc(i)=0.0d0
3650       enddo
3651 c
3652 c
3653 c 9/27/08 AL Split the interaction loop to ensure load balancing of turn terms
3654 C
3655 C Loop over i,i+2 and i,i+3 pairs of the peptide groups
3656 C
3657 C 14/01/2014 TURN3,TUNR4 does no go under periodic boundry condition
3658       do i=iturn3_start,iturn3_end
3659 c        if (i.le.1) cycle
3660 C        write(iout,*) "tu jest i",i
3661         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
3662 C changes suggested by Ana to avoid out of bounds
3663 C Adam: Unnecessary: handled by iturn3_end and iturn3_start
3664 c     & .or.((i+4).gt.nres)
3665 c     & .or.((i-1).le.0)
3666 C end of changes by Ana
3667      &  .or. itype(i+2).eq.ntyp1
3668      &  .or. itype(i+3).eq.ntyp1) cycle
3669 C Adam: Instructions below will switch off existing interactions
3670 c        if(i.gt.1)then
3671 c          if(itype(i-1).eq.ntyp1)cycle
3672 c        end if
3673 c        if(i.LT.nres-3)then
3674 c          if (itype(i+4).eq.ntyp1) cycle
3675 c        end if
3676         dxi=dc(1,i)
3677         dyi=dc(2,i)
3678         dzi=dc(3,i)
3679         dx_normi=dc_norm(1,i)
3680         dy_normi=dc_norm(2,i)
3681         dz_normi=dc_norm(3,i)
3682         xmedi=c(1,i)+0.5d0*dxi
3683         ymedi=c(2,i)+0.5d0*dyi
3684         zmedi=c(3,i)+0.5d0*dzi
3685         call to_box(xmedi,ymedi,zmedi)
3686         call lipid_layer(xmedi,ymedi,zmedi,sslipi,ssgradlipi)
3687         num_conti=0
3688         call eelecij(i,i+2,ees,evdw1,eel_loc)
3689         if (wturn3.gt.0.0d0) call eturn3(i,eello_turn3)
3690 #ifdef FOURBODY
3691         num_cont_hb(i)=num_conti
3692 #endif
3693       enddo
3694       do i=iturn4_start,iturn4_end
3695         if (i.lt.1) cycle
3696         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
3697 C changes suggested by Ana to avoid out of bounds
3698 c     & .or.((i+5).gt.nres)
3699 c     & .or.((i-1).le.0)
3700 C end of changes suggested by Ana
3701      &    .or. itype(i+3).eq.ntyp1
3702      &    .or. itype(i+4).eq.ntyp1
3703 c     &    .or. itype(i+5).eq.ntyp1
3704 c     &    .or. itype(i).eq.ntyp1
3705 c     &    .or. itype(i-1).eq.ntyp1
3706      &                             ) cycle
3707         dxi=dc(1,i)
3708         dyi=dc(2,i)
3709         dzi=dc(3,i)
3710         dx_normi=dc_norm(1,i)
3711         dy_normi=dc_norm(2,i)
3712         dz_normi=dc_norm(3,i)
3713         xmedi=c(1,i)+0.5d0*dxi
3714         ymedi=c(2,i)+0.5d0*dyi
3715         zmedi=c(3,i)+0.5d0*dzi
3716 C Return atom into box, boxxsize is size of box in x dimension
3717 c  194   continue
3718 c        if (xmedi.gt.((0.5d0)*boxxsize)) xmedi=xmedi-boxxsize
3719 c        if (xmedi.lt.((-0.5d0)*boxxsize)) xmedi=xmedi+boxxsize
3720 C Condition for being inside the proper box
3721 c        if ((xmedi.gt.((0.5d0)*boxxsize)).or.
3722 c     &       (xmedi.lt.((-0.5d0)*boxxsize))) then
3723 c        go to 194
3724 c        endif
3725 c  195   continue
3726 c        if (ymedi.gt.((0.5d0)*boxysize)) ymedi=ymedi-boxysize
3727 c        if (ymedi.lt.((-0.5d0)*boxysize)) ymedi=ymedi+boxysize
3728 C Condition for being inside the proper box
3729 c        if ((ymedi.gt.((0.5d0)*boxysize)).or.
3730 c     &       (ymedi.lt.((-0.5d0)*boxysize))) then
3731 c        go to 195
3732 c        endif
3733 c  196   continue
3734 c        if (zmedi.gt.((0.5d0)*boxzsize)) zmedi=zmedi-boxzsize
3735 c        if (zmedi.lt.((-0.5d0)*boxzsize)) zmedi=zmedi+boxzsize
3736 C Condition for being inside the proper box
3737 c        if ((zmedi.gt.((0.5d0)*boxzsize)).or.
3738 c     &       (zmedi.lt.((-0.5d0)*boxzsize))) then
3739 c        go to 196
3740 c        endif
3741         call to_box(xmedi,ymedi,zmedi)
3742         call lipid_layer(xmedi,ymedi,zmedi,sslipi,ssgradlipi)
3743 #ifdef FOURBODY
3744         num_conti=num_cont_hb(i)
3745 #endif
3746 c        write(iout,*) "JESTEM W PETLI"
3747         call eelecij(i,i+3,ees,evdw1,eel_loc)
3748         if (wturn4.gt.0.0d0 .and. itype(i+2).ne.ntyp1)
3749      &   call eturn4(i,eello_turn4)
3750 #ifdef FOURBODY
3751         num_cont_hb(i)=num_conti
3752 #endif
3753       enddo   ! i
3754 C Loop over all neighbouring boxes
3755 C      do xshift=-1,1
3756 C      do yshift=-1,1
3757 C      do zshift=-1,1
3758 c
3759 c Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
3760 c
3761 CTU KURWA
3762 c      do i=iatel_s,iatel_e
3763       do ikont=g_listpp_start,g_listpp_end
3764         i=newcontlistppi(ikont)
3765         j=newcontlistppj(ikont)
3766 C        do i=75,75
3767 c        if (i.le.1) cycle
3768         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
3769 C changes suggested by Ana to avoid out of bounds
3770 c     & .or.((i+2).gt.nres)
3771 c     & .or.((i-1).le.0)
3772 C end of changes by Ana
3773 c     &  .or. itype(i+2).eq.ntyp1
3774 c     &  .or. itype(i-1).eq.ntyp1
3775      &                ) cycle
3776         dxi=dc(1,i)
3777         dyi=dc(2,i)
3778         dzi=dc(3,i)
3779         dx_normi=dc_norm(1,i)
3780         dy_normi=dc_norm(2,i)
3781         dz_normi=dc_norm(3,i)
3782         xmedi=c(1,i)+0.5d0*dxi
3783         ymedi=c(2,i)+0.5d0*dyi
3784         zmedi=c(3,i)+0.5d0*dzi
3785         call to_box(xmedi,ymedi,zmedi)
3786         call lipid_layer(xmedi,ymedi,zmedi,sslipi,ssgradlipi)
3787 C          xmedi=xmedi+xshift*boxxsize
3788 C          ymedi=ymedi+yshift*boxysize
3789 C          zmedi=zmedi+zshift*boxzsize
3790
3791 C Return tom into box, boxxsize is size of box in x dimension
3792 c  164   continue
3793 c        if (xmedi.gt.((xshift+0.5d0)*boxxsize)) xmedi=xmedi-boxxsize
3794 c        if (xmedi.lt.((xshift-0.5d0)*boxxsize)) xmedi=xmedi+boxxsize
3795 C Condition for being inside the proper box
3796 c        if ((xmedi.gt.((xshift+0.5d0)*boxxsize)).or.
3797 c     &       (xmedi.lt.((xshift-0.5d0)*boxxsize))) then
3798 c        go to 164
3799 c        endif
3800 c  165   continue
3801 c        if (ymedi.gt.((yshift+0.5d0)*boxysize)) ymedi=ymedi-boxysize
3802 c        if (ymedi.lt.((yshift-0.5d0)*boxysize)) ymedi=ymedi+boxysize
3803 C Condition for being inside the proper box
3804 c        if ((ymedi.gt.((yshift+0.5d0)*boxysize)).or.
3805 c     &       (ymedi.lt.((yshift-0.5d0)*boxysize))) then
3806 c        go to 165
3807 c        endif
3808 c  166   continue
3809 c        if (zmedi.gt.((zshift+0.5d0)*boxzsize)) zmedi=zmedi-boxzsize
3810 c        if (zmedi.lt.((zshift-0.5d0)*boxzsize)) zmedi=zmedi+boxzsize
3811 cC Condition for being inside the proper box
3812 c        if ((zmedi.gt.((zshift+0.5d0)*boxzsize)).or.
3813 c     &       (zmedi.lt.((zshift-0.5d0)*boxzsize))) then
3814 c        go to 166
3815 c        endif
3816
3817 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
3818 #ifdef FOURBODY
3819         num_conti=num_cont_hb(i)
3820 #endif
3821 C I TU KURWA
3822 c        do j=ielstart(i),ielend(i)
3823 C          do j=16,17
3824 C          write (iout,*) i,j
3825 C         if (j.le.1) cycle
3826         if (itype(j).eq.ntyp1.or. itype(j+1).eq.ntyp1
3827 C changes suggested by Ana to avoid out of bounds
3828 c     & .or.((j+2).gt.nres)
3829 c     & .or.((j-1).le.0)
3830 C end of changes by Ana
3831 c     & .or.itype(j+2).eq.ntyp1
3832 c     & .or.itype(j-1).eq.ntyp1
3833      &) cycle
3834         call eelecij(i,j,ees,evdw1,eel_loc)
3835 c        enddo ! j
3836 #ifdef FOURBODY
3837         num_cont_hb(i)=num_conti
3838 #endif
3839       enddo   ! i
3840 C     enddo   ! zshift
3841 C      enddo   ! yshift
3842 C      enddo   ! xshift
3843
3844 c      write (iout,*) "Number of loop steps in EELEC:",ind
3845 cd      do i=1,nres
3846 cd        write (iout,'(i3,3f10.5,5x,3f10.5)')
3847 cd     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
3848 cd      enddo
3849 c 12/7/99 Adam eello_turn3 will be considered as a separate energy term
3850 ccc      eel_loc=eel_loc+eello_turn3
3851 cd      print *,"Processor",fg_rank," t_eelecij",t_eelecij
3852       return
3853       end
3854 C-------------------------------------------------------------------------------
3855       subroutine eelecij(i,j,ees,evdw1,eel_loc)
3856       implicit none
3857       include 'DIMENSIONS'
3858 #ifdef MPI
3859       include "mpif.h"
3860 #endif
3861       include 'COMMON.CONTROL'
3862       include 'COMMON.IOUNITS'
3863       include 'COMMON.GEO'
3864       include 'COMMON.VAR'
3865       include 'COMMON.LOCAL'
3866       include 'COMMON.CHAIN'
3867       include 'COMMON.DERIV'
3868       include 'COMMON.INTERACT'
3869 #ifdef FOURBODY
3870       include 'COMMON.CONTACTS'
3871       include 'COMMON.CONTMAT'
3872 #endif
3873       include 'COMMON.CORRMAT'
3874       include 'COMMON.TORSION'
3875       include 'COMMON.VECTORS'
3876       include 'COMMON.FFIELD'
3877       include 'COMMON.TIME1'
3878       include 'COMMON.SPLITELE'
3879       include 'COMMON.SHIELD'
3880       double precision ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
3881      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
3882       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
3883      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4),gmuij1(4),gmuji1(4),
3884      &    gmuij2(4),gmuji2(4)
3885       double precision dxi,dyi,dzi
3886       double precision dx_normi,dy_normi,dz_normi,aux
3887       integer j1,j2,lll,num_conti
3888       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3889      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3890      &    num_conti,j1,j2
3891       integer k,i,j,iteli,itelj,kkk,l,kkll,m,isubchap,ilist,iresshield
3892       double precision ael6i,rrmij,rmij,r0ij,fcont,fprimcont,ees0tmp
3893       double precision ees,evdw1,eel_loc,aaa,bbb,ael3i
3894       double precision dxj,dyj,dzj,dx_normj,dy_normj,dz_normj,xj,yj,zj,
3895      &  rij,r3ij,r6ij,cosa,cosb,cosg,fac,ev1,ev2,fac3,fac4,
3896      &  evdwij,el1,el2,eesij,ees0ij,facvdw,facel,fac1,ecosa,
3897      &  ecosb,ecosg,ury,urz,vry,vrz,facr,a22der,a23der,a32der,
3898      &  a33der,eel_loc_ij,cosa4,wij,cosbg1,cosbg2,ees0pij,
3899      &  ees0pij1,ees0mij,ees0mij1,fac3p,ees0mijp,ees0pijp,
3900      &  ecosa1,ecosb1,ecosg1,ecosa2,ecosb2,ecosg2,ecosap,ecosbp,
3901      &  ecosgp,ecosam,ecosbm,ecosgm,ghalf,rlocshield
3902       double precision a22,a23,a32,a33,geel_loc_ij,geel_loc_ji
3903       double precision xmedi,ymedi,zmedi
3904       double precision sscale,sscagrad,scalar
3905       double precision boxshift
3906       double precision sslipi,sslipj,ssgradlipi,ssgradlipj,faclipij,
3907      & faclipij2
3908       common /lipcalc/ sslipi,sslipj,ssgradlipi,ssgradlipj,faclipij
3909 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
3910 #ifdef MOMENT
3911       double precision scal_el /1.0d0/
3912 #else
3913       double precision scal_el /0.5d0/
3914 #endif
3915 C 12/13/98
3916 C 13-go grudnia roku pamietnego...
3917       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
3918      &                   0.0d0,1.0d0,0.0d0,
3919      &                   0.0d0,0.0d0,1.0d0/
3920 c          time00=MPI_Wtime()
3921 cd      write (iout,*) "eelecij",i,j
3922 c          ind=ind+1
3923 c          write (iout,*) "lipscale",lipscale
3924           iteli=itel(i)
3925           itelj=itel(j)
3926           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
3927           aaa=app(iteli,itelj)
3928           bbb=bpp(iteli,itelj)
3929           ael6i=ael6(iteli,itelj)
3930           ael3i=ael3(iteli,itelj)
3931           dxj=dc(1,j)
3932           dyj=dc(2,j)
3933           dzj=dc(3,j)
3934           dx_normj=dc_norm(1,j)
3935           dy_normj=dc_norm(2,j)
3936           dz_normj=dc_norm(3,j)
3937 C          xj=c(1,j)+0.5D0*dxj-xmedi
3938 C          yj=c(2,j)+0.5D0*dyj-ymedi
3939 C          zj=c(3,j)+0.5D0*dzj-zmedi
3940           xj=c(1,j)+0.5D0*dxj
3941           yj=c(2,j)+0.5D0*dyj
3942           zj=c(3,j)+0.5D0*dzj
3943           call to_box(xj,yj,zj)
3944           call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
3945           faclipij=(sslipi+sslipj)/2.0d0*lipscale+1.0d0
3946           faclipij2=(sslipi+sslipj)/2.0d0*lipscale**2+1.0d0
3947           xj=boxshift(xj-xmedi,boxxsize)
3948           yj=boxshift(yj-ymedi,boxysize)
3949           zj=boxshift(zj-zmedi,boxzsize)
3950 C        if ((i+3).lt.j) then !this condition keeps for turn3 and turn4 not subject to PBC
3951 c  174   continue
3952           rij=xj*xj+yj*yj+zj*zj
3953
3954           sss=sscale(dsqrt(rij),r_cut_int)
3955           if (sss.eq.0.0d0) return
3956           sssgrad=sscagrad(dsqrt(rij),r_cut_int)
3957 c            if (sss.gt.0.0d0) then
3958           rrmij=1.0D0/rij
3959           rij=dsqrt(rij)
3960           rmij=1.0D0/rij
3961           r3ij=rrmij*rmij
3962           r6ij=r3ij*r3ij
3963           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
3964           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
3965           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
3966           fac=cosa-3.0D0*cosb*cosg
3967           ev1=aaa*r6ij*r6ij
3968 c 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
3969           if (j.eq.i+2) ev1=scal_el*ev1
3970           ev2=bbb*r6ij
3971           fac3=ael6i*r6ij
3972           fac4=ael3i*r3ij
3973           evdwij=(ev1+ev2)
3974           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
3975           el2=fac4*fac
3976 C MARYSIA
3977 C          eesij=(el1+el2)
3978 C 12/26/95 - for the evaluation of multi-body H-bonding interactions
3979           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
3980           if (shield_mode.gt.0) then
3981 C          fac_shield(i)=0.4
3982 C          fac_shield(j)=0.6
3983           el1=el1*fac_shield(i)**2*fac_shield(j)**2
3984           el2=el2*fac_shield(i)**2*fac_shield(j)**2
3985           eesij=(el1+el2)
3986           ees=ees+eesij*sss*faclipij2
3987           else
3988           fac_shield(i)=1.0
3989           fac_shield(j)=1.0
3990           eesij=(el1+el2)
3991           ees=ees+eesij*sss*faclipij2
3992           endif
3993           ees=ees
3994           evdw1=evdw1+evdwij*sss*faclipij2
3995 cd          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
3996 cd     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
3997 cd     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
3998 cd     &      xmedi,ymedi,zmedi,xj,yj,zj
3999
4000           if (energy_dec) then
4001             write (iout,'(a6,2i5,0pf7.3,2i5,e11.3,3f10.5)')
4002      &        'evdw1',i,j,evdwij,iteli,itelj,aaa,evdw1,sss,rij
4003             write (iout,'(a6,2i5,0pf7.3,6f8.5)') 'ees',i,j,eesij,
4004      &        fac_shield(i),fac_shield(j),sslipi,sslipj,faclipij,
4005      &        faclipij2
4006           endif
4007
4008 C
4009 C Calculate contributions to the Cartesian gradient.
4010 C
4011 #ifdef SPLITELE
4012           facvdw=-6*rrmij*(ev1+evdwij)*sss
4013           facel=-3*rrmij*(el1+eesij)
4014           fac1=fac
4015           erij(1)=xj*rmij
4016           erij(2)=yj*rmij
4017           erij(3)=zj*rmij
4018
4019 *
4020 * Radial derivatives. First process both termini of the fragment (i,j)
4021 *
4022           aux=(facel*sss+rmij*sssgrad*eesij)*faclipij2
4023           ggg(1)=aux*xj
4024           ggg(2)=aux*yj
4025           ggg(3)=aux*zj
4026           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
4027      &  (shield_mode.gt.0)) then
4028 C          print *,i,j
4029           do ilist=1,ishield_list(i)
4030            iresshield=shield_list(ilist,i)
4031            do k=1,3
4032            rlocshield=grad_shield_side(k,ilist,i)*eesij/fac_shield(i)
4033      &      *2.0
4034            gshieldx(k,iresshield)=gshieldx(k,iresshield)+
4035      &              rlocshield
4036      & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)*2.0
4037             gshieldc(k,iresshield-1)=gshieldc(k,iresshield-1)+rlocshield
4038 C           gshieldc_loc(k,iresshield)=gshieldc_loc(k,iresshield)
4039 C     & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)
4040 C             if (iresshield.gt.i) then
4041 C               do ishi=i+1,iresshield-1
4042 C                gshieldc(k,ishi)=gshieldc(k,ishi)+rlocshield
4043 C     & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)
4044 C
4045 C              enddo
4046 C             else
4047 C               do ishi=iresshield,i
4048 C                gshieldc(k,ishi)=gshieldc(k,ishi)-rlocshield
4049 C     & -grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)
4050 C
4051 C               enddo
4052 C              endif
4053            enddo
4054           enddo
4055           do ilist=1,ishield_list(j)
4056            iresshield=shield_list(ilist,j)
4057            do k=1,3
4058            rlocshield=grad_shield_side(k,ilist,j)*eesij/fac_shield(j)
4059      &     *2.0*sss
4060            gshieldx(k,iresshield)=gshieldx(k,iresshield)+
4061      &              rlocshield
4062      & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)*2.0*sss
4063            gshieldc(k,iresshield-1)=gshieldc(k,iresshield-1)+rlocshield
4064
4065 C     & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
4066 C           gshieldc_loc(k,iresshield)=gshieldc_loc(k,iresshield)
4067 C     & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
4068 C             if (iresshield.gt.j) then
4069 C               do ishi=j+1,iresshield-1
4070 C                gshieldc(k,ishi)=gshieldc(k,ishi)+rlocshield
4071 C     & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
4072 C
4073 C               enddo
4074 C            else
4075 C               do ishi=iresshield,j
4076 C                gshieldc(k,ishi)=gshieldc(k,ishi)-rlocshield
4077 C     & -grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
4078 C               enddo
4079 C              endif
4080            enddo
4081           enddo
4082
4083           do k=1,3
4084             gshieldc(k,i)=gshieldc(k,i)+
4085      &              grad_shield(k,i)*eesij/fac_shield(i)*2.0*sss
4086             gshieldc(k,j)=gshieldc(k,j)+
4087      &              grad_shield(k,j)*eesij/fac_shield(j)*2.0*sss
4088             gshieldc(k,i-1)=gshieldc(k,i-1)+
4089      &              grad_shield(k,i)*eesij/fac_shield(i)*2.0*sss
4090             gshieldc(k,j-1)=gshieldc(k,j-1)+
4091      &              grad_shield(k,j)*eesij/fac_shield(j)*2.0*sss
4092
4093            enddo
4094            endif
4095 c          do k=1,3
4096 c            ghalf=0.5D0*ggg(k)
4097 c            gelc(k,i)=gelc(k,i)+ghalf
4098 c            gelc(k,j)=gelc(k,j)+ghalf
4099 c          enddo
4100 c 9/28/08 AL Gradient compotents will be summed only at the end
4101 C           print *,"before", gelc_long(1,i), gelc_long(1,j)
4102           do k=1,3
4103             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
4104             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
4105           enddo
4106           gelc_long(3,j)=gelc_long(3,j)+
4107      &      ssgradlipj*eesij/2.0d0*lipscale**2*sss
4108
4109           gelc_long(3,i)=gelc_long(3,i)+
4110      &      ssgradlipi*eesij/2.0d0*lipscale**2*sss
4111
4112
4113 *
4114 * Loop over residues i+1 thru j-1.
4115 *
4116 cgrad          do k=i+1,j-1
4117 cgrad            do l=1,3
4118 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
4119 cgrad            enddo
4120 cgrad          enddo
4121           facvdw=(facvdw+sssgrad*rmij*evdwij)*faclipij2
4122           ggg(1)=facvdw*xj
4123           ggg(2)=facvdw*yj
4124           ggg(3)=facvdw*zj
4125 c          do k=1,3
4126 c            ghalf=0.5D0*ggg(k)
4127 c            gvdwpp(k,i)=gvdwpp(k,i)+ghalf
4128 c            gvdwpp(k,j)=gvdwpp(k,j)+ghalf
4129 c          enddo
4130 c 9/28/08 AL Gradient compotents will be summed only at the end
4131           do k=1,3
4132             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
4133             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
4134           enddo
4135 !C Lipidic part for scaling weight
4136           gvdwpp(3,j)=gvdwpp(3,j)+
4137      &      sss*ssgradlipj*evdwij/2.0d0*lipscale**2
4138           gvdwpp(3,i)=gvdwpp(3,i)+
4139      &      sss*ssgradlipi*evdwij/2.0d0*lipscale**2
4140 *
4141 * Loop over residues i+1 thru j-1.
4142 *
4143 cgrad          do k=i+1,j-1
4144 cgrad            do l=1,3
4145 cgrad              gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
4146 cgrad            enddo
4147 cgrad          enddo
4148 #else
4149 C MARYSIA
4150           facvdw=(ev1+evdwij)*faclipij2
4151           facel=(el1+eesij)
4152           fac1=fac
4153           fac=-3*rrmij*(facvdw+facvdw+facel)*sss
4154      &       +(evdwij+eesij)*sssgrad*rrmij
4155           erij(1)=xj*rmij
4156           erij(2)=yj*rmij
4157           erij(3)=zj*rmij
4158 *
4159 * Radial derivatives. First process both termini of the fragment (i,j)
4160 *
4161           ggg(1)=fac*xj
4162 C+eesij*grad_shield(1,i)+eesij*grad_shield(1,j)
4163           ggg(2)=fac*yj
4164 C+eesij*grad_shield(2,i)+eesij*grad_shield(2,j)
4165           ggg(3)=fac*zj
4166 C+eesij*grad_shield(3,i)+eesij*grad_shield(3,j)
4167 c          do k=1,3
4168 c            ghalf=0.5D0*ggg(k)
4169 c            gelc(k,i)=gelc(k,i)+ghalf
4170 c            gelc(k,j)=gelc(k,j)+ghalf
4171 c          enddo
4172 c 9/28/08 AL Gradient compotents will be summed only at the end
4173           do k=1,3
4174             gelc_long(k,j)=gelc(k,j)+ggg(k)
4175             gelc_long(k,i)=gelc(k,i)-ggg(k)
4176           enddo
4177 *
4178 * Loop over residues i+1 thru j-1.
4179 *
4180 cgrad          do k=i+1,j-1
4181 cgrad            do l=1,3
4182 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
4183 cgrad            enddo
4184 cgrad          enddo
4185 c 9/28/08 AL Gradient compotents will be summed only at the end
4186           ggg(1)=facvdw*xj+sssgrad*rmij*evdwij*xj
4187           ggg(2)=facvdw*yj+sssgrad*rmij*evdwij*yj
4188           ggg(3)=facvdw*zj+sssgrad*rmij*evdwij*zj
4189           do k=1,3
4190             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
4191             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
4192           enddo
4193           gvdwpp(3,j)=gvdwpp(3,j)+
4194      &      sss*ssgradlipj*evdwij/2.0d0*lipscale**2
4195           gvdwpp(3,i)=gvdwpp(3,i)+
4196      &      sss*ssgradlipi*evdwij/2.0d0*lipscale**2
4197 #endif
4198 *
4199 * Angular part
4200 *
4201           ecosa=2.0D0*fac3*fac1+fac4
4202           fac4=-3.0D0*fac4
4203           fac3=-6.0D0*fac3
4204           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
4205           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
4206           do k=1,3
4207             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
4208             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
4209           enddo
4210 cd        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
4211 cd   &          (dcosg(k),k=1,3)
4212           do k=1,3
4213             ggg(k)=(ecosb*dcosb(k)+ecosg*dcosg(k))*
4214      &      fac_shield(i)**2*fac_shield(j)**2*sss*faclipij2
4215           enddo
4216 c          do k=1,3
4217 c            ghalf=0.5D0*ggg(k)
4218 c            gelc(k,i)=gelc(k,i)+ghalf
4219 c     &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
4220 c     &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
4221 c            gelc(k,j)=gelc(k,j)+ghalf
4222 c     &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
4223 c     &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
4224 c          enddo
4225 cgrad          do k=i+1,j-1
4226 cgrad            do l=1,3
4227 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
4228 cgrad            enddo
4229 cgrad          enddo
4230 C                     print *,"before22", gelc_long(1,i), gelc_long(1,j)
4231           do k=1,3
4232             gelc(k,i)=gelc(k,i)
4233      &           +((ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
4234      &           + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1))*sss
4235      &           *fac_shield(i)**2*fac_shield(j)**2*faclipij2
4236             gelc(k,j)=gelc(k,j)
4237      &           +((ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
4238      &           + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1))*sss
4239      &           *fac_shield(i)**2*fac_shield(j)**2*faclipij2
4240             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
4241             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
4242           enddo
4243 C           print *,"before33", gelc_long(1,i), gelc_long(1,j)
4244
4245 C MARYSIA
4246 c          endif !sscale
4247           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
4248      &        .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0
4249      &        .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
4250 C
4251 C 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
4252 C   energy of a peptide unit is assumed in the form of a second-order
4253 C   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
4254 C   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
4255 C   are computed for EVERY pair of non-contiguous peptide groups.
4256 C
4257
4258           if (j.lt.nres-1) then
4259             j1=j+1
4260             j2=j-1
4261           else
4262             j1=j-1
4263             j2=j-2
4264           endif
4265           kkk=0
4266           lll=0
4267           do k=1,2
4268             do l=1,2
4269               kkk=kkk+1
4270               muij(kkk)=mu(k,i)*mu(l,j)
4271 c              write(iout,*) 'mumu=', mu(k,i),mu(l,j),i,j,k,l
4272 #ifdef NEWCORR
4273              gmuij1(kkk)=gtb1(k,i+1)*mu(l,j)
4274 c             write(iout,*) 'k=',k,i,gtb1(k,i+1),gtb1(k,i+1)*mu(l,j)
4275              gmuij2(kkk)=gUb2(k,i)*mu(l,j)
4276              gmuji1(kkk)=mu(k,i)*gtb1(l,j+1)
4277 c             write(iout,*) 'l=',l,j,gtb1(l,j+1),gtb1(l,j+1)*mu(k,i)
4278              gmuji2(kkk)=mu(k,i)*gUb2(l,j)
4279 #endif
4280             enddo
4281           enddo
4282 #ifdef DEBUG
4283           write (iout,*) 'EELEC: i',i,' j',j
4284           write (iout,*) 'j',j,' j1',j1,' j2',j2
4285           write(iout,*) 'muij',muij
4286 #endif
4287           ury=scalar(uy(1,i),erij)
4288           urz=scalar(uz(1,i),erij)
4289           vry=scalar(uy(1,j),erij)
4290           vrz=scalar(uz(1,j),erij)
4291           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
4292           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
4293           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
4294           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
4295           fac=dsqrt(-ael6i)*r3ij
4296 #ifdef DEBUG
4297           write (iout,*) "ury",ury," urz",urz," vry",vry," vrz",vrz
4298           write (iout,*) "uyvy",scalar(uy(1,i),uy(1,j)),
4299      &      "uyvz",scalar(uy(1,i),uz(1,j)),
4300      &      "uzvy",scalar(uz(1,i),uy(1,j)),
4301      &      "uzvz",scalar(uz(1,i),uz(1,j))
4302           write (iout,*) "a22",a22," a23",a23," a32",a32," a33",a33
4303           write (iout,*) "fac",fac
4304 #endif
4305           a22=a22*fac
4306           a23=a23*fac
4307           a32=a32*fac
4308           a33=a33*fac
4309 #ifdef DEBUG
4310           write (iout,*) "a22",a22," a23",a23," a32",a32," a33",a33
4311 #endif
4312 #undef DEBUG
4313 cd          write (iout,'(4i5,4f10.5)')
4314 cd     &     i,itortyp(itype(i)),j,itortyp(itype(j)),a22,a23,a32,a33
4315 cd          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
4316 cd          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') uy(:,i),uz(:,i),
4317 cd     &      uy(:,j),uz(:,j)
4318 cd          write (iout,'(4f10.5)')
4319 cd     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
4320 cd     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
4321 cd          write (iout,'(4f10.5)') ury,urz,vry,vrz
4322 cd           write (iout,'(9f10.5/)')
4323 cd     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
4324 C Derivatives of the elements of A in virtual-bond vectors
4325           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
4326           do k=1,3
4327             uryg(k,1)=scalar(erder(1,k),uy(1,i))
4328             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
4329             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
4330             urzg(k,1)=scalar(erder(1,k),uz(1,i))
4331             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
4332             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
4333             vryg(k,1)=scalar(erder(1,k),uy(1,j))
4334             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
4335             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
4336             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
4337             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
4338             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
4339           enddo
4340 C Compute radial contributions to the gradient
4341           facr=-3.0d0*rrmij
4342           a22der=a22*facr
4343           a23der=a23*facr
4344           a32der=a32*facr
4345           a33der=a33*facr
4346           agg(1,1)=a22der*xj
4347           agg(2,1)=a22der*yj
4348           agg(3,1)=a22der*zj
4349           agg(1,2)=a23der*xj
4350           agg(2,2)=a23der*yj
4351           agg(3,2)=a23der*zj
4352           agg(1,3)=a32der*xj
4353           agg(2,3)=a32der*yj
4354           agg(3,3)=a32der*zj
4355           agg(1,4)=a33der*xj
4356           agg(2,4)=a33der*yj
4357           agg(3,4)=a33der*zj
4358 C Add the contributions coming from er
4359           fac3=-3.0d0*fac
4360           do k=1,3
4361             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
4362             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
4363             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
4364             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
4365           enddo
4366           do k=1,3
4367 C Derivatives in DC(i)
4368 cgrad            ghalf1=0.5d0*agg(k,1)
4369 cgrad            ghalf2=0.5d0*agg(k,2)
4370 cgrad            ghalf3=0.5d0*agg(k,3)
4371 cgrad            ghalf4=0.5d0*agg(k,4)
4372             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j))
4373      &      -3.0d0*uryg(k,2)*vry)!+ghalf1
4374             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j))
4375      &      -3.0d0*uryg(k,2)*vrz)!+ghalf2
4376             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j))
4377      &      -3.0d0*urzg(k,2)*vry)!+ghalf3
4378             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j))
4379      &      -3.0d0*urzg(k,2)*vrz)!+ghalf4
4380 C Derivatives in DC(i+1)
4381             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j))
4382      &      -3.0d0*uryg(k,3)*vry)!+agg(k,1)
4383             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j))
4384      &      -3.0d0*uryg(k,3)*vrz)!+agg(k,2)
4385             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j))
4386      &      -3.0d0*urzg(k,3)*vry)!+agg(k,3)
4387             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j))
4388      &      -3.0d0*urzg(k,3)*vrz)!+agg(k,4)
4389 C Derivatives in DC(j)
4390             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i))
4391      &      -3.0d0*vryg(k,2)*ury)!+ghalf1
4392             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i))
4393      &      -3.0d0*vrzg(k,2)*ury)!+ghalf2
4394             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i))
4395      &      -3.0d0*vryg(k,2)*urz)!+ghalf3
4396             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i))
4397      &      -3.0d0*vrzg(k,2)*urz)!+ghalf4
4398 C Derivatives in DC(j+1) or DC(nres-1)
4399             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i))
4400      &      -3.0d0*vryg(k,3)*ury)
4401             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i))
4402      &      -3.0d0*vrzg(k,3)*ury)
4403             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i))
4404      &      -3.0d0*vryg(k,3)*urz)
4405             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i))
4406      &      -3.0d0*vrzg(k,3)*urz)
4407 cgrad            if (j.eq.nres-1 .and. i.lt.j-2) then
4408 cgrad              do l=1,4
4409 cgrad                aggj1(k,l)=aggj1(k,l)+agg(k,l)
4410 cgrad              enddo
4411 cgrad            endif
4412           enddo
4413           acipa(1,1)=a22
4414           acipa(1,2)=a23
4415           acipa(2,1)=a32
4416           acipa(2,2)=a33
4417           a22=-a22
4418           a23=-a23
4419           do l=1,2
4420             do k=1,3
4421               agg(k,l)=-agg(k,l)
4422               aggi(k,l)=-aggi(k,l)
4423               aggi1(k,l)=-aggi1(k,l)
4424               aggj(k,l)=-aggj(k,l)
4425               aggj1(k,l)=-aggj1(k,l)
4426             enddo
4427           enddo
4428           if (j.lt.nres-1) then
4429             a22=-a22
4430             a32=-a32
4431             do l=1,3,2
4432               do k=1,3
4433                 agg(k,l)=-agg(k,l)
4434                 aggi(k,l)=-aggi(k,l)
4435                 aggi1(k,l)=-aggi1(k,l)
4436                 aggj(k,l)=-aggj(k,l)
4437                 aggj1(k,l)=-aggj1(k,l)
4438               enddo
4439             enddo
4440           else
4441             a22=-a22
4442             a23=-a23
4443             a32=-a32
4444             a33=-a33
4445             do l=1,4
4446               do k=1,3
4447                 agg(k,l)=-agg(k,l)
4448                 aggi(k,l)=-aggi(k,l)
4449                 aggi1(k,l)=-aggi1(k,l)
4450                 aggj(k,l)=-aggj(k,l)
4451                 aggj1(k,l)=-aggj1(k,l)
4452               enddo
4453             enddo
4454           endif
4455           ENDIF ! WCORR
4456           IF (wel_loc.gt.0.0d0) THEN
4457 C Contribution to the local-electrostatic energy coming from the i-j pair
4458           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3)
4459      &     +a33*muij(4)
4460 #ifdef DEBUG
4461           write (iout,*) "muij",muij," a22",a22," a23",a23," a32",a32,
4462      &     " a33",a33
4463           write (iout,*) "ij",i,j," eel_loc_ij",eel_loc_ij,
4464      &     " wel_loc",wel_loc
4465 #endif
4466           if (shield_mode.eq.0) then
4467            fac_shield(i)=1.0
4468            fac_shield(j)=1.0
4469 C          else
4470 C           fac_shield(i)=0.4
4471 C           fac_shield(j)=0.6
4472           endif
4473           eel_loc_ij=eel_loc_ij
4474      &    *fac_shield(i)*fac_shield(j)*sss*faclipij
4475 c          if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
4476 c     &            'eelloc',i,j,eel_loc_ij
4477 C Now derivative over eel_loc
4478           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
4479      &  (shield_mode.gt.0)) then
4480 C          print *,i,j
4481
4482           do ilist=1,ishield_list(i)
4483            iresshield=shield_list(ilist,i)
4484            do k=1,3
4485            rlocshield=grad_shield_side(k,ilist,i)*eel_loc_ij
4486      &                                          /fac_shield(i)
4487 C     &      *2.0
4488            gshieldx_ll(k,iresshield)=gshieldx_ll(k,iresshield)+
4489      &              rlocshield
4490      & +grad_shield_loc(k,ilist,i)*eel_loc_ij/fac_shield(i)
4491             gshieldc_ll(k,iresshield-1)=gshieldc_ll(k,iresshield-1)
4492      &      +rlocshield
4493            enddo
4494           enddo
4495           do ilist=1,ishield_list(j)
4496            iresshield=shield_list(ilist,j)
4497            do k=1,3
4498            rlocshield=grad_shield_side(k,ilist,j)*eel_loc_ij
4499      &                                       /fac_shield(j)
4500 C     &     *2.0
4501            gshieldx_ll(k,iresshield)=gshieldx_ll(k,iresshield)+
4502      &              rlocshield
4503      & +grad_shield_loc(k,ilist,j)*eel_loc_ij/fac_shield(j)
4504            gshieldc_ll(k,iresshield-1)=gshieldc_ll(k,iresshield-1)
4505      &             +rlocshield
4506
4507            enddo
4508           enddo
4509
4510           do k=1,3
4511             gshieldc_ll(k,i)=gshieldc_ll(k,i)+
4512      &              grad_shield(k,i)*eel_loc_ij/fac_shield(i)
4513             gshieldc_ll(k,j)=gshieldc_ll(k,j)+
4514      &              grad_shield(k,j)*eel_loc_ij/fac_shield(j)
4515             gshieldc_ll(k,i-1)=gshieldc_ll(k,i-1)+
4516      &              grad_shield(k,i)*eel_loc_ij/fac_shield(i)
4517             gshieldc_ll(k,j-1)=gshieldc_ll(k,j-1)+
4518      &              grad_shield(k,j)*eel_loc_ij/fac_shield(j)
4519            enddo
4520            endif
4521
4522
4523 c          write (iout,*) 'i',i,' j',j,itype(i),itype(j),
4524 c     &                     ' eel_loc_ij',eel_loc_ij
4525 C          write(iout,*) 'muije=',i,j,muij(1),muij(2),muij(3),muij(4)
4526 C Calculate patrial derivative for theta angle
4527 #ifdef NEWCORR
4528          geel_loc_ij=(a22*gmuij1(1)
4529      &     +a23*gmuij1(2)
4530      &     +a32*gmuij1(3)
4531      &     +a33*gmuij1(4))
4532      &    *fac_shield(i)*fac_shield(j)*sss*faclipij
4533 c         write(iout,*) "derivative over thatai"
4534 c         write(iout,*) a22*gmuij1(1), a23*gmuij1(2) ,a32*gmuij1(3),
4535 c     &   a33*gmuij1(4)
4536          gloc(nphi+i,icg)=gloc(nphi+i,icg)+
4537      &      geel_loc_ij*wel_loc
4538 c         write(iout,*) "derivative over thatai-1"
4539 c         write(iout,*) a22*gmuij2(1), a23*gmuij2(2) ,a32*gmuij2(3),
4540 c     &   a33*gmuij2(4)
4541          geel_loc_ij=
4542      &     a22*gmuij2(1)
4543      &     +a23*gmuij2(2)
4544      &     +a32*gmuij2(3)
4545      &     +a33*gmuij2(4)
4546          gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
4547      &      geel_loc_ij*wel_loc
4548      &    *fac_shield(i)*fac_shield(j)*sss*faclipij
4549
4550 c  Derivative over j residue
4551          geel_loc_ji=a22*gmuji1(1)
4552      &     +a23*gmuji1(2)
4553      &     +a32*gmuji1(3)
4554      &     +a33*gmuji1(4)
4555 c         write(iout,*) "derivative over thataj"
4556 c         write(iout,*) a22*gmuji1(1), a23*gmuji1(2) ,a32*gmuji1(3),
4557 c     &   a33*gmuji1(4)
4558
4559         gloc(nphi+j,icg)=gloc(nphi+j,icg)+
4560      &      geel_loc_ji*wel_loc
4561      &    *fac_shield(i)*fac_shield(j)*sss*faclipij
4562
4563          geel_loc_ji=
4564      &     +a22*gmuji2(1)
4565      &     +a23*gmuji2(2)
4566      &     +a32*gmuji2(3)
4567      &     +a33*gmuji2(4)
4568 c         write(iout,*) "derivative over thataj-1"
4569 c         write(iout,*) a22*gmuji2(1), a23*gmuji2(2) ,a32*gmuji2(3),
4570 c     &   a33*gmuji2(4)
4571          gloc(nphi+j-1,icg)=gloc(nphi+j-1,icg)+
4572      &      geel_loc_ji*wel_loc
4573      &    *fac_shield(i)*fac_shield(j)*sss*faclipij
4574 #endif
4575 cd          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
4576
4577           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
4578      &            'eelloc',i,j,eel_loc_ij
4579 c           if (eel_loc_ij.ne.0)
4580 c     &      write (iout,'(a4,2i4,8f9.5)')'chuj',
4581 c     &     i,j,a22,muij(1),a23,muij(2),a32,muij(3),a33,muij(4)
4582
4583           eel_loc=eel_loc+eel_loc_ij
4584 C Partial derivatives in virtual-bond dihedral angles gamma
4585           if (i.gt.1)
4586      &    gel_loc_loc(i-1)=gel_loc_loc(i-1)+
4587      &            (a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j)
4588      &           +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j))
4589      &    *fac_shield(i)*fac_shield(j)*sss*faclipij
4590
4591           gel_loc_loc(j-1)=gel_loc_loc(j-1)+
4592      &           (a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j)
4593      &           +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j))
4594      &    *fac_shield(i)*fac_shield(j)*sss*faclipij
4595 C Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
4596           aux=eel_loc_ij/sss*sssgrad*rmij
4597           ggg(1)=aux*xj
4598           ggg(2)=aux*yj
4599           ggg(3)=aux*zj
4600           do l=1,3
4601             ggg(l)=ggg(l)+(agg(l,1)*muij(1)+
4602      &          agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4))
4603      &    *fac_shield(i)*fac_shield(j)*sss*faclipij
4604             gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l)
4605             gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l)
4606 cgrad            ghalf=0.5d0*ggg(l)
4607 cgrad            gel_loc(l,i)=gel_loc(l,i)+ghalf
4608 cgrad            gel_loc(l,j)=gel_loc(l,j)+ghalf
4609           enddo
4610           gel_loc_long(3,j)=gel_loc_long(3,j)+
4611      &      ssgradlipj*eel_loc_ij/2.0d0*lipscale/faclipij
4612
4613           gel_loc_long(3,i)=gel_loc_long(3,i)+
4614      &      ssgradlipi*eel_loc_ij/2.0d0*lipscale/faclipij
4615
4616 cgrad          do k=i+1,j2
4617 cgrad            do l=1,3
4618 cgrad              gel_loc(l,k)=gel_loc(l,k)+ggg(l)
4619 cgrad            enddo
4620 cgrad          enddo
4621 C Remaining derivatives of eello
4622           do l=1,3
4623             gel_loc(l,i)=gel_loc(l,i)+(aggi(l,1)*muij(1)+
4624      &        aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4))
4625      &        *fac_shield(i)*fac_shield(j)*sss*faclipij
4626
4627             gel_loc(l,i+1)=gel_loc(l,i+1)+(aggi1(l,1)*muij(1)+
4628      &        aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4))
4629      &        *fac_shield(i)*fac_shield(j)*sss*faclipij
4630
4631             gel_loc(l,j)=gel_loc(l,j)+(aggj(l,1)*muij(1)+
4632      &        aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4))
4633      &        *fac_shield(i)*fac_shield(j)*sss*faclipij
4634
4635             gel_loc(l,j1)=gel_loc(l,j1)+(aggj1(l,1)*muij(1)+
4636      &        aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4))
4637      &        *fac_shield(i)*fac_shield(j)*sss*faclipij
4638
4639           enddo
4640           ENDIF
4641 C Change 12/26/95 to calculate four-body contributions to H-bonding energy
4642 c          if (j.gt.i+1 .and. num_conti.le.maxconts) then
4643 #ifdef FOURBODY
4644           if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0
4645      &       .and. num_conti.le.maxconts) then
4646 c            write (iout,*) i,j," entered corr"
4647 C
4648 C Calculate the contact function. The ith column of the array JCONT will
4649 C contain the numbers of atoms that make contacts with the atom I (of numbers
4650 C greater than I). The arrays FACONT and GACONT will contain the values of
4651 C the contact function and its derivative.
4652 c           r0ij=1.02D0*rpp(iteli,itelj)
4653 c           r0ij=1.11D0*rpp(iteli,itelj)
4654             r0ij=2.20D0*rpp(iteli,itelj)
4655 c           r0ij=1.55D0*rpp(iteli,itelj)
4656             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
4657             if (fcont.gt.0.0D0) then
4658               num_conti=num_conti+1
4659               if (num_conti.gt.maxconts) then
4660                 write (iout,*) 'WARNING - max. # of contacts exceeded;',
4661      &                         ' will skip next contacts for this conf.'
4662               else
4663                 jcont_hb(num_conti,i)=j
4664 cd                write (iout,*) "i",i," j",j," num_conti",num_conti,
4665 cd     &           " jcont_hb",jcont_hb(num_conti,i)
4666                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.
4667      &          wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
4668 C 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
4669 C  terms.
4670                 d_cont(num_conti,i)=rij
4671 cd                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
4672 C     --- Electrostatic-interaction matrix ---
4673                 a_chuj(1,1,num_conti,i)=a22
4674                 a_chuj(1,2,num_conti,i)=a23
4675                 a_chuj(2,1,num_conti,i)=a32
4676                 a_chuj(2,2,num_conti,i)=a33
4677 C     --- Gradient of rij
4678                 do kkk=1,3
4679                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
4680                 enddo
4681                 kkll=0
4682                 do k=1,2
4683                   do l=1,2
4684                     kkll=kkll+1
4685                     do m=1,3
4686                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
4687                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
4688                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
4689                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
4690                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
4691                     enddo
4692                   enddo
4693                 enddo
4694                 ENDIF
4695                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
4696 C Calculate contact energies
4697                 cosa4=4.0D0*cosa
4698                 wij=cosa-3.0D0*cosb*cosg
4699                 cosbg1=cosb+cosg
4700                 cosbg2=cosb-cosg
4701 c               fac3=dsqrt(-ael6i)/r0ij**3
4702                 fac3=dsqrt(-ael6i)*r3ij
4703 c                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
4704                 ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
4705                 if (ees0tmp.gt.0) then
4706                   ees0pij=dsqrt(ees0tmp)
4707                 else
4708                   ees0pij=0
4709                 endif
4710 c                ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
4711                 ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
4712                 if (ees0tmp.gt.0) then
4713                   ees0mij=dsqrt(ees0tmp)
4714                 else
4715                   ees0mij=0
4716                 endif
4717 c               ees0mij=0.0D0
4718                 if (shield_mode.eq.0) then
4719                 fac_shield(i)=1.0d0
4720                 fac_shield(j)=1.0d0
4721                 else
4722                 ees0plist(num_conti,i)=j
4723 C                fac_shield(i)=0.4d0
4724 C                fac_shield(j)=0.6d0
4725                 endif
4726                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij)
4727      &          *fac_shield(i)*fac_shield(j)*sss
4728                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij)
4729      &          *fac_shield(i)*fac_shield(j)*sss
4730 C Diagnostics. Comment out or remove after debugging!
4731 c               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
4732 c               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
4733 c               ees0m(num_conti,i)=0.0D0
4734 C End diagnostics.
4735 c               write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
4736 c    & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
4737 C Angular derivatives of the contact function
4738                 ees0pij1=fac3/ees0pij
4739                 ees0mij1=fac3/ees0mij
4740                 fac3p=-3.0D0*fac3*rrmij
4741                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
4742                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
4743 c               ees0mij1=0.0D0
4744                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
4745                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
4746                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
4747                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
4748                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
4749                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
4750                 ecosap=ecosa1+ecosa2
4751                 ecosbp=ecosb1+ecosb2
4752                 ecosgp=ecosg1+ecosg2
4753                 ecosam=ecosa1-ecosa2
4754                 ecosbm=ecosb1-ecosb2
4755                 ecosgm=ecosg1-ecosg2
4756 C Diagnostics
4757 c               ecosap=ecosa1
4758 c               ecosbp=ecosb1
4759 c               ecosgp=ecosg1
4760 c               ecosam=0.0D0
4761 c               ecosbm=0.0D0
4762 c               ecosgm=0.0D0
4763 C End diagnostics
4764                 facont_hb(num_conti,i)=fcont
4765                 fprimcont=fprimcont/rij
4766 cd              facont_hb(num_conti,i)=1.0D0
4767 C Following line is for diagnostics.
4768 cd              fprimcont=0.0D0
4769                 do k=1,3
4770                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
4771                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
4772                 enddo
4773                 do k=1,3
4774                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
4775                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
4776                 enddo
4777                 gggp(1)=gggp(1)+ees0pijp*xj
4778      &          +ees0p(num_conti,i)/sss*rmij*xj*sssgrad
4779                 gggp(2)=gggp(2)+ees0pijp*yj
4780      &          +ees0p(num_conti,i)/sss*rmij*yj*sssgrad
4781                 gggp(3)=gggp(3)+ees0pijp*zj
4782      &          +ees0p(num_conti,i)/sss*rmij*zj*sssgrad
4783                 gggm(1)=gggm(1)+ees0mijp*xj
4784      &          +ees0m(num_conti,i)/sss*rmij*xj*sssgrad
4785                 gggm(2)=gggm(2)+ees0mijp*yj
4786      &          +ees0m(num_conti,i)/sss*rmij*yj*sssgrad
4787                 gggm(3)=gggm(3)+ees0mijp*zj
4788      &          +ees0m(num_conti,i)/sss*rmij*zj*sssgrad
4789 C Derivatives due to the contact function
4790                 gacont_hbr(1,num_conti,i)=fprimcont*xj
4791                 gacont_hbr(2,num_conti,i)=fprimcont*yj
4792                 gacont_hbr(3,num_conti,i)=fprimcont*zj
4793                 do k=1,3
4794 c
4795 c 10/24/08 cgrad and ! comments indicate the parts of the code removed
4796 c          following the change of gradient-summation algorithm.
4797 c
4798 cgrad                  ghalfp=0.5D0*gggp(k)
4799 cgrad                  ghalfm=0.5D0*gggm(k)
4800                   gacontp_hb1(k,num_conti,i)=!ghalfp
4801      &              +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i))
4802      &              + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
4803      &          *fac_shield(i)*fac_shield(j)*sss
4804
4805                   gacontp_hb2(k,num_conti,i)=!ghalfp
4806      &              +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j))
4807      &              + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
4808      &          *fac_shield(i)*fac_shield(j)*sss
4809
4810                   gacontp_hb3(k,num_conti,i)=gggp(k)
4811      &          *fac_shield(i)*fac_shield(j)*sss
4812
4813                   gacontm_hb1(k,num_conti,i)=!ghalfm
4814      &              +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i))
4815      &              + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
4816      &          *fac_shield(i)*fac_shield(j)*sss
4817
4818                   gacontm_hb2(k,num_conti,i)=!ghalfm
4819      &              +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j))
4820      &              + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
4821      &          *fac_shield(i)*fac_shield(j)*sss
4822
4823                   gacontm_hb3(k,num_conti,i)=gggm(k)
4824      &          *fac_shield(i)*fac_shield(j)*sss
4825
4826                 enddo
4827 C Diagnostics. Comment out or remove after debugging!
4828 cdiag           do k=1,3
4829 cdiag             gacontp_hb1(k,num_conti,i)=0.0D0
4830 cdiag             gacontp_hb2(k,num_conti,i)=0.0D0
4831 cdiag             gacontp_hb3(k,num_conti,i)=0.0D0
4832 cdiag             gacontm_hb1(k,num_conti,i)=0.0D0
4833 cdiag             gacontm_hb2(k,num_conti,i)=0.0D0
4834 cdiag             gacontm_hb3(k,num_conti,i)=0.0D0
4835 cdiag           enddo
4836               ENDIF ! wcorr
4837               endif  ! num_conti.le.maxconts
4838             endif  ! fcont.gt.0
4839           endif    ! j.gt.i+1
4840 #endif
4841           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
4842             do k=1,4
4843               do l=1,3
4844                 ghalf=0.5d0*agg(l,k)
4845                 aggi(l,k)=aggi(l,k)+ghalf
4846                 aggi1(l,k)=aggi1(l,k)+agg(l,k)
4847                 aggj(l,k)=aggj(l,k)+ghalf
4848               enddo
4849             enddo
4850             if (j.eq.nres-1 .and. i.lt.j-2) then
4851               do k=1,4
4852                 do l=1,3
4853                   aggj1(l,k)=aggj1(l,k)+agg(l,k)
4854                 enddo
4855               enddo
4856             endif
4857           endif
4858 c          t_eelecij=t_eelecij+MPI_Wtime()-time00
4859       return
4860       end
4861 C-----------------------------------------------------------------------------
4862       subroutine eturn3(i,eello_turn3)
4863 C Third- and fourth-order contributions from turns
4864       implicit real*8 (a-h,o-z)
4865       include 'DIMENSIONS'
4866       include 'COMMON.IOUNITS'
4867       include 'COMMON.GEO'
4868       include 'COMMON.VAR'
4869       include 'COMMON.LOCAL'
4870       include 'COMMON.CHAIN'
4871       include 'COMMON.DERIV'
4872       include 'COMMON.INTERACT'
4873       include 'COMMON.CORRMAT'
4874       include 'COMMON.TORSION'
4875       include 'COMMON.VECTORS'
4876       include 'COMMON.FFIELD'
4877       include 'COMMON.CONTROL'
4878       include 'COMMON.SHIELD'
4879       dimension ggg(3)
4880       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
4881      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
4882      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2),gpizda1(2,2),
4883      &  gpizda2(2,2),auxgmat1(2,2),auxgmatt1(2,2),
4884      &  auxgmat2(2,2),auxgmatt2(2,2)
4885       double precision agg(3,4),aggi(3,4),aggi1(3,4),
4886      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
4887       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
4888      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
4889      &    num_conti,j1,j2
4890       double precision sslipi,sslipj,ssgradlipi,ssgradlipj,faclipij
4891       common /lipcalc/ sslipi,sslipj,ssgradlipi,ssgradlipj,faclipij
4892       j=i+2
4893 c      write (iout,*) "eturn3",i,j,j1,j2
4894       a_temp(1,1)=a22
4895       a_temp(1,2)=a23
4896       a_temp(2,1)=a32
4897       a_temp(2,2)=a33
4898 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4899 C
4900 C               Third-order contributions
4901 C
4902 C                 (i+2)o----(i+3)
4903 C                      | |
4904 C                      | |
4905 C                 (i+1)o----i
4906 C
4907 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4908 cd        call checkint_turn3(i,a_temp,eello_turn3_num)
4909         call matmat2(EUg(1,1,i+1),EUg(1,1,i+2),auxmat(1,1))
4910 c auxalary matices for theta gradient
4911 c auxalary matrix for i+1 and constant i+2
4912         call matmat2(gtEUg(1,1,i+1),EUg(1,1,i+2),auxgmat1(1,1))
4913 c auxalary matrix for i+2 and constant i+1
4914         call matmat2(EUg(1,1,i+1),gtEUg(1,1,i+2),auxgmat2(1,1))
4915         call transpose2(auxmat(1,1),auxmat1(1,1))
4916         call transpose2(auxgmat1(1,1),auxgmatt1(1,1))
4917         call transpose2(auxgmat2(1,1),auxgmatt2(1,1))
4918         call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4919         call matmat2(a_temp(1,1),auxgmatt1(1,1),gpizda1(1,1))
4920         call matmat2(a_temp(1,1),auxgmatt2(1,1),gpizda2(1,1))
4921         if (shield_mode.eq.0) then
4922         fac_shield(i)=1.0
4923         fac_shield(j)=1.0
4924 C        else
4925 C        fac_shield(i)=0.4
4926 C        fac_shield(j)=0.6
4927         endif
4928         eello_turn3=eello_turn3+0.5d0*(pizda(1,1)+pizda(2,2))
4929      &  *fac_shield(i)*fac_shield(j)*faclipij
4930         eello_t3=0.5d0*(pizda(1,1)+pizda(2,2))
4931      &  *fac_shield(i)*fac_shield(j)
4932         if (energy_dec) write (iout,'(6heturn3,2i5,0pf7.3)') i,i+2,
4933      &    eello_t3
4934 C#ifdef NEWCORR
4935 C Derivatives in theta
4936         gloc(nphi+i,icg)=gloc(nphi+i,icg)
4937      &  +0.5d0*(gpizda1(1,1)+gpizda1(2,2))*wturn3
4938      &   *fac_shield(i)*fac_shield(j)*faclipij
4939         gloc(nphi+i+1,icg)=gloc(nphi+i+1,icg)
4940      &  +0.5d0*(gpizda2(1,1)+gpizda2(2,2))*wturn3
4941      &   *fac_shield(i)*fac_shield(j)*faclipij
4942 C#endif
4943
4944 C Derivatives in shield mode
4945           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
4946      &  (shield_mode.gt.0)) then
4947 C          print *,i,j
4948
4949           do ilist=1,ishield_list(i)
4950            iresshield=shield_list(ilist,i)
4951            do k=1,3
4952            rlocshield=grad_shield_side(k,ilist,i)*eello_t3/fac_shield(i)
4953 C     &      *2.0
4954            gshieldx_t3(k,iresshield)=gshieldx_t3(k,iresshield)+
4955      &              rlocshield
4956      & +grad_shield_loc(k,ilist,i)*eello_t3/fac_shield(i)
4957             gshieldc_t3(k,iresshield-1)=gshieldc_t3(k,iresshield-1)
4958      &      +rlocshield
4959            enddo
4960           enddo
4961           do ilist=1,ishield_list(j)
4962            iresshield=shield_list(ilist,j)
4963            do k=1,3
4964            rlocshield=grad_shield_side(k,ilist,j)*eello_t3/fac_shield(j)
4965 C     &     *2.0
4966            gshieldx_t3(k,iresshield)=gshieldx_t3(k,iresshield)+
4967      &              rlocshield
4968      & +grad_shield_loc(k,ilist,j)*eello_t3/fac_shield(j)
4969            gshieldc_t3(k,iresshield-1)=gshieldc_t3(k,iresshield-1)
4970      &             +rlocshield
4971
4972            enddo
4973           enddo
4974
4975           do k=1,3
4976             gshieldc_t3(k,i)=gshieldc_t3(k,i)+
4977      &              grad_shield(k,i)*eello_t3/fac_shield(i)
4978             gshieldc_t3(k,j)=gshieldc_t3(k,j)+
4979      &              grad_shield(k,j)*eello_t3/fac_shield(j)
4980             gshieldc_t3(k,i-1)=gshieldc_t3(k,i-1)+
4981      &              grad_shield(k,i)*eello_t3/fac_shield(i)
4982             gshieldc_t3(k,j-1)=gshieldc_t3(k,j-1)+
4983      &              grad_shield(k,j)*eello_t3/fac_shield(j)
4984            enddo
4985            endif
4986
4987 C        if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
4988 cd        write (2,*) 'i,',i,' j',j,'eello_turn3',
4989 cd     &    0.5d0*(pizda(1,1)+pizda(2,2)),
4990 cd     &    ' eello_turn3_num',4*eello_turn3_num
4991 C Derivatives in gamma(i)
4992         call matmat2(EUgder(1,1,i+1),EUg(1,1,i+2),auxmat2(1,1))
4993         call transpose2(auxmat2(1,1),auxmat3(1,1))
4994         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
4995         gel_loc_turn3(i)=gel_loc_turn3(i)+0.5d0*(pizda(1,1)+pizda(2,2))
4996      &   *fac_shield(i)*fac_shield(j)*faclipij
4997 C Derivatives in gamma(i+1)
4998         call matmat2(EUg(1,1,i+1),EUgder(1,1,i+2),auxmat2(1,1))
4999         call transpose2(auxmat2(1,1),auxmat3(1,1))
5000         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
5001         gel_loc_turn3(i+1)=gel_loc_turn3(i+1)
5002      &    +0.5d0*(pizda(1,1)+pizda(2,2))
5003      &   *fac_shield(i)*fac_shield(j)*faclipij
5004 C Cartesian derivatives
5005         do l=1,3
5006 c            ghalf1=0.5d0*agg(l,1)
5007 c            ghalf2=0.5d0*agg(l,2)
5008 c            ghalf3=0.5d0*agg(l,3)
5009 c            ghalf4=0.5d0*agg(l,4)
5010           a_temp(1,1)=aggi(l,1)!+ghalf1
5011           a_temp(1,2)=aggi(l,2)!+ghalf2
5012           a_temp(2,1)=aggi(l,3)!+ghalf3
5013           a_temp(2,2)=aggi(l,4)!+ghalf4
5014           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
5015           gcorr3_turn(l,i)=gcorr3_turn(l,i)
5016      &      +0.5d0*(pizda(1,1)+pizda(2,2))
5017      &      *fac_shield(i)*fac_shield(j)*faclipij
5018
5019           a_temp(1,1)=aggi1(l,1)!+agg(l,1)
5020           a_temp(1,2)=aggi1(l,2)!+agg(l,2)
5021           a_temp(2,1)=aggi1(l,3)!+agg(l,3)
5022           a_temp(2,2)=aggi1(l,4)!+agg(l,4)
5023           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
5024           gcorr3_turn(l,i+1)=gcorr3_turn(l,i+1)
5025      &      +0.5d0*(pizda(1,1)+pizda(2,2))
5026      &      *fac_shield(i)*fac_shield(j)*faclipij
5027           a_temp(1,1)=aggj(l,1)!+ghalf1
5028           a_temp(1,2)=aggj(l,2)!+ghalf2
5029           a_temp(2,1)=aggj(l,3)!+ghalf3
5030           a_temp(2,2)=aggj(l,4)!+ghalf4
5031           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
5032           gcorr3_turn(l,j)=gcorr3_turn(l,j)
5033      &      +0.5d0*(pizda(1,1)+pizda(2,2))
5034      &      *fac_shield(i)*fac_shield(j)*faclipij
5035           a_temp(1,1)=aggj1(l,1)
5036           a_temp(1,2)=aggj1(l,2)
5037           a_temp(2,1)=aggj1(l,3)
5038           a_temp(2,2)=aggj1(l,4)
5039           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
5040           gcorr3_turn(l,j1)=gcorr3_turn(l,j1)
5041      &      +0.5d0*(pizda(1,1)+pizda(2,2))
5042      &      *fac_shield(i)*fac_shield(j)*faclipij
5043         enddo
5044         gshieldc_t3(3,i)=gshieldc_t3(3,i)+
5045      &    ssgradlipi*eello_t3/4.0d0*lipscale
5046         gshieldc_t3(3,j)=gshieldc_t3(3,j)+
5047      &    ssgradlipj*eello_t3/4.0d0*lipscale
5048         gshieldc_t3(3,i-1)=gshieldc_t3(3,i-1)+
5049      &    ssgradlipi*eello_t3/4.0d0*lipscale
5050         gshieldc_t3(3,j-1)=gshieldc_t3(3,j-1)+
5051      &    ssgradlipj*eello_t3/4.0d0*lipscale
5052
5053       return
5054       end
5055 C-------------------------------------------------------------------------------
5056       subroutine eturn4(i,eello_turn4)
5057 C Third- and fourth-order contributions from turns
5058       implicit real*8 (a-h,o-z)
5059       include 'DIMENSIONS'
5060       include 'COMMON.IOUNITS'
5061       include 'COMMON.GEO'
5062       include 'COMMON.VAR'
5063       include 'COMMON.LOCAL'
5064       include 'COMMON.CHAIN'
5065       include 'COMMON.DERIV'
5066       include 'COMMON.INTERACT'
5067       include 'COMMON.CORRMAT'
5068       include 'COMMON.TORSION'
5069       include 'COMMON.VECTORS'
5070       include 'COMMON.FFIELD'
5071       include 'COMMON.CONTROL'
5072       include 'COMMON.SHIELD'
5073       dimension ggg(3)
5074       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
5075      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
5076      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2),auxgvec(2),
5077      &  auxgEvec1(2),auxgEvec2(2),auxgEvec3(2),
5078      &  gte1t(2,2),gte2t(2,2),gte3t(2,2),
5079      &  gte1a(2,2),gtae3(2,2),gtae3e2(2,2), ae3gte2(2,2),
5080      &  gtEpizda1(2,2),gtEpizda2(2,2),gtEpizda3(2,2)
5081       double precision agg(3,4),aggi(3,4),aggi1(3,4),
5082      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
5083       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
5084      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
5085      &    num_conti,j1,j2
5086       j=i+3
5087 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
5088 C
5089 C               Fourth-order contributions
5090 C
5091 C                 (i+3)o----(i+4)
5092 C                     /  |
5093 C               (i+2)o   |
5094 C                     \  |
5095 C                 (i+1)o----i
5096 C
5097 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
5098 cd        call checkint_turn4(i,a_temp,eello_turn4_num)
5099 c        write (iout,*) "eturn4 i",i," j",j," j1",j1," j2",j2
5100 c        write(iout,*)"WCHODZE W PROGRAM"
5101         a_temp(1,1)=a22
5102         a_temp(1,2)=a23
5103         a_temp(2,1)=a32
5104         a_temp(2,2)=a33
5105         iti1=itype2loc(itype(i+1))
5106         iti2=itype2loc(itype(i+2))
5107         iti3=itype2loc(itype(i+3))
5108 c        write(iout,*) "iti1",iti1," iti2",iti2," iti3",iti3
5109         call transpose2(EUg(1,1,i+1),e1t(1,1))
5110         call transpose2(Eug(1,1,i+2),e2t(1,1))
5111         call transpose2(Eug(1,1,i+3),e3t(1,1))
5112 C Ematrix derivative in theta
5113         call transpose2(gtEUg(1,1,i+1),gte1t(1,1))
5114         call transpose2(gtEug(1,1,i+2),gte2t(1,1))
5115         call transpose2(gtEug(1,1,i+3),gte3t(1,1))
5116         call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5117 c       eta1 in derivative theta
5118         call matmat2(gte1t(1,1),a_temp(1,1),gte1a(1,1))
5119         call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5120 c       auxgvec is derivative of Ub2 so i+3 theta
5121         call matvec2(e1a(1,1),gUb2(1,i+3),auxgvec(1))
5122 c       auxalary matrix of E i+1
5123         call matvec2(gte1a(1,1),Ub2(1,i+3),auxgEvec1(1))
5124 c        s1=0.0
5125 c        gs1=0.0
5126         s1=scalar2(b1(1,i+2),auxvec(1))
5127 c derivative of theta i+2 with constant i+3
5128         gs23=scalar2(gtb1(1,i+2),auxvec(1))
5129 c derivative of theta i+2 with constant i+2
5130         gs32=scalar2(b1(1,i+2),auxgvec(1))
5131 c derivative of E matix in theta of i+1
5132         gsE13=scalar2(b1(1,i+2),auxgEvec1(1))
5133
5134         call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5135 c       ea31 in derivative theta
5136         call matmat2(a_temp(1,1),gte3t(1,1),gtae3(1,1))
5137         call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5138 c auxilary matrix auxgvec of Ub2 with constant E matirx
5139         call matvec2(ae3(1,1),gUb2(1,i+2),auxgvec(1))
5140 c auxilary matrix auxgEvec1 of E matix with Ub2 constant
5141         call matvec2(gtae3(1,1),Ub2(1,i+2),auxgEvec3(1))
5142
5143 c        s2=0.0
5144 c        gs2=0.0
5145         s2=scalar2(b1(1,i+1),auxvec(1))
5146 c derivative of theta i+1 with constant i+3
5147         gs13=scalar2(gtb1(1,i+1),auxvec(1))
5148 c derivative of theta i+2 with constant i+1
5149         gs21=scalar2(b1(1,i+1),auxgvec(1))
5150 c derivative of theta i+3 with constant i+1
5151         gsE31=scalar2(b1(1,i+1),auxgEvec3(1))
5152 c        write(iout,*) gs1,gs2,'i=',i,auxgvec(1),gUb2(1,i+2),gtb1(1,i+2),
5153 c     &  gtb1(1,i+1)
5154         call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5155 c two derivatives over diffetent matrices
5156 c gtae3e2 is derivative over i+3
5157         call matmat2(gtae3(1,1),e2t(1,1),gtae3e2(1,1))
5158 c ae3gte2 is derivative over i+2
5159         call matmat2(ae3(1,1),gte2t(1,1),ae3gte2(1,1))
5160         call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5161 c three possible derivative over theta E matices
5162 c i+1
5163         call matmat2(ae3e2(1,1),gte1t(1,1),gtEpizda1(1,1))
5164 c i+2
5165         call matmat2(ae3gte2(1,1),e1t(1,1),gtEpizda2(1,1))
5166 c i+3
5167         call matmat2(gtae3e2(1,1),e1t(1,1),gtEpizda3(1,1))
5168         s3=0.5d0*(pizda(1,1)+pizda(2,2))
5169
5170         gsEE1=0.5d0*(gtEpizda1(1,1)+gtEpizda1(2,2))
5171         gsEE2=0.5d0*(gtEpizda2(1,1)+gtEpizda2(2,2))
5172         gsEE3=0.5d0*(gtEpizda3(1,1)+gtEpizda3(2,2))
5173         if (shield_mode.eq.0) then
5174         fac_shield(i)=1.0
5175         fac_shield(j)=1.0
5176 C        else
5177 C        fac_shield(i)=0.6
5178 C        fac_shield(j)=0.4
5179         endif
5180         eello_turn4=eello_turn4-(s1+s2+s3)
5181      &  *fac_shield(i)*fac_shield(j)*faclipij
5182         eello_t4=-(s1+s2+s3)
5183      &  *fac_shield(i)*fac_shield(j)
5184 c             write(iout,*)'chujOWO', auxvec(1),b1(1,iti2)
5185         if (energy_dec) write (iout,'(a6,2i5,0pf7.3,3f7.3)')
5186      &      'eturn4',i,j,-(s1+s2+s3),s1,s2,s3
5187 C Now derivative over shield:
5188           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
5189      &  (shield_mode.gt.0)) then
5190 C          print *,i,j
5191
5192           do ilist=1,ishield_list(i)
5193            iresshield=shield_list(ilist,i)
5194            do k=1,3
5195            rlocshield=grad_shield_side(k,ilist,i)*eello_t4/fac_shield(i)
5196 C     &      *2.0
5197            gshieldx_t4(k,iresshield)=gshieldx_t4(k,iresshield)+
5198      &              rlocshield
5199      & +grad_shield_loc(k,ilist,i)*eello_t4/fac_shield(i)
5200             gshieldc_t4(k,iresshield-1)=gshieldc_t4(k,iresshield-1)
5201      &      +rlocshield
5202            enddo
5203           enddo
5204           do ilist=1,ishield_list(j)
5205            iresshield=shield_list(ilist,j)
5206            do k=1,3
5207            rlocshield=grad_shield_side(k,ilist,j)*eello_t4/fac_shield(j)
5208 C     &     *2.0
5209            gshieldx_t4(k,iresshield)=gshieldx_t4(k,iresshield)+
5210      &              rlocshield
5211      & +grad_shield_loc(k,ilist,j)*eello_t4/fac_shield(j)
5212            gshieldc_t4(k,iresshield-1)=gshieldc_t4(k,iresshield-1)
5213      &             +rlocshield
5214
5215            enddo
5216           enddo
5217
5218           do k=1,3
5219             gshieldc_t4(k,i)=gshieldc_t4(k,i)+
5220      &              grad_shield(k,i)*eello_t4/fac_shield(i)
5221             gshieldc_t4(k,j)=gshieldc_t4(k,j)+
5222      &              grad_shield(k,j)*eello_t4/fac_shield(j)
5223             gshieldc_t4(k,i-1)=gshieldc_t4(k,i-1)+
5224      &              grad_shield(k,i)*eello_t4/fac_shield(i)
5225             gshieldc_t4(k,j-1)=gshieldc_t4(k,j-1)+
5226      &              grad_shield(k,j)*eello_t4/fac_shield(j)
5227            enddo
5228            endif
5229 cd        write (2,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
5230 cd     &    ' eello_turn4_num',8*eello_turn4_num
5231 #ifdef NEWCORR
5232         gloc(nphi+i,icg)=gloc(nphi+i,icg)
5233      &                  -(gs13+gsE13+gsEE1)*wturn4
5234      &  *fac_shield(i)*fac_shield(j)
5235         gloc(nphi+i+1,icg)= gloc(nphi+i+1,icg)
5236      &                    -(gs23+gs21+gsEE2)*wturn4
5237      &  *fac_shield(i)*fac_shield(j)
5238
5239         gloc(nphi+i+2,icg)= gloc(nphi+i+2,icg)
5240      &                    -(gs32+gsE31+gsEE3)*wturn4
5241      &  *fac_shield(i)*fac_shield(j)
5242
5243 c         gloc(nphi+i+1,icg)=gloc(nphi+i+1,icg)-
5244 c     &   gs2
5245 #endif
5246         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
5247      &      'eturn4',i,j,-(s1+s2+s3)
5248 c        write (iout,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
5249 c     &    ' eello_turn4_num',8*eello_turn4_num
5250 C Derivatives in gamma(i)
5251         call transpose2(EUgder(1,1,i+1),e1tder(1,1))
5252         call matmat2(e1tder(1,1),a_temp(1,1),auxmat(1,1))
5253         call matvec2(auxmat(1,1),Ub2(1,i+3),auxvec(1))
5254         s1=scalar2(b1(1,i+2),auxvec(1))
5255         call matmat2(ae3e2(1,1),e1tder(1,1),pizda(1,1))
5256         s3=0.5d0*(pizda(1,1)+pizda(2,2))
5257         gel_loc_turn4(i)=gel_loc_turn4(i)-(s1+s3)
5258      &  *fac_shield(i)*fac_shield(j)*faclipij
5259 C Derivatives in gamma(i+1)
5260         call transpose2(EUgder(1,1,i+2),e2tder(1,1))
5261         call matvec2(ae3(1,1),Ub2der(1,i+2),auxvec(1))
5262         s2=scalar2(b1(1,i+1),auxvec(1))
5263         call matmat2(ae3(1,1),e2tder(1,1),auxmat(1,1))
5264         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
5265         s3=0.5d0*(pizda(1,1)+pizda(2,2))
5266         gel_loc_turn4(i+1)=gel_loc_turn4(i+1)-(s2+s3)
5267      &  *fac_shield(i)*fac_shield(j)*faclipij
5268 C Derivatives in gamma(i+2)
5269         call transpose2(EUgder(1,1,i+3),e3tder(1,1))
5270         call matvec2(e1a(1,1),Ub2der(1,i+3),auxvec(1))
5271         s1=scalar2(b1(1,i+2),auxvec(1))
5272         call matmat2(a_temp(1,1),e3tder(1,1),auxmat(1,1))
5273         call matvec2(auxmat(1,1),Ub2(1,i+2),auxvec(1))
5274         s2=scalar2(b1(1,i+1),auxvec(1))
5275         call matmat2(auxmat(1,1),e2t(1,1),auxmat3(1,1))
5276         call matmat2(auxmat3(1,1),e1t(1,1),pizda(1,1))
5277         s3=0.5d0*(pizda(1,1)+pizda(2,2))
5278         gel_loc_turn4(i+2)=gel_loc_turn4(i+2)-(s1+s2+s3)
5279      &  *fac_shield(i)*fac_shield(j)*faclipij
5280 C Cartesian derivatives
5281 C Derivatives of this turn contributions in DC(i+2)
5282         if (j.lt.nres-1) then
5283           do l=1,3
5284             a_temp(1,1)=agg(l,1)
5285             a_temp(1,2)=agg(l,2)
5286             a_temp(2,1)=agg(l,3)
5287             a_temp(2,2)=agg(l,4)
5288             call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5289             call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5290             s1=scalar2(b1(1,i+2),auxvec(1))
5291             call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5292             call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5293             s2=scalar2(b1(1,i+1),auxvec(1))
5294             call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5295             call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5296             s3=0.5d0*(pizda(1,1)+pizda(2,2))
5297             ggg(l)=-(s1+s2+s3)
5298             gcorr4_turn(l,i+2)=gcorr4_turn(l,i+2)-(s1+s2+s3)
5299      &       *fac_shield(i)*fac_shield(j)*faclipij
5300           enddo
5301         endif
5302 C Remaining derivatives of this turn contribution
5303         do l=1,3
5304           a_temp(1,1)=aggi(l,1)
5305           a_temp(1,2)=aggi(l,2)
5306           a_temp(2,1)=aggi(l,3)
5307           a_temp(2,2)=aggi(l,4)
5308           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5309           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5310           s1=scalar2(b1(1,i+2),auxvec(1))
5311           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5312           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5313           s2=scalar2(b1(1,i+1),auxvec(1))
5314           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5315           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5316           s3=0.5d0*(pizda(1,1)+pizda(2,2))
5317           gcorr4_turn(l,i)=gcorr4_turn(l,i)-(s1+s2+s3)
5318      &     *fac_shield(i)*fac_shield(j)*faclipij
5319           a_temp(1,1)=aggi1(l,1)
5320           a_temp(1,2)=aggi1(l,2)
5321           a_temp(2,1)=aggi1(l,3)
5322           a_temp(2,2)=aggi1(l,4)
5323           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5324           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5325           s1=scalar2(b1(1,i+2),auxvec(1))
5326           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5327           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5328           s2=scalar2(b1(1,i+1),auxvec(1))
5329           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5330           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5331           s3=0.5d0*(pizda(1,1)+pizda(2,2))
5332           gcorr4_turn(l,i+1)=gcorr4_turn(l,i+1)-(s1+s2+s3)
5333      &      *fac_shield(i)*fac_shield(j)*faclipij
5334           a_temp(1,1)=aggj(l,1)
5335           a_temp(1,2)=aggj(l,2)
5336           a_temp(2,1)=aggj(l,3)
5337           a_temp(2,2)=aggj(l,4)
5338           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5339           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5340           s1=scalar2(b1(1,i+2),auxvec(1))
5341           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5342           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5343           s2=scalar2(b1(1,i+1),auxvec(1))
5344           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5345           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5346           s3=0.5d0*(pizda(1,1)+pizda(2,2))
5347           gcorr4_turn(l,j)=gcorr4_turn(l,j)-(s1+s2+s3)
5348      &      *fac_shield(i)*fac_shield(j)*faclipij
5349           a_temp(1,1)=aggj1(l,1)
5350           a_temp(1,2)=aggj1(l,2)
5351           a_temp(2,1)=aggj1(l,3)
5352           a_temp(2,2)=aggj1(l,4)
5353           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5354           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5355           s1=scalar2(b1(1,i+2),auxvec(1))
5356           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5357           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5358           s2=scalar2(b1(1,i+1),auxvec(1))
5359           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5360           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5361           s3=0.5d0*(pizda(1,1)+pizda(2,2))
5362 c          write (iout,*) "s1",s1," s2",s2," s3",s3," s1+s2+s3",s1+s2+s3
5363           gcorr4_turn(l,j1)=gcorr4_turn(l,j1)-(s1+s2+s3)
5364      &      *fac_shield(i)*fac_shield(j)*faclipij
5365         enddo
5366         gshieldc_t4(3,i)=gshieldc_t4(3,i)+
5367      &    ssgradlipi*eello_t4/4.0d0*lipscale
5368         gshieldc_t4(3,j)=gshieldc_t4(3,j)+
5369      &    ssgradlipj*eello_t4/4.0d0*lipscale
5370         gshieldc_t4(3,i-1)=gshieldc_t4(3,i-1)+
5371      &    ssgradlipi*eello_t4/4.0d0*lipscale
5372         gshieldc_t4(3,j-1)=gshieldc_t4(3,j-1)+
5373      &    ssgradlipj*eello_t4/4.0d0*lipscale
5374       return
5375       end
5376 C-----------------------------------------------------------------------------
5377       subroutine vecpr(u,v,w)
5378       implicit real*8(a-h,o-z)
5379       dimension u(3),v(3),w(3)
5380       w(1)=u(2)*v(3)-u(3)*v(2)
5381       w(2)=-u(1)*v(3)+u(3)*v(1)
5382       w(3)=u(1)*v(2)-u(2)*v(1)
5383       return
5384       end
5385 C-----------------------------------------------------------------------------
5386       subroutine unormderiv(u,ugrad,unorm,ungrad)
5387 C This subroutine computes the derivatives of a normalized vector u, given
5388 C the derivatives computed without normalization conditions, ugrad. Returns
5389 C ungrad.
5390       implicit none
5391       double precision u(3),ugrad(3,3),unorm,ungrad(3,3)
5392       double precision vec(3)
5393       double precision scalar
5394       integer i,j
5395 c      write (2,*) 'ugrad',ugrad
5396 c      write (2,*) 'u',u
5397       do i=1,3
5398         vec(i)=scalar(ugrad(1,i),u(1))
5399       enddo
5400 c      write (2,*) 'vec',vec
5401       do i=1,3
5402         do j=1,3
5403           ungrad(j,i)=(ugrad(j,i)-u(j)*vec(i))*unorm
5404         enddo
5405       enddo
5406 c      write (2,*) 'ungrad',ungrad
5407       return
5408       end
5409 C-----------------------------------------------------------------------------
5410       subroutine escp_soft_sphere(evdw2,evdw2_14)
5411 C
5412 C This subroutine calculates the excluded-volume interaction energy between
5413 C peptide-group centers and side chains and its gradient in virtual-bond and
5414 C side-chain vectors.
5415 C
5416       implicit real*8 (a-h,o-z)
5417       include 'DIMENSIONS'
5418       include 'COMMON.GEO'
5419       include 'COMMON.VAR'
5420       include 'COMMON.LOCAL'
5421       include 'COMMON.CHAIN'
5422       include 'COMMON.DERIV'
5423       include 'COMMON.INTERACT'
5424       include 'COMMON.FFIELD'
5425       include 'COMMON.IOUNITS'
5426       include 'COMMON.CONTROL'
5427       dimension ggg(3)
5428       double precision boxshift
5429       evdw2=0.0D0
5430       evdw2_14=0.0d0
5431       r0_scp=4.5d0
5432 cd    print '(a)','Enter ESCP'
5433 cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
5434 C      do xshift=-1,1
5435 C      do yshift=-1,1
5436 C      do zshift=-1,1
5437 c      do i=iatscp_s,iatscp_e
5438       do ikont=g_listscp_start,g_listscp_end
5439         i=newcontlistscpi(ikont)
5440         j=newcontlistscpj(ikont)
5441         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
5442         iteli=itel(i)
5443         xi=0.5D0*(c(1,i)+c(1,i+1))
5444         yi=0.5D0*(c(2,i)+c(2,i+1))
5445         zi=0.5D0*(c(3,i)+c(3,i+1))
5446 C Return atom into box, boxxsize is size of box in x dimension
5447 c  134   continue
5448 c        if (xi.gt.((xshift+0.5d0)*boxxsize)) xi=xi-boxxsize
5449 c        if (xi.lt.((xshift-0.5d0)*boxxsize)) xi=xi+boxxsize
5450 C Condition for being inside the proper box
5451 c        if ((xi.gt.((xshift+0.5d0)*boxxsize)).or.
5452 c     &       (xi.lt.((xshift-0.5d0)*boxxsize))) then
5453 c        go to 134
5454 c        endif
5455 c  135   continue
5456 c        if (yi.gt.((yshift+0.5d0)*boxysize)) yi=yi-boxysize
5457 c        if (yi.lt.((yshift-0.5d0)*boxysize)) yi=yi+boxysize
5458 C Condition for being inside the proper box
5459 c        if ((yi.gt.((yshift+0.5d0)*boxysize)).or.
5460 c     &       (yi.lt.((yshift-0.5d0)*boxysize))) then
5461 c        go to 135
5462 c c       endif
5463 c  136   continue
5464 c        if (zi.gt.((zshift+0.5d0)*boxzsize)) zi=zi-boxzsize
5465 c        if (zi.lt.((zshift-0.5d0)*boxzsize)) zi=zi+boxzsize
5466 cC Condition for being inside the proper box
5467 c        if ((zi.gt.((zshift+0.5d0)*boxzsize)).or.
5468 c     &       (zi.lt.((zshift-0.5d0)*boxzsize))) then
5469 c        go to 136
5470 c        endif
5471           call to_box(xi,yi,zi)
5472 C          xi=xi+xshift*boxxsize
5473 C          yi=yi+yshift*boxysize
5474 C          zi=zi+zshift*boxzsize
5475 c        do iint=1,nscp_gr(i)
5476
5477 c        do j=iscpstart(i,iint),iscpend(i,iint)
5478           if (itype(j).eq.ntyp1) cycle
5479           itypj=iabs(itype(j))
5480 C Uncomment following three lines for SC-p interactions
5481 c         xj=c(1,nres+j)-xi
5482 c         yj=c(2,nres+j)-yi
5483 c         zj=c(3,nres+j)-zi
5484 C Uncomment following three lines for Ca-p interactions
5485           xj=c(1,j)
5486           yj=c(2,j)
5487           zj=c(3,j)
5488           call to_box(xj,yj,zj)
5489           xj=boxshift(xj-xi,boxxsize)
5490           yj=boxshift(yj-yi,boxysize)
5491           zj=boxshift(zj-zi,boxzsize)
5492 C          xj=xj-xi
5493 C          yj=yj-yi
5494 C          zj=zj-zi
5495           rij=xj*xj+yj*yj+zj*zj
5496
5497           r0ij=r0_scp
5498           r0ijsq=r0ij*r0ij
5499           if (rij.lt.r0ijsq) then
5500             evdwij=0.25d0*(rij-r0ijsq)**2
5501             fac=rij-r0ijsq
5502           else
5503             evdwij=0.0d0
5504             fac=0.0d0
5505           endif
5506           evdw2=evdw2+evdwij
5507 C
5508 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
5509 C
5510           ggg(1)=xj*fac
5511           ggg(2)=yj*fac
5512           ggg(3)=zj*fac
5513           do k=1,3
5514             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
5515             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
5516           enddo
5517 c        enddo
5518
5519 c        enddo ! iint
5520       enddo ! i
5521 C      enddo !zshift
5522 C      enddo !yshift
5523 C      enddo !xshift
5524       return
5525       end
5526 C-----------------------------------------------------------------------------
5527       subroutine escp(evdw2,evdw2_14)
5528 C
5529 C This subroutine calculates the excluded-volume interaction energy between
5530 C peptide-group centers and side chains and its gradient in virtual-bond and
5531 C side-chain vectors.
5532 C
5533       implicit none
5534 #ifdef MPI
5535       include 'mpif.h'
5536 #endif
5537       include 'DIMENSIONS'
5538       include 'COMMON.GEO'
5539       include 'COMMON.VAR'
5540       include 'COMMON.LOCAL'
5541       include 'COMMON.CHAIN'
5542       include 'COMMON.DERIV'
5543       include 'COMMON.INTERACT'
5544       include 'COMMON.FFIELD'
5545       include 'COMMON.IOUNITS'
5546       include 'COMMON.CONTROL'
5547       include 'COMMON.SPLITELE'
5548       include 'COMMON.TIME1'
5549       double precision ggg(3)
5550       integer i,iint,j,k,iteli,itypj,subchap,ikont
5551       double precision xi,yi,zi,xj,yj,zj,rrij,sss1,sssgrad1,
5552      & fac,e1,e2,rij
5553       double precision evdw2,evdw2_14,evdwij
5554       double precision sscale,sscagrad
5555       double precision boxshift
5556       external boxshift,to_box
5557 c#ifdef TIMING_ENE
5558 c      double precision time01
5559 c#endif
5560       evdw2=0.0D0
5561       evdw2_14=0.0d0
5562 c        print *,boxxsize,boxysize,boxzsize,'wymiary pudla'
5563 cd    print '(a)','Enter ESCP'
5564 cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
5565 C      do xshift=-1,1
5566 C      do yshift=-1,1
5567 C      do zshift=-1,1
5568       if (energy_dec) write (iout,*) "escp:",r_cut_int,rlamb
5569 c      do i=iatscp_s,iatscp_e
5570       do ikont=g_listscp_start,g_listscp_end
5571 c#ifdef TIMING_ENE
5572 c        time01=MPI_Wtime()
5573 c#endif
5574         i=newcontlistscpi(ikont)
5575         j=newcontlistscpj(ikont)
5576         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
5577         iteli=itel(i)
5578         xi=0.5D0*(c(1,i)+c(1,i+1))
5579         yi=0.5D0*(c(2,i)+c(2,i+1))
5580         zi=0.5D0*(c(3,i)+c(3,i+1))
5581 !DIR$ INLINE
5582         call to_box(xi,yi,zi)
5583 c        do iint=1,nscp_gr(i)
5584
5585 c        do j=iscpstart(i,iint),iscpend(i,iint)
5586           itypj=iabs(itype(j))
5587           if (itypj.eq.ntyp1) cycle
5588 C Uncomment following three lines for SC-p interactions
5589 c         xj=c(1,nres+j)-xi
5590 c         yj=c(2,nres+j)-yi
5591 c         zj=c(3,nres+j)-zi
5592 C Uncomment following three lines for Ca-p interactions
5593           xj=c(1,j)
5594           yj=c(2,j)
5595           zj=c(3,j)
5596 !DIR$ INLINE
5597           call to_box(xj,yj,zj)
5598 c#ifdef TIMING_ENE
5599 c       time_escpsetup=time_escpsetup+MPI_Wtime()-time01
5600 c       time01=MPI_Wtime()
5601 c#endif
5602 !DIR$ INLINE
5603           xj=boxshift(xj-xi,boxxsize)
5604           yj=boxshift(yj-yi,boxysize)
5605           zj=boxshift(zj-zi,boxzsize)
5606 c          print *,xj,yj,zj,'polozenie j'
5607 c#ifdef TIMING_ENE
5608 c       time_escpsetup=time_escpsetup+MPI_Wtime()-time01
5609 c       time01=MPI_Wtime()
5610 c#endif
5611           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
5612 c          print *,rrij
5613           sss=sscale(1.0d0/(dsqrt(rrij)),r_cut_int)
5614 c          print *,r_cut,1.0d0/dsqrt(rrij),sss,'tu patrz'
5615 c          if (sss.eq.0) print *,'czasem jest OK'
5616           if (sss.le.0.0d0) cycle
5617           sssgrad=sscagrad(1.0d0/(dsqrt(rrij)),r_cut_int)
5618           fac=rrij**expon2
5619           e1=fac*fac*aad(itypj,iteli)
5620           e2=fac*bad(itypj,iteli)
5621           if (iabs(j-i) .le. 2) then
5622             e1=scal14*e1
5623             e2=scal14*e2
5624             evdw2_14=evdw2_14+(e1+e2)*sss
5625           endif
5626           evdwij=e1+e2
5627           evdw2=evdw2+evdwij*sss
5628           if (energy_dec) write (iout,'(a6,2i5,3f7.3,2i3,3e11.3)')
5629      &        'evdw2',i,j,1.0d0/dsqrt(rrij),sss,
5630      &       evdwij,iteli,itypj,fac,aad(itypj,iteli),
5631      &       bad(itypj,iteli)
5632 C
5633 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
5634 C
5635           fac=-(evdwij+e1)*rrij*sss
5636           fac=fac+(evdwij)*sssgrad*dsqrt(rrij)/expon
5637           ggg(1)=xj*fac
5638           ggg(2)=yj*fac
5639           ggg(3)=zj*fac
5640 cgrad          if (j.lt.i) then
5641 cd          write (iout,*) 'j<i'
5642 C Uncomment following three lines for SC-p interactions
5643 c           do k=1,3
5644 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
5645 c           enddo
5646 cgrad          else
5647 cd          write (iout,*) 'j>i'
5648 cgrad            do k=1,3
5649 cgrad              ggg(k)=-ggg(k)
5650 C Uncomment following line for SC-p interactions
5651 ccgrad             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
5652 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
5653 cgrad            enddo
5654 cgrad          endif
5655 cgrad          do k=1,3
5656 cgrad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
5657 cgrad          enddo
5658 cgrad          kstart=min0(i+1,j)
5659 cgrad          kend=max0(i-1,j-1)
5660 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
5661 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
5662 cgrad          do k=kstart,kend
5663 cgrad            do l=1,3
5664 cgrad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
5665 cgrad            enddo
5666 cgrad          enddo
5667           do k=1,3
5668             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
5669             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
5670           enddo
5671 c#ifdef TIMING_ENE
5672 c          time_escpcalc=time_escpcalc+MPI_Wtime()-time01
5673 c#endif
5674 c        endif !endif for sscale cutoff
5675 c        enddo ! j
5676
5677 c        enddo ! iint
5678       enddo ! i
5679 c      enddo !zshift
5680 c      enddo !yshift
5681 c      enddo !xshift
5682       do i=1,nct
5683         do j=1,3
5684           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
5685           gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
5686           gradx_scp(j,i)=expon*gradx_scp(j,i)
5687         enddo
5688       enddo
5689 C******************************************************************************
5690 C
5691 C                              N O T E !!!
5692 C
5693 C To save time the factor EXPON has been extracted from ALL components
5694 C of GVDWC and GRADX. Remember to multiply them by this factor before further
5695 C use!
5696 C
5697 C******************************************************************************
5698       return
5699       end
5700 C--------------------------------------------------------------------------
5701       subroutine edis(ehpb)
5702 C
5703 C Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors.
5704 C
5705       implicit real*8 (a-h,o-z)
5706       include 'DIMENSIONS'
5707       include 'COMMON.SBRIDGE'
5708       include 'COMMON.CHAIN'
5709       include 'COMMON.DERIV'
5710       include 'COMMON.VAR'
5711       include 'COMMON.INTERACT'
5712       include 'COMMON.IOUNITS'
5713       include 'COMMON.CONTROL'
5714       dimension ggg(3),ggg_peak(3,1000)
5715       ehpb=0.0D0
5716       do i=1,3
5717        ggg(i)=0.0d0
5718       enddo
5719 c 8/21/18 AL: added explicit restraints on reference coords
5720 c      write (iout,*) "restr_on_coord",restr_on_coord
5721       if (restr_on_coord) then
5722
5723       do i=nnt,nct
5724         ecoor=0.0d0
5725         if (itype(i).eq.ntyp1) cycle
5726         do j=1,3
5727           ecoor=ecoor+(c(j,i)-cref(j,i))**2
5728           ghpbc(j,i)=ghpbc(j,i)+bfac(i)*(c(j,i)-cref(j,i))
5729         enddo
5730         if (itype(i).ne.10) then
5731           do j=1,3
5732             ecoor=ecoor+(c(j,i+nres)-cref(j,i+nres))**2
5733             ghpbx(j,i)=ghpbx(j,i)+bfac(i)*(c(j,i+nres)-cref(j,i+nres))
5734           enddo
5735         endif
5736         if (energy_dec) write (iout,*)
5737      &     "i",i," bfac",bfac(i)," ecoor",ecoor
5738         ehpb=ehpb+0.5d0*bfac(i)*ecoor
5739       enddo
5740
5741       endif
5742 C      write (iout,*) ,"link_end",link_end,constr_dist
5743 cd      write(iout,*)'edis: nhpb=',nhpb,' fbr=',fbr
5744 c      write(iout,*)'link_start=',link_start,' link_end=',link_end,
5745 c     &  " constr_dist",constr_dist," link_start_peak",link_start_peak,
5746 c     &  " link_end_peak",link_end_peak
5747       if (link_end.eq.0.and.link_end_peak.eq.0) return
5748       do i=link_start_peak,link_end_peak
5749         ehpb_peak=0.0d0
5750 c        print *,"i",i," link_end_peak",link_end_peak," ipeak",
5751 c     &   ipeak(1,i),ipeak(2,i)
5752         do ip=ipeak(1,i),ipeak(2,i)
5753           ii=ihpb_peak(ip)
5754           jj=jhpb_peak(ip)
5755           dd=dist(ii,jj)
5756           iip=ip-ipeak(1,i)+1
5757 C iii and jjj point to the residues for which the distance is assigned.
5758 c          if (ii.gt.nres) then
5759 c            iii=ii-nres
5760 c            jjj=jj-nres
5761 c          else
5762 c            iii=ii
5763 c            jjj=jj
5764 c          endif
5765           if (ii.gt.nres) then
5766             iii=ii-nres
5767           else
5768             iii=ii
5769           endif
5770           if (jj.gt.nres) then
5771             jjj=jj-nres
5772           else
5773             jjj=jj
5774           endif
5775           aux=rlornmr1(dd,dhpb_peak(ip),dhpb1_peak(ip),forcon_peak(ip))
5776           aux=dexp(-scal_peak*aux)
5777           ehpb_peak=ehpb_peak+aux
5778           fac=rlornmr1prim(dd,dhpb_peak(ip),dhpb1_peak(ip),
5779      &      forcon_peak(ip))*aux/dd
5780           do j=1,3
5781             ggg_peak(j,iip)=fac*(c(j,jj)-c(j,ii))
5782           enddo
5783           if (energy_dec) write (iout,'(a6,3i5,6f10.3,i5)')
5784      &      "edisL",i,ii,jj,dd,dhpb_peak(ip),dhpb1_peak(ip),
5785      &      forcon_peak(ip),fordepth_peak(ip),ehpb_peak
5786         enddo
5787 c        write (iout,*) "ehpb_peak",ehpb_peak," scal_peak",scal_peak
5788         ehpb=ehpb-fordepth_peak(ipeak(1,i))*dlog(ehpb_peak)/scal_peak
5789         do ip=ipeak(1,i),ipeak(2,i)
5790           iip=ip-ipeak(1,i)+1
5791           do j=1,3
5792             ggg(j)=ggg_peak(j,iip)/ehpb_peak
5793           enddo
5794           ii=ihpb_peak(ip)
5795           jj=jhpb_peak(ip)
5796 C iii and jjj point to the residues for which the distance is assigned.
5797 c          if (ii.gt.nres) then
5798 c            iii=ii-nres
5799 c            jjj=jj-nres
5800 c          else
5801 c            iii=ii
5802 c            jjj=jj
5803 c          endif
5804           if (ii.gt.nres) then
5805             iii=ii-nres
5806           else
5807             iii=ii
5808           endif
5809           if (jj.gt.nres) then
5810             jjj=jj-nres
5811           else
5812             jjj=jj
5813           endif
5814           if (iii.lt.ii) then
5815             do j=1,3
5816               ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
5817             enddo
5818           endif
5819           if (jjj.lt.jj) then
5820             do j=1,3
5821               ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
5822             enddo
5823           endif
5824           do k=1,3
5825             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
5826             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
5827           enddo
5828         enddo
5829       enddo
5830       do i=link_start,link_end
5831 C If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a
5832 C CA-CA distance used in regularization of structure.
5833         ii=ihpb(i)
5834         jj=jhpb(i)
5835 C iii and jjj point to the residues for which the distance is assigned.
5836         if (ii.gt.nres) then
5837           iii=ii-nres
5838         else
5839           iii=ii
5840         endif
5841         if (jj.gt.nres) then
5842           jjj=jj-nres
5843         else
5844           jjj=jj
5845         endif
5846 c        write (iout,*) "i",i," ii",ii," iii",iii," jj",jj," jjj",jjj,
5847 c     &    dhpb(i),dhpb1(i),forcon(i)
5848 C 24/11/03 AL: SS bridges handled separately because of introducing a specific
5849 C    distance and angle dependent SS bond potential.
5850 C        if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and.
5851 C     & iabs(itype(jjj)).eq.1) then
5852 cmc        if (ii.gt.nres .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then
5853 C 18/07/06 MC: Use the convention that the first nss pairs are SS bonds
5854         if (.not.dyn_ss .and. i.le.nss) then
5855 C 15/02/13 CC dynamic SSbond - additional check
5856           if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and.
5857      &        iabs(itype(jjj)).eq.1) then
5858            call ssbond_ene(iii,jjj,eij)
5859 c           ehpb=ehpb+2*eij
5860            ehpb=ehpb+eij
5861          endif
5862 cd          write (iout,*) "eij",eij
5863 cd   &   ' waga=',waga,' fac=',fac
5864 !        else if (ii.gt.nres .and. jj.gt.nres) then
5865         else
5866 C Calculate the distance between the two points and its difference from the
5867 C target distance.
5868           dd=dist(ii,jj)
5869           if (irestr_type(i).eq.11) then
5870             ehpb=ehpb+fordepth(i)!**4.0d0
5871      &           *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i))
5872             fac=fordepth(i)!**4.0d0
5873      &           *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd
5874             if (energy_dec) write (iout,'(a6,2i5,6f10.3,i5)')
5875      &        "edisL",ii,jj,dd,dhpb(i),dhpb1(i),forcon(i),fordepth(i),
5876      &        ehpb,irestr_type(i)
5877           else if (irestr_type(i).eq.10) then
5878 c AL 6//19/2018 cross-link restraints
5879             xdis = 0.5d0*(dd/forcon(i))**2
5880             expdis = dexp(-xdis)
5881 c            aux=(dhpb(i)+dhpb1(i)*xdis)*expdis+fordepth(i)
5882             aux=(dhpb(i)+dhpb1(i)*xdis*xdis)*expdis+fordepth(i)
5883 c            write (iout,*)"HERE: xdis",xdis," expdis",expdis," aux",aux,
5884 c     &          " wboltzd",wboltzd
5885             ehpb=ehpb-wboltzd*xlscore(i)*dlog(aux)
5886 c            fac=-wboltzd*(dhpb1(i)*(1.0d0-xdis)-dhpb(i))
5887             fac=-wboltzd*xlscore(i)*(dhpb1(i)*(2.0d0-xdis)*xdis-dhpb(i))
5888      &           *expdis/(aux*forcon(i)**2)
5889             if (energy_dec) write(iout,'(a6,2i5,6f10.3,i5)')
5890      &        "edisX",ii,jj,dd,dhpb(i),dhpb1(i),forcon(i),fordepth(i),
5891      &        -wboltzd*xlscore(i)*dlog(aux),irestr_type(i)
5892           else if (irestr_type(i).eq.2) then
5893 c Quartic restraints
5894             ehpb=ehpb+forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
5895             if (energy_dec) write(iout,'(a6,2i5,5f10.3,i5)')
5896      &      "edisQ",ii,jj,dd,dhpb(i),dhpb1(i),forcon(i),
5897      &      forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i)),irestr_type(i)
5898             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
5899           else
5900 c Quadratic restraints
5901             rdis=dd-dhpb(i)
5902 C Get the force constant corresponding to this distance.
5903             waga=forcon(i)
5904 C Calculate the contribution to energy.
5905             ehpb=ehpb+0.5d0*waga*rdis*rdis
5906             if (energy_dec) write(iout,'(a6,2i5,5f10.3,i5)')
5907      &      "edisS",ii,jj,dd,dhpb(i),dhpb1(i),forcon(i),
5908      &       0.5d0*waga*rdis*rdis,irestr_type(i)
5909 C
5910 C Evaluate gradient.
5911 C
5912             fac=waga*rdis/dd
5913           endif
5914 c Calculate Cartesian gradient
5915           do j=1,3
5916             ggg(j)=fac*(c(j,jj)-c(j,ii))
5917           enddo
5918 cd      print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
5919 C If this is a SC-SC distance, we need to calculate the contributions to the
5920 C Cartesian gradient in the SC vectors (ghpbx).
5921           if (iii.lt.ii) then
5922             do j=1,3
5923               ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
5924             enddo
5925           endif
5926           if (jjj.lt.jj) then
5927             do j=1,3
5928               ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
5929             enddo
5930           endif
5931           do k=1,3
5932             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
5933             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
5934           enddo
5935         endif
5936       enddo
5937       return
5938       end
5939 C--------------------------------------------------------------------------
5940       subroutine ssbond_ene(i,j,eij)
5941 C
5942 C Calculate the distance and angle dependent SS-bond potential energy
5943 C using a free-energy function derived based on RHF/6-31G** ab initio
5944 C calculations of diethyl disulfide.
5945 C
5946 C A. Liwo and U. Kozlowska, 11/24/03
5947 C
5948       implicit real*8 (a-h,o-z)
5949       include 'DIMENSIONS'
5950       include 'COMMON.SBRIDGE'
5951       include 'COMMON.CHAIN'
5952       include 'COMMON.DERIV'
5953       include 'COMMON.LOCAL'
5954       include 'COMMON.INTERACT'
5955       include 'COMMON.VAR'
5956       include 'COMMON.IOUNITS'
5957       double precision erij(3),dcosom1(3),dcosom2(3),gg(3)
5958       itypi=iabs(itype(i))
5959       xi=c(1,nres+i)
5960       yi=c(2,nres+i)
5961       zi=c(3,nres+i)
5962       dxi=dc_norm(1,nres+i)
5963       dyi=dc_norm(2,nres+i)
5964       dzi=dc_norm(3,nres+i)
5965 c      dsci_inv=dsc_inv(itypi)
5966       dsci_inv=vbld_inv(nres+i)
5967       itypj=iabs(itype(j))
5968 c      dscj_inv=dsc_inv(itypj)
5969       dscj_inv=vbld_inv(nres+j)
5970       xj=c(1,nres+j)-xi
5971       yj=c(2,nres+j)-yi
5972       zj=c(3,nres+j)-zi
5973       dxj=dc_norm(1,nres+j)
5974       dyj=dc_norm(2,nres+j)
5975       dzj=dc_norm(3,nres+j)
5976       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
5977       rij=dsqrt(rrij)
5978       erij(1)=xj*rij
5979       erij(2)=yj*rij
5980       erij(3)=zj*rij
5981       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
5982       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
5983       om12=dxi*dxj+dyi*dyj+dzi*dzj
5984       do k=1,3
5985         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
5986         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
5987       enddo
5988       rij=1.0d0/rij
5989       deltad=rij-d0cm
5990       deltat1=1.0d0-om1
5991       deltat2=1.0d0+om2
5992       deltat12=om2-om1+2.0d0
5993       cosphi=om12-om1*om2
5994       eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2)
5995      &  +akct*deltad*deltat12
5996      &  +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi+ebr
5997 c      write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth,
5998 c     &  " akct",akct," deltad",deltad," deltat",deltat1,deltat2,
5999 c     &  " deltat12",deltat12," eij",eij
6000       ed=2*akcm*deltad+akct*deltat12
6001       pom1=akct*deltad
6002       pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
6003       eom1=-2*akth*deltat1-pom1-om2*pom2
6004       eom2= 2*akth*deltat2+pom1-om1*pom2
6005       eom12=pom2
6006       do k=1,3
6007         ggk=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
6008         ghpbx(k,i)=ghpbx(k,i)-ggk
6009      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
6010      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
6011         ghpbx(k,j)=ghpbx(k,j)+ggk
6012      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
6013      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
6014         ghpbc(k,i)=ghpbc(k,i)-ggk
6015         ghpbc(k,j)=ghpbc(k,j)+ggk
6016       enddo
6017 C
6018 C Calculate the components of the gradient in DC and X
6019 C
6020 cgrad      do k=i,j-1
6021 cgrad        do l=1,3
6022 cgrad          ghpbc(l,k)=ghpbc(l,k)+gg(l)
6023 cgrad        enddo
6024 cgrad      enddo
6025       return
6026       end
6027 C--------------------------------------------------------------------------
6028       subroutine ebond(estr)
6029 c
6030 c Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
6031 c
6032       implicit real*8 (a-h,o-z)
6033       include 'DIMENSIONS'
6034       include 'COMMON.LOCAL'
6035       include 'COMMON.GEO'
6036       include 'COMMON.INTERACT'
6037       include 'COMMON.DERIV'
6038       include 'COMMON.VAR'
6039       include 'COMMON.CHAIN'
6040       include 'COMMON.IOUNITS'
6041       include 'COMMON.NAMES'
6042       include 'COMMON.FFIELD'
6043       include 'COMMON.CONTROL'
6044       include 'COMMON.SETUP'
6045       double precision u(3),ud(3)
6046       estr=0.0d0
6047       estr1=0.0d0
6048       do i=ibondp_start,ibondp_end
6049 c  3/4/2020 Adam: removed dummy bond graient if Calpha and SC coords are
6050 c      used
6051 #ifdef FIVEDIAG
6052         if (itype(i-1).eq.ntyp1 .or. itype(i).eq.ntyp1) cycle
6053         diff = vbld(i)-vbldp0
6054 #else
6055         if (itype(i-1).eq.ntyp1 .and. itype(i).eq.ntyp1) cycle
6056 c          estr1=estr1+gnmr1(vbld(i),-1.0d0,distchainmax)
6057 c          do j=1,3
6058 c          gradb(j,i-1)=gnmr1prim(vbld(i),-1.0d0,distchainmax)
6059 c     &      *dc(j,i-1)/vbld(i)
6060 c          enddo
6061 c          if (energy_dec) write(iout,*)
6062 c     &       "estr1",i,gnmr1(vbld(i),-1.0d0,distchainmax)
6063 c        else
6064 C       Checking if it involves dummy (NH3+ or COO-) group
6065         if (itype(i-1).eq.ntyp1 .or. itype(i).eq.ntyp1) then
6066 C YES   vbldpDUM is the equlibrium length of spring for Dummy atom
6067           diff = vbld(i)-vbldpDUM
6068           if (energy_dec) write(iout,*) "dum_bond",i,diff
6069         else
6070 C NO    vbldp0 is the equlibrium length of spring for peptide group
6071           diff = vbld(i)-vbldp0
6072         endif
6073 #endif
6074         if (energy_dec) write (iout,'(a7,i5,4f7.3)')
6075      &     "estr bb",i,vbld(i),vbldp0,diff,AKP*diff*diff
6076         estr=estr+diff*diff
6077         do j=1,3
6078           gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)
6079         enddo
6080 c        write (iout,'(i5,3f10.5)') i,(gradb(j,i-1),j=1,3)
6081 c        endif
6082       enddo
6083
6084       estr=0.5d0*AKP*estr+estr1
6085 c
6086 c 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included
6087 c
6088       do i=ibond_start,ibond_end
6089         iti=iabs(itype(i))
6090         if (iti.ne.10 .and. iti.ne.ntyp1) then
6091           nbi=nbondterm(iti)
6092           if (nbi.eq.1) then
6093             diff=vbld(i+nres)-vbldsc0(1,iti)
6094             if (energy_dec)  write (iout,*)
6095      &      "estr sc",i,iti,vbld(i+nres),vbldsc0(1,iti),diff,
6096      &      AKSC(1,iti),AKSC(1,iti)*diff*diff
6097             estr=estr+0.5d0*AKSC(1,iti)*diff*diff
6098             do j=1,3
6099               gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
6100             enddo
6101           else
6102             do j=1,nbi
6103               diff=vbld(i+nres)-vbldsc0(j,iti)
6104               ud(j)=aksc(j,iti)*diff
6105               u(j)=abond0(j,iti)+0.5d0*ud(j)*diff
6106             enddo
6107             uprod=u(1)
6108             do j=2,nbi
6109               uprod=uprod*u(j)
6110             enddo
6111             usum=0.0d0
6112             usumsqder=0.0d0
6113             do j=1,nbi
6114               uprod1=1.0d0
6115               uprod2=1.0d0
6116               do k=1,nbi
6117                 if (k.ne.j) then
6118                   uprod1=uprod1*u(k)
6119                   uprod2=uprod2*u(k)*u(k)
6120                 endif
6121               enddo
6122               usum=usum+uprod1
6123               usumsqder=usumsqder+ud(j)*uprod2
6124             enddo
6125             estr=estr+uprod/usum
6126             do j=1,3
6127              gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
6128             enddo
6129           endif
6130         endif
6131       enddo
6132       return
6133       end
6134 #ifdef CRYST_THETA
6135 C--------------------------------------------------------------------------
6136       subroutine ebend(etheta)
6137 C
6138 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
6139 C angles gamma and its derivatives in consecutive thetas and gammas.
6140 C
6141       implicit real*8 (a-h,o-z)
6142       include 'DIMENSIONS'
6143       include 'COMMON.LOCAL'
6144       include 'COMMON.GEO'
6145       include 'COMMON.INTERACT'
6146       include 'COMMON.DERIV'
6147       include 'COMMON.VAR'
6148       include 'COMMON.CHAIN'
6149       include 'COMMON.IOUNITS'
6150       include 'COMMON.NAMES'
6151       include 'COMMON.FFIELD'
6152       include 'COMMON.CONTROL'
6153       include 'COMMON.TORCNSTR'
6154       common /calcthet/ term1,term2,termm,diffak,ratak,
6155      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
6156      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
6157       double precision y(2),z(2)
6158       delta=0.02d0*pi
6159 c      time11=dexp(-2*time)
6160 c      time12=1.0d0
6161       etheta=0.0D0
6162 c     write (*,'(a,i2)') 'EBEND ICG=',icg
6163       do i=ithet_start,ithet_end
6164         if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
6165      &  .or.itype(i).eq.ntyp1) cycle
6166 C Zero the energy function and its derivative at 0 or pi.
6167         call splinthet(theta(i),0.5d0*delta,ss,ssd)
6168         it=itype(i-1)
6169         ichir1=isign(1,itype(i-2))
6170         ichir2=isign(1,itype(i))
6171          if (itype(i-2).eq.10) ichir1=isign(1,itype(i-1))
6172          if (itype(i).eq.10) ichir2=isign(1,itype(i-1))
6173          if (itype(i-1).eq.10) then
6174           itype1=isign(10,itype(i-2))
6175           ichir11=isign(1,itype(i-2))
6176           ichir12=isign(1,itype(i-2))
6177           itype2=isign(10,itype(i))
6178           ichir21=isign(1,itype(i))
6179           ichir22=isign(1,itype(i))
6180          endif
6181
6182         if (i.gt.3 .and. itype(i-3).ne.ntyp1) then
6183 #ifdef OSF
6184           phii=phi(i)
6185           if (phii.ne.phii) phii=150.0
6186 #else
6187           phii=phi(i)
6188 #endif
6189           y(1)=dcos(phii)
6190           y(2)=dsin(phii)
6191         else
6192           y(1)=0.0D0
6193           y(2)=0.0D0
6194         endif
6195         if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
6196 #ifdef OSF
6197           phii1=phi(i+1)
6198           if (phii1.ne.phii1) phii1=150.0
6199           phii1=pinorm(phii1)
6200           z(1)=cos(phii1)
6201 #else
6202           phii1=phi(i+1)
6203 #endif
6204           z(1)=dcos(phii1)
6205           z(2)=dsin(phii1)
6206         else
6207           z(1)=0.0D0
6208           z(2)=0.0D0
6209         endif
6210 C Calculate the "mean" value of theta from the part of the distribution
6211 C dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2).
6212 C In following comments this theta will be referred to as t_c.
6213         thet_pred_mean=0.0d0
6214         do k=1,2
6215             athetk=athet(k,it,ichir1,ichir2)
6216             bthetk=bthet(k,it,ichir1,ichir2)
6217           if (it.eq.10) then
6218              athetk=athet(k,itype1,ichir11,ichir12)
6219              bthetk=bthet(k,itype2,ichir21,ichir22)
6220           endif
6221          thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k)
6222 c         write(iout,*) 'chuj tu', y(k),z(k)
6223         enddo
6224         dthett=thet_pred_mean*ssd
6225         thet_pred_mean=thet_pred_mean*ss+a0thet(it)
6226 C Derivatives of the "mean" values in gamma1 and gamma2.
6227         dthetg1=(-athet(1,it,ichir1,ichir2)*y(2)
6228      &+athet(2,it,ichir1,ichir2)*y(1))*ss
6229          dthetg2=(-bthet(1,it,ichir1,ichir2)*z(2)
6230      &          +bthet(2,it,ichir1,ichir2)*z(1))*ss
6231          if (it.eq.10) then
6232       dthetg1=(-athet(1,itype1,ichir11,ichir12)*y(2)
6233      &+athet(2,itype1,ichir11,ichir12)*y(1))*ss
6234         dthetg2=(-bthet(1,itype2,ichir21,ichir22)*z(2)
6235      &         +bthet(2,itype2,ichir21,ichir22)*z(1))*ss
6236          endif
6237         if (theta(i).gt.pi-delta) then
6238           call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,
6239      &         E_tc0)
6240           call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0)
6241           call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
6242           call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,
6243      &        E_theta)
6244           call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,
6245      &        E_tc)
6246         else if (theta(i).lt.delta) then
6247           call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0)
6248           call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
6249           call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,
6250      &        E_theta)
6251           call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0)
6252           call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,
6253      &        E_tc)
6254         else
6255           call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,
6256      &        E_theta,E_tc)
6257         endif
6258         etheta=etheta+ethetai
6259         if (energy_dec) write (iout,'(a6,i5,0pf7.3,f7.3,i5)')
6260      &      'ebend',i,ethetai,theta(i),itype(i)
6261         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1
6262         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2
6263         gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)+gloc(nphi+i-2,icg)
6264       enddo
6265
6266 C Ufff.... We've done all this!!!
6267       return
6268       end
6269 C---------------------------------------------------------------------------
6270       subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,
6271      &     E_tc)
6272       implicit real*8 (a-h,o-z)
6273       include 'DIMENSIONS'
6274       include 'COMMON.LOCAL'
6275       include 'COMMON.IOUNITS'
6276       common /calcthet/ term1,term2,termm,diffak,ratak,
6277      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
6278      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
6279 C Calculate the contributions to both Gaussian lobes.
6280 C 6/6/97 - Deform the Gaussians using the factor of 1/(1+time)
6281 C The "polynomial part" of the "standard deviation" of this part of
6282 C the distributioni.
6283 ccc        write (iout,*) thetai,thet_pred_mean
6284         sig=polthet(3,it)
6285         do j=2,0,-1
6286           sig=sig*thet_pred_mean+polthet(j,it)
6287         enddo
6288 C Derivative of the "interior part" of the "standard deviation of the"
6289 C gamma-dependent Gaussian lobe in t_c.
6290         sigtc=3*polthet(3,it)
6291         do j=2,1,-1
6292           sigtc=sigtc*thet_pred_mean+j*polthet(j,it)
6293         enddo
6294         sigtc=sig*sigtc
6295 C Set the parameters of both Gaussian lobes of the distribution.
6296 C "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc)
6297         fac=sig*sig+sigc0(it)
6298         sigcsq=fac+fac
6299         sigc=1.0D0/sigcsq
6300 C Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c
6301         sigsqtc=-4.0D0*sigcsq*sigtc
6302 c       print *,i,sig,sigtc,sigsqtc
6303 C Following variable (sigtc) is d[sigma(t_c)]/dt_c
6304         sigtc=-sigtc/(fac*fac)
6305 C Following variable is sigma(t_c)**(-2)
6306         sigcsq=sigcsq*sigcsq
6307         sig0i=sig0(it)
6308         sig0inv=1.0D0/sig0i**2
6309         delthec=thetai-thet_pred_mean
6310         delthe0=thetai-theta0i
6311         term1=-0.5D0*sigcsq*delthec*delthec
6312         term2=-0.5D0*sig0inv*delthe0*delthe0
6313 C        write (iout,*)'term1',term1,term2,sigcsq,delthec,sig0inv,delthe0
6314 C Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and
6315 C NaNs in taking the logarithm. We extract the largest exponent which is added
6316 C to the energy (this being the log of the distribution) at the end of energy
6317 C term evaluation for this virtual-bond angle.
6318         if (term1.gt.term2) then
6319           termm=term1
6320           term2=dexp(term2-termm)
6321           term1=1.0d0
6322         else
6323           termm=term2
6324           term1=dexp(term1-termm)
6325           term2=1.0d0
6326         endif
6327 C The ratio between the gamma-independent and gamma-dependent lobes of
6328 C the distribution is a Gaussian function of thet_pred_mean too.
6329         diffak=gthet(2,it)-thet_pred_mean
6330         ratak=diffak/gthet(3,it)**2
6331         ak=dexp(gthet(1,it)-0.5D0*diffak*ratak)
6332 C Let's differentiate it in thet_pred_mean NOW.
6333         aktc=ak*ratak
6334 C Now put together the distribution terms to make complete distribution.
6335         termexp=term1+ak*term2
6336         termpre=sigc+ak*sig0i
6337 C Contribution of the bending energy from this theta is just the -log of
6338 C the sum of the contributions from the two lobes and the pre-exponential
6339 C factor. Simple enough, isn't it?
6340         ethetai=(-dlog(termexp)-termm+dlog(termpre))
6341 C       write (iout,*) 'termexp',termexp,termm,termpre,i
6342 C NOW the derivatives!!!
6343 C 6/6/97 Take into account the deformation.
6344         E_theta=(delthec*sigcsq*term1
6345      &       +ak*delthe0*sig0inv*term2)/termexp
6346         E_tc=((sigtc+aktc*sig0i)/termpre
6347      &      -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+
6348      &       aktc*term2)/termexp)
6349       return
6350       end
6351 c-----------------------------------------------------------------------------
6352       subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)
6353       implicit real*8 (a-h,o-z)
6354       include 'DIMENSIONS'
6355       include 'COMMON.LOCAL'
6356       include 'COMMON.IOUNITS'
6357       common /calcthet/ term1,term2,termm,diffak,ratak,
6358      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
6359      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
6360       delthec=thetai-thet_pred_mean
6361       delthe0=thetai-theta0i
6362 C "Thank you" to MAPLE (probably spared one day of hand-differentiation).
6363       t3 = thetai-thet_pred_mean
6364       t6 = t3**2
6365       t9 = term1
6366       t12 = t3*sigcsq
6367       t14 = t12+t6*sigsqtc
6368       t16 = 1.0d0
6369       t21 = thetai-theta0i
6370       t23 = t21**2
6371       t26 = term2
6372       t27 = t21*t26
6373       t32 = termexp
6374       t40 = t32**2
6375       E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9
6376      & -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40
6377      & *(-t12*t9-ak*sig0inv*t27)
6378       return
6379       end
6380 #else
6381 C--------------------------------------------------------------------------
6382       subroutine ebend(etheta)
6383 C
6384 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
6385 C angles gamma and its derivatives in consecutive thetas and gammas.
6386 C ab initio-derived potentials from
6387 c Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203
6388 C
6389       implicit real*8 (a-h,o-z)
6390       include 'DIMENSIONS'
6391       include 'COMMON.LOCAL'
6392       include 'COMMON.GEO'
6393       include 'COMMON.INTERACT'
6394       include 'COMMON.DERIV'
6395       include 'COMMON.VAR'
6396       include 'COMMON.CHAIN'
6397       include 'COMMON.IOUNITS'
6398       include 'COMMON.NAMES'
6399       include 'COMMON.FFIELD'
6400       include 'COMMON.CONTROL'
6401       include 'COMMON.TORCNSTR'
6402       double precision coskt(mmaxtheterm),sinkt(mmaxtheterm),
6403      & cosph1(maxsingle),sinph1(maxsingle),cosph2(maxsingle),
6404      & sinph2(maxsingle),cosph1ph2(maxdouble,maxdouble),
6405      & sinph1ph2(maxdouble,maxdouble)
6406       logical lprn /.false./, lprn1 /.false./
6407       etheta=0.0D0
6408       do i=ithet_start,ithet_end
6409 c        print *,i,itype(i-1),itype(i),itype(i-2)
6410         if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
6411      &  .or.itype(i).eq.ntyp1) cycle
6412 C        print *,i,theta(i)
6413         if (iabs(itype(i+1)).eq.20) iblock=2
6414         if (iabs(itype(i+1)).ne.20) iblock=1
6415         dethetai=0.0d0
6416         dephii=0.0d0
6417         dephii1=0.0d0
6418         theti2=0.5d0*theta(i)
6419         ityp2=ithetyp((itype(i-1)))
6420         do k=1,nntheterm
6421           coskt(k)=dcos(k*theti2)
6422           sinkt(k)=dsin(k*theti2)
6423         enddo
6424 C        print *,ethetai
6425         if (i.gt.3 .and. itype(i-3).ne.ntyp1) then
6426 #ifdef OSF
6427           phii=phi(i)
6428           if (phii.ne.phii) phii=150.0
6429 #else
6430           phii=phi(i)
6431 #endif
6432           ityp1=ithetyp((itype(i-2)))
6433 C propagation of chirality for glycine type
6434           do k=1,nsingle
6435             cosph1(k)=dcos(k*phii)
6436             sinph1(k)=dsin(k*phii)
6437           enddo
6438         else
6439           phii=0.0d0
6440           do k=1,nsingle
6441           ityp1=ithetyp((itype(i-2)))
6442             cosph1(k)=0.0d0
6443             sinph1(k)=0.0d0
6444           enddo
6445         endif
6446         if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
6447 #ifdef OSF
6448           phii1=phi(i+1)
6449           if (phii1.ne.phii1) phii1=150.0
6450           phii1=pinorm(phii1)
6451 #else
6452           phii1=phi(i+1)
6453 #endif
6454           ityp3=ithetyp((itype(i)))
6455           do k=1,nsingle
6456             cosph2(k)=dcos(k*phii1)
6457             sinph2(k)=dsin(k*phii1)
6458           enddo
6459         else
6460           phii1=0.0d0
6461           ityp3=ithetyp((itype(i)))
6462           do k=1,nsingle
6463             cosph2(k)=0.0d0
6464             sinph2(k)=0.0d0
6465           enddo
6466         endif
6467         ethetai=aa0thet(ityp1,ityp2,ityp3,iblock)
6468         do k=1,ndouble
6469           do l=1,k-1
6470             ccl=cosph1(l)*cosph2(k-l)
6471             ssl=sinph1(l)*sinph2(k-l)
6472             scl=sinph1(l)*cosph2(k-l)
6473             csl=cosph1(l)*sinph2(k-l)
6474             cosph1ph2(l,k)=ccl-ssl
6475             cosph1ph2(k,l)=ccl+ssl
6476             sinph1ph2(l,k)=scl+csl
6477             sinph1ph2(k,l)=scl-csl
6478           enddo
6479         enddo
6480         if (lprn) then
6481         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,
6482      &    " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
6483         write (iout,*) "coskt and sinkt"
6484         do k=1,nntheterm
6485           write (iout,*) k,coskt(k),sinkt(k)
6486         enddo
6487         endif
6488         do k=1,ntheterm
6489           ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3,iblock)*sinkt(k)
6490           dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3,iblock)
6491      &      *coskt(k)
6492           if (lprn)
6493      &    write (iout,*) "k",k,"
6494      &     aathet",aathet(k,ityp1,ityp2,ityp3,iblock),
6495      &     " ethetai",ethetai
6496         enddo
6497         if (lprn) then
6498         write (iout,*) "cosph and sinph"
6499         do k=1,nsingle
6500           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
6501         enddo
6502         write (iout,*) "cosph1ph2 and sinph2ph2"
6503         do k=2,ndouble
6504           do l=1,k-1
6505             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),
6506      &         sinph1ph2(l,k),sinph1ph2(k,l)
6507           enddo
6508         enddo
6509         write(iout,*) "ethetai",ethetai
6510         endif
6511 C       print *,ethetai
6512         do m=1,ntheterm2
6513           do k=1,nsingle
6514             aux=bbthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)
6515      &         +ccthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k)
6516      &         +ddthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)
6517      &         +eethet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k)
6518             ethetai=ethetai+sinkt(m)*aux
6519             dethetai=dethetai+0.5d0*m*aux*coskt(m)
6520             dephii=dephii+k*sinkt(m)*(
6521      &          ccthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)-
6522      &          bbthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k))
6523             dephii1=dephii1+k*sinkt(m)*(
6524      &          eethet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)-
6525      &          ddthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k))
6526             if (lprn)
6527      &      write (iout,*) "m",m," k",k," bbthet",
6528      &         bbthet(k,m,ityp1,ityp2,ityp3,iblock)," ccthet",
6529      &         ccthet(k,m,ityp1,ityp2,ityp3,iblock)," ddthet",
6530      &         ddthet(k,m,ityp1,ityp2,ityp3,iblock)," eethet",
6531      &         eethet(k,m,ityp1,ityp2,ityp3,iblock)," ethetai",ethetai
6532 C        print *,"tu",cosph1(k),sinph1(k),cosph2(k),sinph2(k)
6533           enddo
6534         enddo
6535 C        print *,"cosph1", (cosph1(k), k=1,nsingle)
6536 C        print *,"cosph2", (cosph2(k), k=1,nsingle)
6537 C        print *,"sinph1", (sinph1(k), k=1,nsingle)
6538 C        print *,"sinph2", (sinph2(k), k=1,nsingle)
6539         if (lprn)
6540      &  write(iout,*) "ethetai",ethetai
6541 C        print *,"tu",cosph1(k),sinph1(k),cosph2(k),sinph2(k)
6542         do m=1,ntheterm3
6543           do k=2,ndouble
6544             do l=1,k-1
6545               aux=ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
6546      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l)+
6547      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
6548      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)
6549               ethetai=ethetai+sinkt(m)*aux
6550               dethetai=dethetai+0.5d0*m*coskt(m)*aux
6551               dephii=dephii+l*sinkt(m)*(
6552      &           -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)-
6553      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
6554      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
6555      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
6556               dephii1=dephii1+(k-l)*sinkt(m)*(
6557      &           -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
6558      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
6559      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)-
6560      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
6561               if (lprn) then
6562               write (iout,*) "m",m," k",k," l",l," ffthet",
6563      &            ffthet(l,k,m,ityp1,ityp2,ityp3,iblock),
6564      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)," ggthet",
6565      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock),
6566      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock),
6567      &            " ethetai",ethetai
6568               write (iout,*) cosph1ph2(l,k)*sinkt(m),
6569      &            cosph1ph2(k,l)*sinkt(m),
6570      &            sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
6571               endif
6572             enddo
6573           enddo
6574         enddo
6575 10      continue
6576 c        lprn1=.true.
6577 C        print *,ethetai
6578         if (lprn1)
6579      &    write (iout,'(i2,3f8.1,9h ethetai ,f10.5)')
6580      &   i,theta(i)*rad2deg,phii*rad2deg,
6581      &   phii1*rad2deg,ethetai
6582 c        lprn1=.false.
6583         etheta=etheta+ethetai
6584         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
6585         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
6586         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)+wang*dethetai
6587       enddo
6588
6589       return
6590       end
6591 #endif
6592 #ifdef CRYST_SC
6593 c-----------------------------------------------------------------------------
6594       subroutine esc(escloc)
6595 C Calculate the local energy of a side chain and its derivatives in the
6596 C corresponding virtual-bond valence angles THETA and the spherical angles
6597 C ALPHA and OMEGA.
6598       implicit real*8 (a-h,o-z)
6599       include 'DIMENSIONS'
6600       include 'COMMON.GEO'
6601       include 'COMMON.LOCAL'
6602       include 'COMMON.VAR'
6603       include 'COMMON.INTERACT'
6604       include 'COMMON.DERIV'
6605       include 'COMMON.CHAIN'
6606       include 'COMMON.IOUNITS'
6607       include 'COMMON.NAMES'
6608       include 'COMMON.FFIELD'
6609       include 'COMMON.CONTROL'
6610       double precision x(3),dersc(3),xemp(3),dersc0(3),dersc1(3),
6611      &     ddersc0(3),ddummy(3),xtemp(3),temp(3)
6612       common /sccalc/ time11,time12,time112,theti,it,nlobit
6613       delta=0.02d0*pi
6614       escloc=0.0D0
6615 c     write (iout,'(a)') 'ESC'
6616       do i=loc_start,loc_end
6617         it=itype(i)
6618         if (it.eq.ntyp1) cycle
6619         if (it.eq.10) goto 1
6620         nlobit=nlob(iabs(it))
6621 c       print *,'i=',i,' it=',it,' nlobit=',nlobit
6622 c       write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
6623         theti=theta(i+1)-pipol
6624         x(1)=dtan(theti)
6625         x(2)=alph(i)
6626         x(3)=omeg(i)
6627
6628         if (x(2).gt.pi-delta) then
6629           xtemp(1)=x(1)
6630           xtemp(2)=pi-delta
6631           xtemp(3)=x(3)
6632           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
6633           xtemp(2)=pi
6634           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
6635           call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),
6636      &        escloci,dersc(2))
6637           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
6638      &        ddersc0(1),dersc(1))
6639           call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),
6640      &        ddersc0(3),dersc(3))
6641           xtemp(2)=pi-delta
6642           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
6643           xtemp(2)=pi
6644           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
6645           call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,
6646      &            dersc0(2),esclocbi,dersc02)
6647           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
6648      &            dersc12,dersc01)
6649           call splinthet(x(2),0.5d0*delta,ss,ssd)
6650           dersc0(1)=dersc01
6651           dersc0(2)=dersc02
6652           dersc0(3)=0.0d0
6653           do k=1,3
6654             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
6655           enddo
6656           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
6657 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
6658 c    &             esclocbi,ss,ssd
6659           escloci=ss*escloci+(1.0d0-ss)*esclocbi
6660 c         escloci=esclocbi
6661 c         write (iout,*) escloci
6662         else if (x(2).lt.delta) then
6663           xtemp(1)=x(1)
6664           xtemp(2)=delta
6665           xtemp(3)=x(3)
6666           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
6667           xtemp(2)=0.0d0
6668           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
6669           call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),
6670      &        escloci,dersc(2))
6671           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
6672      &        ddersc0(1),dersc(1))
6673           call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),
6674      &        ddersc0(3),dersc(3))
6675           xtemp(2)=delta
6676           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
6677           xtemp(2)=0.0d0
6678           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
6679           call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,
6680      &            dersc0(2),esclocbi,dersc02)
6681           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
6682      &            dersc12,dersc01)
6683           dersc0(1)=dersc01
6684           dersc0(2)=dersc02
6685           dersc0(3)=0.0d0
6686           call splinthet(x(2),0.5d0*delta,ss,ssd)
6687           do k=1,3
6688             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
6689           enddo
6690           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
6691 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
6692 c    &             esclocbi,ss,ssd
6693           escloci=ss*escloci+(1.0d0-ss)*esclocbi
6694 c         write (iout,*) escloci
6695         else
6696           call enesc(x,escloci,dersc,ddummy,.false.)
6697         endif
6698
6699         escloc=escloc+escloci
6700         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
6701      &     'escloc',i,escloci
6702 c       write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
6703
6704         gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
6705      &   wscloc*dersc(1)
6706         gloc(ialph(i,1),icg)=wscloc*dersc(2)
6707         gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
6708     1   continue
6709       enddo
6710       return
6711       end
6712 C---------------------------------------------------------------------------
6713       subroutine enesc(x,escloci,dersc,ddersc,mixed)
6714       implicit real*8 (a-h,o-z)
6715       include 'DIMENSIONS'
6716       include 'COMMON.GEO'
6717       include 'COMMON.LOCAL'
6718       include 'COMMON.IOUNITS'
6719       common /sccalc/ time11,time12,time112,theti,it,nlobit
6720       double precision x(3),z(3),Ax(3,maxlob,-1:1),dersc(3),ddersc(3)
6721       double precision contr(maxlob,-1:1)
6722       logical mixed
6723 c       write (iout,*) 'it=',it,' nlobit=',nlobit
6724         escloc_i=0.0D0
6725         do j=1,3
6726           dersc(j)=0.0D0
6727           if (mixed) ddersc(j)=0.0d0
6728         enddo
6729         x3=x(3)
6730
6731 C Because of periodicity of the dependence of the SC energy in omega we have
6732 C to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
6733 C To avoid underflows, first compute & store the exponents.
6734
6735         do iii=-1,1
6736
6737           x(3)=x3+iii*dwapi
6738
6739           do j=1,nlobit
6740             do k=1,3
6741               z(k)=x(k)-censc(k,j,it)
6742             enddo
6743             do k=1,3
6744               Axk=0.0D0
6745               do l=1,3
6746                 Axk=Axk+gaussc(l,k,j,it)*z(l)
6747               enddo
6748               Ax(k,j,iii)=Axk
6749             enddo
6750             expfac=0.0D0
6751             do k=1,3
6752               expfac=expfac+Ax(k,j,iii)*z(k)
6753             enddo
6754             contr(j,iii)=expfac
6755           enddo ! j
6756
6757         enddo ! iii
6758
6759         x(3)=x3
6760 C As in the case of ebend, we want to avoid underflows in exponentiation and
6761 C subsequent NaNs and INFs in energy calculation.
6762 C Find the largest exponent
6763         emin=contr(1,-1)
6764         do iii=-1,1
6765           do j=1,nlobit
6766             if (emin.gt.contr(j,iii)) emin=contr(j,iii)
6767           enddo
6768         enddo
6769         emin=0.5D0*emin
6770 cd      print *,'it=',it,' emin=',emin
6771
6772 C Compute the contribution to SC energy and derivatives
6773         do iii=-1,1
6774
6775           do j=1,nlobit
6776 #ifdef OSF
6777             adexp=bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin
6778             if(adexp.ne.adexp) adexp=1.0
6779             expfac=dexp(adexp)
6780 #else
6781             expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin)
6782 #endif
6783 cd          print *,'j=',j,' expfac=',expfac
6784             escloc_i=escloc_i+expfac
6785             do k=1,3
6786               dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
6787             enddo
6788             if (mixed) then
6789               do k=1,3,2
6790                 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii)
6791      &            +gaussc(k,2,j,it))*expfac
6792               enddo
6793             endif
6794           enddo
6795
6796         enddo ! iii
6797
6798         dersc(1)=dersc(1)/cos(theti)**2
6799         ddersc(1)=ddersc(1)/cos(theti)**2
6800         ddersc(3)=ddersc(3)
6801
6802         escloci=-(dlog(escloc_i)-emin)
6803         do j=1,3
6804           dersc(j)=dersc(j)/escloc_i
6805         enddo
6806         if (mixed) then
6807           do j=1,3,2
6808             ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
6809           enddo
6810         endif
6811       return
6812       end
6813 C------------------------------------------------------------------------------
6814       subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
6815       implicit real*8 (a-h,o-z)
6816       include 'DIMENSIONS'
6817       include 'COMMON.GEO'
6818       include 'COMMON.LOCAL'
6819       include 'COMMON.IOUNITS'
6820       common /sccalc/ time11,time12,time112,theti,it,nlobit
6821       double precision x(3),z(3),Ax(3,maxlob),dersc(3)
6822       double precision contr(maxlob)
6823       logical mixed
6824
6825       escloc_i=0.0D0
6826
6827       do j=1,3
6828         dersc(j)=0.0D0
6829       enddo
6830
6831       do j=1,nlobit
6832         do k=1,2
6833           z(k)=x(k)-censc(k,j,it)
6834         enddo
6835         z(3)=dwapi
6836         do k=1,3
6837           Axk=0.0D0
6838           do l=1,3
6839             Axk=Axk+gaussc(l,k,j,it)*z(l)
6840           enddo
6841           Ax(k,j)=Axk
6842         enddo
6843         expfac=0.0D0
6844         do k=1,3
6845           expfac=expfac+Ax(k,j)*z(k)
6846         enddo
6847         contr(j)=expfac
6848       enddo ! j
6849
6850 C As in the case of ebend, we want to avoid underflows in exponentiation and
6851 C subsequent NaNs and INFs in energy calculation.
6852 C Find the largest exponent
6853       emin=contr(1)
6854       do j=1,nlobit
6855         if (emin.gt.contr(j)) emin=contr(j)
6856       enddo
6857       emin=0.5D0*emin
6858
6859 C Compute the contribution to SC energy and derivatives
6860
6861       dersc12=0.0d0
6862       do j=1,nlobit
6863         expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j)+emin)
6864         escloc_i=escloc_i+expfac
6865         do k=1,2
6866           dersc(k)=dersc(k)+Ax(k,j)*expfac
6867         enddo
6868         if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j)
6869      &            +gaussc(1,2,j,it))*expfac
6870         dersc(3)=0.0d0
6871       enddo
6872
6873       dersc(1)=dersc(1)/cos(theti)**2
6874       dersc12=dersc12/cos(theti)**2
6875       escloci=-(dlog(escloc_i)-emin)
6876       do j=1,2
6877         dersc(j)=dersc(j)/escloc_i
6878       enddo
6879       if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
6880       return
6881       end
6882 #else
6883 c----------------------------------------------------------------------------------
6884       subroutine esc(escloc)
6885 C Calculate the local energy of a side chain and its derivatives in the
6886 C corresponding virtual-bond valence angles THETA and the spherical angles
6887 C ALPHA and OMEGA derived from AM1 all-atom calculations.
6888 C added by Urszula Kozlowska. 07/11/2007
6889 C
6890       implicit real*8 (a-h,o-z)
6891       include 'DIMENSIONS'
6892       include 'COMMON.GEO'
6893       include 'COMMON.LOCAL'
6894       include 'COMMON.VAR'
6895       include 'COMMON.SCROT'
6896       include 'COMMON.INTERACT'
6897       include 'COMMON.DERIV'
6898       include 'COMMON.CHAIN'
6899       include 'COMMON.IOUNITS'
6900       include 'COMMON.NAMES'
6901       include 'COMMON.FFIELD'
6902       include 'COMMON.CONTROL'
6903       include 'COMMON.VECTORS'
6904       double precision x_prime(3),y_prime(3),z_prime(3)
6905      &    , sumene,dsc_i,dp2_i,x(65),
6906      &     xx,yy,zz,sumene1,sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6,
6907      &    de_dxx,de_dyy,de_dzz,de_dt
6908       double precision s1_t,s1_6_t,s2_t,s2_6_t
6909       double precision
6910      & dXX_Ci1(3),dYY_Ci1(3),dZZ_Ci1(3),dXX_Ci(3),
6911      & dYY_Ci(3),dZZ_Ci(3),dXX_XYZ(3),dYY_XYZ(3),dZZ_XYZ(3),
6912      & dt_dCi(3),dt_dCi1(3)
6913       common /sccalc/ time11,time12,time112,theti,it,nlobit
6914       delta=0.02d0*pi
6915       escloc=0.0D0
6916       do i=loc_start,loc_end
6917         if (itype(i).eq.ntyp1) cycle
6918         costtab(i+1) =dcos(theta(i+1))
6919         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
6920         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
6921         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
6922         cosfac2=0.5d0/(1.0d0+costtab(i+1))
6923         cosfac=dsqrt(cosfac2)
6924         sinfac2=0.5d0/(1.0d0-costtab(i+1))
6925         sinfac=dsqrt(sinfac2)
6926         it=iabs(itype(i))
6927         if (it.eq.10) goto 1
6928 c
6929 C  Compute the axes of tghe local cartesian coordinates system; store in
6930 c   x_prime, y_prime and z_prime
6931 c
6932         do j=1,3
6933           x_prime(j) = 0.00
6934           y_prime(j) = 0.00
6935           z_prime(j) = 0.00
6936         enddo
6937 C        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
6938 C     &   dc_norm(3,i+nres)
6939         do j = 1,3
6940           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
6941           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
6942         enddo
6943         do j = 1,3
6944           z_prime(j) = -uz(j,i-1)*dsign(1.0d0,dfloat(itype(i)))
6945         enddo
6946 c       write (2,*) "i",i
6947 c       write (2,*) "x_prime",(x_prime(j),j=1,3)
6948 c       write (2,*) "y_prime",(y_prime(j),j=1,3)
6949 c       write (2,*) "z_prime",(z_prime(j),j=1,3)
6950 c       write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
6951 c      & " xy",scalar(x_prime(1),y_prime(1)),
6952 c      & " xz",scalar(x_prime(1),z_prime(1)),
6953 c      & " yy",scalar(y_prime(1),y_prime(1)),
6954 c      & " yz",scalar(y_prime(1),z_prime(1)),
6955 c      & " zz",scalar(z_prime(1),z_prime(1))
6956 c
6957 C Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
6958 C to local coordinate system. Store in xx, yy, zz.
6959 c
6960         xx=0.0d0
6961         yy=0.0d0
6962         zz=0.0d0
6963         do j = 1,3
6964           xx = xx + x_prime(j)*dc_norm(j,i+nres)
6965           yy = yy + y_prime(j)*dc_norm(j,i+nres)
6966           zz = zz + z_prime(j)*dc_norm(j,i+nres)
6967         enddo
6968
6969         xxtab(i)=xx
6970         yytab(i)=yy
6971         zztab(i)=zz
6972 C
6973 C Compute the energy of the ith side cbain
6974 C
6975 c        write (2,*) "xx",xx," yy",yy," zz",zz
6976         it=iabs(itype(i))
6977         do j = 1,65
6978           x(j) = sc_parmin(j,it)
6979         enddo
6980 #ifdef CHECK_COORD
6981 Cc diagnostics - remove later
6982         xx1 = dcos(alph(2))
6983         yy1 = dsin(alph(2))*dcos(omeg(2))
6984         zz1 = -dsign(1.0,dfloat(itype(i)))*dsin(alph(2))*dsin(omeg(2))
6985         write(2,'(3f8.1,3f9.3,1x,3f9.3)')
6986      &    alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,
6987      &    xx1,yy1,zz1
6988 C,"  --- ", xx_w,yy_w,zz_w
6989 c end diagnostics
6990 #endif
6991         sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
6992      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
6993      &   + x(10)*yy*zz
6994         sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
6995      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
6996      & + x(20)*yy*zz
6997         sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
6998      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
6999      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
7000      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
7001      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
7002      &  +x(40)*xx*yy*zz
7003         sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
7004      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
7005      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
7006      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
7007      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
7008      &  +x(60)*xx*yy*zz
7009         dsc_i   = 0.743d0+x(61)
7010         dp2_i   = 1.9d0+x(62)
7011         dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
7012      &          *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
7013         dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
7014      &          *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
7015         s1=(1+x(63))/(0.1d0 + dscp1)
7016         s1_6=(1+x(64))/(0.1d0 + dscp1**6)
7017         s2=(1+x(65))/(0.1d0 + dscp2)
7018         s2_6=(1+x(65))/(0.1d0 + dscp2**6)
7019         sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6)
7020      & + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
7021 c        write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
7022 c     &   sumene4,
7023 c     &   dscp1,dscp2,sumene
7024 c        sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
7025         escloc = escloc + sumene
7026         if (energy_dec) write (2,*) "i",i," itype",itype(i)," it",it,
7027      &   " escloc",sumene,escloc,it,itype(i)
7028 c     & ,zz,xx,yy
7029 c#define DEBUG
7030 #ifdef DEBUG
7031 C
7032 C This section to check the numerical derivatives of the energy of ith side
7033 C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
7034 C #define DEBUG in the code to turn it on.
7035 C
7036         write (2,*) "sumene               =",sumene
7037         aincr=1.0d-7
7038         xxsave=xx
7039         xx=xx+aincr
7040         write (2,*) xx,yy,zz
7041         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
7042         de_dxx_num=(sumenep-sumene)/aincr
7043         xx=xxsave
7044         write (2,*) "xx+ sumene from enesc=",sumenep
7045         yysave=yy
7046         yy=yy+aincr
7047         write (2,*) xx,yy,zz
7048         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
7049         de_dyy_num=(sumenep-sumene)/aincr
7050         yy=yysave
7051         write (2,*) "yy+ sumene from enesc=",sumenep
7052         zzsave=zz
7053         zz=zz+aincr
7054         write (2,*) xx,yy,zz
7055         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
7056         de_dzz_num=(sumenep-sumene)/aincr
7057         zz=zzsave
7058         write (2,*) "zz+ sumene from enesc=",sumenep
7059         costsave=cost2tab(i+1)
7060         sintsave=sint2tab(i+1)
7061         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
7062         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
7063         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
7064         de_dt_num=(sumenep-sumene)/aincr
7065         write (2,*) " t+ sumene from enesc=",sumenep
7066         cost2tab(i+1)=costsave
7067         sint2tab(i+1)=sintsave
7068 C End of diagnostics section.
7069 #endif
7070 C
7071 C Compute the gradient of esc
7072 C
7073 c        zz=zz*dsign(1.0,dfloat(itype(i)))
7074         pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
7075         pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
7076         pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
7077         pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
7078         pom_dx=dsc_i*dp2_i*cost2tab(i+1)
7079         pom_dy=dsc_i*dp2_i*sint2tab(i+1)
7080         pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
7081         pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
7082         pom1=(sumene3*sint2tab(i+1)+sumene1)
7083      &     *(pom_s1/dscp1+pom_s16*dscp1**4)
7084         pom2=(sumene4*cost2tab(i+1)+sumene2)
7085      &     *(pom_s2/dscp2+pom_s26*dscp2**4)
7086         sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
7087         sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2
7088      &  +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2)
7089      &  +x(40)*yy*zz
7090         sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
7091         sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2
7092      &  +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2)
7093      &  +x(60)*yy*zz
7094         de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6)
7095      &        +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6)
7096      &        +(pom1+pom2)*pom_dx
7097 #ifdef DEBUG
7098         write(2,*), "de_dxx = ", de_dxx,de_dxx_num,itype(i)
7099 #endif
7100 C
7101         sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
7102         sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2
7103      &  +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2)
7104      &  +x(40)*xx*zz
7105         sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
7106         sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz
7107      &  +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz
7108      &  +x(59)*zz**2 +x(60)*xx*zz
7109         de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6)
7110      &        +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6)
7111      &        +(pom1-pom2)*pom_dy
7112 #ifdef DEBUG
7113         write(2,*), "de_dyy = ", de_dyy,de_dyy_num,itype(i)
7114 #endif
7115 C
7116         de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy
7117      &  +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx
7118      &  +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6)
7119      &  +(x(4) + 2*x(7)*zz+  x(8)*xx + x(10)*yy)*(s1+s1_6)
7120      &  +(x(44)+2*x(47)*zz +x(48)*xx   +x(50)*yy  +3*x(53)*zz**2
7121      &  +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy
7122      &  +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6)
7123      &  + ( x(14) + 2*x(17)*zz+  x(18)*xx + x(20)*yy)*(s2+s2_6)
7124 #ifdef DEBUG
7125         write(2,*), "de_dzz = ", de_dzz,de_dzz_num,itype(i)
7126 #endif
7127 C
7128         de_dt =  0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6)
7129      &  -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6)
7130      &  +pom1*pom_dt1+pom2*pom_dt2
7131 #ifdef DEBUG
7132         write(2,*), "de_dt = ", de_dt,de_dt_num,itype(i)
7133 #endif
7134 c#undef DEBUG
7135 c
7136 C
7137        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
7138        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
7139        cosfac2xx=cosfac2*xx
7140        sinfac2yy=sinfac2*yy
7141        do k = 1,3
7142          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))*
7143      &      vbld_inv(i+1)
7144          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))*
7145      &      vbld_inv(i)
7146          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
7147          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
7148 c         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
7149 c     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
7150 c         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
7151 c     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
7152          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
7153          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
7154          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
7155          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
7156          dZZ_Ci1(k)=0.0d0
7157          dZZ_Ci(k)=0.0d0
7158          do j=1,3
7159            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)
7160      &     *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
7161            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)
7162      &     *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
7163          enddo
7164
7165          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
7166          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
7167          dZZ_XYZ(k)=vbld_inv(i+nres)*
7168      &   (z_prime(k)-zz*dC_norm(k,i+nres))
7169 c
7170          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
7171          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
7172        enddo
7173
7174        do k=1,3
7175          dXX_Ctab(k,i)=dXX_Ci(k)
7176          dXX_C1tab(k,i)=dXX_Ci1(k)
7177          dYY_Ctab(k,i)=dYY_Ci(k)
7178          dYY_C1tab(k,i)=dYY_Ci1(k)
7179          dZZ_Ctab(k,i)=dZZ_Ci(k)
7180          dZZ_C1tab(k,i)=dZZ_Ci1(k)
7181          dXX_XYZtab(k,i)=dXX_XYZ(k)
7182          dYY_XYZtab(k,i)=dYY_XYZ(k)
7183          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
7184        enddo
7185
7186        do k = 1,3
7187 c         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
7188 c     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
7189 c         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
7190 c     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
7191 c         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
7192 c     &    dt_dci(k)
7193 c         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
7194 c     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
7195          gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k)
7196      &    +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
7197          gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k)
7198      &    +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
7199          gsclocx(k,i)=                 de_dxx*dxx_XYZ(k)
7200      &    +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
7201        enddo
7202 c       write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
7203 c     &  (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
7204
7205 C to check gradient call subroutine check_grad
7206
7207     1 continue
7208       enddo
7209       return
7210       end
7211 c------------------------------------------------------------------------------
7212       double precision function enesc(x,xx,yy,zz,cost2,sint2)
7213       implicit none
7214       double precision x(65),xx,yy,zz,cost2,sint2,sumene1,sumene2,
7215      & sumene3,sumene4,sumene,dsc_i,dp2_i,dscp1,dscp2,s1,s1_6,s2,s2_6
7216       sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
7217      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
7218      &   + x(10)*yy*zz
7219       sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
7220      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
7221      & + x(20)*yy*zz
7222       sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
7223      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
7224      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
7225      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
7226      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
7227      &  +x(40)*xx*yy*zz
7228       sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
7229      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
7230      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
7231      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
7232      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
7233      &  +x(60)*xx*yy*zz
7234       dsc_i   = 0.743d0+x(61)
7235       dp2_i   = 1.9d0+x(62)
7236       dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
7237      &          *(xx*cost2+yy*sint2))
7238       dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
7239      &          *(xx*cost2-yy*sint2))
7240       s1=(1+x(63))/(0.1d0 + dscp1)
7241       s1_6=(1+x(64))/(0.1d0 + dscp1**6)
7242       s2=(1+x(65))/(0.1d0 + dscp2)
7243       s2_6=(1+x(65))/(0.1d0 + dscp2**6)
7244       sumene = ( sumene3*sint2 + sumene1)*(s1+s1_6)
7245      & + (sumene4*cost2 +sumene2)*(s2+s2_6)
7246       enesc=sumene
7247       return
7248       end
7249 #endif
7250 c------------------------------------------------------------------------------
7251       subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
7252 C
7253 C This procedure calculates two-body contact function g(rij) and its derivative:
7254 C
7255 C           eps0ij                                     !       x < -1
7256 C g(rij) =  esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5)  ! -1 =< x =< 1
7257 C            0                                         !       x > 1
7258 C
7259 C where x=(rij-r0ij)/delta
7260 C
7261 C rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
7262 C
7263       implicit none
7264       double precision rij,r0ij,eps0ij,fcont,fprimcont
7265       double precision x,x2,x4,delta
7266 c     delta=0.02D0*r0ij
7267 c      delta=0.2D0*r0ij
7268       x=(rij-r0ij)/delta
7269       if (x.lt.-1.0D0) then
7270         fcont=eps0ij
7271         fprimcont=0.0D0
7272       else if (x.le.1.0D0) then
7273         x2=x*x
7274         x4=x2*x2
7275         fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
7276         fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
7277       else
7278         fcont=0.0D0
7279         fprimcont=0.0D0
7280       endif
7281       return
7282       end
7283 c------------------------------------------------------------------------------
7284       subroutine splinthet(theti,delta,ss,ssder)
7285       implicit real*8 (a-h,o-z)
7286       include 'DIMENSIONS'
7287       include 'COMMON.VAR'
7288       include 'COMMON.GEO'
7289       thetup=pi-delta
7290       thetlow=delta
7291       if (theti.gt.pipol) then
7292         call gcont(theti,thetup,1.0d0,delta,ss,ssder)
7293       else
7294         call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
7295         ssder=-ssder
7296       endif
7297       return
7298       end
7299 c------------------------------------------------------------------------------
7300       subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
7301       implicit none
7302       double precision x,x0,delta,f0,f1,fprim0,f,fprim
7303       double precision ksi,ksi2,ksi3,a1,a2,a3
7304       a1=fprim0*delta/(f1-f0)
7305       a2=3.0d0-2.0d0*a1
7306       a3=a1-2.0d0
7307       ksi=(x-x0)/delta
7308       ksi2=ksi*ksi
7309       ksi3=ksi2*ksi
7310       f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
7311       fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
7312       return
7313       end
7314 c------------------------------------------------------------------------------
7315       subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
7316       implicit none
7317       double precision x,x0,delta,f0x,f1x,fprim0x,fx
7318       double precision ksi,ksi2,ksi3,a1,a2,a3
7319       ksi=(x-x0)/delta
7320       ksi2=ksi*ksi
7321       ksi3=ksi2*ksi
7322       a1=fprim0x*delta
7323       a2=3*(f1x-f0x)-2*fprim0x*delta
7324       a3=fprim0x*delta-2*(f1x-f0x)
7325       fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
7326       return
7327       end
7328 C-----------------------------------------------------------------------------
7329 #ifdef CRYST_TOR
7330 C-----------------------------------------------------------------------------
7331       subroutine etor(etors)
7332       implicit real*8 (a-h,o-z)
7333       include 'DIMENSIONS'
7334       include 'COMMON.VAR'
7335       include 'COMMON.GEO'
7336       include 'COMMON.LOCAL'
7337       include 'COMMON.TORSION'
7338       include 'COMMON.INTERACT'
7339       include 'COMMON.DERIV'
7340       include 'COMMON.CHAIN'
7341       include 'COMMON.NAMES'
7342       include 'COMMON.IOUNITS'
7343       include 'COMMON.FFIELD'
7344       include 'COMMON.TORCNSTR'
7345       include 'COMMON.CONTROL'
7346       logical lprn
7347 C Set lprn=.true. for debugging
7348       lprn=.false.
7349 c      lprn=.true.
7350       etors=0.0D0
7351       do i=iphi_start,iphi_end
7352       etors_ii=0.0D0
7353         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
7354      &      .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
7355         itori=itortyp(itype(i-2))
7356         itori1=itortyp(itype(i-1))
7357         phii=phi(i)
7358         gloci=0.0D0
7359 C Proline-Proline pair is a special case...
7360         if (itori.eq.3 .and. itori1.eq.3) then
7361           if (phii.gt.-dwapi3) then
7362             cosphi=dcos(3*phii)
7363             fac=1.0D0/(1.0D0-cosphi)
7364             etorsi=v1(1,3,3)*fac
7365             etorsi=etorsi+etorsi
7366             etors=etors+etorsi-v1(1,3,3)
7367             if (energy_dec) etors_ii=etors_ii+etorsi-v1(1,3,3)
7368             gloci=gloci-3*fac*etorsi*dsin(3*phii)
7369           endif
7370           do j=1,3
7371             v1ij=v1(j+1,itori,itori1)
7372             v2ij=v2(j+1,itori,itori1)
7373             cosphi=dcos(j*phii)
7374             sinphi=dsin(j*phii)
7375             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7376             if (energy_dec) etors_ii=etors_ii+
7377      &                              v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7378             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7379           enddo
7380         else
7381           do j=1,nterm_old
7382             v1ij=v1(j,itori,itori1)
7383             v2ij=v2(j,itori,itori1)
7384             cosphi=dcos(j*phii)
7385             sinphi=dsin(j*phii)
7386             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7387             if (energy_dec) etors_ii=etors_ii+
7388      &                  v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7389             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7390           enddo
7391         endif
7392         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
7393              'etor',i,etors_ii
7394         if (lprn)
7395      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
7396      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
7397      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
7398         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
7399 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
7400       enddo
7401       return
7402       end
7403 c------------------------------------------------------------------------------
7404       subroutine etor_d(etors_d)
7405       etors_d=0.0d0
7406       return
7407       end
7408 c----------------------------------------------------------------------------
7409 c LICZENIE WIEZOW Z ROWNANIA ENERGII MODELLERA
7410       subroutine e_modeller(ehomology_constr)
7411       ehomology_constr=0.0d0
7412       write (iout,*) "!!!!!UWAGA, JESTEM W DZIWNEJ PETLI, TEST!!!!!"
7413       return
7414       end
7415 C !!!!!!!! NIE CZYTANE !!!!!!!!!!!
7416
7417 c------------------------------------------------------------------------------
7418       subroutine etor_d(etors_d)
7419       etors_d=0.0d0
7420       return
7421       end
7422 c----------------------------------------------------------------------------
7423 #else
7424       subroutine etor(etors)
7425       implicit real*8 (a-h,o-z)
7426       include 'DIMENSIONS'
7427       include 'COMMON.VAR'
7428       include 'COMMON.GEO'
7429       include 'COMMON.LOCAL'
7430       include 'COMMON.TORSION'
7431       include 'COMMON.INTERACT'
7432       include 'COMMON.DERIV'
7433       include 'COMMON.CHAIN'
7434       include 'COMMON.NAMES'
7435       include 'COMMON.IOUNITS'
7436       include 'COMMON.FFIELD'
7437       include 'COMMON.TORCNSTR'
7438       include 'COMMON.CONTROL'
7439       logical lprn
7440 C Set lprn=.true. for debugging
7441       lprn=.false.
7442 c     lprn=.true.
7443       etors=0.0D0
7444       do i=iphi_start,iphi_end
7445 C ANY TWO ARE DUMMY ATOMS in row CYCLE
7446 c        if (((itype(i-3).eq.ntyp1).and.(itype(i-2).eq.ntyp1)).or.
7447 c     &      ((itype(i-2).eq.ntyp1).and.(itype(i-1).eq.ntyp1))  .or.
7448 c     &      ((itype(i-1).eq.ntyp1).and.(itype(i).eq.ntyp1))) cycle
7449         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
7450      &      .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
7451 C In current verion the ALL DUMMY ATOM POTENTIALS ARE OFF
7452 C For introducing the NH3+ and COO- group please check the etor_d for reference
7453 C and guidance
7454         etors_ii=0.0D0
7455          if (iabs(itype(i)).eq.20) then
7456          iblock=2
7457          else
7458          iblock=1
7459          endif
7460         itori=itortyp(itype(i-2))
7461         itori1=itortyp(itype(i-1))
7462         phii=phi(i)
7463         gloci=0.0D0
7464 C Regular cosine and sine terms
7465         do j=1,nterm(itori,itori1,iblock)
7466           v1ij=v1(j,itori,itori1,iblock)
7467           v2ij=v2(j,itori,itori1,iblock)
7468           cosphi=dcos(j*phii)
7469           sinphi=dsin(j*phii)
7470           etors=etors+v1ij*cosphi+v2ij*sinphi
7471           if (energy_dec) etors_ii=etors_ii+
7472      &                v1ij*cosphi+v2ij*sinphi
7473           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7474         enddo
7475 C Lorentz terms
7476 C                         v1
7477 C  E = SUM ----------------------------------- - v1
7478 C          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
7479 C
7480         cosphi=dcos(0.5d0*phii)
7481         sinphi=dsin(0.5d0*phii)
7482         do j=1,nlor(itori,itori1,iblock)
7483           vl1ij=vlor1(j,itori,itori1)
7484           vl2ij=vlor2(j,itori,itori1)
7485           vl3ij=vlor3(j,itori,itori1)
7486           pom=vl2ij*cosphi+vl3ij*sinphi
7487           pom1=1.0d0/(pom*pom+1.0d0)
7488           etors=etors+vl1ij*pom1
7489           if (energy_dec) etors_ii=etors_ii+
7490      &                vl1ij*pom1
7491           pom=-pom*pom1*pom1
7492           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
7493         enddo
7494 C Subtract the constant term
7495         etors=etors-v0(itori,itori1,iblock)
7496           if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
7497      &         'etor',i,etors_ii-v0(itori,itori1,iblock)
7498         if (lprn)
7499      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
7500      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
7501      &  (v1(j,itori,itori1,iblock),j=1,6),
7502      &  (v2(j,itori,itori1,iblock),j=1,6)
7503         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
7504 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
7505       enddo
7506       return
7507       end
7508 c----------------------------------------------------------------------------
7509       subroutine etor_d(etors_d)
7510 C 6/23/01 Compute double torsional energy
7511       implicit real*8 (a-h,o-z)
7512       include 'DIMENSIONS'
7513       include 'COMMON.VAR'
7514       include 'COMMON.GEO'
7515       include 'COMMON.LOCAL'
7516       include 'COMMON.TORSION'
7517       include 'COMMON.INTERACT'
7518       include 'COMMON.DERIV'
7519       include 'COMMON.CHAIN'
7520       include 'COMMON.NAMES'
7521       include 'COMMON.IOUNITS'
7522       include 'COMMON.FFIELD'
7523       include 'COMMON.TORCNSTR'
7524       logical lprn
7525 C Set lprn=.true. for debugging
7526       lprn=.false.
7527 c     lprn=.true.
7528       etors_d=0.0D0
7529 c      write(iout,*) "a tu??"
7530       do i=iphid_start,iphid_end
7531 C ANY TWO ARE DUMMY ATOMS in row CYCLE
7532 C        if (((itype(i-3).eq.ntyp1).and.(itype(i-2).eq.ntyp1)).or.
7533 C     &      ((itype(i-2).eq.ntyp1).and.(itype(i-1).eq.ntyp1)).or.
7534 C     &      ((itype(i-1).eq.ntyp1).and.(itype(i).eq.ntyp1))  .or.
7535 C     &      ((itype(i).eq.ntyp1).and.(itype(i+1).eq.ntyp1))) cycle
7536          if ((itype(i-2).eq.ntyp1).or.itype(i-3).eq.ntyp1.or.
7537      &  (itype(i-1).eq.ntyp1).or.(itype(i).eq.ntyp1).or.
7538      &  (itype(i+1).eq.ntyp1)) cycle
7539 C In current verion the ALL DUMMY ATOM POTENTIALS ARE OFF
7540         itori=itortyp(itype(i-2))
7541         itori1=itortyp(itype(i-1))
7542         itori2=itortyp(itype(i))
7543         phii=phi(i)
7544         phii1=phi(i+1)
7545         gloci1=0.0D0
7546         gloci2=0.0D0
7547         iblock=1
7548         if (iabs(itype(i+1)).eq.20) iblock=2
7549 C Iblock=2 Proline type
7550 C ADASKO: WHEN PARAMETERS FOR THIS TYPE OF BLOCKING GROUP IS READY UNCOMMENT
7551 C CHECK WEATHER THERE IS NECCESITY FOR iblock=3 for COO-
7552 C        if (itype(i+1).eq.ntyp1) iblock=3
7553 C The problem of NH3+ group can be resolved by adding new parameters please note if there
7554 C IS or IS NOT need for this
7555 C IF Yes uncomment below and add to parmread.F appropriate changes and to v1cij and so on
7556 C        is (itype(i-3).eq.ntyp1) ntblock=2
7557 C        ntblock is N-terminal blocking group
7558
7559 C Regular cosine and sine terms
7560         do j=1,ntermd_1(itori,itori1,itori2,iblock)
7561 C Example of changes for NH3+ blocking group
7562 C       do j=1,ntermd_1(itori,itori1,itori2,iblock,ntblock)
7563 C          v1cij=v1c(1,j,itori,itori1,itori2,iblock,ntblock)
7564           v1cij=v1c(1,j,itori,itori1,itori2,iblock)
7565           v1sij=v1s(1,j,itori,itori1,itori2,iblock)
7566           v2cij=v1c(2,j,itori,itori1,itori2,iblock)
7567           v2sij=v1s(2,j,itori,itori1,itori2,iblock)
7568           cosphi1=dcos(j*phii)
7569           sinphi1=dsin(j*phii)
7570           cosphi2=dcos(j*phii1)
7571           sinphi2=dsin(j*phii1)
7572           etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+
7573      &     v2cij*cosphi2+v2sij*sinphi2
7574           gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
7575           gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
7576         enddo
7577         do k=2,ntermd_2(itori,itori1,itori2,iblock)
7578           do l=1,k-1
7579             v1cdij = v2c(k,l,itori,itori1,itori2,iblock)
7580             v2cdij = v2c(l,k,itori,itori1,itori2,iblock)
7581             v1sdij = v2s(k,l,itori,itori1,itori2,iblock)
7582             v2sdij = v2s(l,k,itori,itori1,itori2,iblock)
7583             cosphi1p2=dcos(l*phii+(k-l)*phii1)
7584             cosphi1m2=dcos(l*phii-(k-l)*phii1)
7585             sinphi1p2=dsin(l*phii+(k-l)*phii1)
7586             sinphi1m2=dsin(l*phii-(k-l)*phii1)
7587             etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+
7588      &        v1sdij*sinphi1p2+v2sdij*sinphi1m2
7589             gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2
7590      &        -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
7591             gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2
7592      &        -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
7593           enddo
7594         enddo
7595         gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*gloci1
7596         gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*gloci2
7597       enddo
7598       return
7599       end
7600 #endif
7601 C----------------------------------------------------------------------------------
7602 C The rigorous attempt to derive energy function
7603       subroutine etor_kcc(etors)
7604       implicit real*8 (a-h,o-z)
7605       include 'DIMENSIONS'
7606       include 'COMMON.VAR'
7607       include 'COMMON.GEO'
7608       include 'COMMON.LOCAL'
7609       include 'COMMON.TORSION'
7610       include 'COMMON.INTERACT'
7611       include 'COMMON.DERIV'
7612       include 'COMMON.CHAIN'
7613       include 'COMMON.NAMES'
7614       include 'COMMON.IOUNITS'
7615       include 'COMMON.FFIELD'
7616       include 'COMMON.TORCNSTR'
7617       include 'COMMON.CONTROL'
7618       double precision c1(0:maxval_kcc),c2(0:maxval_kcc)
7619       logical lprn
7620 c      double precision thybt1(maxtermkcc),thybt2(maxtermkcc)
7621 C Set lprn=.true. for debugging
7622       lprn=energy_dec
7623 c     lprn=.true.
7624 C      print *,"wchodze kcc"
7625       if (lprn) write (iout,*) "etor_kcc tor_mode",tor_mode
7626       etors=0.0D0
7627       do i=iphi_start,iphi_end
7628 C ANY TWO ARE DUMMY ATOMS in row CYCLE
7629 c        if (((itype(i-3).eq.ntyp1).and.(itype(i-2).eq.ntyp1)).or.
7630 c     &      ((itype(i-2).eq.ntyp1).and.(itype(i-1).eq.ntyp1))  .or.
7631 c     &      ((itype(i-1).eq.ntyp1).and.(itype(i).eq.ntyp1))) cycle
7632         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
7633      &      .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
7634         itori=itortyp(itype(i-2))
7635         itori1=itortyp(itype(i-1))
7636         phii=phi(i)
7637         glocig=0.0D0
7638         glocit1=0.0d0
7639         glocit2=0.0d0
7640 C to avoid multiple devision by 2
7641 c        theti22=0.5d0*theta(i)
7642 C theta 12 is the theta_1 /2
7643 C theta 22 is theta_2 /2
7644 c        theti12=0.5d0*theta(i-1)
7645 C and appropriate sinus function
7646         sinthet1=dsin(theta(i-1))
7647         sinthet2=dsin(theta(i))
7648         costhet1=dcos(theta(i-1))
7649         costhet2=dcos(theta(i))
7650 C to speed up lets store its mutliplication
7651         sint1t2=sinthet2*sinthet1
7652         sint1t2n=1.0d0
7653 C \sum_{i=1}^n (sin(theta_1) * sin(theta_2))^n * (c_n* cos(n*gamma)
7654 C +d_n*sin(n*gamma)) *
7655 C \sum_{i=1}^m (1+a_m*Tb_m(cos(theta_1 /2))+b_m*Tb_m(cos(theta_2 /2)))
7656 C we have two sum 1) Non-Chebyshev which is with n and gamma
7657         nval=nterm_kcc_Tb(itori,itori1)
7658         c1(0)=0.0d0
7659         c2(0)=0.0d0
7660         c1(1)=1.0d0
7661         c2(1)=1.0d0
7662         do j=2,nval
7663           c1(j)=c1(j-1)*costhet1
7664           c2(j)=c2(j-1)*costhet2
7665         enddo
7666         etori=0.0d0
7667         do j=1,nterm_kcc(itori,itori1)
7668           cosphi=dcos(j*phii)
7669           sinphi=dsin(j*phii)
7670           sint1t2n1=sint1t2n
7671           sint1t2n=sint1t2n*sint1t2
7672           sumvalc=0.0d0
7673           gradvalct1=0.0d0
7674           gradvalct2=0.0d0
7675           do k=1,nval
7676             do l=1,nval
7677               sumvalc=sumvalc+v1_kcc(l,k,j,itori1,itori)*c1(k)*c2(l)
7678               gradvalct1=gradvalct1+
7679      &           (k-1)*v1_kcc(l,k,j,itori1,itori)*c1(k-1)*c2(l)
7680               gradvalct2=gradvalct2+
7681      &           (l-1)*v1_kcc(l,k,j,itori1,itori)*c1(k)*c2(l-1)
7682             enddo
7683           enddo
7684           gradvalct1=-gradvalct1*sinthet1
7685           gradvalct2=-gradvalct2*sinthet2
7686           sumvals=0.0d0
7687           gradvalst1=0.0d0
7688           gradvalst2=0.0d0
7689           do k=1,nval
7690             do l=1,nval
7691               sumvals=sumvals+v2_kcc(l,k,j,itori1,itori)*c1(k)*c2(l)
7692               gradvalst1=gradvalst1+
7693      &           (k-1)*v2_kcc(l,k,j,itori1,itori)*c1(k-1)*c2(l)
7694               gradvalst2=gradvalst2+
7695      &           (l-1)*v2_kcc(l,k,j,itori1,itori)*c1(k)*c2(l-1)
7696             enddo
7697           enddo
7698           gradvalst1=-gradvalst1*sinthet1
7699           gradvalst2=-gradvalst2*sinthet2
7700           if (lprn) write (iout,*)j,"sumvalc",sumvalc," sumvals",sumvals
7701           etori=etori+sint1t2n*(sumvalc*cosphi+sumvals*sinphi)
7702 C glocig is the gradient local i site in gamma
7703           glocig=glocig+j*sint1t2n*(sumvals*cosphi-sumvalc*sinphi)
7704 C now gradient over theta_1
7705           glocit1=glocit1+sint1t2n*(gradvalct1*cosphi+gradvalst1*sinphi)
7706      &   +j*sint1t2n1*costhet1*sinthet2*(sumvalc*cosphi+sumvals*sinphi)
7707           glocit2=glocit2+sint1t2n*(gradvalct2*cosphi+gradvalst2*sinphi)
7708      &   +j*sint1t2n1*sinthet1*costhet2*(sumvalc*cosphi+sumvals*sinphi)
7709         enddo ! j
7710         etors=etors+etori
7711 C derivative over gamma
7712         gloc(i-3,icg)=gloc(i-3,icg)+wtor*glocig
7713 C derivative over theta1
7714         gloc(nphi+i-3,icg)=gloc(nphi+i-3,icg)+wtor*glocit1
7715 C now derivative over theta2
7716         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)+wtor*glocit2
7717         if (lprn) then
7718           write (iout,*) i-2,i-1,itype(i-2),itype(i-1),itori,itori1,
7719      &       theta(i-1)*rad2deg,theta(i)*rad2deg,phii*rad2deg,etori
7720           write (iout,*) "c1",(c1(k),k=0,nval),
7721      &    " c2",(c2(k),k=0,nval)
7722         endif
7723       enddo
7724       return
7725       end
7726 c---------------------------------------------------------------------------------------------
7727       subroutine etor_constr(edihcnstr)
7728       implicit real*8 (a-h,o-z)
7729       include 'DIMENSIONS'
7730       include 'COMMON.VAR'
7731       include 'COMMON.GEO'
7732       include 'COMMON.LOCAL'
7733       include 'COMMON.TORSION'
7734       include 'COMMON.INTERACT'
7735       include 'COMMON.DERIV'
7736       include 'COMMON.CHAIN'
7737       include 'COMMON.NAMES'
7738       include 'COMMON.IOUNITS'
7739       include 'COMMON.FFIELD'
7740       include 'COMMON.TORCNSTR'
7741       include 'COMMON.BOUNDS'
7742       include 'COMMON.CONTROL'
7743 ! 6/20/98 - dihedral angle constraints
7744       edihcnstr=0.0d0
7745 c      do i=1,ndih_constr
7746       if (raw_psipred) then
7747         do i=idihconstr_start,idihconstr_end
7748           itori=idih_constr(i)
7749           phii=phi(itori)
7750           gaudih_i=vpsipred(1,i)
7751           gauder_i=0.0d0
7752           do j=1,2
7753             s = sdihed(j,i)
7754             cos_i=(1.0d0-dcos(phii-phibound(j,i)))/s**2
7755             dexpcos_i=dexp(-cos_i*cos_i)
7756             gaudih_i=gaudih_i+vpsipred(j+1,i)*dexpcos_i
7757             gauder_i=gauder_i-2*vpsipred(j+1,i)*dsin(phii-phibound(j,i))
7758      &            *cos_i*dexpcos_i/s**2
7759           enddo
7760           edihcnstr=edihcnstr-wdihc*dlog(gaudih_i)
7761           gloc(itori-3,icg)=gloc(itori-3,icg)-wdihc*gauder_i/gaudih_i
7762           if (energy_dec)
7763      &     write (iout,'(2i5,f8.3,f8.5,2(f8.5,2f8.3),f10.5)')
7764      &     i,itori,phii*rad2deg,vpsipred(1,i),vpsipred(2,i),
7765      &     phibound(1,i)*rad2deg,sdihed(1,i)*rad2deg,vpsipred(3,i),
7766      &     phibound(2,i)*rad2deg,sdihed(2,i)*rad2deg,
7767      &     -wdihc*dlog(gaudih_i)
7768         enddo
7769       else
7770
7771       do i=idihconstr_start,idihconstr_end
7772         itori=idih_constr(i)
7773         phii=phi(itori)
7774         difi=pinorm(phii-phi0(i))
7775         if (difi.gt.drange(i)) then
7776           difi=difi-drange(i)
7777           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
7778           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
7779         else if (difi.lt.-drange(i)) then
7780           difi=difi+drange(i)
7781           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
7782           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
7783         else
7784           difi=0.0
7785         endif
7786       enddo
7787
7788       endif
7789
7790       return
7791       end
7792 c----------------------------------------------------------------------------
7793 c MODELLER restraint function
7794       subroutine e_modeller(ehomology_constr)
7795       implicit none
7796       include 'DIMENSIONS'
7797
7798       double precision ehomology_constr
7799       integer nnn,i,ii,j,k,ijk,jik,ki,kk,nexl,irec,l
7800       integer katy, odleglosci, test7
7801       real*8 odleg, odleg2, odleg3, kat, kat2, kat3, gdih(max_template)
7802       real*8 Eval,Erot
7803       real*8 distance(max_template),distancek(max_template),
7804      &    min_odl,godl(max_template),dih_diff(max_template)
7805
7806 c
7807 c     FP - 30/10/2014 Temporary specifications for homology restraints
7808 c
7809       double precision utheta_i,gutheta_i,sum_gtheta,sum_sgtheta,
7810      &                 sgtheta
7811       double precision, dimension (maxres) :: guscdiff,usc_diff
7812       double precision, dimension (max_template) ::
7813      &           gtheta,dscdiff,uscdiffk,guscdiff2,guscdiff3,
7814      &           theta_diff
7815       double precision sum_godl,sgodl,grad_odl3,ggodl,sum_gdih,
7816      & sum_guscdiff,sum_sgdih,sgdih,grad_dih3,usc_diff_i,dxx,dyy,dzz,
7817      & betai,sum_sgodl,dij
7818       double precision dist,pinorm
7819 c
7820       include 'COMMON.SBRIDGE'
7821       include 'COMMON.CHAIN'
7822       include 'COMMON.GEO'
7823       include 'COMMON.DERIV'
7824       include 'COMMON.LOCAL'
7825       include 'COMMON.INTERACT'
7826       include 'COMMON.VAR'
7827       include 'COMMON.IOUNITS'
7828 c      include 'COMMON.MD'
7829       include 'COMMON.CONTROL'
7830       include 'COMMON.HOMOLOGY'
7831       include 'COMMON.QRESTR'
7832 c
7833 c     From subroutine Econstr_back
7834 c
7835       include 'COMMON.NAMES'
7836       include 'COMMON.TIME1'
7837 c
7838
7839
7840       do i=1,max_template
7841         distancek(i)=9999999.9
7842       enddo
7843
7844
7845       odleg=0.0d0
7846
7847 c Pseudo-energy and gradient from homology restraints (MODELLER-like
7848 c function)
7849 C AL 5/2/14 - Introduce list of restraints
7850 c     write(iout,*) "waga_theta",waga_theta,"waga_d",waga_d
7851 #ifdef DEBUG
7852       write(iout,*) "------- dist restrs start -------"
7853 #endif
7854       do ii = link_start_homo,link_end_homo
7855          i = ires_homo(ii)
7856          j = jres_homo(ii)
7857          dij=dist(i,j)
7858 c        write (iout,*) "dij(",i,j,") =",dij
7859          nexl=0
7860          do k=1,constr_homology
7861 c           write(iout,*) ii,k,i,j,l_homo(k,ii),dij,odl(k,ii)
7862            if(.not.l_homo(k,ii)) then
7863              nexl=nexl+1
7864              cycle
7865            endif
7866            distance(k)=odl(k,ii)-dij
7867 c          write (iout,*) "distance(",k,") =",distance(k)
7868 c
7869 c          For Gaussian-type Urestr
7870 c
7871            distancek(k)=0.5d0*distance(k)**2*sigma_odl(k,ii) ! waga_dist rmvd from Gaussian argument
7872 c          write (iout,*) "sigma_odl(",k,ii,") =",sigma_odl(k,ii)
7873 c          write (iout,*) "distancek(",k,") =",distancek(k)
7874 c          distancek(k)=0.5d0*waga_dist*distance(k)**2*sigma_odl(k,ii)
7875 c
7876 c          For Lorentzian-type Urestr
7877 c
7878            if (waga_dist.lt.0.0d0) then
7879               sigma_odlir(k,ii)=dsqrt(1/sigma_odl(k,ii))
7880               distancek(k)=distance(k)**2/(sigma_odlir(k,ii)*
7881      &                     (distance(k)**2+sigma_odlir(k,ii)**2))
7882            endif
7883          enddo
7884
7885 c         min_odl=minval(distancek)
7886          if (nexl.gt.0) then
7887            min_odl=0.0d0
7888          else
7889            do kk=1,constr_homology
7890             if(l_homo(kk,ii)) then
7891               min_odl=distancek(kk)
7892               exit
7893             endif
7894            enddo
7895            do kk=1,constr_homology
7896             if(l_homo(kk,ii) .and. distancek(kk).lt.min_odl)
7897      &              min_odl=distancek(kk)
7898            enddo
7899          endif
7900
7901 c        write (iout,* )"min_odl",min_odl
7902 #ifdef DEBUG
7903          write (iout,*) "ij dij",i,j,dij
7904          write (iout,*) "distance",(distance(k),k=1,constr_homology)
7905          write (iout,*) "distancek",(distancek(k),k=1,constr_homology)
7906          write (iout,* )"min_odl",min_odl
7907 #endif
7908 #ifdef OLDRESTR
7909          odleg2=0.0d0
7910 #else
7911          if (waga_dist.ge.0.0d0) then
7912            odleg2=nexl
7913          else
7914            odleg2=0.0d0
7915          endif
7916 #endif
7917          do k=1,constr_homology
7918 c Nie wiem po co to liczycie jeszcze raz!
7919 c            odleg3=-waga_dist(iset)*((distance(i,j,k)**2)/
7920 c     &              (2*(sigma_odl(i,j,k))**2))
7921            if(.not.l_homo(k,ii)) cycle
7922            if (waga_dist.ge.0.0d0) then
7923 c
7924 c          For Gaussian-type Urestr
7925 c
7926             godl(k)=dexp(-distancek(k)+min_odl)
7927             odleg2=odleg2+godl(k)
7928 c
7929 c          For Lorentzian-type Urestr
7930 c
7931            else
7932             odleg2=odleg2+distancek(k)
7933            endif
7934
7935 ccc       write(iout,779) i,j,k, "odleg2=",odleg2, "odleg3=", odleg3,
7936 ccc     & "dEXP(odleg3)=", dEXP(odleg3),"distance(i,j,k)^2=",
7937 ccc     & distance(i,j,k)**2, "dist(i+1,j+1)=", dist(i+1,j+1),
7938 ccc     & "sigma_odl(i,j,k)=", sigma_odl(i,j,k)
7939
7940          enddo
7941 c        write (iout,*) "godl",(godl(k),k=1,constr_homology) ! exponents
7942 c        write (iout,*) "ii i j",ii,i,j," odleg2",odleg2 ! sum of exps
7943 #ifdef DEBUG
7944          write (iout,*) "godl",(godl(k),k=1,constr_homology) ! exponents
7945          write (iout,*) "ii i j",ii,i,j," odleg2",odleg2 ! sum of exps
7946 #endif
7947            if (waga_dist.ge.0.0d0) then
7948 c
7949 c          For Gaussian-type Urestr
7950 c
7951               odleg=odleg-dLOG(odleg2/constr_homology)+min_odl
7952 c
7953 c          For Lorentzian-type Urestr
7954 c
7955            else
7956               odleg=odleg+odleg2/constr_homology
7957            endif
7958 c
7959 c        write (iout,*) "odleg",odleg ! sum of -ln-s
7960 c Gradient
7961 c
7962 c          For Gaussian-type Urestr
7963 c
7964          if (waga_dist.ge.0.0d0) sum_godl=odleg2
7965          sum_sgodl=0.0d0
7966          do k=1,constr_homology
7967 c            godl=dexp(((-(distance(i,j,k)**2)/(2*(sigma_odl(i,j,k))**2))
7968 c     &           *waga_dist)+min_odl
7969 c          sgodl=-godl(k)*distance(k)*sigma_odl(k,ii)*waga_dist
7970 c
7971          if(.not.l_homo(k,ii)) cycle
7972          if (waga_dist.ge.0.0d0) then
7973 c          For Gaussian-type Urestr
7974 c
7975            sgodl=-godl(k)*distance(k)*sigma_odl(k,ii) ! waga_dist rmvd
7976 c
7977 c          For Lorentzian-type Urestr
7978 c
7979          else
7980            sgodl=-2*sigma_odlir(k,ii)*(distance(k)/(distance(k)**2+
7981      &           sigma_odlir(k,ii)**2)**2)
7982          endif
7983            sum_sgodl=sum_sgodl+sgodl
7984
7985 c            sgodl2=sgodl2+sgodl
7986 c      write(iout,*) i, j, k, distance(i,j,k), "W GRADIENCIE1"
7987 c      write(iout,*) "constr_homology=",constr_homology
7988 c      write(iout,*) i, j, k, "TEST K"
7989          enddo
7990          if (waga_dist.ge.0.0d0) then
7991 c
7992 c          For Gaussian-type Urestr
7993 c
7994             grad_odl3=waga_homology(iset)*waga_dist
7995      &                *sum_sgodl/(sum_godl*dij)
7996 c
7997 c          For Lorentzian-type Urestr
7998 c
7999          else
8000 c Original grad expr modified by analogy w Gaussian-type Urestr grad
8001 c           grad_odl3=-waga_homology(iset)*waga_dist*sum_sgodl
8002             grad_odl3=-waga_homology(iset)*waga_dist*
8003      &                sum_sgodl/(constr_homology*dij)
8004          endif
8005 c
8006 c        grad_odl3=sum_sgodl/(sum_godl*dij)
8007
8008
8009 c      write(iout,*) i, j, k, distance(i,j,k), "W GRADIENCIE2"
8010 c      write(iout,*) (distance(i,j,k)**2), (2*(sigma_odl(i,j,k))**2),
8011 c     &              (-(distance(i,j,k)**2)/(2*(sigma_odl(i,j,k))**2))
8012
8013 ccc      write(iout,*) godl, sgodl, grad_odl3
8014
8015 c          grad_odl=grad_odl+grad_odl3
8016
8017          do jik=1,3
8018             ggodl=grad_odl3*(c(jik,i)-c(jik,j))
8019 ccc      write(iout,*) c(jik,i+1), c(jik,j+1), (c(jik,i+1)-c(jik,j+1))
8020 ccc      write(iout,746) "GRAD_ODL_1", i, j, jik, ggodl,
8021 ccc     &              ghpbc(jik,i+1), ghpbc(jik,j+1)
8022             ghpbc(jik,i)=ghpbc(jik,i)+ggodl
8023             ghpbc(jik,j)=ghpbc(jik,j)-ggodl
8024 ccc      write(iout,746) "GRAD_ODL_2", i, j, jik, ggodl,
8025 ccc     &              ghpbc(jik,i+1), ghpbc(jik,j+1)
8026 c         if (i.eq.25.and.j.eq.27) then
8027 c         write(iout,*) "jik",jik,"i",i,"j",j
8028 c         write(iout,*) "sum_sgodl",sum_sgodl,"sgodl",sgodl
8029 c         write(iout,*) "grad_odl3",grad_odl3
8030 c         write(iout,*) "c(",jik,i,")",c(jik,i),"c(",jik,j,")",c(jik,j)
8031 c         write(iout,*) "ggodl",ggodl
8032 c         write(iout,*) "ghpbc(",jik,i,")",
8033 c     &                 ghpbc(jik,i),"ghpbc(",jik,j,")",
8034 c     &                 ghpbc(jik,j)
8035 c         endif
8036          enddo
8037 ccc       write(iout,778)"TEST: odleg2=", odleg2, "DLOG(odleg2)=",
8038 ccc     & dLOG(odleg2),"-odleg=", -odleg
8039
8040       enddo ! ii-loop for dist
8041 #ifdef DEBUG
8042       write(iout,*) "------- dist restrs end -------"
8043 c     if (waga_angle.eq.1.0d0 .or. waga_theta.eq.1.0d0 .or.
8044 c    &     waga_d.eq.1.0d0) call sum_gradient
8045 #endif
8046 c Pseudo-energy and gradient from dihedral-angle restraints from
8047 c homology templates
8048 c      write (iout,*) "End of distance loop"
8049 c      call flush(iout)
8050       kat=0.0d0
8051 c      write (iout,*) idihconstr_start_homo,idihconstr_end_homo
8052 #ifdef DEBUG
8053       write(iout,*) "------- dih restrs start -------"
8054       do i=idihconstr_start_homo,idihconstr_end_homo
8055         write (iout,*) "gloc_init(",i,icg,")",gloc(i,icg)
8056       enddo
8057 #endif
8058       do i=idihconstr_start_homo,idihconstr_end_homo
8059         kat2=0.0d0
8060 c        betai=beta(i,i+1,i+2,i+3)
8061         betai = phi(i)
8062 c       write (iout,*) "betai =",betai
8063         do k=1,constr_homology
8064           dih_diff(k)=pinorm(dih(k,i)-betai)
8065 cd          write (iout,'(a8,2i4,2f15.8)') "dih_diff",i,k,dih_diff(k)
8066 cd     &                  ,sigma_dih(k,i)
8067 c          if (dih_diff(i,k).gt.3.14159) dih_diff(i,k)=
8068 c     &                                   -(6.28318-dih_diff(i,k))
8069 c          if (dih_diff(i,k).lt.-3.14159) dih_diff(i,k)=
8070 c     &                                   6.28318+dih_diff(i,k)
8071 #ifdef OLD_DIHED
8072           kat3=-0.5d0*dih_diff(k)**2*sigma_dih(k,i) ! waga_angle rmvd from Gaussian argument
8073 #else
8074           kat3=(dcos(dih_diff(k))-1)*sigma_dih(k,i) ! waga_angle rmvd from Gaussian argument
8075 #endif
8076 c         kat3=-0.5d0*waga_angle*dih_diff(k)**2*sigma_dih(k,i)
8077           gdih(k)=dexp(kat3)
8078           kat2=kat2+gdih(k)
8079 c          write(iout,*) "kat2=", kat2, "exp(kat3)=", exp(kat3)
8080 c          write(*,*)""
8081         enddo
8082 c       write (iout,*) "gdih",(gdih(k),k=1,constr_homology) ! exps
8083 c       write (iout,*) "i",i," betai",betai," kat2",kat2 ! sum of exps
8084 #ifdef DEBUG
8085         write (iout,*) "i",i," betai",betai," kat2",kat2
8086         write (iout,*) "gdih",(gdih(k),k=1,constr_homology)
8087 #endif
8088         if (kat2.le.1.0d-14) cycle
8089         kat=kat-dLOG(kat2/constr_homology)
8090 c       write (iout,*) "kat",kat ! sum of -ln-s
8091
8092 ccc       write(iout,778)"TEST: kat2=", kat2, "DLOG(kat2)=",
8093 ccc     & dLOG(kat2), "-kat=", -kat
8094
8095 c ----------------------------------------------------------------------
8096 c Gradient
8097 c ----------------------------------------------------------------------
8098
8099         sum_gdih=kat2
8100         sum_sgdih=0.0d0
8101         do k=1,constr_homology
8102 #ifdef OLD_DIHED
8103           sgdih=-gdih(k)*dih_diff(k)*sigma_dih(k,i)  ! waga_angle rmvd
8104 #else
8105           sgdih=-gdih(k)*dsin(dih_diff(k))*sigma_dih(k,i)  ! waga_angle rmvd
8106 #endif
8107 c         sgdih=-gdih(k)*dih_diff(k)*sigma_dih(k,i)*waga_angle
8108           sum_sgdih=sum_sgdih+sgdih
8109         enddo
8110 c       grad_dih3=sum_sgdih/sum_gdih
8111         grad_dih3=waga_homology(iset)*waga_angle*sum_sgdih/sum_gdih
8112
8113 c      write(iout,*)i,k,gdih,sgdih,beta(i+1,i+2,i+3,i+4),grad_dih3
8114 ccc      write(iout,747) "GRAD_KAT_1", i, nphi, icg, grad_dih3,
8115 ccc     & gloc(nphi+i-3,icg)
8116         gloc(i-3,icg)=gloc(i-3,icg)+grad_dih3
8117 c        if (i.eq.25) then
8118 c        write(iout,*) "i",i,"icg",icg,"gloc(",i,icg,")",gloc(i,icg)
8119 c        endif
8120 ccc      write(iout,747) "GRAD_KAT_2", i, nphi, icg, grad_dih3,
8121 ccc     & gloc(nphi+i-3,icg)
8122
8123       enddo ! i-loop for dih
8124 #ifdef DEBUG
8125       write(iout,*) "------- dih restrs end -------"
8126 #endif
8127
8128 c Pseudo-energy and gradient for theta angle restraints from
8129 c homology templates
8130 c FP 01/15 - inserted from econstr_local_test.F, loop structure
8131 c adapted
8132
8133 c
8134 c     For constr_homology reference structures (FP)
8135 c
8136 c     Uconst_back_tot=0.0d0
8137       Eval=0.0d0
8138       Erot=0.0d0
8139 c     Econstr_back legacy
8140       do i=1,nres
8141 c     do i=ithet_start,ithet_end
8142        dutheta(i)=0.0d0
8143 c     enddo
8144 c     do i=loc_start,loc_end
8145         do j=1,3
8146           duscdiff(j,i)=0.0d0
8147           duscdiffx(j,i)=0.0d0
8148         enddo
8149       enddo
8150 c
8151 c     do iref=1,nref
8152 c     write (iout,*) "ithet_start =",ithet_start,"ithet_end =",ithet_end
8153 c     write (iout,*) "waga_theta",waga_theta
8154       if (waga_theta.gt.0.0d0) then
8155 #ifdef DEBUG
8156       write (iout,*) "usampl",usampl
8157       write(iout,*) "------- theta restrs start -------"
8158 c     do i=ithet_start,ithet_end
8159 c       write (iout,*) "gloc_init(",nphi+i,icg,")",gloc(nphi+i,icg)
8160 c     enddo
8161 #endif
8162 c     write (iout,*) "maxres",maxres,"nres",nres
8163
8164       do i=ithet_start,ithet_end
8165 c
8166 c     do i=1,nfrag_back
8167 c       ii = ifrag_back(2,i,iset)-ifrag_back(1,i,iset)
8168 c
8169 c Deviation of theta angles wrt constr_homology ref structures
8170 c
8171         utheta_i=0.0d0 ! argument of Gaussian for single k
8172         gutheta_i=0.0d0 ! Sum of Gaussians over constr_homology ref structures
8173 c       do j=ifrag_back(1,i,iset)+2,ifrag_back(2,i,iset) ! original loop
8174 c       over residues in a fragment
8175 c       write (iout,*) "theta(",i,")=",theta(i)
8176         do k=1,constr_homology
8177 c
8178 c         dtheta_i=theta(j)-thetaref(j,iref)
8179 c         dtheta_i=thetaref(k,i)-theta(i) ! original form without indexing
8180           theta_diff(k)=thetatpl(k,i)-theta(i)
8181 cd          write (iout,'(a8,2i4,2f15.8)') "theta_diff",i,k,theta_diff(k)
8182 cd     &                  ,sigma_theta(k,i)
8183
8184 c
8185           utheta_i=-0.5d0*theta_diff(k)**2*sigma_theta(k,i) ! waga_theta rmvd from Gaussian argument
8186 c         utheta_i=-0.5d0*waga_theta*theta_diff(k)**2*sigma_theta(k,i) ! waga_theta?
8187           gtheta(k)=dexp(utheta_i) ! + min_utheta_i?
8188           gutheta_i=gutheta_i+gtheta(k)  ! Sum of Gaussians (pk)
8189 c         Gradient for single Gaussian restraint in subr Econstr_back
8190 c         dutheta(j-2)=dutheta(j-2)+wfrag_back(1,i,iset)*dtheta_i/(ii-1)
8191 c
8192         enddo
8193 c       write (iout,*) "gtheta",(gtheta(k),k=1,constr_homology) ! exps
8194 c       write (iout,*) "i",i," gutheta_i",gutheta_i ! sum of exps
8195
8196 c
8197 c         Gradient for multiple Gaussian restraint
8198         sum_gtheta=gutheta_i
8199         sum_sgtheta=0.0d0
8200         do k=1,constr_homology
8201 c        New generalized expr for multiple Gaussian from Econstr_back
8202          sgtheta=-gtheta(k)*theta_diff(k)*sigma_theta(k,i) ! waga_theta rmvd
8203 c
8204 c        sgtheta=-gtheta(k)*theta_diff(k)*sigma_theta(k,i)*waga_theta ! right functional form?
8205           sum_sgtheta=sum_sgtheta+sgtheta ! cum variable
8206         enddo
8207 c       Final value of gradient using same var as in Econstr_back
8208         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)
8209      &      +sum_sgtheta/sum_gtheta*waga_theta
8210      &               *waga_homology(iset)
8211 c        dutheta(i-2)=sum_sgtheta/sum_gtheta*waga_theta
8212 c     &               *waga_homology(iset)
8213 c       dutheta(i)=sum_sgtheta/sum_gtheta
8214 c
8215 c       Uconst_back=Uconst_back+waga_theta*utheta(i) ! waga_theta added as weight
8216         Eval=Eval-dLOG(gutheta_i/constr_homology)
8217 c       write (iout,*) "utheta(",i,")=",utheta(i) ! -ln of sum of exps
8218 c       write (iout,*) "Uconst_back",Uconst_back ! sum of -ln-s
8219 c       Uconst_back=Uconst_back+utheta(i)
8220       enddo ! (i-loop for theta)
8221 #ifdef DEBUG
8222       write(iout,*) "------- theta restrs end -------"
8223 #endif
8224       endif
8225 c
8226 c Deviation of local SC geometry
8227 c
8228 c Separation of two i-loops (instructed by AL - 11/3/2014)
8229 c
8230 c     write (iout,*) "loc_start =",loc_start,"loc_end =",loc_end
8231 c     write (iout,*) "waga_d",waga_d
8232
8233 #ifdef DEBUG
8234       write(iout,*) "------- SC restrs start -------"
8235       write (iout,*) "Initial duscdiff,duscdiffx"
8236       do i=loc_start,loc_end
8237         write (iout,*) i,(duscdiff(jik,i),jik=1,3),
8238      &                 (duscdiffx(jik,i),jik=1,3)
8239       enddo
8240 #endif
8241       do i=loc_start,loc_end
8242         usc_diff_i=0.0d0 ! argument of Gaussian for single k
8243         guscdiff(i)=0.0d0 ! Sum of Gaussians over constr_homology ref structures
8244 c       do j=ifrag_back(1,i,iset)+1,ifrag_back(2,i,iset)-1 ! Econstr_back legacy
8245 c       write(iout,*) "xxtab, yytab, zztab"
8246 c       write(iout,'(i5,3f8.2)') i,xxtab(i),yytab(i),zztab(i)
8247         do k=1,constr_homology
8248 c
8249           dxx=-xxtpl(k,i)+xxtab(i) ! Diff b/w x component of ith SC vector in model and kth ref str?
8250 c                                    Original sign inverted for calc of gradients (s. Econstr_back)
8251           dyy=-yytpl(k,i)+yytab(i) ! ibid y
8252           dzz=-zztpl(k,i)+zztab(i) ! ibid z
8253 c         write(iout,*) "dxx, dyy, dzz"
8254 cd          write(iout,'(2i5,4f8.2)') k,i,dxx,dyy,dzz,sigma_d(k,i)
8255 c
8256           usc_diff_i=-0.5d0*(dxx**2+dyy**2+dzz**2)*sigma_d(k,i)  ! waga_d rmvd from Gaussian argument
8257 c         usc_diff(i)=-0.5d0*waga_d*(dxx**2+dyy**2+dzz**2)*sigma_d(k,i) ! waga_d?
8258 c         uscdiffk(k)=usc_diff(i)
8259           guscdiff2(k)=dexp(usc_diff_i) ! without min_scdiff
8260 c          write(iout,*) "i",i," k",k," sigma_d",sigma_d(k,i),
8261 c     &       " guscdiff2",guscdiff2(k)
8262           guscdiff(i)=guscdiff(i)+guscdiff2(k)  !Sum of Gaussians (pk)
8263 c          write (iout,'(i5,6f10.5)') j,xxtab(j),yytab(j),zztab(j),
8264 c     &      xxref(j),yyref(j),zzref(j)
8265         enddo
8266 c
8267 c       Gradient
8268 c
8269 c       Generalized expression for multiple Gaussian acc to that for a single
8270 c       Gaussian in Econstr_back as instructed by AL (FP - 03/11/2014)
8271 c
8272 c       Original implementation
8273 c       sum_guscdiff=guscdiff(i)
8274 c
8275 c       sum_sguscdiff=0.0d0
8276 c       do k=1,constr_homology
8277 c          sguscdiff=-guscdiff2(k)*dscdiff(k)*sigma_d(k,i)*waga_d !waga_d?
8278 c          sguscdiff=-guscdiff3(k)*dscdiff(k)*sigma_d(k,i)*waga_d ! w min_uscdiff
8279 c          sum_sguscdiff=sum_sguscdiff+sguscdiff
8280 c       enddo
8281 c
8282 c       Implementation of new expressions for gradient (Jan. 2015)
8283 c
8284 c       grad_uscdiff=sum_sguscdiff/(sum_guscdiff*dtab) !?
8285         do k=1,constr_homology
8286 c
8287 c       New calculation of dxx, dyy, and dzz corrected by AL (07/11), was missing and wrong
8288 c       before. Now the drivatives should be correct
8289 c
8290           dxx=-xxtpl(k,i)+xxtab(i) ! Diff b/w x component of ith SC vector in model and kth ref str?
8291 c                                  Original sign inverted for calc of gradients (s. Econstr_back)
8292           dyy=-yytpl(k,i)+yytab(i) ! ibid y
8293           dzz=-zztpl(k,i)+zztab(i) ! ibid z
8294 c
8295 c         New implementation
8296 c
8297           sum_guscdiff=guscdiff2(k)*!(dsqrt(dxx*dxx+dyy*dyy+dzz*dzz))* -> wrong!
8298      &                 sigma_d(k,i) ! for the grad wrt r'
8299 c         sum_sguscdiff=sum_sguscdiff+sum_guscdiff
8300 c
8301 c
8302 c        New implementation
8303          sum_guscdiff = waga_homology(iset)*waga_d*sum_guscdiff
8304          do jik=1,3
8305             duscdiff(jik,i-1)=duscdiff(jik,i-1)+
8306      &      sum_guscdiff*(dXX_C1tab(jik,i)*dxx+
8307      &      dYY_C1tab(jik,i)*dyy+dZZ_C1tab(jik,i)*dzz)/guscdiff(i)
8308             duscdiff(jik,i)=duscdiff(jik,i)+
8309      &      sum_guscdiff*(dXX_Ctab(jik,i)*dxx+
8310      &      dYY_Ctab(jik,i)*dyy+dZZ_Ctab(jik,i)*dzz)/guscdiff(i)
8311             duscdiffx(jik,i)=duscdiffx(jik,i)+
8312      &      sum_guscdiff*(dXX_XYZtab(jik,i)*dxx+
8313      &      dYY_XYZtab(jik,i)*dyy+dZZ_XYZtab(jik,i)*dzz)/guscdiff(i)
8314 c
8315 #ifdef DEBUG
8316              write(iout,*) "jik",jik,"i",i
8317              write(iout,*) "dxx, dyy, dzz"
8318              write(iout,'(2i5,3f8.2)') k,i,dxx,dyy,dzz
8319              write(iout,*) "guscdiff2(",k,")",guscdiff2(k)
8320 c            write(iout,*) "sum_sguscdiff",sum_sguscdiff
8321 cc           write(iout,*) "dXX_Ctab(",jik,i,")",dXX_Ctab(jik,i)
8322 c            write(iout,*) "dYY_Ctab(",jik,i,")",dYY_Ctab(jik,i)
8323 c            write(iout,*) "dZZ_Ctab(",jik,i,")",dZZ_Ctab(jik,i)
8324 c            write(iout,*) "dXX_C1tab(",jik,i,")",dXX_C1tab(jik,i)
8325 c            write(iout,*) "dYY_C1tab(",jik,i,")",dYY_C1tab(jik,i)
8326 c            write(iout,*) "dZZ_C1tab(",jik,i,")",dZZ_C1tab(jik,i)
8327 c            write(iout,*) "dXX_XYZtab(",jik,i,")",dXX_XYZtab(jik,i)
8328 c            write(iout,*) "dYY_XYZtab(",jik,i,")",dYY_XYZtab(jik,i)
8329 c            write(iout,*) "dZZ_XYZtab(",jik,i,")",dZZ_XYZtab(jik,i)
8330 c            write(iout,*) "duscdiff(",jik,i-1,")",duscdiff(jik,i-1)
8331 c            write(iout,*) "duscdiff(",jik,i,")",duscdiff(jik,i)
8332 c            write(iout,*) "duscdiffx(",jik,i,")",duscdiffx(jik,i)
8333 c            endif
8334 #endif
8335          enddo
8336         enddo
8337 c
8338 c       uscdiff(i)=-dLOG(guscdiff(i)/(ii-1))      ! Weighting by (ii-1) required?
8339 c        usc_diff(i)=-dLOG(guscdiff(i)/constr_homology) ! + min_uscdiff ?
8340 c
8341 c        write (iout,*) i," uscdiff",uscdiff(i)
8342 c
8343 c Put together deviations from local geometry
8344
8345 c       Uconst_back=Uconst_back+wfrag_back(1,i,iset)*utheta(i)+
8346 c      &            wfrag_back(3,i,iset)*uscdiff(i)
8347         Erot=Erot-dLOG(guscdiff(i)/constr_homology)
8348 c       write (iout,*) "usc_diff(",i,")=",usc_diff(i) ! -ln of sum of exps
8349 c       write (iout,*) "Uconst_back",Uconst_back ! cum sum of -ln-s
8350 c       Uconst_back=Uconst_back+usc_diff(i)
8351 c
8352 c     Gradient of multiple Gaussian restraint (FP - 04/11/2014 - right?)
8353 c
8354 c     New implment: multiplied by sum_sguscdiff
8355 c
8356
8357       enddo ! (i-loop for dscdiff)
8358
8359 c      endif
8360
8361 #ifdef DEBUG
8362       write(iout,*) "------- SC restrs end -------"
8363         write (iout,*) "------ After SC loop in e_modeller ------"
8364         do i=loc_start,loc_end
8365          write (iout,*) "i",i," gradc",(gradc(j,i,icg),j=1,3)
8366          write (iout,*) "i",i," gradx",(gradx(j,i,icg),j=1,3)
8367         enddo
8368       if (waga_theta.eq.1.0d0) then
8369       write (iout,*) "in e_modeller after SC restr end: dutheta"
8370       do i=ithet_start,ithet_end
8371         write (iout,*) i,dutheta(i)
8372       enddo
8373       endif
8374       if (waga_d.eq.1.0d0) then
8375       write (iout,*) "e_modeller after SC loop: duscdiff/x"
8376       do i=1,nres
8377         write (iout,*) i,(duscdiff(j,i),j=1,3)
8378         write (iout,*) i,(duscdiffx(j,i),j=1,3)
8379       enddo
8380       endif
8381 #endif
8382
8383 c Total energy from homology restraints
8384 #ifdef DEBUG
8385       write (iout,*) "odleg",odleg," kat",kat
8386 #endif
8387 c
8388 c Addition of energy of theta angle and SC local geom over constr_homologs ref strs
8389 c
8390 c     ehomology_constr=odleg+kat
8391 c
8392 c     For Lorentzian-type Urestr
8393 c
8394
8395       if (waga_dist.ge.0.0d0) then
8396 c
8397 c          For Gaussian-type Urestr
8398 c
8399         ehomology_constr=(waga_dist*odleg+waga_angle*kat+
8400      &              waga_theta*Eval+waga_d*Erot)*waga_homology(iset)
8401 c     write (iout,*) "ehomology_constr=",ehomology_constr
8402       else
8403 c
8404 c          For Lorentzian-type Urestr
8405 c
8406         ehomology_constr=(-waga_dist*odleg+waga_angle*kat+
8407      &              waga_theta*Eval+waga_d*Erot)*waga_homology(iset)
8408 c     write (iout,*) "ehomology_constr=",ehomology_constr
8409       endif
8410 #ifdef DEBUG
8411       write (iout,*) "odleg",waga_dist,odleg," kat",waga_angle,kat,
8412      & "Eval",waga_theta,eval,
8413      &   "Erot",waga_d,Erot
8414       write (iout,*) "ehomology_constr",ehomology_constr
8415 #endif
8416       return
8417 c
8418 c FP 01/15 end
8419 c
8420   748 format(a8,f12.3,a6,f12.3,a7,f12.3)
8421   747 format(a12,i4,i4,i4,f8.3,f8.3)
8422   746 format(a12,i4,i4,i4,f8.3,f8.3,f8.3)
8423   778 format(a7,1X,f10.3,1X,a4,1X,f10.3,1X,a5,1X,f10.3)
8424   779 format(i3,1X,i3,1X,i2,1X,a7,1X,f7.3,1X,a7,1X,f7.3,1X,a13,1X,
8425      &       f7.3,1X,a17,1X,f9.3,1X,a10,1X,f8.3,1X,a10,1X,f8.3)
8426       end
8427 c----------------------------------------------------------------------------
8428 C The rigorous attempt to derive energy function
8429       subroutine ebend_kcc(etheta)
8430
8431       implicit real*8 (a-h,o-z)
8432       include 'DIMENSIONS'
8433       include 'COMMON.VAR'
8434       include 'COMMON.GEO'
8435       include 'COMMON.LOCAL'
8436       include 'COMMON.TORSION'
8437       include 'COMMON.INTERACT'
8438       include 'COMMON.DERIV'
8439       include 'COMMON.CHAIN'
8440       include 'COMMON.NAMES'
8441       include 'COMMON.IOUNITS'
8442       include 'COMMON.FFIELD'
8443       include 'COMMON.TORCNSTR'
8444       include 'COMMON.CONTROL'
8445       logical lprn
8446       double precision thybt1(maxang_kcc)
8447 C Set lprn=.true. for debugging
8448       lprn=energy_dec
8449 c     lprn=.true.
8450 C      print *,"wchodze kcc"
8451       if (lprn) write (iout,*) "ebend_kcc tor_mode",tor_mode
8452       etheta=0.0D0
8453       do i=ithet_start,ithet_end
8454 c        print *,i,itype(i-1),itype(i),itype(i-2)
8455         if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
8456      &  .or.itype(i).eq.ntyp1) cycle
8457         iti=iabs(itortyp(itype(i-1)))
8458         sinthet=dsin(theta(i))
8459         costhet=dcos(theta(i))
8460         do j=1,nbend_kcc_Tb(iti)
8461           thybt1(j)=v1bend_chyb(j,iti)
8462         enddo
8463         sumth1thyb=v1bend_chyb(0,iti)+
8464      &    tschebyshev(1,nbend_kcc_Tb(iti),thybt1(1),costhet)
8465         if (lprn) write (iout,*) i-1,itype(i-1),iti,theta(i)*rad2deg,
8466      &    sumth1thyb
8467         ihelp=nbend_kcc_Tb(iti)-1
8468         gradthybt1=gradtschebyshev(0,ihelp,thybt1(1),costhet)
8469         etheta=etheta+sumth1thyb
8470 C        print *,sumth1thyb,gradthybt1,sinthet*(-0.5d0)
8471         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)-wang*gradthybt1*sinthet
8472       enddo
8473       return
8474       end
8475 c-------------------------------------------------------------------------------------
8476       subroutine etheta_constr(ethetacnstr)
8477
8478       implicit real*8 (a-h,o-z)
8479       include 'DIMENSIONS'
8480       include 'COMMON.VAR'
8481       include 'COMMON.GEO'
8482       include 'COMMON.LOCAL'
8483       include 'COMMON.TORSION'
8484       include 'COMMON.INTERACT'
8485       include 'COMMON.DERIV'
8486       include 'COMMON.CHAIN'
8487       include 'COMMON.NAMES'
8488       include 'COMMON.IOUNITS'
8489       include 'COMMON.FFIELD'
8490       include 'COMMON.TORCNSTR'
8491       include 'COMMON.CONTROL'
8492       ethetacnstr=0.0d0
8493 C      print *,ithetaconstr_start,ithetaconstr_end,"TU"
8494       do i=ithetaconstr_start,ithetaconstr_end
8495         itheta=itheta_constr(i)
8496         thetiii=theta(itheta)
8497         difi=pinorm(thetiii-theta_constr0(i))
8498         if (difi.gt.theta_drange(i)) then
8499           difi=difi-theta_drange(i)
8500           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
8501           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
8502      &    +for_thet_constr(i)*difi**3
8503         else if (difi.lt.-drange(i)) then
8504           difi=difi+drange(i)
8505           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
8506           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
8507      &    +for_thet_constr(i)*difi**3
8508         else
8509           difi=0.0
8510         endif
8511        if (energy_dec) then
8512         write (iout,'(a6,2i5,4f8.3,2e14.5)') "ethetc",
8513      &    i,itheta,rad2deg*thetiii,
8514      &    rad2deg*theta_constr0(i),  rad2deg*theta_drange(i),
8515      &    rad2deg*difi,0.25d0*for_thet_constr(i)*difi**4,
8516      &    gloc(itheta+nphi-2,icg)
8517         endif
8518       enddo
8519       return
8520       end
8521 c------------------------------------------------------------------------------
8522       subroutine eback_sc_corr(esccor)
8523 c 7/21/2007 Correlations between the backbone-local and side-chain-local
8524 c        conformational states; temporarily implemented as differences
8525 c        between UNRES torsional potentials (dependent on three types of
8526 c        residues) and the torsional potentials dependent on all 20 types
8527 c        of residues computed from AM1  energy surfaces of terminally-blocked
8528 c        amino-acid residues.
8529       implicit real*8 (a-h,o-z)
8530       include 'DIMENSIONS'
8531       include 'COMMON.VAR'
8532       include 'COMMON.GEO'
8533       include 'COMMON.LOCAL'
8534       include 'COMMON.TORSION'
8535       include 'COMMON.SCCOR'
8536       include 'COMMON.INTERACT'
8537       include 'COMMON.DERIV'
8538       include 'COMMON.CHAIN'
8539       include 'COMMON.NAMES'
8540       include 'COMMON.IOUNITS'
8541       include 'COMMON.FFIELD'
8542       include 'COMMON.CONTROL'
8543       logical lprn
8544 C Set lprn=.true. for debugging
8545       lprn=.false.
8546 c      lprn=.true.
8547 c      write (iout,*) "EBACK_SC_COR",itau_start,itau_end
8548       esccor=0.0D0
8549       do i=itau_start,itau_end
8550         if ((itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)) cycle
8551         esccor_ii=0.0D0
8552         isccori=isccortyp(itype(i-2))
8553         isccori1=isccortyp(itype(i-1))
8554 c      write (iout,*) "EBACK_SC_COR",i,nterm_sccor(isccori,isccori1)
8555         phii=phi(i)
8556         do intertyp=1,3 !intertyp
8557 cc Added 09 May 2012 (Adasko)
8558 cc  Intertyp means interaction type of backbone mainchain correlation:
8559 c   1 = SC...Ca...Ca...Ca
8560 c   2 = Ca...Ca...Ca...SC
8561 c   3 = SC...Ca...Ca...SCi
8562         gloci=0.0D0
8563         if (((intertyp.eq.3).and.((itype(i-2).eq.10).or.
8564      &      (itype(i-1).eq.10).or.(itype(i-2).eq.ntyp1).or.
8565      &      (itype(i-1).eq.ntyp1)))
8566      &    .or. ((intertyp.eq.1).and.((itype(i-2).eq.10)
8567      &     .or.(itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)
8568      &     .or.(itype(i).eq.ntyp1)))
8569      &    .or.((intertyp.eq.2).and.((itype(i-1).eq.10).or.
8570      &      (itype(i-1).eq.ntyp1).or.(itype(i-2).eq.ntyp1).or.
8571      &      (itype(i-3).eq.ntyp1)))) cycle
8572         if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1).eq.ntyp1)) cycle
8573         if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres).eq.ntyp1))
8574      & cycle
8575        do j=1,nterm_sccor(isccori,isccori1)
8576           v1ij=v1sccor(j,intertyp,isccori,isccori1)
8577           v2ij=v2sccor(j,intertyp,isccori,isccori1)
8578           cosphi=dcos(j*tauangle(intertyp,i))
8579           sinphi=dsin(j*tauangle(intertyp,i))
8580           esccor=esccor+v1ij*cosphi+v2ij*sinphi
8581           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
8582         enddo
8583 c      write (iout,*) "EBACK_SC_COR",i,v1ij*cosphi+v2ij*sinphi,intertyp
8584         gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci
8585         if (lprn)
8586      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
8587      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,isccori,isccori1,
8588      &  (v1sccor(j,intertyp,isccori,isccori1),j=1,6)
8589      & ,(v2sccor(j,intertyp,isccori,isccori1),j=1,6)
8590         gsccor_loc(i-3)=gsccor_loc(i-3)+gloci
8591        enddo !intertyp
8592       enddo
8593
8594       return
8595       end
8596 #ifdef FOURBODY
8597 c----------------------------------------------------------------------------
8598       subroutine multibody(ecorr)
8599 C This subroutine calculates multi-body contributions to energy following
8600 C the idea of Skolnick et al. If side chains I and J make a contact and
8601 C at the same time side chains I+1 and J+1 make a contact, an extra
8602 C contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
8603       implicit real*8 (a-h,o-z)
8604       include 'DIMENSIONS'
8605       include 'COMMON.IOUNITS'
8606       include 'COMMON.DERIV'
8607       include 'COMMON.INTERACT'
8608       include 'COMMON.CONTACTS'
8609       include 'COMMON.CONTMAT'
8610       include 'COMMON.CORRMAT'
8611       double precision gx(3),gx1(3)
8612       logical lprn
8613
8614 C Set lprn=.true. for debugging
8615       lprn=.false.
8616
8617       if (lprn) then
8618         write (iout,'(a)') 'Contact function values:'
8619         do i=nnt,nct-2
8620           write (iout,'(i2,20(1x,i2,f10.5))')
8621      &        i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
8622         enddo
8623       endif
8624       ecorr=0.0D0
8625       do i=nnt,nct
8626         do j=1,3
8627           gradcorr(j,i)=0.0D0
8628           gradxorr(j,i)=0.0D0
8629         enddo
8630       enddo
8631       do i=nnt,nct-2
8632
8633         DO ISHIFT = 3,4
8634
8635         i1=i+ishift
8636         num_conti=num_cont(i)
8637         num_conti1=num_cont(i1)
8638         do jj=1,num_conti
8639           j=jcont(jj,i)
8640           do kk=1,num_conti1
8641             j1=jcont(kk,i1)
8642             if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
8643 cd          write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
8644 cd   &                   ' ishift=',ishift
8645 C Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
8646 C The system gains extra energy.
8647               ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
8648             endif   ! j1==j+-ishift
8649           enddo     ! kk
8650         enddo       ! jj
8651
8652         ENDDO ! ISHIFT
8653
8654       enddo         ! i
8655       return
8656       end
8657 c------------------------------------------------------------------------------
8658       double precision function esccorr(i,j,k,l,jj,kk)
8659       implicit real*8 (a-h,o-z)
8660       include 'DIMENSIONS'
8661       include 'COMMON.IOUNITS'
8662       include 'COMMON.DERIV'
8663       include 'COMMON.INTERACT'
8664       include 'COMMON.CONTACTS'
8665       include 'COMMON.CONTMAT'
8666       include 'COMMON.CORRMAT'
8667       include 'COMMON.SHIELD'
8668       double precision gx(3),gx1(3)
8669       logical lprn
8670       lprn=.false.
8671       eij=facont(jj,i)
8672       ekl=facont(kk,k)
8673 cd    write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
8674 C Calculate the multi-body contribution to energy.
8675 C Calculate multi-body contributions to the gradient.
8676 cd    write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
8677 cd   & k,l,(gacont(m,kk,k),m=1,3)
8678       do m=1,3
8679         gx(m) =ekl*gacont(m,jj,i)
8680         gx1(m)=eij*gacont(m,kk,k)
8681         gradxorr(m,i)=gradxorr(m,i)-gx(m)
8682         gradxorr(m,j)=gradxorr(m,j)+gx(m)
8683         gradxorr(m,k)=gradxorr(m,k)-gx1(m)
8684         gradxorr(m,l)=gradxorr(m,l)+gx1(m)
8685       enddo
8686       do m=i,j-1
8687         do ll=1,3
8688           gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
8689         enddo
8690       enddo
8691       do m=k,l-1
8692         do ll=1,3
8693           gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
8694         enddo
8695       enddo
8696       esccorr=-eij*ekl
8697       return
8698       end
8699 c------------------------------------------------------------------------------
8700       subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
8701 C This subroutine calculates multi-body contributions to hydrogen-bonding
8702       implicit real*8 (a-h,o-z)
8703       include 'DIMENSIONS'
8704       include 'COMMON.IOUNITS'
8705 #ifdef MPI
8706       include "mpif.h"
8707       parameter (max_cont=maxconts)
8708       parameter (max_dim=26)
8709       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
8710       double precision zapas(max_dim,maxconts,max_fg_procs),
8711      &  zapas_recv(max_dim,maxconts,max_fg_procs)
8712       common /przechowalnia/ zapas
8713       integer status(MPI_STATUS_SIZE),req(maxconts*2),
8714      &  status_array(MPI_STATUS_SIZE,maxconts*2)
8715 #endif
8716       include 'COMMON.SETUP'
8717       include 'COMMON.FFIELD'
8718       include 'COMMON.DERIV'
8719       include 'COMMON.INTERACT'
8720       include 'COMMON.CONTACTS'
8721       include 'COMMON.CONTMAT'
8722       include 'COMMON.CORRMAT'
8723       include 'COMMON.CONTROL'
8724       include 'COMMON.LOCAL'
8725       double precision gx(3),gx1(3),time00
8726       logical lprn,ldone
8727
8728 C Set lprn=.true. for debugging
8729       lprn=.false.
8730 #ifdef MPI
8731       n_corr=0
8732       n_corr1=0
8733       if (nfgtasks.le.1) goto 30
8734       if (lprn) then
8735         write (iout,'(a)') 'Contact function values before RECEIVE:'
8736         do i=nnt,nct-2
8737           write (iout,'(2i3,50(1x,i2,f5.2))')
8738      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
8739      &    j=1,num_cont_hb(i))
8740         enddo
8741         call flush(iout)
8742       endif
8743       do i=1,ntask_cont_from
8744         ncont_recv(i)=0
8745       enddo
8746       do i=1,ntask_cont_to
8747         ncont_sent(i)=0
8748       enddo
8749 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
8750 c     & ntask_cont_to
8751 C Make the list of contacts to send to send to other procesors
8752 c      write (iout,*) "limits",max0(iturn4_end-1,iatel_s),iturn3_end
8753 c      call flush(iout)
8754       do i=iturn3_start,iturn3_end
8755 c        write (iout,*) "make contact list turn3",i," num_cont",
8756 c     &    num_cont_hb(i)
8757         call add_hb_contact(i,i+2,iturn3_sent_local(1,i))
8758       enddo
8759       do i=iturn4_start,iturn4_end
8760 c        write (iout,*) "make contact list turn4",i," num_cont",
8761 c     &   num_cont_hb(i)
8762         call add_hb_contact(i,i+3,iturn4_sent_local(1,i))
8763       enddo
8764       do ii=1,nat_sent
8765         i=iat_sent(ii)
8766 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
8767 c     &    num_cont_hb(i)
8768         do j=1,num_cont_hb(i)
8769         do k=1,4
8770           jjc=jcont_hb(j,i)
8771           iproc=iint_sent_local(k,jjc,ii)
8772 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
8773           if (iproc.gt.0) then
8774             ncont_sent(iproc)=ncont_sent(iproc)+1
8775             nn=ncont_sent(iproc)
8776             zapas(1,nn,iproc)=i
8777             zapas(2,nn,iproc)=jjc
8778             zapas(3,nn,iproc)=facont_hb(j,i)
8779             zapas(4,nn,iproc)=ees0p(j,i)
8780             zapas(5,nn,iproc)=ees0m(j,i)
8781             zapas(6,nn,iproc)=gacont_hbr(1,j,i)
8782             zapas(7,nn,iproc)=gacont_hbr(2,j,i)
8783             zapas(8,nn,iproc)=gacont_hbr(3,j,i)
8784             zapas(9,nn,iproc)=gacontm_hb1(1,j,i)
8785             zapas(10,nn,iproc)=gacontm_hb1(2,j,i)
8786             zapas(11,nn,iproc)=gacontm_hb1(3,j,i)
8787             zapas(12,nn,iproc)=gacontp_hb1(1,j,i)
8788             zapas(13,nn,iproc)=gacontp_hb1(2,j,i)
8789             zapas(14,nn,iproc)=gacontp_hb1(3,j,i)
8790             zapas(15,nn,iproc)=gacontm_hb2(1,j,i)
8791             zapas(16,nn,iproc)=gacontm_hb2(2,j,i)
8792             zapas(17,nn,iproc)=gacontm_hb2(3,j,i)
8793             zapas(18,nn,iproc)=gacontp_hb2(1,j,i)
8794             zapas(19,nn,iproc)=gacontp_hb2(2,j,i)
8795             zapas(20,nn,iproc)=gacontp_hb2(3,j,i)
8796             zapas(21,nn,iproc)=gacontm_hb3(1,j,i)
8797             zapas(22,nn,iproc)=gacontm_hb3(2,j,i)
8798             zapas(23,nn,iproc)=gacontm_hb3(3,j,i)
8799             zapas(24,nn,iproc)=gacontp_hb3(1,j,i)
8800             zapas(25,nn,iproc)=gacontp_hb3(2,j,i)
8801             zapas(26,nn,iproc)=gacontp_hb3(3,j,i)
8802           endif
8803         enddo
8804         enddo
8805       enddo
8806       if (lprn) then
8807       write (iout,*)
8808      &  "Numbers of contacts to be sent to other processors",
8809      &  (ncont_sent(i),i=1,ntask_cont_to)
8810       write (iout,*) "Contacts sent"
8811       do ii=1,ntask_cont_to
8812         nn=ncont_sent(ii)
8813         iproc=itask_cont_to(ii)
8814         write (iout,*) nn," contacts to processor",iproc,
8815      &   " of CONT_TO_COMM group"
8816         do i=1,nn
8817           write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
8818         enddo
8819       enddo
8820       call flush(iout)
8821       endif
8822       CorrelType=477
8823       CorrelID=fg_rank+1
8824       CorrelType1=478
8825       CorrelID1=nfgtasks+fg_rank+1
8826       ireq=0
8827 C Receive the numbers of needed contacts from other processors
8828       do ii=1,ntask_cont_from
8829         iproc=itask_cont_from(ii)
8830         ireq=ireq+1
8831         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
8832      &    FG_COMM,req(ireq),IERR)
8833       enddo
8834 c      write (iout,*) "IRECV ended"
8835 c      call flush(iout)
8836 C Send the number of contacts needed by other processors
8837       do ii=1,ntask_cont_to
8838         iproc=itask_cont_to(ii)
8839         ireq=ireq+1
8840         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
8841      &    FG_COMM,req(ireq),IERR)
8842       enddo
8843 c      write (iout,*) "ISEND ended"
8844 c      write (iout,*) "number of requests (nn)",ireq
8845 c      call flush(iout)
8846       if (ireq.gt.0)
8847      &  call MPI_Waitall(ireq,req,status_array,ierr)
8848 c      write (iout,*)
8849 c     &  "Numbers of contacts to be received from other processors",
8850 c     &  (ncont_recv(i),i=1,ntask_cont_from)
8851 c      call flush(iout)
8852 C Receive contacts
8853       ireq=0
8854       do ii=1,ntask_cont_from
8855         iproc=itask_cont_from(ii)
8856         nn=ncont_recv(ii)
8857 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
8858 c     &   " of CONT_TO_COMM group"
8859 c        call flush(iout)
8860         if (nn.gt.0) then
8861           ireq=ireq+1
8862           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
8863      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
8864 c          write (iout,*) "ireq,req",ireq,req(ireq)
8865         endif
8866       enddo
8867 C Send the contacts to processors that need them
8868       do ii=1,ntask_cont_to
8869         iproc=itask_cont_to(ii)
8870         nn=ncont_sent(ii)
8871 c        write (iout,*) nn," contacts to processor",iproc,
8872 c     &   " of CONT_TO_COMM group"
8873         if (nn.gt.0) then
8874           ireq=ireq+1
8875           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
8876      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
8877 c          write (iout,*) "ireq,req",ireq,req(ireq)
8878 c          do i=1,nn
8879 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
8880 c          enddo
8881         endif
8882       enddo
8883 c      write (iout,*) "number of requests (contacts)",ireq
8884 c      write (iout,*) "req",(req(i),i=1,4)
8885 c      call flush(iout)
8886       if (ireq.gt.0)
8887      & call MPI_Waitall(ireq,req,status_array,ierr)
8888       do iii=1,ntask_cont_from
8889         iproc=itask_cont_from(iii)
8890         nn=ncont_recv(iii)
8891         if (lprn) then
8892         write (iout,*) "Received",nn," contacts from processor",iproc,
8893      &   " of CONT_FROM_COMM group"
8894         call flush(iout)
8895         do i=1,nn
8896           write(iout,'(2f5.0,4f10.5)')(zapas_recv(j,i,iii),j=1,5)
8897         enddo
8898         call flush(iout)
8899         endif
8900         do i=1,nn
8901           ii=zapas_recv(1,i,iii)
8902 c Flag the received contacts to prevent double-counting
8903           jj=-zapas_recv(2,i,iii)
8904 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
8905 c          call flush(iout)
8906           nnn=num_cont_hb(ii)+1
8907           num_cont_hb(ii)=nnn
8908           jcont_hb(nnn,ii)=jj
8909           facont_hb(nnn,ii)=zapas_recv(3,i,iii)
8910           ees0p(nnn,ii)=zapas_recv(4,i,iii)
8911           ees0m(nnn,ii)=zapas_recv(5,i,iii)
8912           gacont_hbr(1,nnn,ii)=zapas_recv(6,i,iii)
8913           gacont_hbr(2,nnn,ii)=zapas_recv(7,i,iii)
8914           gacont_hbr(3,nnn,ii)=zapas_recv(8,i,iii)
8915           gacontm_hb1(1,nnn,ii)=zapas_recv(9,i,iii)
8916           gacontm_hb1(2,nnn,ii)=zapas_recv(10,i,iii)
8917           gacontm_hb1(3,nnn,ii)=zapas_recv(11,i,iii)
8918           gacontp_hb1(1,nnn,ii)=zapas_recv(12,i,iii)
8919           gacontp_hb1(2,nnn,ii)=zapas_recv(13,i,iii)
8920           gacontp_hb1(3,nnn,ii)=zapas_recv(14,i,iii)
8921           gacontm_hb2(1,nnn,ii)=zapas_recv(15,i,iii)
8922           gacontm_hb2(2,nnn,ii)=zapas_recv(16,i,iii)
8923           gacontm_hb2(3,nnn,ii)=zapas_recv(17,i,iii)
8924           gacontp_hb2(1,nnn,ii)=zapas_recv(18,i,iii)
8925           gacontp_hb2(2,nnn,ii)=zapas_recv(19,i,iii)
8926           gacontp_hb2(3,nnn,ii)=zapas_recv(20,i,iii)
8927           gacontm_hb3(1,nnn,ii)=zapas_recv(21,i,iii)
8928           gacontm_hb3(2,nnn,ii)=zapas_recv(22,i,iii)
8929           gacontm_hb3(3,nnn,ii)=zapas_recv(23,i,iii)
8930           gacontp_hb3(1,nnn,ii)=zapas_recv(24,i,iii)
8931           gacontp_hb3(2,nnn,ii)=zapas_recv(25,i,iii)
8932           gacontp_hb3(3,nnn,ii)=zapas_recv(26,i,iii)
8933         enddo
8934       enddo
8935       if (lprn) then
8936         write (iout,'(a)') 'Contact function values after receive:'
8937         do i=nnt,nct-2
8938           write (iout,'(2i3,50(1x,i3,f5.2))')
8939      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
8940      &    j=1,num_cont_hb(i))
8941         enddo
8942         call flush(iout)
8943       endif
8944    30 continue
8945 #endif
8946       if (lprn) then
8947         write (iout,'(a)') 'Contact function values:'
8948         do i=nnt,nct-2
8949           write (iout,'(2i3,50(1x,i3,f5.2))')
8950      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
8951      &    j=1,num_cont_hb(i))
8952         enddo
8953         call flush(iout)
8954       endif
8955       ecorr=0.0D0
8956 C Remove the loop below after debugging !!!
8957       do i=nnt,nct
8958         do j=1,3
8959           gradcorr(j,i)=0.0D0
8960           gradxorr(j,i)=0.0D0
8961         enddo
8962       enddo
8963 C Calculate the local-electrostatic correlation terms
8964       do i=min0(iatel_s,iturn4_start),max0(iatel_e,iturn3_end)
8965         i1=i+1
8966         num_conti=num_cont_hb(i)
8967         num_conti1=num_cont_hb(i+1)
8968         do jj=1,num_conti
8969           j=jcont_hb(jj,i)
8970           jp=iabs(j)
8971           do kk=1,num_conti1
8972             j1=jcont_hb(kk,i1)
8973             jp1=iabs(j1)
8974 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
8975 c     &         ' jj=',jj,' kk=',kk
8976 c            call flush(iout)
8977             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
8978      &          .or. j.lt.0 .and. j1.gt.0) .and.
8979      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
8980 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
8981 C The system gains extra energy.
8982               ecorr=ecorr+ehbcorr(i,jp,i+1,jp1,jj,kk,0.72D0,0.32D0)
8983               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
8984      &            'ecorrh',i,j,ehbcorr(i,j,i+1,j1,jj,kk,0.72D0,0.32D0)
8985               n_corr=n_corr+1
8986             else if (j1.eq.j) then
8987 C Contacts I-J and I-(J+1) occur simultaneously.
8988 C The system loses extra energy.
8989 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
8990             endif
8991           enddo ! kk
8992           do kk=1,num_conti
8993             j1=jcont_hb(kk,i)
8994 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
8995 c    &         ' jj=',jj,' kk=',kk
8996             if (j1.eq.j+1) then
8997 C Contacts I-J and (I+1)-J occur simultaneously.
8998 C The system loses extra energy.
8999 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
9000             endif ! j1==j+1
9001           enddo ! kk
9002         enddo ! jj
9003       enddo ! i
9004       return
9005       end
9006 c------------------------------------------------------------------------------
9007       subroutine add_hb_contact(ii,jj,itask)
9008       implicit real*8 (a-h,o-z)
9009       include "DIMENSIONS"
9010       include "COMMON.IOUNITS"
9011       integer max_cont
9012       integer max_dim
9013       parameter (max_cont=maxconts)
9014       parameter (max_dim=26)
9015       include "COMMON.CONTACTS"
9016       include 'COMMON.CONTMAT'
9017       include 'COMMON.CORRMAT'
9018       double precision zapas(max_dim,maxconts,max_fg_procs),
9019      &  zapas_recv(max_dim,maxconts,max_fg_procs)
9020       common /przechowalnia/ zapas
9021       integer i,j,ii,jj,iproc,itask(4),nn
9022 c      write (iout,*) "itask",itask
9023       do i=1,2
9024         iproc=itask(i)
9025         if (iproc.gt.0) then
9026           do j=1,num_cont_hb(ii)
9027             jjc=jcont_hb(j,ii)
9028 c            write (iout,*) "i",ii," j",jj," jjc",jjc
9029             if (jjc.eq.jj) then
9030               ncont_sent(iproc)=ncont_sent(iproc)+1
9031               nn=ncont_sent(iproc)
9032               zapas(1,nn,iproc)=ii
9033               zapas(2,nn,iproc)=jjc
9034               zapas(3,nn,iproc)=facont_hb(j,ii)
9035               zapas(4,nn,iproc)=ees0p(j,ii)
9036               zapas(5,nn,iproc)=ees0m(j,ii)
9037               zapas(6,nn,iproc)=gacont_hbr(1,j,ii)
9038               zapas(7,nn,iproc)=gacont_hbr(2,j,ii)
9039               zapas(8,nn,iproc)=gacont_hbr(3,j,ii)
9040               zapas(9,nn,iproc)=gacontm_hb1(1,j,ii)
9041               zapas(10,nn,iproc)=gacontm_hb1(2,j,ii)
9042               zapas(11,nn,iproc)=gacontm_hb1(3,j,ii)
9043               zapas(12,nn,iproc)=gacontp_hb1(1,j,ii)
9044               zapas(13,nn,iproc)=gacontp_hb1(2,j,ii)
9045               zapas(14,nn,iproc)=gacontp_hb1(3,j,ii)
9046               zapas(15,nn,iproc)=gacontm_hb2(1,j,ii)
9047               zapas(16,nn,iproc)=gacontm_hb2(2,j,ii)
9048               zapas(17,nn,iproc)=gacontm_hb2(3,j,ii)
9049               zapas(18,nn,iproc)=gacontp_hb2(1,j,ii)
9050               zapas(19,nn,iproc)=gacontp_hb2(2,j,ii)
9051               zapas(20,nn,iproc)=gacontp_hb2(3,j,ii)
9052               zapas(21,nn,iproc)=gacontm_hb3(1,j,ii)
9053               zapas(22,nn,iproc)=gacontm_hb3(2,j,ii)
9054               zapas(23,nn,iproc)=gacontm_hb3(3,j,ii)
9055               zapas(24,nn,iproc)=gacontp_hb3(1,j,ii)
9056               zapas(25,nn,iproc)=gacontp_hb3(2,j,ii)
9057               zapas(26,nn,iproc)=gacontp_hb3(3,j,ii)
9058               exit
9059             endif
9060           enddo
9061         endif
9062       enddo
9063       return
9064       end
9065 c------------------------------------------------------------------------------
9066       subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,
9067      &  n_corr1)
9068 C This subroutine calculates multi-body contributions to hydrogen-bonding
9069       implicit real*8 (a-h,o-z)
9070       include 'DIMENSIONS'
9071       include 'COMMON.IOUNITS'
9072 #ifdef MPI
9073       include "mpif.h"
9074       parameter (max_cont=maxconts)
9075       parameter (max_dim=70)
9076       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
9077       double precision zapas(max_dim,maxconts,max_fg_procs),
9078      &  zapas_recv(max_dim,maxconts,max_fg_procs)
9079       common /przechowalnia/ zapas
9080       integer status(MPI_STATUS_SIZE),req(maxconts*2),
9081      &  status_array(MPI_STATUS_SIZE,maxconts*2)
9082 #endif
9083       include 'COMMON.SETUP'
9084       include 'COMMON.FFIELD'
9085       include 'COMMON.DERIV'
9086       include 'COMMON.LOCAL'
9087       include 'COMMON.INTERACT'
9088       include 'COMMON.CONTACTS'
9089       include 'COMMON.CONTMAT'
9090       include 'COMMON.CORRMAT'
9091       include 'COMMON.CHAIN'
9092       include 'COMMON.CONTROL'
9093       include 'COMMON.SHIELD'
9094       double precision gx(3),gx1(3)
9095       integer num_cont_hb_old(maxres)
9096       logical lprn,ldone
9097       double precision eello4,eello5,eelo6,eello_turn6
9098       external eello4,eello5,eello6,eello_turn6
9099 C Set lprn=.true. for debugging
9100       lprn=.false.
9101       eturn6=0.0d0
9102 #ifdef MPI
9103       do i=1,nres
9104         num_cont_hb_old(i)=num_cont_hb(i)
9105       enddo
9106       n_corr=0
9107       n_corr1=0
9108       if (nfgtasks.le.1) goto 30
9109       if (lprn) then
9110         write (iout,'(a)') 'Contact function values before RECEIVE:'
9111         do i=nnt,nct-2
9112           write (iout,'(2i3,50(1x,i2,f5.2))')
9113      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
9114      &    j=1,num_cont_hb(i))
9115         enddo
9116       endif
9117       do i=1,ntask_cont_from
9118         ncont_recv(i)=0
9119       enddo
9120       do i=1,ntask_cont_to
9121         ncont_sent(i)=0
9122       enddo
9123 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
9124 c     & ntask_cont_to
9125 C Make the list of contacts to send to send to other procesors
9126       do i=iturn3_start,iturn3_end
9127 c        write (iout,*) "make contact list turn3",i," num_cont",
9128 c     &    num_cont_hb(i)
9129         call add_hb_contact_eello(i,i+2,iturn3_sent_local(1,i))
9130       enddo
9131       do i=iturn4_start,iturn4_end
9132 c        write (iout,*) "make contact list turn4",i," num_cont",
9133 c     &   num_cont_hb(i)
9134         call add_hb_contact_eello(i,i+3,iturn4_sent_local(1,i))
9135       enddo
9136       do ii=1,nat_sent
9137         i=iat_sent(ii)
9138 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
9139 c     &    num_cont_hb(i)
9140         do j=1,num_cont_hb(i)
9141         do k=1,4
9142           jjc=jcont_hb(j,i)
9143           iproc=iint_sent_local(k,jjc,ii)
9144 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
9145           if (iproc.ne.0) then
9146             ncont_sent(iproc)=ncont_sent(iproc)+1
9147             nn=ncont_sent(iproc)
9148             zapas(1,nn,iproc)=i
9149             zapas(2,nn,iproc)=jjc
9150             zapas(3,nn,iproc)=d_cont(j,i)
9151             ind=3
9152             do kk=1,3
9153               ind=ind+1
9154               zapas(ind,nn,iproc)=grij_hb_cont(kk,j,i)
9155             enddo
9156             do kk=1,2
9157               do ll=1,2
9158                 ind=ind+1
9159                 zapas(ind,nn,iproc)=a_chuj(ll,kk,j,i)
9160               enddo
9161             enddo
9162             do jj=1,5
9163               do kk=1,3
9164                 do ll=1,2
9165                   do mm=1,2
9166                     ind=ind+1
9167                     zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,i)
9168                   enddo
9169                 enddo
9170               enddo
9171             enddo
9172           endif
9173         enddo
9174         enddo
9175       enddo
9176       if (lprn) then
9177       write (iout,*)
9178      &  "Numbers of contacts to be sent to other processors",
9179      &  (ncont_sent(i),i=1,ntask_cont_to)
9180       write (iout,*) "Contacts sent"
9181       do ii=1,ntask_cont_to
9182         nn=ncont_sent(ii)
9183         iproc=itask_cont_to(ii)
9184         write (iout,*) nn," contacts to processor",iproc,
9185      &   " of CONT_TO_COMM group"
9186         do i=1,nn
9187           write(iout,'(2f5.0,10f10.5)')(zapas(j,i,ii),j=1,10)
9188         enddo
9189       enddo
9190       call flush(iout)
9191       endif
9192       CorrelType=477
9193       CorrelID=fg_rank+1
9194       CorrelType1=478
9195       CorrelID1=nfgtasks+fg_rank+1
9196       ireq=0
9197 C Receive the numbers of needed contacts from other processors
9198       do ii=1,ntask_cont_from
9199         iproc=itask_cont_from(ii)
9200         ireq=ireq+1
9201         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
9202      &    FG_COMM,req(ireq),IERR)
9203       enddo
9204 c      write (iout,*) "IRECV ended"
9205 c      call flush(iout)
9206 C Send the number of contacts needed by other processors
9207       do ii=1,ntask_cont_to
9208         iproc=itask_cont_to(ii)
9209         ireq=ireq+1
9210         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
9211      &    FG_COMM,req(ireq),IERR)
9212       enddo
9213 c      write (iout,*) "ISEND ended"
9214 c      write (iout,*) "number of requests (nn)",ireq
9215 c      call flush(iout)
9216       if (ireq.gt.0)
9217      &  call MPI_Waitall(ireq,req,status_array,ierr)
9218 c      write (iout,*)
9219 c     &  "Numbers of contacts to be received from other processors",
9220 c     &  (ncont_recv(i),i=1,ntask_cont_from)
9221 c      call flush(iout)
9222 C Receive contacts
9223       ireq=0
9224       do ii=1,ntask_cont_from
9225         iproc=itask_cont_from(ii)
9226         nn=ncont_recv(ii)
9227 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
9228 c     &   " of CONT_TO_COMM group"
9229 c        call flush(iout)
9230         if (nn.gt.0) then
9231           ireq=ireq+1
9232           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
9233      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
9234 c          write (iout,*) "ireq,req",ireq,req(ireq)
9235         endif
9236       enddo
9237 C Send the contacts to processors that need them
9238       do ii=1,ntask_cont_to
9239         iproc=itask_cont_to(ii)
9240         nn=ncont_sent(ii)
9241 c        write (iout,*) nn," contacts to processor",iproc,
9242 c     &   " of CONT_TO_COMM group"
9243         if (nn.gt.0) then
9244           ireq=ireq+1
9245           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
9246      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
9247 c          write (iout,*) "ireq,req",ireq,req(ireq)
9248 c          do i=1,nn
9249 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
9250 c          enddo
9251         endif
9252       enddo
9253 c      write (iout,*) "number of requests (contacts)",ireq
9254 c      write (iout,*) "req",(req(i),i=1,4)
9255 c      call flush(iout)
9256       if (ireq.gt.0)
9257      & call MPI_Waitall(ireq,req,status_array,ierr)
9258       do iii=1,ntask_cont_from
9259         iproc=itask_cont_from(iii)
9260         nn=ncont_recv(iii)
9261         if (lprn) then
9262         write (iout,*) "Received",nn," contacts from processor",iproc,
9263      &   " of CONT_FROM_COMM group"
9264         call flush(iout)
9265         do i=1,nn
9266           write(iout,'(2f5.0,10f10.5)')(zapas_recv(j,i,iii),j=1,10)
9267         enddo
9268         call flush(iout)
9269         endif
9270         do i=1,nn
9271           ii=zapas_recv(1,i,iii)
9272 c Flag the received contacts to prevent double-counting
9273           jj=-zapas_recv(2,i,iii)
9274 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
9275 c          call flush(iout)
9276           nnn=num_cont_hb(ii)+1
9277           num_cont_hb(ii)=nnn
9278           jcont_hb(nnn,ii)=jj
9279           d_cont(nnn,ii)=zapas_recv(3,i,iii)
9280           ind=3
9281           do kk=1,3
9282             ind=ind+1
9283             grij_hb_cont(kk,nnn,ii)=zapas_recv(ind,i,iii)
9284           enddo
9285           do kk=1,2
9286             do ll=1,2
9287               ind=ind+1
9288               a_chuj(ll,kk,nnn,ii)=zapas_recv(ind,i,iii)
9289             enddo
9290           enddo
9291           do jj=1,5
9292             do kk=1,3
9293               do ll=1,2
9294                 do mm=1,2
9295                   ind=ind+1
9296                   a_chuj_der(mm,ll,kk,jj,nnn,ii)=zapas_recv(ind,i,iii)
9297                 enddo
9298               enddo
9299             enddo
9300           enddo
9301         enddo
9302       enddo
9303       if (lprn) then
9304         write (iout,'(a)') 'Contact function values after receive:'
9305         do i=nnt,nct-2
9306           write (iout,'(2i3,50(1x,i3,5f6.3))')
9307      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
9308      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
9309         enddo
9310         call flush(iout)
9311       endif
9312    30 continue
9313 #endif
9314       if (lprn) then
9315         write (iout,'(a)') 'Contact function values:'
9316         do i=nnt,nct-2
9317           write (iout,'(2i3,50(1x,i2,5f6.3))')
9318      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
9319      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
9320         enddo
9321       endif
9322       ecorr=0.0D0
9323       ecorr5=0.0d0
9324       ecorr6=0.0d0
9325 C Remove the loop below after debugging !!!
9326       do i=nnt,nct
9327         do j=1,3
9328           gradcorr(j,i)=0.0D0
9329           gradxorr(j,i)=0.0D0
9330         enddo
9331       enddo
9332 C Calculate the dipole-dipole interaction energies
9333       if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
9334       do i=iatel_s,iatel_e+1
9335         num_conti=num_cont_hb(i)
9336         do jj=1,num_conti
9337           j=jcont_hb(jj,i)
9338 #ifdef MOMENT
9339           call dipole(i,j,jj)
9340 #endif
9341         enddo
9342       enddo
9343       endif
9344 C Calculate the local-electrostatic correlation terms
9345 c                write (iout,*) "gradcorr5 in eello5 before loop"
9346 c                do iii=1,nres
9347 c                  write (iout,'(i5,3f10.5)')
9348 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
9349 c                enddo
9350       do i=min0(iatel_s,iturn4_start),max0(iatel_e+1,iturn3_end+1)
9351 c        write (iout,*) "corr loop i",i
9352         i1=i+1
9353         num_conti=num_cont_hb(i)
9354         num_conti1=num_cont_hb(i+1)
9355         do jj=1,num_conti
9356           j=jcont_hb(jj,i)
9357           jp=iabs(j)
9358           do kk=1,num_conti1
9359             j1=jcont_hb(kk,i1)
9360             jp1=iabs(j1)
9361 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
9362 c     &         ' jj=',jj,' kk=',kk
9363 c            if (j1.eq.j+1 .or. j1.eq.j-1) then
9364             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
9365      &          .or. j.lt.0 .and. j1.gt.0) .and.
9366      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
9367 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
9368 C The system gains extra energy.
9369               n_corr=n_corr+1
9370               sqd1=dsqrt(d_cont(jj,i))
9371               sqd2=dsqrt(d_cont(kk,i1))
9372               sred_geom = sqd1*sqd2
9373               IF (sred_geom.lt.cutoff_corr) THEN
9374                 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,
9375      &            ekont,fprimcont)
9376 cd               write (iout,*) 'i=',i,' j=',jp,' i1=',i1,' j1=',jp1,
9377 cd     &         ' jj=',jj,' kk=',kk
9378                 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
9379                 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
9380                 do l=1,3
9381                   g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
9382                   g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
9383                 enddo
9384                 n_corr1=n_corr1+1
9385 cd               write (iout,*) 'sred_geom=',sred_geom,
9386 cd     &          ' ekont=',ekont,' fprim=',fprimcont,
9387 cd     &          ' fac_prim1',fac_prim1,' fac_prim2',fac_prim2
9388 cd               write (iout,*) "g_contij",g_contij
9389 cd               write (iout,*) "grij_hb_cont i",grij_hb_cont(:,jj,i)
9390 cd               write (iout,*) "grij_hb_cont i1",grij_hb_cont(:,jj,i1)
9391                 call calc_eello(i,jp,i+1,jp1,jj,kk)
9392                 if (wcorr4.gt.0.0d0)
9393      &            ecorr=ecorr+eello4(i,jp,i+1,jp1,jj,kk)
9394 CC     &            *fac_shield(i)**2*fac_shield(j)**2
9395                   if (energy_dec.and.wcorr4.gt.0.0d0)
9396      1                 write (iout,'(a6,4i5,0pf7.3)')
9397      2                'ecorr4',i,j,i+1,j1,eello4(i,jp,i+1,jp1,jj,kk)
9398 c                write (iout,*) "gradcorr5 before eello5"
9399 c                do iii=1,nres
9400 c                  write (iout,'(i5,3f10.5)')
9401 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
9402 c                enddo
9403                 if (wcorr5.gt.0.0d0)
9404      &            ecorr5=ecorr5+eello5(i,jp,i+1,jp1,jj,kk)
9405 c                write (iout,*) "gradcorr5 after eello5"
9406 c                do iii=1,nres
9407 c                  write (iout,'(i5,3f10.5)')
9408 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
9409 c                enddo
9410                   if (energy_dec.and.wcorr5.gt.0.0d0)
9411      1                 write (iout,'(a6,4i5,0pf7.3)')
9412      2                'ecorr5',i,j,i+1,j1,eello5(i,jp,i+1,jp1,jj,kk)
9413 cd                write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
9414 cd                write(2,*)'ijkl',i,jp,i+1,jp1
9415                 if (wcorr6.gt.0.0d0 .and. (jp.ne.i+4 .or. jp1.ne.i+3
9416      &               .or. wturn6.eq.0.0d0))then
9417 cd                  write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
9418                   ecorr6=ecorr6+eello6(i,jp,i+1,jp1,jj,kk)
9419                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
9420      1                'ecorr6',i,j,i+1,j1,eello6(i,jp,i+1,jp1,jj,kk)
9421 cd                write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
9422 cd     &            'ecorr6=',ecorr6
9423 cd                write (iout,'(4e15.5)') sred_geom,
9424 cd     &          dabs(eello4(i,jp,i+1,jp1,jj,kk)),
9425 cd     &          dabs(eello5(i,jp,i+1,jp1,jj,kk)),
9426 cd     &          dabs(eello6(i,jp,i+1,jp1,jj,kk))
9427                 else if (wturn6.gt.0.0d0
9428      &            .and. (jp.eq.i+4 .and. jp1.eq.i+3)) then
9429 cd                  write (iout,*) '******eturn6: i,j,i+1,j1',i,jip,i+1,jp1
9430                   eturn6=eturn6+eello_turn6(i,jj,kk)
9431                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
9432      1                 'eturn6',i,j,i+1,j1,eello_turn6(i,jj,kk)
9433 cd                  write (2,*) 'multibody_eello:eturn6',eturn6
9434                 endif
9435               ENDIF
9436 1111          continue
9437             endif
9438           enddo ! kk
9439         enddo ! jj
9440       enddo ! i
9441       do i=1,nres
9442         num_cont_hb(i)=num_cont_hb_old(i)
9443       enddo
9444 c                write (iout,*) "gradcorr5 in eello5"
9445 c                do iii=1,nres
9446 c                  write (iout,'(i5,3f10.5)')
9447 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
9448 c                enddo
9449       return
9450       end
9451 c------------------------------------------------------------------------------
9452       subroutine add_hb_contact_eello(ii,jj,itask)
9453       implicit real*8 (a-h,o-z)
9454       include "DIMENSIONS"
9455       include "COMMON.IOUNITS"
9456       integer max_cont
9457       integer max_dim
9458       parameter (max_cont=maxconts)
9459       parameter (max_dim=70)
9460       include "COMMON.CONTACTS"
9461       include 'COMMON.CONTMAT'
9462       include 'COMMON.CORRMAT'
9463       double precision zapas(max_dim,maxconts,max_fg_procs),
9464      &  zapas_recv(max_dim,maxconts,max_fg_procs)
9465       common /przechowalnia/ zapas
9466       integer i,j,ii,jj,iproc,itask(4),nn
9467 c      write (iout,*) "itask",itask
9468       do i=1,2
9469         iproc=itask(i)
9470         if (iproc.gt.0) then
9471           do j=1,num_cont_hb(ii)
9472             jjc=jcont_hb(j,ii)
9473 c            write (iout,*) "send turns i",ii," j",jj," jjc",jjc
9474             if (jjc.eq.jj) then
9475               ncont_sent(iproc)=ncont_sent(iproc)+1
9476               nn=ncont_sent(iproc)
9477               zapas(1,nn,iproc)=ii
9478               zapas(2,nn,iproc)=jjc
9479               zapas(3,nn,iproc)=d_cont(j,ii)
9480               ind=3
9481               do kk=1,3
9482                 ind=ind+1
9483                 zapas(ind,nn,iproc)=grij_hb_cont(kk,j,ii)
9484               enddo
9485               do kk=1,2
9486                 do ll=1,2
9487                   ind=ind+1
9488                   zapas(ind,nn,iproc)=a_chuj(ll,kk,j,ii)
9489                 enddo
9490               enddo
9491               do jj=1,5
9492                 do kk=1,3
9493                   do ll=1,2
9494                     do mm=1,2
9495                       ind=ind+1
9496                       zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,ii)
9497                     enddo
9498                   enddo
9499                 enddo
9500               enddo
9501               exit
9502             endif
9503           enddo
9504         endif
9505       enddo
9506       return
9507       end
9508 c------------------------------------------------------------------------------
9509       double precision function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
9510       implicit real*8 (a-h,o-z)
9511       include 'DIMENSIONS'
9512       include 'COMMON.IOUNITS'
9513       include 'COMMON.DERIV'
9514       include 'COMMON.INTERACT'
9515       include 'COMMON.CONTACTS'
9516       include 'COMMON.CONTMAT'
9517       include 'COMMON.CORRMAT'
9518       include 'COMMON.SHIELD'
9519       include 'COMMON.CONTROL'
9520       double precision gx(3),gx1(3)
9521       logical lprn
9522       lprn=.false.
9523 C      print *,"wchodze",fac_shield(i),shield_mode
9524       eij=facont_hb(jj,i)
9525       ekl=facont_hb(kk,k)
9526       ees0pij=ees0p(jj,i)
9527       ees0pkl=ees0p(kk,k)
9528       ees0mij=ees0m(jj,i)
9529       ees0mkl=ees0m(kk,k)
9530       ekont=eij*ekl
9531       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
9532 C*
9533 C     & fac_shield(i)**2*fac_shield(j)**2
9534 cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
9535 C Following 4 lines for diagnostics.
9536 cd    ees0pkl=0.0D0
9537 cd    ees0pij=1.0D0
9538 cd    ees0mkl=0.0D0
9539 cd    ees0mij=1.0D0
9540 c      write (iout,'(2(a,2i3,a,f10.5,a,2f10.5),a,f10.5,a,$)')
9541 c     & 'Contacts ',i,j,
9542 c     & ' eij',eij,' eesij',ees0pij,ees0mij,' and ',k,l
9543 c     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' energy=',ekont*ees,
9544 c     & 'gradcorr_long'
9545 C Calculate the multi-body contribution to energy.
9546 C      ecorr=ecorr+ekont*ees
9547 C Calculate multi-body contributions to the gradient.
9548       coeffpees0pij=coeffp*ees0pij
9549       coeffmees0mij=coeffm*ees0mij
9550       coeffpees0pkl=coeffp*ees0pkl
9551       coeffmees0mkl=coeffm*ees0mkl
9552       do ll=1,3
9553 cgrad        ghalfi=ees*ekl*gacont_hbr(ll,jj,i)
9554         gradcorr(ll,i)=gradcorr(ll,i)!+0.5d0*ghalfi
9555      &  -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+
9556      &  coeffmees0mkl*gacontm_hb1(ll,jj,i))
9557         gradcorr(ll,j)=gradcorr(ll,j)!+0.5d0*ghalfi
9558      &  -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+
9559      &  coeffmees0mkl*gacontm_hb2(ll,jj,i))
9560 cgrad        ghalfk=ees*eij*gacont_hbr(ll,kk,k)
9561         gradcorr(ll,k)=gradcorr(ll,k)!+0.5d0*ghalfk
9562      &  -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+
9563      &  coeffmees0mij*gacontm_hb1(ll,kk,k))
9564         gradcorr(ll,l)=gradcorr(ll,l)!+0.5d0*ghalfk
9565      &  -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+
9566      &  coeffmees0mij*gacontm_hb2(ll,kk,k))
9567         gradlongij=ees*ekl*gacont_hbr(ll,jj,i)-
9568      &     ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+
9569      &     coeffmees0mkl*gacontm_hb3(ll,jj,i))
9570         gradcorr_long(ll,j)=gradcorr_long(ll,j)+gradlongij
9571         gradcorr_long(ll,i)=gradcorr_long(ll,i)-gradlongij
9572         gradlongkl=ees*eij*gacont_hbr(ll,kk,k)-
9573      &     ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+
9574      &     coeffmees0mij*gacontm_hb3(ll,kk,k))
9575         gradcorr_long(ll,l)=gradcorr_long(ll,l)+gradlongkl
9576         gradcorr_long(ll,k)=gradcorr_long(ll,k)-gradlongkl
9577 c        write (iout,'(2f10.5,2x,$)') gradlongij,gradlongkl
9578       enddo
9579 c      write (iout,*)
9580 cgrad      do m=i+1,j-1
9581 cgrad        do ll=1,3
9582 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
9583 cgrad     &     ees*ekl*gacont_hbr(ll,jj,i)-
9584 cgrad     &     ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
9585 cgrad     &     coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
9586 cgrad        enddo
9587 cgrad      enddo
9588 cgrad      do m=k+1,l-1
9589 cgrad        do ll=1,3
9590 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
9591 cgrad     &     ees*eij*gacont_hbr(ll,kk,k)-
9592 cgrad     &     ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
9593 cgrad     &     coeffm*ees0mij*gacontm_hb3(ll,kk,k))
9594 cgrad        enddo
9595 cgrad      enddo
9596 c      write (iout,*) "ehbcorr",ekont*ees
9597 C      print *,ekont,ees,i,k
9598       ehbcorr=ekont*ees
9599 C now gradient over shielding
9600 C      return
9601       if (shield_mode.gt.0) then
9602        j=ees0plist(jj,i)
9603        l=ees0plist(kk,k)
9604 C        print *,i,j,fac_shield(i),fac_shield(j),
9605 C     &fac_shield(k),fac_shield(l)
9606         if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
9607      &      (fac_shield(k).gt.0).and.(fac_shield(l).gt.0)) then
9608           do ilist=1,ishield_list(i)
9609            iresshield=shield_list(ilist,i)
9610            do m=1,3
9611            rlocshield=grad_shield_side(m,ilist,i)*ehbcorr/fac_shield(i)
9612 C     &      *2.0
9613            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
9614      &              rlocshield
9615      & +grad_shield_loc(m,ilist,i)*ehbcorr/fac_shield(i)
9616             gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
9617      &+rlocshield
9618            enddo
9619           enddo
9620           do ilist=1,ishield_list(j)
9621            iresshield=shield_list(ilist,j)
9622            do m=1,3
9623            rlocshield=grad_shield_side(m,ilist,j)*ehbcorr/fac_shield(j)
9624 C     &     *2.0
9625            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
9626      &              rlocshield
9627      & +grad_shield_loc(m,ilist,j)*ehbcorr/fac_shield(j)
9628            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
9629      &     +rlocshield
9630            enddo
9631           enddo
9632
9633           do ilist=1,ishield_list(k)
9634            iresshield=shield_list(ilist,k)
9635            do m=1,3
9636            rlocshield=grad_shield_side(m,ilist,k)*ehbcorr/fac_shield(k)
9637 C     &     *2.0
9638            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
9639      &              rlocshield
9640      & +grad_shield_loc(m,ilist,k)*ehbcorr/fac_shield(k)
9641            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
9642      &     +rlocshield
9643            enddo
9644           enddo
9645           do ilist=1,ishield_list(l)
9646            iresshield=shield_list(ilist,l)
9647            do m=1,3
9648            rlocshield=grad_shield_side(m,ilist,l)*ehbcorr/fac_shield(l)
9649 C     &     *2.0
9650            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
9651      &              rlocshield
9652      & +grad_shield_loc(m,ilist,l)*ehbcorr/fac_shield(l)
9653            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
9654      &     +rlocshield
9655            enddo
9656           enddo
9657 C          print *,gshieldx(m,iresshield)
9658           do m=1,3
9659             gshieldc_ec(m,i)=gshieldc_ec(m,i)+
9660      &              grad_shield(m,i)*ehbcorr/fac_shield(i)
9661             gshieldc_ec(m,j)=gshieldc_ec(m,j)+
9662      &              grad_shield(m,j)*ehbcorr/fac_shield(j)
9663             gshieldc_ec(m,i-1)=gshieldc_ec(m,i-1)+
9664      &              grad_shield(m,i)*ehbcorr/fac_shield(i)
9665             gshieldc_ec(m,j-1)=gshieldc_ec(m,j-1)+
9666      &              grad_shield(m,j)*ehbcorr/fac_shield(j)
9667
9668             gshieldc_ec(m,k)=gshieldc_ec(m,k)+
9669      &              grad_shield(m,k)*ehbcorr/fac_shield(k)
9670             gshieldc_ec(m,l)=gshieldc_ec(m,l)+
9671      &              grad_shield(m,l)*ehbcorr/fac_shield(l)
9672             gshieldc_ec(m,k-1)=gshieldc_ec(m,k-1)+
9673      &              grad_shield(m,k)*ehbcorr/fac_shield(k)
9674             gshieldc_ec(m,l-1)=gshieldc_ec(m,l-1)+
9675      &              grad_shield(m,l)*ehbcorr/fac_shield(l)
9676
9677            enddo
9678       endif
9679       endif
9680       return
9681       end
9682 #ifdef MOMENT
9683 C---------------------------------------------------------------------------
9684       subroutine dipole(i,j,jj)
9685       implicit real*8 (a-h,o-z)
9686       include 'DIMENSIONS'
9687       include 'COMMON.IOUNITS'
9688       include 'COMMON.CHAIN'
9689       include 'COMMON.FFIELD'
9690       include 'COMMON.DERIV'
9691       include 'COMMON.INTERACT'
9692       include 'COMMON.CONTACTS'
9693       include 'COMMON.CONTMAT'
9694       include 'COMMON.CORRMAT'
9695       include 'COMMON.TORSION'
9696       include 'COMMON.VAR'
9697       include 'COMMON.GEO'
9698       dimension dipi(2,2),dipj(2,2),dipderi(2),dipderj(2),auxvec(2),
9699      &  auxmat(2,2)
9700       iti1 = itortyp(itype(i+1))
9701       if (j.lt.nres-1) then
9702         itj1 = itype2loc(itype(j+1))
9703       else
9704         itj1=nloctyp
9705       endif
9706       do iii=1,2
9707         dipi(iii,1)=Ub2(iii,i)
9708         dipderi(iii)=Ub2der(iii,i)
9709         dipi(iii,2)=b1(iii,i+1)
9710         dipj(iii,1)=Ub2(iii,j)
9711         dipderj(iii)=Ub2der(iii,j)
9712         dipj(iii,2)=b1(iii,j+1)
9713       enddo
9714       kkk=0
9715       do iii=1,2
9716         call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
9717         do jjj=1,2
9718           kkk=kkk+1
9719           dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
9720         enddo
9721       enddo
9722       do kkk=1,5
9723         do lll=1,3
9724           mmm=0
9725           do iii=1,2
9726             call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),
9727      &        auxvec(1))
9728             do jjj=1,2
9729               mmm=mmm+1
9730               dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
9731             enddo
9732           enddo
9733         enddo
9734       enddo
9735       call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
9736       call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
9737       do iii=1,2
9738         dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
9739       enddo
9740       call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
9741       do iii=1,2
9742         dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
9743       enddo
9744       return
9745       end
9746 #endif
9747 C---------------------------------------------------------------------------
9748       subroutine calc_eello(i,j,k,l,jj,kk)
9749 C
9750 C This subroutine computes matrices and vectors needed to calculate
9751 C the fourth-, fifth-, and sixth-order local-electrostatic terms.
9752 C
9753       implicit real*8 (a-h,o-z)
9754       include 'DIMENSIONS'
9755       include 'COMMON.IOUNITS'
9756       include 'COMMON.CHAIN'
9757       include 'COMMON.DERIV'
9758       include 'COMMON.INTERACT'
9759       include 'COMMON.CONTACTS'
9760       include 'COMMON.CONTMAT'
9761       include 'COMMON.CORRMAT'
9762       include 'COMMON.TORSION'
9763       include 'COMMON.VAR'
9764       include 'COMMON.GEO'
9765       include 'COMMON.FFIELD'
9766       double precision aa1(2,2),aa2(2,2),aa1t(2,2),aa2t(2,2),
9767      &  aa1tder(2,2,3,5),aa2tder(2,2,3,5),auxmat(2,2)
9768       logical lprn
9769       common /kutas/ lprn
9770 cd      write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
9771 cd     & ' jj=',jj,' kk=',kk
9772 cd      if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
9773 cd      write (iout,*) "a_chujij",((a_chuj(iii,jjj,jj,i),iii=1,2),jjj=1,2)
9774 cd      write (iout,*) "a_chujkl",((a_chuj(iii,jjj,kk,k),iii=1,2),jjj=1,2)
9775       do iii=1,2
9776         do jjj=1,2
9777           aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
9778           aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
9779         enddo
9780       enddo
9781       call transpose2(aa1(1,1),aa1t(1,1))
9782       call transpose2(aa2(1,1),aa2t(1,1))
9783       do kkk=1,5
9784         do lll=1,3
9785           call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),
9786      &      aa1tder(1,1,lll,kkk))
9787           call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),
9788      &      aa2tder(1,1,lll,kkk))
9789         enddo
9790       enddo
9791       if (l.eq.j+1) then
9792 C parallel orientation of the two CA-CA-CA frames.
9793         if (i.gt.1) then
9794           iti=itype2loc(itype(i))
9795         else
9796           iti=nloctyp
9797         endif
9798         itk1=itype2loc(itype(k+1))
9799         itj=itype2loc(itype(j))
9800         if (l.lt.nres-1) then
9801           itl1=itype2loc(itype(l+1))
9802         else
9803           itl1=nloctyp
9804         endif
9805 C A1 kernel(j+1) A2T
9806 cd        do iii=1,2
9807 cd          write (iout,'(3f10.5,5x,3f10.5)')
9808 cd     &     (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
9809 cd        enddo
9810         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9811      &   aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),
9812      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
9813 C Following matrices are needed only for 6-th order cumulants
9814         IF (wcorr6.gt.0.0d0) THEN
9815         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9816      &   aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),
9817      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
9818         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9819      &   aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),
9820      &   Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
9821      &   ADtEAderx(1,1,1,1,1,1))
9822         lprn=.false.
9823         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9824      &   aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),
9825      &   DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
9826      &   ADtEA1derx(1,1,1,1,1,1))
9827         ENDIF
9828 C End 6-th order cumulants
9829 cd        lprn=.false.
9830 cd        if (lprn) then
9831 cd        write (2,*) 'In calc_eello6'
9832 cd        do iii=1,2
9833 cd          write (2,*) 'iii=',iii
9834 cd          do kkk=1,5
9835 cd            write (2,*) 'kkk=',kkk
9836 cd            do jjj=1,2
9837 cd              write (2,'(3(2f10.5),5x)')
9838 cd     &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
9839 cd            enddo
9840 cd          enddo
9841 cd        enddo
9842 cd        endif
9843         call transpose2(EUgder(1,1,k),auxmat(1,1))
9844         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
9845         call transpose2(EUg(1,1,k),auxmat(1,1))
9846         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
9847         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
9848 C AL 4/16/16: Derivatives of the quantitied related to matrices C, D, and E
9849 c    in theta; to be sriten later.
9850 c#ifdef NEWCORR
9851 c        call transpose2(gtEE(1,1,k),auxmat(1,1))
9852 c        call matmat2(auxmat(1,1),AEA(1,1,1),EAEAdert(1,1,1,1))
9853 c        call transpose2(EUg(1,1,k),auxmat(1,1))
9854 c        call matmat2(auxmat(1,1),AEAdert(1,1,1),EAEAdert(1,1,2,1))
9855 c#endif
9856         do iii=1,2
9857           do kkk=1,5
9858             do lll=1,3
9859               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
9860      &          EAEAderx(1,1,lll,kkk,iii,1))
9861             enddo
9862           enddo
9863         enddo
9864 C A1T kernel(i+1) A2
9865         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
9866      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),
9867      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
9868 C Following matrices are needed only for 6-th order cumulants
9869         IF (wcorr6.gt.0.0d0) THEN
9870         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
9871      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),
9872      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
9873         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
9874      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),
9875      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
9876      &   ADtEAderx(1,1,1,1,1,2))
9877         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
9878      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),
9879      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
9880      &   ADtEA1derx(1,1,1,1,1,2))
9881         ENDIF
9882 C End 6-th order cumulants
9883         call transpose2(EUgder(1,1,l),auxmat(1,1))
9884         call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
9885         call transpose2(EUg(1,1,l),auxmat(1,1))
9886         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
9887         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
9888         do iii=1,2
9889           do kkk=1,5
9890             do lll=1,3
9891               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
9892      &          EAEAderx(1,1,lll,kkk,iii,2))
9893             enddo
9894           enddo
9895         enddo
9896 C AEAb1 and AEAb2
9897 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
9898 C They are needed only when the fifth- or the sixth-order cumulants are
9899 C indluded.
9900         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
9901         call transpose2(AEA(1,1,1),auxmat(1,1))
9902         call matvec2(auxmat(1,1),b1(1,i),AEAb1(1,1,1))
9903         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
9904         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
9905         call transpose2(AEAderg(1,1,1),auxmat(1,1))
9906         call matvec2(auxmat(1,1),b1(1,i),AEAb1derg(1,1,1))
9907         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
9908         call matvec2(AEA(1,1,1),b1(1,k+1),AEAb1(1,2,1))
9909         call matvec2(AEAderg(1,1,1),b1(1,k+1),AEAb1derg(1,2,1))
9910         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
9911         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
9912         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
9913         call transpose2(AEA(1,1,2),auxmat(1,1))
9914         call matvec2(auxmat(1,1),b1(1,j),AEAb1(1,1,2))
9915         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
9916         call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
9917         call transpose2(AEAderg(1,1,2),auxmat(1,1))
9918         call matvec2(auxmat(1,1),b1(1,j),AEAb1derg(1,1,2))
9919         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
9920         call matvec2(AEA(1,1,2),b1(1,l+1),AEAb1(1,2,2))
9921         call matvec2(AEAderg(1,1,2),b1(1,l+1),AEAb1derg(1,2,2))
9922         call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
9923         call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
9924         call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
9925 C Calculate the Cartesian derivatives of the vectors.
9926         do iii=1,2
9927           do kkk=1,5
9928             do lll=1,3
9929               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
9930               call matvec2(auxmat(1,1),b1(1,i),
9931      &          AEAb1derx(1,lll,kkk,iii,1,1))
9932               call matvec2(auxmat(1,1),Ub2(1,i),
9933      &          AEAb2derx(1,lll,kkk,iii,1,1))
9934               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
9935      &          AEAb1derx(1,lll,kkk,iii,2,1))
9936               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
9937      &          AEAb2derx(1,lll,kkk,iii,2,1))
9938               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
9939               call matvec2(auxmat(1,1),b1(1,j),
9940      &          AEAb1derx(1,lll,kkk,iii,1,2))
9941               call matvec2(auxmat(1,1),Ub2(1,j),
9942      &          AEAb2derx(1,lll,kkk,iii,1,2))
9943               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,l+1),
9944      &          AEAb1derx(1,lll,kkk,iii,2,2))
9945               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),
9946      &          AEAb2derx(1,lll,kkk,iii,2,2))
9947             enddo
9948           enddo
9949         enddo
9950         ENDIF
9951 C End vectors
9952       else
9953 C Antiparallel orientation of the two CA-CA-CA frames.
9954         if (i.gt.1) then
9955           iti=itype2loc(itype(i))
9956         else
9957           iti=nloctyp
9958         endif
9959         itk1=itype2loc(itype(k+1))
9960         itl=itype2loc(itype(l))
9961         itj=itype2loc(itype(j))
9962         if (j.lt.nres-1) then
9963           itj1=itype2loc(itype(j+1))
9964         else
9965           itj1=nloctyp
9966         endif
9967 C A2 kernel(j-1)T A1T
9968         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9969      &   aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),
9970      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
9971 C Following matrices are needed only for 6-th order cumulants
9972         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
9973      &     j.eq.i+4 .and. l.eq.i+3)) THEN
9974         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9975      &   aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),
9976      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
9977         call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9978      &   aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),
9979      &   Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
9980      &   ADtEAderx(1,1,1,1,1,1))
9981         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9982      &   aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),
9983      &   DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
9984      &   ADtEA1derx(1,1,1,1,1,1))
9985         ENDIF
9986 C End 6-th order cumulants
9987         call transpose2(EUgder(1,1,k),auxmat(1,1))
9988         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
9989         call transpose2(EUg(1,1,k),auxmat(1,1))
9990         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
9991         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
9992         do iii=1,2
9993           do kkk=1,5
9994             do lll=1,3
9995               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
9996      &          EAEAderx(1,1,lll,kkk,iii,1))
9997             enddo
9998           enddo
9999         enddo
10000 C A2T kernel(i+1)T A1
10001         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
10002      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),
10003      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
10004 C Following matrices are needed only for 6-th order cumulants
10005         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
10006      &     j.eq.i+4 .and. l.eq.i+3)) THEN
10007         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
10008      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),
10009      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
10010         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
10011      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),
10012      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
10013      &   ADtEAderx(1,1,1,1,1,2))
10014         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
10015      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),
10016      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
10017      &   ADtEA1derx(1,1,1,1,1,2))
10018         ENDIF
10019 C End 6-th order cumulants
10020         call transpose2(EUgder(1,1,j),auxmat(1,1))
10021         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
10022         call transpose2(EUg(1,1,j),auxmat(1,1))
10023         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
10024         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
10025         do iii=1,2
10026           do kkk=1,5
10027             do lll=1,3
10028               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
10029      &          EAEAderx(1,1,lll,kkk,iii,2))
10030             enddo
10031           enddo
10032         enddo
10033 C AEAb1 and AEAb2
10034 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
10035 C They are needed only when the fifth- or the sixth-order cumulants are
10036 C indluded.
10037         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or.
10038      &    (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
10039         call transpose2(AEA(1,1,1),auxmat(1,1))
10040         call matvec2(auxmat(1,1),b1(1,i),AEAb1(1,1,1))
10041         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
10042         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
10043         call transpose2(AEAderg(1,1,1),auxmat(1,1))
10044         call matvec2(auxmat(1,1),b1(1,i),AEAb1derg(1,1,1))
10045         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
10046         call matvec2(AEA(1,1,1),b1(1,k+1),AEAb1(1,2,1))
10047         call matvec2(AEAderg(1,1,1),b1(1,k+1),AEAb1derg(1,2,1))
10048         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
10049         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
10050         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
10051         call transpose2(AEA(1,1,2),auxmat(1,1))
10052         call matvec2(auxmat(1,1),b1(1,j+1),AEAb1(1,1,2))
10053         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
10054         call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
10055         call transpose2(AEAderg(1,1,2),auxmat(1,1))
10056         call matvec2(auxmat(1,1),b1(1,l),AEAb1(1,1,2))
10057         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
10058         call matvec2(AEA(1,1,2),b1(1,j+1),AEAb1(1,2,2))
10059         call matvec2(AEAderg(1,1,2),b1(1,j+1),AEAb1derg(1,2,2))
10060         call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
10061         call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
10062         call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
10063 C Calculate the Cartesian derivatives of the vectors.
10064         do iii=1,2
10065           do kkk=1,5
10066             do lll=1,3
10067               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
10068               call matvec2(auxmat(1,1),b1(1,i),
10069      &          AEAb1derx(1,lll,kkk,iii,1,1))
10070               call matvec2(auxmat(1,1),Ub2(1,i),
10071      &          AEAb2derx(1,lll,kkk,iii,1,1))
10072               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
10073      &          AEAb1derx(1,lll,kkk,iii,2,1))
10074               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
10075      &          AEAb2derx(1,lll,kkk,iii,2,1))
10076               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
10077               call matvec2(auxmat(1,1),b1(1,l),
10078      &          AEAb1derx(1,lll,kkk,iii,1,2))
10079               call matvec2(auxmat(1,1),Ub2(1,l),
10080      &          AEAb2derx(1,lll,kkk,iii,1,2))
10081               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,j+1),
10082      &          AEAb1derx(1,lll,kkk,iii,2,2))
10083               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),
10084      &          AEAb2derx(1,lll,kkk,iii,2,2))
10085             enddo
10086           enddo
10087         enddo
10088         ENDIF
10089 C End vectors
10090       endif
10091       return
10092       end
10093 C---------------------------------------------------------------------------
10094       subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,
10095      &  KK,KKderg,AKA,AKAderg,AKAderx)
10096       implicit none
10097       integer nderg
10098       logical transp
10099       double precision aa1(2,2),aa2t(2,2),aa1derx(2,2,3,5),
10100      &  aa2tderx(2,2,3,5),KK(2,2),KKderg(2,2,nderg),AKA(2,2),
10101      &  AKAderg(2,2,nderg),AKAderx(2,2,3,5,2)
10102       integer iii,kkk,lll
10103       integer jjj,mmm
10104       logical lprn
10105       common /kutas/ lprn
10106       call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
10107       do iii=1,nderg
10108         call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,
10109      &    AKAderg(1,1,iii))
10110       enddo
10111 cd      if (lprn) write (2,*) 'In kernel'
10112       do kkk=1,5
10113 cd        if (lprn) write (2,*) 'kkk=',kkk
10114         do lll=1,3
10115           call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),
10116      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
10117 cd          if (lprn) then
10118 cd            write (2,*) 'lll=',lll
10119 cd            write (2,*) 'iii=1'
10120 cd            do jjj=1,2
10121 cd              write (2,'(3(2f10.5),5x)')
10122 cd     &        (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
10123 cd            enddo
10124 cd          endif
10125           call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),
10126      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
10127 cd          if (lprn) then
10128 cd            write (2,*) 'lll=',lll
10129 cd            write (2,*) 'iii=2'
10130 cd            do jjj=1,2
10131 cd              write (2,'(3(2f10.5),5x)')
10132 cd     &        (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
10133 cd            enddo
10134 cd          endif
10135         enddo
10136       enddo
10137       return
10138       end
10139 C---------------------------------------------------------------------------
10140       double precision function eello4(i,j,k,l,jj,kk)
10141       implicit real*8 (a-h,o-z)
10142       include 'DIMENSIONS'
10143       include 'COMMON.IOUNITS'
10144       include 'COMMON.CHAIN'
10145       include 'COMMON.DERIV'
10146       include 'COMMON.INTERACT'
10147       include 'COMMON.CONTACTS'
10148       include 'COMMON.CONTMAT'
10149       include 'COMMON.CORRMAT'
10150       include 'COMMON.TORSION'
10151       include 'COMMON.VAR'
10152       include 'COMMON.GEO'
10153       double precision pizda(2,2),ggg1(3),ggg2(3)
10154 cd      if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
10155 cd        eello4=0.0d0
10156 cd        return
10157 cd      endif
10158 cd      print *,'eello4:',i,j,k,l,jj,kk
10159 cd      write (2,*) 'i',i,' j',j,' k',k,' l',l
10160 cd      call checkint4(i,j,k,l,jj,kk,eel4_num)
10161 cold      eij=facont_hb(jj,i)
10162 cold      ekl=facont_hb(kk,k)
10163 cold      ekont=eij*ekl
10164       eel4=-EAEA(1,1,1)-EAEA(2,2,1)
10165 cd      eel41=-EAEA(1,1,2)-EAEA(2,2,2)
10166       gcorr_loc(k-1)=gcorr_loc(k-1)
10167      &   -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
10168       if (l.eq.j+1) then
10169         gcorr_loc(l-1)=gcorr_loc(l-1)
10170      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
10171 C Al 4/16/16: Derivatives in theta, to be added later.
10172 c#ifdef NEWCORR
10173 c        gcorr_loc(nphi+l-1)=gcorr_loc(nphi+l-1)
10174 c     &     -ekont*(EAEAdert(1,1,2,1)+EAEAdert(2,2,2,1))
10175 c#endif
10176       else
10177         gcorr_loc(j-1)=gcorr_loc(j-1)
10178      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
10179 c#ifdef NEWCORR
10180 c        gcorr_loc(nphi+j-1)=gcorr_loc(nphi+j-1)
10181 c     &     -ekont*(EAEAdert(1,1,2,1)+EAEAdert(2,2,2,1))
10182 c#endif
10183       endif
10184       do iii=1,2
10185         do kkk=1,5
10186           do lll=1,3
10187             derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1)
10188      &                        -EAEAderx(2,2,lll,kkk,iii,1)
10189 cd            derx(lll,kkk,iii)=0.0d0
10190           enddo
10191         enddo
10192       enddo
10193 cd      gcorr_loc(l-1)=0.0d0
10194 cd      gcorr_loc(j-1)=0.0d0
10195 cd      gcorr_loc(k-1)=0.0d0
10196 cd      eel4=1.0d0
10197 cd      write (iout,*)'Contacts have occurred for peptide groups',
10198 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l,
10199 cd     &  ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
10200       if (j.lt.nres-1) then
10201         j1=j+1
10202         j2=j-1
10203       else
10204         j1=j-1
10205         j2=j-2
10206       endif
10207       if (l.lt.nres-1) then
10208         l1=l+1
10209         l2=l-1
10210       else
10211         l1=l-1
10212         l2=l-2
10213       endif
10214       do ll=1,3
10215 cgrad        ggg1(ll)=eel4*g_contij(ll,1)
10216 cgrad        ggg2(ll)=eel4*g_contij(ll,2)
10217         glongij=eel4*g_contij(ll,1)+ekont*derx(ll,1,1)
10218         glongkl=eel4*g_contij(ll,2)+ekont*derx(ll,1,2)
10219 cgrad        ghalf=0.5d0*ggg1(ll)
10220         gradcorr(ll,i)=gradcorr(ll,i)+ekont*derx(ll,2,1)
10221         gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
10222         gradcorr(ll,j)=gradcorr(ll,j)+ekont*derx(ll,4,1)
10223         gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
10224         gradcorr_long(ll,j)=gradcorr_long(ll,j)+glongij
10225         gradcorr_long(ll,i)=gradcorr_long(ll,i)-glongij
10226 cgrad        ghalf=0.5d0*ggg2(ll)
10227         gradcorr(ll,k)=gradcorr(ll,k)+ekont*derx(ll,2,2)
10228         gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
10229         gradcorr(ll,l)=gradcorr(ll,l)+ekont*derx(ll,4,2)
10230         gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
10231         gradcorr_long(ll,l)=gradcorr_long(ll,l)+glongkl
10232         gradcorr_long(ll,k)=gradcorr_long(ll,k)-glongkl
10233       enddo
10234 cgrad      do m=i+1,j-1
10235 cgrad        do ll=1,3
10236 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
10237 cgrad        enddo
10238 cgrad      enddo
10239 cgrad      do m=k+1,l-1
10240 cgrad        do ll=1,3
10241 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
10242 cgrad        enddo
10243 cgrad      enddo
10244 cgrad      do m=i+2,j2
10245 cgrad        do ll=1,3
10246 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
10247 cgrad        enddo
10248 cgrad      enddo
10249 cgrad      do m=k+2,l2
10250 cgrad        do ll=1,3
10251 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
10252 cgrad        enddo
10253 cgrad      enddo
10254 cd      do iii=1,nres-3
10255 cd        write (2,*) iii,gcorr_loc(iii)
10256 cd      enddo
10257       eello4=ekont*eel4
10258 cd      write (2,*) 'ekont',ekont
10259 cd      write (iout,*) 'eello4',ekont*eel4
10260       return
10261       end
10262 C---------------------------------------------------------------------------
10263       double precision function eello5(i,j,k,l,jj,kk)
10264       implicit real*8 (a-h,o-z)
10265       include 'DIMENSIONS'
10266       include 'COMMON.IOUNITS'
10267       include 'COMMON.CHAIN'
10268       include 'COMMON.DERIV'
10269       include 'COMMON.INTERACT'
10270       include 'COMMON.CONTACTS'
10271       include 'COMMON.CONTMAT'
10272       include 'COMMON.CORRMAT'
10273       include 'COMMON.TORSION'
10274       include 'COMMON.VAR'
10275       include 'COMMON.GEO'
10276       double precision pizda(2,2),auxmat(2,2),auxmat1(2,2),vv(2)
10277       double precision ggg1(3),ggg2(3)
10278 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10279 C                                                                              C
10280 C                            Parallel chains                                   C
10281 C                                                                              C
10282 C          o             o                   o             o                   C
10283 C         /l\           / \             \   / \           / \   /              C
10284 C        /   \         /   \             \ /   \         /   \ /               C
10285 C       j| o |l1       | o |              o| o |         | o |o                C
10286 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
10287 C      \i/   \         /   \ /             /   \         /   \                 C
10288 C       o    k1             o                                                  C
10289 C         (I)          (II)                (III)          (IV)                 C
10290 C                                                                              C
10291 C      eello5_1        eello5_2            eello5_3       eello5_4             C
10292 C                                                                              C
10293 C                            Antiparallel chains                               C
10294 C                                                                              C
10295 C          o             o                   o             o                   C
10296 C         /j\           / \             \   / \           / \   /              C
10297 C        /   \         /   \             \ /   \         /   \ /               C
10298 C      j1| o |l        | o |              o| o |         | o |o                C
10299 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
10300 C      \i/   \         /   \ /             /   \         /   \                 C
10301 C       o     k1            o                                                  C
10302 C         (I)          (II)                (III)          (IV)                 C
10303 C                                                                              C
10304 C      eello5_1        eello5_2            eello5_3       eello5_4             C
10305 C                                                                              C
10306 C o denotes a local interaction, vertical lines an electrostatic interaction.  C
10307 C                                                                              C
10308 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10309 cd      if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
10310 cd        eello5=0.0d0
10311 cd        return
10312 cd      endif
10313 cd      write (iout,*)
10314 cd     &   'EELLO5: Contacts have occurred for peptide groups',i,j,
10315 cd     &   ' and',k,l
10316       itk=itype2loc(itype(k))
10317       itl=itype2loc(itype(l))
10318       itj=itype2loc(itype(j))
10319       eello5_1=0.0d0
10320       eello5_2=0.0d0
10321       eello5_3=0.0d0
10322       eello5_4=0.0d0
10323 cd      call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
10324 cd     &   eel5_3_num,eel5_4_num)
10325       do iii=1,2
10326         do kkk=1,5
10327           do lll=1,3
10328             derx(lll,kkk,iii)=0.0d0
10329           enddo
10330         enddo
10331       enddo
10332 cd      eij=facont_hb(jj,i)
10333 cd      ekl=facont_hb(kk,k)
10334 cd      ekont=eij*ekl
10335 cd      write (iout,*)'Contacts have occurred for peptide groups',
10336 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l
10337 cd      goto 1111
10338 C Contribution from the graph I.
10339 cd      write (2,*) 'AEA  ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
10340 cd      write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
10341       call transpose2(EUg(1,1,k),auxmat(1,1))
10342       call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
10343       vv(1)=pizda(1,1)-pizda(2,2)
10344       vv(2)=pizda(1,2)+pizda(2,1)
10345       eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k))
10346      & +0.5d0*scalar2(vv(1),Dtobr2(1,i))
10347 C Explicit gradient in virtual-dihedral angles.
10348       if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1)
10349      & +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k))
10350      & +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
10351       call transpose2(EUgder(1,1,k),auxmat1(1,1))
10352       call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
10353       vv(1)=pizda(1,1)-pizda(2,2)
10354       vv(2)=pizda(1,2)+pizda(2,1)
10355       g_corr5_loc(k-1)=g_corr5_loc(k-1)
10356      & +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k))
10357      & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
10358       call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
10359       vv(1)=pizda(1,1)-pizda(2,2)
10360       vv(2)=pizda(1,2)+pizda(2,1)
10361       if (l.eq.j+1) then
10362         if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1)
10363      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
10364      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
10365       else
10366         if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1)
10367      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
10368      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
10369       endif
10370 C Cartesian gradient
10371       do iii=1,2
10372         do kkk=1,5
10373           do lll=1,3
10374             call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),
10375      &        pizda(1,1))
10376             vv(1)=pizda(1,1)-pizda(2,2)
10377             vv(2)=pizda(1,2)+pizda(2,1)
10378             derx(lll,kkk,iii)=derx(lll,kkk,iii)
10379      &       +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k))
10380      &       +0.5d0*scalar2(vv(1),Dtobr2(1,i))
10381           enddo
10382         enddo
10383       enddo
10384 c      goto 1112
10385 c1111  continue
10386 C Contribution from graph II
10387       call transpose2(EE(1,1,k),auxmat(1,1))
10388       call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
10389       vv(1)=pizda(1,1)+pizda(2,2)
10390       vv(2)=pizda(2,1)-pizda(1,2)
10391       eello5_2=scalar2(AEAb1(1,2,1),b1(1,k))
10392      & -0.5d0*scalar2(vv(1),Ctobr(1,k))
10393 C Explicit gradient in virtual-dihedral angles.
10394       g_corr5_loc(k-1)=g_corr5_loc(k-1)
10395      & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
10396       call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
10397       vv(1)=pizda(1,1)+pizda(2,2)
10398       vv(2)=pizda(2,1)-pizda(1,2)
10399       if (l.eq.j+1) then
10400         g_corr5_loc(l-1)=g_corr5_loc(l-1)
10401      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,k))
10402      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
10403       else
10404         g_corr5_loc(j-1)=g_corr5_loc(j-1)
10405      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,k))
10406      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
10407       endif
10408 C Cartesian gradient
10409       do iii=1,2
10410         do kkk=1,5
10411           do lll=1,3
10412             call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
10413      &        pizda(1,1))
10414             vv(1)=pizda(1,1)+pizda(2,2)
10415             vv(2)=pizda(2,1)-pizda(1,2)
10416             derx(lll,kkk,iii)=derx(lll,kkk,iii)
10417      &       +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,k))
10418      &       -0.5d0*scalar2(vv(1),Ctobr(1,k))
10419           enddo
10420         enddo
10421       enddo
10422 cd      goto 1112
10423 cd1111  continue
10424       if (l.eq.j+1) then
10425 cd        goto 1110
10426 C Parallel orientation
10427 C Contribution from graph III
10428         call transpose2(EUg(1,1,l),auxmat(1,1))
10429         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
10430         vv(1)=pizda(1,1)-pizda(2,2)
10431         vv(2)=pizda(1,2)+pizda(2,1)
10432         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l))
10433      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j))
10434 C Explicit gradient in virtual-dihedral angles.
10435         g_corr5_loc(j-1)=g_corr5_loc(j-1)
10436      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l))
10437      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
10438         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
10439         vv(1)=pizda(1,1)-pizda(2,2)
10440         vv(2)=pizda(1,2)+pizda(2,1)
10441         g_corr5_loc(k-1)=g_corr5_loc(k-1)
10442      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l))
10443      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
10444         call transpose2(EUgder(1,1,l),auxmat1(1,1))
10445         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
10446         vv(1)=pizda(1,1)-pizda(2,2)
10447         vv(2)=pizda(1,2)+pizda(2,1)
10448         g_corr5_loc(l-1)=g_corr5_loc(l-1)
10449      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l))
10450      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
10451 C Cartesian gradient
10452         do iii=1,2
10453           do kkk=1,5
10454             do lll=1,3
10455               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
10456      &          pizda(1,1))
10457               vv(1)=pizda(1,1)-pizda(2,2)
10458               vv(2)=pizda(1,2)+pizda(2,1)
10459               derx(lll,kkk,iii)=derx(lll,kkk,iii)
10460      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l))
10461      &         +0.5d0*scalar2(vv(1),Dtobr2(1,j))
10462             enddo
10463           enddo
10464         enddo
10465 cd        goto 1112
10466 C Contribution from graph IV
10467 cd1110    continue
10468         call transpose2(EE(1,1,l),auxmat(1,1))
10469         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
10470         vv(1)=pizda(1,1)+pizda(2,2)
10471         vv(2)=pizda(2,1)-pizda(1,2)
10472         eello5_4=scalar2(AEAb1(1,2,2),b1(1,l))
10473      &   -0.5d0*scalar2(vv(1),Ctobr(1,l))
10474 C Explicit gradient in virtual-dihedral angles.
10475         g_corr5_loc(l-1)=g_corr5_loc(l-1)
10476      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
10477         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
10478         vv(1)=pizda(1,1)+pizda(2,2)
10479         vv(2)=pizda(2,1)-pizda(1,2)
10480         g_corr5_loc(k-1)=g_corr5_loc(k-1)
10481      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,l))
10482      &   -0.5d0*scalar2(vv(1),Ctobr(1,l)))
10483 C Cartesian gradient
10484         do iii=1,2
10485           do kkk=1,5
10486             do lll=1,3
10487               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
10488      &          pizda(1,1))
10489               vv(1)=pizda(1,1)+pizda(2,2)
10490               vv(2)=pizda(2,1)-pizda(1,2)
10491               derx(lll,kkk,iii)=derx(lll,kkk,iii)
10492      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,l))
10493      &         -0.5d0*scalar2(vv(1),Ctobr(1,l))
10494             enddo
10495           enddo
10496         enddo
10497       else
10498 C Antiparallel orientation
10499 C Contribution from graph III
10500 c        goto 1110
10501         call transpose2(EUg(1,1,j),auxmat(1,1))
10502         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
10503         vv(1)=pizda(1,1)-pizda(2,2)
10504         vv(2)=pizda(1,2)+pizda(2,1)
10505         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j))
10506      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l))
10507 C Explicit gradient in virtual-dihedral angles.
10508         g_corr5_loc(l-1)=g_corr5_loc(l-1)
10509      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j))
10510      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
10511         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
10512         vv(1)=pizda(1,1)-pizda(2,2)
10513         vv(2)=pizda(1,2)+pizda(2,1)
10514         g_corr5_loc(k-1)=g_corr5_loc(k-1)
10515      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j))
10516      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
10517         call transpose2(EUgder(1,1,j),auxmat1(1,1))
10518         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
10519         vv(1)=pizda(1,1)-pizda(2,2)
10520         vv(2)=pizda(1,2)+pizda(2,1)
10521         g_corr5_loc(j-1)=g_corr5_loc(j-1)
10522      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j))
10523      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
10524 C Cartesian gradient
10525         do iii=1,2
10526           do kkk=1,5
10527             do lll=1,3
10528               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
10529      &          pizda(1,1))
10530               vv(1)=pizda(1,1)-pizda(2,2)
10531               vv(2)=pizda(1,2)+pizda(2,1)
10532               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
10533      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j))
10534      &         +0.5d0*scalar2(vv(1),Dtobr2(1,l))
10535             enddo
10536           enddo
10537         enddo
10538 cd        goto 1112
10539 C Contribution from graph IV
10540 1110    continue
10541         call transpose2(EE(1,1,j),auxmat(1,1))
10542         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
10543         vv(1)=pizda(1,1)+pizda(2,2)
10544         vv(2)=pizda(2,1)-pizda(1,2)
10545         eello5_4=scalar2(AEAb1(1,2,2),b1(1,j))
10546      &   -0.5d0*scalar2(vv(1),Ctobr(1,j))
10547 C Explicit gradient in virtual-dihedral angles.
10548         g_corr5_loc(j-1)=g_corr5_loc(j-1)
10549      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
10550         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
10551         vv(1)=pizda(1,1)+pizda(2,2)
10552         vv(2)=pizda(2,1)-pizda(1,2)
10553         g_corr5_loc(k-1)=g_corr5_loc(k-1)
10554      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,j))
10555      &   -0.5d0*scalar2(vv(1),Ctobr(1,j)))
10556 C Cartesian gradient
10557         do iii=1,2
10558           do kkk=1,5
10559             do lll=1,3
10560               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
10561      &          pizda(1,1))
10562               vv(1)=pizda(1,1)+pizda(2,2)
10563               vv(2)=pizda(2,1)-pizda(1,2)
10564               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
10565      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,j))
10566      &         -0.5d0*scalar2(vv(1),Ctobr(1,j))
10567             enddo
10568           enddo
10569         enddo
10570       endif
10571 1112  continue
10572       eel5=eello5_1+eello5_2+eello5_3+eello5_4
10573 cd      if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
10574 cd        write (2,*) 'ijkl',i,j,k,l
10575 cd        write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
10576 cd     &     ' eello5_3',eello5_3,' eello5_4',eello5_4
10577 cd      endif
10578 cd      write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
10579 cd      write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
10580 cd      write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
10581 cd      write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
10582       if (j.lt.nres-1) then
10583         j1=j+1
10584         j2=j-1
10585       else
10586         j1=j-1
10587         j2=j-2
10588       endif
10589       if (l.lt.nres-1) then
10590         l1=l+1
10591         l2=l-1
10592       else
10593         l1=l-1
10594         l2=l-2
10595       endif
10596 cd      eij=1.0d0
10597 cd      ekl=1.0d0
10598 cd      ekont=1.0d0
10599 cd      write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
10600 C 2/11/08 AL Gradients over DC's connecting interacting sites will be
10601 C        summed up outside the subrouine as for the other subroutines
10602 C        handling long-range interactions. The old code is commented out
10603 C        with "cgrad" to keep track of changes.
10604       do ll=1,3
10605 cgrad        ggg1(ll)=eel5*g_contij(ll,1)
10606 cgrad        ggg2(ll)=eel5*g_contij(ll,2)
10607         gradcorr5ij=eel5*g_contij(ll,1)+ekont*derx(ll,1,1)
10608         gradcorr5kl=eel5*g_contij(ll,2)+ekont*derx(ll,1,2)
10609 c        write (iout,'(a,3i3,a,5f8.3,2i3,a,5f8.3,a,f8.3)')
10610 c     &   "ecorr5",ll,i,j," derx",derx(ll,2,1),derx(ll,3,1),derx(ll,4,1),
10611 c     &   derx(ll,5,1),k,l," derx",derx(ll,2,2),derx(ll,3,2),
10612 c     &   derx(ll,4,2),derx(ll,5,2)," ekont",ekont
10613 c        write (iout,'(a,3i3,a,3f8.3,2i3,a,3f8.3)')
10614 c     &   "ecorr5",ll,i,j," gradcorr5",g_contij(ll,1),derx(ll,1,1),
10615 c     &   gradcorr5ij,
10616 c     &   k,l," gradcorr5",g_contij(ll,2),derx(ll,1,2),gradcorr5kl
10617 cold        ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
10618 cgrad        ghalf=0.5d0*ggg1(ll)
10619 cd        ghalf=0.0d0
10620         gradcorr5(ll,i)=gradcorr5(ll,i)+ekont*derx(ll,2,1)
10621         gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
10622         gradcorr5(ll,j)=gradcorr5(ll,j)+ekont*derx(ll,4,1)
10623         gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
10624         gradcorr5_long(ll,j)=gradcorr5_long(ll,j)+gradcorr5ij
10625         gradcorr5_long(ll,i)=gradcorr5_long(ll,i)-gradcorr5ij
10626 cold        ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
10627 cgrad        ghalf=0.5d0*ggg2(ll)
10628 cd        ghalf=0.0d0
10629         gradcorr5(ll,k)=gradcorr5(ll,k)+ekont*derx(ll,2,2)
10630         gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
10631         gradcorr5(ll,l)=gradcorr5(ll,l)+ekont*derx(ll,4,2)
10632         gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
10633         gradcorr5_long(ll,l)=gradcorr5_long(ll,l)+gradcorr5kl
10634         gradcorr5_long(ll,k)=gradcorr5_long(ll,k)-gradcorr5kl
10635       enddo
10636 cd      goto 1112
10637 cgrad      do m=i+1,j-1
10638 cgrad        do ll=1,3
10639 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
10640 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
10641 cgrad        enddo
10642 cgrad      enddo
10643 cgrad      do m=k+1,l-1
10644 cgrad        do ll=1,3
10645 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
10646 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
10647 cgrad        enddo
10648 cgrad      enddo
10649 c1112  continue
10650 cgrad      do m=i+2,j2
10651 cgrad        do ll=1,3
10652 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
10653 cgrad        enddo
10654 cgrad      enddo
10655 cgrad      do m=k+2,l2
10656 cgrad        do ll=1,3
10657 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
10658 cgrad        enddo
10659 cgrad      enddo
10660 cd      do iii=1,nres-3
10661 cd        write (2,*) iii,g_corr5_loc(iii)
10662 cd      enddo
10663       eello5=ekont*eel5
10664 cd      write (2,*) 'ekont',ekont
10665 cd      write (iout,*) 'eello5',ekont*eel5
10666       return
10667       end
10668 c--------------------------------------------------------------------------
10669       double precision function eello6(i,j,k,l,jj,kk)
10670       implicit real*8 (a-h,o-z)
10671       include 'DIMENSIONS'
10672       include 'COMMON.IOUNITS'
10673       include 'COMMON.CHAIN'
10674       include 'COMMON.DERIV'
10675       include 'COMMON.INTERACT'
10676       include 'COMMON.CONTACTS'
10677       include 'COMMON.CONTMAT'
10678       include 'COMMON.CORRMAT'
10679       include 'COMMON.TORSION'
10680       include 'COMMON.VAR'
10681       include 'COMMON.GEO'
10682       include 'COMMON.FFIELD'
10683       double precision ggg1(3),ggg2(3)
10684 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
10685 cd        eello6=0.0d0
10686 cd        return
10687 cd      endif
10688 cd      write (iout,*)
10689 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
10690 cd     &   ' and',k,l
10691       eello6_1=0.0d0
10692       eello6_2=0.0d0
10693       eello6_3=0.0d0
10694       eello6_4=0.0d0
10695       eello6_5=0.0d0
10696       eello6_6=0.0d0
10697 cd      call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
10698 cd     &   eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
10699       do iii=1,2
10700         do kkk=1,5
10701           do lll=1,3
10702             derx(lll,kkk,iii)=0.0d0
10703           enddo
10704         enddo
10705       enddo
10706 cd      eij=facont_hb(jj,i)
10707 cd      ekl=facont_hb(kk,k)
10708 cd      ekont=eij*ekl
10709 cd      eij=1.0d0
10710 cd      ekl=1.0d0
10711 cd      ekont=1.0d0
10712       if (l.eq.j+1) then
10713         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
10714         eello6_2=eello6_graph1(j,i,l,k,2,.false.)
10715         eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
10716         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
10717         eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
10718         eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
10719       else
10720         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
10721         eello6_2=eello6_graph1(l,k,j,i,2,.true.)
10722         eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
10723         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
10724         if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
10725           eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
10726         else
10727           eello6_5=0.0d0
10728         endif
10729         eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
10730       endif
10731 C If turn contributions are considered, they will be handled separately.
10732       eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
10733 cd      write(iout,*) 'eello6_1',eello6_1!,' eel6_1_num',16*eel6_1_num
10734 cd      write(iout,*) 'eello6_2',eello6_2!,' eel6_2_num',16*eel6_2_num
10735 cd      write(iout,*) 'eello6_3',eello6_3!,' eel6_3_num',16*eel6_3_num
10736 cd      write(iout,*) 'eello6_4',eello6_4!,' eel6_4_num',16*eel6_4_num
10737 cd      write(iout,*) 'eello6_5',eello6_5!,' eel6_5_num',16*eel6_5_num
10738 cd      write(iout,*) 'eello6_6',eello6_6!,' eel6_6_num',16*eel6_6_num
10739 cd      goto 1112
10740       if (j.lt.nres-1) then
10741         j1=j+1
10742         j2=j-1
10743       else
10744         j1=j-1
10745         j2=j-2
10746       endif
10747       if (l.lt.nres-1) then
10748         l1=l+1
10749         l2=l-1
10750       else
10751         l1=l-1
10752         l2=l-2
10753       endif
10754       do ll=1,3
10755 cgrad        ggg1(ll)=eel6*g_contij(ll,1)
10756 cgrad        ggg2(ll)=eel6*g_contij(ll,2)
10757 cold        ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
10758 cgrad        ghalf=0.5d0*ggg1(ll)
10759 cd        ghalf=0.0d0
10760         gradcorr6ij=eel6*g_contij(ll,1)+ekont*derx(ll,1,1)
10761         gradcorr6kl=eel6*g_contij(ll,2)+ekont*derx(ll,1,2)
10762         gradcorr6(ll,i)=gradcorr6(ll,i)+ekont*derx(ll,2,1)
10763         gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
10764         gradcorr6(ll,j)=gradcorr6(ll,j)+ekont*derx(ll,4,1)
10765         gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
10766         gradcorr6_long(ll,j)=gradcorr6_long(ll,j)+gradcorr6ij
10767         gradcorr6_long(ll,i)=gradcorr6_long(ll,i)-gradcorr6ij
10768 cgrad        ghalf=0.5d0*ggg2(ll)
10769 cold        ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
10770 cd        ghalf=0.0d0
10771         gradcorr6(ll,k)=gradcorr6(ll,k)+ekont*derx(ll,2,2)
10772         gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
10773         gradcorr6(ll,l)=gradcorr6(ll,l)+ekont*derx(ll,4,2)
10774         gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
10775         gradcorr6_long(ll,l)=gradcorr6_long(ll,l)+gradcorr6kl
10776         gradcorr6_long(ll,k)=gradcorr6_long(ll,k)-gradcorr6kl
10777       enddo
10778 cd      goto 1112
10779 cgrad      do m=i+1,j-1
10780 cgrad        do ll=1,3
10781 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
10782 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
10783 cgrad        enddo
10784 cgrad      enddo
10785 cgrad      do m=k+1,l-1
10786 cgrad        do ll=1,3
10787 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
10788 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
10789 cgrad        enddo
10790 cgrad      enddo
10791 cgrad1112  continue
10792 cgrad      do m=i+2,j2
10793 cgrad        do ll=1,3
10794 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
10795 cgrad        enddo
10796 cgrad      enddo
10797 cgrad      do m=k+2,l2
10798 cgrad        do ll=1,3
10799 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
10800 cgrad        enddo
10801 cgrad      enddo
10802 cd      do iii=1,nres-3
10803 cd        write (2,*) iii,g_corr6_loc(iii)
10804 cd      enddo
10805       eello6=ekont*eel6
10806 cd      write (2,*) 'ekont',ekont
10807 cd      write (iout,*) 'eello6',ekont*eel6
10808       return
10809       end
10810 c--------------------------------------------------------------------------
10811       double precision function eello6_graph1(i,j,k,l,imat,swap)
10812       implicit real*8 (a-h,o-z)
10813       include 'DIMENSIONS'
10814       include 'COMMON.IOUNITS'
10815       include 'COMMON.CHAIN'
10816       include 'COMMON.DERIV'
10817       include 'COMMON.INTERACT'
10818       include 'COMMON.CONTACTS'
10819       include 'COMMON.CONTMAT'
10820       include 'COMMON.CORRMAT'
10821       include 'COMMON.TORSION'
10822       include 'COMMON.VAR'
10823       include 'COMMON.GEO'
10824       double precision vv(2),vv1(2),pizda(2,2),auxmat(2,2),pizda1(2,2)
10825       logical swap
10826       logical lprn
10827       common /kutas/ lprn
10828 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10829 C                                                                              C
10830 C      Parallel       Antiparallel                                             C
10831 C                                                                              C
10832 C          o             o                                                     C
10833 C         /l\           /j\                                                    C
10834 C        /   \         /   \                                                   C
10835 C       /| o |         | o |\                                                  C
10836 C     \ j|/k\|  /   \  |/k\|l /                                                C
10837 C      \ /   \ /     \ /   \ /                                                 C
10838 C       o     o       o     o                                                  C
10839 C       i             i                                                        C
10840 C                                                                              C
10841 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10842       itk=itype2loc(itype(k))
10843       s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
10844       s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
10845       s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
10846       call transpose2(EUgC(1,1,k),auxmat(1,1))
10847       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
10848       vv1(1)=pizda1(1,1)-pizda1(2,2)
10849       vv1(2)=pizda1(1,2)+pizda1(2,1)
10850       s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
10851       vv(1)=AEAb1(1,2,imat)*b1(1,k)-AEAb1(2,2,imat)*b1(2,k)
10852       vv(2)=AEAb1(1,2,imat)*b1(2,k)+AEAb1(2,2,imat)*b1(1,k)
10853       s5=scalar2(vv(1),Dtobr2(1,i))
10854 cd      write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
10855       eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
10856       if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1)
10857      & -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i))
10858      & -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k))
10859      & +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k))
10860      & +0.5d0*scalar2(vv1(1),Dtobr2der(1,i))
10861      & +scalar2(vv(1),Dtobr2der(1,i)))
10862       call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
10863       vv1(1)=pizda1(1,1)-pizda1(2,2)
10864       vv1(2)=pizda1(1,2)+pizda1(2,1)
10865       vv(1)=AEAb1derg(1,2,imat)*b1(1,k)-AEAb1derg(2,2,imat)*b1(2,k)
10866       vv(2)=AEAb1derg(1,2,imat)*b1(2,k)+AEAb1derg(2,2,imat)*b1(1,k)
10867       if (l.eq.j+1) then
10868         g_corr6_loc(l-1)=g_corr6_loc(l-1)
10869      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
10870      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
10871      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
10872      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
10873       else
10874         g_corr6_loc(j-1)=g_corr6_loc(j-1)
10875      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
10876      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
10877      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
10878      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
10879       endif
10880       call transpose2(EUgCder(1,1,k),auxmat(1,1))
10881       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
10882       vv1(1)=pizda1(1,1)-pizda1(2,2)
10883       vv1(2)=pizda1(1,2)+pizda1(2,1)
10884       if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1)
10885      & +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k))
10886      & +scalar2(AEAb2(1,1,imat),CUgb2der(1,k))
10887      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
10888       do iii=1,2
10889         if (swap) then
10890           ind=3-iii
10891         else
10892           ind=iii
10893         endif
10894         do kkk=1,5
10895           do lll=1,3
10896             s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
10897             s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
10898             s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
10899             call transpose2(EUgC(1,1,k),auxmat(1,1))
10900             call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
10901      &        pizda1(1,1))
10902             vv1(1)=pizda1(1,1)-pizda1(2,2)
10903             vv1(2)=pizda1(1,2)+pizda1(2,1)
10904             s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
10905             vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,k)
10906      &       -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,k)
10907             vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,k)
10908      &       +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,k)
10909             s5=scalar2(vv(1),Dtobr2(1,i))
10910             derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
10911           enddo
10912         enddo
10913       enddo
10914       return
10915       end
10916 c----------------------------------------------------------------------------
10917       double precision function eello6_graph2(i,j,k,l,jj,kk,swap)
10918       implicit real*8 (a-h,o-z)
10919       include 'DIMENSIONS'
10920       include 'COMMON.IOUNITS'
10921       include 'COMMON.CHAIN'
10922       include 'COMMON.DERIV'
10923       include 'COMMON.INTERACT'
10924       include 'COMMON.CONTACTS'
10925       include 'COMMON.CONTMAT'
10926       include 'COMMON.CORRMAT'
10927       include 'COMMON.TORSION'
10928       include 'COMMON.VAR'
10929       include 'COMMON.GEO'
10930       logical swap
10931       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
10932      & auxvec1(2),auxvec2(2),auxmat1(2,2)
10933       logical lprn
10934       common /kutas/ lprn
10935 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10936 C                                                                              C
10937 C      Parallel       Antiparallel                                             C
10938 C                                                                              C
10939 C          o             o                                                     C
10940 C     \   /l\           /j\   /                                                C
10941 C      \ /   \         /   \ /                                                 C
10942 C       o| o |         | o |o                                                  C
10943 C     \ j|/k\|      \  |/k\|l                                                  C
10944 C      \ /   \       \ /   \                                                   C
10945 C       o             o                                                        C
10946 C       i             i                                                        C
10947 C                                                                              C
10948 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10949 cd      write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
10950 C AL 7/4/01 s1 would occur in the sixth-order moment,
10951 C           but not in a cluster cumulant
10952 #ifdef MOMENT
10953       s1=dip(1,jj,i)*dip(1,kk,k)
10954 #endif
10955       call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
10956       s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
10957       call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
10958       s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
10959       call transpose2(EUg(1,1,k),auxmat(1,1))
10960       call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
10961       vv(1)=pizda(1,1)-pizda(2,2)
10962       vv(2)=pizda(1,2)+pizda(2,1)
10963       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
10964 cd      write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
10965 #ifdef MOMENT
10966       eello6_graph2=-(s1+s2+s3+s4)
10967 #else
10968       eello6_graph2=-(s2+s3+s4)
10969 #endif
10970 c      eello6_graph2=-s3
10971 C Derivatives in gamma(i-1)
10972       if (i.gt.1) then
10973 #ifdef MOMENT
10974         s1=dipderg(1,jj,i)*dip(1,kk,k)
10975 #endif
10976         s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
10977         call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
10978         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
10979         s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
10980 #ifdef MOMENT
10981         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
10982 #else
10983         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
10984 #endif
10985 c        g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
10986       endif
10987 C Derivatives in gamma(k-1)
10988 #ifdef MOMENT
10989       s1=dip(1,jj,i)*dipderg(1,kk,k)
10990 #endif
10991       call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
10992       s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
10993       call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
10994       s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
10995       call transpose2(EUgder(1,1,k),auxmat1(1,1))
10996       call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
10997       vv(1)=pizda(1,1)-pizda(2,2)
10998       vv(2)=pizda(1,2)+pizda(2,1)
10999       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
11000 #ifdef MOMENT
11001       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
11002 #else
11003       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
11004 #endif
11005 c      g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
11006 C Derivatives in gamma(j-1) or gamma(l-1)
11007       if (j.gt.1) then
11008 #ifdef MOMENT
11009         s1=dipderg(3,jj,i)*dip(1,kk,k)
11010 #endif
11011         call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
11012         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
11013         s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
11014         call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
11015         vv(1)=pizda(1,1)-pizda(2,2)
11016         vv(2)=pizda(1,2)+pizda(2,1)
11017         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
11018 #ifdef MOMENT
11019         if (swap) then
11020           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
11021         else
11022           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
11023         endif
11024 #endif
11025         g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
11026 c        g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
11027       endif
11028 C Derivatives in gamma(l-1) or gamma(j-1)
11029       if (l.gt.1) then
11030 #ifdef MOMENT
11031         s1=dip(1,jj,i)*dipderg(3,kk,k)
11032 #endif
11033         call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
11034         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
11035         call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
11036         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
11037         call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
11038         vv(1)=pizda(1,1)-pizda(2,2)
11039         vv(2)=pizda(1,2)+pizda(2,1)
11040         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
11041 #ifdef MOMENT
11042         if (swap) then
11043           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
11044         else
11045           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
11046         endif
11047 #endif
11048         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
11049 c        g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
11050       endif
11051 C Cartesian derivatives.
11052       if (lprn) then
11053         write (2,*) 'In eello6_graph2'
11054         do iii=1,2
11055           write (2,*) 'iii=',iii
11056           do kkk=1,5
11057             write (2,*) 'kkk=',kkk
11058             do jjj=1,2
11059               write (2,'(3(2f10.5),5x)')
11060      &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
11061             enddo
11062           enddo
11063         enddo
11064       endif
11065       do iii=1,2
11066         do kkk=1,5
11067           do lll=1,3
11068 #ifdef MOMENT
11069             if (iii.eq.1) then
11070               s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
11071             else
11072               s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
11073             endif
11074 #endif
11075             call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),
11076      &        auxvec(1))
11077             s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
11078             call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),
11079      &        auxvec(1))
11080             s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
11081             call transpose2(EUg(1,1,k),auxmat(1,1))
11082             call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),
11083      &        pizda(1,1))
11084             vv(1)=pizda(1,1)-pizda(2,2)
11085             vv(2)=pizda(1,2)+pizda(2,1)
11086             s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
11087 cd            write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
11088 #ifdef MOMENT
11089             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
11090 #else
11091             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
11092 #endif
11093             if (swap) then
11094               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
11095             else
11096               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
11097             endif
11098           enddo
11099         enddo
11100       enddo
11101       return
11102       end
11103 c----------------------------------------------------------------------------
11104       double precision function eello6_graph3(i,j,k,l,jj,kk,swap)
11105       implicit real*8 (a-h,o-z)
11106       include 'DIMENSIONS'
11107       include 'COMMON.IOUNITS'
11108       include 'COMMON.CHAIN'
11109       include 'COMMON.DERIV'
11110       include 'COMMON.INTERACT'
11111       include 'COMMON.CONTACTS'
11112       include 'COMMON.CONTMAT'
11113       include 'COMMON.CORRMAT'
11114       include 'COMMON.TORSION'
11115       include 'COMMON.VAR'
11116       include 'COMMON.GEO'
11117       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2)
11118       logical swap
11119 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
11120 C                                                                              C
11121 C      Parallel       Antiparallel                                             C
11122 C                                                                              C
11123 C          o             o                                                     C
11124 C         /l\   /   \   /j\                                                    C
11125 C        /   \ /     \ /   \                                                   C
11126 C       /| o |o       o| o |\                                                  C
11127 C       j|/k\|  /      |/k\|l /                                                C
11128 C        /   \ /       /   \ /                                                 C
11129 C       /     o       /     o                                                  C
11130 C       i             i                                                        C
11131 C                                                                              C
11132 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
11133 C
11134 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
11135 C           energy moment and not to the cluster cumulant.
11136       iti=itortyp(itype(i))
11137       if (j.lt.nres-1) then
11138         itj1=itype2loc(itype(j+1))
11139       else
11140         itj1=nloctyp
11141       endif
11142       itk=itype2loc(itype(k))
11143       itk1=itype2loc(itype(k+1))
11144       if (l.lt.nres-1) then
11145         itl1=itype2loc(itype(l+1))
11146       else
11147         itl1=nloctyp
11148       endif
11149 #ifdef MOMENT
11150       s1=dip(4,jj,i)*dip(4,kk,k)
11151 #endif
11152       call matvec2(AECA(1,1,1),b1(1,k+1),auxvec(1))
11153       s2=0.5d0*scalar2(b1(1,k),auxvec(1))
11154       call matvec2(AECA(1,1,2),b1(1,l+1),auxvec(1))
11155       s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
11156       call transpose2(EE(1,1,k),auxmat(1,1))
11157       call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
11158       vv(1)=pizda(1,1)+pizda(2,2)
11159       vv(2)=pizda(2,1)-pizda(1,2)
11160       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
11161 cd      write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4,
11162 cd     & "sum",-(s2+s3+s4)
11163 #ifdef MOMENT
11164       eello6_graph3=-(s1+s2+s3+s4)
11165 #else
11166       eello6_graph3=-(s2+s3+s4)
11167 #endif
11168 c      eello6_graph3=-s4
11169 C Derivatives in gamma(k-1)
11170       call matvec2(AECAderg(1,1,2),b1(1,l+1),auxvec(1))
11171       s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
11172       s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
11173       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
11174 C Derivatives in gamma(l-1)
11175       call matvec2(AECAderg(1,1,1),b1(1,k+1),auxvec(1))
11176       s2=0.5d0*scalar2(b1(1,k),auxvec(1))
11177       call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
11178       vv(1)=pizda(1,1)+pizda(2,2)
11179       vv(2)=pizda(2,1)-pizda(1,2)
11180       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
11181       g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
11182 C Cartesian derivatives.
11183       do iii=1,2
11184         do kkk=1,5
11185           do lll=1,3
11186 #ifdef MOMENT
11187             if (iii.eq.1) then
11188               s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
11189             else
11190               s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
11191             endif
11192 #endif
11193             call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
11194      &        auxvec(1))
11195             s2=0.5d0*scalar2(b1(1,k),auxvec(1))
11196             call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,l+1),
11197      &        auxvec(1))
11198             s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
11199             call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),
11200      &        pizda(1,1))
11201             vv(1)=pizda(1,1)+pizda(2,2)
11202             vv(2)=pizda(2,1)-pizda(1,2)
11203             s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
11204 #ifdef MOMENT
11205             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
11206 #else
11207             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
11208 #endif
11209             if (swap) then
11210               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
11211             else
11212               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
11213             endif
11214 c            derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
11215           enddo
11216         enddo
11217       enddo
11218       return
11219       end
11220 c----------------------------------------------------------------------------
11221       double precision function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
11222       implicit real*8 (a-h,o-z)
11223       include 'DIMENSIONS'
11224       include 'COMMON.IOUNITS'
11225       include 'COMMON.CHAIN'
11226       include 'COMMON.DERIV'
11227       include 'COMMON.INTERACT'
11228       include 'COMMON.CONTACTS'
11229       include 'COMMON.CONTMAT'
11230       include 'COMMON.CORRMAT'
11231       include 'COMMON.TORSION'
11232       include 'COMMON.VAR'
11233       include 'COMMON.GEO'
11234       include 'COMMON.FFIELD'
11235       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
11236      & auxvec1(2),auxmat1(2,2)
11237       logical swap
11238 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
11239 C                                                                              C
11240 C      Parallel       Antiparallel                                             C
11241 C                                                                              C
11242 C          o             o                                                     C
11243 C         /l\   /   \   /j\                                                    C
11244 C        /   \ /     \ /   \                                                   C
11245 C       /| o |o       o| o |\                                                  C
11246 C     \ j|/k\|      \  |/k\|l                                                  C
11247 C      \ /   \       \ /   \                                                   C
11248 C       o     \       o     \                                                  C
11249 C       i             i                                                        C
11250 C                                                                              C
11251 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
11252 C
11253 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
11254 C           energy moment and not to the cluster cumulant.
11255 cd      write (2,*) 'eello_graph4: wturn6',wturn6
11256       iti=itype2loc(itype(i))
11257       itj=itype2loc(itype(j))
11258       if (j.lt.nres-1) then
11259         itj1=itype2loc(itype(j+1))
11260       else
11261         itj1=nloctyp
11262       endif
11263       itk=itype2loc(itype(k))
11264       if (k.lt.nres-1) then
11265         itk1=itype2loc(itype(k+1))
11266       else
11267         itk1=nloctyp
11268       endif
11269       itl=itype2loc(itype(l))
11270       if (l.lt.nres-1) then
11271         itl1=itype2loc(itype(l+1))
11272       else
11273         itl1=nloctyp
11274       endif
11275 cd      write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
11276 cd      write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
11277 cd     & ' itl',itl,' itl1',itl1
11278 #ifdef MOMENT
11279       if (imat.eq.1) then
11280         s1=dip(3,jj,i)*dip(3,kk,k)
11281       else
11282         s1=dip(2,jj,j)*dip(2,kk,l)
11283       endif
11284 #endif
11285       call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
11286       s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
11287       if (j.eq.l+1) then
11288         call matvec2(ADtEA1(1,1,3-imat),b1(1,j+1),auxvec1(1))
11289         s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
11290       else
11291         call matvec2(ADtEA1(1,1,3-imat),b1(1,l+1),auxvec1(1))
11292         s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
11293       endif
11294       call transpose2(EUg(1,1,k),auxmat(1,1))
11295       call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
11296       vv(1)=pizda(1,1)-pizda(2,2)
11297       vv(2)=pizda(2,1)+pizda(1,2)
11298       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
11299 cd      write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
11300 #ifdef MOMENT
11301       eello6_graph4=-(s1+s2+s3+s4)
11302 #else
11303       eello6_graph4=-(s2+s3+s4)
11304 #endif
11305 C Derivatives in gamma(i-1)
11306       if (i.gt.1) then
11307 #ifdef MOMENT
11308         if (imat.eq.1) then
11309           s1=dipderg(2,jj,i)*dip(3,kk,k)
11310         else
11311           s1=dipderg(4,jj,j)*dip(2,kk,l)
11312         endif
11313 #endif
11314         s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
11315         if (j.eq.l+1) then
11316           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,j+1),auxvec1(1))
11317           s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
11318         else
11319           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,l+1),auxvec1(1))
11320           s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
11321         endif
11322         s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
11323         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
11324 cd          write (2,*) 'turn6 derivatives'
11325 #ifdef MOMENT
11326           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
11327 #else
11328           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
11329 #endif
11330         else
11331 #ifdef MOMENT
11332           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
11333 #else
11334           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
11335 #endif
11336         endif
11337       endif
11338 C Derivatives in gamma(k-1)
11339 #ifdef MOMENT
11340       if (imat.eq.1) then
11341         s1=dip(3,jj,i)*dipderg(2,kk,k)
11342       else
11343         s1=dip(2,jj,j)*dipderg(4,kk,l)
11344       endif
11345 #endif
11346       call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
11347       s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
11348       if (j.eq.l+1) then
11349         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,j+1),auxvec1(1))
11350         s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
11351       else
11352         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,l+1),auxvec1(1))
11353         s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
11354       endif
11355       call transpose2(EUgder(1,1,k),auxmat1(1,1))
11356       call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
11357       vv(1)=pizda(1,1)-pizda(2,2)
11358       vv(2)=pizda(2,1)+pizda(1,2)
11359       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
11360       if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
11361 #ifdef MOMENT
11362         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
11363 #else
11364         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
11365 #endif
11366       else
11367 #ifdef MOMENT
11368         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
11369 #else
11370         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
11371 #endif
11372       endif
11373 C Derivatives in gamma(j-1) or gamma(l-1)
11374       if (l.eq.j+1 .and. l.gt.1) then
11375         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
11376         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
11377         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
11378         vv(1)=pizda(1,1)-pizda(2,2)
11379         vv(2)=pizda(2,1)+pizda(1,2)
11380         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
11381         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
11382       else if (j.gt.1) then
11383         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
11384         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
11385         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
11386         vv(1)=pizda(1,1)-pizda(2,2)
11387         vv(2)=pizda(2,1)+pizda(1,2)
11388         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
11389         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
11390           gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
11391         else
11392           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
11393         endif
11394       endif
11395 C Cartesian derivatives.
11396       do iii=1,2
11397         do kkk=1,5
11398           do lll=1,3
11399 #ifdef MOMENT
11400             if (iii.eq.1) then
11401               if (imat.eq.1) then
11402                 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
11403               else
11404                 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
11405               endif
11406             else
11407               if (imat.eq.1) then
11408                 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
11409               else
11410                 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
11411               endif
11412             endif
11413 #endif
11414             call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),
11415      &        auxvec(1))
11416             s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
11417             if (j.eq.l+1) then
11418               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
11419      &          b1(1,j+1),auxvec(1))
11420               s3=-0.5d0*scalar2(b1(1,j),auxvec(1))
11421             else
11422               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
11423      &          b1(1,l+1),auxvec(1))
11424               s3=-0.5d0*scalar2(b1(1,l),auxvec(1))
11425             endif
11426             call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
11427      &        pizda(1,1))
11428             vv(1)=pizda(1,1)-pizda(2,2)
11429             vv(2)=pizda(2,1)+pizda(1,2)
11430             s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
11431             if (swap) then
11432               if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
11433 #ifdef MOMENT
11434                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
11435      &             -(s1+s2+s4)
11436 #else
11437                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
11438      &             -(s2+s4)
11439 #endif
11440                 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
11441               else
11442 #ifdef MOMENT
11443                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
11444 #else
11445                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
11446 #endif
11447                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
11448               endif
11449             else
11450 #ifdef MOMENT
11451               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
11452 #else
11453               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
11454 #endif
11455               if (l.eq.j+1) then
11456                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
11457               else
11458                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
11459               endif
11460             endif
11461           enddo
11462         enddo
11463       enddo
11464       return
11465       end
11466 c----------------------------------------------------------------------------
11467       double precision function eello_turn6(i,jj,kk)
11468       implicit real*8 (a-h,o-z)
11469       include 'DIMENSIONS'
11470       include 'COMMON.IOUNITS'
11471       include 'COMMON.CHAIN'
11472       include 'COMMON.DERIV'
11473       include 'COMMON.INTERACT'
11474       include 'COMMON.CONTACTS'
11475       include 'COMMON.CONTMAT'
11476       include 'COMMON.CORRMAT'
11477       include 'COMMON.TORSION'
11478       include 'COMMON.VAR'
11479       include 'COMMON.GEO'
11480       double precision vtemp1(2),vtemp2(2),vtemp3(2),vtemp4(2),
11481      &  atemp(2,2),auxmat(2,2),achuj_temp(2,2),gtemp(2,2),gvec(2),
11482      &  ggg1(3),ggg2(3)
11483       double precision vtemp1d(2),vtemp2d(2),vtemp3d(2),vtemp4d(2),
11484      &  atempd(2,2),auxmatd(2,2),achuj_tempd(2,2),gtempd(2,2),gvecd(2)
11485 C 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
11486 C           the respective energy moment and not to the cluster cumulant.
11487       s1=0.0d0
11488       s8=0.0d0
11489       s13=0.0d0
11490 c
11491       eello_turn6=0.0d0
11492       j=i+4
11493       k=i+1
11494       l=i+3
11495       iti=itype2loc(itype(i))
11496       itk=itype2loc(itype(k))
11497       itk1=itype2loc(itype(k+1))
11498       itl=itype2loc(itype(l))
11499       itj=itype2loc(itype(j))
11500 cd      write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
11501 cd      write (2,*) 'i',i,' k',k,' j',j,' l',l
11502 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
11503 cd        eello6=0.0d0
11504 cd        return
11505 cd      endif
11506 cd      write (iout,*)
11507 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
11508 cd     &   ' and',k,l
11509 cd      call checkint_turn6(i,jj,kk,eel_turn6_num)
11510       do iii=1,2
11511         do kkk=1,5
11512           do lll=1,3
11513             derx_turn(lll,kkk,iii)=0.0d0
11514           enddo
11515         enddo
11516       enddo
11517 cd      eij=1.0d0
11518 cd      ekl=1.0d0
11519 cd      ekont=1.0d0
11520       eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
11521 cd      eello6_5=0.0d0
11522 cd      write (2,*) 'eello6_5',eello6_5
11523 #ifdef MOMENT
11524       call transpose2(AEA(1,1,1),auxmat(1,1))
11525       call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
11526       ss1=scalar2(Ub2(1,i+2),b1(1,l))
11527       s1 = (auxmat(1,1)+auxmat(2,2))*ss1
11528 #endif
11529       call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1(1))
11530       call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
11531       s2 = scalar2(b1(1,k),vtemp1(1))
11532 #ifdef MOMENT
11533       call transpose2(AEA(1,1,2),atemp(1,1))
11534       call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
11535       call matvec2(Ug2(1,1,i+2),dd(1,1,k+1),vtemp2(1))
11536       s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,l),vtemp2(1))
11537 #endif
11538       call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
11539       call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
11540       s12 = scalar2(Ub2(1,i+2),vtemp3(1))
11541 #ifdef MOMENT
11542       call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
11543       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
11544       call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
11545       call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
11546       ss13 = scalar2(b1(1,k),vtemp4(1))
11547       s13 = (gtemp(1,1)+gtemp(2,2))*ss13
11548 #endif
11549 c      write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
11550 c      s1=0.0d0
11551 c      s2=0.0d0
11552 c      s8=0.0d0
11553 c      s12=0.0d0
11554 c      s13=0.0d0
11555       eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
11556 C Derivatives in gamma(i+2)
11557       s1d =0.0d0
11558       s8d =0.0d0
11559 #ifdef MOMENT
11560       call transpose2(AEA(1,1,1),auxmatd(1,1))
11561       call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
11562       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
11563       call transpose2(AEAderg(1,1,2),atempd(1,1))
11564       call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
11565       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,l),vtemp2(1))
11566 #endif
11567       call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
11568       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
11569       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
11570 c      s1d=0.0d0
11571 c      s2d=0.0d0
11572 c      s8d=0.0d0
11573 c      s12d=0.0d0
11574 c      s13d=0.0d0
11575       gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
11576 C Derivatives in gamma(i+3)
11577 #ifdef MOMENT
11578       call transpose2(AEA(1,1,1),auxmatd(1,1))
11579       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
11580       ss1d=scalar2(Ub2der(1,i+2),b1(1,l))
11581       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
11582 #endif
11583       call matvec2(EUgder(1,1,i+2),b1(1,l),vtemp1d(1))
11584       call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
11585       s2d = scalar2(b1(1,k),vtemp1d(1))
11586 #ifdef MOMENT
11587       call matvec2(Ug2der(1,1,i+2),dd(1,1,k+1),vtemp2d(1))
11588       s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,l),vtemp2d(1))
11589 #endif
11590       s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
11591 #ifdef MOMENT
11592       call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
11593       call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
11594       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
11595 #endif
11596 c      s1d=0.0d0
11597 c      s2d=0.0d0
11598 c      s8d=0.0d0
11599 c      s12d=0.0d0
11600 c      s13d=0.0d0
11601 #ifdef MOMENT
11602       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
11603      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
11604 #else
11605       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
11606      &               -0.5d0*ekont*(s2d+s12d)
11607 #endif
11608 C Derivatives in gamma(i+4)
11609       call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
11610       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
11611       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
11612 #ifdef MOMENT
11613       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
11614       call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
11615       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
11616 #endif
11617 c      s1d=0.0d0
11618 c      s2d=0.0d0
11619 c      s8d=0.0d0
11620 C      s12d=0.0d0
11621 c      s13d=0.0d0
11622 #ifdef MOMENT
11623       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
11624 #else
11625       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
11626 #endif
11627 C Derivatives in gamma(i+5)
11628 #ifdef MOMENT
11629       call transpose2(AEAderg(1,1,1),auxmatd(1,1))
11630       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
11631       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
11632 #endif
11633       call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1d(1))
11634       call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
11635       s2d = scalar2(b1(1,k),vtemp1d(1))
11636 #ifdef MOMENT
11637       call transpose2(AEA(1,1,2),atempd(1,1))
11638       call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
11639       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,l),vtemp2(1))
11640 #endif
11641       call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
11642       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
11643 #ifdef MOMENT
11644       call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
11645       ss13d = scalar2(b1(1,k),vtemp4d(1))
11646       s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
11647 #endif
11648 c      s1d=0.0d0
11649 c      s2d=0.0d0
11650 c      s8d=0.0d0
11651 c      s12d=0.0d0
11652 c      s13d=0.0d0
11653 #ifdef MOMENT
11654       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
11655      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
11656 #else
11657       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
11658      &               -0.5d0*ekont*(s2d+s12d)
11659 #endif
11660 C Cartesian derivatives
11661       do iii=1,2
11662         do kkk=1,5
11663           do lll=1,3
11664 #ifdef MOMENT
11665             call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
11666             call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
11667             s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
11668 #endif
11669             call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1(1))
11670             call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),
11671      &          vtemp1d(1))
11672             s2d = scalar2(b1(1,k),vtemp1d(1))
11673 #ifdef MOMENT
11674             call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
11675             call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
11676             s8d = -(atempd(1,1)+atempd(2,2))*
11677      &           scalar2(cc(1,1,l),vtemp2(1))
11678 #endif
11679             call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),
11680      &           auxmatd(1,1))
11681             call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
11682             s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
11683 c      s1d=0.0d0
11684 c      s2d=0.0d0
11685 c      s8d=0.0d0
11686 c      s12d=0.0d0
11687 c      s13d=0.0d0
11688 #ifdef MOMENT
11689             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
11690      &        - 0.5d0*(s1d+s2d)
11691 #else
11692             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
11693      &        - 0.5d0*s2d
11694 #endif
11695 #ifdef MOMENT
11696             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
11697      &        - 0.5d0*(s8d+s12d)
11698 #else
11699             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
11700      &        - 0.5d0*s12d
11701 #endif
11702           enddo
11703         enddo
11704       enddo
11705 #ifdef MOMENT
11706       do kkk=1,5
11707         do lll=1,3
11708           call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),
11709      &      achuj_tempd(1,1))
11710           call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
11711           call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
11712           s13d=(gtempd(1,1)+gtempd(2,2))*ss13
11713           derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
11714           call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),
11715      &      vtemp4d(1))
11716           ss13d = scalar2(b1(1,k),vtemp4d(1))
11717           s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
11718           derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
11719         enddo
11720       enddo
11721 #endif
11722 cd      write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
11723 cd     &  16*eel_turn6_num
11724 cd      goto 1112
11725       if (j.lt.nres-1) then
11726         j1=j+1
11727         j2=j-1
11728       else
11729         j1=j-1
11730         j2=j-2
11731       endif
11732       if (l.lt.nres-1) then
11733         l1=l+1
11734         l2=l-1
11735       else
11736         l1=l-1
11737         l2=l-2
11738       endif
11739       do ll=1,3
11740 cgrad        ggg1(ll)=eel_turn6*g_contij(ll,1)
11741 cgrad        ggg2(ll)=eel_turn6*g_contij(ll,2)
11742 cgrad        ghalf=0.5d0*ggg1(ll)
11743 cd        ghalf=0.0d0
11744         gturn6ij=eel_turn6*g_contij(ll,1)+ekont*derx_turn(ll,1,1)
11745         gturn6kl=eel_turn6*g_contij(ll,2)+ekont*derx_turn(ll,1,2)
11746         gcorr6_turn(ll,i)=gcorr6_turn(ll,i)!+ghalf
11747      &    +ekont*derx_turn(ll,2,1)
11748         gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
11749         gcorr6_turn(ll,j)=gcorr6_turn(ll,j)!+ghalf
11750      &    +ekont*derx_turn(ll,4,1)
11751         gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
11752         gcorr6_turn_long(ll,j)=gcorr6_turn_long(ll,j)+gturn6ij
11753         gcorr6_turn_long(ll,i)=gcorr6_turn_long(ll,i)-gturn6ij
11754 cgrad        ghalf=0.5d0*ggg2(ll)
11755 cd        ghalf=0.0d0
11756         gcorr6_turn(ll,k)=gcorr6_turn(ll,k)!+ghalf
11757      &    +ekont*derx_turn(ll,2,2)
11758         gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
11759         gcorr6_turn(ll,l)=gcorr6_turn(ll,l)!+ghalf
11760      &    +ekont*derx_turn(ll,4,2)
11761         gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
11762         gcorr6_turn_long(ll,l)=gcorr6_turn_long(ll,l)+gturn6kl
11763         gcorr6_turn_long(ll,k)=gcorr6_turn_long(ll,k)-gturn6kl
11764       enddo
11765 cd      goto 1112
11766 cgrad      do m=i+1,j-1
11767 cgrad        do ll=1,3
11768 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
11769 cgrad        enddo
11770 cgrad      enddo
11771 cgrad      do m=k+1,l-1
11772 cgrad        do ll=1,3
11773 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
11774 cgrad        enddo
11775 cgrad      enddo
11776 cgrad1112  continue
11777 cgrad      do m=i+2,j2
11778 cgrad        do ll=1,3
11779 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
11780 cgrad        enddo
11781 cgrad      enddo
11782 cgrad      do m=k+2,l2
11783 cgrad        do ll=1,3
11784 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
11785 cgrad        enddo
11786 cgrad      enddo
11787 cd      do iii=1,nres-3
11788 cd        write (2,*) iii,g_corr6_loc(iii)
11789 cd      enddo
11790       eello_turn6=ekont*eel_turn6
11791 cd      write (2,*) 'ekont',ekont
11792 cd      write (2,*) 'eel_turn6',ekont*eel_turn6
11793       return
11794       end
11795 C-----------------------------------------------------------------------------
11796 #endif
11797       double precision function scalar(u,v)
11798 !DIR$ INLINEALWAYS scalar
11799 #ifndef OSF
11800 cDEC$ ATTRIBUTES FORCEINLINE::scalar
11801 #endif
11802       implicit none
11803       double precision u(3),v(3)
11804 cd      double precision sc
11805 cd      integer i
11806 cd      sc=0.0d0
11807 cd      do i=1,3
11808 cd        sc=sc+u(i)*v(i)
11809 cd      enddo
11810 cd      scalar=sc
11811
11812       scalar=u(1)*v(1)+u(2)*v(2)+u(3)*v(3)
11813       return
11814       end
11815 crc-------------------------------------------------
11816       SUBROUTINE MATVEC2(A1,V1,V2)
11817 !DIR$ INLINEALWAYS MATVEC2
11818 #ifndef OSF
11819 cDEC$ ATTRIBUTES FORCEINLINE::MATVEC2
11820 #endif
11821       implicit real*8 (a-h,o-z)
11822       include 'DIMENSIONS'
11823       DIMENSION A1(2,2),V1(2),V2(2)
11824 c      DO 1 I=1,2
11825 c        VI=0.0
11826 c        DO 3 K=1,2
11827 c    3     VI=VI+A1(I,K)*V1(K)
11828 c        Vaux(I)=VI
11829 c    1 CONTINUE
11830
11831       vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
11832       vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
11833
11834       v2(1)=vaux1
11835       v2(2)=vaux2
11836       END
11837 C---------------------------------------
11838       SUBROUTINE MATMAT2(A1,A2,A3)
11839 #ifndef OSF
11840 cDEC$ ATTRIBUTES FORCEINLINE::MATMAT2
11841 #endif
11842       implicit real*8 (a-h,o-z)
11843       include 'DIMENSIONS'
11844       DIMENSION A1(2,2),A2(2,2),A3(2,2)
11845 c      DIMENSION AI3(2,2)
11846 c        DO  J=1,2
11847 c          A3IJ=0.0
11848 c          DO K=1,2
11849 c           A3IJ=A3IJ+A1(I,K)*A2(K,J)
11850 c          enddo
11851 c          A3(I,J)=A3IJ
11852 c       enddo
11853 c      enddo
11854
11855       ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
11856       ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
11857       ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
11858       ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
11859
11860       A3(1,1)=AI3_11
11861       A3(2,1)=AI3_21
11862       A3(1,2)=AI3_12
11863       A3(2,2)=AI3_22
11864       END
11865
11866 c-------------------------------------------------------------------------
11867       double precision function scalar2(u,v)
11868 !DIR$ INLINEALWAYS scalar2
11869       implicit none
11870       double precision u(2),v(2)
11871       double precision sc
11872       integer i
11873       scalar2=u(1)*v(1)+u(2)*v(2)
11874       return
11875       end
11876
11877 C-----------------------------------------------------------------------------
11878
11879       subroutine transpose2(a,at)
11880 !DIR$ INLINEALWAYS transpose2
11881 #ifndef OSF
11882 cDEC$ ATTRIBUTES FORCEINLINE::transpose2
11883 #endif
11884       implicit none
11885       double precision a(2,2),at(2,2)
11886       at(1,1)=a(1,1)
11887       at(1,2)=a(2,1)
11888       at(2,1)=a(1,2)
11889       at(2,2)=a(2,2)
11890       return
11891       end
11892 c--------------------------------------------------------------------------
11893       subroutine transpose(n,a,at)
11894       implicit none
11895       integer n,i,j
11896       double precision a(n,n),at(n,n)
11897       do i=1,n
11898         do j=1,n
11899           at(j,i)=a(i,j)
11900         enddo
11901       enddo
11902       return
11903       end
11904 C---------------------------------------------------------------------------
11905       subroutine prodmat3(a1,a2,kk,transp,prod)
11906 !DIR$ INLINEALWAYS prodmat3
11907 #ifndef OSF
11908 cDEC$ ATTRIBUTES FORCEINLINE::prodmat3
11909 #endif
11910       implicit none
11911       integer i,j
11912       double precision a1(2,2),a2(2,2),a2t(2,2),kk(2,2),prod(2,2)
11913       logical transp
11914 crc      double precision auxmat(2,2),prod_(2,2)
11915
11916       if (transp) then
11917 crc        call transpose2(kk(1,1),auxmat(1,1))
11918 crc        call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
11919 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
11920
11921            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1)
11922      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
11923            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2)
11924      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
11925            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1)
11926      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
11927            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2)
11928      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
11929
11930       else
11931 crc        call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
11932 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
11933
11934            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1)
11935      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
11936            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2)
11937      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
11938            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1)
11939      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
11940            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2)
11941      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
11942
11943       endif
11944 c      call transpose2(a2(1,1),a2t(1,1))
11945
11946 crc      print *,transp
11947 crc      print *,((prod_(i,j),i=1,2),j=1,2)
11948 crc      print *,((prod(i,j),i=1,2),j=1,2)
11949
11950       return
11951       end
11952 CCC----------------------------------------------
11953       subroutine Eliptransfer(eliptran)
11954       implicit real*8 (a-h,o-z)
11955       include 'DIMENSIONS'
11956       include 'COMMON.GEO'
11957       include 'COMMON.VAR'
11958       include 'COMMON.LOCAL'
11959       include 'COMMON.CHAIN'
11960       include 'COMMON.DERIV'
11961       include 'COMMON.NAMES'
11962       include 'COMMON.INTERACT'
11963       include 'COMMON.IOUNITS'
11964       include 'COMMON.CALC'
11965       include 'COMMON.CONTROL'
11966       include 'COMMON.SPLITELE'
11967       include 'COMMON.SBRIDGE'
11968 C this is done by Adasko
11969 C      print *,"wchodze"
11970 C structure of box:
11971 C      water
11972 C--bordliptop-- buffore starts
11973 C--bufliptop--- here true lipid starts
11974 C      lipid
11975 C--buflipbot--- lipid ends buffore starts
11976 C--bordlipbot--buffore ends
11977 c      call cartprint
11978       eliptran=0.0
11979       do i=ilip_start,ilip_end
11980 C       do i=1,1
11981         if (itype(i).eq.ntyp1) cycle
11982
11983         positi=(mod(((c(3,i)+c(3,i+1))/2.0d0),boxzsize))
11984         if (positi.le.0.0) positi=positi+boxzsize
11985 C        print *,i
11986 C first for peptide groups
11987 c for each residue check if it is in lipid or lipid water border area
11988        if ((positi.gt.bordlipbot)
11989      &.and.(positi.lt.bordliptop)) then
11990 C the energy transfer exist
11991         if (positi.lt.buflipbot) then
11992 C what fraction I am in
11993          fracinbuf=1.0d0-
11994      &        ((positi-bordlipbot)/lipbufthick)
11995 C lipbufthick is thickenes of lipid buffore
11996          sslip=sscalelip(fracinbuf)
11997          ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
11998          eliptran=eliptran+sslip*pepliptran
11999          gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
12000          gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
12001 C         gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
12002
12003 C        print *,"doing sccale for lower part"
12004 C         print *,i,sslip,fracinbuf,ssgradlip
12005         elseif (positi.gt.bufliptop) then
12006          fracinbuf=1.0d0-((bordliptop-positi)/lipbufthick)
12007          sslip=sscalelip(fracinbuf)
12008          ssgradlip=sscagradlip(fracinbuf)/lipbufthick
12009          eliptran=eliptran+sslip*pepliptran
12010          gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
12011          gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
12012 C         gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
12013 C          print *, "doing sscalefor top part"
12014 C         print *,i,sslip,fracinbuf,ssgradlip
12015         else
12016          eliptran=eliptran+pepliptran
12017 C         print *,"I am in true lipid"
12018         endif
12019 C       else
12020 C       eliptran=elpitran+0.0 ! I am in water
12021        endif
12022        enddo
12023 C       print *, "nic nie bylo w lipidzie?"
12024 C now multiply all by the peptide group transfer factor
12025 C       eliptran=eliptran*pepliptran
12026 C now the same for side chains
12027 CV       do i=1,1
12028        do i=ilip_start,ilip_end
12029         if (itype(i).eq.ntyp1) cycle
12030         positi=(mod(c(3,i+nres),boxzsize))
12031         if (positi.le.0) positi=positi+boxzsize
12032 c        write(iout,*) "i",i," positi",positi,bordlipbot,buflipbot,
12033 c     &   bordliptop
12034 C       print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop
12035 c for each residue check if it is in lipid or lipid water border area
12036 C       respos=mod(c(3,i+nres),boxzsize)
12037 C       print *,positi,bordlipbot,buflipbot
12038        if ((positi.gt.bordlipbot)
12039      & .and.(positi.lt.bordliptop)) then
12040 C the energy transfer exist
12041         if (positi.lt.buflipbot) then
12042          fracinbuf=1.0d0-
12043      &     ((positi-bordlipbot)/lipbufthick)
12044 c         write (iout,*) "i",i,itype(i)," fracinbuf",fracinbuf
12045 c         write (iout,*) "i",i," liptranene",liptranene(itype(i))
12046 C lipbufthick is thickenes of lipid buffore
12047          sslip=sscalelip(fracinbuf)
12048          ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
12049          eliptran=eliptran+sslip*liptranene(itype(i))
12050          gliptranx(3,i)=gliptranx(3,i)
12051      &+ssgradlip*liptranene(itype(i))
12052          gliptranc(3,i-1)= gliptranc(3,i-1)
12053      &+ssgradlip*liptranene(itype(i))
12054 C         print *,"doing sccale for lower part"
12055         elseif (positi.gt.bufliptop) then
12056          fracinbuf=1.0d0-
12057      &((bordliptop-positi)/lipbufthick)
12058          sslip=sscalelip(fracinbuf)
12059          ssgradlip=sscagradlip(fracinbuf)/lipbufthick
12060          eliptran=eliptran+sslip*liptranene(itype(i))
12061          gliptranx(3,i)=gliptranx(3,i)
12062      &+ssgradlip*liptranene(itype(i))
12063          gliptranc(3,i-1)= gliptranc(3,i-1)
12064      &+ssgradlip*liptranene(itype(i))
12065 C          print *, "doing sscalefor top part",sslip,fracinbuf
12066         else
12067          eliptran=eliptran+liptranene(itype(i))
12068 C         print *,"I am in true lipid"
12069         endif
12070         endif ! if in lipid or buffor
12071 C       else
12072 C       eliptran=elpitran+0.0 ! I am in water
12073        enddo
12074        return
12075        end
12076 C---------------------------------------------------------
12077 C AFM soubroutine for constant force
12078        subroutine AFMforce(Eafmforce)
12079        implicit real*8 (a-h,o-z)
12080       include 'DIMENSIONS'
12081       include 'COMMON.GEO'
12082       include 'COMMON.VAR'
12083       include 'COMMON.LOCAL'
12084       include 'COMMON.CHAIN'
12085       include 'COMMON.DERIV'
12086       include 'COMMON.NAMES'
12087       include 'COMMON.INTERACT'
12088       include 'COMMON.IOUNITS'
12089       include 'COMMON.CALC'
12090       include 'COMMON.CONTROL'
12091       include 'COMMON.SPLITELE'
12092       include 'COMMON.SBRIDGE'
12093       real*8 diffafm(3)
12094       dist=0.0d0
12095       Eafmforce=0.0d0
12096       do i=1,3
12097       diffafm(i)=c(i,afmend)-c(i,afmbeg)
12098       dist=dist+diffafm(i)**2
12099       enddo
12100       dist=dsqrt(dist)
12101       Eafmforce=-forceAFMconst*(dist-distafminit)
12102       do i=1,3
12103       gradafm(i,afmend-1)=-forceAFMconst*diffafm(i)/dist
12104       gradafm(i,afmbeg-1)=forceAFMconst*diffafm(i)/dist
12105       enddo
12106 C      print *,'AFM',Eafmforce
12107       return
12108       end
12109 C---------------------------------------------------------
12110 C AFM subroutine with pseudoconstant velocity
12111        subroutine AFMvel(Eafmforce)
12112        implicit real*8 (a-h,o-z)
12113       include 'DIMENSIONS'
12114       include 'COMMON.GEO'
12115       include 'COMMON.VAR'
12116       include 'COMMON.LOCAL'
12117       include 'COMMON.CHAIN'
12118       include 'COMMON.DERIV'
12119       include 'COMMON.NAMES'
12120       include 'COMMON.INTERACT'
12121       include 'COMMON.IOUNITS'
12122       include 'COMMON.CALC'
12123       include 'COMMON.CONTROL'
12124       include 'COMMON.SPLITELE'
12125       include 'COMMON.SBRIDGE'
12126       real*8 diffafm(3)
12127 C Only for check grad COMMENT if not used for checkgrad
12128 C      totT=3.0d0
12129 C--------------------------------------------------------
12130 C      print *,"wchodze"
12131       dist=0.0d0
12132       Eafmforce=0.0d0
12133       do i=1,3
12134       diffafm(i)=c(i,afmend)-c(i,afmbeg)
12135       dist=dist+diffafm(i)**2
12136       enddo
12137       dist=dsqrt(dist)
12138       Eafmforce=0.5d0*forceAFMconst
12139      & *(distafminit+totTafm*velAFMconst-dist)**2
12140 C      Eafmforce=-forceAFMconst*(dist-distafminit)
12141       do i=1,3
12142       gradafm(i,afmend-1)=-forceAFMconst*
12143      &(distafminit+totTafm*velAFMconst-dist)
12144      &*diffafm(i)/dist
12145       gradafm(i,afmbeg-1)=forceAFMconst*
12146      &(distafminit+totTafm*velAFMconst-dist)
12147      &*diffafm(i)/dist
12148       enddo
12149 C      print *,'AFM',Eafmforce,totTafm*velAFMconst,dist
12150       return
12151       end
12152 C-----------------------------------------------------------
12153 C first for shielding is setting of function of side-chains
12154        subroutine set_shield_fac
12155       implicit real*8 (a-h,o-z)
12156       include 'DIMENSIONS'
12157       include 'COMMON.CHAIN'
12158       include 'COMMON.DERIV'
12159       include 'COMMON.IOUNITS'
12160       include 'COMMON.SHIELD'
12161       include 'COMMON.INTERACT'
12162 C this is the squar root 77 devided by 81 the epislion in lipid (in protein)
12163       double precision div77_81/0.974996043d0/,
12164      &div4_81/0.2222222222d0/,sh_frac_dist_grad(3)
12165
12166 C the vector between center of side_chain and peptide group
12167        double precision pep_side(3),long,side_calf(3),
12168      &pept_group(3),costhet_grad(3),cosphi_grad_long(3),
12169      &cosphi_grad_loc(3),pep_side_norm(3),side_calf_norm(3)
12170 C the line belowe needs to be changed for FGPROC>1
12171       do i=1,nres-1
12172       if ((itype(i).eq.ntyp1).and.itype(i+1).eq.ntyp1) cycle
12173       ishield_list(i)=0
12174 Cif there two consequtive dummy atoms there is no peptide group between them
12175 C the line below has to be changed for FGPROC>1
12176       VolumeTotal=0.0
12177       do k=1,nres
12178        if ((itype(k).eq.ntyp1).or.(itype(k).eq.10)) cycle
12179        dist_pep_side=0.0
12180        dist_side_calf=0.0
12181        do j=1,3
12182 C first lets set vector conecting the ithe side-chain with kth side-chain
12183       pep_side(j)=c(j,k+nres)-(c(j,i)+c(j,i+1))/2.0d0
12184 C      pep_side(j)=2.0d0
12185 C and vector conecting the side-chain with its proper calfa
12186       side_calf(j)=c(j,k+nres)-c(j,k)
12187 C      side_calf(j)=2.0d0
12188       pept_group(j)=c(j,i)-c(j,i+1)
12189 C lets have their lenght
12190       dist_pep_side=pep_side(j)**2+dist_pep_side
12191       dist_side_calf=dist_side_calf+side_calf(j)**2
12192       dist_pept_group=dist_pept_group+pept_group(j)**2
12193       enddo
12194        dist_pep_side=dsqrt(dist_pep_side)
12195        dist_pept_group=dsqrt(dist_pept_group)
12196        dist_side_calf=dsqrt(dist_side_calf)
12197       do j=1,3
12198         pep_side_norm(j)=pep_side(j)/dist_pep_side
12199         side_calf_norm(j)=dist_side_calf
12200       enddo
12201 C now sscale fraction
12202        sh_frac_dist=-(dist_pep_side-rpp(1,1)-buff_shield)/buff_shield
12203 C       print *,buff_shield,"buff"
12204 C now sscale
12205         if (sh_frac_dist.le.0.0) cycle
12206 C If we reach here it means that this side chain reaches the shielding sphere
12207 C Lets add him to the list for gradient
12208         ishield_list(i)=ishield_list(i)+1
12209 C ishield_list is a list of non 0 side-chain that contribute to factor gradient
12210 C this list is essential otherwise problem would be O3
12211         shield_list(ishield_list(i),i)=k
12212 C Lets have the sscale value
12213         if (sh_frac_dist.gt.1.0) then
12214          scale_fac_dist=1.0d0
12215          do j=1,3
12216          sh_frac_dist_grad(j)=0.0d0
12217          enddo
12218         else
12219          scale_fac_dist=-sh_frac_dist*sh_frac_dist
12220      &                   *(2.0*sh_frac_dist-3.0d0)
12221          fac_help_scale=6.0*(sh_frac_dist-sh_frac_dist**2)
12222      &                  /dist_pep_side/buff_shield*0.5
12223 C remember for the final gradient multiply sh_frac_dist_grad(j)
12224 C for side_chain by factor -2 !
12225          do j=1,3
12226          sh_frac_dist_grad(j)=fac_help_scale*pep_side(j)
12227 C         print *,"jestem",scale_fac_dist,fac_help_scale,
12228 C     &                    sh_frac_dist_grad(j)
12229          enddo
12230         endif
12231 C        if ((i.eq.3).and.(k.eq.2)) then
12232 C        print *,i,sh_frac_dist,dist_pep,fac_help_scale,scale_fac_dist
12233 C     & ,"TU"
12234 C        endif
12235
12236 C this is what is now we have the distance scaling now volume...
12237       short=short_r_sidechain(itype(k))
12238       long=long_r_sidechain(itype(k))
12239       costhet=1.0d0/dsqrt(1.0+short**2/dist_pep_side**2)
12240 C now costhet_grad
12241 C       costhet=0.0d0
12242        costhet_fac=costhet**3*short**2*(-0.5)/dist_pep_side**4
12243 C       costhet_fac=0.0d0
12244        do j=1,3
12245          costhet_grad(j)=costhet_fac*pep_side(j)
12246        enddo
12247 C remember for the final gradient multiply costhet_grad(j)
12248 C for side_chain by factor -2 !
12249 C fac alfa is angle between CB_k,CA_k, CA_i,CA_i+1
12250 C pep_side0pept_group is vector multiplication
12251       pep_side0pept_group=0.0
12252       do j=1,3
12253       pep_side0pept_group=pep_side0pept_group+pep_side(j)*side_calf(j)
12254       enddo
12255       cosalfa=(pep_side0pept_group/
12256      & (dist_pep_side*dist_side_calf))
12257       fac_alfa_sin=1.0-cosalfa**2
12258       fac_alfa_sin=dsqrt(fac_alfa_sin)
12259       rkprim=fac_alfa_sin*(long-short)+short
12260 C now costhet_grad
12261        cosphi=1.0d0/dsqrt(1.0+rkprim**2/dist_pep_side**2)
12262        cosphi_fac=cosphi**3*rkprim**2*(-0.5)/dist_pep_side**4
12263
12264        do j=1,3
12265          cosphi_grad_long(j)=cosphi_fac*pep_side(j)
12266      &+cosphi**3*0.5/dist_pep_side**2*(-rkprim)
12267      &*(long-short)/fac_alfa_sin*cosalfa/
12268      &((dist_pep_side*dist_side_calf))*
12269      &((side_calf(j))-cosalfa*
12270      &((pep_side(j)/dist_pep_side)*dist_side_calf))
12271
12272         cosphi_grad_loc(j)=cosphi**3*0.5/dist_pep_side**2*(-rkprim)
12273      &*(long-short)/fac_alfa_sin*cosalfa
12274      &/((dist_pep_side*dist_side_calf))*
12275      &(pep_side(j)-
12276      &cosalfa*side_calf(j)/dist_side_calf*dist_pep_side)
12277        enddo
12278
12279       VofOverlap=VSolvSphere/2.0d0*(1.0-costhet)*(1.0-cosphi)
12280      &                    /VSolvSphere_div
12281      &                    *wshield
12282 C now the gradient...
12283 C grad_shield is gradient of Calfa for peptide groups
12284 C      write(iout,*) "shield_compon",i,k,VSolvSphere,scale_fac_dist,
12285 C     &               costhet,cosphi
12286 C       write(iout,*) "cosphi_compon",i,k,pep_side0pept_group,
12287 C     & dist_pep_side,dist_side_calf,c(1,k+nres),c(1,k),itype(k)
12288       do j=1,3
12289       grad_shield(j,i)=grad_shield(j,i)
12290 C gradient po skalowaniu
12291      &                +(sh_frac_dist_grad(j)
12292 C  gradient po costhet
12293      &-scale_fac_dist*costhet_grad(j)/(1.0-costhet)
12294      &-scale_fac_dist*(cosphi_grad_long(j))
12295      &/(1.0-cosphi) )*div77_81
12296      &*VofOverlap
12297 C grad_shield_side is Cbeta sidechain gradient
12298       grad_shield_side(j,ishield_list(i),i)=
12299      &        (sh_frac_dist_grad(j)*(-2.0d0)
12300      &       +scale_fac_dist*costhet_grad(j)*2.0d0/(1.0-costhet)
12301      &       +scale_fac_dist*(cosphi_grad_long(j))
12302      &        *2.0d0/(1.0-cosphi))
12303      &        *div77_81*VofOverlap
12304
12305        grad_shield_loc(j,ishield_list(i),i)=
12306      &   scale_fac_dist*cosphi_grad_loc(j)
12307      &        *2.0d0/(1.0-cosphi)
12308      &        *div77_81*VofOverlap
12309       enddo
12310       VolumeTotal=VolumeTotal+VofOverlap*scale_fac_dist
12311       enddo
12312       fac_shield(i)=VolumeTotal*div77_81+div4_81
12313 c      write(2,*) "TOTAL VOLUME",i,VolumeTotal,fac_shield(i)
12314       enddo
12315       return
12316       end
12317 C--------------------------------------------------------------------------
12318       double precision function tschebyshev(m,n,x,y)
12319       implicit none
12320       include "DIMENSIONS"
12321       integer i,m,n
12322       double precision x(n),y,yy(0:maxvar),aux
12323 c Tschebyshev polynomial. Note that the first term is omitted
12324 c m=0: the constant term is included
12325 c m=1: the constant term is not included
12326       yy(0)=1.0d0
12327       yy(1)=y
12328       do i=2,n
12329         yy(i)=2*yy(1)*yy(i-1)-yy(i-2)
12330       enddo
12331       aux=0.0d0
12332       do i=m,n
12333         aux=aux+x(i)*yy(i)
12334       enddo
12335       tschebyshev=aux
12336       return
12337       end
12338 C--------------------------------------------------------------------------
12339       double precision function gradtschebyshev(m,n,x,y)
12340       implicit none
12341       include "DIMENSIONS"
12342       integer i,m,n
12343       double precision x(n+1),y,yy(0:maxvar),aux
12344 c Tschebyshev polynomial. Note that the first term is omitted
12345 c m=0: the constant term is included
12346 c m=1: the constant term is not included
12347       yy(0)=1.0d0
12348       yy(1)=2.0d0*y
12349       do i=2,n
12350         yy(i)=2*y*yy(i-1)-yy(i-2)
12351       enddo
12352       aux=0.0d0
12353       do i=m,n
12354         aux=aux+x(i+1)*yy(i)*(i+1)
12355 C        print *, x(i+1),yy(i),i
12356       enddo
12357       gradtschebyshev=aux
12358       return
12359       end
12360 C------------------------------------------------------------------------
12361 C first for shielding is setting of function of side-chains
12362        subroutine set_shield_fac2
12363       implicit real*8 (a-h,o-z)
12364       include 'DIMENSIONS'
12365       include 'COMMON.CHAIN'
12366       include 'COMMON.DERIV'
12367       include 'COMMON.IOUNITS'
12368       include 'COMMON.SHIELD'
12369       include 'COMMON.INTERACT'
12370 C this is the squar root 77 devided by 81 the epislion in lipid (in protein)
12371       double precision div77_81/0.974996043d0/,
12372      &div4_81/0.2222222222d0/,sh_frac_dist_grad(3)
12373
12374 C the vector between center of side_chain and peptide group
12375        double precision pep_side(3),long,side_calf(3),
12376      &pept_group(3),costhet_grad(3),cosphi_grad_long(3),
12377      &cosphi_grad_loc(3),pep_side_norm(3),side_calf_norm(3)
12378 C the line belowe needs to be changed for FGPROC>1
12379       do i=1,nres-1
12380       if ((itype(i).eq.ntyp1).and.itype(i+1).eq.ntyp1) cycle
12381       ishield_list(i)=0
12382 Cif there two consequtive dummy atoms there is no peptide group between them
12383 C the line below has to be changed for FGPROC>1
12384       VolumeTotal=0.0
12385       do k=1,nres
12386        if ((itype(k).eq.ntyp1).or.(itype(k).eq.10)) cycle
12387        dist_pep_side=0.0
12388        dist_side_calf=0.0
12389        do j=1,3
12390 C first lets set vector conecting the ithe side-chain with kth side-chain
12391       pep_side(j)=c(j,k+nres)-(c(j,i)+c(j,i+1))/2.0d0
12392 C      pep_side(j)=2.0d0
12393 C and vector conecting the side-chain with its proper calfa
12394       side_calf(j)=c(j,k+nres)-c(j,k)
12395 C      side_calf(j)=2.0d0
12396       pept_group(j)=c(j,i)-c(j,i+1)
12397 C lets have their lenght
12398       dist_pep_side=pep_side(j)**2+dist_pep_side
12399       dist_side_calf=dist_side_calf+side_calf(j)**2
12400       dist_pept_group=dist_pept_group+pept_group(j)**2
12401       enddo
12402        dist_pep_side=dsqrt(dist_pep_side)
12403        dist_pept_group=dsqrt(dist_pept_group)
12404        dist_side_calf=dsqrt(dist_side_calf)
12405       do j=1,3
12406         pep_side_norm(j)=pep_side(j)/dist_pep_side
12407         side_calf_norm(j)=dist_side_calf
12408       enddo
12409 C now sscale fraction
12410        sh_frac_dist=-(dist_pep_side-rpp(1,1)-buff_shield)/buff_shield
12411 C       print *,buff_shield,"buff"
12412 C now sscale
12413         if (sh_frac_dist.le.0.0) cycle
12414 C If we reach here it means that this side chain reaches the shielding sphere
12415 C Lets add him to the list for gradient
12416         ishield_list(i)=ishield_list(i)+1
12417 C ishield_list is a list of non 0 side-chain that contribute to factor gradient
12418 C this list is essential otherwise problem would be O3
12419         shield_list(ishield_list(i),i)=k
12420 C Lets have the sscale value
12421         if (sh_frac_dist.gt.1.0) then
12422          scale_fac_dist=1.0d0
12423          do j=1,3
12424          sh_frac_dist_grad(j)=0.0d0
12425          enddo
12426         else
12427          scale_fac_dist=-sh_frac_dist*sh_frac_dist
12428      &                   *(2.0d0*sh_frac_dist-3.0d0)
12429          fac_help_scale=6.0d0*(sh_frac_dist-sh_frac_dist**2)
12430      &                  /dist_pep_side/buff_shield*0.5d0
12431 C remember for the final gradient multiply sh_frac_dist_grad(j)
12432 C for side_chain by factor -2 !
12433          do j=1,3
12434          sh_frac_dist_grad(j)=fac_help_scale*pep_side(j)
12435 C         sh_frac_dist_grad(j)=0.0d0
12436 C         scale_fac_dist=1.0d0
12437 C         print *,"jestem",scale_fac_dist,fac_help_scale,
12438 C     &                    sh_frac_dist_grad(j)
12439          enddo
12440         endif
12441 C this is what is now we have the distance scaling now volume...
12442       short=short_r_sidechain(itype(k))
12443       long=long_r_sidechain(itype(k))
12444       costhet=1.0d0/dsqrt(1.0d0+short**2/dist_pep_side**2)
12445       sinthet=short/dist_pep_side*costhet
12446 C now costhet_grad
12447 C       costhet=0.6d0
12448 C       sinthet=0.8
12449        costhet_fac=costhet**3*short**2*(-0.5d0)/dist_pep_side**4
12450 C       sinthet_fac=costhet**2*0.5d0*(short**3/dist_pep_side**4*costhet
12451 C     &             -short/dist_pep_side**2/costhet)
12452 C       costhet_fac=0.0d0
12453        do j=1,3
12454          costhet_grad(j)=costhet_fac*pep_side(j)
12455        enddo
12456 C remember for the final gradient multiply costhet_grad(j)
12457 C for side_chain by factor -2 !
12458 C fac alfa is angle between CB_k,CA_k, CA_i,CA_i+1
12459 C pep_side0pept_group is vector multiplication
12460       pep_side0pept_group=0.0d0
12461       do j=1,3
12462       pep_side0pept_group=pep_side0pept_group+pep_side(j)*side_calf(j)
12463       enddo
12464       cosalfa=(pep_side0pept_group/
12465      & (dist_pep_side*dist_side_calf))
12466       fac_alfa_sin=1.0d0-cosalfa**2
12467       fac_alfa_sin=dsqrt(fac_alfa_sin)
12468       rkprim=fac_alfa_sin*(long-short)+short
12469 C      rkprim=short
12470
12471 C now costhet_grad
12472        cosphi=1.0d0/dsqrt(1.0d0+rkprim**2/dist_pep_side**2)
12473 C       cosphi=0.6
12474        cosphi_fac=cosphi**3*rkprim**2*(-0.5d0)/dist_pep_side**4
12475        sinphi=rkprim/dist_pep_side/dsqrt(1.0d0+rkprim**2/
12476      &      dist_pep_side**2)
12477 C       sinphi=0.8
12478        do j=1,3
12479          cosphi_grad_long(j)=cosphi_fac*pep_side(j)
12480      &+cosphi**3*0.5d0/dist_pep_side**2*(-rkprim)
12481      &*(long-short)/fac_alfa_sin*cosalfa/
12482      &((dist_pep_side*dist_side_calf))*
12483      &((side_calf(j))-cosalfa*
12484      &((pep_side(j)/dist_pep_side)*dist_side_calf))
12485 C       cosphi_grad_long(j)=0.0d0
12486         cosphi_grad_loc(j)=cosphi**3*0.5d0/dist_pep_side**2*(-rkprim)
12487      &*(long-short)/fac_alfa_sin*cosalfa
12488      &/((dist_pep_side*dist_side_calf))*
12489      &(pep_side(j)-
12490      &cosalfa*side_calf(j)/dist_side_calf*dist_pep_side)
12491 C       cosphi_grad_loc(j)=0.0d0
12492        enddo
12493 C      print *,sinphi,sinthet
12494 c      write (iout,*) "VSolvSphere",VSolvSphere," VSolvSphere_div",
12495 c     &  VSolvSphere_div," sinphi",sinphi," sinthet",sinthet
12496       VofOverlap=VSolvSphere/2.0d0*(1.0d0-dsqrt(1.0d0-sinphi*sinthet))
12497      &                    /VSolvSphere_div
12498 C     &                    *wshield
12499 C now the gradient...
12500       do j=1,3
12501       grad_shield(j,i)=grad_shield(j,i)
12502 C gradient po skalowaniu
12503      &                +(sh_frac_dist_grad(j)*VofOverlap
12504 C  gradient po costhet
12505      &       +scale_fac_dist*VSolvSphere/VSolvSphere_div/4.0d0*
12506      &(1.0d0/(-dsqrt(1.0d0-sinphi*sinthet))*(
12507      &       sinphi/sinthet*costhet*costhet_grad(j)
12508      &      +sinthet/sinphi*cosphi*cosphi_grad_long(j)))
12509      & )*wshield
12510 C grad_shield_side is Cbeta sidechain gradient
12511       grad_shield_side(j,ishield_list(i),i)=
12512      &        (sh_frac_dist_grad(j)*(-2.0d0)
12513      &        *VofOverlap
12514      &       -scale_fac_dist*VSolvSphere/VSolvSphere_div/2.0d0*
12515      &(1.0d0/(-dsqrt(1.0d0-sinphi*sinthet))*(
12516      &       sinphi/sinthet*costhet*costhet_grad(j)
12517      &      +sinthet/sinphi*cosphi*cosphi_grad_long(j)))
12518      &       )*wshield
12519
12520        grad_shield_loc(j,ishield_list(i),i)=
12521      &       scale_fac_dist*VSolvSphere/VSolvSphere_div/2.0d0*
12522      &(1.0d0/(dsqrt(1.0d0-sinphi*sinthet))*(
12523      &       sinthet/sinphi*cosphi*cosphi_grad_loc(j)
12524      &        ))
12525      &        *wshield
12526       enddo
12527 c      write (iout,*) "VofOverlap",VofOverlap," scale_fac_dist",
12528 c     & scale_fac_dist
12529       VolumeTotal=VolumeTotal+VofOverlap*scale_fac_dist
12530       enddo
12531       fac_shield(i)=VolumeTotal*wshield+(1.0d0-wshield)
12532 c      write(2,*) "TOTAL VOLUME",i,VolumeTotal,fac_shield(i),
12533 c     &  " wshield",wshield
12534 c      write(2,*) "TU",rpp(1,1),short,long,buff_shield
12535       enddo
12536       return
12537       end
12538 C-----------------------------------------------------------------------
12539 C-----------------------------------------------------------
12540 C This subroutine is to mimic the histone like structure but as well can be
12541 C utilizet to nanostructures (infinit) small modification has to be used to
12542 C make it finite (z gradient at the ends has to be changes as well as the x,y
12543 C gradient has to be modified at the ends
12544 C The energy function is Kihara potential
12545 C E=4esp*((sigma/(r-r0))^12 - (sigma/(r-r0))^6)
12546 C 4eps is depth of well sigma is r_minimum r is distance from center of tube
12547 C and r0 is the excluded size of nanotube (can be set to 0 if we want just a
12548 C simple Kihara potential
12549       subroutine calctube(Etube)
12550        implicit real*8 (a-h,o-z)
12551       include 'DIMENSIONS'
12552       include 'COMMON.GEO'
12553       include 'COMMON.VAR'
12554       include 'COMMON.LOCAL'
12555       include 'COMMON.CHAIN'
12556       include 'COMMON.DERIV'
12557       include 'COMMON.NAMES'
12558       include 'COMMON.INTERACT'
12559       include 'COMMON.IOUNITS'
12560       include 'COMMON.CALC'
12561       include 'COMMON.CONTROL'
12562       include 'COMMON.SPLITELE'
12563       include 'COMMON.SBRIDGE'
12564       double precision tub_r,vectube(3),enetube(maxres*2)
12565       Etube=0.0d0
12566       do i=1,2*nres
12567         enetube(i)=0.0d0
12568       enddo
12569 C first we calculate the distance from tube center
12570 C first sugare-phosphate group for NARES this would be peptide group
12571 C for UNRES
12572       do i=1,nres
12573 C lets ommit dummy atoms for now
12574        if ((itype(i).eq.ntyp1).or.(itype(i+1).eq.ntyp1)) cycle
12575 C now calculate distance from center of tube and direction vectors
12576       vectube(1)=mod((c(1,i)+c(1,i+1))/2.0d0,boxxsize)
12577           if (vectube(1).lt.0) vectube(1)=vectube(1)+boxxsize
12578       vectube(2)=mod((c(2,i)+c(2,i+1))/2.0d0,boxxsize)
12579           if (vectube(2).lt.0) vectube(2)=vectube(2)+boxxsize
12580       vectube(1)=vectube(1)-tubecenter(1)
12581       vectube(2)=vectube(2)-tubecenter(2)
12582
12583 C      print *,"x",(c(1,i)+c(1,i+1))/2.0d0,tubecenter(1)
12584 C      print *,"y",(c(2,i)+c(2,i+1))/2.0d0,tubecenter(2)
12585
12586 C as the tube is infinity we do not calculate the Z-vector use of Z
12587 C as chosen axis
12588       vectube(3)=0.0d0
12589 C now calculte the distance
12590        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
12591 C now normalize vector
12592       vectube(1)=vectube(1)/tub_r
12593       vectube(2)=vectube(2)/tub_r
12594 C calculte rdiffrence between r and r0
12595       rdiff=tub_r-tubeR0
12596 C and its 6 power
12597       rdiff6=rdiff**6.0d0
12598 C for vectorization reasons we will sumup at the end to avoid depenence of previous
12599        enetube(i)=pep_aa_tube/rdiff6**2.0d0-pep_bb_tube/rdiff6
12600 C       write(iout,*) "TU13",i,rdiff6,enetube(i)
12601 C       print *,rdiff,rdiff6,pep_aa_tube
12602 C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
12603 C now we calculate gradient
12604        fac=(-12.0d0*pep_aa_tube/rdiff6+
12605      &       6.0d0*pep_bb_tube)/rdiff6/rdiff
12606 C       write(iout,'(a5,i4,f12.1,3f12.5)') "TU13",i,rdiff6,enetube(i),
12607 C     &rdiff,fac
12608
12609 C now direction of gg_tube vector
12610         do j=1,3
12611         gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac/2.0d0
12612         gg_tube(j,i)=gg_tube(j,i)+vectube(j)*fac/2.0d0
12613         enddo
12614         enddo
12615 C basically thats all code now we split for side-chains (REMEMBER to sum up at the END)
12616         do i=1,nres
12617 C Lets not jump over memory as we use many times iti
12618          iti=itype(i)
12619 C lets ommit dummy atoms for now
12620          if ((iti.eq.ntyp1)
12621 C in UNRES uncomment the line below as GLY has no side-chain...
12622 C      .or.(iti.eq.10)
12623      &   ) cycle
12624           vectube(1)=c(1,i+nres)
12625           vectube(1)=mod(vectube(1),boxxsize)
12626           if (vectube(1).lt.0) vectube(1)=vectube(1)+boxxsize
12627           vectube(2)=c(2,i+nres)
12628           vectube(2)=mod(vectube(2),boxxsize)
12629           if (vectube(2).lt.0) vectube(2)=vectube(2)+boxxsize
12630
12631       vectube(1)=vectube(1)-tubecenter(1)
12632       vectube(2)=vectube(2)-tubecenter(2)
12633
12634 C as the tube is infinity we do not calculate the Z-vector use of Z
12635 C as chosen axis
12636       vectube(3)=0.0d0
12637 C now calculte the distance
12638        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
12639 C now normalize vector
12640       vectube(1)=vectube(1)/tub_r
12641       vectube(2)=vectube(2)/tub_r
12642 C calculte rdiffrence between r and r0
12643       rdiff=tub_r-tubeR0
12644 C and its 6 power
12645       rdiff6=rdiff**6.0d0
12646 C for vectorization reasons we will sumup at the end to avoid depenence of previous
12647        sc_aa_tube=sc_aa_tube_par(iti)
12648        sc_bb_tube=sc_bb_tube_par(iti)
12649        enetube(i+nres)=sc_aa_tube/rdiff6**2.0d0-sc_bb_tube/rdiff6
12650 C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
12651 C now we calculate gradient
12652        fac=-12.0d0*sc_aa_tube/rdiff6**2.0d0/rdiff+
12653      &       6.0d0*sc_bb_tube/rdiff6/rdiff
12654 C now direction of gg_tube vector
12655          do j=1,3
12656           gg_tube_SC(j,i)=gg_tube_SC(j,i)+vectube(j)*fac
12657           gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac
12658          enddo
12659         enddo
12660         do i=1,2*nres
12661           Etube=Etube+enetube(i)
12662         enddo
12663 C        print *,"ETUBE", etube
12664         return
12665         end
12666 C TO DO 1) add to total energy
12667 C       2) add to gradient summation
12668 C       3) add reading parameters (AND of course oppening of PARAM file)
12669 C       4) add reading the center of tube
12670 C       5) add COMMONs
12671 C       6) add to zerograd
12672
12673 C-----------------------------------------------------------------------
12674 C-----------------------------------------------------------
12675 C This subroutine is to mimic the histone like structure but as well can be
12676 C utilizet to nanostructures (infinit) small modification has to be used to
12677 C make it finite (z gradient at the ends has to be changes as well as the x,y
12678 C gradient has to be modified at the ends
12679 C The energy function is Kihara potential
12680 C E=4esp*((sigma/(r-r0))^12 - (sigma/(r-r0))^6)
12681 C 4eps is depth of well sigma is r_minimum r is distance from center of tube
12682 C and r0 is the excluded size of nanotube (can be set to 0 if we want just a
12683 C simple Kihara potential
12684       subroutine calctube2(Etube)
12685        implicit real*8 (a-h,o-z)
12686       include 'DIMENSIONS'
12687       include 'COMMON.GEO'
12688       include 'COMMON.VAR'
12689       include 'COMMON.LOCAL'
12690       include 'COMMON.CHAIN'
12691       include 'COMMON.DERIV'
12692       include 'COMMON.NAMES'
12693       include 'COMMON.INTERACT'
12694       include 'COMMON.IOUNITS'
12695       include 'COMMON.CALC'
12696       include 'COMMON.CONTROL'
12697       include 'COMMON.SPLITELE'
12698       include 'COMMON.SBRIDGE'
12699       double precision tub_r,vectube(3),enetube(maxres*2)
12700       Etube=0.0d0
12701       do i=1,2*nres
12702         enetube(i)=0.0d0
12703       enddo
12704 C first we calculate the distance from tube center
12705 C first sugare-phosphate group for NARES this would be peptide group
12706 C for UNRES
12707       do i=1,nres
12708 C lets ommit dummy atoms for now
12709        if ((itype(i).eq.ntyp1).or.(itype(i+1).eq.ntyp1)) cycle
12710 C now calculate distance from center of tube and direction vectors
12711       vectube(1)=mod((c(1,i)+c(1,i+1))/2.0d0,boxxsize)
12712           if (vectube(1).lt.0) vectube(1)=vectube(1)+boxxsize
12713       vectube(2)=mod((c(2,i)+c(2,i+1))/2.0d0,boxxsize)
12714           if (vectube(2).lt.0) vectube(2)=vectube(2)+boxxsize
12715       vectube(1)=vectube(1)-tubecenter(1)
12716       vectube(2)=vectube(2)-tubecenter(2)
12717
12718 C      print *,"x",(c(1,i)+c(1,i+1))/2.0d0,tubecenter(1)
12719 C      print *,"y",(c(2,i)+c(2,i+1))/2.0d0,tubecenter(2)
12720
12721 C as the tube is infinity we do not calculate the Z-vector use of Z
12722 C as chosen axis
12723       vectube(3)=0.0d0
12724 C now calculte the distance
12725        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
12726 C now normalize vector
12727       vectube(1)=vectube(1)/tub_r
12728       vectube(2)=vectube(2)/tub_r
12729 C calculte rdiffrence between r and r0
12730       rdiff=tub_r-tubeR0
12731 C and its 6 power
12732       rdiff6=rdiff**6.0d0
12733 C for vectorization reasons we will sumup at the end to avoid depenence of previous
12734        enetube(i)=pep_aa_tube/rdiff6**2.0d0-pep_bb_tube/rdiff6
12735 C       write(iout,*) "TU13",i,rdiff6,enetube(i)
12736 C       print *,rdiff,rdiff6,pep_aa_tube
12737 C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
12738 C now we calculate gradient
12739        fac=(-12.0d0*pep_aa_tube/rdiff6+
12740      &       6.0d0*pep_bb_tube)/rdiff6/rdiff
12741 C       write(iout,'(a5,i4,f12.1,3f12.5)') "TU13",i,rdiff6,enetube(i),
12742 C     &rdiff,fac
12743
12744 C now direction of gg_tube vector
12745         do j=1,3
12746         gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac/2.0d0
12747         gg_tube(j,i)=gg_tube(j,i)+vectube(j)*fac/2.0d0
12748         enddo
12749         enddo
12750 C basically thats all code now we split for side-chains (REMEMBER to sum up at the END)
12751         do i=1,nres
12752 C Lets not jump over memory as we use many times iti
12753          iti=itype(i)
12754 C lets ommit dummy atoms for now
12755          if ((iti.eq.ntyp1)
12756 C in UNRES uncomment the line below as GLY has no side-chain...
12757      &      .or.(iti.eq.10)
12758      &   ) cycle
12759           vectube(1)=c(1,i+nres)
12760           vectube(1)=mod(vectube(1),boxxsize)
12761           if (vectube(1).lt.0) vectube(1)=vectube(1)+boxxsize
12762           vectube(2)=c(2,i+nres)
12763           vectube(2)=mod(vectube(2),boxxsize)
12764           if (vectube(2).lt.0) vectube(2)=vectube(2)+boxxsize
12765
12766       vectube(1)=vectube(1)-tubecenter(1)
12767       vectube(2)=vectube(2)-tubecenter(2)
12768 C THIS FRAGMENT MAKES TUBE FINITE
12769         positi=(mod(c(3,i+nres),boxzsize))
12770         if (positi.le.0) positi=positi+boxzsize
12771 C       print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop
12772 c for each residue check if it is in lipid or lipid water border area
12773 C       respos=mod(c(3,i+nres),boxzsize)
12774        print *,positi,bordtubebot,buftubebot,bordtubetop
12775        if ((positi.gt.bordtubebot)
12776      & .and.(positi.lt.bordtubetop)) then
12777 C the energy transfer exist
12778         if (positi.lt.buftubebot) then
12779          fracinbuf=1.0d0-
12780      &     ((positi-bordtubebot)/tubebufthick)
12781 C lipbufthick is thickenes of lipid buffore
12782          sstube=sscalelip(fracinbuf)
12783          ssgradtube=-sscagradlip(fracinbuf)/tubebufthick
12784          print *,ssgradtube, sstube,tubetranene(itype(i))
12785          enetube(i+nres)=enetube(i+nres)+sstube*tubetranene(itype(i))
12786          gg_tube_SC(3,i)=gg_tube_SC(3,i)
12787      &+ssgradtube*tubetranene(itype(i))
12788          gg_tube(3,i-1)= gg_tube(3,i-1)
12789      &+ssgradtube*tubetranene(itype(i))
12790 C         print *,"doing sccale for lower part"
12791         elseif (positi.gt.buftubetop) then
12792          fracinbuf=1.0d0-
12793      &((bordtubetop-positi)/tubebufthick)
12794          sstube=sscalelip(fracinbuf)
12795          ssgradtube=sscagradlip(fracinbuf)/tubebufthick
12796          enetube(i+nres)=enetube(i+nres)+sstube*tubetranene(itype(i))
12797 C         gg_tube_SC(3,i)=gg_tube_SC(3,i)
12798 C     &+ssgradtube*tubetranene(itype(i))
12799 C         gg_tube(3,i-1)= gg_tube(3,i-1)
12800 C     &+ssgradtube*tubetranene(itype(i))
12801 C          print *, "doing sscalefor top part",sslip,fracinbuf
12802         else
12803          sstube=1.0d0
12804          ssgradtube=0.0d0
12805          enetube(i+nres)=enetube(i+nres)+sstube*tubetranene(itype(i))
12806 C         print *,"I am in true lipid"
12807         endif
12808         else
12809 C          sstube=0.0d0
12810 C          ssgradtube=0.0d0
12811         cycle
12812         endif ! if in lipid or buffor
12813 CEND OF FINITE FRAGMENT
12814 C as the tube is infinity we do not calculate the Z-vector use of Z
12815 C as chosen axis
12816       vectube(3)=0.0d0
12817 C now calculte the distance
12818        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
12819 C now normalize vector
12820       vectube(1)=vectube(1)/tub_r
12821       vectube(2)=vectube(2)/tub_r
12822 C calculte rdiffrence between r and r0
12823       rdiff=tub_r-tubeR0
12824 C and its 6 power
12825       rdiff6=rdiff**6.0d0
12826 C for vectorization reasons we will sumup at the end to avoid depenence of previous
12827        sc_aa_tube=sc_aa_tube_par(iti)
12828        sc_bb_tube=sc_bb_tube_par(iti)
12829        enetube(i+nres)=(sc_aa_tube/rdiff6**2.0d0-sc_bb_tube/rdiff6)
12830      &                 *sstube+enetube(i+nres)
12831 C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
12832 C now we calculate gradient
12833        fac=(-12.0d0*sc_aa_tube/rdiff6**2.0d0/rdiff+
12834      &       6.0d0*sc_bb_tube/rdiff6/rdiff)*sstube
12835 C now direction of gg_tube vector
12836          do j=1,3
12837           gg_tube_SC(j,i)=gg_tube_SC(j,i)+vectube(j)*fac
12838           gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac
12839          enddo
12840          gg_tube_SC(3,i)=gg_tube_SC(3,i)
12841      &+ssgradtube*enetube(i+nres)/sstube
12842          gg_tube(3,i-1)= gg_tube(3,i-1)
12843      &+ssgradtube*enetube(i+nres)/sstube
12844
12845         enddo
12846         do i=1,2*nres
12847           Etube=Etube+enetube(i)
12848         enddo
12849 C        print *,"ETUBE", etube
12850         return
12851         end
12852 C TO DO 1) add to total energy
12853 C       2) add to gradient summation
12854 C       3) add reading parameters (AND of course oppening of PARAM file)
12855 C       4) add reading the center of tube
12856 C       5) add COMMONs
12857 C       6) add to zerograd
12858 c----------------------------------------------------------------------------
12859       subroutine e_saxs(Esaxs_constr)
12860       implicit none
12861       include 'DIMENSIONS'
12862 #ifdef MPI
12863       include "mpif.h"
12864       include "COMMON.SETUP"
12865       integer IERR
12866 #endif
12867       include 'COMMON.SBRIDGE'
12868       include 'COMMON.CHAIN'
12869       include 'COMMON.GEO'
12870       include 'COMMON.DERIV'
12871       include 'COMMON.LOCAL'
12872       include 'COMMON.INTERACT'
12873       include 'COMMON.VAR'
12874       include 'COMMON.IOUNITS'
12875 c      include 'COMMON.MD'
12876 #ifdef LANG0
12877 #ifdef FIVEDIAG
12878       include 'COMMON.LANGEVIN.lang0.5diag'
12879 #else
12880       include 'COMMON.LANGEVIN.lang0'
12881 #endif
12882 #else
12883       include 'COMMON.LANGEVIN'
12884 #endif
12885       include 'COMMON.CONTROL'
12886       include 'COMMON.SAXS'
12887       include 'COMMON.NAMES'
12888       include 'COMMON.TIME1'
12889       include 'COMMON.FFIELD'
12890 c
12891       double precision Esaxs_constr
12892       integer i,iint,j,k,l
12893       double precision PgradC(maxSAXS,3,maxres),
12894      &  PgradX(maxSAXS,3,maxres),Pcalc(maxSAXS)
12895 #ifdef MPI
12896       double precision PgradC_(maxSAXS,3,maxres),
12897      &  PgradX_(maxSAXS,3,maxres),Pcalc_(maxSAXS)
12898 #endif
12899       double precision dk,dijCACA,dijCASC,dijSCCA,dijSCSC,
12900      & sigma2CACA,sigma2CASC,sigma2SCCA,sigma2SCSC,expCACA,expCASC,
12901      & expSCCA,expSCSC,CASCgrad,SCCAgrad,SCSCgrad,aux,auxC,auxC1,
12902      & auxX,auxX1,CACAgrad,Cnorm,sigmaCACA,threesig
12903       double precision sss2,ssgrad2,rrr,sscalgrad2,sscale2
12904       double precision dist,mygauss,mygaussder
12905       external dist
12906       integer llicz,lllicz
12907       double precision time01
12908 c  SAXS restraint penalty function
12909 #ifdef DEBUG
12910       write(iout,*) "------- SAXS penalty function start -------"
12911       write (iout,*) "nsaxs",nsaxs
12912       write (iout,*) "Esaxs: iatsc_s",iatsc_s," iatsc_e",iatsc_e
12913       write (iout,*) "Psaxs"
12914       do i=1,nsaxs
12915         write (iout,'(i5,e15.5)') i, Psaxs(i)
12916       enddo
12917 #endif
12918 #ifdef TIMING
12919       time01=MPI_Wtime()
12920 #endif
12921       Esaxs_constr = 0.0d0
12922       do k=1,nsaxs
12923         Pcalc(k)=0.0d0
12924         do j=1,nres
12925           do l=1,3
12926             PgradC(k,l,j)=0.0d0
12927             PgradX(k,l,j)=0.0d0
12928           enddo
12929         enddo
12930       enddo
12931 c      lllicz=0
12932       do i=iatsc_s,iatsc_e
12933        if (itype(i).eq.ntyp1) cycle
12934        do iint=1,nint_gr(i)
12935          do j=istart(i,iint),iend(i,iint)
12936            if (itype(j).eq.ntyp1) cycle
12937 #ifdef ALLSAXS
12938            dijCACA=dist(i,j)
12939            dijCASC=dist(i,j+nres)
12940            dijSCCA=dist(i+nres,j)
12941            dijSCSC=dist(i+nres,j+nres)
12942            sigma2CACA=2.0d0/(pstok**2)
12943            sigma2CASC=4.0d0/(pstok**2+restok(itype(j))**2)
12944            sigma2SCCA=4.0d0/(pstok**2+restok(itype(i))**2)
12945            sigma2SCSC=4.0d0/(restok(itype(j))**2+restok(itype(i))**2)
12946            do k=1,nsaxs
12947              dk = distsaxs(k)
12948              expCACA = dexp(-0.5d0*sigma2CACA*(dijCACA-dk)**2)
12949              if (itype(j).ne.10) then
12950              expCASC = dexp(-0.5d0*sigma2CASC*(dijCASC-dk)**2)
12951              else
12952              endif
12953              expCASC = 0.0d0
12954              if (itype(i).ne.10) then
12955              expSCCA = dexp(-0.5d0*sigma2SCCA*(dijSCCA-dk)**2)
12956              else
12957              expSCCA = 0.0d0
12958              endif
12959              if (itype(i).ne.10 .and. itype(j).ne.10) then
12960              expSCSC = dexp(-0.5d0*sigma2SCSC*(dijSCSC-dk)**2)
12961              else
12962              expSCSC = 0.0d0
12963              endif
12964              Pcalc(k) = Pcalc(k)+expCACA+expCASC+expSCCA+expSCSC
12965 #ifdef DEBUG
12966              write(iout,*) "i j k Pcalc",i,j,Pcalc(k)
12967 #endif
12968              CACAgrad = sigma2CACA*(dijCACA-dk)*expCACA
12969              CASCgrad = sigma2CASC*(dijCASC-dk)*expCASC
12970              SCCAgrad = sigma2SCCA*(dijSCCA-dk)*expSCCA
12971              SCSCgrad = sigma2SCSC*(dijSCSC-dk)*expSCSC
12972              do l=1,3
12973 c CA CA
12974                aux = CACAgrad*(C(l,j)-C(l,i))/dijCACA
12975                PgradC(k,l,i) = PgradC(k,l,i)-aux
12976                PgradC(k,l,j) = PgradC(k,l,j)+aux
12977 c CA SC
12978                if (itype(j).ne.10) then
12979                aux = CASCgrad*(C(l,j+nres)-C(l,i))/dijCASC
12980                PgradC(k,l,i) = PgradC(k,l,i)-aux
12981                PgradC(k,l,j) = PgradC(k,l,j)+aux
12982                PgradX(k,l,j) = PgradX(k,l,j)+aux
12983                endif
12984 c SC CA
12985                if (itype(i).ne.10) then
12986                aux = SCCAgrad*(C(l,j)-C(l,i+nres))/dijSCCA
12987                PgradX(k,l,i) = PgradX(k,l,i)-aux
12988                PgradC(k,l,i) = PgradC(k,l,i)-aux
12989                PgradC(k,l,j) = PgradC(k,l,j)+aux
12990                endif
12991 c SC SC
12992                if (itype(i).ne.10 .and. itype(j).ne.10) then
12993                aux = SCSCgrad*(C(l,j+nres)-C(l,i+nres))/dijSCSC
12994                PgradC(k,l,i) = PgradC(k,l,i)-aux
12995                PgradC(k,l,j) = PgradC(k,l,j)+aux
12996                PgradX(k,l,i) = PgradX(k,l,i)-aux
12997                PgradX(k,l,j) = PgradX(k,l,j)+aux
12998                endif
12999              enddo ! l
13000            enddo ! k
13001 #else
13002            dijCACA=dist(i,j)
13003            sigma2CACA=scal_rad**2*0.25d0/
13004      &        (restok(itype(j))**2+restok(itype(i))**2)
13005 c           write (iout,*) "scal_rad",scal_rad," restok",restok(itype(j))
13006 c     &       ,restok(itype(i)),"sigma",1.0d0/dsqrt(sigma2CACA)
13007 #ifdef MYGAUSS
13008            sigmaCACA=dsqrt(sigma2CACA)
13009            threesig=3.0d0/sigmaCACA
13010 c           llicz=0
13011            do k=1,nsaxs
13012              dk = distsaxs(k)
13013              if (dabs(dijCACA-dk).ge.threesig) cycle
13014 c             llicz=llicz+1
13015 c             lllicz=lllicz+1
13016              aux = sigmaCACA*(dijCACA-dk)
13017              expCACA = mygauss(aux)
13018 c             if (expcaca.eq.0.0d0) cycle
13019              Pcalc(k) = Pcalc(k)+expCACA
13020              CACAgrad = -sigmaCACA*mygaussder(aux)
13021 c             write (iout,*) "i,j,k,aux",i,j,k,CACAgrad
13022              do l=1,3
13023                aux = CACAgrad*(C(l,j)-C(l,i))/dijCACA
13024                PgradC(k,l,i) = PgradC(k,l,i)-aux
13025                PgradC(k,l,j) = PgradC(k,l,j)+aux
13026              enddo ! l
13027            enddo ! k
13028 c           write (iout,*) "i",i," j",j," llicz",llicz
13029 #else
13030            IF (saxs_cutoff.eq.0) THEN
13031            do k=1,nsaxs
13032              dk = distsaxs(k)
13033              expCACA = dexp(-0.5d0*sigma2CACA*(dijCACA-dk)**2)
13034              Pcalc(k) = Pcalc(k)+expCACA
13035              CACAgrad = sigma2CACA*(dijCACA-dk)*expCACA
13036              do l=1,3
13037                aux = CACAgrad*(C(l,j)-C(l,i))/dijCACA
13038                PgradC(k,l,i) = PgradC(k,l,i)-aux
13039                PgradC(k,l,j) = PgradC(k,l,j)+aux
13040              enddo ! l
13041            enddo ! k
13042            ELSE
13043            rrr = saxs_cutoff*2.0d0/dsqrt(sigma2CACA)
13044            do k=1,nsaxs
13045              dk = distsaxs(k)
13046 c             write (2,*) "ijk",i,j,k
13047              sss2 = sscale2(dijCACA,rrr,dk,0.3d0)
13048              if (sss2.eq.0.0d0) cycle
13049              ssgrad2 = sscalgrad2(dijCACA,rrr,dk,0.3d0)
13050              if (energy_dec) write(iout,'(a4,3i5,8f10.4)')
13051      &          'saxs',i,j,k,dijCACA,restok(itype(i)),restok(itype(j)),
13052      &          1.0d0/dsqrt(sigma2CACA),rrr,dk,
13053      &           sss2,ssgrad2
13054              expCACA = dexp(-0.5d0*sigma2CACA*(dijCACA-dk)**2)*sss2
13055              Pcalc(k) = Pcalc(k)+expCACA
13056 #ifdef DEBUG
13057              write(iout,*) "i j k Pcalc",i,j,Pcalc(k)
13058 #endif
13059              CACAgrad = -sigma2CACA*(dijCACA-dk)*expCACA+
13060      &             ssgrad2*expCACA/sss2
13061              do l=1,3
13062 c CA CA
13063                aux = CACAgrad*(C(l,j)-C(l,i))/dijCACA
13064                PgradC(k,l,i) = PgradC(k,l,i)+aux
13065                PgradC(k,l,j) = PgradC(k,l,j)-aux
13066              enddo ! l
13067            enddo ! k
13068            ENDIF
13069 #endif
13070 #endif
13071          enddo ! j
13072        enddo ! iint
13073       enddo ! i
13074 c#ifdef TIMING
13075 c      time_SAXS=time_SAXS+MPI_Wtime()-time01
13076 c#endif
13077 c      write (iout,*) "lllicz",lllicz
13078 c#ifdef TIMING
13079 c      time01=MPI_Wtime()
13080 c#endif
13081 #ifdef MPI
13082       if (nfgtasks.gt.1) then
13083        call MPI_AllReduce(Pcalc(1),Pcalc_(1),nsaxs,MPI_DOUBLE_PRECISION,
13084      &    MPI_SUM,FG_COMM,IERR)
13085 c        if (fg_rank.eq.king) then
13086           do k=1,nsaxs
13087             Pcalc(k) = Pcalc_(k)
13088           enddo
13089 c        endif
13090 c        call MPI_AllReduce(PgradC(k,1,1),PgradC_(k,1,1),3*maxsaxs*nres,
13091 c     &    MPI_DOUBLE_PRECISION,MPI_SUM,FG_COMM,IERR)
13092 c        if (fg_rank.eq.king) then
13093 c          do i=1,nres
13094 c            do l=1,3
13095 c              do k=1,nsaxs
13096 c                PgradC(k,l,i) = PgradC_(k,l,i)
13097 c              enddo
13098 c            enddo
13099 c          enddo
13100 c        endif
13101 #ifdef ALLSAXS
13102 c        call MPI_AllReduce(PgradX(k,1,1),PgradX_(k,1,1),3*maxsaxs*nres,
13103 c     &    MPI_DOUBLE_PRECISION,MPI_SUM,FG_COMM,IERR)
13104 c        if (fg_rank.eq.king) then
13105 c          do i=1,nres
13106 c            do l=1,3
13107 c              do k=1,nsaxs
13108 c                PgradX(k,l,i) = PgradX_(k,l,i)
13109 c              enddo
13110 c            enddo
13111 c          enddo
13112 c        endif
13113 #endif
13114       endif
13115 #endif
13116       Cnorm = 0.0d0
13117       do k=1,nsaxs
13118         Cnorm = Cnorm + Pcalc(k)
13119       enddo
13120 #ifdef MPI
13121       if (fg_rank.eq.king) then
13122 #endif
13123       Esaxs_constr = dlog(Cnorm)-wsaxs0
13124       do k=1,nsaxs
13125         if (Pcalc(k).gt.0.0d0)
13126      &  Esaxs_constr = Esaxs_constr - Psaxs(k)*dlog(Pcalc(k))
13127 #ifdef DEBUG
13128         write (iout,*) "k",k," Esaxs_constr",Esaxs_constr
13129 #endif
13130       enddo
13131 #ifdef DEBUG
13132       write (iout,*) "Cnorm",Cnorm," Esaxs_constr",Esaxs_constr
13133 #endif
13134 #ifdef MPI
13135       endif
13136 #endif
13137       gsaxsC=0.0d0
13138       gsaxsX=0.0d0
13139       do i=nnt,nct
13140         do l=1,3
13141           auxC=0.0d0
13142           auxC1=0.0d0
13143           auxX=0.0d0
13144           auxX1=0.d0
13145           do k=1,nsaxs
13146             if (Pcalc(k).gt.0)
13147      &      auxC  = auxC +Psaxs(k)*PgradC(k,l,i)/Pcalc(k)
13148             auxC1 = auxC1+PgradC(k,l,i)
13149 #ifdef ALLSAXS
13150             auxX  = auxX +Psaxs(k)*PgradX(k,l,i)/Pcalc(k)
13151             auxX1 = auxX1+PgradX(k,l,i)
13152 #endif
13153           enddo
13154           gsaxsC(l,i) = auxC - auxC1/Cnorm
13155 #ifdef ALLSAXS
13156           gsaxsX(l,i) = auxX - auxX1/Cnorm
13157 #endif
13158 c          write (iout,*) "l i",l,i," gradC",wsaxs*(auxC - auxC1/Cnorm),
13159 c     *     " gradX",wsaxs*(auxX - auxX1/Cnorm)
13160 c          write (iout,*) "l i",l,i," gradC",wsaxs*gsaxsC(l,i),
13161 c     *     " gradX",wsaxs*gsaxsX(l,i)
13162         enddo
13163       enddo
13164 #ifdef TIMING
13165       time_SAXS=time_SAXS+MPI_Wtime()-time01
13166 #endif
13167 #ifdef DEBUG
13168       write (iout,*) "gsaxsc"
13169       do i=nnt,nct
13170         write (iout,'(i5,3e15.5)') i,(gsaxsc(j,i),j=1,3)
13171       enddo
13172 #endif
13173 #ifdef MPI
13174 c      endif
13175 #endif
13176       return
13177       end
13178 c----------------------------------------------------------------------------
13179       subroutine e_saxsC(Esaxs_constr)
13180       implicit none
13181       include 'DIMENSIONS'
13182 #ifdef MPI
13183       include "mpif.h"
13184       include "COMMON.SETUP"
13185       integer IERR
13186 #endif
13187       include 'COMMON.SBRIDGE'
13188       include 'COMMON.CHAIN'
13189       include 'COMMON.GEO'
13190       include 'COMMON.DERIV'
13191       include 'COMMON.LOCAL'
13192       include 'COMMON.INTERACT'
13193       include 'COMMON.VAR'
13194       include 'COMMON.IOUNITS'
13195 c      include 'COMMON.MD'
13196 #ifdef LANG0
13197 #ifdef FIVEDIAG
13198       include 'COMMON.LANGEVIN.lang0.5diag'
13199 #else
13200       include 'COMMON.LANGEVIN.lang0'
13201 #endif
13202 #else
13203       include 'COMMON.LANGEVIN'
13204 #endif
13205       include 'COMMON.CONTROL'
13206       include 'COMMON.SAXS'
13207       include 'COMMON.NAMES'
13208       include 'COMMON.TIME1'
13209       include 'COMMON.FFIELD'
13210 c
13211       double precision Esaxs_constr
13212       integer i,iint,j,k,l
13213       double precision PgradC(3,maxres),PgradX(3,maxres),Pcalc,logPtot
13214 #ifdef MPI
13215       double precision gsaxsc_(3,maxres),gsaxsx_(3,maxres),logPtot_
13216 #endif
13217       double precision dk,dijCASPH,dijSCSPH,
13218      & sigma2CA,sigma2SC,expCASPH,expSCSPH,
13219      & CASPHgrad,SCSPHgrad,aux,auxC,auxC1,
13220      & auxX,auxX1,Cnorm
13221 c  SAXS restraint penalty function
13222 #ifdef DEBUG
13223       write(iout,*) "------- SAXS penalty function start -------"
13224       write (iout,*) "nsaxs",nsaxs
13225
13226       do i=nnt,nct
13227         print *,MyRank,"C",i,(C(j,i),j=1,3)
13228       enddo
13229       do i=nnt,nct
13230         print *,MyRank,"CSaxs",i,(Csaxs(j,i),j=1,3)
13231       enddo
13232 #endif
13233       Esaxs_constr = 0.0d0
13234       logPtot=0.0d0
13235       do j=isaxs_start,isaxs_end
13236         Pcalc=0.0d0
13237         do i=1,nres
13238           do l=1,3
13239             PgradC(l,i)=0.0d0
13240             PgradX(l,i)=0.0d0
13241           enddo
13242         enddo
13243         do i=nnt,nct
13244           if (itype(i).eq.ntyp1) cycle
13245           dijCASPH=0.0d0
13246           dijSCSPH=0.0d0
13247           do l=1,3
13248             dijCASPH=dijCASPH+(C(l,i)-Csaxs(l,j))**2
13249           enddo
13250           if (itype(i).ne.10) then
13251           do l=1,3
13252             dijSCSPH=dijSCSPH+(C(l,i+nres)-Csaxs(l,j))**2
13253           enddo
13254           endif
13255           sigma2CA=2.0d0/pstok**2
13256           sigma2SC=4.0d0/restok(itype(i))**2
13257           expCASPH = dexp(-0.5d0*sigma2CA*dijCASPH)
13258           expSCSPH = dexp(-0.5d0*sigma2SC*dijSCSPH)
13259           Pcalc = Pcalc+expCASPH+expSCSPH
13260 #ifdef DEBUG
13261           write(*,*) "processor i j Pcalc",
13262      &       MyRank,i,j,dijCASPH,dijSCSPH, Pcalc
13263 #endif
13264           CASPHgrad = sigma2CA*expCASPH
13265           SCSPHgrad = sigma2SC*expSCSPH
13266           do l=1,3
13267             aux = (C(l,i+nres)-Csaxs(l,j))*SCSPHgrad
13268             PgradX(l,i) = PgradX(l,i) + aux
13269             PgradC(l,i) = PgradC(l,i)+(C(l,i)-Csaxs(l,j))*CASPHgrad+aux
13270           enddo ! l
13271         enddo ! i
13272         do i=nnt,nct
13273           do l=1,3
13274             gsaxsc(l,i)=gsaxsc(l,i)+PgradC(l,i)/Pcalc
13275             gsaxsx(l,i)=gsaxsx(l,i)+PgradX(l,i)/Pcalc
13276           enddo
13277         enddo
13278         logPtot = logPtot - dlog(Pcalc)
13279 c        print *,"me",me,MyRank," j",j," logPcalc",-dlog(Pcalc),
13280 c     &    " logPtot",logPtot
13281       enddo ! j
13282 #ifdef MPI
13283       if (nfgtasks.gt.1) then
13284 c        write (iout,*) "logPtot before reduction",logPtot
13285         call MPI_Reduce(logPtot,logPtot_,1,MPI_DOUBLE_PRECISION,
13286      &    MPI_SUM,king,FG_COMM,IERR)
13287         logPtot = logPtot_
13288 c        write (iout,*) "logPtot after reduction",logPtot
13289         call MPI_Reduce(gsaxsC(1,1),gsaxsC_(1,1),3*nres,
13290      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
13291         if (fg_rank.eq.king) then
13292           do i=1,nres
13293             do l=1,3
13294               gsaxsC(l,i) = gsaxsC_(l,i)
13295             enddo
13296           enddo
13297         endif
13298         call MPI_Reduce(gsaxsX(1,1),gsaxsX_(1,1),3*nres,
13299      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
13300         if (fg_rank.eq.king) then
13301           do i=1,nres
13302             do l=1,3
13303               gsaxsX(l,i) = gsaxsX_(l,i)
13304             enddo
13305           enddo
13306         endif
13307       endif
13308 #endif
13309       Esaxs_constr = logPtot
13310       return
13311       end
13312 c----------------------------------------------------------------------------
13313       double precision function sscale2(r,r_cut,r0,rlamb)
13314       implicit none
13315       double precision r,gamm,r_cut,r0,rlamb,rr
13316       rr = dabs(r-r0)
13317 c      write (2,*) "r",r," r_cut",r_cut," r0",r0," rlamb",rlamb
13318 c      write (2,*) "rr",rr
13319       if(rr.lt.r_cut-rlamb) then
13320         sscale2=1.0d0
13321       else if(rr.le.r_cut.and.rr.ge.r_cut-rlamb) then
13322         gamm=(rr-(r_cut-rlamb))/rlamb
13323         sscale2=1.0d0+gamm*gamm*(2*gamm-3.0d0)
13324       else
13325         sscale2=0d0
13326       endif
13327       return
13328       end
13329 C-----------------------------------------------------------------------
13330       double precision function sscalgrad2(r,r_cut,r0,rlamb)
13331       implicit none
13332       double precision r,gamm,r_cut,r0,rlamb,rr
13333       rr = dabs(r-r0)
13334       if(rr.lt.r_cut-rlamb) then
13335         sscalgrad2=0.0d0
13336       else if(rr.le.r_cut.and.rr.ge.r_cut-rlamb) then
13337         gamm=(rr-(r_cut-rlamb))/rlamb
13338         if (r.ge.r0) then
13339           sscalgrad2=gamm*(6*gamm-6.0d0)/rlamb
13340         else
13341           sscalgrad2=-gamm*(6*gamm-6.0d0)/rlamb
13342         endif
13343       else
13344         sscalgrad2=0.0d0
13345       endif
13346       return
13347       end
13348 c------------------------------------------------------------------------
13349       double precision function boxshift(x,boxsize)
13350       implicit none
13351       double precision x,boxsize
13352       double precision xtemp
13353       xtemp=dmod(x,boxsize)
13354       if (dabs(xtemp-boxsize).lt.dabs(xtemp)) then
13355         boxshift=xtemp-boxsize
13356       else if (dabs(xtemp+boxsize).lt.dabs(xtemp)) then
13357         boxshift=xtemp+boxsize
13358       else
13359         boxshift=xtemp
13360       endif
13361       return
13362       end
13363 c--------------------------------------------------------------------------
13364       subroutine closest_img(xi,yi,zi,xj,yj,zj)
13365       include 'DIMENSIONS'
13366       include 'COMMON.CHAIN'
13367       integer xshift,yshift,zshift,subchap
13368       double precision dist_init,xj_safe,yj_safe,zj_safe,
13369      & xj_temp,yj_temp,zj_temp,dist_temp
13370       xj_safe=xj
13371       yj_safe=yj
13372       zj_safe=zj
13373       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
13374       subchap=0
13375       do xshift=-1,1
13376         do yshift=-1,1
13377           do zshift=-1,1
13378             xj=xj_safe+xshift*boxxsize
13379             yj=yj_safe+yshift*boxysize
13380             zj=zj_safe+zshift*boxzsize
13381             dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
13382             if(dist_temp.lt.dist_init) then
13383               dist_init=dist_temp
13384               xj_temp=xj
13385               yj_temp=yj
13386               zj_temp=zj
13387               subchap=1
13388             endif
13389           enddo
13390         enddo
13391       enddo
13392       if (subchap.eq.1) then
13393         xj=xj_temp-xi
13394         yj=yj_temp-yi
13395         zj=zj_temp-zi
13396       else
13397         xj=xj_safe-xi
13398         yj=yj_safe-yi
13399         zj=zj_safe-zi
13400       endif
13401       return
13402       end
13403 c--------------------------------------------------------------------------
13404       subroutine to_box(xi,yi,zi)
13405       implicit none
13406       include 'DIMENSIONS'
13407       include 'COMMON.CHAIN'
13408       double precision xi,yi,zi
13409       xi=dmod(xi,boxxsize)
13410       if (xi.lt.0.0d0) xi=xi+boxxsize
13411       yi=dmod(yi,boxysize)
13412       if (yi.lt.0.0d0) yi=yi+boxysize
13413       zi=dmod(zi,boxzsize)
13414       if (zi.lt.0.0d0) zi=zi+boxzsize
13415       return
13416       end
13417 c--------------------------------------------------------------------------
13418       subroutine lipid_layer(xi,yi,zi,sslipi,ssgradlipi)
13419       implicit none
13420       include 'DIMENSIONS'
13421       include 'COMMON.IOUNITS'
13422       include 'COMMON.CHAIN'
13423       double precision xi,yi,zi,sslipi,ssgradlipi
13424       double precision fracinbuf
13425       double precision sscalelip,sscagradlip
13426 #ifdef DEBUG
13427       write (iout,*) "bordlipbot",bordlipbot," bordliptop",bordliptop
13428       write (iout,*) "buflipbot",buflipbot," lipbufthick",lipbufthick
13429       write (iout,*) "xi yi zi",xi,yi,zi
13430 #endif
13431       if ((zi.gt.bordlipbot).and.(zi.lt.bordliptop)) then
13432 C the energy transfer exist
13433         if (zi.lt.buflipbot) then
13434 C what fraction I am in
13435           fracinbuf=1.0d0-((zi-bordlipbot)/lipbufthick)
13436 C lipbufthick is thickenes of lipid buffore
13437           sslipi=sscalelip(fracinbuf)
13438           ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
13439         elseif (zi.gt.bufliptop) then
13440           fracinbuf=1.0d0-((bordliptop-zi)/lipbufthick)
13441           sslipi=sscalelip(fracinbuf)
13442           ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
13443         else
13444           sslipi=1.0d0
13445           ssgradlipi=0.0
13446         endif
13447       else
13448         sslipi=0.0d0
13449         ssgradlipi=0.0
13450       endif
13451 #ifdef DEBUG
13452       write (iout,*) "sslipi",sslipi," ssgradlipi",ssgradlipi
13453 #endif
13454       return
13455       end