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

   1       subroutine etotal(energia)
   2       implicit none
   3       include 'DIMENSIONS'
   4 #ifndef ISNAN
   5       external proc_proc
   6 #ifdef WINPGI
   7 cMS$ATTRIBUTES C ::  proc_proc
   8 #endif
   9 #endif
  10 #ifdef MPI
  11       include "mpif.h"
  12       double precision weights_(n_ene)
  13       double precision time00
  14       integer ierror,ierr
  15 #endif
  16       include 'COMMON.SETUP'
  17       include 'COMMON.IOUNITS'
  18       double precision energia(0:n_ene)
  19       include 'COMMON.LOCAL'
  20       include 'COMMON.FFIELD'
  21       include 'COMMON.DERIV'
  22       include 'COMMON.INTERACT'
  23       include 'COMMON.SBRIDGE'
  24       include 'COMMON.CHAIN'
  25       include 'COMMON.VAR'
  26 c      include 'COMMON.MD'
  27       include 'COMMON.QRESTR'
  28       include 'COMMON.CONTROL'
  29       include 'COMMON.TIME1'
  30       include 'COMMON.SPLITELE'
  31       include 'COMMON.TORCNSTR'
  32       include 'COMMON.SAXS'
  33       include 'COMMON.MD'
  34       double precision evdw,evdw1,evdw2,evdw2_14,ees,eel_loc,
  35      & eello_turn3,eello_turn4,edfadis,estr,ehpb,ebe,ethetacnstr,
  36      & escloc,etors,edihcnstr,etors_d,esccor,ecorr,ecorr5,ecorr6,eturn6,
  37      & eliptran,Eafmforce,Etube,
  38      & esaxs_constr,ehomology_constr,edfator,edfanei,edfabet
  39       integer n_corr,n_corr1
  40 #ifdef MPI
  41 c      print*,"ETOTAL Processor",fg_rank," absolute rank",myrank,
  42 c     & " nfgtasks",nfgtasks
  43       if (nfgtasks.gt.1) then
  44         time00=MPI_Wtime()
  45 C FG slaves call the following matching MPI_Bcast in ERGASTULUM
  46         if (fg_rank.eq.0) then
  47           call MPI_Bcast(0,1,MPI_INTEGER,king,FG_COMM,IERROR)
  48 c          print *,"Processor",myrank," BROADCAST iorder"
  49 C FG master sets up the WEIGHTS_ array which will be broadcast to the
  50 C FG slaves as WEIGHTS array.
  51           weights_(1)=wsc
  52           weights_(2)=wscp
  53           weights_(3)=welec
  54           weights_(4)=wcorr
  55           weights_(5)=wcorr5
  56           weights_(6)=wcorr6
  57           weights_(7)=wel_loc
  58           weights_(8)=wturn3
  59           weights_(9)=wturn4
  60           weights_(10)=wturn6
  61           weights_(11)=wang
  62           weights_(12)=wscloc
  63           weights_(13)=wtor
  64           weights_(14)=wtor_d
  65           weights_(15)=wstrain
  66           weights_(16)=wvdwpp
  67           weights_(17)=wbond
  68           weights_(18)=scal14
  69           weights_(21)=wsccor
  70           weights_(22)=wliptran
  71           weights_(25)=wtube
  72           weights_(26)=wsaxs
  73           weights_(28)=wdfa_dist
  74           weights_(29)=wdfa_tor
  75           weights_(30)=wdfa_nei
  76           weights_(31)=wdfa_beta
  77 C FG Master broadcasts the WEIGHTS_ array
  78           call MPI_Bcast(weights_(1),n_ene,
  79      &        MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
  80         else
  81 C FG slaves receive the WEIGHTS array
  82           call MPI_Bcast(weights(1),n_ene,
  83      &        MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
  84           wsc=weights(1)
  85           wscp=weights(2)
  86           welec=weights(3)
  87           wcorr=weights(4)
  88           wcorr5=weights(5)
  89           wcorr6=weights(6)
  90           wel_loc=weights(7)
  91           wturn3=weights(8)
  92           wturn4=weights(9)
  93           wturn6=weights(10)
  94           wang=weights(11)
  95           wscloc=weights(12)
  96           wtor=weights(13)
  97           wtor_d=weights(14)
  98           wstrain=weights(15)
  99           wvdwpp=weights(16)
 100           wbond=weights(17)
 101           scal14=weights(18)
 102           wsccor=weights(21)
 103           wliptran=weights(22)
 104           wtube=weights(25)
 105           wsaxs=weights(26)
 106           wdfa_dist=weights_(28)
 107           wdfa_tor=weights_(29)
 108           wdfa_nei=weights_(30)
 109           wdfa_beta=weights_(31)
 110         endif
 111         time_Bcast=time_Bcast+MPI_Wtime()-time00
 112         time_Bcastw=time_Bcastw+MPI_Wtime()-time00
 113 c        call chainbuild_cart
 114       endif
 115       if (nfgtasks.gt.1) then
 116         call MPI_Bcast(itime_mat,1,MPI_INT,king,FG_COMM,IERROR)
 117       endif
 118 c      write (iout,*) "itime_mat",itime_mat," imatupdate",imatupdate
 119       if (mod(itime_mat,imatupdate).eq.0) then
 120         call make_SCp_inter_list
 121 c        write (iout,*) "Finished make_SCp_inter_list"
 122 c        call flush(iout)
 123         call make_SCSC_inter_list
 124 c        write (iout,*) "Finished make_SCSC_inter_list"
 125 c        call flush(iout)
 126         call make_pp_inter_list
 127 c        write (iout,*) "Finished make_pp_inter_list"
 128 c        call flush(iout)
 129         call make_pp_vdw_inter_list
 130 c        write (iout,*) "Finished make_pp_vdw_inter_list"
 131 c        call flush(iout)
 132       endif
 133 c      print *,'Processor',myrank,' calling etotal ipot=',ipot
 134 c      print *,'Processor',myrank,' nnt=',nnt,' nct=',nct
 135 #else
 136 c      if (modecalc.eq.12.or.modecalc.eq.14) then
 137 c        call int_from_cart1(.false.)
 138 c      endif
 139 #endif
 140 #ifdef TIMING
 141       time00=MPI_Wtime()
 142 #endif
 143
 144 #ifndef DFA
 145       edfadis=0.0d0
 146       edfator=0.0d0
 147       edfanei=0.0d0
 148       edfabet=0.0d0
 149 #endif
 150 C
 151 C Compute the side-chain and electrostatic interaction energy
 152 C
 153 C      print *,ipot
 154       goto (101,102,103,104,105,106) ipot
 155 C Lennard-Jones potential.
 156   101 call elj(evdw)
 157 cd    print '(a)','Exit ELJ'
 158       goto 107
 159 C Lennard-Jones-Kihara potential (shifted).
 160   102 call eljk(evdw)
 161       goto 107
 162 C Berne-Pechukas potential (dilated LJ, angular dependence).
 163   103 call ebp(evdw)
 164       goto 107
 165 C Gay-Berne potential (shifted LJ, angular dependence).
 166   104 call egb(evdw)
 167 C      print *,"bylem w egb"
 168       goto 107
 169 C Gay-Berne-Vorobjev potential (shifted LJ, angular dependence).
 170   105 call egbv(evdw)
 171       goto 107
 172 C Soft-sphere potential
 173   106 call e_softsphere(evdw)
 174 C
 175 C Calculate electrostatic (H-bonding) energy of the main chain.
 176 C
 177   107 continue
 178 #ifdef DFA
 179 C     BARTEK for dfa test!
 180       if (wdfa_dist.gt.0) then
 181         call edfad(edfadis)
 182       else
 183         edfadis=0
 184       endif
 185 c      print*, 'edfad is finished!', edfadis
 186       if (wdfa_tor.gt.0) then
 187         call edfat(edfator)
 188       else
 189         edfator=0
 190       endif
 191 c      print*, 'edfat is finished!', edfator
 192       if (wdfa_nei.gt.0) then
 193         call edfan(edfanei)
 194       else
 195         edfanei=0
 196       endif
 197 c      print*, 'edfan is finished!', edfanei
 198       if (wdfa_beta.gt.0) then
 199         call edfab(edfabet)
 200       else
 201         edfabet=0
 202       endif
 203 #endif
 204 cmc
 205 cmc Sep-06: egb takes care of dynamic ss bonds too
 206 cmc
 207 c      if (dyn_ss) call dyn_set_nss
 208
 209 c      print *,"Processor",myrank," computed USCSC"
 210 #ifdef TIMING
 211       time01=MPI_Wtime()
 212 #endif
 213       call vec_and_deriv
 214 #ifdef TIMING
 215       time_vec=time_vec+MPI_Wtime()-time01
 216 #endif
 217 C Introduction of shielding effect first for each peptide group
 218 C the shielding factor is set this factor is describing how each
 219 C peptide group is shielded by side-chains
 220 C the matrix - shield_fac(i) the i index describe the ith between i and i+1
 221 C      write (iout,*) "shield_mode",shield_mode
 222       if (shield_mode.eq.1) then
 223        call set_shield_fac
 224       else if  (shield_mode.eq.2) then
 225        call set_shield_fac2
 226       endif
 227 c      print *,"Processor",myrank," left VEC_AND_DERIV"
 228       if (ipot.lt.6) then
 229 #ifdef SPLITELE
 230          if (welec.gt.0d0.or.wvdwpp.gt.0d0.or.wel_loc.gt.0d0.or.
 231      &       wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0
 232      &       .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0
 233      &       .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
 234 #else
 235          if (welec.gt.0d0.or.wel_loc.gt.0d0.or.
 236      &       wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0
 237      &       .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0
 238      &       .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
 239 #endif
 240             call eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
 241          else
 242             ees=0.0d0
 243             evdw1=0.0d0
 244             eel_loc=0.0d0
 245             eello_turn3=0.0d0
 246             eello_turn4=0.0d0
 247          endif
 248       else
 249         write (iout,*) "Soft-spheer ELEC potential"
 250 c        call eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,
 251 c     &   eello_turn4)
 252       endif
 253 c#ifdef TIMING
 254 c      time_enecalc=time_enecalc+MPI_Wtime()-time00
 255 c#endif
 256 c      print *,"Processor",myrank," computed UELEC"
 257 C
 258 C Calculate excluded-volume interaction energy between peptide groups
 259 C and side chains.
 260 C
 261       if (ipot.lt.6) then
 262        if(wscp.gt.0d0) then
 263         call escp(evdw2,evdw2_14)
 264        else
 265         evdw2=0
 266         evdw2_14=0
 267        endif
 268       else
 269 c        write (iout,*) "Soft-sphere SCP potential"
 270         call escp_soft_sphere(evdw2,evdw2_14)
 271       endif
 272 c
 273 c Calculate the bond-stretching energy
 274 c
 275       call ebond(estr)
 276 C
 277 C Calculate the disulfide-bridge and other energy and the contributions
 278 C from other distance constraints.
 279 cd      write (iout,*) 'Calling EHPB'
 280       call edis(ehpb)
 281 cd    print *,'EHPB exitted succesfully.'
 282 C
 283 C Calculate the virtual-bond-angle energy.
 284 C
 285       if (wang.gt.0d0) then
 286        if (tor_mode.eq.0) then
 287          call ebend(ebe)
 288        else
 289 C ebend kcc is Kubo cumulant clustered rigorous attemp to derive the
 290 C energy function
 291          call ebend_kcc(ebe)
 292        endif
 293       else
 294         ebe=0.0d0
 295       endif
 296       ethetacnstr=0.0d0
 297       if (with_theta_constr) call etheta_constr(ethetacnstr)
 298 c      print *,"Processor",myrank," computed UB"
 299 C
 300 C Calculate the SC local energy.
 301 C
 302 C      print *,"TU DOCHODZE?"
 303       call esc(escloc)
 304 c      print *,"Processor",myrank," computed USC"
 305 C
 306 C Calculate the virtual-bond torsional energy.
 307 C
 308 cd    print *,'nterm=',nterm
 309 C      print *,"tor",tor_mode
 310       if (wtor.gt.0.0d0) then
 311          if (tor_mode.eq.0) then
 312            call etor(etors)
 313          else
 314 C etor kcc is Kubo cumulant clustered rigorous attemp to derive the
 315 C energy function
 316            call etor_kcc(etors)
 317          endif
 318       else
 319         etors=0.0d0
 320       endif
 321       edihcnstr=0.0d0
 322       if (ndih_constr.gt.0) call etor_constr(edihcnstr)
 323 c      print *,"Processor",myrank," computed Utor"
 324       if (constr_homology.ge.1) then
 325         call e_modeller(ehomology_constr)
 326 c        print *,'iset=',iset,'me=',me,ehomology_constr,
 327 c     &  'Processor',fg_rank,' CG group',kolor,
 328 c     &  ' absolute rank',MyRank
 329       else
 330         ehomology_constr=0.0d0
 331       endif
 332 C
 333 C 6/23/01 Calculate double-torsional energy
 334 C
 335       if ((wtor_d.gt.0.0d0).and.(tor_mode.eq.0)) then
 336         call etor_d(etors_d)
 337       else
 338         etors_d=0
 339       endif
 340 c      print *,"Processor",myrank," computed Utord"
 341 C
 342 C 21/5/07 Calculate local sicdechain correlation energy
 343 C
 344       if (wsccor.gt.0.0d0) then
 345         call eback_sc_corr(esccor)
 346       else
 347         esccor=0.0d0
 348       endif
 349 #ifdef FOURBODY
 350 C      print *,"PRZED MULIt"
 351 c      print *,"Processor",myrank," computed Usccorr"
 352 C
 353 C 12/1/95 Multi-body terms
 354 C
 355       n_corr=0
 356       n_corr1=0
 357       if ((wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0
 358      &    .or. wturn6.gt.0.0d0) .and. ipot.lt.6) then
 359          call multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1)
 360 c         write(2,*)'MULTIBODY_EELLO n_corr=',n_corr,' n_corr1=',n_corr1,
 361 c     &" ecorr",ecorr," ecorr5",ecorr5," ecorr6",ecorr6," eturn6",eturn6
 362 c        call flush(iout)
 363       else
 364          ecorr=0.0d0
 365          ecorr5=0.0d0
 366          ecorr6=0.0d0
 367          eturn6=0.0d0
 368       endif
 369       if ((wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) .and. ipot.lt.6) then
 370 c         write (iout,*) "Before MULTIBODY_HB ecorr",ecorr,ecorr5,ecorr6,
 371 c     &     n_corr,n_corr1
 372 c         call flush(iout)
 373          call multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
 374 c         write (iout,*) "MULTIBODY_HB ecorr",ecorr,ecorr5,ecorr6,n_corr,
 375 c     &     n_corr1
 376 c         call flush(iout)
 377       else
 378          ecorr=0.0d0
 379          ecorr5=0.0d0
 380          ecorr6=0.0d0
 381          eturn6=0.0d0
 382       endif
 383 #else
 384       ecorr=0.0d0
 385       ecorr5=0.0d0
 386       ecorr6=0.0d0
 387       eturn6=0.0d0
 388 #endif
 389 c      print *,"Processor",myrank," computed Ucorr"
 390 c      write (iout,*) "nsaxs",nsaxs," saxs_mode",saxs_mode
 391       if (nsaxs.gt.0 .and. saxs_mode.eq.0) then
 392         call e_saxs(Esaxs_constr)
 393 c        write (iout,*) "From Esaxs: Esaxs_constr",Esaxs_constr
 394       else if (nsaxs.gt.0 .and. saxs_mode.gt.0) then
 395         call e_saxsC(Esaxs_constr)
 396 c        write (iout,*) "From EsaxsC: Esaxs_constr",Esaxs_constr
 397       else
 398         Esaxs_constr = 0.0d0
 399       endif
 400 C
 401 C If performing constraint dynamics, call the constraint energy
 402 C  after the equilibration time
 403 c      if(usampl.and.totT.gt.eq_time) then
 404 c      write (iout,*) "usampl",usampl
 405       if(usampl) then
 406          call EconstrQ
 407          if (loc_qlike) then
 408            call Econstr_back_qlike
 409          else
 410            call Econstr_back
 411          endif
 412       else
 413          Uconst=0.0d0
 414          Uconst_back=0.0d0
 415       endif
 416 C 01/27/2015 added by adasko
 417 C the energy component below is energy transfer into lipid environment
 418 C based on partition function
 419 C      print *,"przed lipidami"
 420       if (wliptran.gt.0) then
 421         call Eliptransfer(eliptran)
 422       else
 423         eliptran=0.0d0
 424       endif
 425 C      print *,"za lipidami"
 426       if (AFMlog.gt.0) then
 427         call AFMforce(Eafmforce)
 428       else if (selfguide.gt.0) then
 429         call AFMvel(Eafmforce)
 430       else
 431         Eafmforce=0.0d0
 432       endif
 433       if (TUBElog.eq.1) then
 434 C      print *,"just before call"
 435         call calctube(Etube)
 436       elseif (TUBElog.eq.2) then
 437         call calctube2(Etube)
 438       else
 439         Etube=0.0d0
 440       endif
 441
 442 #ifdef TIMING
 443       time_enecalc=time_enecalc+MPI_Wtime()-time00
 444 #endif
 445 c      print *,"Processor",myrank," computed Uconstr"
 446 #ifdef TIMING
 447       time00=MPI_Wtime()
 448 #endif
 449 c
 450 C Sum the energies
 451 C
 452       energia(1)=evdw
 453 #ifdef SCP14
 454       energia(2)=evdw2-evdw2_14
 455       energia(18)=evdw2_14
 456 #else
 457       energia(2)=evdw2
 458       energia(18)=0.0d0
 459 #endif
 460 #ifdef SPLITELE
 461       energia(3)=ees
 462       energia(16)=evdw1
 463 #else
 464       energia(3)=ees+evdw1
 465       energia(16)=0.0d0
 466 #endif
 467       energia(4)=ecorr
 468       energia(5)=ecorr5
 469       energia(6)=ecorr6
 470       energia(7)=eel_loc
 471       energia(8)=eello_turn3
 472       energia(9)=eello_turn4
 473       energia(10)=eturn6
 474       energia(11)=ebe
 475       energia(12)=escloc
 476       energia(13)=etors
 477       energia(14)=etors_d
 478       energia(15)=ehpb
 479       energia(19)=edihcnstr
 480       energia(17)=estr
 481       energia(20)=Uconst+Uconst_back
 482       energia(21)=esccor
 483       energia(22)=eliptran
 484       energia(23)=Eafmforce
 485       energia(24)=ethetacnstr
 486       energia(25)=Etube
 487       energia(26)=Esaxs_constr
 488       energia(27)=ehomology_constr
 489       energia(28)=edfadis
 490       energia(29)=edfator
 491       energia(30)=edfanei
 492       energia(31)=edfabet
 493 c      write (iout,*) "esaxs_constr",energia(26)
 494 c    Here are the energies showed per procesor if the are more processors
 495 c    per molecule then we sum it up in sum_energy subroutine
 496 c      print *," Processor",myrank," calls SUM_ENERGY"
 497       call sum_energy(energia,.true.)
 498 c      write (iout,*) "After sum_energy: esaxs_constr",energia(26)
 499       if (dyn_ss) call dyn_set_nss
 500 c      print *," Processor",myrank," left SUM_ENERGY"
 501 #ifdef TIMING
 502       time_sumene=time_sumene+MPI_Wtime()-time00
 503 #endif
 504       return
 505       end
 506 c-------------------------------------------------------------------------------
 507       subroutine sum_energy(energia,reduce)
 508       implicit none
 509       include 'DIMENSIONS'
 510 #ifndef ISNAN
 511       external proc_proc
 512 #ifdef WINPGI
 513 cMS$ATTRIBUTES C ::  proc_proc
 514 #endif
 515 #endif
 516 #ifdef MPI
 517       include "mpif.h"
 518       integer ierr
 519       double precision time00
 520 #endif
 521       include 'COMMON.SETUP'
 522       include 'COMMON.IOUNITS'
 523       double precision energia(0:n_ene),enebuff(0:n_ene+1)
 524       include 'COMMON.FFIELD'
 525       include 'COMMON.DERIV'
 526       include 'COMMON.INTERACT'
 527       include 'COMMON.SBRIDGE'
 528       include 'COMMON.CHAIN'
 529       include 'COMMON.VAR'
 530       include 'COMMON.CONTROL'
 531       include 'COMMON.TIME1'
 532       logical reduce
 533       integer i
 534       double precision evdw,evdw1,evdw2,evdw2_14,ees,eel_loc,
 535      & eello_turn3,eello_turn4,edfadis,estr,ehpb,ebe,ethetacnstr,
 536      & escloc,etors,edihcnstr,etors_d,esccor,ecorr,ecorr5,ecorr6,eturn6,
 537      & eliptran,Eafmforce,Etube,
 538      & esaxs_constr,ehomology_constr,edfator,edfanei,edfabet
 539       double precision Uconst,etot
 540 #ifdef MPI
 541       if (nfgtasks.gt.1 .and. reduce) then
 542 #ifdef DEBUG
 543         write (iout,*) "energies before REDUCE"
 544         call enerprint(energia)
 545         call flush(iout)
 546 #endif
 547         do i=0,n_ene
 548           enebuff(i)=energia(i)
 549         enddo
 550         time00=MPI_Wtime()
 551         call MPI_Barrier(FG_COMM,IERR)
 552         time_barrier_e=time_barrier_e+MPI_Wtime()-time00
 553         time00=MPI_Wtime()
 554         call MPI_Reduce(enebuff(0),energia(0),n_ene+1,
 555      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 556 #ifdef DEBUG
 557         write (iout,*) "energies after REDUCE"
 558         call enerprint(energia)
 559         call flush(iout)
 560 #endif
 561         time_Reduce=time_Reduce+MPI_Wtime()-time00
 562       endif
 563       if (fg_rank.eq.0) then
 564 #endif
 565       evdw=energia(1)
 566 #ifdef SCP14
 567       evdw2=energia(2)+energia(18)
 568       evdw2_14=energia(18)
 569 #else
 570       evdw2=energia(2)
 571 #endif
 572 #ifdef SPLITELE
 573       ees=energia(3)
 574       evdw1=energia(16)
 575 #else
 576       ees=energia(3)
 577       evdw1=0.0d0
 578 #endif
 579       ecorr=energia(4)
 580       ecorr5=energia(5)
 581       ecorr6=energia(6)
 582       eel_loc=energia(7)
 583       eello_turn3=energia(8)
 584       eello_turn4=energia(9)
 585       eturn6=energia(10)
 586       ebe=energia(11)
 587       escloc=energia(12)
 588       etors=energia(13)
 589       etors_d=energia(14)
 590       ehpb=energia(15)
 591       edihcnstr=energia(19)
 592       estr=energia(17)
 593       Uconst=energia(20)
 594       esccor=energia(21)
 595       eliptran=energia(22)
 596       Eafmforce=energia(23)
 597       ethetacnstr=energia(24)
 598       Etube=energia(25)
 599       esaxs_constr=energia(26)
 600       ehomology_constr=energia(27)
 601       edfadis=energia(28)
 602       edfator=energia(29)
 603       edfanei=energia(30)
 604       edfabet=energia(31)
 605 #ifdef SPLITELE
 606       etot=wsc*evdw+wscp*evdw2+welec*ees+wvdwpp*evdw1
 607      & +wang*ebe+wtor*etors+wscloc*escloc
 608      & +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5
 609      & +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3
 610      & +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d
 611      & +wbond*estr+wumb*Uconst+wsccor*esccor+wliptran*eliptran+Eafmforce
 612      & +ethetacnstr+wtube*Etube+wsaxs*esaxs_constr+ehomology_constr
 613      & +wdfa_dist*edfadis+wdfa_tor*edfator+wdfa_nei*edfanei
 614      & +wdfa_beta*edfabet
 615 #else
 616       etot=wsc*evdw+wscp*evdw2+welec*(ees+evdw1)
 617      & +wang*ebe+wtor*etors+wscloc*escloc
 618      & +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5
 619      & +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3
 620      & +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d
 621      & +wbond*estr+wumb*Uconst+wsccor*esccor+wliptran*eliptran
 622      & +Eafmforce
 623      & +ethetacnstr+wtube*Etube+wsaxs*esaxs_constr+ehomology_constr
 624      & +wdfa_dist*edfadis+wdfa_tor*edfator+wdfa_nei*edfanei
 625      & +wdfa_beta*edfabet
 626 #endif
 627       energia(0)=etot
 628 c detecting NaNQ
 629 #ifdef ISNAN
 630 #ifdef AIX
 631       if (isnan(etot).ne.0) energia(0)=1.0d+99
 632 #else
 633       if (isnan(etot)) energia(0)=1.0d+99
 634 #endif
 635 #else
 636       i=0
 637 #ifdef WINPGI
 638       idumm=proc_proc(etot,i)
 639 #else
 640       call proc_proc(etot,i)
 641 #endif
 642       if(i.eq.1)energia(0)=1.0d+99
 643 #endif
 644 #ifdef MPI
 645       endif
 646 #endif
 647       return
 648       end
 649 c-------------------------------------------------------------------------------
 650       subroutine sum_gradient
 651       implicit none
 652       include 'DIMENSIONS'
 653 #ifndef ISNAN
 654       external proc_proc
 655 #ifdef WINPGI
 656 cMS$ATTRIBUTES C ::  proc_proc
 657 #endif
 658 #endif
 659 #ifdef MPI
 660       include 'mpif.h'
 661       integer ierror,ierr
 662       double precision time00,time01
 663 #endif
 664       double precision gradbufc(3,-1:maxres),gradbufx(3,-1:maxres),
 665      & glocbuf(4*maxres),gradbufc_sum(3,-1:maxres)
 666      & ,gloc_scbuf(3,-1:maxres)
 667       include 'COMMON.SETUP'
 668       include 'COMMON.IOUNITS'
 669       include 'COMMON.FFIELD'
 670       include 'COMMON.DERIV'
 671       include 'COMMON.INTERACT'
 672       include 'COMMON.SBRIDGE'
 673       include 'COMMON.CHAIN'
 674       include 'COMMON.VAR'
 675       include 'COMMON.CONTROL'
 676       include 'COMMON.TIME1'
 677       include 'COMMON.MAXGRAD'
 678       include 'COMMON.SCCOR'
 679 c      include 'COMMON.MD'
 680       include 'COMMON.QRESTR'
 681       integer i,j,k
 682       double precision scalar
 683       double precision gvdwc_norm,gvdwc_scp_norm,gelc_norm,gvdwpp_norm,
 684      &gradb_norm,ghpbc_norm,gradcorr_norm,gel_loc_norm,gcorr3_turn_norm,
 685      &gcorr4_turn_norm,gradcorr5_norm,gradcorr6_norm,
 686      &gcorr6_turn_norm,gsccorrc_norm,gscloc_norm,gvdwx_norm,
 687      &gradx_scp_norm,ghpbx_norm,gradxorr_norm,gsccorrx_norm,
 688      &gsclocx_norm
 689 #ifdef TIMING
 690       time01=MPI_Wtime()
 691 #endif
 692 #ifdef DEBUG
 693       write (iout,*) "sum_gradient gvdwc, gvdwx"
 694       do i=1,nres
 695         write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)')
 696      &   i,(gvdwx(j,i),j=1,3),(gvdwc(j,i),j=1,3)
 697       enddo
 698       call flush(iout)
 699 #endif
 700 #ifdef DEBUG
 701       write (iout,*) "sum_gradient gsaxsc, gsaxsx"
 702       do i=0,nres
 703         write (iout,'(i3,3e15.5,5x,3e15.5)')
 704      &   i,(gsaxsc(j,i),j=1,3),(gsaxsx(j,i),j=1,3)
 705       enddo
 706       call flush(iout)
 707 #endif
 708 #ifdef MPI
 709 C FG slaves call the following matching MPI_Bcast in ERGASTULUM
 710         if (nfgtasks.gt.1 .and. fg_rank.eq.0)
 711      &    call MPI_Bcast(1,1,MPI_INTEGER,king,FG_COMM,IERROR)
 712 #endif
 713 C
 714 C 9/29/08 AL Transform parts of gradients in site coordinates to the gradient
 715 C            in virtual-bond-vector coordinates
 716 C
 717 #ifdef DEBUG
 718 c      write (iout,*) "gel_loc gel_loc_long and gel_loc_loc"
 719 c      do i=1,nres-1
 720 c        write (iout,'(i5,3f10.5,2x,3f10.5,2x,f10.5)')
 721 c     &   i,(gel_loc(j,i),j=1,3),(gel_loc_long(j,i),j=1,3),gel_loc_loc(i)
 722 c      enddo
 723 c      write (iout,*) "gel_loc_tur3 gel_loc_turn4"
 724 c      do i=1,nres-1
 725 c        write (iout,'(i5,3f10.5,2x,f10.5)')
 726 c     &  i,(gcorr4_turn(j,i),j=1,3),gel_loc_turn4(i)
 727 c      enddo
 728       write (iout,*) "gradcorr5 gradcorr5_long gradcorr5_loc"
 729       do i=1,nres
 730         write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)')
 731      &   i,(gradcorr5(j,i),j=1,3),(gradcorr5_long(j,i),j=1,3),
 732      &   g_corr5_loc(i)
 733       enddo
 734       call flush(iout)
 735 #endif
 736 #ifdef DEBUG
 737       write (iout,*) "gsaxsc"
 738       do i=1,nres
 739         write (iout,'(i3,3f10.5)') i,(wsaxs*gsaxsc(j,i),j=1,3)
 740       enddo
 741       call flush(iout)
 742 #endif
 743 #ifdef SPLITELE
 744       do i=0,nct
 745         do j=1,3
 746           gradbufc(j,i)=wsc*gvdwc(j,i)+
 747      &                wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+
 748      &                welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+
 749      &                wel_loc*gel_loc_long(j,i)+
 750      &                wcorr*gradcorr_long(j,i)+
 751      &                wcorr5*gradcorr5_long(j,i)+
 752      &                wcorr6*gradcorr6_long(j,i)+
 753      &                wturn6*gcorr6_turn_long(j,i)+
 754      &                wstrain*ghpbc(j,i)
 755      &                +wliptran*gliptranc(j,i)
 756      &                +gradafm(j,i)
 757      &                +welec*gshieldc(j,i)
 758      &                +wcorr*gshieldc_ec(j,i)
 759      &                +wturn3*gshieldc_t3(j,i)
 760      &                +wturn4*gshieldc_t4(j,i)
 761      &                +wel_loc*gshieldc_ll(j,i)
 762      &                +wtube*gg_tube(j,i)
 763      &                +wsaxs*gsaxsc(j,i)
 764         enddo
 765       enddo
 766 #else
 767       do i=0,nct
 768         do j=1,3
 769           gradbufc(j,i)=wsc*gvdwc(j,i)+
 770      &                wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+
 771      &                welec*gelc_long(j,i)+
 772      &                wbond*gradb(j,i)+
 773      &                wel_loc*gel_loc_long(j,i)+
 774      &                wcorr*gradcorr_long(j,i)+
 775      &                wcorr5*gradcorr5_long(j,i)+
 776      &                wcorr6*gradcorr6_long(j,i)+
 777      &                wturn6*gcorr6_turn_long(j,i)+
 778      &                wstrain*ghpbc(j,i)
 779      &                +wliptran*gliptranc(j,i)
 780      &                +gradafm(j,i)
 781      &                 +welec*gshieldc(j,i)
 782      &                 +wcorr*gshieldc_ec(j,i)
 783      &                 +wturn4*gshieldc_t4(j,i)
 784      &                 +wel_loc*gshieldc_ll(j,i)
 785      &                +wtube*gg_tube(j,i)
 786      &                +wsaxs*gsaxsc(j,i)
 787         enddo
 788       enddo
 789 #endif
 790       do i=1,nct
 791         do j=1,3
 792           gradbufc(j,i)=gradbufc(j,i)+
 793      &                wdfa_dist*gdfad(j,i)+
 794      &                wdfa_tor*gdfat(j,i)+
 795      &                wdfa_nei*gdfan(j,i)+
 796      &                wdfa_beta*gdfab(j,i)
 797         enddo
 798       enddo
 799 #ifdef DEBUG
 800       write (iout,*) "gradc from gradbufc"
 801       do i=1,nres
 802         write (iout,'(i3,3f10.5)') i,(gradc(j,i,icg),j=1,3)
 803       enddo
 804       call flush(iout)
 805 #endif
 806 #ifdef MPI
 807       if (nfgtasks.gt.1) then
 808       time00=MPI_Wtime()
 809 #ifdef DEBUG
 810       write (iout,*) "gradbufc before allreduce"
 811       do i=1,nres
 812         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 813       enddo
 814       call flush(iout)
 815 #endif
 816       do i=0,nres
 817         do j=1,3
 818           gradbufc_sum(j,i)=gradbufc(j,i)
 819         enddo
 820       enddo
 821 c      call MPI_AllReduce(gradbufc(1,1),gradbufc_sum(1,1),3*nres,
 822 c     &    MPI_DOUBLE_PRECISION,MPI_SUM,FG_COMM,IERR)
 823 c      time_reduce=time_reduce+MPI_Wtime()-time00
 824 #ifdef DEBUG
 825 c      write (iout,*) "gradbufc_sum after allreduce"
 826 c      do i=1,nres
 827 c        write (iout,'(i3,3f10.5)') i,(gradbufc_sum(j,i),j=1,3)
 828 c      enddo
 829 c      call flush(iout)
 830 #endif
 831 #ifdef TIMING
 832 c      time_allreduce=time_allreduce+MPI_Wtime()-time00
 833 #endif
 834       do i=nnt,nres
 835         do k=1,3
 836           gradbufc(k,i)=0.0d0
 837         enddo
 838       enddo
 839 #ifdef DEBUG
 840       write (iout,*) "igrad_start",igrad_start," igrad_end",igrad_end
 841       write (iout,*) (i," jgrad_start",jgrad_start(i),
 842      &                  " jgrad_end  ",jgrad_end(i),
 843      &                  i=igrad_start,igrad_end)
 844 #endif
 845 c
 846 c Obsolete and inefficient code; we can make the effort O(n) and, therefore,
 847 c do not parallelize this part.
 848 c
 849 c      do i=igrad_start,igrad_end
 850 c        do j=jgrad_start(i),jgrad_end(i)
 851 c          do k=1,3
 852 c            gradbufc(k,i)=gradbufc(k,i)+gradbufc_sum(k,j)
 853 c          enddo
 854 c        enddo
 855 c      enddo
 856       do j=1,3
 857         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
 858       enddo
 859       do i=nres-2,-1,-1
 860         do j=1,3
 861           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
 862         enddo
 863       enddo
 864 #ifdef DEBUG
 865       write (iout,*) "gradbufc after summing"
 866       do i=1,nres
 867         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 868       enddo
 869       call flush(iout)
 870 #endif
 871       else
 872 #endif
 873 #ifdef DEBUG
 874       write (iout,*) "gradbufc"
 875       do i=1,nres
 876         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 877       enddo
 878       call flush(iout)
 879 #endif
 880       do i=-1,nres
 881         do j=1,3
 882           gradbufc_sum(j,i)=gradbufc(j,i)
 883           gradbufc(j,i)=0.0d0
 884         enddo
 885       enddo
 886       do j=1,3
 887         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
 888       enddo
 889       do i=nres-2,-1,-1
 890         do j=1,3
 891           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
 892         enddo
 893       enddo
 894 c      do i=nnt,nres-1
 895 c        do k=1,3
 896 c          gradbufc(k,i)=0.0d0
 897 c        enddo
 898 c        do j=i+1,nres
 899 c          do k=1,3
 900 c            gradbufc(k,i)=gradbufc(k,i)+gradbufc(k,j)
 901 c          enddo
 902 c        enddo
 903 c      enddo
 904 #ifdef DEBUG
 905       write (iout,*) "gradbufc after summing"
 906       do i=1,nres
 907         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 908       enddo
 909       call flush(iout)
 910 #endif
 911 #ifdef MPI
 912       endif
 913 #endif
 914       do k=1,3
 915         gradbufc(k,nres)=0.0d0
 916       enddo
 917       do i=-1,nct
 918         do j=1,3
 919 #ifdef SPLITELE
 920 C          print *,gradbufc(1,13)
 921 C          print *,welec*gelc(1,13)
 922 C          print *,wel_loc*gel_loc(1,13)
 923 C          print *,0.5d0*(wscp*gvdwc_scpp(1,13))
 924 C          print *,welec*gelc_long(1,13)+wvdwpp*gvdwpp(1,13)
 925 C          print *,wel_loc*gel_loc_long(1,13)
 926 C          print *,gradafm(1,13),"AFM"
 927           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+
 928      &                wel_loc*gel_loc(j,i)+
 929      &                0.5d0*(wscp*gvdwc_scpp(j,i)+
 930      &                welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+
 931      &                wel_loc*gel_loc_long(j,i)+
 932      &                wcorr*gradcorr_long(j,i)+
 933      &                wcorr5*gradcorr5_long(j,i)+
 934      &                wcorr6*gradcorr6_long(j,i)+
 935      &                wturn6*gcorr6_turn_long(j,i))+
 936      &                wbond*gradb(j,i)+
 937      &                wcorr*gradcorr(j,i)+
 938      &                wturn3*gcorr3_turn(j,i)+
 939      &                wturn4*gcorr4_turn(j,i)+
 940      &                wcorr5*gradcorr5(j,i)+
 941      &                wcorr6*gradcorr6(j,i)+
 942      &                wturn6*gcorr6_turn(j,i)+
 943      &                wsccor*gsccorc(j,i)
 944      &               +wscloc*gscloc(j,i)
 945      &               +wliptran*gliptranc(j,i)
 946      &                +gradafm(j,i)
 947      &                 +welec*gshieldc(j,i)
 948      &                 +welec*gshieldc_loc(j,i)
 949      &                 +wcorr*gshieldc_ec(j,i)
 950      &                 +wcorr*gshieldc_loc_ec(j,i)
 951      &                 +wturn3*gshieldc_t3(j,i)
 952      &                 +wturn3*gshieldc_loc_t3(j,i)
 953      &                 +wturn4*gshieldc_t4(j,i)
 954      &                 +wturn4*gshieldc_loc_t4(j,i)
 955      &                 +wel_loc*gshieldc_ll(j,i)
 956      &                 +wel_loc*gshieldc_loc_ll(j,i)
 957      &                +wtube*gg_tube(j,i)
 958
 959 #else
 960           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+
 961      &                wel_loc*gel_loc(j,i)+
 962      &                0.5d0*(wscp*gvdwc_scpp(j,i)+
 963      &                welec*gelc_long(j,i)+
 964      &                wel_loc*gel_loc_long(j,i)+
 965      &                wcorr*gcorr_long(j,i)+
 966      &                wcorr5*gradcorr5_long(j,i)+
 967      &                wcorr6*gradcorr6_long(j,i)+
 968      &                wturn6*gcorr6_turn_long(j,i))+
 969      &                wbond*gradb(j,i)+
 970      &                wcorr*gradcorr(j,i)+
 971      &                wturn3*gcorr3_turn(j,i)+
 972      &                wturn4*gcorr4_turn(j,i)+
 973      &                wcorr5*gradcorr5(j,i)+
 974      &                wcorr6*gradcorr6(j,i)+
 975      &                wturn6*gcorr6_turn(j,i)+
 976      &                wsccor*gsccorc(j,i)
 977      &               +wscloc*gscloc(j,i)
 978      &               +wliptran*gliptranc(j,i)
 979      &                +gradafm(j,i)
 980      &                 +welec*gshieldc(j,i)
 981      &                 +welec*gshieldc_loc(j,i)
 982      &                 +wcorr*gshieldc_ec(j,i)
 983      &                 +wcorr*gshieldc_loc_ec(j,i)
 984      &                 +wturn3*gshieldc_t3(j,i)
 985      &                 +wturn3*gshieldc_loc_t3(j,i)
 986      &                 +wturn4*gshieldc_t4(j,i)
 987      &                 +wturn4*gshieldc_loc_t4(j,i)
 988      &                 +wel_loc*gshieldc_ll(j,i)
 989      &                 +wel_loc*gshieldc_loc_ll(j,i)
 990      &                +wtube*gg_tube(j,i)
 991
 992
 993 #endif
 994           gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+
 995      &                  wbond*gradbx(j,i)+
 996      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
 997      &                  wsccor*gsccorx(j,i)
 998      &                 +wscloc*gsclocx(j,i)
 999      &                 +wliptran*gliptranx(j,i)
1000      &                 +welec*gshieldx(j,i)
1001      &                 +wcorr*gshieldx_ec(j,i)
1002      &                 +wturn3*gshieldx_t3(j,i)
1003      &                 +wturn4*gshieldx_t4(j,i)
1004      &                 +wel_loc*gshieldx_ll(j,i)
1005      &                 +wtube*gg_tube_sc(j,i)
1006      &                 +wsaxs*gsaxsx(j,i)
1007
1008
1009
1010         enddo
1011       enddo
1012       if (constr_homology.gt.0) then
1013         do i=1,nct
1014           do j=1,3
1015             gradc(j,i,icg)=gradc(j,i,icg)+duscdiff(j,i)
1016             gradx(j,i,icg)=gradx(j,i,icg)+duscdiffx(j,i)
1017           enddo
1018         enddo
1019       endif
1020 #ifdef DEBUG
1021       write (iout,*) "gradc gradx gloc after adding"
1022       do i=1,nres
1023         write (iout,'(i5,3f10.5,5x,3f10.5,5x,f10.5)')
1024      &   i,(gradc(j,i,icg),j=1,3),(gradx(j,i,icg),j=1,3),gloc(i,icg)
1025       enddo
1026 #endif
1027 #ifdef DEBUG
1028       write (iout,*) "gloc before adding corr"
1029       do i=1,4*nres
1030         write (iout,*) i,gloc(i,icg)
1031       enddo
1032 #endif
1033       do i=1,nres-3
1034         gloc(i,icg)=gloc(i,icg)+wcorr*gcorr_loc(i)
1035      &   +wcorr5*g_corr5_loc(i)
1036      &   +wcorr6*g_corr6_loc(i)
1037      &   +wturn4*gel_loc_turn4(i)
1038      &   +wturn3*gel_loc_turn3(i)
1039      &   +wturn6*gel_loc_turn6(i)
1040      &   +wel_loc*gel_loc_loc(i)
1041       enddo
1042 #ifdef DEBUG
1043       write (iout,*) "gloc after adding corr"
1044       do i=1,4*nres
1045         write (iout,*) i,gloc(i,icg)
1046       enddo
1047 #endif
1048 #ifdef MPI
1049       if (nfgtasks.gt.1) then
1050         do j=1,3
1051           do i=1,nres
1052             gradbufc(j,i)=gradc(j,i,icg)
1053             gradbufx(j,i)=gradx(j,i,icg)
1054           enddo
1055         enddo
1056         do i=1,4*nres
1057           glocbuf(i)=gloc(i,icg)
1058         enddo
1059 c#define DEBUG
1060 #ifdef DEBUG
1061       write (iout,*) "gloc_sc before reduce"
1062       do i=1,nres
1063        do j=1,1
1064         write (iout,*) i,j,gloc_sc(j,i,icg)
1065        enddo
1066       enddo
1067 #endif
1068 c#undef DEBUG
1069         do i=1,nres
1070          do j=1,3
1071           gloc_scbuf(j,i)=gloc_sc(j,i,icg)
1072          enddo
1073         enddo
1074         time00=MPI_Wtime()
1075         call MPI_Barrier(FG_COMM,IERR)
1076         time_barrier_g=time_barrier_g+MPI_Wtime()-time00
1077         time00=MPI_Wtime()
1078         call MPI_Reduce(gradbufc(1,1),gradc(1,1,icg),3*nres,
1079      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
1080         call MPI_Reduce(gradbufx(1,1),gradx(1,1,icg),3*nres,
1081      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
1082         call MPI_Reduce(glocbuf(1),gloc(1,icg),4*nres,
1083      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
1084         time_reduce=time_reduce+MPI_Wtime()-time00
1085         call MPI_Reduce(gloc_scbuf(1,1),gloc_sc(1,1,icg),3*nres,
1086      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
1087         time_reduce=time_reduce+MPI_Wtime()-time00
1088 #ifdef DEBUG
1089       write (iout,*) "gradc after reduce"
1090       do i=1,nres
1091        do j=1,3
1092         write (iout,*) i,j,gradc(j,i,icg)
1093        enddo
1094       enddo
1095 #endif
1096 #ifdef DEBUG
1097       write (iout,*) "gloc_sc after reduce"
1098       do i=1,nres
1099        do j=1,1
1100         write (iout,*) i,j,gloc_sc(j,i,icg)
1101        enddo
1102       enddo
1103 #endif
1104 #ifdef DEBUG
1105       write (iout,*) "gloc after reduce"
1106       do i=1,4*nres
1107         write (iout,*) i,gloc(i,icg)
1108       enddo
1109 #endif
1110       endif
1111 #endif
1112       if (gnorm_check) then
1113 c
1114 c Compute the maximum elements of the gradient
1115 c
1116       gvdwc_max=0.0d0
1117       gvdwc_scp_max=0.0d0
1118       gelc_max=0.0d0
1119       gvdwpp_max=0.0d0
1120       gradb_max=0.0d0
1121       ghpbc_max=0.0d0
1122       gradcorr_max=0.0d0
1123       gel_loc_max=0.0d0
1124       gcorr3_turn_max=0.0d0
1125       gcorr4_turn_max=0.0d0
1126       gradcorr5_max=0.0d0
1127       gradcorr6_max=0.0d0
1128       gcorr6_turn_max=0.0d0
1129       gsccorrc_max=0.0d0
1130       gscloc_max=0.0d0
1131       gvdwx_max=0.0d0
1132       gradx_scp_max=0.0d0
1133       ghpbx_max=0.0d0
1134       gradxorr_max=0.0d0
1135       gsccorrx_max=0.0d0
1136       gsclocx_max=0.0d0
1137       do i=1,nct
1138         gvdwc_norm=dsqrt(scalar(gvdwc(1,i),gvdwc(1,i)))
1139         if (gvdwc_norm.gt.gvdwc_max) gvdwc_max=gvdwc_norm
1140         gvdwc_scp_norm=dsqrt(scalar(gvdwc_scp(1,i),gvdwc_scp(1,i)))
1141         if (gvdwc_scp_norm.gt.gvdwc_scp_max)
1142      &   gvdwc_scp_max=gvdwc_scp_norm
1143         gelc_norm=dsqrt(scalar(gelc(1,i),gelc(1,i)))
1144         if (gelc_norm.gt.gelc_max) gelc_max=gelc_norm
1145         gvdwpp_norm=dsqrt(scalar(gvdwpp(1,i),gvdwpp(1,i)))
1146         if (gvdwpp_norm.gt.gvdwpp_max) gvdwpp_max=gvdwpp_norm
1147         gradb_norm=dsqrt(scalar(gradb(1,i),gradb(1,i)))
1148         if (gradb_norm.gt.gradb_max) gradb_max=gradb_norm
1149         ghpbc_norm=dsqrt(scalar(ghpbc(1,i),ghpbc(1,i)))
1150         if (ghpbc_norm.gt.ghpbc_max) ghpbc_max=ghpbc_norm
1151         gradcorr_norm=dsqrt(scalar(gradcorr(1,i),gradcorr(1,i)))
1152         if (gradcorr_norm.gt.gradcorr_max) gradcorr_max=gradcorr_norm
1153         gel_loc_norm=dsqrt(scalar(gel_loc(1,i),gel_loc(1,i)))
1154         if (gel_loc_norm.gt.gel_loc_max) gel_loc_max=gel_loc_norm
1155         gcorr3_turn_norm=dsqrt(scalar(gcorr3_turn(1,i),
1156      &    gcorr3_turn(1,i)))
1157         if (gcorr3_turn_norm.gt.gcorr3_turn_max)
1158      &    gcorr3_turn_max=gcorr3_turn_norm
1159         gcorr4_turn_norm=dsqrt(scalar(gcorr4_turn(1,i),
1160      &    gcorr4_turn(1,i)))
1161         if (gcorr4_turn_norm.gt.gcorr4_turn_max)
1162      &    gcorr4_turn_max=gcorr4_turn_norm
1163         gradcorr5_norm=dsqrt(scalar(gradcorr5(1,i),gradcorr5(1,i)))
1164         if (gradcorr5_norm.gt.gradcorr5_max)
1165      &    gradcorr5_max=gradcorr5_norm
1166         gradcorr6_norm=dsqrt(scalar(gradcorr6(1,i),gradcorr6(1,i)))
1167         if (gradcorr6_norm.gt.gradcorr6_max)gradcorr6_max=gradcorr6_norm
1168         gcorr6_turn_norm=dsqrt(scalar(gcorr6_turn(1,i),
1169      &    gcorr6_turn(1,i)))
1170         if (gcorr6_turn_norm.gt.gcorr6_turn_max)
1171      &    gcorr6_turn_max=gcorr6_turn_norm
1172         gsccorrc_norm=dsqrt(scalar(gsccorc(1,i),gsccorc(1,i)))
1173         if (gsccorrc_norm.gt.gsccorrc_max) gsccorrc_max=gsccorrc_norm
1174         gscloc_norm=dsqrt(scalar(gscloc(1,i),gscloc(1,i)))
1175         if (gscloc_norm.gt.gscloc_max) gscloc_max=gscloc_norm
1176         gvdwx_norm=dsqrt(scalar(gvdwx(1,i),gvdwx(1,i)))
1177         if (gvdwx_norm.gt.gvdwx_max) gvdwx_max=gvdwx_norm
1178         gradx_scp_norm=dsqrt(scalar(gradx_scp(1,i),gradx_scp(1,i)))
1179         if (gradx_scp_norm.gt.gradx_scp_max)
1180      &    gradx_scp_max=gradx_scp_norm
1181         ghpbx_norm=dsqrt(scalar(ghpbx(1,i),ghpbx(1,i)))
1182         if (ghpbx_norm.gt.ghpbx_max) ghpbx_max=ghpbx_norm
1183         gradxorr_norm=dsqrt(scalar(gradxorr(1,i),gradxorr(1,i)))
1184         if (gradxorr_norm.gt.gradxorr_max) gradxorr_max=gradxorr_norm
1185         gsccorrx_norm=dsqrt(scalar(gsccorx(1,i),gsccorx(1,i)))
1186         if (gsccorrx_norm.gt.gsccorrx_max) gsccorrx_max=gsccorrx_norm
1187         gsclocx_norm=dsqrt(scalar(gsclocx(1,i),gsclocx(1,i)))
1188         if (gsclocx_norm.gt.gsclocx_max) gsclocx_max=gsclocx_norm
1189       enddo
1190       if (gradout) then
1191 #if (defined AIX || defined CRAY)
1192         open(istat,file=statname,position="append")
1193 #else
1194         open(istat,file=statname,access="append")
1195 #endif
1196         write (istat,'(1h#,21f10.2)') gvdwc_max,gvdwc_scp_max,
1197      &     gelc_max,gvdwpp_max,gradb_max,ghpbc_max,
1198      &     gradcorr_max,gel_loc_max,gcorr3_turn_max,gcorr4_turn_max,
1199      &     gradcorr5_max,gradcorr6_max,gcorr6_turn_max,gsccorrc_max,
1200      &     gscloc_max,gvdwx_max,gradx_scp_max,ghpbx_max,gradxorr_max,
1201      &     gsccorrx_max,gsclocx_max
1202         close(istat)
1203         if (gvdwc_max.gt.1.0d4) then
1204           write (iout,*) "gvdwc gvdwx gradb gradbx"
1205           do i=nnt,nct
1206             write(iout,'(i5,4(3f10.2,5x))') i,(gvdwc(j,i),gvdwx(j,i),
1207      &        gradb(j,i),gradbx(j,i),j=1,3)
1208           enddo
1209           call pdbout(0.0d0,'cipiszcze',iout)
1210           call flush(iout)
1211         endif
1212       endif
1213       endif
1214 #ifdef DEBUG
1215       write (iout,*) "gradc gradx gloc"
1216       do i=1,nres
1217         write (iout,'(i5,3f10.5,5x,3f10.5,5x,f10.5)')
1218      &   i,(gradc(j,i,icg),j=1,3),(gradx(j,i,icg),j=1,3),gloc(i,icg)
1219       enddo
1220 #endif
1221 #ifdef TIMING
1222       time_sumgradient=time_sumgradient+MPI_Wtime()-time01
1223 #endif
1224       return
1225       end
1226 c-------------------------------------------------------------------------------
1227       subroutine rescale_weights(t_bath)
1228       implicit none
1229 #ifdef MPI
1230       include 'mpif.h'
1231       integer ierror
1232 #endif
1233       include 'DIMENSIONS'
1234       include 'COMMON.IOUNITS'
1235       include 'COMMON.FFIELD'
1236       include 'COMMON.SBRIDGE'
1237       include 'COMMON.CONTROL'
1238       double precision t_bath
1239       double precision facT,facT2,facT3,facT4,facT5
1240       double precision kfac /2.4d0/
1241       double precision x,x2,x3,x4,x5,licznik /1.12692801104297249644/
1242 c      facT=temp0/t_bath
1243 c      facT=2*temp0/(t_bath+temp0)
1244       if (rescale_mode.eq.0) then
1245         facT=1.0d0
1246         facT2=1.0d0
1247         facT3=1.0d0
1248         facT4=1.0d0
1249         facT5=1.0d0
1250       else if (rescale_mode.eq.1) then
1251         facT=kfac/(kfac-1.0d0+t_bath/temp0)
1252         facT2=kfac**2/(kfac**2-1.0d0+(t_bath/temp0)**2)
1253         facT3=kfac**3/(kfac**3-1.0d0+(t_bath/temp0)**3)
1254         facT4=kfac**4/(kfac**4-1.0d0+(t_bath/temp0)**4)
1255         facT5=kfac**5/(kfac**5-1.0d0+(t_bath/temp0)**5)
1256       else if (rescale_mode.eq.2) then
1257         x=t_bath/temp0
1258         x2=x*x
1259         x3=x2*x
1260         x4=x3*x
1261         x5=x4*x
1262         facT=licznik/dlog(dexp(x)+dexp(-x))
1263         facT2=licznik/dlog(dexp(x2)+dexp(-x2))
1264         facT3=licznik/dlog(dexp(x3)+dexp(-x3))
1265         facT4=licznik/dlog(dexp(x4)+dexp(-x4))
1266         facT5=licznik/dlog(dexp(x5)+dexp(-x5))
1267       else
1268         write (iout,*) "Wrong RESCALE_MODE",rescale_mode
1269         write (*,*) "Wrong RESCALE_MODE",rescale_mode
1270 #ifdef MPI
1271        call MPI_Finalize(MPI_COMM_WORLD,IERROR)
1272 #endif
1273        stop 555
1274       endif
1275       if (shield_mode.gt.0) then
1276        wscp=weights(2)*fact
1277        wsc=weights(1)*fact
1278        wvdwpp=weights(16)*fact
1279       endif
1280       welec=weights(3)*fact
1281       wcorr=weights(4)*fact3
1282       wcorr5=weights(5)*fact4
1283       wcorr6=weights(6)*fact5
1284       wel_loc=weights(7)*fact2
1285       wturn3=weights(8)*fact2
1286       wturn4=weights(9)*fact3
1287       wturn6=weights(10)*fact5
1288       wtor=weights(13)*fact
1289       wtor_d=weights(14)*fact2
1290       wsccor=weights(21)*fact
1291       if (scale_umb) wumb=t_bath/temp0
1292 c      write (iout,*) "scale_umb",scale_umb
1293 c      write (iout,*) "t_bath",t_bath," temp0",temp0," wumb",wumb
1294
1295       return
1296       end
1297 C------------------------------------------------------------------------
1298       subroutine enerprint(energia)
1299       implicit none
1300       include 'DIMENSIONS'
1301       include 'COMMON.IOUNITS'
1302       include 'COMMON.FFIELD'
1303       include 'COMMON.SBRIDGE'
1304       include 'COMMON.QRESTR'
1305       double precision energia(0:n_ene)
1306       double precision evdw,evdw1,evdw2,evdw2_14,ees,eel_loc,
1307      & eello_turn3,eello_turn4,edfadis,estr,ehpb,ebe,ethetacnstr,
1308      & escloc,etors,edihcnstr,etors_d,esccor,ecorr,ecorr5,ecorr6,
1309      & eello_turn6,
1310      & eliptran,Eafmforce,Etube,
1311      & esaxs,ehomology_constr,edfator,edfanei,edfabet,etot
1312       etot=energia(0)
1313       evdw=energia(1)
1314       evdw2=energia(2)
1315 #ifdef SCP14
1316       evdw2=energia(2)+energia(18)
1317 #else
1318       evdw2=energia(2)
1319 #endif
1320       ees=energia(3)
1321 #ifdef SPLITELE
1322       evdw1=energia(16)
1323 #endif
1324       ecorr=energia(4)
1325       ecorr5=energia(5)
1326       ecorr6=energia(6)
1327       eel_loc=energia(7)
1328       eello_turn3=energia(8)
1329       eello_turn4=energia(9)
1330       eello_turn6=energia(10)
1331       ebe=energia(11)
1332       escloc=energia(12)
1333       etors=energia(13)
1334       etors_d=energia(14)
1335       ehpb=energia(15)
1336       edihcnstr=energia(19)
1337       estr=energia(17)
1338       Uconst=energia(20)
1339       esccor=energia(21)
1340       eliptran=energia(22)
1341       Eafmforce=energia(23)
1342       ethetacnstr=energia(24)
1343       etube=energia(25)
1344       esaxs=energia(26)
1345       ehomology_constr=energia(27)
1346 C     Bartek
1347       edfadis = energia(28)
1348       edfator = energia(29)
1349       edfanei = energia(30)
1350       edfabet = energia(31)
1351 #ifdef SPLITELE
1352       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,evdw1,wvdwpp,
1353      &  estr,wbond,ebe,wang,
1354      &  escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,
1355 #ifdef FOURBODY
1356      &  ecorr,wcorr,
1357      &  ecorr5,wcorr5,ecorr6,wcorr6,
1358 #endif
1359      &  eel_loc,wel_loc,eello_turn3,wturn3,
1360      &  eello_turn4,wturn4,
1361 #ifdef FOURBODY
1362      &  eello_turn6,wturn6,
1363 #endif
1364      &  esccor,wsccor,edihcnstr,
1365      &  ethetacnstr,ebr*nss,Uconst,wumb,eliptran,wliptran,Eafmforce,
1366      &  etube,wtube,esaxs,wsaxs,ehomology_constr,
1367      &  edfadis,wdfa_dist,edfator,wdfa_tor,edfanei,wdfa_nei,
1368      &  edfabet,wdfa_beta,
1369      &  etot
1370    10 format (/'Virtual-chain energies:'//
1371      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pE16.6,' (SC-SC)'/
1372      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pE16.6,' (SC-p)'/
1373      & 'EES=   ',1pE16.6,' WEIGHT=',1pE16.6,' (p-p)'/
1374      & 'EVDWPP=',1pE16.6,' WEIGHT=',1pE16.6,' (p-p VDW)'/
1375      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pE16.6,' (stretching)'/
1376      & 'EBE=   ',1pE16.6,' WEIGHT=',1pE16.6,' (bending)'/
1377      & 'ESC=   ',1pE16.6,' WEIGHT=',1pE16.6,' (SC local)'/
1378      & 'ETORS= ',1pE16.6,' WEIGHT=',1pE16.6,' (torsional)'/
1379      & 'ETORSD=',1pE16.6,' WEIGHT=',1pE16.6,' (double torsional)'/
1380      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pE16.6,
1381      & ' (SS bridges & dist. cnstr.)'/
1382 #ifdef FOURBODY
1383      & 'ECORR4=',1pE16.6,' WEIGHT=',1pE16.6,' (multi-body)'/
1384      & 'ECORR5=',1pE16.6,' WEIGHT=',1pE16.6,' (multi-body)'/
1385      & 'ECORR6=',1pE16.6,' WEIGHT=',1pE16.6,' (multi-body)'/
1386 #endif
1387      & 'EELLO= ',1pE16.6,' WEIGHT=',1pE16.6,' (electrostatic-local)'/
1388      & 'ETURN3=',1pE16.6,' WEIGHT=',1pE16.6,' (turns, 3rd order)'/
1389      & 'ETURN4=',1pE16.6,' WEIGHT=',1pE16.6,' (turns, 4th order)'/
1390 #ifdef FOURBODY
1391      & 'ETURN6=',1pE16.6,' WEIGHT=',1pE16.6,' (turns, 6th order)'/
1392 #endif
1393      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pE16.6,' (backbone-rotamer corr)'/
1394      & 'EDIHC= ',1pE16.6,' (virtual-bond dihedral angle restraints)'/
1395      & 'ETHETC=',1pE16.6,' (virtual-bond angle restraints)'/
1396      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
1397      & 'UCONST=',1pE16.6,' WEIGHT=',1pE16.6' (umbrella restraints)'/
1398      & 'ELT=   ',1pE16.6,' WEIGHT=',1pE16.6,' (Lipid transfer)'/
1399      & 'EAFM=  ',1pE16.6,' (atomic-force microscopy)'/
1400      & 'ETUBE= ',1pE16.6,' WEIGHT=',1pE16.6,' (tube confinment)'/
1401      & 'E_SAXS=',1pE16.6,' WEIGHT=',1pE16.6,' (SAXS restraints)'/
1402      & 'H_CONS=',1pE16.6,' (Homology model constraints energy)'/
1403      & 'EDFAD= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA distance energy)'/
1404      & 'EDFAT= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA torsion energy)'/
1405      & 'EDFAN= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA NCa energy)'/
1406      & 'EDFAB= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA Beta energy)'/
1407      & 'ETOT=  ',1pE16.6,' (total)')
1408
1409 #else
1410       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,
1411      &  estr,wbond,ebe,wang,
1412      &  escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,
1413 #ifdef FOURBODY
1414      &  ecorr,wcorr,
1415      &  ecorr5,wcorr5,ecorr6,wcorr6,
1416 #endif
1417      &  eel_loc,wel_loc,eello_turn3,wturn3,
1418      &  eello_turn4,wturn4,
1419 #ifdef FOURBODY
1420      &  eello_turn6,wturn6,
1421 #endif
1422      &  esccor,wsccor,edihcnstr,
1423      &  ethetacnstr,ebr*nss,Uconst,wumb,eliptran,wliptran,Eafmforc,
1424      &  etube,wtube,esaxs,wsaxs,ehomology_constr,
1425      &  edfadis,wdfa_dist,edfator,wdfa_tor,edfanei,wdfa_nei,
1426      &  edfabet,wdfa_beta,
1427      &  etot
1428    10 format (/'Virtual-chain energies:'//
1429      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pE16.6,' (SC-SC)'/
1430      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pE16.6,' (SC-p)'/
1431      & 'EES=   ',1pE16.6,' WEIGHT=',1pE16.6,' (p-p)'/
1432      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pE16.6,' (stretching)'/
1433      & 'EBE=   ',1pE16.6,' WEIGHT=',1pE16.6,' (bending)'/
1434      & 'ESC=   ',1pE16.6,' WEIGHT=',1pE16.6,' (SC local)'/
1435      & 'ETORS= ',1pE16.6,' WEIGHT=',1pE16.6,' (torsional)'/
1436      & 'ETORSD=',1pE16.6,' WEIGHT=',1pE16.6,' (double torsional)'/
1437      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pE16.6,
1438      & ' (SS bridges & dist. restr.)'/
1439 #ifdef FOURBODY
1440      & 'ECORR4=',1pE16.6,' WEIGHT=',1pE16.6,' (multi-body)'/
1441      & 'ECORR5=',1pE16.6,' WEIGHT=',1pE16.6,' (multi-body)'/
1442      & 'ECORR6=',1pE16.6,' WEIGHT=',1pE16.6,' (multi-body)'/
1443 #endif
1444      & 'EELLO= ',1pE16.6,' WEIGHT=',1pE16.6,' (electrostatic-local)'/
1445      & 'ETURN3=',1pE16.6,' WEIGHT=',1pE16.6,' (turns, 3rd order)'/
1446      & 'ETURN4=',1pE16.6,' WEIGHT=',1pE16.6,' (turns, 4th order)'/
1447 #ifdef FOURBODY
1448      & 'ETURN6=',1pE16.6,' WEIGHT=',1pE16.6,' (turns, 6th order)'/
1449 #endif
1450      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pE16.6,' (backbone-rotamer corr)'/
1451      & 'EDIHC= ',1pE16.6,' (virtual-bond dihedral angle restraints)'/
1452      & 'ETHETC=',1pE16.6,' (virtual-bond angle restraints)'/
1453      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
1454      & 'UCONST=',1pE16.6,' WEIGHT=',1pE16.6' (umbrella restraints)'/
1455      & 'ELT=   ',1pE16.6,' WEIGHT=',1pE16.6,' (Lipid transfer)'/
1456      & 'EAFM=  ',1pE16.6,' (atomic-force microscopy)'/
1457      & 'ETUBE= ',1pE16.6,' WEIGHT=',1pE16.6,' (tube confinment)'/
1458      & 'E_SAXS=',1pE16.6,' WEIGHT=',1pE16.6,' (SAXS restraints)'/
1459      & 'H_CONS=',1pE16.6,' (Homology model constraints energy)'/
1460      & 'EDFAD= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA distance energy)'/
1461      & 'EDFAT= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA torsion energy)'/
1462      & 'EDFAN= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA NCa energy)'/
1463      & 'EDFAB= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA Beta energy)'/
1464      & 'ETOT=  ',1pE16.6,' (total)')
1465 #endif
1466       return
1467       end
1468 C-----------------------------------------------------------------------
1469       subroutine elj(evdw)
1470 C
1471 C This subroutine calculates the interaction energy of nonbonded side chains
1472 C assuming the LJ potential of interaction.
1473 C
1474       implicit none
1475       double precision accur
1476       include 'DIMENSIONS'
1477       parameter (accur=1.0d-10)
1478       include 'COMMON.GEO'
1479       include 'COMMON.VAR'
1480       include 'COMMON.LOCAL'
1481       include 'COMMON.CHAIN'
1482       include 'COMMON.DERIV'
1483       include 'COMMON.INTERACT'
1484       include 'COMMON.TORSION'
1485       include 'COMMON.SBRIDGE'
1486       include 'COMMON.NAMES'
1487       include 'COMMON.IOUNITS'
1488       include 'COMMON.SPLITELE'
1489 #ifdef FOURBODY
1490       include 'COMMON.CONTACTS'
1491       include 'COMMON.CONTMAT'
1492 #endif
1493       double precision gg(3)
1494       double precision evdw,evdwij
1495       integer i,j,k,itypi,itypj,itypi1,num_conti,iint,ikont
1496       double precision xi,yi,zi,xj,yj,zj,rij,eps0ij,fac,e1,e2,rrij,
1497      & sigij,r0ij,rcut,sqrij,sss1,sssgrad1
1498       double precision fcont,fprimcont
1499       double precision sscale,sscagrad
1500       double precision boxshift
1501 c      write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
1502       evdw=0.0D0
1503 c      do i=iatsc_s,iatsc_e
1504       do ikont=g_listscsc_start,g_listscsc_end
1505         i=newcontlisti(ikont)
1506         j=newcontlistj(ikont)
1507         itypi=iabs(itype(i))
1508         if (itypi.eq.ntyp1) cycle
1509         itypi1=iabs(itype(i+1))
1510         xi=c(1,nres+i)
1511         yi=c(2,nres+i)
1512         zi=c(3,nres+i)
1513         call to_box(xi,yi,zi)
1514 C Change 12/1/95
1515         num_conti=0
1516 C
1517 C Calculate SC interaction energy.
1518 C
1519 c        do iint=1,nint_gr(i)
1520 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
1521 cd   &                  'iend=',iend(i,iint)
1522 c          do j=istart(i,iint),iend(i,iint)
1523             itypj=iabs(itype(j))
1524             if (itypj.eq.ntyp1) cycle
1525             xj=c(1,nres+j)
1526             yj=c(2,nres+j)
1527             zj=c(3,nres+j)
1528             call to_box(xj,yj,zj)
1529             xj=boxshift(xj-xi,boxxsize)
1530             yj=boxshift(yj-yi,boxysize)
1531             zj=boxshift(zj-zi,boxzsize)
1532 C Change 12/1/95 to calculate four-body interactions
1533             rij=xj*xj+yj*yj+zj*zj
1534             rrij=1.0D0/rij
1535             sqrij=dsqrt(rij)
1536             sss1=sscale(sqrij,r_cut_int)
1537             if (sss1.eq.0.0d0) cycle
1538             sssgrad1=sscagrad(sqrij,r_cut_int)
1539
1540 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
1541             eps0ij=eps(itypi,itypj)
1542             fac=rrij**expon2
1543 C have you changed here?
1544             e1=fac*fac*aa
1545             e2=fac*bb
1546             evdwij=e1+e2
1547 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1548 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1549 cd          write (iout,'(2(a3,i3,2x),6(1pd12.4)/2(3(1pd12.4),5x)/)')
1550 cd   &        restyp(itypi),i,restyp(itypj),j,a(itypi,itypj),
1551 cd   &        bb(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,epsi,sigm,
1552 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1553             evdw=evdw+sss1*evdwij
1554 C
1555 C Calculate the components of the gradient in DC and X
1556 C
1557             fac=-rrij*(e1+evdwij)*sss1
1558      &          +evdwij*sssgrad1/sqrij/expon
1559             gg(1)=xj*fac
1560             gg(2)=yj*fac
1561             gg(3)=zj*fac
1562             do k=1,3
1563               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1564               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1565               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1566               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1567             enddo
1568 cgrad            do k=i,j-1
1569 cgrad              do l=1,3
1570 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1571 cgrad              enddo
1572 cgrad            enddo
1573 C
1574 #ifdef FOURBODY
1575 C 12/1/95, revised on 5/20/97
1576 C
1577 C Calculate the contact function. The ith column of the array JCONT will
1578 C contain the numbers of atoms that make contacts with the atom I (of numbers
1579 C greater than I). The arrays FACONT and GACONT will contain the values of
1580 C the contact function and its derivative.
1581 C
1582 C Uncomment next line, if the correlation interactions include EVDW explicitly.
1583 c           if (j.gt.i+1 .and. evdwij.le.0.0D0) then
1584 C Uncomment next line, if the correlation interactions are contact function only
1585             if (j.gt.i+1.and. eps0ij.gt.0.0D0) then
1586               rij=dsqrt(rij)
1587               sigij=sigma(itypi,itypj)
1588               r0ij=rs0(itypi,itypj)
1589 C
1590 C Check whether the SC's are not too far to make a contact.
1591 C
1592               rcut=1.5d0*r0ij
1593               call gcont(rij,rcut,1.0d0,0.2d0*rcut,fcont,fprimcont)
1594 C Add a new contact, if the SC's are close enough, but not too close (r<sigma).
1595 C
1596               if (fcont.gt.0.0D0) then
1597 C If the SC-SC distance if close to sigma, apply spline.
1598 cAdam           call gcont(-rij,-1.03d0*sigij,2.0d0*sigij,1.0d0,
1599 cAdam &             fcont1,fprimcont1)
1600 cAdam           fcont1=1.0d0-fcont1
1601 cAdam           if (fcont1.gt.0.0d0) then
1602 cAdam             fprimcont=fprimcont*fcont1+fcont*fprimcont1
1603 cAdam             fcont=fcont*fcont1
1604 cAdam           endif
1605 C Uncomment following 4 lines to have the geometric average of the epsilon0's
1606 cga             eps0ij=1.0d0/dsqrt(eps0ij)
1607 cga             do k=1,3
1608 cga               gg(k)=gg(k)*eps0ij
1609 cga             enddo
1610 cga             eps0ij=-evdwij*eps0ij
1611 C Uncomment for AL's type of SC correlation interactions.
1612 cadam           eps0ij=-evdwij
1613                 num_conti=num_conti+1
1614                 jcont(num_conti,i)=j
1615                 facont(num_conti,i)=fcont*eps0ij
1616                 fprimcont=eps0ij*fprimcont/rij
1617                 fcont=expon*fcont
1618 cAdam           gacont(1,num_conti,i)=-fprimcont*xj+fcont*gg(1)
1619 cAdam           gacont(2,num_conti,i)=-fprimcont*yj+fcont*gg(2)
1620 cAdam           gacont(3,num_conti,i)=-fprimcont*zj+fcont*gg(3)
1621 C Uncomment following 3 lines for Skolnick's type of SC correlation.
1622                 gacont(1,num_conti,i)=-fprimcont*xj
1623                 gacont(2,num_conti,i)=-fprimcont*yj
1624                 gacont(3,num_conti,i)=-fprimcont*zj
1625 cd              write (iout,'(2i5,2f10.5)') i,j,rij,facont(num_conti,i)
1626 cd              write (iout,'(2i3,3f10.5)')
1627 cd   &           i,j,(gacont(kk,num_conti,i),kk=1,3)
1628               endif
1629             endif
1630 #endif
1631 c          enddo      ! j
1632 c        enddo        ! iint
1633 C Change 12/1/95
1634 #ifdef FOURBODY
1635         num_cont(i)=num_conti
1636 #endif
1637       enddo          ! i
1638       do i=1,nct
1639         do j=1,3
1640           gvdwc(j,i)=expon*gvdwc(j,i)
1641           gvdwx(j,i)=expon*gvdwx(j,i)
1642         enddo
1643       enddo
1644 C******************************************************************************
1645 C
1646 C                              N O T E !!!
1647 C
1648 C To save time, the factor of EXPON has been extracted from ALL components
1649 C of GVDWC and GRADX. Remember to multiply them by this factor before further
1650 C use!
1651 C
1652 C******************************************************************************
1653       return
1654       end
1655 C-----------------------------------------------------------------------------
1656       subroutine eljk(evdw)
1657 C
1658 C This subroutine calculates the interaction energy of nonbonded side chains
1659 C assuming the LJK potential of interaction.
1660 C
1661       implicit none
1662       include 'DIMENSIONS'
1663       include 'COMMON.GEO'
1664       include 'COMMON.VAR'
1665       include 'COMMON.LOCAL'
1666       include 'COMMON.CHAIN'
1667       include 'COMMON.DERIV'
1668       include 'COMMON.INTERACT'
1669       include 'COMMON.IOUNITS'
1670       include 'COMMON.NAMES'
1671       include 'COMMON.SPLITELE'
1672       double precision gg(3)
1673       double precision evdw,evdwij
1674       integer i,j,k,itypi,itypj,itypi1,iint,ikont
1675       double precision xi,yi,zi,xj,yj,zj,rij,eps0ij,fac,e1,e2,rrij,
1676      & fac_augm,e_augm,r_inv_ij,r_shift_inv,sss1,sssgrad1
1677       logical scheck
1678       double precision sscale,sscagrad
1679       double precision boxshift
1680 c     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
1681       evdw=0.0D0
1682 c      do i=iatsc_s,iatsc_e
1683       do ikont=g_listscsc_start,g_listscsc_end
1684         i=newcontlisti(ikont)
1685         j=newcontlistj(ikont)
1686         itypi=iabs(itype(i))
1687         if (itypi.eq.ntyp1) cycle
1688         itypi1=iabs(itype(i+1))
1689         xi=c(1,nres+i)
1690         yi=c(2,nres+i)
1691         zi=c(3,nres+i)
1692         call to_box(xi,yi,zi)
1693 C
1694 C Calculate SC interaction energy.
1695 C
1696 c        do iint=1,nint_gr(i)
1697 c          do j=istart(i,iint),iend(i,iint)
1698             itypj=iabs(itype(j))
1699             if (itypj.eq.ntyp1) cycle
1700             xj=c(1,nres+j)
1701             yj=c(2,nres+j)
1702             zj=c(3,nres+j)
1703             call to_box(xj,yj,zj)
1704             xj=boxshift(xj-xi,boxxsize)
1705             yj=boxshift(yj-yi,boxysize)
1706             zj=boxshift(zj-zi,boxzsize)
1707             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1708             fac_augm=rrij**expon
1709             e_augm=augm(itypi,itypj)*fac_augm
1710             r_inv_ij=dsqrt(rrij)
1711             rij=1.0D0/r_inv_ij
1712             sss1=sscale(rij,r_cut_int)
1713             if (sss1.eq.0.0d0) cycle
1714             sssgrad1=sscagrad(rij,r_cut_int)
1715             r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
1716             fac=r_shift_inv**expon
1717 C have you changed here?
1718             e1=fac*fac*aa
1719             e2=fac*bb
1720             evdwij=e_augm+e1+e2
1721 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1722 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1723 cd          write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
1724 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
1725 cd   &        bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
1726 cd   &        sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
1727 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1728             evdw=evdw+evdwij*sss1
1729 C
1730 C Calculate the components of the gradient in DC and X
1731 C
1732             fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
1733      &          +evdwij*sssgrad1*r_inv_ij/expon
1734             gg(1)=xj*fac
1735             gg(2)=yj*fac
1736             gg(3)=zj*fac
1737             do k=1,3
1738               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1739               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1740               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1741               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1742             enddo
1743 cgrad            do k=i,j-1
1744 cgrad              do l=1,3
1745 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1746 cgrad              enddo
1747 cgrad            enddo
1748 c          enddo      ! j
1749 c        enddo        ! iint
1750       enddo          ! i
1751       do i=1,nct
1752         do j=1,3
1753           gvdwc(j,i)=expon*gvdwc(j,i)
1754           gvdwx(j,i)=expon*gvdwx(j,i)
1755         enddo
1756       enddo
1757       return
1758       end
1759 C-----------------------------------------------------------------------------
1760       subroutine ebp(evdw)
1761 C
1762 C This subroutine calculates the interaction energy of nonbonded side chains
1763 C assuming the Berne-Pechukas potential of interaction.
1764 C
1765       implicit none
1766       include 'DIMENSIONS'
1767       include 'COMMON.GEO'
1768       include 'COMMON.VAR'
1769       include 'COMMON.LOCAL'
1770       include 'COMMON.CHAIN'
1771       include 'COMMON.DERIV'
1772       include 'COMMON.NAMES'
1773       include 'COMMON.INTERACT'
1774       include 'COMMON.IOUNITS'
1775       include 'COMMON.CALC'
1776       include 'COMMON.SPLITELE'
1777       integer icall
1778       common /srutu/ icall
1779       double precision evdw
1780       integer itypi,itypj,itypi1,iint,ind,ikont
1781       double precision eps0ij,epsi,sigm,fac,e1,e2,rrij,xi,yi,zi,
1782      & sss1,sssgrad1
1783       double precision sscale,sscagrad
1784       double precision boxshift
1785 c     double precision rrsave(maxdim)
1786       logical lprn
1787       evdw=0.0D0
1788 c     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
1789       evdw=0.0D0
1790 c     if (icall.eq.0) then
1791 c       lprn=.true.
1792 c     else
1793         lprn=.false.
1794 c     endif
1795       ind=0
1796 c      do i=iatsc_s,iatsc_e
1797       do ikont=g_listscsc_start,g_listscsc_end
1798         i=newcontlisti(ikont)
1799         j=newcontlistj(ikont)
1800         itypi=iabs(itype(i))
1801         if (itypi.eq.ntyp1) cycle
1802         itypi1=iabs(itype(i+1))
1803         xi=c(1,nres+i)
1804         yi=c(2,nres+i)
1805         zi=c(3,nres+i)
1806         call to_box(xi,yi,zi)
1807         dxi=dc_norm(1,nres+i)
1808         dyi=dc_norm(2,nres+i)
1809         dzi=dc_norm(3,nres+i)
1810 c        dsci_inv=dsc_inv(itypi)
1811         dsci_inv=vbld_inv(i+nres)
1812 C
1813 C Calculate SC interaction energy.
1814 C
1815 c        do iint=1,nint_gr(i)
1816 c          do j=istart(i,iint),iend(i,iint)
1817             ind=ind+1
1818             itypj=iabs(itype(j))
1819             if (itypj.eq.ntyp1) cycle
1820 c            dscj_inv=dsc_inv(itypj)
1821             dscj_inv=vbld_inv(j+nres)
1822             chi1=chi(itypi,itypj)
1823             chi2=chi(itypj,itypi)
1824             chi12=chi1*chi2
1825             chip1=chip(itypi)
1826             chip2=chip(itypj)
1827             chip12=chip1*chip2
1828             alf1=alp(itypi)
1829             alf2=alp(itypj)
1830             alf12=0.5D0*(alf1+alf2)
1831 C For diagnostics only!!!
1832 c           chi1=0.0D0
1833 c           chi2=0.0D0
1834 c           chi12=0.0D0
1835 c           chip1=0.0D0
1836 c           chip2=0.0D0
1837 c           chip12=0.0D0
1838 c           alf1=0.0D0
1839 c           alf2=0.0D0
1840 c           alf12=0.0D0
1841             xj=c(1,nres+j)
1842             yj=c(2,nres+j)
1843             zj=c(3,nres+j)
1844             call to_box(xj,yj,zj)
1845             xj=boxshift(xj-xi,boxxsize)
1846             yj=boxshift(yj-yi,boxysize)
1847             zj=boxshift(zj-zi,boxzsize)
1848             dxj=dc_norm(1,nres+j)
1849             dyj=dc_norm(2,nres+j)
1850             dzj=dc_norm(3,nres+j)
1851             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1852 cd          if (icall.eq.0) then
1853 cd            rrsave(ind)=rrij
1854 cd          else
1855 cd            rrij=rrsave(ind)
1856 cd          endif
1857             rij=dsqrt(rrij)
1858             sss1=sscale(1.0d0/rij,r_cut_int)
1859             if (sss1.eq.0.0d0) cycle
1860             sssgrad1=sscagrad(1.0d0/rij,r_cut_int)
1861 C Calculate the angle-dependent terms of energy & contributions to derivatives.
1862             call sc_angular
1863 C Calculate whole angle-dependent part of epsilon and contributions
1864 C to its derivatives
1865 C have you changed here?
1866             fac=(rrij*sigsq)**expon2
1867             e1=fac*fac*aa
1868             e2=fac*bb
1869             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1870             eps2der=evdwij*eps3rt
1871             eps3der=evdwij*eps2rt
1872             evdwij=evdwij*eps2rt*eps3rt
1873             evdw=evdw+sss1*evdwij
1874             if (lprn) then
1875             sigm=dabs(aa/bb)**(1.0D0/6.0D0)
1876             epsi=bb**2/aa
1877 cd            write (iout,'(2(a3,i3,2x),15(0pf7.3))')
1878 cd     &        restyp(itypi),i,restyp(itypj),j,
1879 cd     &        epsi,sigm,chi1,chi2,chip1,chip2,
1880 cd     &        eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
1881 cd     &        om1,om2,om12,1.0D0/dsqrt(rrij),
1882 cd     &        evdwij
1883             endif
1884 C Calculate gradient components.
1885             e1=e1*eps1*eps2rt**2*eps3rt**2
1886             fac=-expon*(e1+evdwij)
1887             sigder=fac/sigsq
1888             fac=rrij*fac
1889      &          +evdwij*sssgrad1/sss1*rij
1890 C Calculate radial part of the gradient
1891             gg(1)=xj*fac
1892             gg(2)=yj*fac
1893             gg(3)=zj*fac
1894 C Calculate the angular part of the gradient and sum add the contributions
1895 C to the appropriate components of the Cartesian gradient.
1896             call sc_grad
1897 !          enddo      ! j
1898 !        enddo        ! iint
1899       enddo          ! i
1900 c     stop
1901       return
1902       end
1903 C-----------------------------------------------------------------------------
1904       subroutine egb(evdw)
1905 C
1906 C This subroutine calculates the interaction energy of nonbonded side chains
1907 C assuming the Gay-Berne potential of interaction.
1908 C
1909       implicit none
1910       include 'DIMENSIONS'
1911       include 'COMMON.GEO'
1912       include 'COMMON.VAR'
1913       include 'COMMON.LOCAL'
1914       include 'COMMON.CHAIN'
1915       include 'COMMON.DERIV'
1916       include 'COMMON.NAMES'
1917       include 'COMMON.INTERACT'
1918       include 'COMMON.IOUNITS'
1919       include 'COMMON.CALC'
1920       include 'COMMON.CONTROL'
1921       include 'COMMON.SPLITELE'
1922       include 'COMMON.SBRIDGE'
1923       logical lprn
1924       double precision evdw
1925       integer itypi,itypj,itypi1,iint,ind,ikont
1926       double precision eps0ij,epsi,sigm,fac,e1,e2,rrij,xi,yi,zi
1927       double precision fracinbuf,sslipi,evdwij_przed_tri,sig0ij,
1928      & sslipj,ssgradlipj,ssgradlipi,sig,rij_shift,faclip
1929       double precision dist,sscale,sscagrad,sscagradlip,sscalelip
1930       double precision boxshift
1931       evdw=0.0D0
1932 ccccc      energy_dec=.false.
1933 C      print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1934       evdw=0.0D0
1935       lprn=.false.
1936 c     if (icall.eq.0) lprn=.false.
1937       ind=0
1938 C the loop over all 27 posible neigbours (for xshift=0,yshift=0,zshift=0
1939 C we have the original box)
1940 C      do xshift=-1,1
1941 C      do yshift=-1,1
1942 C      do zshift=-1,1
1943 c      do i=iatsc_s,iatsc_e
1944       do ikont=g_listscsc_start,g_listscsc_end
1945         i=newcontlisti(ikont)
1946         j=newcontlistj(ikont)
1947         itypi=iabs(itype(i))
1948         if (itypi.eq.ntyp1) cycle
1949         itypi1=iabs(itype(i+1))
1950         xi=c(1,nres+i)
1951         yi=c(2,nres+i)
1952         zi=c(3,nres+i)
1953         call to_box(xi,yi,zi)
1954 C define scaling factor for lipids
1955
1956 C        if (positi.le.0) positi=positi+boxzsize
1957 C        print *,i
1958 C first for peptide groups
1959 c for each residue check if it is in lipid or lipid water border area
1960         call lipid_layer(xi,yi,zi,sslipi,ssgradlipi)
1961 C          xi=xi+xshift*boxxsize
1962 C          yi=yi+yshift*boxysize
1963 C          zi=zi+zshift*boxzsize
1964
1965         dxi=dc_norm(1,nres+i)
1966         dyi=dc_norm(2,nres+i)
1967         dzi=dc_norm(3,nres+i)
1968 c        dsci_inv=dsc_inv(itypi)
1969         dsci_inv=vbld_inv(i+nres)
1970 c        write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)
1971 c        write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi
1972 C
1973 C Calculate SC interaction energy.
1974 C
1975 c        do iint=1,nint_gr(i)
1976 c          do j=istart(i,iint),iend(i,iint)
1977             IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN
1978
1979 c              write(iout,*) "PRZED ZWYKLE", evdwij
1980               call dyn_ssbond_ene(i,j,evdwij)
1981 c              write(iout,*) "PO ZWYKLE", evdwij
1982
1983               evdw=evdw+evdwij
1984               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)')
1985      &                        'evdw',i,j,evdwij,' ss'
1986 C triple bond artifac removal
1987               do k=j+1,iend(i,iint)
1988 C search over all next residues
1989                 if (dyn_ss_mask(k)) then
1990 C check if they are cysteins
1991 C              write(iout,*) 'k=',k
1992
1993 c              write(iout,*) "PRZED TRI", evdwij
1994                   evdwij_przed_tri=evdwij
1995                   call triple_ssbond_ene(i,j,k,evdwij)
1996 c               if(evdwij_przed_tri.ne.evdwij) then
1997 c                 write (iout,*) "TRI:", evdwij, evdwij_przed_tri
1998 c               endif
1999
2000 c              write(iout,*) "PO TRI", evdwij
2001 C call the energy function that removes the artifical triple disulfide
2002 C bond the soubroutine is located in ssMD.F
2003                   evdw=evdw+evdwij
2004                   if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)')
2005      &                        'evdw',i,j,evdwij,'tss'
2006                 endif!dyn_ss_mask(k)
2007               enddo! k
2008             ELSE
2009               ind=ind+1
2010               itypj=iabs(itype(j))
2011               if (itypj.eq.ntyp1) cycle
2012 c            dscj_inv=dsc_inv(itypj)
2013               dscj_inv=vbld_inv(j+nres)
2014 c            write (iout,*) "j",j,dsc_inv(itypj),dscj_inv,
2015 c     &       1.0d0/vbld(j+nres)
2016 c            write (iout,*) "i",i," j", j," itype",itype(i),itype(j)
2017               sig0ij=sigma(itypi,itypj)
2018               chi1=chi(itypi,itypj)
2019               chi2=chi(itypj,itypi)
2020               chi12=chi1*chi2
2021               chip1=chip(itypi)
2022               chip2=chip(itypj)
2023               chip12=chip1*chip2
2024               alf1=alp(itypi)
2025               alf2=alp(itypj)
2026               alf12=0.5D0*(alf1+alf2)
2027 C For diagnostics only!!!
2028 c           chi1=0.0D0
2029 c           chi2=0.0D0
2030 c           chi12=0.0D0
2031 c           chip1=0.0D0
2032 c           chip2=0.0D0
2033 c           chip12=0.0D0
2034 c           alf1=0.0D0
2035 c           alf2=0.0D0
2036 c           alf12=0.0D0
2037               xj=c(1,nres+j)
2038               yj=c(2,nres+j)
2039               zj=c(3,nres+j)
2040               call to_box(xj,yj,zj)
2041               call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
2042               aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
2043      &          +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
2044               bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
2045      &          +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
2046 C      write(iout,*) "tu,", i,j,aa_lip(itypi,itypj),bb_lip(itypi,itypj)
2047 C      if (aa.ne.aa_aq(itypi,itypj)) write(63,'(2e10.5)')
2048 C     &(aa-aa_aq(itypi,itypj)),(bb-bb_aq(itypi,itypj))
2049 C      if (ssgradlipj.gt.0.0d0) print *,"??WTF??"
2050 C      print *,sslipi,sslipj,bordlipbot,zi,zj
2051               xj=boxshift(xj-xi,boxxsize)
2052               yj=boxshift(yj-yi,boxysize)
2053               zj=boxshift(zj-zi,boxzsize)
2054               dxj=dc_norm(1,nres+j)
2055               dyj=dc_norm(2,nres+j)
2056               dzj=dc_norm(3,nres+j)
2057 C            xj=xj-xi
2058 C            yj=yj-yi
2059 C            zj=zj-zi
2060 c            write (iout,*) "dcnorj",dxi*dxi+dyi*dyi+dzi*dzi
2061 c            write (iout,*) "j",j," dc_norm",
2062 c     &       dc_norm(1,nres+j),dc_norm(2,nres+j),dc_norm(3,nres+j)
2063               rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
2064               rij=dsqrt(rrij)
2065               sss=sscale(1.0d0/rij,r_cut_int)
2066 c            write (iout,'(a7,4f8.3)')
2067 c    &      "ssscale",sss,((1.0d0/rij)/sigma(itypi,itypj)),r_cut,rlamb
2068               if (sss.eq.0.0d0) cycle
2069               sssgrad=sscagrad(1.0d0/rij,r_cut_int)
2070 C Calculate angle-dependent terms of energy and contributions to their
2071 C derivatives.
2072               call sc_angular
2073               sigsq=1.0D0/sigsq
2074               sig=sig0ij*dsqrt(sigsq)
2075               rij_shift=1.0D0/rij-sig+sig0ij
2076 c              if (energy_dec)
2077 c     &        write (iout,*) "rij",1.0d0/rij," rij_shift",rij_shift,
2078 c     &       " sig",sig," sig0ij",sig0ij
2079 c for diagnostics; uncomment
2080 c            rij_shift=1.2*sig0ij
2081 C I hate to put IF's in the loops, but here don't have another choice!!!!
2082               if (rij_shift.le.0.0D0) then
2083                 evdw=1.0D20
2084 cd              write (iout,'(2(a3,i3,2x),17(0pf7.3))')
2085 cd     &        restyp(itypi),i,restyp(itypj),j,
2086 cd     &        rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq)
2087 c                return
2088               endif
2089               sigder=-sig*sigsq
2090 c---------------------------------------------------------------
2091               rij_shift=1.0D0/rij_shift
2092               fac=rij_shift**expon
2093 C here to start with
2094 C            if (c(i,3).gt.
2095               faclip=fac
2096               e1=fac*fac*aa
2097               e2=fac*bb
2098               evdwij=eps1*eps2rt*eps3rt*(e1+e2)
2099               eps2der=evdwij*eps3rt
2100               eps3der=evdwij*eps2rt
2101 C       write(63,'(2i3,2e10.3,2f10.5)') i,j,aa,bb, evdwij,
2102 C     &((sslipi+sslipj)/2.0d0+
2103 C     &(2.0d0-sslipi-sslipj)/2.0d0)
2104 c            write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt,
2105 c     &        " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2
2106               evdwij=evdwij*eps2rt*eps3rt
2107               evdw=evdw+evdwij*sss
2108               if (lprn) then
2109                 sigm=dabs(aa/bb)**(1.0D0/6.0D0)
2110                 epsi=bb**2/aa
2111                 write (iout,'(2(a3,i3,2x),17(0pf7.3))')
2112      &           restyp(itypi),i,restyp(itypj),j,
2113      &           epsi,sigm,chi1,chi2,chip1,chip2,
2114      &           eps1,eps2rt**2,eps3rt**2,sig,sig0ij,
2115      &           om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
2116      &           evdwij
2117               endif
2118
2119               if (energy_dec) write (iout,'(a,2i5,2f10.5,e15.5)')
2120      &                    'r sss evdw',i,j,1.0d0/rij,sss,evdwij
2121
2122 C Calculate gradient components.
2123               e1=e1*eps1*eps2rt**2*eps3rt**2
2124               fac=-expon*(e1+evdwij)*rij_shift
2125               sigder=fac*sigder
2126               fac=rij*fac
2127 c            print '(2i4,6f8.4)',i,j,sss,sssgrad*
2128 c     &      evdwij,fac,sigma(itypi,itypj),expon
2129               fac=fac+evdwij*sssgrad/sss*rij
2130 c            fac=0.0d0
2131 C Calculate the radial part of the gradient
2132               gg_lipi(3)=eps1*(eps2rt*eps2rt)
2133      &          *(eps3rt*eps3rt)*sss/2.0d0*(faclip*faclip*
2134      &           (aa_lip(itypi,itypj)-aa_aq(itypi,itypj))
2135      &          +faclip*(bb_lip(itypi,itypj)-bb_aq(itypi,itypj)))
2136               gg_lipj(3)=ssgradlipj*gg_lipi(3)
2137               gg_lipi(3)=gg_lipi(3)*ssgradlipi
2138 C            gg_lipi(3)=0.0d0
2139 C            gg_lipj(3)=0.0d0
2140               gg(1)=xj*fac
2141               gg(2)=yj*fac
2142               gg(3)=zj*fac
2143 C Calculate angular part of the gradient.
2144 c            call sc_grad_scale(sss)
2145               call sc_grad
2146             ENDIF    ! dyn_ss
2147 c          enddo      ! j
2148 c        enddo        ! iint
2149       enddo          ! i
2150 C      enddo          ! zshift
2151 C      enddo          ! yshift
2152 C      enddo          ! xshift
2153 c      write (iout,*) "Number of loop steps in EGB:",ind
2154 cccc      energy_dec=.false.
2155       return
2156       end
2157 C-----------------------------------------------------------------------------
2158       subroutine egbv(evdw)
2159 C
2160 C This subroutine calculates the interaction energy of nonbonded side chains
2161 C assuming the Gay-Berne-Vorobjev potential of interaction.
2162 C
2163       implicit none
2164       include 'DIMENSIONS'
2165       include 'COMMON.GEO'
2166       include 'COMMON.VAR'
2167       include 'COMMON.LOCAL'
2168       include 'COMMON.CHAIN'
2169       include 'COMMON.DERIV'
2170       include 'COMMON.NAMES'
2171       include 'COMMON.INTERACT'
2172       include 'COMMON.IOUNITS'
2173       include 'COMMON.CALC'
2174       include 'COMMON.SPLITELE'
2175       double precision boxshift
2176       integer icall
2177       common /srutu/ icall
2178       logical lprn
2179       double precision evdw
2180       integer itypi,itypj,itypi1,iint,ind,ikont
2181       double precision eps0ij,epsi,sigm,fac,e1,e2,rrij,r0ij,
2182      & xi,yi,zi,fac_augm,e_augm
2183       double precision fracinbuf,sslipi,evdwij_przed_tri,sig0ij,
2184      & sslipj,ssgradlipj,ssgradlipi,sig,rij_shift,faclip,sssgrad1
2185       double precision dist,sscale,sscagrad,sscagradlip,sscalelip
2186       evdw=0.0D0
2187 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
2188       evdw=0.0D0
2189       lprn=.false.
2190 c     if (icall.eq.0) lprn=.true.
2191       ind=0
2192 c      do i=iatsc_s,iatsc_e
2193       do ikont=g_listscsc_start,g_listscsc_end
2194         i=newcontlisti(ikont)
2195         j=newcontlistj(ikont)
2196         itypi=iabs(itype(i))
2197         if (itypi.eq.ntyp1) cycle
2198         itypi1=iabs(itype(i+1))
2199         xi=c(1,nres+i)
2200         yi=c(2,nres+i)
2201         zi=c(3,nres+i)
2202         call to_box(xi,yi,zi)
2203 C define scaling factor for lipids
2204
2205 C        if (positi.le.0) positi=positi+boxzsize
2206 C        print *,i
2207 C first for peptide groups
2208 c for each residue check if it is in lipid or lipid water border area
2209         call lipid_layer(xi,yi,zi,sslipi,ssgradlipi)
2210         dxi=dc_norm(1,nres+i)
2211         dyi=dc_norm(2,nres+i)
2212         dzi=dc_norm(3,nres+i)
2213 c        dsci_inv=dsc_inv(itypi)
2214         dsci_inv=vbld_inv(i+nres)
2215 C
2216 C Calculate SC interaction energy.
2217 C
2218 c        do iint=1,nint_gr(i)
2219 c          do j=istart(i,iint),iend(i,iint)
2220             ind=ind+1
2221             itypj=iabs(itype(j))
2222             if (itypj.eq.ntyp1) cycle
2223 c            dscj_inv=dsc_inv(itypj)
2224             dscj_inv=vbld_inv(j+nres)
2225             sig0ij=sigma(itypi,itypj)
2226             r0ij=r0(itypi,itypj)
2227             chi1=chi(itypi,itypj)
2228             chi2=chi(itypj,itypi)
2229             chi12=chi1*chi2
2230             chip1=chip(itypi)
2231             chip2=chip(itypj)
2232             chip12=chip1*chip2
2233             alf1=alp(itypi)
2234             alf2=alp(itypj)
2235             alf12=0.5D0*(alf1+alf2)
2236 C For diagnostics only!!!
2237 c           chi1=0.0D0
2238 c           chi2=0.0D0
2239 c           chi12=0.0D0
2240 c           chip1=0.0D0
2241 c           chip2=0.0D0
2242 c           chip12=0.0D0
2243 c           alf1=0.0D0
2244 c           alf2=0.0D0
2245 c           alf12=0.0D0
2246            xj=c(1,nres+j)
2247            yj=c(2,nres+j)
2248            zj=c(3,nres+j)
2249            call to_box(xj,yj,zj)
2250            call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
2251            aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
2252      &       +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
2253            bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
2254      &       +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
2255 C      if (aa.ne.aa_aq(itypi,itypj)) write(63,'2e10.5')
2256 C     &(aa-aa_aq(itypi,itypj)),(bb-bb_aq(itypi,itypj))
2257 C      write(iout,*) "tu,", i,j,aa,bb,aa_lip(itypi,itypj),sslipi,sslipj
2258            xj=boxshift(xj-xi,boxxsize)
2259            yj=boxshift(yj-yi,boxysize)
2260            zj=boxshift(zj-zi,boxzsize)
2261            dxj=dc_norm(1,nres+j)
2262            dyj=dc_norm(2,nres+j)
2263            dzj=dc_norm(3,nres+j)
2264            rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
2265            rij=dsqrt(rrij)
2266            sss=sscale(1.0d0/rij,r_cut_int)
2267            if (sss.eq.0.0d0) cycle
2268            sssgrad=sscagrad(1.0d0/rij,r_cut_int)
2269 C Calculate angle-dependent terms of energy and contributions to their
2270 C derivatives.
2271            call sc_angular
2272            sigsq=1.0D0/sigsq
2273            sig=sig0ij*dsqrt(sigsq)
2274            rij_shift=1.0D0/rij-sig+r0ij
2275 C I hate to put IF's in the loops, but here don't have another choice!!!!
2276            if (rij_shift.le.0.0D0) then
2277              evdw=1.0D20
2278              return
2279            endif
2280            sigder=-sig*sigsq
2281 c---------------------------------------------------------------
2282            rij_shift=1.0D0/rij_shift
2283            fac=rij_shift**expon
2284            e1=fac*fac*aa
2285            e2=fac*bb
2286            evdwij=eps1*eps2rt*eps3rt*(e1+e2)
2287            eps2der=evdwij*eps3rt
2288            eps3der=evdwij*eps2rt
2289            fac_augm=rrij**expon
2290            e_augm=augm(itypi,itypj)*fac_augm
2291            evdwij=evdwij*eps2rt*eps3rt
2292            evdw=evdw+evdwij+e_augm
2293            if (lprn) then
2294              sigm=dabs(aa/bb)**(1.0D0/6.0D0)
2295              epsi=bb**2/aa
2296              write (iout,'(2(a3,i3,2x),17(0pf7.3))')
2297      &        restyp(itypi),i,restyp(itypj),j,
2298      &        epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),
2299      &        chi1,chi2,chip1,chip2,
2300      &        eps1,eps2rt**2,eps3rt**2,
2301      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
2302      &        evdwij+e_augm
2303            endif
2304 C Calculate gradient components.
2305            e1=e1*eps1*eps2rt**2*eps3rt**2
2306            fac=-expon*(e1+evdwij)*rij_shift
2307            sigder=fac*sigder
2308            fac=rij*fac-2*expon*rrij*e_augm
2309            fac=fac+(evdwij+e_augm)*sssgrad/sss*rij
2310 C Calculate the radial part of the gradient
2311            gg(1)=xj*fac
2312            gg(2)=yj*fac
2313            gg(3)=zj*fac
2314 C Calculate angular part of the gradient.
2315 c            call sc_grad_scale(sss)
2316            call sc_grad
2317 c          enddo      ! j
2318 c        enddo        ! iint
2319       enddo          ! i
2320       end
2321 C-----------------------------------------------------------------------------
2322       subroutine sc_angular
2323 C Calculate eps1,eps2,eps3,sigma, and parts of their derivatives in om1,om2,
2324 C om12. Called by ebp, egb, and egbv.
2325       implicit none
2326       include 'COMMON.CALC'
2327       include 'COMMON.IOUNITS'
2328       erij(1)=xj*rij
2329       erij(2)=yj*rij
2330       erij(3)=zj*rij
2331       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
2332       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
2333       om12=dxi*dxj+dyi*dyj+dzi*dzj
2334       chiom12=chi12*om12
2335 C Calculate eps1(om12) and its derivative in om12
2336       faceps1=1.0D0-om12*chiom12
2337       faceps1_inv=1.0D0/faceps1
2338       eps1=dsqrt(faceps1_inv)
2339 C Following variable is eps1*deps1/dom12
2340       eps1_om12=faceps1_inv*chiom12
2341 c diagnostics only
2342 c      faceps1_inv=om12
2343 c      eps1=om12
2344 c      eps1_om12=1.0d0
2345 c      write (iout,*) "om12",om12," eps1",eps1
2346 C Calculate sigma(om1,om2,om12) and the derivatives of sigma**2 in om1,om2,
2347 C and om12.
2348       om1om2=om1*om2
2349       chiom1=chi1*om1
2350       chiom2=chi2*om2
2351       facsig=om1*chiom1+om2*chiom2-2.0D0*om1om2*chiom12
2352       sigsq=1.0D0-facsig*faceps1_inv
2353       sigsq_om1=(chiom1-chiom12*om2)*faceps1_inv
2354       sigsq_om2=(chiom2-chiom12*om1)*faceps1_inv
2355       sigsq_om12=-chi12*(om1om2*faceps1-om12*facsig)*faceps1_inv**2
2356 c diagnostics only
2357 c      sigsq=1.0d0
2358 c      sigsq_om1=0.0d0
2359 c      sigsq_om2=0.0d0
2360 c      sigsq_om12=0.0d0
2361 c      write (iout,*) "chiom1",chiom1," chiom2",chiom2," chiom12",chiom12
2362 c      write (iout,*) "faceps1",faceps1," faceps1_inv",faceps1_inv,
2363 c     &    " eps1",eps1
2364 C Calculate eps2 and its derivatives in om1, om2, and om12.
2365       chipom1=chip1*om1
2366       chipom2=chip2*om2
2367       chipom12=chip12*om12
2368       facp=1.0D0-om12*chipom12
2369       facp_inv=1.0D0/facp
2370       facp1=om1*chipom1+om2*chipom2-2.0D0*om1om2*chipom12
2371 c      write (iout,*) "chipom1",chipom1," chipom2",chipom2,
2372 c     &  " chipom12",chipom12," facp",facp," facp_inv",facp_inv
2373 C Following variable is the square root of eps2
2374       eps2rt=1.0D0-facp1*facp_inv
2375 C Following three variables are the derivatives of the square root of eps
2376 C in om1, om2, and om12.
2377       eps2rt_om1=-4.0D0*(chipom1-chipom12*om2)*facp_inv
2378       eps2rt_om2=-4.0D0*(chipom2-chipom12*om1)*facp_inv
2379       eps2rt_om12=4.0D0*chip12*(om1om2*facp-om12*facp1)*facp_inv**2
2380 C Evaluate the "asymmetric" factor in the VDW constant, eps3
2381       eps3rt=1.0D0-alf1*om1+alf2*om2-alf12*om12
2382 c      write (iout,*) "eps2rt",eps2rt," eps3rt",eps3rt
2383 c      write (iout,*) "eps2rt_om1",eps2rt_om1," eps2rt_om2",eps2rt_om2,
2384 c     &  " eps2rt_om12",eps2rt_om12
2385 C Calculate whole angle-dependent part of epsilon and contributions
2386 C to its derivatives
2387       return
2388       end
2389 C----------------------------------------------------------------------------
2390       subroutine sc_grad
2391       implicit real*8 (a-h,o-z)
2392       include 'DIMENSIONS'
2393       include 'COMMON.CHAIN'
2394       include 'COMMON.DERIV'
2395       include 'COMMON.CALC'
2396       include 'COMMON.IOUNITS'
2397       double precision dcosom1(3),dcosom2(3)
2398 cc      print *,'sss=',sss
2399       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
2400       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
2401       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12
2402      &     -2.0D0*alf12*eps3der+sigder*sigsq_om12
2403 c diagnostics only
2404 c      eom1=0.0d0
2405 c      eom2=0.0d0
2406 c      eom12=evdwij*eps1_om12
2407 c end diagnostics
2408 c      write (iout,*) "eps2der",eps2der," eps3der",eps3der,
2409 c     &  " sigder",sigder
2410 c      write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12
2411 c      write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12
2412       do k=1,3
2413         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
2414         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
2415       enddo
2416       do k=1,3
2417         gg(k)=(gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k))*sss
2418       enddo
2419 c      write (iout,*) "gg",(gg(k),k=1,3)
2420       do k=1,3
2421         gvdwx(k,i)=gvdwx(k,i)-gg(k)+gg_lipi(k)
2422      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
2423      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv*sss
2424         gvdwx(k,j)=gvdwx(k,j)+gg(k)+gg_lipj(k)
2425      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
2426      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv*sss
2427 c        write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
2428 c     &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
2429 c        write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
2430 c     &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
2431       enddo
2432 C
2433 C Calculate the components of the gradient in DC and X
2434 C
2435 cgrad      do k=i,j-1
2436 cgrad        do l=1,3
2437 cgrad          gvdwc(l,k)=gvdwc(l,k)+gg(l)
2438 cgrad        enddo
2439 cgrad      enddo
2440       do l=1,3
2441         gvdwc(l,i)=gvdwc(l,i)-gg(l)+gg_lipi(l)
2442         gvdwc(l,j)=gvdwc(l,j)+gg(l)+gg_lipj(l)
2443       enddo
2444       return
2445       end
2446 C-----------------------------------------------------------------------
2447       subroutine e_softsphere(evdw)
2448 C
2449 C This subroutine calculates the interaction energy of nonbonded side chains
2450 C assuming the LJ potential of interaction.
2451 C
2452       implicit real*8 (a-h,o-z)
2453       include 'DIMENSIONS'
2454       parameter (accur=1.0d-10)
2455       include 'COMMON.GEO'
2456       include 'COMMON.VAR'
2457       include 'COMMON.LOCAL'
2458       include 'COMMON.CHAIN'
2459       include 'COMMON.DERIV'
2460       include 'COMMON.INTERACT'
2461       include 'COMMON.TORSION'
2462       include 'COMMON.SBRIDGE'
2463       include 'COMMON.NAMES'
2464       include 'COMMON.IOUNITS'
2465 c      include 'COMMON.CONTACTS'
2466       dimension gg(3)
2467       double precision boxshift
2468 cd    print *,'Entering Esoft_sphere nnt=',nnt,' nct=',nct
2469       evdw=0.0D0
2470 c      do i=iatsc_s,iatsc_e
2471       do ikont=g_listscsc_start,g_listscsc_end
2472         i=newcontlisti(ikont)
2473         j=newcontlistj(ikont)
2474         itypi=iabs(itype(i))
2475         if (itypi.eq.ntyp1) cycle
2476         itypi1=iabs(itype(i+1))
2477         xi=c(1,nres+i)
2478         yi=c(2,nres+i)
2479         zi=c(3,nres+i)
2480         call to_box(xi,yi,zi)
2481 C
2482 C Calculate SC interaction energy.
2483 C
2484 c        do iint=1,nint_gr(i)
2485 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
2486 cd   &                  'iend=',iend(i,iint)
2487 c          do j=istart(i,iint),iend(i,iint)
2488             itypj=iabs(itype(j))
2489             if (itypj.eq.ntyp1) cycle
2490             xj=boxshift(c(1,nres+j)-xi,boxxsize)
2491             yj=boxshift(c(2,nres+j)-yi,boxysize)
2492             zj=boxshift(c(3,nres+j)-zi,boxzsize)
2493             rij=xj*xj+yj*yj+zj*zj
2494 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
2495             r0ij=r0(itypi,itypj)
2496             r0ijsq=r0ij*r0ij
2497 c            print *,i,j,r0ij,dsqrt(rij)
2498             if (rij.lt.r0ijsq) then
2499               evdwij=0.25d0*(rij-r0ijsq)**2
2500               fac=rij-r0ijsq
2501             else
2502               evdwij=0.0d0
2503               fac=0.0d0
2504             endif
2505             evdw=evdw+evdwij
2506 C
2507 C Calculate the components of the gradient in DC and X
2508 C
2509             gg(1)=xj*fac
2510             gg(2)=yj*fac
2511             gg(3)=zj*fac
2512             do k=1,3
2513               gvdwx(k,i)=gvdwx(k,i)-gg(k)
2514               gvdwx(k,j)=gvdwx(k,j)+gg(k)
2515               gvdwc(k,i)=gvdwc(k,i)-gg(k)
2516               gvdwc(k,j)=gvdwc(k,j)+gg(k)
2517             enddo
2518 cgrad            do k=i,j-1
2519 cgrad              do l=1,3
2520 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
2521 cgrad              enddo
2522 cgrad            enddo
2523 c          enddo ! j
2524 c        enddo ! iint
2525       enddo ! i
2526       return
2527       end
2528 C--------------------------------------------------------------------------
2529       subroutine eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,
2530      &              eello_turn4)
2531 C
2532 C Soft-sphere potential of p-p interaction
2533 C
2534       implicit real*8 (a-h,o-z)
2535       include 'DIMENSIONS'
2536       include 'COMMON.CONTROL'
2537       include 'COMMON.IOUNITS'
2538       include 'COMMON.GEO'
2539       include 'COMMON.VAR'
2540       include 'COMMON.LOCAL'
2541       include 'COMMON.CHAIN'
2542       include 'COMMON.DERIV'
2543       include 'COMMON.INTERACT'
2544 c      include 'COMMON.CONTACTS'
2545       include 'COMMON.TORSION'
2546       include 'COMMON.VECTORS'
2547       include 'COMMON.FFIELD'
2548       dimension ggg(3)
2549       double precision boxshift
2550 C      write(iout,*) 'In EELEC_soft_sphere'
2551       ees=0.0D0
2552       evdw1=0.0D0
2553       eel_loc=0.0d0
2554       eello_turn3=0.0d0
2555       eello_turn4=0.0d0
2556       ind=0
2557       do i=iatel_s,iatel_e
2558         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
2559         dxi=dc(1,i)
2560         dyi=dc(2,i)
2561         dzi=dc(3,i)
2562         xmedi=c(1,i)+0.5d0*dxi
2563         ymedi=c(2,i)+0.5d0*dyi
2564         zmedi=c(3,i)+0.5d0*dzi
2565         call to_box(xmedi,ymedi,zmedi)
2566         num_conti=0
2567 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
2568         do j=ielstart(i),ielend(i)
2569           if (itype(j).eq.ntyp1 .or. itype(j+1).eq.ntyp1) cycle
2570           ind=ind+1
2571           iteli=itel(i)
2572           itelj=itel(j)
2573           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
2574           r0ij=rpp(iteli,itelj)
2575           r0ijsq=r0ij*r0ij
2576           dxj=dc(1,j)
2577           dyj=dc(2,j)
2578           dzj=dc(3,j)
2579           xj=c(1,j)+0.5D0*dxj
2580           yj=c(2,j)+0.5D0*dyj
2581           zj=c(3,j)+0.5D0*dzj
2582           call to_box(xj,yj,zj)
2583           xj=boxshift(xj-xmedi,boxxsize)
2584           yj=boxshift(yj-ymedi,boxysize)
2585           zj=boxshift(zj-zmedi,boxzsize)
2586           rij=xj*xj+yj*yj+zj*zj
2587             sss=sscale(sqrt(rij),r_cut_int)
2588             sssgrad=sscagrad(sqrt(rij),r_cut_int)
2589           if (rij.lt.r0ijsq) then
2590             evdw1ij=0.25d0*(rij-r0ijsq)**2
2591             fac=rij-r0ijsq
2592           else
2593             evdw1ij=0.0d0
2594             fac=0.0d0
2595           endif
2596           evdw1=evdw1+evdw1ij*sss
2597 C
2598 C Calculate contributions to the Cartesian gradient.
2599 C
2600           ggg(1)=fac*xj*sssgrad
2601           ggg(2)=fac*yj*sssgrad
2602           ggg(3)=fac*zj*sssgrad
2603           do k=1,3
2604             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
2605             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
2606           enddo
2607 *
2608 * Loop over residues i+1 thru j-1.
2609 *
2610 cgrad          do k=i+1,j-1
2611 cgrad            do l=1,3
2612 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
2613 cgrad            enddo
2614 cgrad          enddo
2615         enddo ! j
2616       enddo   ! i
2617 cgrad      do i=nnt,nct-1
2618 cgrad        do k=1,3
2619 cgrad          gelc(k,i)=gelc(k,i)+0.5d0*gelc(k,i)
2620 cgrad        enddo
2621 cgrad        do j=i+1,nct-1
2622 cgrad          do k=1,3
2623 cgrad            gelc(k,i)=gelc(k,i)+gelc(k,j)
2624 cgrad          enddo
2625 cgrad        enddo
2626 cgrad      enddo
2627       return
2628       end
2629 c------------------------------------------------------------------------------
2630       subroutine vec_and_deriv
2631       implicit real*8 (a-h,o-z)
2632       include 'DIMENSIONS'
2633 #ifdef MPI
2634       include 'mpif.h'
2635 #endif
2636       include 'COMMON.IOUNITS'
2637       include 'COMMON.GEO'
2638       include 'COMMON.VAR'
2639       include 'COMMON.LOCAL'
2640       include 'COMMON.CHAIN'
2641       include 'COMMON.VECTORS'
2642       include 'COMMON.SETUP'
2643       include 'COMMON.TIME1'
2644       dimension uyder(3,3,2),uzder(3,3,2),vbld_inv_temp(2)
2645 C Compute the local reference systems. For reference system (i), the
2646 C X-axis points from CA(i) to CA(i+1), the Y axis is in the
2647 C CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
2648 #ifdef PARVEC
2649       do i=ivec_start,ivec_end
2650 #else
2651       do i=1,nres-1
2652 #endif
2653           if (i.eq.nres-1) then
2654 C Case of the last full residue
2655 C Compute the Z-axis
2656             call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
2657             costh=dcos(pi-theta(nres))
2658             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2659             do k=1,3
2660               uz(k,i)=fac*uz(k,i)
2661             enddo
2662 C Compute the derivatives of uz
2663             uzder(1,1,1)= 0.0d0
2664             uzder(2,1,1)=-dc_norm(3,i-1)
2665             uzder(3,1,1)= dc_norm(2,i-1)
2666             uzder(1,2,1)= dc_norm(3,i-1)
2667             uzder(2,2,1)= 0.0d0
2668             uzder(3,2,1)=-dc_norm(1,i-1)
2669             uzder(1,3,1)=-dc_norm(2,i-1)
2670             uzder(2,3,1)= dc_norm(1,i-1)
2671             uzder(3,3,1)= 0.0d0
2672             uzder(1,1,2)= 0.0d0
2673             uzder(2,1,2)= dc_norm(3,i)
2674             uzder(3,1,2)=-dc_norm(2,i)
2675             uzder(1,2,2)=-dc_norm(3,i)
2676             uzder(2,2,2)= 0.0d0
2677             uzder(3,2,2)= dc_norm(1,i)
2678             uzder(1,3,2)= dc_norm(2,i)
2679             uzder(2,3,2)=-dc_norm(1,i)
2680             uzder(3,3,2)= 0.0d0
2681 C Compute the Y-axis
2682             facy=fac
2683             do k=1,3
2684               uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
2685             enddo
2686 C Compute the derivatives of uy
2687             do j=1,3
2688               do k=1,3
2689                 uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i)
2690      &                        -dc_norm(k,i)*dc_norm(j,i-1)
2691                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2692               enddo
2693               uyder(j,j,1)=uyder(j,j,1)-costh
2694               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2695             enddo
2696             do j=1,2
2697               do k=1,3
2698                 do l=1,3
2699                   uygrad(l,k,j,i)=uyder(l,k,j)
2700                   uzgrad(l,k,j,i)=uzder(l,k,j)
2701                 enddo
2702               enddo
2703             enddo
2704             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2705             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2706             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2707             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2708           else
2709 C Other residues
2710 C Compute the Z-axis
2711             call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
2712             costh=dcos(pi-theta(i+2))
2713             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2714             do k=1,3
2715               uz(k,i)=fac*uz(k,i)
2716             enddo
2717 C Compute the derivatives of uz
2718             uzder(1,1,1)= 0.0d0
2719             uzder(2,1,1)=-dc_norm(3,i+1)
2720             uzder(3,1,1)= dc_norm(2,i+1)
2721             uzder(1,2,1)= dc_norm(3,i+1)
2722             uzder(2,2,1)= 0.0d0
2723             uzder(3,2,1)=-dc_norm(1,i+1)
2724             uzder(1,3,1)=-dc_norm(2,i+1)
2725             uzder(2,3,1)= dc_norm(1,i+1)
2726             uzder(3,3,1)= 0.0d0
2727             uzder(1,1,2)= 0.0d0
2728             uzder(2,1,2)= dc_norm(3,i)
2729             uzder(3,1,2)=-dc_norm(2,i)
2730             uzder(1,2,2)=-dc_norm(3,i)
2731             uzder(2,2,2)= 0.0d0
2732             uzder(3,2,2)= dc_norm(1,i)
2733             uzder(1,3,2)= dc_norm(2,i)
2734             uzder(2,3,2)=-dc_norm(1,i)
2735             uzder(3,3,2)= 0.0d0
2736 C Compute the Y-axis
2737             facy=fac
2738             do k=1,3
2739               uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
2740             enddo
2741 C Compute the derivatives of uy
2742             do j=1,3
2743               do k=1,3
2744                 uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i)
2745      &                        -dc_norm(k,i)*dc_norm(j,i+1)
2746                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2747               enddo
2748               uyder(j,j,1)=uyder(j,j,1)-costh
2749               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2750             enddo
2751             do j=1,2
2752               do k=1,3
2753                 do l=1,3
2754                   uygrad(l,k,j,i)=uyder(l,k,j)
2755                   uzgrad(l,k,j,i)=uzder(l,k,j)
2756                 enddo
2757               enddo
2758             enddo
2759             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2760             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2761             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2762             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2763           endif
2764       enddo
2765       do i=1,nres-1
2766         vbld_inv_temp(1)=vbld_inv(i+1)
2767         if (i.lt.nres-1) then
2768           vbld_inv_temp(2)=vbld_inv(i+2)
2769           else
2770           vbld_inv_temp(2)=vbld_inv(i)
2771           endif
2772         do j=1,2
2773           do k=1,3
2774             do l=1,3
2775               uygrad(l,k,j,i)=vbld_inv_temp(j)*uygrad(l,k,j,i)
2776               uzgrad(l,k,j,i)=vbld_inv_temp(j)*uzgrad(l,k,j,i)
2777             enddo
2778           enddo
2779         enddo
2780       enddo
2781 #if defined(PARVEC) && defined(MPI)
2782       if (nfgtasks1.gt.1) then
2783         time00=MPI_Wtime()
2784 c        print *,"Processor",fg_rank1,kolor1," ivec_start",ivec_start,
2785 c     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks1-1),
2786 c     &   " ivec_count",(ivec_count(i),i=0,nfgtasks1-1)
2787         call MPI_Allgatherv(uy(1,ivec_start),ivec_count(fg_rank1),
2788      &   MPI_UYZ,uy(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
2789      &   FG_COMM1,IERR)
2790         call MPI_Allgatherv(uz(1,ivec_start),ivec_count(fg_rank1),
2791      &   MPI_UYZ,uz(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
2792      &   FG_COMM1,IERR)
2793         call MPI_Allgatherv(uygrad(1,1,1,ivec_start),
2794      &   ivec_count(fg_rank1),MPI_UYZGRAD,uygrad(1,1,1,1),ivec_count(0),
2795      &   ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2796         call MPI_Allgatherv(uzgrad(1,1,1,ivec_start),
2797      &   ivec_count(fg_rank1),MPI_UYZGRAD,uzgrad(1,1,1,1),ivec_count(0),
2798      &   ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2799         time_gather=time_gather+MPI_Wtime()-time00
2800       endif
2801 #endif
2802 #ifdef DEBUG
2803       if (fg_rank.eq.0) then
2804         write (iout,*) "Arrays UY and UZ"
2805         do i=1,nres-1
2806           write (iout,'(i5,3f10.5,5x,3f10.5)') i,(uy(k,i),k=1,3),
2807      &     (uz(k,i),k=1,3)
2808         enddo
2809       endif
2810 #endif
2811       return
2812       end
2813 C--------------------------------------------------------------------------
2814       subroutine set_matrices
2815       implicit real*8 (a-h,o-z)
2816       include 'DIMENSIONS'
2817 #ifdef MPI
2818       include "mpif.h"
2819       include "COMMON.SETUP"
2820       integer IERR
2821       integer status(MPI_STATUS_SIZE)
2822 #endif
2823       include 'COMMON.IOUNITS'
2824       include 'COMMON.GEO'
2825       include 'COMMON.VAR'
2826       include 'COMMON.LOCAL'
2827       include 'COMMON.CHAIN'
2828       include 'COMMON.DERIV'
2829       include 'COMMON.INTERACT'
2830       include 'COMMON.CORRMAT'
2831       include 'COMMON.TORSION'
2832       include 'COMMON.VECTORS'
2833       include 'COMMON.FFIELD'
2834       double precision auxvec(2),auxmat(2,2)
2835 C
2836 C Compute the virtual-bond-torsional-angle dependent quantities needed
2837 C to calculate the el-loc multibody terms of various order.
2838 C
2839 c      write(iout,*) 'nphi=',nphi,nres
2840 c      write(iout,*) "itype2loc",itype2loc
2841 #ifdef PARMAT
2842       do i=ivec_start+2,ivec_end+2
2843 #else
2844       do i=3,nres+1
2845 #endif
2846         ii=ireschain(i-2)
2847 c        write (iout,*) "i",i,i-2," ii",ii
2848         if (ii.eq.0) cycle
2849         innt=chain_border(1,ii)
2850         inct=chain_border(2,ii)
2851 c        write (iout,*) "i",i,i-2," ii",ii," innt",innt," inct",inct
2852 c        if (i.gt. nnt+2 .and. i.lt.nct+2) then
2853         if (i.gt. innt+2 .and. i.lt.inct+2) then
2854           iti = itype2loc(itype(i-2))
2855         else
2856           iti=nloctyp
2857         endif
2858 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2859         if (i.gt. innt+1 .and. i.lt.inct+1) then
2860           iti1 = itype2loc(itype(i-1))
2861         else
2862           iti1=nloctyp
2863         endif
2864 c        write(iout,*),"i",i,i-2," iti",itype(i-2),iti,
2865 c     &  " iti1",itype(i-1),iti1
2866 #ifdef NEWCORR
2867         cost1=dcos(theta(i-1))
2868         sint1=dsin(theta(i-1))
2869         sint1sq=sint1*sint1
2870         sint1cub=sint1sq*sint1
2871         sint1cost1=2*sint1*cost1
2872 c        write (iout,*) "bnew1",i,iti
2873 c        write (iout,*) (bnew1(k,1,iti),k=1,3)
2874 c        write (iout,*) (bnew1(k,2,iti),k=1,3)
2875 c        write (iout,*) "bnew2",i,iti
2876 c        write (iout,*) (bnew2(k,1,iti),k=1,3)
2877 c        write (iout,*) (bnew2(k,2,iti),k=1,3)
2878         do k=1,2
2879           b1k=bnew1(1,k,iti)+(bnew1(2,k,iti)+bnew1(3,k,iti)*cost1)*cost1
2880           b1(k,i-2)=sint1*b1k
2881           gtb1(k,i-2)=cost1*b1k-sint1sq*
2882      &              (bnew1(2,k,iti)+2*bnew1(3,k,iti)*cost1)
2883           b2k=bnew2(1,k,iti)+(bnew2(2,k,iti)+bnew2(3,k,iti)*cost1)*cost1
2884           b2(k,i-2)=sint1*b2k
2885           gtb2(k,i-2)=cost1*b2k-sint1sq*
2886      &              (bnew2(2,k,iti)+2*bnew2(3,k,iti)*cost1)
2887         enddo
2888         do k=1,2
2889           aux=ccnew(1,k,iti)+(ccnew(2,k,iti)+ccnew(3,k,iti)*cost1)*cost1
2890           cc(1,k,i-2)=sint1sq*aux
2891           gtcc(1,k,i-2)=sint1cost1*aux-sint1cub*
2892      &              (ccnew(2,k,iti)+2*ccnew(3,k,iti)*cost1)
2893           aux=ddnew(1,k,iti)+(ddnew(2,k,iti)+ddnew(3,k,iti)*cost1)*cost1
2894           dd(1,k,i-2)=sint1sq*aux
2895           gtdd(1,k,i-2)=sint1cost1*aux-sint1cub*
2896      &              (ddnew(2,k,iti)+2*ddnew(3,k,iti)*cost1)
2897         enddo
2898         cc(2,1,i-2)=cc(1,2,i-2)
2899         cc(2,2,i-2)=-cc(1,1,i-2)
2900         gtcc(2,1,i-2)=gtcc(1,2,i-2)
2901         gtcc(2,2,i-2)=-gtcc(1,1,i-2)
2902         dd(2,1,i-2)=dd(1,2,i-2)
2903         dd(2,2,i-2)=-dd(1,1,i-2)
2904         gtdd(2,1,i-2)=gtdd(1,2,i-2)
2905         gtdd(2,2,i-2)=-gtdd(1,1,i-2)
2906         do k=1,2
2907           do l=1,2
2908             aux=eenew(1,l,k,iti)+eenew(2,l,k,iti)*cost1
2909             EE(l,k,i-2)=sint1sq*aux
2910             gtEE(l,k,i-2)=sint1cost1*aux-sint1cub*eenew(2,l,k,iti)
2911           enddo
2912         enddo
2913         EE(1,1,i-2)=EE(1,1,i-2)+e0new(1,iti)*cost1
2914         EE(1,2,i-2)=EE(1,2,i-2)+e0new(2,iti)+e0new(3,iti)*cost1
2915         EE(2,1,i-2)=EE(2,1,i-2)+e0new(2,iti)*cost1+e0new(3,iti)
2916         EE(2,2,i-2)=EE(2,2,i-2)-e0new(1,iti)
2917         gtEE(1,1,i-2)=gtEE(1,1,i-2)-e0new(1,iti)*sint1
2918         gtEE(1,2,i-2)=gtEE(1,2,i-2)-e0new(3,iti)*sint1
2919         gtEE(2,1,i-2)=gtEE(2,1,i-2)-e0new(2,iti)*sint1
2920 c        b1tilde(1,i-2)=b1(1,i-2)
2921 c        b1tilde(2,i-2)=-b1(2,i-2)
2922 c        b2tilde(1,i-2)=b2(1,i-2)
2923 c        b2tilde(2,i-2)=-b2(2,i-2)
2924 #ifdef DEBUG
2925         write (iout,*) 'i=',i-2,gtb1(2,i-2),gtb1(1,i-2)
2926         write(iout,*)  'b1=',(b1(k,i-2),k=1,2)
2927         write(iout,*)  'b2=',(b2(k,i-2),k=1,2)
2928         write (iout,*) 'theta=', theta(i-1)
2929 #endif
2930 #else
2931         if (i.gt. innt+2 .and. i.lt.inct+2) then
2932 c        if (i.gt. nnt+2 .and. i.lt.nct+2) then
2933           iti = itype2loc(itype(i-2))
2934         else
2935           iti=nloctyp
2936         endif
2937 c        write (iout,*) "i",i-1," itype",itype(i-2)," iti",iti
2938 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2939         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2940           iti1 = itype2loc(itype(i-1))
2941         else
2942           iti1=nloctyp
2943         endif
2944         b1(1,i-2)=b(3,iti)
2945         b1(2,i-2)=b(5,iti)
2946         b2(1,i-2)=b(2,iti)
2947         b2(2,i-2)=b(4,iti)
2948         do k=1,2
2949           do l=1,2
2950            CC(k,l,i-2)=ccold(k,l,iti)
2951            DD(k,l,i-2)=ddold(k,l,iti)
2952            EE(k,l,i-2)=eeold(k,l,iti)
2953            gtEE(k,l,i-2)=0.0d0
2954           enddo
2955         enddo
2956 #endif
2957         b1tilde(1,i-2)= b1(1,i-2)
2958         b1tilde(2,i-2)=-b1(2,i-2)
2959         b2tilde(1,i-2)= b2(1,i-2)
2960         b2tilde(2,i-2)=-b2(2,i-2)
2961 c
2962         Ctilde(1,1,i-2)= CC(1,1,i-2)
2963         Ctilde(1,2,i-2)= CC(1,2,i-2)
2964         Ctilde(2,1,i-2)=-CC(2,1,i-2)
2965         Ctilde(2,2,i-2)=-CC(2,2,i-2)
2966 c
2967         Dtilde(1,1,i-2)= DD(1,1,i-2)
2968         Dtilde(1,2,i-2)= DD(1,2,i-2)
2969         Dtilde(2,1,i-2)=-DD(2,1,i-2)
2970         Dtilde(2,2,i-2)=-DD(2,2,i-2)
2971 #ifdef DEBUG
2972         write(iout,*) "i",i," iti",iti
2973         write(iout,*)  'b1=',(b1(k,i-2),k=1,2)
2974         write(iout,*)  'b2=',(b2(k,i-2),k=1,2)
2975 #endif
2976       enddo
2977       mu=0.0d0
2978 #ifdef PARMAT
2979       do i=ivec_start+2,ivec_end+2
2980 #else
2981       do i=3,nres+1
2982 #endif
2983 c        if (itype(i-1).eq.ntyp1 .and. itype(i).eq.ntyp1) cycle
2984         if (i .lt. nres+1 .and. itype(i-1).lt.ntyp1) then
2985           sin1=dsin(phi(i))
2986           cos1=dcos(phi(i))
2987           sintab(i-2)=sin1
2988           costab(i-2)=cos1
2989           obrot(1,i-2)=cos1
2990           obrot(2,i-2)=sin1
2991           sin2=dsin(2*phi(i))
2992           cos2=dcos(2*phi(i))
2993           sintab2(i-2)=sin2
2994           costab2(i-2)=cos2
2995           obrot2(1,i-2)=cos2
2996           obrot2(2,i-2)=sin2
2997           Ug(1,1,i-2)=-cos1
2998           Ug(1,2,i-2)=-sin1
2999           Ug(2,1,i-2)=-sin1
3000           Ug(2,2,i-2)= cos1
3001           Ug2(1,1,i-2)=-cos2
3002           Ug2(1,2,i-2)=-sin2
3003           Ug2(2,1,i-2)=-sin2
3004           Ug2(2,2,i-2)= cos2
3005         else
3006           costab(i-2)=1.0d0
3007           sintab(i-2)=0.0d0
3008           obrot(1,i-2)=1.0d0
3009           obrot(2,i-2)=0.0d0
3010           obrot2(1,i-2)=0.0d0
3011           obrot2(2,i-2)=0.0d0
3012           Ug(1,1,i-2)=1.0d0
3013           Ug(1,2,i-2)=0.0d0
3014           Ug(2,1,i-2)=0.0d0
3015           Ug(2,2,i-2)=1.0d0
3016           Ug2(1,1,i-2)=0.0d0
3017           Ug2(1,2,i-2)=0.0d0
3018           Ug2(2,1,i-2)=0.0d0
3019           Ug2(2,2,i-2)=0.0d0
3020         endif
3021         if (i .gt. 3) then
3022           obrot_der(1,i-2)=-sin1
3023           obrot_der(2,i-2)= cos1
3024           Ugder(1,1,i-2)= sin1
3025           Ugder(1,2,i-2)=-cos1
3026           Ugder(2,1,i-2)=-cos1
3027           Ugder(2,2,i-2)=-sin1
3028           dwacos2=cos2+cos2
3029           dwasin2=sin2+sin2
3030           obrot2_der(1,i-2)=-dwasin2
3031           obrot2_der(2,i-2)= dwacos2
3032           Ug2der(1,1,i-2)= dwasin2
3033           Ug2der(1,2,i-2)=-dwacos2
3034           Ug2der(2,1,i-2)=-dwacos2
3035           Ug2der(2,2,i-2)=-dwasin2
3036         else
3037           obrot_der(1,i-2)=0.0d0
3038           obrot_der(2,i-2)=0.0d0
3039           Ugder(1,1,i-2)=0.0d0
3040           Ugder(1,2,i-2)=0.0d0
3041           Ugder(2,1,i-2)=0.0d0
3042           Ugder(2,2,i-2)=0.0d0
3043           obrot2_der(1,i-2)=0.0d0
3044           obrot2_der(2,i-2)=0.0d0
3045           Ug2der(1,1,i-2)=0.0d0
3046           Ug2der(1,2,i-2)=0.0d0
3047           Ug2der(2,1,i-2)=0.0d0
3048           Ug2der(2,2,i-2)=0.0d0
3049         endif
3050 c        if (i.gt. iatel_s+2 .and. i.lt.iatel_e+5) then
3051 c        if (i.gt. nnt+2 .and. i.lt.nct+2) then
3052         if (i.gt.nnt+2 .and.i.lt.nct+2) then
3053           iti = itype2loc(itype(i-2))
3054         else
3055           iti=nloctyp
3056         endif
3057 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
3058         if (i.gt. nnt+1 .and. i.lt.nct+1) then
3059           iti1 = itype2loc(itype(i-1))
3060         else
3061           iti1=nloctyp
3062         endif
3063 cd        write (iout,*) '*******i',i,' iti1',iti
3064 cd        write (iout,*) 'b1',b1(:,iti)
3065 cd        write (iout,*) 'b2',b2(:,iti)
3066 cd        write (iout,*) 'Ug',Ug(:,:,i-2)
3067 c        if (i .gt. iatel_s+2) then
3068         if (i .gt. nnt+2) then
3069           call matvec2(Ug(1,1,i-2),b2(1,i-2),Ub2(1,i-2))
3070 #ifdef NEWCORR
3071           call matvec2(Ug(1,1,i-2),gtb2(1,i-2),gUb2(1,i-2))
3072 c          write (iout,*) Ug(1,1,i-2),gtb2(1,i-2),gUb2(1,i-2),"chuj"
3073 #endif
3074 c          write(iout,*) "co jest kurwa", iti, EE(1,1,i),EE(2,1,i),
3075 c     &    EE(1,2,iti),EE(2,2,i)
3076           call matmat2(EE(1,1,i-2),Ug(1,1,i-2),EUg(1,1,i-2))
3077           call matmat2(gtEE(1,1,i-2),Ug(1,1,i-2),gtEUg(1,1,i-2))
3078 c          write(iout,*) "Macierz EUG",
3079 c     &    eug(1,1,i-2),eug(1,2,i-2),eug(2,1,i-2),
3080 c     &    eug(2,2,i-2)
3081 #ifdef FOURBODY
3082           if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
3083      &    then
3084           call matmat2(CC(1,1,i-2),Ug(1,1,i-2),CUg(1,1,i-2))
3085           call matmat2(DD(1,1,i-2),Ug(1,1,i-2),DUg(1,1,i-2))
3086           call matmat2(Dtilde(1,1,i-2),Ug2(1,1,i-2),DtUg2(1,1,i-2))
3087           call matvec2(Ctilde(1,1,i-1),obrot(1,i-2),Ctobr(1,i-2))
3088           call matvec2(Dtilde(1,1,i-2),obrot2(1,i-2),Dtobr2(1,i-2))
3089           endif
3090 #endif
3091         else
3092           do k=1,2
3093             Ub2(k,i-2)=0.0d0
3094             Ctobr(k,i-2)=0.0d0
3095             Dtobr2(k,i-2)=0.0d0
3096             do l=1,2
3097               EUg(l,k,i-2)=0.0d0
3098               CUg(l,k,i-2)=0.0d0
3099               DUg(l,k,i-2)=0.0d0
3100               DtUg2(l,k,i-2)=0.0d0
3101             enddo
3102           enddo
3103         endif
3104         call matvec2(Ugder(1,1,i-2),b2(1,i-2),Ub2der(1,i-2))
3105         call matmat2(EE(1,1,i-2),Ugder(1,1,i-2),EUgder(1,1,i-2))
3106         do k=1,2
3107           muder(k,i-2)=Ub2der(k,i-2)
3108         enddo
3109 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
3110         if (i.gt. nnt+1 .and. i.lt.nct+1) then
3111           if (itype(i-1).le.ntyp) then
3112             iti1 = itype2loc(itype(i-1))
3113           else
3114             iti1=nloctyp
3115           endif
3116         else
3117           iti1=nloctyp
3118         endif
3119         do k=1,2
3120           mu(k,i-2)=Ub2(k,i-2)+b1(k,i-1)
3121 c          mu(k,i-2)=b1(k,i-1)
3122 c          mu(k,i-2)=Ub2(k,i-2)
3123         enddo
3124 #ifdef MUOUT
3125         write (iout,'(2hmu,i3,3f8.1,12f10.5)') i-2,rad2deg*theta(i-1),
3126      &     rad2deg*theta(i),rad2deg*phi(i),mu(1,i-2),mu(2,i-2),
3127      &       -b2(1,i-2),b2(2,i-2),b1(1,i-2),b1(2,i-2),
3128      &       dsqrt(b2(1,i-1)**2+b2(2,i-1)**2)
3129      &      +dsqrt(b1(1,i-1)**2+b1(2,i-1)**2),
3130      &      ((ee(l,k,i-2),l=1,2),k=1,2)
3131 #endif
3132 cd        write (iout,*) 'mu1',mu1(:,i-2)
3133 cd        write (iout,*) 'mu2',mu2(:,i-2)
3134 cd        write (iout,*) 'mu',i-2,mu(:,i-2)
3135 #ifdef FOURBODY
3136         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
3137      &  then
3138         call matmat2(CC(1,1,i-1),Ugder(1,1,i-2),CUgder(1,1,i-2))
3139         call matmat2(DD(1,1,i-2),Ugder(1,1,i-2),DUgder(1,1,i-2))
3140         call matmat2(Dtilde(1,1,i-2),Ug2der(1,1,i-2),DtUg2der(1,1,i-2))
3141         call matvec2(Ctilde(1,1,i-1),obrot_der(1,i-2),Ctobrder(1,i-2))
3142         call matvec2(Dtilde(1,1,i-2),obrot2_der(1,i-2),Dtobr2der(1,i-2))
3143 C Vectors and matrices dependent on a single virtual-bond dihedral.
3144         call matvec2(DD(1,1,i-2),b1tilde(1,i-1),auxvec(1))
3145         call matvec2(Ug2(1,1,i-2),auxvec(1),Ug2Db1t(1,i-2))
3146         call matvec2(Ug2der(1,1,i-2),auxvec(1),Ug2Db1tder(1,i-2))
3147         call matvec2(CC(1,1,i-1),Ub2(1,i-2),CUgb2(1,i-2))
3148         call matvec2(CC(1,1,i-1),Ub2der(1,i-2),CUgb2der(1,i-2))
3149         call matmat2(EUg(1,1,i-2),CC(1,1,i-1),EUgC(1,1,i-2))
3150         call matmat2(EUgder(1,1,i-2),CC(1,1,i-1),EUgCder(1,1,i-2))
3151         call matmat2(EUg(1,1,i-2),DD(1,1,i-1),EUgD(1,1,i-2))
3152         call matmat2(EUgder(1,1,i-2),DD(1,1,i-1),EUgDder(1,1,i-2))
3153         endif
3154 #endif
3155       enddo
3156 #ifdef FOURBODY
3157 C Matrices dependent on two consecutive virtual-bond dihedrals.
3158 C The order of matrices is from left to right.
3159       if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
3160      &then
3161 c      do i=max0(ivec_start,2),ivec_end
3162       do i=2,nres-1
3163         call matmat2(DtUg2(1,1,i-1),EUg(1,1,i),DtUg2EUg(1,1,i))
3164         call matmat2(DtUg2der(1,1,i-1),EUg(1,1,i),DtUg2EUgder(1,1,1,i))
3165         call matmat2(DtUg2(1,1,i-1),EUgder(1,1,i),DtUg2EUgder(1,1,2,i))
3166         call transpose2(DtUg2(1,1,i-1),auxmat(1,1))
3167         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUg(1,1,i))
3168         call matmat2(auxmat(1,1),EUgder(1,1,i),Ug2DtEUgder(1,1,2,i))
3169         call transpose2(DtUg2der(1,1,i-1),auxmat(1,1))
3170         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUgder(1,1,1,i))
3171       enddo
3172       endif
3173 #endif
3174 #if defined(MPI) && defined(PARMAT)
3175 #ifdef DEBUG
3176 c      if (fg_rank.eq.0) then
3177         write (iout,*) "Arrays UG and UGDER before GATHER"
3178         do i=1,nres-1
3179           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3180      &     ((ug(l,k,i),l=1,2),k=1,2),
3181      &     ((ugder(l,k,i),l=1,2),k=1,2)
3182         enddo
3183         write (iout,*) "Arrays UG2 and UG2DER"
3184         do i=1,nres-1
3185           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3186      &     ((ug2(l,k,i),l=1,2),k=1,2),
3187      &     ((ug2der(l,k,i),l=1,2),k=1,2)
3188         enddo
3189         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
3190         do i=1,nres-1
3191           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3192      &     (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
3193      &     (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
3194         enddo
3195         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
3196         do i=1,nres-1
3197           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3198      &     costab(i),sintab(i),costab2(i),sintab2(i)
3199         enddo
3200         write (iout,*) "Array MUDER"
3201         do i=1,nres-1
3202           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
3203         enddo
3204 c      endif
3205 #endif
3206       if (nfgtasks.gt.1) then
3207         time00=MPI_Wtime()
3208 c        write(iout,*)"Processor",fg_rank,kolor," ivec_start",ivec_start,
3209 c     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks-1),
3210 c     &   " ivec_count",(ivec_count(i),i=0,nfgtasks-1)
3211 #ifdef MATGATHER
3212         call MPI_Allgatherv(Ub2(1,ivec_start),ivec_count(fg_rank1),
3213      &   MPI_MU,Ub2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3214      &   FG_COMM1,IERR)
3215         call MPI_Allgatherv(Ub2der(1,ivec_start),ivec_count(fg_rank1),
3216      &   MPI_MU,Ub2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3217      &   FG_COMM1,IERR)
3218         call MPI_Allgatherv(mu(1,ivec_start),ivec_count(fg_rank1),
3219      &   MPI_MU,mu(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3220      &   FG_COMM1,IERR)
3221         call MPI_Allgatherv(muder(1,ivec_start),ivec_count(fg_rank1),
3222      &   MPI_MU,muder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3223      &   FG_COMM1,IERR)
3224         call MPI_Allgatherv(Eug(1,1,ivec_start),ivec_count(fg_rank1),
3225      &   MPI_MAT1,Eug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3226      &   FG_COMM1,IERR)
3227         call MPI_Allgatherv(Eugder(1,1,ivec_start),ivec_count(fg_rank1),
3228      &   MPI_MAT1,Eugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3229      &   FG_COMM1,IERR)
3230         call MPI_Allgatherv(costab(ivec_start),ivec_count(fg_rank1),
3231      &   MPI_DOUBLE_PRECISION,costab(1),ivec_count(0),ivec_displ(0),
3232      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3233         call MPI_Allgatherv(sintab(ivec_start),ivec_count(fg_rank1),
3234      &   MPI_DOUBLE_PRECISION,sintab(1),ivec_count(0),ivec_displ(0),
3235      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3236         call MPI_Allgatherv(costab2(ivec_start),ivec_count(fg_rank1),
3237      &   MPI_DOUBLE_PRECISION,costab2(1),ivec_count(0),ivec_displ(0),
3238      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3239         call MPI_Allgatherv(sintab2(ivec_start),ivec_count(fg_rank1),
3240      &   MPI_DOUBLE_PRECISION,sintab2(1),ivec_count(0),ivec_displ(0),
3241      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3242 #ifdef FOURBODY
3243         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
3244      &  then
3245         call MPI_Allgatherv(Ctobr(1,ivec_start),ivec_count(fg_rank1),
3246      &   MPI_MU,Ctobr(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3247      &   FG_COMM1,IERR)
3248         call MPI_Allgatherv(Ctobrder(1,ivec_start),ivec_count(fg_rank1),
3249      &   MPI_MU,Ctobrder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3250      &   FG_COMM1,IERR)
3251         call MPI_Allgatherv(Dtobr2(1,ivec_start),ivec_count(fg_rank1),
3252      &   MPI_MU,Dtobr2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3253      &   FG_COMM1,IERR)
3254        call MPI_Allgatherv(Dtobr2der(1,ivec_start),ivec_count(fg_rank1),
3255      &   MPI_MU,Dtobr2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3256      &   FG_COMM1,IERR)
3257         call MPI_Allgatherv(Ug2Db1t(1,ivec_start),ivec_count(fg_rank1),
3258      &   MPI_MU,Ug2Db1t(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3259      &   FG_COMM1,IERR)
3260         call MPI_Allgatherv(Ug2Db1tder(1,ivec_start),
3261      &   ivec_count(fg_rank1),
3262      &   MPI_MU,Ug2Db1tder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3263      &   FG_COMM1,IERR)
3264         call MPI_Allgatherv(CUgb2(1,ivec_start),ivec_count(fg_rank1),
3265      &   MPI_MU,CUgb2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3266      &   FG_COMM1,IERR)
3267         call MPI_Allgatherv(CUgb2der(1,ivec_start),ivec_count(fg_rank1),
3268      &   MPI_MU,CUgb2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3269      &   FG_COMM1,IERR)
3270         call MPI_Allgatherv(Cug(1,1,ivec_start),ivec_count(fg_rank1),
3271      &   MPI_MAT1,Cug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3272      &   FG_COMM1,IERR)
3273         call MPI_Allgatherv(Cugder(1,1,ivec_start),ivec_count(fg_rank1),
3274      &   MPI_MAT1,Cugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3275      &   FG_COMM1,IERR)
3276         call MPI_Allgatherv(Dug(1,1,ivec_start),ivec_count(fg_rank1),
3277      &   MPI_MAT1,Dug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3278      &   FG_COMM1,IERR)
3279         call MPI_Allgatherv(Dugder(1,1,ivec_start),ivec_count(fg_rank1),
3280      &   MPI_MAT1,Dugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3281      &   FG_COMM1,IERR)
3282         call MPI_Allgatherv(Dtug2(1,1,ivec_start),ivec_count(fg_rank1),
3283      &   MPI_MAT1,Dtug2(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3284      &   FG_COMM1,IERR)
3285         call MPI_Allgatherv(Dtug2der(1,1,ivec_start),
3286      &   ivec_count(fg_rank1),
3287      &   MPI_MAT1,Dtug2der(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3288      &   FG_COMM1,IERR)
3289         call MPI_Allgatherv(EugC(1,1,ivec_start),ivec_count(fg_rank1),
3290      &   MPI_MAT1,EugC(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3291      &   FG_COMM1,IERR)
3292        call MPI_Allgatherv(EugCder(1,1,ivec_start),ivec_count(fg_rank1),
3293      &   MPI_MAT1,EugCder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3294      &   FG_COMM1,IERR)
3295         call MPI_Allgatherv(EugD(1,1,ivec_start),ivec_count(fg_rank1),
3296      &   MPI_MAT1,EugD(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3297      &   FG_COMM1,IERR)
3298        call MPI_Allgatherv(EugDder(1,1,ivec_start),ivec_count(fg_rank1),
3299      &   MPI_MAT1,EugDder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3300      &   FG_COMM1,IERR)
3301         call MPI_Allgatherv(DtUg2EUg(1,1,ivec_start),
3302      &   ivec_count(fg_rank1),
3303      &   MPI_MAT1,DtUg2EUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3304      &   FG_COMM1,IERR)
3305         call MPI_Allgatherv(Ug2DtEUg(1,1,ivec_start),
3306      &   ivec_count(fg_rank1),
3307      &   MPI_MAT1,Ug2DtEUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3308      &   FG_COMM1,IERR)
3309         call MPI_Allgatherv(DtUg2EUgder(1,1,1,ivec_start),
3310      &   ivec_count(fg_rank1),
3311      &   MPI_MAT2,DtUg2EUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
3312      &   MPI_MAT2,FG_COMM1,IERR)
3313         call MPI_Allgatherv(Ug2DtEUgder(1,1,1,ivec_start),
3314      &   ivec_count(fg_rank1),
3315      &   MPI_MAT2,Ug2DtEUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
3316      &   MPI_MAT2,FG_COMM1,IERR)
3317         endif
3318 #endif
3319 #else
3320 c Passes matrix info through the ring
3321       isend=fg_rank1
3322       irecv=fg_rank1-1
3323       if (irecv.lt.0) irecv=nfgtasks1-1
3324       iprev=irecv
3325       inext=fg_rank1+1
3326       if (inext.ge.nfgtasks1) inext=0
3327       do i=1,nfgtasks1-1
3328 c        write (iout,*) "isend",isend," irecv",irecv
3329 c        call flush(iout)
3330         lensend=lentyp(isend)
3331         lenrecv=lentyp(irecv)
3332 c        write (iout,*) "lensend",lensend," lenrecv",lenrecv
3333 c        call MPI_SENDRECV(ug(1,1,ivec_displ(isend)+1),1,
3334 c     &   MPI_ROTAT1(lensend),inext,2200+isend,
3335 c     &   ug(1,1,ivec_displ(irecv)+1),1,MPI_ROTAT1(lenrecv),
3336 c     &   iprev,2200+irecv,FG_COMM,status,IERR)
3337 c        write (iout,*) "Gather ROTAT1"
3338 c        call flush(iout)
3339 c        call MPI_SENDRECV(obrot(1,ivec_displ(isend)+1),1,
3340 c     &   MPI_ROTAT2(lensend),inext,3300+isend,
3341 c     &   obrot(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
3342 c     &   iprev,3300+irecv,FG_COMM,status,IERR)
3343 c        write (iout,*) "Gather ROTAT2"
3344 c        call flush(iout)
3345         call MPI_SENDRECV(costab(ivec_displ(isend)+1),1,
3346      &   MPI_ROTAT_OLD(lensend),inext,4400+isend,
3347      &   costab(ivec_displ(irecv)+1),1,MPI_ROTAT_OLD(lenrecv),
3348      &   iprev,4400+irecv,FG_COMM,status,IERR)
3349 c        write (iout,*) "Gather ROTAT_OLD"
3350 c        call flush(iout)
3351         call MPI_SENDRECV(mu(1,ivec_displ(isend)+1),1,
3352      &   MPI_PRECOMP11(lensend),inext,5500+isend,
3353      &   mu(1,ivec_displ(irecv)+1),1,MPI_PRECOMP11(lenrecv),
3354      &   iprev,5500+irecv,FG_COMM,status,IERR)
3355 c        write (iout,*) "Gather PRECOMP11"
3356 c        call flush(iout)
3357         call MPI_SENDRECV(Eug(1,1,ivec_displ(isend)+1),1,
3358      &   MPI_PRECOMP12(lensend),inext,6600+isend,
3359      &   Eug(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP12(lenrecv),
3360      &   iprev,6600+irecv,FG_COMM,status,IERR)
3361 c        write (iout,*) "Gather PRECOMP12"
3362 c        call flush(iout)
3363 #ifdef FOURBODY
3364         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
3365      &  then
3366         call MPI_SENDRECV(ug2db1t(1,ivec_displ(isend)+1),1,
3367      &   MPI_ROTAT2(lensend),inext,7700+isend,
3368      &   ug2db1t(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
3369      &   iprev,7700+irecv,FG_COMM,status,IERR)
3370 c        write (iout,*) "Gather PRECOMP21"
3371 c        call flush(iout)
3372         call MPI_SENDRECV(EUgC(1,1,ivec_displ(isend)+1),1,
3373      &   MPI_PRECOMP22(lensend),inext,8800+isend,
3374      &   EUgC(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP22(lenrecv),
3375      &   iprev,8800+irecv,FG_COMM,status,IERR)
3376 c        write (iout,*) "Gather PRECOMP22"
3377 c        call flush(iout)
3378         call MPI_SENDRECV(Ug2DtEUgder(1,1,1,ivec_displ(isend)+1),1,
3379      &   MPI_PRECOMP23(lensend),inext,9900+isend,
3380      &   Ug2DtEUgder(1,1,1,ivec_displ(irecv)+1),1,
3381      &   MPI_PRECOMP23(lenrecv),
3382      &   iprev,9900+irecv,FG_COMM,status,IERR)
3383 #endif
3384 c        write (iout,*) "Gather PRECOMP23"
3385 c        call flush(iout)
3386         endif
3387         isend=irecv
3388         irecv=irecv-1
3389         if (irecv.lt.0) irecv=nfgtasks1-1
3390       enddo
3391 #endif
3392         time_gather=time_gather+MPI_Wtime()-time00
3393       endif
3394 #ifdef DEBUG
3395 c      if (fg_rank.eq.0) then
3396         write (iout,*) "Arrays UG and UGDER"
3397         do i=1,nres-1
3398           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3399      &     ((ug(l,k,i),l=1,2),k=1,2),
3400      &     ((ugder(l,k,i),l=1,2),k=1,2)
3401         enddo
3402         write (iout,*) "Arrays UG2 and UG2DER"
3403         do i=1,nres-1
3404           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3405      &     ((ug2(l,k,i),l=1,2),k=1,2),
3406      &     ((ug2der(l,k,i),l=1,2),k=1,2)
3407         enddo
3408         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
3409         do i=1,nres-1
3410           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3411      &     (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
3412      &     (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
3413         enddo
3414         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
3415         do i=1,nres-1
3416           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3417      &     costab(i),sintab(i),costab2(i),sintab2(i)
3418         enddo
3419         write (iout,*) "Array MUDER"
3420         do i=1,nres-1
3421           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
3422         enddo
3423 c      endif
3424 #endif
3425 #endif
3426 cd      do i=1,nres
3427 cd        iti = itype2loc(itype(i))
3428 cd        write (iout,*) i
3429 cd        do j=1,2
3430 cd        write (iout,'(2f10.5,5x,2f10.5,5x,2f10.5)')
3431 cd     &  (EE(j,k,i),k=1,2),(Ug(j,k,i),k=1,2),(EUg(j,k,i),k=1,2)
3432 cd        enddo
3433 cd      enddo
3434       return
3435       end
3436 C-----------------------------------------------------------------------------
3437       subroutine eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
3438 C
3439 C This subroutine calculates the average interaction energy and its gradient
3440 C in the virtual-bond vectors between non-adjacent peptide groups, based on
3441 C the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
3442 C The potential depends both on the distance of peptide-group centers and on
3443 C the orientation of the CA-CA virtual bonds.
3444 C
3445       implicit real*8 (a-h,o-z)
3446 #ifdef MPI
3447       include 'mpif.h'
3448 #endif
3449       include 'DIMENSIONS'
3450       include 'COMMON.CONTROL'
3451       include 'COMMON.SETUP'
3452       include 'COMMON.IOUNITS'
3453       include 'COMMON.GEO'
3454       include 'COMMON.VAR'
3455       include 'COMMON.LOCAL'
3456       include 'COMMON.CHAIN'
3457       include 'COMMON.DERIV'
3458       include 'COMMON.INTERACT'
3459 #ifdef FOURBODY
3460       include 'COMMON.CONTACTS'
3461       include 'COMMON.CONTMAT'
3462 #endif
3463       include 'COMMON.CORRMAT'
3464       include 'COMMON.TORSION'
3465       include 'COMMON.VECTORS'
3466       include 'COMMON.FFIELD'
3467       include 'COMMON.TIME1'
3468       include 'COMMON.SPLITELE'
3469       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
3470      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
3471       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
3472      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4),gmuij(4)
3473       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3474      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3475      &    num_conti,j1,j2
3476 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
3477 #ifdef MOMENT
3478       double precision scal_el /1.0d0/
3479 #else
3480       double precision scal_el /0.5d0/
3481 #endif
3482 C 12/13/98
3483 C 13-go grudnia roku pamietnego...
3484       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
3485      &                   0.0d0,1.0d0,0.0d0,
3486      &                   0.0d0,0.0d0,1.0d0/
3487 cd      write(iout,*) 'In EELEC'
3488 cd      do i=1,nloctyp
3489 cd        write(iout,*) 'Type',i
3490 cd        write(iout,*) 'B1',B1(:,i)
3491 cd        write(iout,*) 'B2',B2(:,i)
3492 cd        write(iout,*) 'CC',CC(:,:,i)
3493 cd        write(iout,*) 'DD',DD(:,:,i)
3494 cd        write(iout,*) 'EE',EE(:,:,i)
3495 cd      enddo
3496 cd      call check_vecgrad
3497 cd      stop
3498       if (icheckgrad.eq.1) then
3499         do i=1,nres-1
3500           fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
3501           do k=1,3
3502             dc_norm(k,i)=dc(k,i)*fac
3503           enddo
3504 c          write (iout,*) 'i',i,' fac',fac
3505         enddo
3506       endif
3507       if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
3508      &    .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or.
3509      &    wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
3510 c        call vec_and_deriv
3511 #ifdef TIMING
3512         time01=MPI_Wtime()
3513 #endif
3514         call set_matrices
3515 #ifdef TIMING
3516         time_mat=time_mat+MPI_Wtime()-time01
3517 #endif
3518       endif
3519 cd      do i=1,nres-1
3520 cd        write (iout,*) 'i=',i
3521 cd        do k=1,3
3522 cd        write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
3523 cd        enddo
3524 cd        do k=1,3
3525 cd          write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
3526 cd     &     uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
3527 cd        enddo
3528 cd      enddo
3529       t_eelecij=0.0d0
3530       ees=0.0D0
3531       evdw1=0.0D0
3532       eel_loc=0.0d0
3533       eello_turn3=0.0d0
3534       eello_turn4=0.0d0
3535       ind=0
3536 #ifdef FOURBODY
3537       do i=1,nres
3538         num_cont_hb(i)=0
3539       enddo
3540 #endif
3541 cd      print '(a)','Enter EELEC'
3542 cd      write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
3543       do i=1,nres
3544         gel_loc_loc(i)=0.0d0
3545         gcorr_loc(i)=0.0d0
3546       enddo
3547 c
3548 c
3549 c 9/27/08 AL Split the interaction loop to ensure load balancing of turn terms
3550 C
3551 C Loop over i,i+2 and i,i+3 pairs of the peptide groups
3552 C
3553 C 14/01/2014 TURN3,TUNR4 does no go under periodic boundry condition
3554       do i=iturn3_start,iturn3_end
3555 c        if (i.le.1) cycle
3556 C        write(iout,*) "tu jest i",i
3557         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
3558 C changes suggested by Ana to avoid out of bounds
3559 C Adam: Unnecessary: handled by iturn3_end and iturn3_start
3560 c     & .or.((i+4).gt.nres)
3561 c     & .or.((i-1).le.0)
3562 C end of changes by Ana
3563      &  .or. itype(i+2).eq.ntyp1
3564      &  .or. itype(i+3).eq.ntyp1) cycle
3565 C Adam: Instructions below will switch off existing interactions
3566 c        if(i.gt.1)then
3567 c          if(itype(i-1).eq.ntyp1)cycle
3568 c        end if
3569 c        if(i.LT.nres-3)then
3570 c          if (itype(i+4).eq.ntyp1) cycle
3571 c        end if
3572         dxi=dc(1,i)
3573         dyi=dc(2,i)
3574         dzi=dc(3,i)
3575         dx_normi=dc_norm(1,i)
3576         dy_normi=dc_norm(2,i)
3577         dz_normi=dc_norm(3,i)
3578         xmedi=c(1,i)+0.5d0*dxi
3579         ymedi=c(2,i)+0.5d0*dyi
3580         zmedi=c(3,i)+0.5d0*dzi
3581         call to_box(xmedi,ymedi,zmedi)
3582         num_conti=0
3583         call eelecij(i,i+2,ees,evdw1,eel_loc)
3584         if (wturn3.gt.0.0d0) call eturn3(i,eello_turn3)
3585 #ifdef FOURBODY
3586         num_cont_hb(i)=num_conti
3587 #endif
3588       enddo
3589       do i=iturn4_start,iturn4_end
3590         if (i.lt.1) cycle
3591         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
3592 C changes suggested by Ana to avoid out of bounds
3593 c     & .or.((i+5).gt.nres)
3594 c     & .or.((i-1).le.0)
3595 C end of changes suggested by Ana
3596      &    .or. itype(i+3).eq.ntyp1
3597      &    .or. itype(i+4).eq.ntyp1
3598 c     &    .or. itype(i+5).eq.ntyp1
3599 c     &    .or. itype(i).eq.ntyp1
3600 c     &    .or. itype(i-1).eq.ntyp1
3601      &                             ) cycle
3602         dxi=dc(1,i)
3603         dyi=dc(2,i)
3604         dzi=dc(3,i)
3605         dx_normi=dc_norm(1,i)
3606         dy_normi=dc_norm(2,i)
3607         dz_normi=dc_norm(3,i)
3608         xmedi=c(1,i)+0.5d0*dxi
3609         ymedi=c(2,i)+0.5d0*dyi
3610         zmedi=c(3,i)+0.5d0*dzi
3611 C Return atom into box, boxxsize is size of box in x dimension
3612 c  194   continue
3613 c        if (xmedi.gt.((0.5d0)*boxxsize)) xmedi=xmedi-boxxsize
3614 c        if (xmedi.lt.((-0.5d0)*boxxsize)) xmedi=xmedi+boxxsize
3615 C Condition for being inside the proper box
3616 c        if ((xmedi.gt.((0.5d0)*boxxsize)).or.
3617 c     &       (xmedi.lt.((-0.5d0)*boxxsize))) then
3618 c        go to 194
3619 c        endif
3620 c  195   continue
3621 c        if (ymedi.gt.((0.5d0)*boxysize)) ymedi=ymedi-boxysize
3622 c        if (ymedi.lt.((-0.5d0)*boxysize)) ymedi=ymedi+boxysize
3623 C Condition for being inside the proper box
3624 c        if ((ymedi.gt.((0.5d0)*boxysize)).or.
3625 c     &       (ymedi.lt.((-0.5d0)*boxysize))) then
3626 c        go to 195
3627 c        endif
3628 c  196   continue
3629 c        if (zmedi.gt.((0.5d0)*boxzsize)) zmedi=zmedi-boxzsize
3630 c        if (zmedi.lt.((-0.5d0)*boxzsize)) zmedi=zmedi+boxzsize
3631 C Condition for being inside the proper box
3632 c        if ((zmedi.gt.((0.5d0)*boxzsize)).or.
3633 c     &       (zmedi.lt.((-0.5d0)*boxzsize))) then
3634 c        go to 196
3635 c        endif
3636         call to_box(xmedi,ymedi,zmedi)
3637 #ifdef FOURBODY
3638         num_conti=num_cont_hb(i)
3639 #endif
3640 c        write(iout,*) "JESTEM W PETLI"
3641         call eelecij(i,i+3,ees,evdw1,eel_loc)
3642         if (wturn4.gt.0.0d0 .and. itype(i+2).ne.ntyp1)
3643      &   call eturn4(i,eello_turn4)
3644 #ifdef FOURBODY
3645         num_cont_hb(i)=num_conti
3646 #endif
3647       enddo   ! i
3648 C Loop over all neighbouring boxes
3649 C      do xshift=-1,1
3650 C      do yshift=-1,1
3651 C      do zshift=-1,1
3652 c
3653 c Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
3654 c
3655 CTU KURWA
3656 c      do i=iatel_s,iatel_e
3657       do ikont=g_listpp_start,g_listpp_end
3658         i=newcontlistppi(ikont)
3659         j=newcontlistppj(ikont)
3660 C        do i=75,75
3661 c        if (i.le.1) cycle
3662         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
3663 C changes suggested by Ana to avoid out of bounds
3664 c     & .or.((i+2).gt.nres)
3665 c     & .or.((i-1).le.0)
3666 C end of changes by Ana
3667 c     &  .or. itype(i+2).eq.ntyp1
3668 c     &  .or. itype(i-1).eq.ntyp1
3669      &                ) cycle
3670         dxi=dc(1,i)
3671         dyi=dc(2,i)
3672         dzi=dc(3,i)
3673         dx_normi=dc_norm(1,i)
3674         dy_normi=dc_norm(2,i)
3675         dz_normi=dc_norm(3,i)
3676         xmedi=c(1,i)+0.5d0*dxi
3677         ymedi=c(2,i)+0.5d0*dyi
3678         zmedi=c(3,i)+0.5d0*dzi
3679         call to_box(xmedi,ymedi,zmedi)
3680 C          xmedi=xmedi+xshift*boxxsize
3681 C          ymedi=ymedi+yshift*boxysize
3682 C          zmedi=zmedi+zshift*boxzsize
3683
3684 C Return tom into box, boxxsize is size of box in x dimension
3685 c  164   continue
3686 c        if (xmedi.gt.((xshift+0.5d0)*boxxsize)) xmedi=xmedi-boxxsize
3687 c        if (xmedi.lt.((xshift-0.5d0)*boxxsize)) xmedi=xmedi+boxxsize
3688 C Condition for being inside the proper box
3689 c        if ((xmedi.gt.((xshift+0.5d0)*boxxsize)).or.
3690 c     &       (xmedi.lt.((xshift-0.5d0)*boxxsize))) then
3691 c        go to 164
3692 c        endif
3693 c  165   continue
3694 c        if (ymedi.gt.((yshift+0.5d0)*boxysize)) ymedi=ymedi-boxysize
3695 c        if (ymedi.lt.((yshift-0.5d0)*boxysize)) ymedi=ymedi+boxysize
3696 C Condition for being inside the proper box
3697 c        if ((ymedi.gt.((yshift+0.5d0)*boxysize)).or.
3698 c     &       (ymedi.lt.((yshift-0.5d0)*boxysize))) then
3699 c        go to 165
3700 c        endif
3701 c  166   continue
3702 c        if (zmedi.gt.((zshift+0.5d0)*boxzsize)) zmedi=zmedi-boxzsize
3703 c        if (zmedi.lt.((zshift-0.5d0)*boxzsize)) zmedi=zmedi+boxzsize
3704 cC Condition for being inside the proper box
3705 c        if ((zmedi.gt.((zshift+0.5d0)*boxzsize)).or.
3706 c     &       (zmedi.lt.((zshift-0.5d0)*boxzsize))) then
3707 c        go to 166
3708 c        endif
3709
3710 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
3711 #ifdef FOURBODY
3712         num_conti=num_cont_hb(i)
3713 #endif
3714 C I TU KURWA
3715 c        do j=ielstart(i),ielend(i)
3716 C          do j=16,17
3717 C          write (iout,*) i,j
3718 C         if (j.le.1) cycle
3719         if (itype(j).eq.ntyp1.or. itype(j+1).eq.ntyp1
3720 C changes suggested by Ana to avoid out of bounds
3721 c     & .or.((j+2).gt.nres)
3722 c     & .or.((j-1).le.0)
3723 C end of changes by Ana
3724 c     & .or.itype(j+2).eq.ntyp1
3725 c     & .or.itype(j-1).eq.ntyp1
3726      &) cycle
3727         call eelecij(i,j,ees,evdw1,eel_loc)
3728 c        enddo ! j
3729 #ifdef FOURBODY
3730         num_cont_hb(i)=num_conti
3731 #endif
3732       enddo   ! i
3733 C     enddo   ! zshift
3734 C      enddo   ! yshift
3735 C      enddo   ! xshift
3736
3737 c      write (iout,*) "Number of loop steps in EELEC:",ind
3738 cd      do i=1,nres
3739 cd        write (iout,'(i3,3f10.5,5x,3f10.5)')
3740 cd     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
3741 cd      enddo
3742 c 12/7/99 Adam eello_turn3 will be considered as a separate energy term
3743 ccc      eel_loc=eel_loc+eello_turn3
3744 cd      print *,"Processor",fg_rank," t_eelecij",t_eelecij
3745       return
3746       end
3747 C-------------------------------------------------------------------------------
3748       subroutine eelecij(i,j,ees,evdw1,eel_loc)
3749       implicit none
3750       include 'DIMENSIONS'
3751 #ifdef MPI
3752       include "mpif.h"
3753 #endif
3754       include 'COMMON.CONTROL'
3755       include 'COMMON.IOUNITS'
3756       include 'COMMON.GEO'
3757       include 'COMMON.VAR'
3758       include 'COMMON.LOCAL'
3759       include 'COMMON.CHAIN'
3760       include 'COMMON.DERIV'
3761       include 'COMMON.INTERACT'
3762 #ifdef FOURBODY
3763       include 'COMMON.CONTACTS'
3764       include 'COMMON.CONTMAT'
3765 #endif
3766       include 'COMMON.CORRMAT'
3767       include 'COMMON.TORSION'
3768       include 'COMMON.VECTORS'
3769       include 'COMMON.FFIELD'
3770       include 'COMMON.TIME1'
3771       include 'COMMON.SPLITELE'
3772       include 'COMMON.SHIELD'
3773       double precision ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
3774      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
3775       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
3776      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4),gmuij1(4),gmuji1(4),
3777      &    gmuij2(4),gmuji2(4)
3778       double precision dxi,dyi,dzi
3779       double precision dx_normi,dy_normi,dz_normi,aux
3780       integer j1,j2,lll,num_conti
3781       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3782      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3783      &    num_conti,j1,j2
3784       integer k,i,j,iteli,itelj,kkk,l,kkll,m,isubchap,ilist,iresshield
3785       double precision ael6i,rrmij,rmij,r0ij,fcont,fprimcont,ees0tmp
3786       double precision ees,evdw1,eel_loc,aaa,bbb,ael3i
3787       double precision dxj,dyj,dzj,dx_normj,dy_normj,dz_normj,xj,yj,zj,
3788      &  rij,r3ij,r6ij,cosa,cosb,cosg,fac,ev1,ev2,fac3,fac4,
3789      &  evdwij,el1,el2,eesij,ees0ij,facvdw,facel,fac1,ecosa,
3790      &  ecosb,ecosg,ury,urz,vry,vrz,facr,a22der,a23der,a32der,
3791      &  a33der,eel_loc_ij,cosa4,wij,cosbg1,cosbg2,ees0pij,
3792      &  ees0pij1,ees0mij,ees0mij1,fac3p,ees0mijp,ees0pijp,
3793      &  ecosa1,ecosb1,ecosg1,ecosa2,ecosb2,ecosg2,ecosap,ecosbp,
3794      &  ecosgp,ecosam,ecosbm,ecosgm,ghalf,rlocshield
3795       double precision a22,a23,a32,a33,geel_loc_ij,geel_loc_ji
3796       double precision xmedi,ymedi,zmedi
3797       double precision sscale,sscagrad,scalar
3798       double precision boxshift
3799 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
3800 #ifdef MOMENT
3801       double precision scal_el /1.0d0/
3802 #else
3803       double precision scal_el /0.5d0/
3804 #endif
3805 C 12/13/98
3806 C 13-go grudnia roku pamietnego...
3807       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
3808      &                   0.0d0,1.0d0,0.0d0,
3809      &                   0.0d0,0.0d0,1.0d0/
3810 c          time00=MPI_Wtime()
3811 cd      write (iout,*) "eelecij",i,j
3812 c          ind=ind+1
3813           iteli=itel(i)
3814           itelj=itel(j)
3815           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
3816           aaa=app(iteli,itelj)
3817           bbb=bpp(iteli,itelj)
3818           ael6i=ael6(iteli,itelj)
3819           ael3i=ael3(iteli,itelj)
3820           dxj=dc(1,j)
3821           dyj=dc(2,j)
3822           dzj=dc(3,j)
3823           dx_normj=dc_norm(1,j)
3824           dy_normj=dc_norm(2,j)
3825           dz_normj=dc_norm(3,j)
3826 C          xj=c(1,j)+0.5D0*dxj-xmedi
3827 C          yj=c(2,j)+0.5D0*dyj-ymedi
3828 C          zj=c(3,j)+0.5D0*dzj-zmedi
3829           xj=c(1,j)+0.5D0*dxj
3830           yj=c(2,j)+0.5D0*dyj
3831           zj=c(3,j)+0.5D0*dzj
3832           call to_box(xj,yj,zj)
3833           xj=boxshift(xj-xmedi,boxxsize)
3834           yj=boxshift(yj-ymedi,boxysize)
3835           zj=boxshift(zj-zmedi,boxzsize)
3836 C        if ((i+3).lt.j) then !this condition keeps for turn3 and turn4 not subject to PBC
3837 c  174   continue
3838           rij=xj*xj+yj*yj+zj*zj
3839
3840           sss=sscale(dsqrt(rij),r_cut_int)
3841           if (sss.eq.0.0d0) return
3842           sssgrad=sscagrad(dsqrt(rij),r_cut_int)
3843 c            if (sss.gt.0.0d0) then
3844           rrmij=1.0D0/rij
3845           rij=dsqrt(rij)
3846           rmij=1.0D0/rij
3847           r3ij=rrmij*rmij
3848           r6ij=r3ij*r3ij
3849           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
3850           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
3851           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
3852           fac=cosa-3.0D0*cosb*cosg
3853           ev1=aaa*r6ij*r6ij
3854 c 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
3855           if (j.eq.i+2) ev1=scal_el*ev1
3856           ev2=bbb*r6ij
3857           fac3=ael6i*r6ij
3858           fac4=ael3i*r3ij
3859           evdwij=(ev1+ev2)
3860           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
3861           el2=fac4*fac
3862 C MARYSIA
3863 C          eesij=(el1+el2)
3864 C 12/26/95 - for the evaluation of multi-body H-bonding interactions
3865           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
3866           if (shield_mode.gt.0) then
3867 C          fac_shield(i)=0.4
3868 C          fac_shield(j)=0.6
3869           el1=el1*fac_shield(i)**2*fac_shield(j)**2
3870           el2=el2*fac_shield(i)**2*fac_shield(j)**2
3871           eesij=(el1+el2)
3872           ees=ees+eesij
3873           else
3874           fac_shield(i)=1.0
3875           fac_shield(j)=1.0
3876           eesij=(el1+el2)
3877           ees=ees+eesij*sss
3878           endif
3879           evdw1=evdw1+evdwij*sss
3880 cd          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
3881 cd     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
3882 cd     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
3883 cd     &      xmedi,ymedi,zmedi,xj,yj,zj
3884
3885           if (energy_dec) then
3886             write (iout,'(a6,2i5,0pf7.3,2i5,e11.3,3f10.5)')
3887      &        'evdw1',i,j,evdwij,iteli,itelj,aaa,evdw1,sss,rij
3888             write (iout,'(a6,2i5,0pf7.3,2f8.3)') 'ees',i,j,eesij,
3889      &        fac_shield(i),fac_shield(j)
3890           endif
3891
3892 C
3893 C Calculate contributions to the Cartesian gradient.
3894 C
3895 #ifdef SPLITELE
3896           facvdw=-6*rrmij*(ev1+evdwij)*sss
3897           facel=-3*rrmij*(el1+eesij)
3898           fac1=fac
3899           erij(1)=xj*rmij
3900           erij(2)=yj*rmij
3901           erij(3)=zj*rmij
3902
3903 *
3904 * Radial derivatives. First process both termini of the fragment (i,j)
3905 *
3906           aux=facel*sss+rmij*sssgrad*eesij
3907           ggg(1)=aux*xj
3908           ggg(2)=aux*yj
3909           ggg(3)=aux*zj
3910           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
3911      &  (shield_mode.gt.0)) then
3912 C          print *,i,j
3913           do ilist=1,ishield_list(i)
3914            iresshield=shield_list(ilist,i)
3915            do k=1,3
3916            rlocshield=grad_shield_side(k,ilist,i)*eesij/fac_shield(i)
3917      &      *2.0
3918            gshieldx(k,iresshield)=gshieldx(k,iresshield)+
3919      &              rlocshield
3920      & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)*2.0
3921             gshieldc(k,iresshield-1)=gshieldc(k,iresshield-1)+rlocshield
3922 C           gshieldc_loc(k,iresshield)=gshieldc_loc(k,iresshield)
3923 C     & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)
3924 C             if (iresshield.gt.i) then
3925 C               do ishi=i+1,iresshield-1
3926 C                gshieldc(k,ishi)=gshieldc(k,ishi)+rlocshield
3927 C     & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)
3928 C
3929 C              enddo
3930 C             else
3931 C               do ishi=iresshield,i
3932 C                gshieldc(k,ishi)=gshieldc(k,ishi)-rlocshield
3933 C     & -grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)
3934 C
3935 C               enddo
3936 C              endif
3937            enddo
3938           enddo
3939           do ilist=1,ishield_list(j)
3940            iresshield=shield_list(ilist,j)
3941            do k=1,3
3942            rlocshield=grad_shield_side(k,ilist,j)*eesij/fac_shield(j)
3943      &     *2.0*sss
3944            gshieldx(k,iresshield)=gshieldx(k,iresshield)+
3945      &              rlocshield
3946      & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)*2.0*sss
3947            gshieldc(k,iresshield-1)=gshieldc(k,iresshield-1)+rlocshield
3948
3949 C     & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
3950 C           gshieldc_loc(k,iresshield)=gshieldc_loc(k,iresshield)
3951 C     & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
3952 C             if (iresshield.gt.j) then
3953 C               do ishi=j+1,iresshield-1
3954 C                gshieldc(k,ishi)=gshieldc(k,ishi)+rlocshield
3955 C     & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
3956 C
3957 C               enddo
3958 C            else
3959 C               do ishi=iresshield,j
3960 C                gshieldc(k,ishi)=gshieldc(k,ishi)-rlocshield
3961 C     & -grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
3962 C               enddo
3963 C              endif
3964            enddo
3965           enddo
3966
3967           do k=1,3
3968             gshieldc(k,i)=gshieldc(k,i)+
3969      &              grad_shield(k,i)*eesij/fac_shield(i)*2.0*sss
3970             gshieldc(k,j)=gshieldc(k,j)+
3971      &              grad_shield(k,j)*eesij/fac_shield(j)*2.0*sss
3972             gshieldc(k,i-1)=gshieldc(k,i-1)+
3973      &              grad_shield(k,i)*eesij/fac_shield(i)*2.0*sss
3974             gshieldc(k,j-1)=gshieldc(k,j-1)+
3975      &              grad_shield(k,j)*eesij/fac_shield(j)*2.0*sss
3976
3977            enddo
3978            endif
3979 c          do k=1,3
3980 c            ghalf=0.5D0*ggg(k)
3981 c            gelc(k,i)=gelc(k,i)+ghalf
3982 c            gelc(k,j)=gelc(k,j)+ghalf
3983 c          enddo
3984 c 9/28/08 AL Gradient compotents will be summed only at the end
3985 C           print *,"before", gelc_long(1,i), gelc_long(1,j)
3986           do k=1,3
3987             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
3988 C     &                    +grad_shield(k,j)*eesij/fac_shield(j)
3989             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
3990 C     &                    +grad_shield(k,i)*eesij/fac_shield(i)
3991 C            gelc_long(k,i-1)=gelc_long(k,i-1)
3992 C     &                    +grad_shield(k,i)*eesij/fac_shield(i)
3993 C            gelc_long(k,j-1)=gelc_long(k,j-1)
3994 C     &                    +grad_shield(k,j)*eesij/fac_shield(j)
3995           enddo
3996 C           print *,"bafter", gelc_long(1,i), gelc_long(1,j)
3997
3998 *
3999 * Loop over residues i+1 thru j-1.
4000 *
4001 cgrad          do k=i+1,j-1
4002 cgrad            do l=1,3
4003 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
4004 cgrad            enddo
4005 cgrad          enddo
4006           facvdw=facvdw+sssgrad*rmij*evdwij
4007           ggg(1)=facvdw*xj
4008           ggg(2)=facvdw*yj
4009           ggg(3)=facvdw*zj
4010 c          do k=1,3
4011 c            ghalf=0.5D0*ggg(k)
4012 c            gvdwpp(k,i)=gvdwpp(k,i)+ghalf
4013 c            gvdwpp(k,j)=gvdwpp(k,j)+ghalf
4014 c          enddo
4015 c 9/28/08 AL Gradient compotents will be summed only at the end
4016           do k=1,3
4017             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
4018             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
4019           enddo
4020 *
4021 * Loop over residues i+1 thru j-1.
4022 *
4023 cgrad          do k=i+1,j-1
4024 cgrad            do l=1,3
4025 cgrad              gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
4026 cgrad            enddo
4027 cgrad          enddo
4028 #else
4029 C MARYSIA
4030           facvdw=(ev1+evdwij)
4031           facel=(el1+eesij)
4032           fac1=fac
4033           fac=-3*rrmij*(facvdw+facvdw+facel)*sss
4034      &       +(evdwij+eesij)*sssgrad*rrmij
4035           erij(1)=xj*rmij
4036           erij(2)=yj*rmij
4037           erij(3)=zj*rmij
4038 *
4039 * Radial derivatives. First process both termini of the fragment (i,j)
4040 *
4041           ggg(1)=fac*xj
4042 C+eesij*grad_shield(1,i)+eesij*grad_shield(1,j)
4043           ggg(2)=fac*yj
4044 C+eesij*grad_shield(2,i)+eesij*grad_shield(2,j)
4045           ggg(3)=fac*zj
4046 C+eesij*grad_shield(3,i)+eesij*grad_shield(3,j)
4047 c          do k=1,3
4048 c            ghalf=0.5D0*ggg(k)
4049 c            gelc(k,i)=gelc(k,i)+ghalf
4050 c            gelc(k,j)=gelc(k,j)+ghalf
4051 c          enddo
4052 c 9/28/08 AL Gradient compotents will be summed only at the end
4053           do k=1,3
4054             gelc_long(k,j)=gelc(k,j)+ggg(k)
4055             gelc_long(k,i)=gelc(k,i)-ggg(k)
4056           enddo
4057 *
4058 * Loop over residues i+1 thru j-1.
4059 *
4060 cgrad          do k=i+1,j-1
4061 cgrad            do l=1,3
4062 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
4063 cgrad            enddo
4064 cgrad          enddo
4065 c 9/28/08 AL Gradient compotents will be summed only at the end
4066           ggg(1)=facvdw*xj+sssgrad*rmij*evdwij*xj
4067           ggg(2)=facvdw*yj+sssgrad*rmij*evdwij*yj
4068           ggg(3)=facvdw*zj+sssgrad*rmij*evdwij*zj
4069           do k=1,3
4070             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
4071             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
4072           enddo
4073 #endif
4074 *
4075 * Angular part
4076 *
4077           ecosa=2.0D0*fac3*fac1+fac4
4078           fac4=-3.0D0*fac4
4079           fac3=-6.0D0*fac3
4080           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
4081           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
4082           do k=1,3
4083             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
4084             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
4085           enddo
4086 cd        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
4087 cd   &          (dcosg(k),k=1,3)
4088           do k=1,3
4089             ggg(k)=(ecosb*dcosb(k)+ecosg*dcosg(k))*
4090      &      fac_shield(i)**2*fac_shield(j)**2*sss
4091           enddo
4092 c          do k=1,3
4093 c            ghalf=0.5D0*ggg(k)
4094 c            gelc(k,i)=gelc(k,i)+ghalf
4095 c     &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
4096 c     &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
4097 c            gelc(k,j)=gelc(k,j)+ghalf
4098 c     &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
4099 c     &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
4100 c          enddo
4101 cgrad          do k=i+1,j-1
4102 cgrad            do l=1,3
4103 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
4104 cgrad            enddo
4105 cgrad          enddo
4106 C                     print *,"before22", gelc_long(1,i), gelc_long(1,j)
4107           do k=1,3
4108             gelc(k,i)=gelc(k,i)
4109      &           +((ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
4110      &           + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1))*sss
4111      &           *fac_shield(i)**2*fac_shield(j)**2
4112             gelc(k,j)=gelc(k,j)
4113      &           +((ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
4114      &           + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1))*sss
4115      &           *fac_shield(i)**2*fac_shield(j)**2
4116             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
4117             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
4118           enddo
4119 C           print *,"before33", gelc_long(1,i), gelc_long(1,j)
4120
4121 C MARYSIA
4122 c          endif !sscale
4123           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
4124      &        .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0
4125      &        .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
4126 C
4127 C 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
4128 C   energy of a peptide unit is assumed in the form of a second-order
4129 C   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
4130 C   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
4131 C   are computed for EVERY pair of non-contiguous peptide groups.
4132 C
4133
4134           if (j.lt.nres-1) then
4135             j1=j+1
4136             j2=j-1
4137           else
4138             j1=j-1
4139             j2=j-2
4140           endif
4141           kkk=0
4142           lll=0
4143           do k=1,2
4144             do l=1,2
4145               kkk=kkk+1
4146               muij(kkk)=mu(k,i)*mu(l,j)
4147 c              write(iout,*) 'mumu=', mu(k,i),mu(l,j),i,j,k,l
4148 #ifdef NEWCORR
4149              gmuij1(kkk)=gtb1(k,i+1)*mu(l,j)
4150 c             write(iout,*) 'k=',k,i,gtb1(k,i+1),gtb1(k,i+1)*mu(l,j)
4151              gmuij2(kkk)=gUb2(k,i)*mu(l,j)
4152              gmuji1(kkk)=mu(k,i)*gtb1(l,j+1)
4153 c             write(iout,*) 'l=',l,j,gtb1(l,j+1),gtb1(l,j+1)*mu(k,i)
4154              gmuji2(kkk)=mu(k,i)*gUb2(l,j)
4155 #endif
4156             enddo
4157           enddo
4158 #ifdef DEBUG
4159           write (iout,*) 'EELEC: i',i,' j',j
4160           write (iout,*) 'j',j,' j1',j1,' j2',j2
4161           write(iout,*) 'muij',muij
4162 #endif
4163           ury=scalar(uy(1,i),erij)
4164           urz=scalar(uz(1,i),erij)
4165           vry=scalar(uy(1,j),erij)
4166           vrz=scalar(uz(1,j),erij)
4167           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
4168           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
4169           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
4170           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
4171           fac=dsqrt(-ael6i)*r3ij
4172 #ifdef DEBUG
4173           write (iout,*) "ury",ury," urz",urz," vry",vry," vrz",vrz
4174           write (iout,*) "uyvy",scalar(uy(1,i),uy(1,j)),
4175      &      "uyvz",scalar(uy(1,i),uz(1,j)),
4176      &      "uzvy",scalar(uz(1,i),uy(1,j)),
4177      &      "uzvz",scalar(uz(1,i),uz(1,j))
4178           write (iout,*) "a22",a22," a23",a23," a32",a32," a33",a33
4179           write (iout,*) "fac",fac
4180 #endif
4181           a22=a22*fac
4182           a23=a23*fac
4183           a32=a32*fac
4184           a33=a33*fac
4185 #ifdef DEBUG
4186           write (iout,*) "a22",a22," a23",a23," a32",a32," a33",a33
4187 #endif
4188 #undef DEBUG
4189 cd          write (iout,'(4i5,4f10.5)')
4190 cd     &     i,itortyp(itype(i)),j,itortyp(itype(j)),a22,a23,a32,a33
4191 cd          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
4192 cd          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') uy(:,i),uz(:,i),
4193 cd     &      uy(:,j),uz(:,j)
4194 cd          write (iout,'(4f10.5)')
4195 cd     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
4196 cd     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
4197 cd          write (iout,'(4f10.5)') ury,urz,vry,vrz
4198 cd           write (iout,'(9f10.5/)')
4199 cd     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
4200 C Derivatives of the elements of A in virtual-bond vectors
4201           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
4202           do k=1,3
4203             uryg(k,1)=scalar(erder(1,k),uy(1,i))
4204             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
4205             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
4206             urzg(k,1)=scalar(erder(1,k),uz(1,i))
4207             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
4208             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
4209             vryg(k,1)=scalar(erder(1,k),uy(1,j))
4210             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
4211             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
4212             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
4213             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
4214             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
4215           enddo
4216 C Compute radial contributions to the gradient
4217           facr=-3.0d0*rrmij
4218           a22der=a22*facr
4219           a23der=a23*facr
4220           a32der=a32*facr
4221           a33der=a33*facr
4222           agg(1,1)=a22der*xj
4223           agg(2,1)=a22der*yj
4224           agg(3,1)=a22der*zj
4225           agg(1,2)=a23der*xj
4226           agg(2,2)=a23der*yj
4227           agg(3,2)=a23der*zj
4228           agg(1,3)=a32der*xj
4229           agg(2,3)=a32der*yj
4230           agg(3,3)=a32der*zj
4231           agg(1,4)=a33der*xj
4232           agg(2,4)=a33der*yj
4233           agg(3,4)=a33der*zj
4234 C Add the contributions coming from er
4235           fac3=-3.0d0*fac
4236           do k=1,3
4237             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
4238             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
4239             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
4240             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
4241           enddo
4242           do k=1,3
4243 C Derivatives in DC(i)
4244 cgrad            ghalf1=0.5d0*agg(k,1)
4245 cgrad            ghalf2=0.5d0*agg(k,2)
4246 cgrad            ghalf3=0.5d0*agg(k,3)
4247 cgrad            ghalf4=0.5d0*agg(k,4)
4248             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j))
4249      &      -3.0d0*uryg(k,2)*vry)!+ghalf1
4250             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j))
4251      &      -3.0d0*uryg(k,2)*vrz)!+ghalf2
4252             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j))
4253      &      -3.0d0*urzg(k,2)*vry)!+ghalf3
4254             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j))
4255      &      -3.0d0*urzg(k,2)*vrz)!+ghalf4
4256 C Derivatives in DC(i+1)
4257             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j))
4258      &      -3.0d0*uryg(k,3)*vry)!+agg(k,1)
4259             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j))
4260      &      -3.0d0*uryg(k,3)*vrz)!+agg(k,2)
4261             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j))
4262      &      -3.0d0*urzg(k,3)*vry)!+agg(k,3)
4263             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j))
4264      &      -3.0d0*urzg(k,3)*vrz)!+agg(k,4)
4265 C Derivatives in DC(j)
4266             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i))
4267      &      -3.0d0*vryg(k,2)*ury)!+ghalf1
4268             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i))
4269      &      -3.0d0*vrzg(k,2)*ury)!+ghalf2
4270             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i))
4271      &      -3.0d0*vryg(k,2)*urz)!+ghalf3
4272             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i))
4273      &      -3.0d0*vrzg(k,2)*urz)!+ghalf4
4274 C Derivatives in DC(j+1) or DC(nres-1)
4275             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i))
4276      &      -3.0d0*vryg(k,3)*ury)
4277             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i))
4278      &      -3.0d0*vrzg(k,3)*ury)
4279             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i))
4280      &      -3.0d0*vryg(k,3)*urz)
4281             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i))
4282      &      -3.0d0*vrzg(k,3)*urz)
4283 cgrad            if (j.eq.nres-1 .and. i.lt.j-2) then
4284 cgrad              do l=1,4
4285 cgrad                aggj1(k,l)=aggj1(k,l)+agg(k,l)
4286 cgrad              enddo
4287 cgrad            endif
4288           enddo
4289           acipa(1,1)=a22
4290           acipa(1,2)=a23
4291           acipa(2,1)=a32
4292           acipa(2,2)=a33
4293           a22=-a22
4294           a23=-a23
4295           do l=1,2
4296             do k=1,3
4297               agg(k,l)=-agg(k,l)
4298               aggi(k,l)=-aggi(k,l)
4299               aggi1(k,l)=-aggi1(k,l)
4300               aggj(k,l)=-aggj(k,l)
4301               aggj1(k,l)=-aggj1(k,l)
4302             enddo
4303           enddo
4304           if (j.lt.nres-1) then
4305             a22=-a22
4306             a32=-a32
4307             do l=1,3,2
4308               do k=1,3
4309                 agg(k,l)=-agg(k,l)
4310                 aggi(k,l)=-aggi(k,l)
4311                 aggi1(k,l)=-aggi1(k,l)
4312                 aggj(k,l)=-aggj(k,l)
4313                 aggj1(k,l)=-aggj1(k,l)
4314               enddo
4315             enddo
4316           else
4317             a22=-a22
4318             a23=-a23
4319             a32=-a32
4320             a33=-a33
4321             do l=1,4
4322               do k=1,3
4323                 agg(k,l)=-agg(k,l)
4324                 aggi(k,l)=-aggi(k,l)
4325                 aggi1(k,l)=-aggi1(k,l)
4326                 aggj(k,l)=-aggj(k,l)
4327                 aggj1(k,l)=-aggj1(k,l)
4328               enddo
4329             enddo
4330           endif
4331           ENDIF ! WCORR
4332           IF (wel_loc.gt.0.0d0) THEN
4333 C Contribution to the local-electrostatic energy coming from the i-j pair
4334           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3)
4335      &     +a33*muij(4)
4336 #ifdef DEBUG
4337           write (iout,*) "muij",muij," a22",a22," a23",a23," a32",a32,
4338      &     " a33",a33
4339           write (iout,*) "ij",i,j," eel_loc_ij",eel_loc_ij,
4340      &     " wel_loc",wel_loc
4341 #endif
4342           if (shield_mode.eq.0) then
4343            fac_shield(i)=1.0
4344            fac_shield(j)=1.0
4345 C          else
4346 C           fac_shield(i)=0.4
4347 C           fac_shield(j)=0.6
4348           endif
4349           eel_loc_ij=eel_loc_ij
4350      &    *fac_shield(i)*fac_shield(j)*sss
4351 c          if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
4352 c     &            'eelloc',i,j,eel_loc_ij
4353 C Now derivative over eel_loc
4354           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
4355      &  (shield_mode.gt.0)) then
4356 C          print *,i,j
4357
4358           do ilist=1,ishield_list(i)
4359            iresshield=shield_list(ilist,i)
4360            do k=1,3
4361            rlocshield=grad_shield_side(k,ilist,i)*eel_loc_ij
4362      &                                          /fac_shield(i)
4363 C     &      *2.0
4364            gshieldx_ll(k,iresshield)=gshieldx_ll(k,iresshield)+
4365      &              rlocshield
4366      & +grad_shield_loc(k,ilist,i)*eel_loc_ij/fac_shield(i)
4367             gshieldc_ll(k,iresshield-1)=gshieldc_ll(k,iresshield-1)
4368      &      +rlocshield
4369            enddo
4370           enddo
4371           do ilist=1,ishield_list(j)
4372            iresshield=shield_list(ilist,j)
4373            do k=1,3
4374            rlocshield=grad_shield_side(k,ilist,j)*eel_loc_ij
4375      &                                       /fac_shield(j)
4376 C     &     *2.0
4377            gshieldx_ll(k,iresshield)=gshieldx_ll(k,iresshield)+
4378      &              rlocshield
4379      & +grad_shield_loc(k,ilist,j)*eel_loc_ij/fac_shield(j)
4380            gshieldc_ll(k,iresshield-1)=gshieldc_ll(k,iresshield-1)
4381      &             +rlocshield
4382
4383            enddo
4384           enddo
4385
4386           do k=1,3
4387             gshieldc_ll(k,i)=gshieldc_ll(k,i)+
4388      &              grad_shield(k,i)*eel_loc_ij/fac_shield(i)
4389             gshieldc_ll(k,j)=gshieldc_ll(k,j)+
4390      &              grad_shield(k,j)*eel_loc_ij/fac_shield(j)
4391             gshieldc_ll(k,i-1)=gshieldc_ll(k,i-1)+
4392      &              grad_shield(k,i)*eel_loc_ij/fac_shield(i)
4393             gshieldc_ll(k,j-1)=gshieldc_ll(k,j-1)+
4394      &              grad_shield(k,j)*eel_loc_ij/fac_shield(j)
4395            enddo
4396            endif
4397
4398
4399 c          write (iout,*) 'i',i,' j',j,itype(i),itype(j),
4400 c     &                     ' eel_loc_ij',eel_loc_ij
4401 C          write(iout,*) 'muije=',i,j,muij(1),muij(2),muij(3),muij(4)
4402 C Calculate patrial derivative for theta angle
4403 #ifdef NEWCORR
4404          geel_loc_ij=(a22*gmuij1(1)
4405      &     +a23*gmuij1(2)
4406      &     +a32*gmuij1(3)
4407      &     +a33*gmuij1(4))
4408      &    *fac_shield(i)*fac_shield(j)*sss
4409 c         write(iout,*) "derivative over thatai"
4410 c         write(iout,*) a22*gmuij1(1), a23*gmuij1(2) ,a32*gmuij1(3),
4411 c     &   a33*gmuij1(4)
4412          gloc(nphi+i,icg)=gloc(nphi+i,icg)+
4413      &      geel_loc_ij*wel_loc
4414 c         write(iout,*) "derivative over thatai-1"
4415 c         write(iout,*) a22*gmuij2(1), a23*gmuij2(2) ,a32*gmuij2(3),
4416 c     &   a33*gmuij2(4)
4417          geel_loc_ij=
4418      &     a22*gmuij2(1)
4419      &     +a23*gmuij2(2)
4420      &     +a32*gmuij2(3)
4421      &     +a33*gmuij2(4)
4422          gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
4423      &      geel_loc_ij*wel_loc
4424      &    *fac_shield(i)*fac_shield(j)*sss
4425
4426 c  Derivative over j residue
4427          geel_loc_ji=a22*gmuji1(1)
4428      &     +a23*gmuji1(2)
4429      &     +a32*gmuji1(3)
4430      &     +a33*gmuji1(4)
4431 c         write(iout,*) "derivative over thataj"
4432 c         write(iout,*) a22*gmuji1(1), a23*gmuji1(2) ,a32*gmuji1(3),
4433 c     &   a33*gmuji1(4)
4434
4435         gloc(nphi+j,icg)=gloc(nphi+j,icg)+
4436      &      geel_loc_ji*wel_loc
4437      &    *fac_shield(i)*fac_shield(j)*sss
4438
4439          geel_loc_ji=
4440      &     +a22*gmuji2(1)
4441      &     +a23*gmuji2(2)
4442      &     +a32*gmuji2(3)
4443      &     +a33*gmuji2(4)
4444 c         write(iout,*) "derivative over thataj-1"
4445 c         write(iout,*) a22*gmuji2(1), a23*gmuji2(2) ,a32*gmuji2(3),
4446 c     &   a33*gmuji2(4)
4447          gloc(nphi+j-1,icg)=gloc(nphi+j-1,icg)+
4448      &      geel_loc_ji*wel_loc
4449      &    *fac_shield(i)*fac_shield(j)*sss
4450 #endif
4451 cd          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
4452
4453           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
4454      &            'eelloc',i,j,eel_loc_ij
4455 c           if (eel_loc_ij.ne.0)
4456 c     &      write (iout,'(a4,2i4,8f9.5)')'chuj',
4457 c     &     i,j,a22,muij(1),a23,muij(2),a32,muij(3),a33,muij(4)
4458
4459           eel_loc=eel_loc+eel_loc_ij
4460 C Partial derivatives in virtual-bond dihedral angles gamma
4461           if (i.gt.1)
4462      &    gel_loc_loc(i-1)=gel_loc_loc(i-1)+
4463      &            (a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j)
4464      &           +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j))
4465      &    *fac_shield(i)*fac_shield(j)*sss
4466
4467           gel_loc_loc(j-1)=gel_loc_loc(j-1)+
4468      &           (a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j)
4469      &           +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j))
4470      &    *fac_shield(i)*fac_shield(j)*sss
4471 C Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
4472           aux=eel_loc_ij/sss*sssgrad*rmij
4473           ggg(1)=aux*xj
4474           ggg(2)=aux*yj
4475           ggg(3)=aux*zj
4476           do l=1,3
4477             ggg(l)=ggg(l)+(agg(l,1)*muij(1)+
4478      &          agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4))
4479      &    *fac_shield(i)*fac_shield(j)*sss
4480             gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l)
4481             gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l)
4482 cgrad            ghalf=0.5d0*ggg(l)
4483 cgrad            gel_loc(l,i)=gel_loc(l,i)+ghalf
4484 cgrad            gel_loc(l,j)=gel_loc(l,j)+ghalf
4485           enddo
4486 cgrad          do k=i+1,j2
4487 cgrad            do l=1,3
4488 cgrad              gel_loc(l,k)=gel_loc(l,k)+ggg(l)
4489 cgrad            enddo
4490 cgrad          enddo
4491 C Remaining derivatives of eello
4492           do l=1,3
4493             gel_loc(l,i)=gel_loc(l,i)+(aggi(l,1)*muij(1)+
4494      &        aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4))
4495      &    *fac_shield(i)*fac_shield(j)*sss
4496
4497             gel_loc(l,i+1)=gel_loc(l,i+1)+(aggi1(l,1)*muij(1)+
4498      &     aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4))
4499      &    *fac_shield(i)*fac_shield(j)*sss
4500
4501             gel_loc(l,j)=gel_loc(l,j)+(aggj(l,1)*muij(1)+
4502      &       aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4))
4503      &    *fac_shield(i)*fac_shield(j)*sss
4504
4505             gel_loc(l,j1)=gel_loc(l,j1)+(aggj1(l,1)*muij(1)+
4506      &     aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4))
4507      &    *fac_shield(i)*fac_shield(j)*sss
4508
4509           enddo
4510           ENDIF
4511 C Change 12/26/95 to calculate four-body contributions to H-bonding energy
4512 c          if (j.gt.i+1 .and. num_conti.le.maxconts) then
4513 #ifdef FOURBODY
4514           if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0
4515      &       .and. num_conti.le.maxconts) then
4516 c            write (iout,*) i,j," entered corr"
4517 C
4518 C Calculate the contact function. The ith column of the array JCONT will
4519 C contain the numbers of atoms that make contacts with the atom I (of numbers
4520 C greater than I). The arrays FACONT and GACONT will contain the values of
4521 C the contact function and its derivative.
4522 c           r0ij=1.02D0*rpp(iteli,itelj)
4523 c           r0ij=1.11D0*rpp(iteli,itelj)
4524             r0ij=2.20D0*rpp(iteli,itelj)
4525 c           r0ij=1.55D0*rpp(iteli,itelj)
4526             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
4527             if (fcont.gt.0.0D0) then
4528               num_conti=num_conti+1
4529               if (num_conti.gt.maxconts) then
4530                 write (iout,*) 'WARNING - max. # of contacts exceeded;',
4531      &                         ' will skip next contacts for this conf.'
4532               else
4533                 jcont_hb(num_conti,i)=j
4534 cd                write (iout,*) "i",i," j",j," num_conti",num_conti,
4535 cd     &           " jcont_hb",jcont_hb(num_conti,i)
4536                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.
4537      &          wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
4538 C 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
4539 C  terms.
4540                 d_cont(num_conti,i)=rij
4541 cd                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
4542 C     --- Electrostatic-interaction matrix ---
4543                 a_chuj(1,1,num_conti,i)=a22
4544                 a_chuj(1,2,num_conti,i)=a23
4545                 a_chuj(2,1,num_conti,i)=a32
4546                 a_chuj(2,2,num_conti,i)=a33
4547 C     --- Gradient of rij
4548                 do kkk=1,3
4549                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
4550                 enddo
4551                 kkll=0
4552                 do k=1,2
4553                   do l=1,2
4554                     kkll=kkll+1
4555                     do m=1,3
4556                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
4557                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
4558                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
4559                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
4560                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
4561                     enddo
4562                   enddo
4563                 enddo
4564                 ENDIF
4565                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
4566 C Calculate contact energies
4567                 cosa4=4.0D0*cosa
4568                 wij=cosa-3.0D0*cosb*cosg
4569                 cosbg1=cosb+cosg
4570                 cosbg2=cosb-cosg
4571 c               fac3=dsqrt(-ael6i)/r0ij**3
4572                 fac3=dsqrt(-ael6i)*r3ij
4573 c                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
4574                 ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
4575                 if (ees0tmp.gt.0) then
4576                   ees0pij=dsqrt(ees0tmp)
4577                 else
4578                   ees0pij=0
4579                 endif
4580 c                ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
4581                 ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
4582                 if (ees0tmp.gt.0) then
4583                   ees0mij=dsqrt(ees0tmp)
4584                 else
4585                   ees0mij=0
4586                 endif
4587 c               ees0mij=0.0D0
4588                 if (shield_mode.eq.0) then
4589                 fac_shield(i)=1.0d0
4590                 fac_shield(j)=1.0d0
4591                 else
4592                 ees0plist(num_conti,i)=j
4593 C                fac_shield(i)=0.4d0
4594 C                fac_shield(j)=0.6d0
4595                 endif
4596                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij)
4597      &          *fac_shield(i)*fac_shield(j)*sss
4598                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij)
4599      &          *fac_shield(i)*fac_shield(j)*sss
4600 C Diagnostics. Comment out or remove after debugging!
4601 c               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
4602 c               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
4603 c               ees0m(num_conti,i)=0.0D0
4604 C End diagnostics.
4605 c               write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
4606 c    & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
4607 C Angular derivatives of the contact function
4608                 ees0pij1=fac3/ees0pij
4609                 ees0mij1=fac3/ees0mij
4610                 fac3p=-3.0D0*fac3*rrmij
4611                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
4612                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
4613 c               ees0mij1=0.0D0
4614                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
4615                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
4616                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
4617                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
4618                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
4619                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
4620                 ecosap=ecosa1+ecosa2
4621                 ecosbp=ecosb1+ecosb2
4622                 ecosgp=ecosg1+ecosg2
4623                 ecosam=ecosa1-ecosa2
4624                 ecosbm=ecosb1-ecosb2
4625                 ecosgm=ecosg1-ecosg2
4626 C Diagnostics
4627 c               ecosap=ecosa1
4628 c               ecosbp=ecosb1
4629 c               ecosgp=ecosg1
4630 c               ecosam=0.0D0
4631 c               ecosbm=0.0D0
4632 c               ecosgm=0.0D0
4633 C End diagnostics
4634                 facont_hb(num_conti,i)=fcont
4635                 fprimcont=fprimcont/rij
4636 cd              facont_hb(num_conti,i)=1.0D0
4637 C Following line is for diagnostics.
4638 cd              fprimcont=0.0D0
4639                 do k=1,3
4640                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
4641                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
4642                 enddo
4643                 do k=1,3
4644                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
4645                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
4646                 enddo
4647                 gggp(1)=gggp(1)+ees0pijp*xj
4648      &          +ees0p(num_conti,i)/sss*rmij*xj*sssgrad
4649                 gggp(2)=gggp(2)+ees0pijp*yj
4650      &          +ees0p(num_conti,i)/sss*rmij*yj*sssgrad
4651                 gggp(3)=gggp(3)+ees0pijp*zj
4652      &          +ees0p(num_conti,i)/sss*rmij*zj*sssgrad
4653                 gggm(1)=gggm(1)+ees0mijp*xj
4654      &          +ees0m(num_conti,i)/sss*rmij*xj*sssgrad
4655                 gggm(2)=gggm(2)+ees0mijp*yj
4656      &          +ees0m(num_conti,i)/sss*rmij*yj*sssgrad
4657                 gggm(3)=gggm(3)+ees0mijp*zj
4658      &          +ees0m(num_conti,i)/sss*rmij*zj*sssgrad
4659 C Derivatives due to the contact function
4660                 gacont_hbr(1,num_conti,i)=fprimcont*xj
4661                 gacont_hbr(2,num_conti,i)=fprimcont*yj
4662                 gacont_hbr(3,num_conti,i)=fprimcont*zj
4663                 do k=1,3
4664 c
4665 c 10/24/08 cgrad and ! comments indicate the parts of the code removed
4666 c          following the change of gradient-summation algorithm.
4667 c
4668 cgrad                  ghalfp=0.5D0*gggp(k)
4669 cgrad                  ghalfm=0.5D0*gggm(k)
4670                   gacontp_hb1(k,num_conti,i)=!ghalfp
4671      &              +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i))
4672      &              + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
4673      &          *fac_shield(i)*fac_shield(j)*sss
4674
4675                   gacontp_hb2(k,num_conti,i)=!ghalfp
4676      &              +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j))
4677      &              + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
4678      &          *fac_shield(i)*fac_shield(j)*sss
4679
4680                   gacontp_hb3(k,num_conti,i)=gggp(k)
4681      &          *fac_shield(i)*fac_shield(j)*sss
4682
4683                   gacontm_hb1(k,num_conti,i)=!ghalfm
4684      &              +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i))
4685      &              + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
4686      &          *fac_shield(i)*fac_shield(j)*sss
4687
4688                   gacontm_hb2(k,num_conti,i)=!ghalfm
4689      &              +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j))
4690      &              + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
4691      &          *fac_shield(i)*fac_shield(j)*sss
4692
4693                   gacontm_hb3(k,num_conti,i)=gggm(k)
4694      &          *fac_shield(i)*fac_shield(j)*sss
4695
4696                 enddo
4697 C Diagnostics. Comment out or remove after debugging!
4698 cdiag           do k=1,3
4699 cdiag             gacontp_hb1(k,num_conti,i)=0.0D0
4700 cdiag             gacontp_hb2(k,num_conti,i)=0.0D0
4701 cdiag             gacontp_hb3(k,num_conti,i)=0.0D0
4702 cdiag             gacontm_hb1(k,num_conti,i)=0.0D0
4703 cdiag             gacontm_hb2(k,num_conti,i)=0.0D0
4704 cdiag             gacontm_hb3(k,num_conti,i)=0.0D0
4705 cdiag           enddo
4706               ENDIF ! wcorr
4707               endif  ! num_conti.le.maxconts
4708             endif  ! fcont.gt.0
4709           endif    ! j.gt.i+1
4710 #endif
4711           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
4712             do k=1,4
4713               do l=1,3
4714                 ghalf=0.5d0*agg(l,k)
4715                 aggi(l,k)=aggi(l,k)+ghalf
4716                 aggi1(l,k)=aggi1(l,k)+agg(l,k)
4717                 aggj(l,k)=aggj(l,k)+ghalf
4718               enddo
4719             enddo
4720             if (j.eq.nres-1 .and. i.lt.j-2) then
4721               do k=1,4
4722                 do l=1,3
4723                   aggj1(l,k)=aggj1(l,k)+agg(l,k)
4724                 enddo
4725               enddo
4726             endif
4727           endif
4728 c          t_eelecij=t_eelecij+MPI_Wtime()-time00
4729       return
4730       end
4731 C-----------------------------------------------------------------------------
4732       subroutine eturn3(i,eello_turn3)
4733 C Third- and fourth-order contributions from turns
4734       implicit real*8 (a-h,o-z)
4735       include 'DIMENSIONS'
4736       include 'COMMON.IOUNITS'
4737       include 'COMMON.GEO'
4738       include 'COMMON.VAR'
4739       include 'COMMON.LOCAL'
4740       include 'COMMON.CHAIN'
4741       include 'COMMON.DERIV'
4742       include 'COMMON.INTERACT'
4743       include 'COMMON.CORRMAT'
4744       include 'COMMON.TORSION'
4745       include 'COMMON.VECTORS'
4746       include 'COMMON.FFIELD'
4747       include 'COMMON.CONTROL'
4748       include 'COMMON.SHIELD'
4749       dimension ggg(3)
4750       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
4751      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
4752      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2),gpizda1(2,2),
4753      &  gpizda2(2,2),auxgmat1(2,2),auxgmatt1(2,2),
4754      &  auxgmat2(2,2),auxgmatt2(2,2)
4755       double precision agg(3,4),aggi(3,4),aggi1(3,4),
4756      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
4757       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
4758      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
4759      &    num_conti,j1,j2
4760       j=i+2
4761 c      write (iout,*) "eturn3",i,j,j1,j2
4762       a_temp(1,1)=a22
4763       a_temp(1,2)=a23
4764       a_temp(2,1)=a32
4765       a_temp(2,2)=a33
4766 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4767 C
4768 C               Third-order contributions
4769 C
4770 C                 (i+2)o----(i+3)
4771 C                      | |
4772 C                      | |
4773 C                 (i+1)o----i
4774 C
4775 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4776 cd        call checkint_turn3(i,a_temp,eello_turn3_num)
4777         call matmat2(EUg(1,1,i+1),EUg(1,1,i+2),auxmat(1,1))
4778 c auxalary matices for theta gradient
4779 c auxalary matrix for i+1 and constant i+2
4780         call matmat2(gtEUg(1,1,i+1),EUg(1,1,i+2),auxgmat1(1,1))
4781 c auxalary matrix for i+2 and constant i+1
4782         call matmat2(EUg(1,1,i+1),gtEUg(1,1,i+2),auxgmat2(1,1))
4783         call transpose2(auxmat(1,1),auxmat1(1,1))
4784         call transpose2(auxgmat1(1,1),auxgmatt1(1,1))
4785         call transpose2(auxgmat2(1,1),auxgmatt2(1,1))
4786         call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4787         call matmat2(a_temp(1,1),auxgmatt1(1,1),gpizda1(1,1))
4788         call matmat2(a_temp(1,1),auxgmatt2(1,1),gpizda2(1,1))
4789         if (shield_mode.eq.0) then
4790         fac_shield(i)=1.0
4791         fac_shield(j)=1.0
4792 C        else
4793 C        fac_shield(i)=0.4
4794 C        fac_shield(j)=0.6
4795         endif
4796         eello_turn3=eello_turn3+0.5d0*(pizda(1,1)+pizda(2,2))
4797      &  *fac_shield(i)*fac_shield(j)
4798         eello_t3=0.5d0*(pizda(1,1)+pizda(2,2))
4799      &  *fac_shield(i)*fac_shield(j)
4800         if (energy_dec) write (iout,'(6heturn3,2i5,0pf7.3)') i,i+2,
4801      &    eello_t3
4802 C#ifdef NEWCORR
4803 C Derivatives in theta
4804         gloc(nphi+i,icg)=gloc(nphi+i,icg)
4805      &  +0.5d0*(gpizda1(1,1)+gpizda1(2,2))*wturn3
4806      &   *fac_shield(i)*fac_shield(j)
4807         gloc(nphi+i+1,icg)=gloc(nphi+i+1,icg)
4808      &  +0.5d0*(gpizda2(1,1)+gpizda2(2,2))*wturn3
4809      &   *fac_shield(i)*fac_shield(j)
4810 C#endif
4811
4812 C Derivatives in shield mode
4813           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
4814      &  (shield_mode.gt.0)) then
4815 C          print *,i,j
4816
4817           do ilist=1,ishield_list(i)
4818            iresshield=shield_list(ilist,i)
4819            do k=1,3
4820            rlocshield=grad_shield_side(k,ilist,i)*eello_t3/fac_shield(i)
4821 C     &      *2.0
4822            gshieldx_t3(k,iresshield)=gshieldx_t3(k,iresshield)+
4823      &              rlocshield
4824      & +grad_shield_loc(k,ilist,i)*eello_t3/fac_shield(i)
4825             gshieldc_t3(k,iresshield-1)=gshieldc_t3(k,iresshield-1)
4826      &      +rlocshield
4827            enddo
4828           enddo
4829           do ilist=1,ishield_list(j)
4830            iresshield=shield_list(ilist,j)
4831            do k=1,3
4832            rlocshield=grad_shield_side(k,ilist,j)*eello_t3/fac_shield(j)
4833 C     &     *2.0
4834            gshieldx_t3(k,iresshield)=gshieldx_t3(k,iresshield)+
4835      &              rlocshield
4836      & +grad_shield_loc(k,ilist,j)*eello_t3/fac_shield(j)
4837            gshieldc_t3(k,iresshield-1)=gshieldc_t3(k,iresshield-1)
4838      &             +rlocshield
4839
4840            enddo
4841           enddo
4842
4843           do k=1,3
4844             gshieldc_t3(k,i)=gshieldc_t3(k,i)+
4845      &              grad_shield(k,i)*eello_t3/fac_shield(i)
4846             gshieldc_t3(k,j)=gshieldc_t3(k,j)+
4847      &              grad_shield(k,j)*eello_t3/fac_shield(j)
4848             gshieldc_t3(k,i-1)=gshieldc_t3(k,i-1)+
4849      &              grad_shield(k,i)*eello_t3/fac_shield(i)
4850             gshieldc_t3(k,j-1)=gshieldc_t3(k,j-1)+
4851      &              grad_shield(k,j)*eello_t3/fac_shield(j)
4852            enddo
4853            endif
4854
4855 C        if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
4856 cd        write (2,*) 'i,',i,' j',j,'eello_turn3',
4857 cd     &    0.5d0*(pizda(1,1)+pizda(2,2)),
4858 cd     &    ' eello_turn3_num',4*eello_turn3_num
4859 C Derivatives in gamma(i)
4860         call matmat2(EUgder(1,1,i+1),EUg(1,1,i+2),auxmat2(1,1))
4861         call transpose2(auxmat2(1,1),auxmat3(1,1))
4862         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
4863         gel_loc_turn3(i)=gel_loc_turn3(i)+0.5d0*(pizda(1,1)+pizda(2,2))
4864      &   *fac_shield(i)*fac_shield(j)
4865 C Derivatives in gamma(i+1)
4866         call matmat2(EUg(1,1,i+1),EUgder(1,1,i+2),auxmat2(1,1))
4867         call transpose2(auxmat2(1,1),auxmat3(1,1))
4868         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
4869         gel_loc_turn3(i+1)=gel_loc_turn3(i+1)
4870      &    +0.5d0*(pizda(1,1)+pizda(2,2))
4871      &   *fac_shield(i)*fac_shield(j)
4872 C Cartesian derivatives
4873         do l=1,3
4874 c            ghalf1=0.5d0*agg(l,1)
4875 c            ghalf2=0.5d0*agg(l,2)
4876 c            ghalf3=0.5d0*agg(l,3)
4877 c            ghalf4=0.5d0*agg(l,4)
4878           a_temp(1,1)=aggi(l,1)!+ghalf1
4879           a_temp(1,2)=aggi(l,2)!+ghalf2
4880           a_temp(2,1)=aggi(l,3)!+ghalf3
4881           a_temp(2,2)=aggi(l,4)!+ghalf4
4882           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4883           gcorr3_turn(l,i)=gcorr3_turn(l,i)
4884      &      +0.5d0*(pizda(1,1)+pizda(2,2))
4885      &   *fac_shield(i)*fac_shield(j)
4886
4887           a_temp(1,1)=aggi1(l,1)!+agg(l,1)
4888           a_temp(1,2)=aggi1(l,2)!+agg(l,2)
4889           a_temp(2,1)=aggi1(l,3)!+agg(l,3)
4890           a_temp(2,2)=aggi1(l,4)!+agg(l,4)
4891           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4892           gcorr3_turn(l,i+1)=gcorr3_turn(l,i+1)
4893      &      +0.5d0*(pizda(1,1)+pizda(2,2))
4894      &   *fac_shield(i)*fac_shield(j)
4895           a_temp(1,1)=aggj(l,1)!+ghalf1
4896           a_temp(1,2)=aggj(l,2)!+ghalf2
4897           a_temp(2,1)=aggj(l,3)!+ghalf3
4898           a_temp(2,2)=aggj(l,4)!+ghalf4
4899           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4900           gcorr3_turn(l,j)=gcorr3_turn(l,j)
4901      &      +0.5d0*(pizda(1,1)+pizda(2,2))
4902      &   *fac_shield(i)*fac_shield(j)
4903           a_temp(1,1)=aggj1(l,1)
4904           a_temp(1,2)=aggj1(l,2)
4905           a_temp(2,1)=aggj1(l,3)
4906           a_temp(2,2)=aggj1(l,4)
4907           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4908           gcorr3_turn(l,j1)=gcorr3_turn(l,j1)
4909      &      +0.5d0*(pizda(1,1)+pizda(2,2))
4910      &   *fac_shield(i)*fac_shield(j)
4911         enddo
4912       return
4913       end
4914 C-------------------------------------------------------------------------------
4915       subroutine eturn4(i,eello_turn4)
4916 C Third- and fourth-order contributions from turns
4917       implicit real*8 (a-h,o-z)
4918       include 'DIMENSIONS'
4919       include 'COMMON.IOUNITS'
4920       include 'COMMON.GEO'
4921       include 'COMMON.VAR'
4922       include 'COMMON.LOCAL'
4923       include 'COMMON.CHAIN'
4924       include 'COMMON.DERIV'
4925       include 'COMMON.INTERACT'
4926       include 'COMMON.CORRMAT'
4927       include 'COMMON.TORSION'
4928       include 'COMMON.VECTORS'
4929       include 'COMMON.FFIELD'
4930       include 'COMMON.CONTROL'
4931       include 'COMMON.SHIELD'
4932       dimension ggg(3)
4933       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
4934      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
4935      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2),auxgvec(2),
4936      &  auxgEvec1(2),auxgEvec2(2),auxgEvec3(2),
4937      &  gte1t(2,2),gte2t(2,2),gte3t(2,2),
4938      &  gte1a(2,2),gtae3(2,2),gtae3e2(2,2), ae3gte2(2,2),
4939      &  gtEpizda1(2,2),gtEpizda2(2,2),gtEpizda3(2,2)
4940       double precision agg(3,4),aggi(3,4),aggi1(3,4),
4941      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
4942       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
4943      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
4944      &    num_conti,j1,j2
4945       j=i+3
4946 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4947 C
4948 C               Fourth-order contributions
4949 C
4950 C                 (i+3)o----(i+4)
4951 C                     /  |
4952 C               (i+2)o   |
4953 C                     \  |
4954 C                 (i+1)o----i
4955 C
4956 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4957 cd        call checkint_turn4(i,a_temp,eello_turn4_num)
4958 c        write (iout,*) "eturn4 i",i," j",j," j1",j1," j2",j2
4959 c        write(iout,*)"WCHODZE W PROGRAM"
4960         a_temp(1,1)=a22
4961         a_temp(1,2)=a23
4962         a_temp(2,1)=a32
4963         a_temp(2,2)=a33
4964         iti1=itype2loc(itype(i+1))
4965         iti2=itype2loc(itype(i+2))
4966         iti3=itype2loc(itype(i+3))
4967 c        write(iout,*) "iti1",iti1," iti2",iti2," iti3",iti3
4968         call transpose2(EUg(1,1,i+1),e1t(1,1))
4969         call transpose2(Eug(1,1,i+2),e2t(1,1))
4970         call transpose2(Eug(1,1,i+3),e3t(1,1))
4971 C Ematrix derivative in theta
4972         call transpose2(gtEUg(1,1,i+1),gte1t(1,1))
4973         call transpose2(gtEug(1,1,i+2),gte2t(1,1))
4974         call transpose2(gtEug(1,1,i+3),gte3t(1,1))
4975         call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4976 c       eta1 in derivative theta
4977         call matmat2(gte1t(1,1),a_temp(1,1),gte1a(1,1))
4978         call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4979 c       auxgvec is derivative of Ub2 so i+3 theta
4980         call matvec2(e1a(1,1),gUb2(1,i+3),auxgvec(1))
4981 c       auxalary matrix of E i+1
4982         call matvec2(gte1a(1,1),Ub2(1,i+3),auxgEvec1(1))
4983 c        s1=0.0
4984 c        gs1=0.0
4985         s1=scalar2(b1(1,i+2),auxvec(1))
4986 c derivative of theta i+2 with constant i+3
4987         gs23=scalar2(gtb1(1,i+2),auxvec(1))
4988 c derivative of theta i+2 with constant i+2
4989         gs32=scalar2(b1(1,i+2),auxgvec(1))
4990 c derivative of E matix in theta of i+1
4991         gsE13=scalar2(b1(1,i+2),auxgEvec1(1))
4992
4993         call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4994 c       ea31 in derivative theta
4995         call matmat2(a_temp(1,1),gte3t(1,1),gtae3(1,1))
4996         call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4997 c auxilary matrix auxgvec of Ub2 with constant E matirx
4998         call matvec2(ae3(1,1),gUb2(1,i+2),auxgvec(1))
4999 c auxilary matrix auxgEvec1 of E matix with Ub2 constant
5000         call matvec2(gtae3(1,1),Ub2(1,i+2),auxgEvec3(1))
5001
5002 c        s2=0.0
5003 c        gs2=0.0
5004         s2=scalar2(b1(1,i+1),auxvec(1))
5005 c derivative of theta i+1 with constant i+3
5006         gs13=scalar2(gtb1(1,i+1),auxvec(1))
5007 c derivative of theta i+2 with constant i+1
5008         gs21=scalar2(b1(1,i+1),auxgvec(1))
5009 c derivative of theta i+3 with constant i+1
5010         gsE31=scalar2(b1(1,i+1),auxgEvec3(1))
5011 c        write(iout,*) gs1,gs2,'i=',i,auxgvec(1),gUb2(1,i+2),gtb1(1,i+2),
5012 c     &  gtb1(1,i+1)
5013         call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5014 c two derivatives over diffetent matrices
5015 c gtae3e2 is derivative over i+3
5016         call matmat2(gtae3(1,1),e2t(1,1),gtae3e2(1,1))
5017 c ae3gte2 is derivative over i+2
5018         call matmat2(ae3(1,1),gte2t(1,1),ae3gte2(1,1))
5019         call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5020 c three possible derivative over theta E matices
5021 c i+1
5022         call matmat2(ae3e2(1,1),gte1t(1,1),gtEpizda1(1,1))
5023 c i+2
5024         call matmat2(ae3gte2(1,1),e1t(1,1),gtEpizda2(1,1))
5025 c i+3
5026         call matmat2(gtae3e2(1,1),e1t(1,1),gtEpizda3(1,1))
5027         s3=0.5d0*(pizda(1,1)+pizda(2,2))
5028
5029         gsEE1=0.5d0*(gtEpizda1(1,1)+gtEpizda1(2,2))
5030         gsEE2=0.5d0*(gtEpizda2(1,1)+gtEpizda2(2,2))
5031         gsEE3=0.5d0*(gtEpizda3(1,1)+gtEpizda3(2,2))
5032         if (shield_mode.eq.0) then
5033         fac_shield(i)=1.0
5034         fac_shield(j)=1.0
5035 C        else
5036 C        fac_shield(i)=0.6
5037 C        fac_shield(j)=0.4
5038         endif
5039         eello_turn4=eello_turn4-(s1+s2+s3)
5040      &  *fac_shield(i)*fac_shield(j)
5041         eello_t4=-(s1+s2+s3)
5042      &  *fac_shield(i)*fac_shield(j)
5043 c             write(iout,*)'chujOWO', auxvec(1),b1(1,iti2)
5044         if (energy_dec) write (iout,'(a6,2i5,0pf7.3,3f7.3)')
5045      &      'eturn4',i,j,-(s1+s2+s3),s1,s2,s3
5046 C Now derivative over shield:
5047           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
5048      &  (shield_mode.gt.0)) then
5049 C          print *,i,j
5050
5051           do ilist=1,ishield_list(i)
5052            iresshield=shield_list(ilist,i)
5053            do k=1,3
5054            rlocshield=grad_shield_side(k,ilist,i)*eello_t4/fac_shield(i)
5055 C     &      *2.0
5056            gshieldx_t4(k,iresshield)=gshieldx_t4(k,iresshield)+
5057      &              rlocshield
5058      & +grad_shield_loc(k,ilist,i)*eello_t4/fac_shield(i)
5059             gshieldc_t4(k,iresshield-1)=gshieldc_t4(k,iresshield-1)
5060      &      +rlocshield
5061            enddo
5062           enddo
5063           do ilist=1,ishield_list(j)
5064            iresshield=shield_list(ilist,j)
5065            do k=1,3
5066            rlocshield=grad_shield_side(k,ilist,j)*eello_t4/fac_shield(j)
5067 C     &     *2.0
5068            gshieldx_t4(k,iresshield)=gshieldx_t4(k,iresshield)+
5069      &              rlocshield
5070      & +grad_shield_loc(k,ilist,j)*eello_t4/fac_shield(j)
5071            gshieldc_t4(k,iresshield-1)=gshieldc_t4(k,iresshield-1)
5072      &             +rlocshield
5073
5074            enddo
5075           enddo
5076
5077           do k=1,3
5078             gshieldc_t4(k,i)=gshieldc_t4(k,i)+
5079      &              grad_shield(k,i)*eello_t4/fac_shield(i)
5080             gshieldc_t4(k,j)=gshieldc_t4(k,j)+
5081      &              grad_shield(k,j)*eello_t4/fac_shield(j)
5082             gshieldc_t4(k,i-1)=gshieldc_t4(k,i-1)+
5083      &              grad_shield(k,i)*eello_t4/fac_shield(i)
5084             gshieldc_t4(k,j-1)=gshieldc_t4(k,j-1)+
5085      &              grad_shield(k,j)*eello_t4/fac_shield(j)
5086            enddo
5087            endif
5088
5089
5090
5091
5092
5093
5094 cd        write (2,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
5095 cd     &    ' eello_turn4_num',8*eello_turn4_num
5096 #ifdef NEWCORR
5097         gloc(nphi+i,icg)=gloc(nphi+i,icg)
5098      &                  -(gs13+gsE13+gsEE1)*wturn4
5099      &  *fac_shield(i)*fac_shield(j)
5100         gloc(nphi+i+1,icg)= gloc(nphi+i+1,icg)
5101      &                    -(gs23+gs21+gsEE2)*wturn4
5102      &  *fac_shield(i)*fac_shield(j)
5103
5104         gloc(nphi+i+2,icg)= gloc(nphi+i+2,icg)
5105      &                    -(gs32+gsE31+gsEE3)*wturn4
5106      &  *fac_shield(i)*fac_shield(j)
5107
5108 c         gloc(nphi+i+1,icg)=gloc(nphi+i+1,icg)-
5109 c     &   gs2
5110 #endif
5111         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
5112      &      'eturn4',i,j,-(s1+s2+s3)
5113 c        write (iout,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
5114 c     &    ' eello_turn4_num',8*eello_turn4_num
5115 C Derivatives in gamma(i)
5116         call transpose2(EUgder(1,1,i+1),e1tder(1,1))
5117         call matmat2(e1tder(1,1),a_temp(1,1),auxmat(1,1))
5118         call matvec2(auxmat(1,1),Ub2(1,i+3),auxvec(1))
5119         s1=scalar2(b1(1,i+2),auxvec(1))
5120         call matmat2(ae3e2(1,1),e1tder(1,1),pizda(1,1))
5121         s3=0.5d0*(pizda(1,1)+pizda(2,2))
5122         gel_loc_turn4(i)=gel_loc_turn4(i)-(s1+s3)
5123      &  *fac_shield(i)*fac_shield(j)
5124 C Derivatives in gamma(i+1)
5125         call transpose2(EUgder(1,1,i+2),e2tder(1,1))
5126         call matvec2(ae3(1,1),Ub2der(1,i+2),auxvec(1))
5127         s2=scalar2(b1(1,i+1),auxvec(1))
5128         call matmat2(ae3(1,1),e2tder(1,1),auxmat(1,1))
5129         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
5130         s3=0.5d0*(pizda(1,1)+pizda(2,2))
5131         gel_loc_turn4(i+1)=gel_loc_turn4(i+1)-(s2+s3)
5132      &  *fac_shield(i)*fac_shield(j)
5133 C Derivatives in gamma(i+2)
5134         call transpose2(EUgder(1,1,i+3),e3tder(1,1))
5135         call matvec2(e1a(1,1),Ub2der(1,i+3),auxvec(1))
5136         s1=scalar2(b1(1,i+2),auxvec(1))
5137         call matmat2(a_temp(1,1),e3tder(1,1),auxmat(1,1))
5138         call matvec2(auxmat(1,1),Ub2(1,i+2),auxvec(1))
5139         s2=scalar2(b1(1,i+1),auxvec(1))
5140         call matmat2(auxmat(1,1),e2t(1,1),auxmat3(1,1))
5141         call matmat2(auxmat3(1,1),e1t(1,1),pizda(1,1))
5142         s3=0.5d0*(pizda(1,1)+pizda(2,2))
5143         gel_loc_turn4(i+2)=gel_loc_turn4(i+2)-(s1+s2+s3)
5144      &  *fac_shield(i)*fac_shield(j)
5145 C Cartesian derivatives
5146 C Derivatives of this turn contributions in DC(i+2)
5147         if (j.lt.nres-1) then
5148           do l=1,3
5149             a_temp(1,1)=agg(l,1)
5150             a_temp(1,2)=agg(l,2)
5151             a_temp(2,1)=agg(l,3)
5152             a_temp(2,2)=agg(l,4)
5153             call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5154             call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5155             s1=scalar2(b1(1,i+2),auxvec(1))
5156             call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5157             call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5158             s2=scalar2(b1(1,i+1),auxvec(1))
5159             call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5160             call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5161             s3=0.5d0*(pizda(1,1)+pizda(2,2))
5162             ggg(l)=-(s1+s2+s3)
5163             gcorr4_turn(l,i+2)=gcorr4_turn(l,i+2)-(s1+s2+s3)
5164      &  *fac_shield(i)*fac_shield(j)
5165           enddo
5166         endif
5167 C Remaining derivatives of this turn contribution
5168         do l=1,3
5169           a_temp(1,1)=aggi(l,1)
5170           a_temp(1,2)=aggi(l,2)
5171           a_temp(2,1)=aggi(l,3)
5172           a_temp(2,2)=aggi(l,4)
5173           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5174           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5175           s1=scalar2(b1(1,i+2),auxvec(1))
5176           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5177           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5178           s2=scalar2(b1(1,i+1),auxvec(1))
5179           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5180           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5181           s3=0.5d0*(pizda(1,1)+pizda(2,2))
5182           gcorr4_turn(l,i)=gcorr4_turn(l,i)-(s1+s2+s3)
5183      &  *fac_shield(i)*fac_shield(j)
5184           a_temp(1,1)=aggi1(l,1)
5185           a_temp(1,2)=aggi1(l,2)
5186           a_temp(2,1)=aggi1(l,3)
5187           a_temp(2,2)=aggi1(l,4)
5188           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5189           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5190           s1=scalar2(b1(1,i+2),auxvec(1))
5191           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5192           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5193           s2=scalar2(b1(1,i+1),auxvec(1))
5194           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5195           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5196           s3=0.5d0*(pizda(1,1)+pizda(2,2))
5197           gcorr4_turn(l,i+1)=gcorr4_turn(l,i+1)-(s1+s2+s3)
5198      &  *fac_shield(i)*fac_shield(j)
5199           a_temp(1,1)=aggj(l,1)
5200           a_temp(1,2)=aggj(l,2)
5201           a_temp(2,1)=aggj(l,3)
5202           a_temp(2,2)=aggj(l,4)
5203           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5204           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5205           s1=scalar2(b1(1,i+2),auxvec(1))
5206           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5207           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5208           s2=scalar2(b1(1,i+1),auxvec(1))
5209           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5210           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5211           s3=0.5d0*(pizda(1,1)+pizda(2,2))
5212           gcorr4_turn(l,j)=gcorr4_turn(l,j)-(s1+s2+s3)
5213      &  *fac_shield(i)*fac_shield(j)
5214           a_temp(1,1)=aggj1(l,1)
5215           a_temp(1,2)=aggj1(l,2)
5216           a_temp(2,1)=aggj1(l,3)
5217           a_temp(2,2)=aggj1(l,4)
5218           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5219           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5220           s1=scalar2(b1(1,i+2),auxvec(1))
5221           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5222           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5223           s2=scalar2(b1(1,i+1),auxvec(1))
5224           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5225           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5226           s3=0.5d0*(pizda(1,1)+pizda(2,2))
5227 c          write (iout,*) "s1",s1," s2",s2," s3",s3," s1+s2+s3",s1+s2+s3
5228           gcorr4_turn(l,j1)=gcorr4_turn(l,j1)-(s1+s2+s3)
5229      &  *fac_shield(i)*fac_shield(j)
5230         enddo
5231       return
5232       end
5233 C-----------------------------------------------------------------------------
5234       subroutine vecpr(u,v,w)
5235       implicit real*8(a-h,o-z)
5236       dimension u(3),v(3),w(3)
5237       w(1)=u(2)*v(3)-u(3)*v(2)
5238       w(2)=-u(1)*v(3)+u(3)*v(1)
5239       w(3)=u(1)*v(2)-u(2)*v(1)
5240       return
5241       end
5242 C-----------------------------------------------------------------------------
5243       subroutine unormderiv(u,ugrad,unorm,ungrad)
5244 C This subroutine computes the derivatives of a normalized vector u, given
5245 C the derivatives computed without normalization conditions, ugrad. Returns
5246 C ungrad.
5247       implicit none
5248       double precision u(3),ugrad(3,3),unorm,ungrad(3,3)
5249       double precision vec(3)
5250       double precision scalar
5251       integer i,j
5252 c      write (2,*) 'ugrad',ugrad
5253 c      write (2,*) 'u',u
5254       do i=1,3
5255         vec(i)=scalar(ugrad(1,i),u(1))
5256       enddo
5257 c      write (2,*) 'vec',vec
5258       do i=1,3
5259         do j=1,3
5260           ungrad(j,i)=(ugrad(j,i)-u(j)*vec(i))*unorm
5261         enddo
5262       enddo
5263 c      write (2,*) 'ungrad',ungrad
5264       return
5265       end
5266 C-----------------------------------------------------------------------------
5267       subroutine escp_soft_sphere(evdw2,evdw2_14)
5268 C
5269 C This subroutine calculates the excluded-volume interaction energy between
5270 C peptide-group centers and side chains and its gradient in virtual-bond and
5271 C side-chain vectors.
5272 C
5273       implicit real*8 (a-h,o-z)
5274       include 'DIMENSIONS'
5275       include 'COMMON.GEO'
5276       include 'COMMON.VAR'
5277       include 'COMMON.LOCAL'
5278       include 'COMMON.CHAIN'
5279       include 'COMMON.DERIV'
5280       include 'COMMON.INTERACT'
5281       include 'COMMON.FFIELD'
5282       include 'COMMON.IOUNITS'
5283       include 'COMMON.CONTROL'
5284       dimension ggg(3)
5285       double precision boxshift
5286       evdw2=0.0D0
5287       evdw2_14=0.0d0
5288       r0_scp=4.5d0
5289 cd    print '(a)','Enter ESCP'
5290 cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
5291 C      do xshift=-1,1
5292 C      do yshift=-1,1
5293 C      do zshift=-1,1
5294 c      do i=iatscp_s,iatscp_e
5295       do ikont=g_listscp_start,g_listscp_end
5296         i=newcontlistscpi(ikont)
5297         j=newcontlistscpj(ikont)
5298         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
5299         iteli=itel(i)
5300         xi=0.5D0*(c(1,i)+c(1,i+1))
5301         yi=0.5D0*(c(2,i)+c(2,i+1))
5302         zi=0.5D0*(c(3,i)+c(3,i+1))
5303 C Return atom into box, boxxsize is size of box in x dimension
5304 c  134   continue
5305 c        if (xi.gt.((xshift+0.5d0)*boxxsize)) xi=xi-boxxsize
5306 c        if (xi.lt.((xshift-0.5d0)*boxxsize)) xi=xi+boxxsize
5307 C Condition for being inside the proper box
5308 c        if ((xi.gt.((xshift+0.5d0)*boxxsize)).or.
5309 c     &       (xi.lt.((xshift-0.5d0)*boxxsize))) then
5310 c        go to 134
5311 c        endif
5312 c  135   continue
5313 c        if (yi.gt.((yshift+0.5d0)*boxysize)) yi=yi-boxysize
5314 c        if (yi.lt.((yshift-0.5d0)*boxysize)) yi=yi+boxysize
5315 C Condition for being inside the proper box
5316 c        if ((yi.gt.((yshift+0.5d0)*boxysize)).or.
5317 c     &       (yi.lt.((yshift-0.5d0)*boxysize))) then
5318 c        go to 135
5319 c c       endif
5320 c  136   continue
5321 c        if (zi.gt.((zshift+0.5d0)*boxzsize)) zi=zi-boxzsize
5322 c        if (zi.lt.((zshift-0.5d0)*boxzsize)) zi=zi+boxzsize
5323 cC Condition for being inside the proper box
5324 c        if ((zi.gt.((zshift+0.5d0)*boxzsize)).or.
5325 c     &       (zi.lt.((zshift-0.5d0)*boxzsize))) then
5326 c        go to 136
5327 c        endif
5328           call to_box(xi,yi,zi)
5329 C          xi=xi+xshift*boxxsize
5330 C          yi=yi+yshift*boxysize
5331 C          zi=zi+zshift*boxzsize
5332 c        do iint=1,nscp_gr(i)
5333
5334 c        do j=iscpstart(i,iint),iscpend(i,iint)
5335           if (itype(j).eq.ntyp1) cycle
5336           itypj=iabs(itype(j))
5337 C Uncomment following three lines for SC-p interactions
5338 c         xj=c(1,nres+j)-xi
5339 c         yj=c(2,nres+j)-yi
5340 c         zj=c(3,nres+j)-zi
5341 C Uncomment following three lines for Ca-p interactions
5342           xj=c(1,j)
5343           yj=c(2,j)
5344           zj=c(3,j)
5345           call to_box(xj,yj,zj)
5346           xj=boxshift(xj-xi,boxxsize)
5347           yj=boxshift(yj-yi,boxysize)
5348           zj=boxshift(zj-zi,boxzsize)
5349 C          xj=xj-xi
5350 C          yj=yj-yi
5351 C          zj=zj-zi
5352           rij=xj*xj+yj*yj+zj*zj
5353
5354           r0ij=r0_scp
5355           r0ijsq=r0ij*r0ij
5356           if (rij.lt.r0ijsq) then
5357             evdwij=0.25d0*(rij-r0ijsq)**2
5358             fac=rij-r0ijsq
5359           else
5360             evdwij=0.0d0
5361             fac=0.0d0
5362           endif
5363           evdw2=evdw2+evdwij
5364 C
5365 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
5366 C
5367           ggg(1)=xj*fac
5368           ggg(2)=yj*fac
5369           ggg(3)=zj*fac
5370           do k=1,3
5371             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
5372             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
5373           enddo
5374 c        enddo
5375
5376 c        enddo ! iint
5377       enddo ! i
5378 C      enddo !zshift
5379 C      enddo !yshift
5380 C      enddo !xshift
5381       return
5382       end
5383 C-----------------------------------------------------------------------------
5384       subroutine escp(evdw2,evdw2_14)
5385 C
5386 C This subroutine calculates the excluded-volume interaction energy between
5387 C peptide-group centers and side chains and its gradient in virtual-bond and
5388 C side-chain vectors.
5389 C
5390       implicit none
5391       include 'DIMENSIONS'
5392       include 'COMMON.GEO'
5393       include 'COMMON.VAR'
5394       include 'COMMON.LOCAL'
5395       include 'COMMON.CHAIN'
5396       include 'COMMON.DERIV'
5397       include 'COMMON.INTERACT'
5398       include 'COMMON.FFIELD'
5399       include 'COMMON.IOUNITS'
5400       include 'COMMON.CONTROL'
5401       include 'COMMON.SPLITELE'
5402       double precision ggg(3)
5403       integer i,iint,j,k,iteli,itypj,subchap,ikont
5404       double precision xi,yi,zi,xj,yj,zj,rrij,sss1,sssgrad1,
5405      & fac,e1,e2,rij
5406       double precision evdw2,evdw2_14,evdwij
5407       double precision sscale,sscagrad
5408       double precision boxshift
5409       evdw2=0.0D0
5410       evdw2_14=0.0d0
5411 c        print *,boxxsize,boxysize,boxzsize,'wymiary pudla'
5412 cd    print '(a)','Enter ESCP'
5413 cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
5414 C      do xshift=-1,1
5415 C      do yshift=-1,1
5416 C      do zshift=-1,1
5417       if (energy_dec) write (iout,*) "escp:",r_cut_int,rlamb
5418 c      do i=iatscp_s,iatscp_e
5419       do ikont=g_listscp_start,g_listscp_end
5420         i=newcontlistscpi(ikont)
5421         j=newcontlistscpj(ikont)
5422         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
5423         iteli=itel(i)
5424         xi=0.5D0*(c(1,i)+c(1,i+1))
5425         yi=0.5D0*(c(2,i)+c(2,i+1))
5426         zi=0.5D0*(c(3,i)+c(3,i+1))
5427         call to_box(xi,yi,zi)
5428 c        do iint=1,nscp_gr(i)
5429
5430 c        do j=iscpstart(i,iint),iscpend(i,iint)
5431           itypj=iabs(itype(j))
5432           if (itypj.eq.ntyp1) cycle
5433 C Uncomment following three lines for SC-p interactions
5434 c         xj=c(1,nres+j)-xi
5435 c         yj=c(2,nres+j)-yi
5436 c         zj=c(3,nres+j)-zi
5437 C Uncomment following three lines for Ca-p interactions
5438           xj=c(1,j)
5439           yj=c(2,j)
5440           zj=c(3,j)
5441           call to_box(xj,yj,zj)
5442           xj=boxshift(xj-xi,boxxsize)
5443           yj=boxshift(yj-yi,boxysize)
5444           zj=boxshift(zj-zi,boxzsize)
5445 c          print *,xj,yj,zj,'polozenie j'
5446           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
5447 c          print *,rrij
5448           sss=sscale(1.0d0/(dsqrt(rrij)),r_cut_int)
5449 c          print *,r_cut,1.0d0/dsqrt(rrij),sss,'tu patrz'
5450 c          if (sss.eq.0) print *,'czasem jest OK'
5451           if (sss.le.0.0d0) cycle
5452           sssgrad=sscagrad(1.0d0/(dsqrt(rrij)),r_cut_int)
5453           fac=rrij**expon2
5454           e1=fac*fac*aad(itypj,iteli)
5455           e2=fac*bad(itypj,iteli)
5456           if (iabs(j-i) .le. 2) then
5457             e1=scal14*e1
5458             e2=scal14*e2
5459             evdw2_14=evdw2_14+(e1+e2)*sss
5460           endif
5461           evdwij=e1+e2
5462           evdw2=evdw2+evdwij*sss
5463           if (energy_dec) write (iout,'(a6,2i5,3f7.3,2i3,3e11.3)')
5464      &        'evdw2',i,j,1.0d0/dsqrt(rrij),sss,
5465      &       evdwij,iteli,itypj,fac,aad(itypj,iteli),
5466      &       bad(itypj,iteli)
5467 C
5468 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
5469 C
5470           fac=-(evdwij+e1)*rrij*sss
5471           fac=fac+(evdwij)*sssgrad*dsqrt(rrij)/expon
5472           ggg(1)=xj*fac
5473           ggg(2)=yj*fac
5474           ggg(3)=zj*fac
5475 cgrad          if (j.lt.i) then
5476 cd          write (iout,*) 'j<i'
5477 C Uncomment following three lines for SC-p interactions
5478 c           do k=1,3
5479 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
5480 c           enddo
5481 cgrad          else
5482 cd          write (iout,*) 'j>i'
5483 cgrad            do k=1,3
5484 cgrad              ggg(k)=-ggg(k)
5485 C Uncomment following line for SC-p interactions
5486 ccgrad             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
5487 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
5488 cgrad            enddo
5489 cgrad          endif
5490 cgrad          do k=1,3
5491 cgrad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
5492 cgrad          enddo
5493 cgrad          kstart=min0(i+1,j)
5494 cgrad          kend=max0(i-1,j-1)
5495 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
5496 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
5497 cgrad          do k=kstart,kend
5498 cgrad            do l=1,3
5499 cgrad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
5500 cgrad            enddo
5501 cgrad          enddo
5502           do k=1,3
5503             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
5504             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
5505           enddo
5506 c        endif !endif for sscale cutoff
5507 c        enddo ! j
5508
5509 c        enddo ! iint
5510       enddo ! i
5511 c      enddo !zshift
5512 c      enddo !yshift
5513 c      enddo !xshift
5514       do i=1,nct
5515         do j=1,3
5516           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
5517           gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
5518           gradx_scp(j,i)=expon*gradx_scp(j,i)
5519         enddo
5520       enddo
5521 C******************************************************************************
5522 C
5523 C                              N O T E !!!
5524 C
5525 C To save time the factor EXPON has been extracted from ALL components
5526 C of GVDWC and GRADX. Remember to multiply them by this factor before further
5527 C use!
5528 C
5529 C******************************************************************************
5530       return
5531       end
5532 C--------------------------------------------------------------------------
5533       subroutine edis(ehpb)
5534 C
5535 C Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors.
5536 C
5537       implicit real*8 (a-h,o-z)
5538       include 'DIMENSIONS'
5539       include 'COMMON.SBRIDGE'
5540       include 'COMMON.CHAIN'
5541       include 'COMMON.DERIV'
5542       include 'COMMON.VAR'
5543       include 'COMMON.INTERACT'
5544       include 'COMMON.IOUNITS'
5545       include 'COMMON.CONTROL'
5546       dimension ggg(3),ggg_peak(3,1000)
5547       ehpb=0.0D0
5548       do i=1,3
5549        ggg(i)=0.0d0
5550       enddo
5551 c 8/21/18 AL: added explicit restraints on reference coords
5552 c      write (iout,*) "restr_on_coord",restr_on_coord
5553       if (restr_on_coord) then
5554
5555       do i=nnt,nct
5556         ecoor=0.0d0
5557         if (itype(i).eq.ntyp1) cycle
5558         do j=1,3
5559           ecoor=ecoor+(c(j,i)-cref(j,i))**2
5560           ghpbc(j,i)=ghpbc(j,i)+bfac(i)*(c(j,i)-cref(j,i))
5561         enddo
5562         if (itype(i).ne.10) then
5563           do j=1,3
5564             ecoor=ecoor+(c(j,i+nres)-cref(j,i+nres))**2
5565             ghpbx(j,i)=ghpbx(j,i)+bfac(i)*(c(j,i+nres)-cref(j,i+nres))
5566           enddo
5567         endif
5568         if (energy_dec) write (iout,*)
5569      &     "i",i," bfac",bfac(i)," ecoor",ecoor
5570         ehpb=ehpb+0.5d0*bfac(i)*ecoor
5571       enddo
5572
5573       endif
5574 C      write (iout,*) ,"link_end",link_end,constr_dist
5575 cd      write(iout,*)'edis: nhpb=',nhpb,' fbr=',fbr
5576 c      write(iout,*)'link_start=',link_start,' link_end=',link_end,
5577 c     &  " constr_dist",constr_dist," link_start_peak",link_start_peak,
5578 c     &  " link_end_peak",link_end_peak
5579       if (link_end.eq.0.and.link_end_peak.eq.0) return
5580       do i=link_start_peak,link_end_peak
5581         ehpb_peak=0.0d0
5582 c        print *,"i",i," link_end_peak",link_end_peak," ipeak",
5583 c     &   ipeak(1,i),ipeak(2,i)
5584         do ip=ipeak(1,i),ipeak(2,i)
5585           ii=ihpb_peak(ip)
5586           jj=jhpb_peak(ip)
5587           dd=dist(ii,jj)
5588           iip=ip-ipeak(1,i)+1
5589 C iii and jjj point to the residues for which the distance is assigned.
5590 c          if (ii.gt.nres) then
5591 c            iii=ii-nres
5592 c            jjj=jj-nres
5593 c          else
5594 c            iii=ii
5595 c            jjj=jj
5596 c          endif
5597           if (ii.gt.nres) then
5598             iii=ii-nres
5599           else
5600             iii=ii
5601           endif
5602           if (jj.gt.nres) then
5603             jjj=jj-nres
5604           else
5605             jjj=jj
5606           endif
5607           aux=rlornmr1(dd,dhpb_peak(ip),dhpb1_peak(ip),forcon_peak(ip))
5608           aux=dexp(-scal_peak*aux)
5609           ehpb_peak=ehpb_peak+aux
5610           fac=rlornmr1prim(dd,dhpb_peak(ip),dhpb1_peak(ip),
5611      &      forcon_peak(ip))*aux/dd
5612           do j=1,3
5613             ggg_peak(j,iip)=fac*(c(j,jj)-c(j,ii))
5614           enddo
5615           if (energy_dec) write (iout,'(a6,3i5,6f10.3,i5)')
5616      &      "edisL",i,ii,jj,dd,dhpb_peak(ip),dhpb1_peak(ip),
5617      &      forcon_peak(ip),fordepth_peak(ip),ehpb_peak
5618         enddo
5619 c        write (iout,*) "ehpb_peak",ehpb_peak," scal_peak",scal_peak
5620         ehpb=ehpb-fordepth_peak(ipeak(1,i))*dlog(ehpb_peak)/scal_peak
5621         do ip=ipeak(1,i),ipeak(2,i)
5622           iip=ip-ipeak(1,i)+1
5623           do j=1,3
5624             ggg(j)=ggg_peak(j,iip)/ehpb_peak
5625           enddo
5626           ii=ihpb_peak(ip)
5627           jj=jhpb_peak(ip)
5628 C iii and jjj point to the residues for which the distance is assigned.
5629 c          if (ii.gt.nres) then
5630 c            iii=ii-nres
5631 c            jjj=jj-nres
5632 c          else
5633 c            iii=ii
5634 c            jjj=jj
5635 c          endif
5636           if (ii.gt.nres) then
5637             iii=ii-nres
5638           else
5639             iii=ii
5640           endif
5641           if (jj.gt.nres) then
5642             jjj=jj-nres
5643           else
5644             jjj=jj
5645           endif
5646           if (iii.lt.ii) then
5647             do j=1,3
5648               ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
5649             enddo
5650           endif
5651           if (jjj.lt.jj) then
5652             do j=1,3
5653               ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
5654             enddo
5655           endif
5656           do k=1,3
5657             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
5658             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
5659           enddo
5660         enddo
5661       enddo
5662       do i=link_start,link_end
5663 C If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a
5664 C CA-CA distance used in regularization of structure.
5665         ii=ihpb(i)
5666         jj=jhpb(i)
5667 C iii and jjj point to the residues for which the distance is assigned.
5668         if (ii.gt.nres) then
5669           iii=ii-nres
5670         else
5671           iii=ii
5672         endif
5673         if (jj.gt.nres) then
5674           jjj=jj-nres
5675         else
5676           jjj=jj
5677         endif
5678 c        write (iout,*) "i",i," ii",ii," iii",iii," jj",jj," jjj",jjj,
5679 c     &    dhpb(i),dhpb1(i),forcon(i)
5680 C 24/11/03 AL: SS bridges handled separately because of introducing a specific
5681 C    distance and angle dependent SS bond potential.
5682 C        if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and.
5683 C     & iabs(itype(jjj)).eq.1) then
5684 cmc        if (ii.gt.nres .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then
5685 C 18/07/06 MC: Use the convention that the first nss pairs are SS bonds
5686         if (.not.dyn_ss .and. i.le.nss) then
5687 C 15/02/13 CC dynamic SSbond - additional check
5688           if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and.
5689      &        iabs(itype(jjj)).eq.1) then
5690            call ssbond_ene(iii,jjj,eij)
5691            ehpb=ehpb+2*eij
5692          endif
5693 cd          write (iout,*) "eij",eij
5694 cd   &   ' waga=',waga,' fac=',fac
5695 !        else if (ii.gt.nres .and. jj.gt.nres) then
5696         else
5697 C Calculate the distance between the two points and its difference from the
5698 C target distance.
5699           dd=dist(ii,jj)
5700           if (irestr_type(i).eq.11) then
5701             ehpb=ehpb+fordepth(i)!**4.0d0
5702      &           *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i))
5703             fac=fordepth(i)!**4.0d0
5704      &           *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd
5705             if (energy_dec) write (iout,'(a6,2i5,6f10.3,i5)')
5706      &        "edisL",ii,jj,dd,dhpb(i),dhpb1(i),forcon(i),fordepth(i),
5707      &        ehpb,irestr_type(i)
5708           else if (irestr_type(i).eq.10) then
5709 c AL 6//19/2018 cross-link restraints
5710             xdis = 0.5d0*(dd/forcon(i))**2
5711             expdis = dexp(-xdis)
5712 c            aux=(dhpb(i)+dhpb1(i)*xdis)*expdis+fordepth(i)
5713             aux=(dhpb(i)+dhpb1(i)*xdis*xdis)*expdis+fordepth(i)
5714 c            write (iout,*)"HERE: xdis",xdis," expdis",expdis," aux",aux,
5715 c     &          " wboltzd",wboltzd
5716             ehpb=ehpb-wboltzd*xlscore(i)*dlog(aux)
5717 c            fac=-wboltzd*(dhpb1(i)*(1.0d0-xdis)-dhpb(i))
5718             fac=-wboltzd*xlscore(i)*(dhpb1(i)*(2.0d0-xdis)*xdis-dhpb(i))
5719      &           *expdis/(aux*forcon(i)**2)
5720             if (energy_dec) write(iout,'(a6,2i5,6f10.3,i5)')
5721      &        "edisX",ii,jj,dd,dhpb(i),dhpb1(i),forcon(i),fordepth(i),
5722      &        -wboltzd*xlscore(i)*dlog(aux),irestr_type(i)
5723           else if (irestr_type(i).eq.2) then
5724 c Quartic restraints
5725             ehpb=ehpb+forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
5726             if (energy_dec) write(iout,'(a6,2i5,5f10.3,i5)')
5727      &      "edisQ",ii,jj,dd,dhpb(i),dhpb1(i),forcon(i),
5728      &      forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i)),irestr_type(i)
5729             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
5730           else
5731 c Quadratic restraints
5732             rdis=dd-dhpb(i)
5733 C Get the force constant corresponding to this distance.
5734             waga=forcon(i)
5735 C Calculate the contribution to energy.
5736             ehpb=ehpb+0.5d0*waga*rdis*rdis
5737             if (energy_dec) write(iout,'(a6,2i5,5f10.3,i5)')
5738      &      "edisS",ii,jj,dd,dhpb(i),dhpb1(i),forcon(i),
5739      &       0.5d0*waga*rdis*rdis,irestr_type(i)
5740 C
5741 C Evaluate gradient.
5742 C
5743             fac=waga*rdis/dd
5744           endif
5745 c Calculate Cartesian gradient
5746           do j=1,3
5747             ggg(j)=fac*(c(j,jj)-c(j,ii))
5748           enddo
5749 cd      print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
5750 C If this is a SC-SC distance, we need to calculate the contributions to the
5751 C Cartesian gradient in the SC vectors (ghpbx).
5752           if (iii.lt.ii) then
5753             do j=1,3
5754               ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
5755             enddo
5756           endif
5757           if (jjj.lt.jj) then
5758             do j=1,3
5759               ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
5760             enddo
5761           endif
5762           do k=1,3
5763             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
5764             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
5765           enddo
5766         endif
5767       enddo
5768       return
5769       end
5770 C--------------------------------------------------------------------------
5771       subroutine ssbond_ene(i,j,eij)
5772 C
5773 C Calculate the distance and angle dependent SS-bond potential energy
5774 C using a free-energy function derived based on RHF/6-31G** ab initio
5775 C calculations of diethyl disulfide.
5776 C
5777 C A. Liwo and U. Kozlowska, 11/24/03
5778 C
5779       implicit real*8 (a-h,o-z)
5780       include 'DIMENSIONS'
5781       include 'COMMON.SBRIDGE'
5782       include 'COMMON.CHAIN'
5783       include 'COMMON.DERIV'
5784       include 'COMMON.LOCAL'
5785       include 'COMMON.INTERACT'
5786       include 'COMMON.VAR'
5787       include 'COMMON.IOUNITS'
5788       double precision erij(3),dcosom1(3),dcosom2(3),gg(3)
5789       itypi=iabs(itype(i))
5790       xi=c(1,nres+i)
5791       yi=c(2,nres+i)
5792       zi=c(3,nres+i)
5793       dxi=dc_norm(1,nres+i)
5794       dyi=dc_norm(2,nres+i)
5795       dzi=dc_norm(3,nres+i)
5796 c      dsci_inv=dsc_inv(itypi)
5797       dsci_inv=vbld_inv(nres+i)
5798       itypj=iabs(itype(j))
5799 c      dscj_inv=dsc_inv(itypj)
5800       dscj_inv=vbld_inv(nres+j)
5801       xj=c(1,nres+j)-xi
5802       yj=c(2,nres+j)-yi
5803       zj=c(3,nres+j)-zi
5804       dxj=dc_norm(1,nres+j)
5805       dyj=dc_norm(2,nres+j)
5806       dzj=dc_norm(3,nres+j)
5807       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
5808       rij=dsqrt(rrij)
5809       erij(1)=xj*rij
5810       erij(2)=yj*rij
5811       erij(3)=zj*rij
5812       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
5813       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
5814       om12=dxi*dxj+dyi*dyj+dzi*dzj
5815       do k=1,3
5816         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
5817         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
5818       enddo
5819       rij=1.0d0/rij
5820       deltad=rij-d0cm
5821       deltat1=1.0d0-om1
5822       deltat2=1.0d0+om2
5823       deltat12=om2-om1+2.0d0
5824       cosphi=om12-om1*om2
5825       eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2)
5826      &  +akct*deltad*deltat12
5827      &  +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi+ebr
5828 c      write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth,
5829 c     &  " akct",akct," deltad",deltad," deltat",deltat1,deltat2,
5830 c     &  " deltat12",deltat12," eij",eij
5831       ed=2*akcm*deltad+akct*deltat12
5832       pom1=akct*deltad
5833       pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
5834       eom1=-2*akth*deltat1-pom1-om2*pom2
5835       eom2= 2*akth*deltat2+pom1-om1*pom2
5836       eom12=pom2
5837       do k=1,3
5838         ggk=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
5839         ghpbx(k,i)=ghpbx(k,i)-ggk
5840      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
5841      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
5842         ghpbx(k,j)=ghpbx(k,j)+ggk
5843      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
5844      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
5845         ghpbc(k,i)=ghpbc(k,i)-ggk
5846         ghpbc(k,j)=ghpbc(k,j)+ggk
5847       enddo
5848 C
5849 C Calculate the components of the gradient in DC and X
5850 C
5851 cgrad      do k=i,j-1
5852 cgrad        do l=1,3
5853 cgrad          ghpbc(l,k)=ghpbc(l,k)+gg(l)
5854 cgrad        enddo
5855 cgrad      enddo
5856       return
5857       end
5858 C--------------------------------------------------------------------------
5859       subroutine ebond(estr)
5860 c
5861 c Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
5862 c
5863       implicit real*8 (a-h,o-z)
5864       include 'DIMENSIONS'
5865       include 'COMMON.LOCAL'
5866       include 'COMMON.GEO'
5867       include 'COMMON.INTERACT'
5868       include 'COMMON.DERIV'
5869       include 'COMMON.VAR'
5870       include 'COMMON.CHAIN'
5871       include 'COMMON.IOUNITS'
5872       include 'COMMON.NAMES'
5873       include 'COMMON.FFIELD'
5874       include 'COMMON.CONTROL'
5875       include 'COMMON.SETUP'
5876       double precision u(3),ud(3)
5877       estr=0.0d0
5878       estr1=0.0d0
5879       do i=ibondp_start,ibondp_end
5880 c  3/4/2020 Adam: removed dummy bond graient if Calpha and SC coords are
5881 c      used
5882 #ifdef FIVEDIAG
5883         if (itype(i-1).eq.ntyp1 .or. itype(i).eq.ntyp1) cycle
5884         diff = vbld(i)-vbldp0
5885 #else
5886         if (itype(i-1).eq.ntyp1 .and. itype(i).eq.ntyp1) cycle
5887 c          estr1=estr1+gnmr1(vbld(i),-1.0d0,distchainmax)
5888 c          do j=1,3
5889 c          gradb(j,i-1)=gnmr1prim(vbld(i),-1.0d0,distchainmax)
5890 c     &      *dc(j,i-1)/vbld(i)
5891 c          enddo
5892 c          if (energy_dec) write(iout,*)
5893 c     &       "estr1",i,gnmr1(vbld(i),-1.0d0,distchainmax)
5894 c        else
5895 C       Checking if it involves dummy (NH3+ or COO-) group
5896         if (itype(i-1).eq.ntyp1 .or. itype(i).eq.ntyp1) then
5897 C YES   vbldpDUM is the equlibrium length of spring for Dummy atom
5898           diff = vbld(i)-vbldpDUM
5899           if (energy_dec) write(iout,*) "dum_bond",i,diff
5900         else
5901 C NO    vbldp0 is the equlibrium length of spring for peptide group
5902           diff = vbld(i)-vbldp0
5903         endif
5904 #endif
5905         if (energy_dec) write (iout,'(a7,i5,4f7.3)')
5906      &     "estr bb",i,vbld(i),vbldp0,diff,AKP*diff*diff
5907         estr=estr+diff*diff
5908         do j=1,3
5909           gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)
5910         enddo
5911 c        write (iout,'(i5,3f10.5)') i,(gradb(j,i-1),j=1,3)
5912 c        endif
5913       enddo
5914
5915       estr=0.5d0*AKP*estr+estr1
5916 c
5917 c 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included
5918 c
5919       do i=ibond_start,ibond_end
5920         iti=iabs(itype(i))
5921         if (iti.ne.10 .and. iti.ne.ntyp1) then
5922           nbi=nbondterm(iti)
5923           if (nbi.eq.1) then
5924             diff=vbld(i+nres)-vbldsc0(1,iti)
5925             if (energy_dec)  write (iout,*)
5926      &      "estr sc",i,iti,vbld(i+nres),vbldsc0(1,iti),diff,
5927      &      AKSC(1,iti),AKSC(1,iti)*diff*diff
5928             estr=estr+0.5d0*AKSC(1,iti)*diff*diff
5929             do j=1,3
5930               gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
5931             enddo
5932           else
5933             do j=1,nbi
5934               diff=vbld(i+nres)-vbldsc0(j,iti)
5935               ud(j)=aksc(j,iti)*diff
5936               u(j)=abond0(j,iti)+0.5d0*ud(j)*diff
5937             enddo
5938             uprod=u(1)
5939             do j=2,nbi
5940               uprod=uprod*u(j)
5941             enddo
5942             usum=0.0d0
5943             usumsqder=0.0d0
5944             do j=1,nbi
5945               uprod1=1.0d0
5946               uprod2=1.0d0
5947               do k=1,nbi
5948                 if (k.ne.j) then
5949                   uprod1=uprod1*u(k)
5950                   uprod2=uprod2*u(k)*u(k)
5951                 endif
5952               enddo
5953               usum=usum+uprod1
5954               usumsqder=usumsqder+ud(j)*uprod2
5955             enddo
5956             estr=estr+uprod/usum
5957             do j=1,3
5958              gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
5959             enddo
5960           endif
5961         endif
5962       enddo
5963       return
5964       end
5965 #ifdef CRYST_THETA
5966 C--------------------------------------------------------------------------
5967       subroutine ebend(etheta)
5968 C
5969 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
5970 C angles gamma and its derivatives in consecutive thetas and gammas.
5971 C
5972       implicit real*8 (a-h,o-z)
5973       include 'DIMENSIONS'
5974       include 'COMMON.LOCAL'
5975       include 'COMMON.GEO'
5976       include 'COMMON.INTERACT'
5977       include 'COMMON.DERIV'
5978       include 'COMMON.VAR'
5979       include 'COMMON.CHAIN'
5980       include 'COMMON.IOUNITS'
5981       include 'COMMON.NAMES'
5982       include 'COMMON.FFIELD'
5983       include 'COMMON.CONTROL'
5984       include 'COMMON.TORCNSTR'
5985       common /calcthet/ term1,term2,termm,diffak,ratak,
5986      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
5987      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
5988       double precision y(2),z(2)
5989       delta=0.02d0*pi
5990 c      time11=dexp(-2*time)
5991 c      time12=1.0d0
5992       etheta=0.0D0
5993 c     write (*,'(a,i2)') 'EBEND ICG=',icg
5994       do i=ithet_start,ithet_end
5995         if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
5996      &  .or.itype(i).eq.ntyp1) cycle
5997 C Zero the energy function and its derivative at 0 or pi.
5998         call splinthet(theta(i),0.5d0*delta,ss,ssd)
5999         it=itype(i-1)
6000         ichir1=isign(1,itype(i-2))
6001         ichir2=isign(1,itype(i))
6002          if (itype(i-2).eq.10) ichir1=isign(1,itype(i-1))
6003          if (itype(i).eq.10) ichir2=isign(1,itype(i-1))
6004          if (itype(i-1).eq.10) then
6005           itype1=isign(10,itype(i-2))
6006           ichir11=isign(1,itype(i-2))
6007           ichir12=isign(1,itype(i-2))
6008           itype2=isign(10,itype(i))
6009           ichir21=isign(1,itype(i))
6010           ichir22=isign(1,itype(i))
6011          endif
6012
6013         if (i.gt.3 .and. itype(i-3).ne.ntyp1) then
6014 #ifdef OSF
6015           phii=phi(i)
6016           if (phii.ne.phii) phii=150.0
6017 #else
6018           phii=phi(i)
6019 #endif
6020           y(1)=dcos(phii)
6021           y(2)=dsin(phii)
6022         else
6023           y(1)=0.0D0
6024           y(2)=0.0D0
6025         endif
6026         if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
6027 #ifdef OSF
6028           phii1=phi(i+1)
6029           if (phii1.ne.phii1) phii1=150.0
6030           phii1=pinorm(phii1)
6031           z(1)=cos(phii1)
6032 #else
6033           phii1=phi(i+1)
6034 #endif
6035           z(1)=dcos(phii1)
6036           z(2)=dsin(phii1)
6037         else
6038           z(1)=0.0D0
6039           z(2)=0.0D0
6040         endif
6041 C Calculate the "mean" value of theta from the part of the distribution
6042 C dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2).
6043 C In following comments this theta will be referred to as t_c.
6044         thet_pred_mean=0.0d0
6045         do k=1,2
6046             athetk=athet(k,it,ichir1,ichir2)
6047             bthetk=bthet(k,it,ichir1,ichir2)
6048           if (it.eq.10) then
6049              athetk=athet(k,itype1,ichir11,ichir12)
6050              bthetk=bthet(k,itype2,ichir21,ichir22)
6051           endif
6052          thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k)
6053 c         write(iout,*) 'chuj tu', y(k),z(k)
6054         enddo
6055         dthett=thet_pred_mean*ssd
6056         thet_pred_mean=thet_pred_mean*ss+a0thet(it)
6057 C Derivatives of the "mean" values in gamma1 and gamma2.
6058         dthetg1=(-athet(1,it,ichir1,ichir2)*y(2)
6059      &+athet(2,it,ichir1,ichir2)*y(1))*ss
6060          dthetg2=(-bthet(1,it,ichir1,ichir2)*z(2)
6061      &          +bthet(2,it,ichir1,ichir2)*z(1))*ss
6062          if (it.eq.10) then
6063       dthetg1=(-athet(1,itype1,ichir11,ichir12)*y(2)
6064      &+athet(2,itype1,ichir11,ichir12)*y(1))*ss
6065         dthetg2=(-bthet(1,itype2,ichir21,ichir22)*z(2)
6066      &         +bthet(2,itype2,ichir21,ichir22)*z(1))*ss
6067          endif
6068         if (theta(i).gt.pi-delta) then
6069           call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,
6070      &         E_tc0)
6071           call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0)
6072           call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
6073           call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,
6074      &        E_theta)
6075           call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,
6076      &        E_tc)
6077         else if (theta(i).lt.delta) then
6078           call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0)
6079           call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
6080           call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,
6081      &        E_theta)
6082           call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0)
6083           call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,
6084      &        E_tc)
6085         else
6086           call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,
6087      &        E_theta,E_tc)
6088         endif
6089         etheta=etheta+ethetai
6090         if (energy_dec) write (iout,'(a6,i5,0pf7.3,f7.3,i5)')
6091      &      'ebend',i,ethetai,theta(i),itype(i)
6092         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1
6093         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2
6094         gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)+gloc(nphi+i-2,icg)
6095       enddo
6096
6097 C Ufff.... We've done all this!!!
6098       return
6099       end
6100 C---------------------------------------------------------------------------
6101       subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,
6102      &     E_tc)
6103       implicit real*8 (a-h,o-z)
6104       include 'DIMENSIONS'
6105       include 'COMMON.LOCAL'
6106       include 'COMMON.IOUNITS'
6107       common /calcthet/ term1,term2,termm,diffak,ratak,
6108      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
6109      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
6110 C Calculate the contributions to both Gaussian lobes.
6111 C 6/6/97 - Deform the Gaussians using the factor of 1/(1+time)
6112 C The "polynomial part" of the "standard deviation" of this part of
6113 C the distributioni.
6114 ccc        write (iout,*) thetai,thet_pred_mean
6115         sig=polthet(3,it)
6116         do j=2,0,-1
6117           sig=sig*thet_pred_mean+polthet(j,it)
6118         enddo
6119 C Derivative of the "interior part" of the "standard deviation of the"
6120 C gamma-dependent Gaussian lobe in t_c.
6121         sigtc=3*polthet(3,it)
6122         do j=2,1,-1
6123           sigtc=sigtc*thet_pred_mean+j*polthet(j,it)
6124         enddo
6125         sigtc=sig*sigtc
6126 C Set the parameters of both Gaussian lobes of the distribution.
6127 C "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc)
6128         fac=sig*sig+sigc0(it)
6129         sigcsq=fac+fac
6130         sigc=1.0D0/sigcsq
6131 C Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c
6132         sigsqtc=-4.0D0*sigcsq*sigtc
6133 c       print *,i,sig,sigtc,sigsqtc
6134 C Following variable (sigtc) is d[sigma(t_c)]/dt_c
6135         sigtc=-sigtc/(fac*fac)
6136 C Following variable is sigma(t_c)**(-2)
6137         sigcsq=sigcsq*sigcsq
6138         sig0i=sig0(it)
6139         sig0inv=1.0D0/sig0i**2
6140         delthec=thetai-thet_pred_mean
6141         delthe0=thetai-theta0i
6142         term1=-0.5D0*sigcsq*delthec*delthec
6143         term2=-0.5D0*sig0inv*delthe0*delthe0
6144 C        write (iout,*)'term1',term1,term2,sigcsq,delthec,sig0inv,delthe0
6145 C Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and
6146 C NaNs in taking the logarithm. We extract the largest exponent which is added
6147 C to the energy (this being the log of the distribution) at the end of energy
6148 C term evaluation for this virtual-bond angle.
6149         if (term1.gt.term2) then
6150           termm=term1
6151           term2=dexp(term2-termm)
6152           term1=1.0d0
6153         else
6154           termm=term2
6155           term1=dexp(term1-termm)
6156           term2=1.0d0
6157         endif
6158 C The ratio between the gamma-independent and gamma-dependent lobes of
6159 C the distribution is a Gaussian function of thet_pred_mean too.
6160         diffak=gthet(2,it)-thet_pred_mean
6161         ratak=diffak/gthet(3,it)**2
6162         ak=dexp(gthet(1,it)-0.5D0*diffak*ratak)
6163 C Let's differentiate it in thet_pred_mean NOW.
6164         aktc=ak*ratak
6165 C Now put together the distribution terms to make complete distribution.
6166         termexp=term1+ak*term2
6167         termpre=sigc+ak*sig0i
6168 C Contribution of the bending energy from this theta is just the -log of
6169 C the sum of the contributions from the two lobes and the pre-exponential
6170 C factor. Simple enough, isn't it?
6171         ethetai=(-dlog(termexp)-termm+dlog(termpre))
6172 C       write (iout,*) 'termexp',termexp,termm,termpre,i
6173 C NOW the derivatives!!!
6174 C 6/6/97 Take into account the deformation.
6175         E_theta=(delthec*sigcsq*term1
6176      &       +ak*delthe0*sig0inv*term2)/termexp
6177         E_tc=((sigtc+aktc*sig0i)/termpre
6178      &      -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+
6179      &       aktc*term2)/termexp)
6180       return
6181       end
6182 c-----------------------------------------------------------------------------
6183       subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)
6184       implicit real*8 (a-h,o-z)
6185       include 'DIMENSIONS'
6186       include 'COMMON.LOCAL'
6187       include 'COMMON.IOUNITS'
6188       common /calcthet/ term1,term2,termm,diffak,ratak,
6189      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
6190      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
6191       delthec=thetai-thet_pred_mean
6192       delthe0=thetai-theta0i
6193 C "Thank you" to MAPLE (probably spared one day of hand-differentiation).
6194       t3 = thetai-thet_pred_mean
6195       t6 = t3**2
6196       t9 = term1
6197       t12 = t3*sigcsq
6198       t14 = t12+t6*sigsqtc
6199       t16 = 1.0d0
6200       t21 = thetai-theta0i
6201       t23 = t21**2
6202       t26 = term2
6203       t27 = t21*t26
6204       t32 = termexp
6205       t40 = t32**2
6206       E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9
6207      & -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40
6208      & *(-t12*t9-ak*sig0inv*t27)
6209       return
6210       end
6211 #else
6212 C--------------------------------------------------------------------------
6213       subroutine ebend(etheta)
6214 C
6215 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
6216 C angles gamma and its derivatives in consecutive thetas and gammas.
6217 C ab initio-derived potentials from
6218 c Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203
6219 C
6220       implicit real*8 (a-h,o-z)
6221       include 'DIMENSIONS'
6222       include 'COMMON.LOCAL'
6223       include 'COMMON.GEO'
6224       include 'COMMON.INTERACT'
6225       include 'COMMON.DERIV'
6226       include 'COMMON.VAR'
6227       include 'COMMON.CHAIN'
6228       include 'COMMON.IOUNITS'
6229       include 'COMMON.NAMES'
6230       include 'COMMON.FFIELD'
6231       include 'COMMON.CONTROL'
6232       include 'COMMON.TORCNSTR'
6233       double precision coskt(mmaxtheterm),sinkt(mmaxtheterm),
6234      & cosph1(maxsingle),sinph1(maxsingle),cosph2(maxsingle),
6235      & sinph2(maxsingle),cosph1ph2(maxdouble,maxdouble),
6236      & sinph1ph2(maxdouble,maxdouble)
6237       logical lprn /.false./, lprn1 /.false./
6238       etheta=0.0D0
6239       do i=ithet_start,ithet_end
6240 c        print *,i,itype(i-1),itype(i),itype(i-2)
6241         if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
6242      &  .or.itype(i).eq.ntyp1) cycle
6243 C        print *,i,theta(i)
6244         if (iabs(itype(i+1)).eq.20) iblock=2
6245         if (iabs(itype(i+1)).ne.20) iblock=1
6246         dethetai=0.0d0
6247         dephii=0.0d0
6248         dephii1=0.0d0
6249         theti2=0.5d0*theta(i)
6250         ityp2=ithetyp((itype(i-1)))
6251         do k=1,nntheterm
6252           coskt(k)=dcos(k*theti2)
6253           sinkt(k)=dsin(k*theti2)
6254         enddo
6255 C        print *,ethetai
6256         if (i.gt.3 .and. itype(i-3).ne.ntyp1) then
6257 #ifdef OSF
6258           phii=phi(i)
6259           if (phii.ne.phii) phii=150.0
6260 #else
6261           phii=phi(i)
6262 #endif
6263           ityp1=ithetyp((itype(i-2)))
6264 C propagation of chirality for glycine type
6265           do k=1,nsingle
6266             cosph1(k)=dcos(k*phii)
6267             sinph1(k)=dsin(k*phii)
6268           enddo
6269         else
6270           phii=0.0d0
6271           do k=1,nsingle
6272           ityp1=ithetyp((itype(i-2)))
6273             cosph1(k)=0.0d0
6274             sinph1(k)=0.0d0
6275           enddo
6276         endif
6277         if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
6278 #ifdef OSF
6279           phii1=phi(i+1)
6280           if (phii1.ne.phii1) phii1=150.0
6281           phii1=pinorm(phii1)
6282 #else
6283           phii1=phi(i+1)
6284 #endif
6285           ityp3=ithetyp((itype(i)))
6286           do k=1,nsingle
6287             cosph2(k)=dcos(k*phii1)
6288             sinph2(k)=dsin(k*phii1)
6289           enddo
6290         else
6291           phii1=0.0d0
6292           ityp3=ithetyp((itype(i)))
6293           do k=1,nsingle
6294             cosph2(k)=0.0d0
6295             sinph2(k)=0.0d0
6296           enddo
6297         endif
6298         ethetai=aa0thet(ityp1,ityp2,ityp3,iblock)
6299         do k=1,ndouble
6300           do l=1,k-1
6301             ccl=cosph1(l)*cosph2(k-l)
6302             ssl=sinph1(l)*sinph2(k-l)
6303             scl=sinph1(l)*cosph2(k-l)
6304             csl=cosph1(l)*sinph2(k-l)
6305             cosph1ph2(l,k)=ccl-ssl
6306             cosph1ph2(k,l)=ccl+ssl
6307             sinph1ph2(l,k)=scl+csl
6308             sinph1ph2(k,l)=scl-csl
6309           enddo
6310         enddo
6311         if (lprn) then
6312         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,
6313      &    " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
6314         write (iout,*) "coskt and sinkt"
6315         do k=1,nntheterm
6316           write (iout,*) k,coskt(k),sinkt(k)
6317         enddo
6318         endif
6319         do k=1,ntheterm
6320           ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3,iblock)*sinkt(k)
6321           dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3,iblock)
6322      &      *coskt(k)
6323           if (lprn)
6324      &    write (iout,*) "k",k,"
6325      &     aathet",aathet(k,ityp1,ityp2,ityp3,iblock),
6326      &     " ethetai",ethetai
6327         enddo
6328         if (lprn) then
6329         write (iout,*) "cosph and sinph"
6330         do k=1,nsingle
6331           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
6332         enddo
6333         write (iout,*) "cosph1ph2 and sinph2ph2"
6334         do k=2,ndouble
6335           do l=1,k-1
6336             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),
6337      &         sinph1ph2(l,k),sinph1ph2(k,l)
6338           enddo
6339         enddo
6340         write(iout,*) "ethetai",ethetai
6341         endif
6342 C       print *,ethetai
6343         do m=1,ntheterm2
6344           do k=1,nsingle
6345             aux=bbthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)
6346      &         +ccthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k)
6347      &         +ddthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)
6348      &         +eethet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k)
6349             ethetai=ethetai+sinkt(m)*aux
6350             dethetai=dethetai+0.5d0*m*aux*coskt(m)
6351             dephii=dephii+k*sinkt(m)*(
6352      &          ccthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)-
6353      &          bbthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k))
6354             dephii1=dephii1+k*sinkt(m)*(
6355      &          eethet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)-
6356      &          ddthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k))
6357             if (lprn)
6358      &      write (iout,*) "m",m," k",k," bbthet",
6359      &         bbthet(k,m,ityp1,ityp2,ityp3,iblock)," ccthet",
6360      &         ccthet(k,m,ityp1,ityp2,ityp3,iblock)," ddthet",
6361      &         ddthet(k,m,ityp1,ityp2,ityp3,iblock)," eethet",
6362      &         eethet(k,m,ityp1,ityp2,ityp3,iblock)," ethetai",ethetai
6363 C        print *,"tu",cosph1(k),sinph1(k),cosph2(k),sinph2(k)
6364           enddo
6365         enddo
6366 C        print *,"cosph1", (cosph1(k), k=1,nsingle)
6367 C        print *,"cosph2", (cosph2(k), k=1,nsingle)
6368 C        print *,"sinph1", (sinph1(k), k=1,nsingle)
6369 C        print *,"sinph2", (sinph2(k), k=1,nsingle)
6370         if (lprn)
6371      &  write(iout,*) "ethetai",ethetai
6372 C        print *,"tu",cosph1(k),sinph1(k),cosph2(k),sinph2(k)
6373         do m=1,ntheterm3
6374           do k=2,ndouble
6375             do l=1,k-1
6376               aux=ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
6377      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l)+
6378      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
6379      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)
6380               ethetai=ethetai+sinkt(m)*aux
6381               dethetai=dethetai+0.5d0*m*coskt(m)*aux
6382               dephii=dephii+l*sinkt(m)*(
6383      &           -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)-
6384      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
6385      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
6386      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
6387               dephii1=dephii1+(k-l)*sinkt(m)*(
6388      &           -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
6389      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
6390      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)-
6391      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
6392               if (lprn) then
6393               write (iout,*) "m",m," k",k," l",l," ffthet",
6394      &            ffthet(l,k,m,ityp1,ityp2,ityp3,iblock),
6395      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)," ggthet",
6396      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock),
6397      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock),
6398      &            " ethetai",ethetai
6399               write (iout,*) cosph1ph2(l,k)*sinkt(m),
6400      &            cosph1ph2(k,l)*sinkt(m),
6401      &            sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
6402               endif
6403             enddo
6404           enddo
6405         enddo
6406 10      continue
6407 c        lprn1=.true.
6408 C        print *,ethetai
6409         if (lprn1)
6410      &    write (iout,'(i2,3f8.1,9h ethetai ,f10.5)')
6411      &   i,theta(i)*rad2deg,phii*rad2deg,
6412      &   phii1*rad2deg,ethetai
6413 c        lprn1=.false.
6414         etheta=etheta+ethetai
6415         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
6416         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
6417         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)+wang*dethetai
6418       enddo
6419
6420       return
6421       end
6422 #endif
6423 #ifdef CRYST_SC
6424 c-----------------------------------------------------------------------------
6425       subroutine esc(escloc)
6426 C Calculate the local energy of a side chain and its derivatives in the
6427 C corresponding virtual-bond valence angles THETA and the spherical angles
6428 C ALPHA and OMEGA.
6429       implicit real*8 (a-h,o-z)
6430       include 'DIMENSIONS'
6431       include 'COMMON.GEO'
6432       include 'COMMON.LOCAL'
6433       include 'COMMON.VAR'
6434       include 'COMMON.INTERACT'
6435       include 'COMMON.DERIV'
6436       include 'COMMON.CHAIN'
6437       include 'COMMON.IOUNITS'
6438       include 'COMMON.NAMES'
6439       include 'COMMON.FFIELD'
6440       include 'COMMON.CONTROL'
6441       double precision x(3),dersc(3),xemp(3),dersc0(3),dersc1(3),
6442      &     ddersc0(3),ddummy(3),xtemp(3),temp(3)
6443       common /sccalc/ time11,time12,time112,theti,it,nlobit
6444       delta=0.02d0*pi
6445       escloc=0.0D0
6446 c     write (iout,'(a)') 'ESC'
6447       do i=loc_start,loc_end
6448         it=itype(i)
6449         if (it.eq.ntyp1) cycle
6450         if (it.eq.10) goto 1
6451         nlobit=nlob(iabs(it))
6452 c       print *,'i=',i,' it=',it,' nlobit=',nlobit
6453 c       write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
6454         theti=theta(i+1)-pipol
6455         x(1)=dtan(theti)
6456         x(2)=alph(i)
6457         x(3)=omeg(i)
6458
6459         if (x(2).gt.pi-delta) then
6460           xtemp(1)=x(1)
6461           xtemp(2)=pi-delta
6462           xtemp(3)=x(3)
6463           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
6464           xtemp(2)=pi
6465           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
6466           call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),
6467      &        escloci,dersc(2))
6468           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
6469      &        ddersc0(1),dersc(1))
6470           call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),
6471      &        ddersc0(3),dersc(3))
6472           xtemp(2)=pi-delta
6473           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
6474           xtemp(2)=pi
6475           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
6476           call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,
6477      &            dersc0(2),esclocbi,dersc02)
6478           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
6479      &            dersc12,dersc01)
6480           call splinthet(x(2),0.5d0*delta,ss,ssd)
6481           dersc0(1)=dersc01
6482           dersc0(2)=dersc02
6483           dersc0(3)=0.0d0
6484           do k=1,3
6485             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
6486           enddo
6487           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
6488 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
6489 c    &             esclocbi,ss,ssd
6490           escloci=ss*escloci+(1.0d0-ss)*esclocbi
6491 c         escloci=esclocbi
6492 c         write (iout,*) escloci
6493         else if (x(2).lt.delta) then
6494           xtemp(1)=x(1)
6495           xtemp(2)=delta
6496           xtemp(3)=x(3)
6497           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
6498           xtemp(2)=0.0d0
6499           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
6500           call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),
6501      &        escloci,dersc(2))
6502           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
6503      &        ddersc0(1),dersc(1))
6504           call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),
6505      &        ddersc0(3),dersc(3))
6506           xtemp(2)=delta
6507           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
6508           xtemp(2)=0.0d0
6509           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
6510           call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,
6511      &            dersc0(2),esclocbi,dersc02)
6512           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
6513      &            dersc12,dersc01)
6514           dersc0(1)=dersc01
6515           dersc0(2)=dersc02
6516           dersc0(3)=0.0d0
6517           call splinthet(x(2),0.5d0*delta,ss,ssd)
6518           do k=1,3
6519             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
6520           enddo
6521           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
6522 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
6523 c    &             esclocbi,ss,ssd
6524           escloci=ss*escloci+(1.0d0-ss)*esclocbi
6525 c         write (iout,*) escloci
6526         else
6527           call enesc(x,escloci,dersc,ddummy,.false.)
6528         endif
6529
6530         escloc=escloc+escloci
6531         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
6532      &     'escloc',i,escloci
6533 c       write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
6534
6535         gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
6536      &   wscloc*dersc(1)
6537         gloc(ialph(i,1),icg)=wscloc*dersc(2)
6538         gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
6539     1   continue
6540       enddo
6541       return
6542       end
6543 C---------------------------------------------------------------------------
6544       subroutine enesc(x,escloci,dersc,ddersc,mixed)
6545       implicit real*8 (a-h,o-z)
6546       include 'DIMENSIONS'
6547       include 'COMMON.GEO'
6548       include 'COMMON.LOCAL'
6549       include 'COMMON.IOUNITS'
6550       common /sccalc/ time11,time12,time112,theti,it,nlobit
6551       double precision x(3),z(3),Ax(3,maxlob,-1:1),dersc(3),ddersc(3)
6552       double precision contr(maxlob,-1:1)
6553       logical mixed
6554 c       write (iout,*) 'it=',it,' nlobit=',nlobit
6555         escloc_i=0.0D0
6556         do j=1,3
6557           dersc(j)=0.0D0
6558           if (mixed) ddersc(j)=0.0d0
6559         enddo
6560         x3=x(3)
6561
6562 C Because of periodicity of the dependence of the SC energy in omega we have
6563 C to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
6564 C To avoid underflows, first compute & store the exponents.
6565
6566         do iii=-1,1
6567
6568           x(3)=x3+iii*dwapi
6569
6570           do j=1,nlobit
6571             do k=1,3
6572               z(k)=x(k)-censc(k,j,it)
6573             enddo
6574             do k=1,3
6575               Axk=0.0D0
6576               do l=1,3
6577                 Axk=Axk+gaussc(l,k,j,it)*z(l)
6578               enddo
6579               Ax(k,j,iii)=Axk
6580             enddo
6581             expfac=0.0D0
6582             do k=1,3
6583               expfac=expfac+Ax(k,j,iii)*z(k)
6584             enddo
6585             contr(j,iii)=expfac
6586           enddo ! j
6587
6588         enddo ! iii
6589
6590         x(3)=x3
6591 C As in the case of ebend, we want to avoid underflows in exponentiation and
6592 C subsequent NaNs and INFs in energy calculation.
6593 C Find the largest exponent
6594         emin=contr(1,-1)
6595         do iii=-1,1
6596           do j=1,nlobit
6597             if (emin.gt.contr(j,iii)) emin=contr(j,iii)
6598           enddo
6599         enddo
6600         emin=0.5D0*emin
6601 cd      print *,'it=',it,' emin=',emin
6602
6603 C Compute the contribution to SC energy and derivatives
6604         do iii=-1,1
6605
6606           do j=1,nlobit
6607 #ifdef OSF
6608             adexp=bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin
6609             if(adexp.ne.adexp) adexp=1.0
6610             expfac=dexp(adexp)
6611 #else
6612             expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin)
6613 #endif
6614 cd          print *,'j=',j,' expfac=',expfac
6615             escloc_i=escloc_i+expfac
6616             do k=1,3
6617               dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
6618             enddo
6619             if (mixed) then
6620               do k=1,3,2
6621                 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii)
6622      &            +gaussc(k,2,j,it))*expfac
6623               enddo
6624             endif
6625           enddo
6626
6627         enddo ! iii
6628
6629         dersc(1)=dersc(1)/cos(theti)**2
6630         ddersc(1)=ddersc(1)/cos(theti)**2
6631         ddersc(3)=ddersc(3)
6632
6633         escloci=-(dlog(escloc_i)-emin)
6634         do j=1,3
6635           dersc(j)=dersc(j)/escloc_i
6636         enddo
6637         if (mixed) then
6638           do j=1,3,2
6639             ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
6640           enddo
6641         endif
6642       return
6643       end
6644 C------------------------------------------------------------------------------
6645       subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
6646       implicit real*8 (a-h,o-z)
6647       include 'DIMENSIONS'
6648       include 'COMMON.GEO'
6649       include 'COMMON.LOCAL'
6650       include 'COMMON.IOUNITS'
6651       common /sccalc/ time11,time12,time112,theti,it,nlobit
6652       double precision x(3),z(3),Ax(3,maxlob),dersc(3)
6653       double precision contr(maxlob)
6654       logical mixed
6655
6656       escloc_i=0.0D0
6657
6658       do j=1,3
6659         dersc(j)=0.0D0
6660       enddo
6661
6662       do j=1,nlobit
6663         do k=1,2
6664           z(k)=x(k)-censc(k,j,it)
6665         enddo
6666         z(3)=dwapi
6667         do k=1,3
6668           Axk=0.0D0
6669           do l=1,3
6670             Axk=Axk+gaussc(l,k,j,it)*z(l)
6671           enddo
6672           Ax(k,j)=Axk
6673         enddo
6674         expfac=0.0D0
6675         do k=1,3
6676           expfac=expfac+Ax(k,j)*z(k)
6677         enddo
6678         contr(j)=expfac
6679       enddo ! j
6680
6681 C As in the case of ebend, we want to avoid underflows in exponentiation and
6682 C subsequent NaNs and INFs in energy calculation.
6683 C Find the largest exponent
6684       emin=contr(1)
6685       do j=1,nlobit
6686         if (emin.gt.contr(j)) emin=contr(j)
6687       enddo
6688       emin=0.5D0*emin
6689
6690 C Compute the contribution to SC energy and derivatives
6691
6692       dersc12=0.0d0
6693       do j=1,nlobit
6694         expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j)+emin)
6695         escloc_i=escloc_i+expfac
6696         do k=1,2
6697           dersc(k)=dersc(k)+Ax(k,j)*expfac
6698         enddo
6699         if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j)
6700      &            +gaussc(1,2,j,it))*expfac
6701         dersc(3)=0.0d0
6702       enddo
6703
6704       dersc(1)=dersc(1)/cos(theti)**2
6705       dersc12=dersc12/cos(theti)**2
6706       escloci=-(dlog(escloc_i)-emin)
6707       do j=1,2
6708         dersc(j)=dersc(j)/escloc_i
6709       enddo
6710       if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
6711       return
6712       end
6713 #else
6714 c----------------------------------------------------------------------------------
6715       subroutine esc(escloc)
6716 C Calculate the local energy of a side chain and its derivatives in the
6717 C corresponding virtual-bond valence angles THETA and the spherical angles
6718 C ALPHA and OMEGA derived from AM1 all-atom calculations.
6719 C added by Urszula Kozlowska. 07/11/2007
6720 C
6721       implicit real*8 (a-h,o-z)
6722       include 'DIMENSIONS'
6723       include 'COMMON.GEO'
6724       include 'COMMON.LOCAL'
6725       include 'COMMON.VAR'
6726       include 'COMMON.SCROT'
6727       include 'COMMON.INTERACT'
6728       include 'COMMON.DERIV'
6729       include 'COMMON.CHAIN'
6730       include 'COMMON.IOUNITS'
6731       include 'COMMON.NAMES'
6732       include 'COMMON.FFIELD'
6733       include 'COMMON.CONTROL'
6734       include 'COMMON.VECTORS'
6735       double precision x_prime(3),y_prime(3),z_prime(3)
6736      &    , sumene,dsc_i,dp2_i,x(65),
6737      &     xx,yy,zz,sumene1,sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6,
6738      &    de_dxx,de_dyy,de_dzz,de_dt
6739       double precision s1_t,s1_6_t,s2_t,s2_6_t
6740       double precision
6741      & dXX_Ci1(3),dYY_Ci1(3),dZZ_Ci1(3),dXX_Ci(3),
6742      & dYY_Ci(3),dZZ_Ci(3),dXX_XYZ(3),dYY_XYZ(3),dZZ_XYZ(3),
6743      & dt_dCi(3),dt_dCi1(3)
6744       common /sccalc/ time11,time12,time112,theti,it,nlobit
6745       delta=0.02d0*pi
6746       escloc=0.0D0
6747       do i=loc_start,loc_end
6748         if (itype(i).eq.ntyp1) cycle
6749         costtab(i+1) =dcos(theta(i+1))
6750         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
6751         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
6752         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
6753         cosfac2=0.5d0/(1.0d0+costtab(i+1))
6754         cosfac=dsqrt(cosfac2)
6755         sinfac2=0.5d0/(1.0d0-costtab(i+1))
6756         sinfac=dsqrt(sinfac2)
6757         it=iabs(itype(i))
6758         if (it.eq.10) goto 1
6759 c
6760 C  Compute the axes of tghe local cartesian coordinates system; store in
6761 c   x_prime, y_prime and z_prime
6762 c
6763         do j=1,3
6764           x_prime(j) = 0.00
6765           y_prime(j) = 0.00
6766           z_prime(j) = 0.00
6767         enddo
6768 C        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
6769 C     &   dc_norm(3,i+nres)
6770         do j = 1,3
6771           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
6772           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
6773         enddo
6774         do j = 1,3
6775           z_prime(j) = -uz(j,i-1)*dsign(1.0d0,dfloat(itype(i)))
6776         enddo
6777 c       write (2,*) "i",i
6778 c       write (2,*) "x_prime",(x_prime(j),j=1,3)
6779 c       write (2,*) "y_prime",(y_prime(j),j=1,3)
6780 c       write (2,*) "z_prime",(z_prime(j),j=1,3)
6781 c       write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
6782 c      & " xy",scalar(x_prime(1),y_prime(1)),
6783 c      & " xz",scalar(x_prime(1),z_prime(1)),
6784 c      & " yy",scalar(y_prime(1),y_prime(1)),
6785 c      & " yz",scalar(y_prime(1),z_prime(1)),
6786 c      & " zz",scalar(z_prime(1),z_prime(1))
6787 c
6788 C Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
6789 C to local coordinate system. Store in xx, yy, zz.
6790 c
6791         xx=0.0d0
6792         yy=0.0d0
6793         zz=0.0d0
6794         do j = 1,3
6795           xx = xx + x_prime(j)*dc_norm(j,i+nres)
6796           yy = yy + y_prime(j)*dc_norm(j,i+nres)
6797           zz = zz + z_prime(j)*dc_norm(j,i+nres)
6798         enddo
6799
6800         xxtab(i)=xx
6801         yytab(i)=yy
6802         zztab(i)=zz
6803 C
6804 C Compute the energy of the ith side cbain
6805 C
6806 c        write (2,*) "xx",xx," yy",yy," zz",zz
6807         it=iabs(itype(i))
6808         do j = 1,65
6809           x(j) = sc_parmin(j,it)
6810         enddo
6811 #ifdef CHECK_COORD
6812 Cc diagnostics - remove later
6813         xx1 = dcos(alph(2))
6814         yy1 = dsin(alph(2))*dcos(omeg(2))
6815         zz1 = -dsign(1.0,dfloat(itype(i)))*dsin(alph(2))*dsin(omeg(2))
6816         write(2,'(3f8.1,3f9.3,1x,3f9.3)')
6817      &    alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,
6818      &    xx1,yy1,zz1
6819 C,"  --- ", xx_w,yy_w,zz_w
6820 c end diagnostics
6821 #endif
6822         sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
6823      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
6824      &   + x(10)*yy*zz
6825         sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
6826      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
6827      & + x(20)*yy*zz
6828         sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
6829      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
6830      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
6831      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
6832      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
6833      &  +x(40)*xx*yy*zz
6834         sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
6835      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
6836      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
6837      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
6838      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
6839      &  +x(60)*xx*yy*zz
6840         dsc_i   = 0.743d0+x(61)
6841         dp2_i   = 1.9d0+x(62)
6842         dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
6843      &          *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
6844         dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
6845      &          *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
6846         s1=(1+x(63))/(0.1d0 + dscp1)
6847         s1_6=(1+x(64))/(0.1d0 + dscp1**6)
6848         s2=(1+x(65))/(0.1d0 + dscp2)
6849         s2_6=(1+x(65))/(0.1d0 + dscp2**6)
6850         sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6)
6851      & + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
6852 c        write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
6853 c     &   sumene4,
6854 c     &   dscp1,dscp2,sumene
6855 c        sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6856         escloc = escloc + sumene
6857         if (energy_dec) write (2,*) "i",i," itype",itype(i)," it",it,
6858      &   " escloc",sumene,escloc,it,itype(i)
6859 c     & ,zz,xx,yy
6860 c#define DEBUG
6861 #ifdef DEBUG
6862 C
6863 C This section to check the numerical derivatives of the energy of ith side
6864 C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
6865 C #define DEBUG in the code to turn it on.
6866 C
6867         write (2,*) "sumene               =",sumene
6868         aincr=1.0d-7
6869         xxsave=xx
6870         xx=xx+aincr
6871         write (2,*) xx,yy,zz
6872         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6873         de_dxx_num=(sumenep-sumene)/aincr
6874         xx=xxsave
6875         write (2,*) "xx+ sumene from enesc=",sumenep
6876         yysave=yy
6877         yy=yy+aincr
6878         write (2,*) xx,yy,zz
6879         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6880         de_dyy_num=(sumenep-sumene)/aincr
6881         yy=yysave
6882         write (2,*) "yy+ sumene from enesc=",sumenep
6883         zzsave=zz
6884         zz=zz+aincr
6885         write (2,*) xx,yy,zz
6886         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6887         de_dzz_num=(sumenep-sumene)/aincr
6888         zz=zzsave
6889         write (2,*) "zz+ sumene from enesc=",sumenep
6890         costsave=cost2tab(i+1)
6891         sintsave=sint2tab(i+1)
6892         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
6893         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
6894         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6895         de_dt_num=(sumenep-sumene)/aincr
6896         write (2,*) " t+ sumene from enesc=",sumenep
6897         cost2tab(i+1)=costsave
6898         sint2tab(i+1)=sintsave
6899 C End of diagnostics section.
6900 #endif
6901 C
6902 C Compute the gradient of esc
6903 C
6904 c        zz=zz*dsign(1.0,dfloat(itype(i)))
6905         pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
6906         pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
6907         pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
6908         pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
6909         pom_dx=dsc_i*dp2_i*cost2tab(i+1)
6910         pom_dy=dsc_i*dp2_i*sint2tab(i+1)
6911         pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
6912         pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
6913         pom1=(sumene3*sint2tab(i+1)+sumene1)
6914      &     *(pom_s1/dscp1+pom_s16*dscp1**4)
6915         pom2=(sumene4*cost2tab(i+1)+sumene2)
6916      &     *(pom_s2/dscp2+pom_s26*dscp2**4)
6917         sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
6918         sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2
6919      &  +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2)
6920      &  +x(40)*yy*zz
6921         sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
6922         sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2
6923      &  +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2)
6924      &  +x(60)*yy*zz
6925         de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6)
6926      &        +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6)
6927      &        +(pom1+pom2)*pom_dx
6928 #ifdef DEBUG
6929         write(2,*), "de_dxx = ", de_dxx,de_dxx_num,itype(i)
6930 #endif
6931 C
6932         sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
6933         sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2
6934      &  +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2)
6935      &  +x(40)*xx*zz
6936         sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
6937         sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz
6938      &  +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz
6939      &  +x(59)*zz**2 +x(60)*xx*zz
6940         de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6)
6941      &        +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6)
6942      &        +(pom1-pom2)*pom_dy
6943 #ifdef DEBUG
6944         write(2,*), "de_dyy = ", de_dyy,de_dyy_num,itype(i)
6945 #endif
6946 C
6947         de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy
6948      &  +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx
6949      &  +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6)
6950      &  +(x(4) + 2*x(7)*zz+  x(8)*xx + x(10)*yy)*(s1+s1_6)
6951      &  +(x(44)+2*x(47)*zz +x(48)*xx   +x(50)*yy  +3*x(53)*zz**2
6952      &  +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy
6953      &  +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6)
6954      &  + ( x(14) + 2*x(17)*zz+  x(18)*xx + x(20)*yy)*(s2+s2_6)
6955 #ifdef DEBUG
6956         write(2,*), "de_dzz = ", de_dzz,de_dzz_num,itype(i)
6957 #endif
6958 C
6959         de_dt =  0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6)
6960      &  -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6)
6961      &  +pom1*pom_dt1+pom2*pom_dt2
6962 #ifdef DEBUG
6963         write(2,*), "de_dt = ", de_dt,de_dt_num,itype(i)
6964 #endif
6965 c#undef DEBUG
6966 c
6967 C
6968        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
6969        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
6970        cosfac2xx=cosfac2*xx
6971        sinfac2yy=sinfac2*yy
6972        do k = 1,3
6973          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))*
6974      &      vbld_inv(i+1)
6975          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))*
6976      &      vbld_inv(i)
6977          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
6978          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
6979 c         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
6980 c     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
6981 c         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
6982 c     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
6983          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
6984          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
6985          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
6986          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
6987          dZZ_Ci1(k)=0.0d0
6988          dZZ_Ci(k)=0.0d0
6989          do j=1,3
6990            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)
6991      &     *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
6992            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)
6993      &     *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
6994          enddo
6995
6996          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
6997          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
6998          dZZ_XYZ(k)=vbld_inv(i+nres)*
6999      &   (z_prime(k)-zz*dC_norm(k,i+nres))
7000 c
7001          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
7002          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
7003        enddo
7004
7005        do k=1,3
7006          dXX_Ctab(k,i)=dXX_Ci(k)
7007          dXX_C1tab(k,i)=dXX_Ci1(k)
7008          dYY_Ctab(k,i)=dYY_Ci(k)
7009          dYY_C1tab(k,i)=dYY_Ci1(k)
7010          dZZ_Ctab(k,i)=dZZ_Ci(k)
7011          dZZ_C1tab(k,i)=dZZ_Ci1(k)
7012          dXX_XYZtab(k,i)=dXX_XYZ(k)
7013          dYY_XYZtab(k,i)=dYY_XYZ(k)
7014          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
7015        enddo
7016
7017        do k = 1,3
7018 c         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
7019 c     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
7020 c         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
7021 c     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
7022 c         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
7023 c     &    dt_dci(k)
7024 c         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
7025 c     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
7026          gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k)
7027      &    +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
7028          gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k)
7029      &    +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
7030          gsclocx(k,i)=                 de_dxx*dxx_XYZ(k)
7031      &    +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
7032        enddo
7033 c       write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
7034 c     &  (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
7035
7036 C to check gradient call subroutine check_grad
7037
7038     1 continue
7039       enddo
7040       return
7041       end
7042 c------------------------------------------------------------------------------
7043       double precision function enesc(x,xx,yy,zz,cost2,sint2)
7044       implicit none
7045       double precision x(65),xx,yy,zz,cost2,sint2,sumene1,sumene2,
7046      & sumene3,sumene4,sumene,dsc_i,dp2_i,dscp1,dscp2,s1,s1_6,s2,s2_6
7047       sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
7048      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
7049      &   + x(10)*yy*zz
7050       sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
7051      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
7052      & + x(20)*yy*zz
7053       sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
7054      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
7055      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
7056      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
7057      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
7058      &  +x(40)*xx*yy*zz
7059       sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
7060      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
7061      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
7062      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
7063      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
7064      &  +x(60)*xx*yy*zz
7065       dsc_i   = 0.743d0+x(61)
7066       dp2_i   = 1.9d0+x(62)
7067       dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
7068      &          *(xx*cost2+yy*sint2))
7069       dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
7070      &          *(xx*cost2-yy*sint2))
7071       s1=(1+x(63))/(0.1d0 + dscp1)
7072       s1_6=(1+x(64))/(0.1d0 + dscp1**6)
7073       s2=(1+x(65))/(0.1d0 + dscp2)
7074       s2_6=(1+x(65))/(0.1d0 + dscp2**6)
7075       sumene = ( sumene3*sint2 + sumene1)*(s1+s1_6)
7076      & + (sumene4*cost2 +sumene2)*(s2+s2_6)
7077       enesc=sumene
7078       return
7079       end
7080 #endif
7081 c------------------------------------------------------------------------------
7082       subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
7083 C
7084 C This procedure calculates two-body contact function g(rij) and its derivative:
7085 C
7086 C           eps0ij                                     !       x < -1
7087 C g(rij) =  esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5)  ! -1 =< x =< 1
7088 C            0                                         !       x > 1
7089 C
7090 C where x=(rij-r0ij)/delta
7091 C
7092 C rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
7093 C
7094       implicit none
7095       double precision rij,r0ij,eps0ij,fcont,fprimcont
7096       double precision x,x2,x4,delta
7097 c     delta=0.02D0*r0ij
7098 c      delta=0.2D0*r0ij
7099       x=(rij-r0ij)/delta
7100       if (x.lt.-1.0D0) then
7101         fcont=eps0ij
7102         fprimcont=0.0D0
7103       else if (x.le.1.0D0) then
7104         x2=x*x
7105         x4=x2*x2
7106         fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
7107         fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
7108       else
7109         fcont=0.0D0
7110         fprimcont=0.0D0
7111       endif
7112       return
7113       end
7114 c------------------------------------------------------------------------------
7115       subroutine splinthet(theti,delta,ss,ssder)
7116       implicit real*8 (a-h,o-z)
7117       include 'DIMENSIONS'
7118       include 'COMMON.VAR'
7119       include 'COMMON.GEO'
7120       thetup=pi-delta
7121       thetlow=delta
7122       if (theti.gt.pipol) then
7123         call gcont(theti,thetup,1.0d0,delta,ss,ssder)
7124       else
7125         call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
7126         ssder=-ssder
7127       endif
7128       return
7129       end
7130 c------------------------------------------------------------------------------
7131       subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
7132       implicit none
7133       double precision x,x0,delta,f0,f1,fprim0,f,fprim
7134       double precision ksi,ksi2,ksi3,a1,a2,a3
7135       a1=fprim0*delta/(f1-f0)
7136       a2=3.0d0-2.0d0*a1
7137       a3=a1-2.0d0
7138       ksi=(x-x0)/delta
7139       ksi2=ksi*ksi
7140       ksi3=ksi2*ksi
7141       f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
7142       fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
7143       return
7144       end
7145 c------------------------------------------------------------------------------
7146       subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
7147       implicit none
7148       double precision x,x0,delta,f0x,f1x,fprim0x,fx
7149       double precision ksi,ksi2,ksi3,a1,a2,a3
7150       ksi=(x-x0)/delta
7151       ksi2=ksi*ksi
7152       ksi3=ksi2*ksi
7153       a1=fprim0x*delta
7154       a2=3*(f1x-f0x)-2*fprim0x*delta
7155       a3=fprim0x*delta-2*(f1x-f0x)
7156       fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
7157       return
7158       end
7159 C-----------------------------------------------------------------------------
7160 #ifdef CRYST_TOR
7161 C-----------------------------------------------------------------------------
7162       subroutine etor(etors)
7163       implicit real*8 (a-h,o-z)
7164       include 'DIMENSIONS'
7165       include 'COMMON.VAR'
7166       include 'COMMON.GEO'
7167       include 'COMMON.LOCAL'
7168       include 'COMMON.TORSION'
7169       include 'COMMON.INTERACT'
7170       include 'COMMON.DERIV'
7171       include 'COMMON.CHAIN'
7172       include 'COMMON.NAMES'
7173       include 'COMMON.IOUNITS'
7174       include 'COMMON.FFIELD'
7175       include 'COMMON.TORCNSTR'
7176       include 'COMMON.CONTROL'
7177       logical lprn
7178 C Set lprn=.true. for debugging
7179       lprn=.false.
7180 c      lprn=.true.
7181       etors=0.0D0
7182       do i=iphi_start,iphi_end
7183       etors_ii=0.0D0
7184         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
7185      &      .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
7186         itori=itortyp(itype(i-2))
7187         itori1=itortyp(itype(i-1))
7188         phii=phi(i)
7189         gloci=0.0D0
7190 C Proline-Proline pair is a special case...
7191         if (itori.eq.3 .and. itori1.eq.3) then
7192           if (phii.gt.-dwapi3) then
7193             cosphi=dcos(3*phii)
7194             fac=1.0D0/(1.0D0-cosphi)
7195             etorsi=v1(1,3,3)*fac
7196             etorsi=etorsi+etorsi
7197             etors=etors+etorsi-v1(1,3,3)
7198             if (energy_dec) etors_ii=etors_ii+etorsi-v1(1,3,3)
7199             gloci=gloci-3*fac*etorsi*dsin(3*phii)
7200           endif
7201           do j=1,3
7202             v1ij=v1(j+1,itori,itori1)
7203             v2ij=v2(j+1,itori,itori1)
7204             cosphi=dcos(j*phii)
7205             sinphi=dsin(j*phii)
7206             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7207             if (energy_dec) etors_ii=etors_ii+
7208      &                              v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7209             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7210           enddo
7211         else
7212           do j=1,nterm_old
7213             v1ij=v1(j,itori,itori1)
7214             v2ij=v2(j,itori,itori1)
7215             cosphi=dcos(j*phii)
7216             sinphi=dsin(j*phii)
7217             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7218             if (energy_dec) etors_ii=etors_ii+
7219      &                  v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7220             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7221           enddo
7222         endif
7223         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
7224              'etor',i,etors_ii
7225         if (lprn)
7226      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
7227      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
7228      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
7229         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
7230 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
7231       enddo
7232       return
7233       end
7234 c------------------------------------------------------------------------------
7235       subroutine etor_d(etors_d)
7236       etors_d=0.0d0
7237       return
7238       end
7239 c----------------------------------------------------------------------------
7240 c LICZENIE WIEZOW Z ROWNANIA ENERGII MODELLERA
7241       subroutine e_modeller(ehomology_constr)
7242       ehomology_constr=0.0d0
7243       write (iout,*) "!!!!!UWAGA, JESTEM W DZIWNEJ PETLI, TEST!!!!!"
7244       return
7245       end
7246 C !!!!!!!! NIE CZYTANE !!!!!!!!!!!
7247
7248 c------------------------------------------------------------------------------
7249       subroutine etor_d(etors_d)
7250       etors_d=0.0d0
7251       return
7252       end
7253 c----------------------------------------------------------------------------
7254 #else
7255       subroutine etor(etors)
7256       implicit real*8 (a-h,o-z)
7257       include 'DIMENSIONS'
7258       include 'COMMON.VAR'
7259       include 'COMMON.GEO'
7260       include 'COMMON.LOCAL'
7261       include 'COMMON.TORSION'
7262       include 'COMMON.INTERACT'
7263       include 'COMMON.DERIV'
7264       include 'COMMON.CHAIN'
7265       include 'COMMON.NAMES'
7266       include 'COMMON.IOUNITS'
7267       include 'COMMON.FFIELD'
7268       include 'COMMON.TORCNSTR'
7269       include 'COMMON.CONTROL'
7270       logical lprn
7271 C Set lprn=.true. for debugging
7272       lprn=.false.
7273 c     lprn=.true.
7274       etors=0.0D0
7275       do i=iphi_start,iphi_end
7276 C ANY TWO ARE DUMMY ATOMS in row CYCLE
7277 c        if (((itype(i-3).eq.ntyp1).and.(itype(i-2).eq.ntyp1)).or.
7278 c     &      ((itype(i-2).eq.ntyp1).and.(itype(i-1).eq.ntyp1))  .or.
7279 c     &      ((itype(i-1).eq.ntyp1).and.(itype(i).eq.ntyp1))) cycle
7280         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
7281      &      .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
7282 C In current verion the ALL DUMMY ATOM POTENTIALS ARE OFF
7283 C For introducing the NH3+ and COO- group please check the etor_d for reference
7284 C and guidance
7285         etors_ii=0.0D0
7286          if (iabs(itype(i)).eq.20) then
7287          iblock=2
7288          else
7289          iblock=1
7290          endif
7291         itori=itortyp(itype(i-2))
7292         itori1=itortyp(itype(i-1))
7293         phii=phi(i)
7294         gloci=0.0D0
7295 C Regular cosine and sine terms
7296         do j=1,nterm(itori,itori1,iblock)
7297           v1ij=v1(j,itori,itori1,iblock)
7298           v2ij=v2(j,itori,itori1,iblock)
7299           cosphi=dcos(j*phii)
7300           sinphi=dsin(j*phii)
7301           etors=etors+v1ij*cosphi+v2ij*sinphi
7302           if (energy_dec) etors_ii=etors_ii+
7303      &                v1ij*cosphi+v2ij*sinphi
7304           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7305         enddo
7306 C Lorentz terms
7307 C                         v1
7308 C  E = SUM ----------------------------------- - v1
7309 C          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
7310 C
7311         cosphi=dcos(0.5d0*phii)
7312         sinphi=dsin(0.5d0*phii)
7313         do j=1,nlor(itori,itori1,iblock)
7314           vl1ij=vlor1(j,itori,itori1)
7315           vl2ij=vlor2(j,itori,itori1)
7316           vl3ij=vlor3(j,itori,itori1)
7317           pom=vl2ij*cosphi+vl3ij*sinphi
7318           pom1=1.0d0/(pom*pom+1.0d0)
7319           etors=etors+vl1ij*pom1
7320           if (energy_dec) etors_ii=etors_ii+
7321      &                vl1ij*pom1
7322           pom=-pom*pom1*pom1
7323           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
7324         enddo
7325 C Subtract the constant term
7326         etors=etors-v0(itori,itori1,iblock)
7327           if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
7328      &         'etor',i,etors_ii-v0(itori,itori1,iblock)
7329         if (lprn)
7330      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
7331      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
7332      &  (v1(j,itori,itori1,iblock),j=1,6),
7333      &  (v2(j,itori,itori1,iblock),j=1,6)
7334         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
7335 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
7336       enddo
7337       return
7338       end
7339 c----------------------------------------------------------------------------
7340       subroutine etor_d(etors_d)
7341 C 6/23/01 Compute double torsional energy
7342       implicit real*8 (a-h,o-z)
7343       include 'DIMENSIONS'
7344       include 'COMMON.VAR'
7345       include 'COMMON.GEO'
7346       include 'COMMON.LOCAL'
7347       include 'COMMON.TORSION'
7348       include 'COMMON.INTERACT'
7349       include 'COMMON.DERIV'
7350       include 'COMMON.CHAIN'
7351       include 'COMMON.NAMES'
7352       include 'COMMON.IOUNITS'
7353       include 'COMMON.FFIELD'
7354       include 'COMMON.TORCNSTR'
7355       logical lprn
7356 C Set lprn=.true. for debugging
7357       lprn=.false.
7358 c     lprn=.true.
7359       etors_d=0.0D0
7360 c      write(iout,*) "a tu??"
7361       do i=iphid_start,iphid_end
7362 C ANY TWO ARE DUMMY ATOMS in row CYCLE
7363 C        if (((itype(i-3).eq.ntyp1).and.(itype(i-2).eq.ntyp1)).or.
7364 C     &      ((itype(i-2).eq.ntyp1).and.(itype(i-1).eq.ntyp1)).or.
7365 C     &      ((itype(i-1).eq.ntyp1).and.(itype(i).eq.ntyp1))  .or.
7366 C     &      ((itype(i).eq.ntyp1).and.(itype(i+1).eq.ntyp1))) cycle
7367          if ((itype(i-2).eq.ntyp1).or.itype(i-3).eq.ntyp1.or.
7368      &  (itype(i-1).eq.ntyp1).or.(itype(i).eq.ntyp1).or.
7369      &  (itype(i+1).eq.ntyp1)) cycle
7370 C In current verion the ALL DUMMY ATOM POTENTIALS ARE OFF
7371         itori=itortyp(itype(i-2))
7372         itori1=itortyp(itype(i-1))
7373         itori2=itortyp(itype(i))
7374         phii=phi(i)
7375         phii1=phi(i+1)
7376         gloci1=0.0D0
7377         gloci2=0.0D0
7378         iblock=1
7379         if (iabs(itype(i+1)).eq.20) iblock=2
7380 C Iblock=2 Proline type
7381 C ADASKO: WHEN PARAMETERS FOR THIS TYPE OF BLOCKING GROUP IS READY UNCOMMENT
7382 C CHECK WEATHER THERE IS NECCESITY FOR iblock=3 for COO-
7383 C        if (itype(i+1).eq.ntyp1) iblock=3
7384 C The problem of NH3+ group can be resolved by adding new parameters please note if there
7385 C IS or IS NOT need for this
7386 C IF Yes uncomment below and add to parmread.F appropriate changes and to v1cij and so on
7387 C        is (itype(i-3).eq.ntyp1) ntblock=2
7388 C        ntblock is N-terminal blocking group
7389
7390 C Regular cosine and sine terms
7391         do j=1,ntermd_1(itori,itori1,itori2,iblock)
7392 C Example of changes for NH3+ blocking group
7393 C       do j=1,ntermd_1(itori,itori1,itori2,iblock,ntblock)
7394 C          v1cij=v1c(1,j,itori,itori1,itori2,iblock,ntblock)
7395           v1cij=v1c(1,j,itori,itori1,itori2,iblock)
7396           v1sij=v1s(1,j,itori,itori1,itori2,iblock)
7397           v2cij=v1c(2,j,itori,itori1,itori2,iblock)
7398           v2sij=v1s(2,j,itori,itori1,itori2,iblock)
7399           cosphi1=dcos(j*phii)
7400           sinphi1=dsin(j*phii)
7401           cosphi2=dcos(j*phii1)
7402           sinphi2=dsin(j*phii1)
7403           etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+
7404      &     v2cij*cosphi2+v2sij*sinphi2
7405           gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
7406           gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
7407         enddo
7408         do k=2,ntermd_2(itori,itori1,itori2,iblock)
7409           do l=1,k-1
7410             v1cdij = v2c(k,l,itori,itori1,itori2,iblock)
7411             v2cdij = v2c(l,k,itori,itori1,itori2,iblock)
7412             v1sdij = v2s(k,l,itori,itori1,itori2,iblock)
7413             v2sdij = v2s(l,k,itori,itori1,itori2,iblock)
7414             cosphi1p2=dcos(l*phii+(k-l)*phii1)
7415             cosphi1m2=dcos(l*phii-(k-l)*phii1)
7416             sinphi1p2=dsin(l*phii+(k-l)*phii1)
7417             sinphi1m2=dsin(l*phii-(k-l)*phii1)
7418             etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+
7419      &        v1sdij*sinphi1p2+v2sdij*sinphi1m2
7420             gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2
7421      &        -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
7422             gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2
7423      &        -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
7424           enddo
7425         enddo
7426         gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*gloci1
7427         gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*gloci2
7428       enddo
7429       return
7430       end
7431 #endif
7432 C----------------------------------------------------------------------------------
7433 C The rigorous attempt to derive energy function
7434       subroutine etor_kcc(etors)
7435       implicit real*8 (a-h,o-z)
7436       include 'DIMENSIONS'
7437       include 'COMMON.VAR'
7438       include 'COMMON.GEO'
7439       include 'COMMON.LOCAL'
7440       include 'COMMON.TORSION'
7441       include 'COMMON.INTERACT'
7442       include 'COMMON.DERIV'
7443       include 'COMMON.CHAIN'
7444       include 'COMMON.NAMES'
7445       include 'COMMON.IOUNITS'
7446       include 'COMMON.FFIELD'
7447       include 'COMMON.TORCNSTR'
7448       include 'COMMON.CONTROL'
7449       double precision c1(0:maxval_kcc),c2(0:maxval_kcc)
7450       logical lprn
7451 c      double precision thybt1(maxtermkcc),thybt2(maxtermkcc)
7452 C Set lprn=.true. for debugging
7453       lprn=energy_dec
7454 c     lprn=.true.
7455 C      print *,"wchodze kcc"
7456       if (lprn) write (iout,*) "etor_kcc tor_mode",tor_mode
7457       etors=0.0D0
7458       do i=iphi_start,iphi_end
7459 C ANY TWO ARE DUMMY ATOMS in row CYCLE
7460 c        if (((itype(i-3).eq.ntyp1).and.(itype(i-2).eq.ntyp1)).or.
7461 c     &      ((itype(i-2).eq.ntyp1).and.(itype(i-1).eq.ntyp1))  .or.
7462 c     &      ((itype(i-1).eq.ntyp1).and.(itype(i).eq.ntyp1))) cycle
7463         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
7464      &      .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
7465         itori=itortyp(itype(i-2))
7466         itori1=itortyp(itype(i-1))
7467         phii=phi(i)
7468         glocig=0.0D0
7469         glocit1=0.0d0
7470         glocit2=0.0d0
7471 C to avoid multiple devision by 2
7472 c        theti22=0.5d0*theta(i)
7473 C theta 12 is the theta_1 /2
7474 C theta 22 is theta_2 /2
7475 c        theti12=0.5d0*theta(i-1)
7476 C and appropriate sinus function
7477         sinthet1=dsin(theta(i-1))
7478         sinthet2=dsin(theta(i))
7479         costhet1=dcos(theta(i-1))
7480         costhet2=dcos(theta(i))
7481 C to speed up lets store its mutliplication
7482         sint1t2=sinthet2*sinthet1
7483         sint1t2n=1.0d0
7484 C \sum_{i=1}^n (sin(theta_1) * sin(theta_2))^n * (c_n* cos(n*gamma)
7485 C +d_n*sin(n*gamma)) *
7486 C \sum_{i=1}^m (1+a_m*Tb_m(cos(theta_1 /2))+b_m*Tb_m(cos(theta_2 /2)))
7487 C we have two sum 1) Non-Chebyshev which is with n and gamma
7488         nval=nterm_kcc_Tb(itori,itori1)
7489         c1(0)=0.0d0
7490         c2(0)=0.0d0
7491         c1(1)=1.0d0
7492         c2(1)=1.0d0
7493         do j=2,nval
7494           c1(j)=c1(j-1)*costhet1
7495           c2(j)=c2(j-1)*costhet2
7496         enddo
7497         etori=0.0d0
7498         do j=1,nterm_kcc(itori,itori1)
7499           cosphi=dcos(j*phii)
7500           sinphi=dsin(j*phii)
7501           sint1t2n1=sint1t2n
7502           sint1t2n=sint1t2n*sint1t2
7503           sumvalc=0.0d0
7504           gradvalct1=0.0d0
7505           gradvalct2=0.0d0
7506           do k=1,nval
7507             do l=1,nval
7508               sumvalc=sumvalc+v1_kcc(l,k,j,itori1,itori)*c1(k)*c2(l)
7509               gradvalct1=gradvalct1+
7510      &           (k-1)*v1_kcc(l,k,j,itori1,itori)*c1(k-1)*c2(l)
7511               gradvalct2=gradvalct2+
7512      &           (l-1)*v1_kcc(l,k,j,itori1,itori)*c1(k)*c2(l-1)
7513             enddo
7514           enddo
7515           gradvalct1=-gradvalct1*sinthet1
7516           gradvalct2=-gradvalct2*sinthet2
7517           sumvals=0.0d0
7518           gradvalst1=0.0d0
7519           gradvalst2=0.0d0
7520           do k=1,nval
7521             do l=1,nval
7522               sumvals=sumvals+v2_kcc(l,k,j,itori1,itori)*c1(k)*c2(l)
7523               gradvalst1=gradvalst1+
7524      &           (k-1)*v2_kcc(l,k,j,itori1,itori)*c1(k-1)*c2(l)
7525               gradvalst2=gradvalst2+
7526      &           (l-1)*v2_kcc(l,k,j,itori1,itori)*c1(k)*c2(l-1)
7527             enddo
7528           enddo
7529           gradvalst1=-gradvalst1*sinthet1
7530           gradvalst2=-gradvalst2*sinthet2
7531           if (lprn) write (iout,*)j,"sumvalc",sumvalc," sumvals",sumvals
7532           etori=etori+sint1t2n*(sumvalc*cosphi+sumvals*sinphi)
7533 C glocig is the gradient local i site in gamma
7534           glocig=glocig+j*sint1t2n*(sumvals*cosphi-sumvalc*sinphi)
7535 C now gradient over theta_1
7536           glocit1=glocit1+sint1t2n*(gradvalct1*cosphi+gradvalst1*sinphi)
7537      &   +j*sint1t2n1*costhet1*sinthet2*(sumvalc*cosphi+sumvals*sinphi)
7538           glocit2=glocit2+sint1t2n*(gradvalct2*cosphi+gradvalst2*sinphi)
7539      &   +j*sint1t2n1*sinthet1*costhet2*(sumvalc*cosphi+sumvals*sinphi)
7540         enddo ! j
7541         etors=etors+etori
7542 C derivative over gamma
7543         gloc(i-3,icg)=gloc(i-3,icg)+wtor*glocig
7544 C derivative over theta1
7545         gloc(nphi+i-3,icg)=gloc(nphi+i-3,icg)+wtor*glocit1
7546 C now derivative over theta2
7547         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)+wtor*glocit2
7548         if (lprn) then
7549           write (iout,*) i-2,i-1,itype(i-2),itype(i-1),itori,itori1,
7550      &       theta(i-1)*rad2deg,theta(i)*rad2deg,phii*rad2deg,etori
7551           write (iout,*) "c1",(c1(k),k=0,nval),
7552      &    " c2",(c2(k),k=0,nval)
7553         endif
7554       enddo
7555       return
7556       end
7557 c---------------------------------------------------------------------------------------------
7558       subroutine etor_constr(edihcnstr)
7559       implicit real*8 (a-h,o-z)
7560       include 'DIMENSIONS'
7561       include 'COMMON.VAR'
7562       include 'COMMON.GEO'
7563       include 'COMMON.LOCAL'
7564       include 'COMMON.TORSION'
7565       include 'COMMON.INTERACT'
7566       include 'COMMON.DERIV'
7567       include 'COMMON.CHAIN'
7568       include 'COMMON.NAMES'
7569       include 'COMMON.IOUNITS'
7570       include 'COMMON.FFIELD'
7571       include 'COMMON.TORCNSTR'
7572       include 'COMMON.BOUNDS'
7573       include 'COMMON.CONTROL'
7574 ! 6/20/98 - dihedral angle constraints
7575       edihcnstr=0.0d0
7576 c      do i=1,ndih_constr
7577       if (raw_psipred) then
7578         do i=idihconstr_start,idihconstr_end
7579           itori=idih_constr(i)
7580           phii=phi(itori)
7581           gaudih_i=vpsipred(1,i)
7582           gauder_i=0.0d0
7583           do j=1,2
7584             s = sdihed(j,i)
7585             cos_i=(1.0d0-dcos(phii-phibound(j,i)))/s**2
7586             dexpcos_i=dexp(-cos_i*cos_i)
7587             gaudih_i=gaudih_i+vpsipred(j+1,i)*dexpcos_i
7588             gauder_i=gauder_i-2*vpsipred(j+1,i)*dsin(phii-phibound(j,i))
7589      &            *cos_i*dexpcos_i/s**2
7590           enddo
7591           edihcnstr=edihcnstr-wdihc*dlog(gaudih_i)
7592           gloc(itori-3,icg)=gloc(itori-3,icg)-wdihc*gauder_i/gaudih_i
7593           if (energy_dec)
7594      &     write (iout,'(2i5,f8.3,f8.5,2(f8.5,2f8.3),f10.5)')
7595      &     i,itori,phii*rad2deg,vpsipred(1,i),vpsipred(2,i),
7596      &     phibound(1,i)*rad2deg,sdihed(1,i)*rad2deg,vpsipred(3,i),
7597      &     phibound(2,i)*rad2deg,sdihed(2,i)*rad2deg,
7598      &     -wdihc*dlog(gaudih_i)
7599         enddo
7600       else
7601
7602       do i=idihconstr_start,idihconstr_end
7603         itori=idih_constr(i)
7604         phii=phi(itori)
7605         difi=pinorm(phii-phi0(i))
7606         if (difi.gt.drange(i)) then
7607           difi=difi-drange(i)
7608           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
7609           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
7610         else if (difi.lt.-drange(i)) then
7611           difi=difi+drange(i)
7612           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
7613           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
7614         else
7615           difi=0.0
7616         endif
7617       enddo
7618
7619       endif
7620
7621       return
7622       end
7623 c----------------------------------------------------------------------------
7624 c MODELLER restraint function
7625       subroutine e_modeller(ehomology_constr)
7626       implicit none
7627       include 'DIMENSIONS'
7628
7629       double precision ehomology_constr
7630       integer nnn,i,ii,j,k,ijk,jik,ki,kk,nexl,irec,l
7631       integer katy, odleglosci, test7
7632       real*8 odleg, odleg2, odleg3, kat, kat2, kat3, gdih(max_template)
7633       real*8 Eval,Erot
7634       real*8 distance(max_template),distancek(max_template),
7635      &    min_odl,godl(max_template),dih_diff(max_template)
7636
7637 c
7638 c     FP - 30/10/2014 Temporary specifications for homology restraints
7639 c
7640       double precision utheta_i,gutheta_i,sum_gtheta,sum_sgtheta,
7641      &                 sgtheta
7642       double precision, dimension (maxres) :: guscdiff,usc_diff
7643       double precision, dimension (max_template) ::
7644      &           gtheta,dscdiff,uscdiffk,guscdiff2,guscdiff3,
7645      &           theta_diff
7646       double precision sum_godl,sgodl,grad_odl3,ggodl,sum_gdih,
7647      & sum_guscdiff,sum_sgdih,sgdih,grad_dih3,usc_diff_i,dxx,dyy,dzz,
7648      & betai,sum_sgodl,dij
7649       double precision dist,pinorm
7650 c
7651       include 'COMMON.SBRIDGE'
7652       include 'COMMON.CHAIN'
7653       include 'COMMON.GEO'
7654       include 'COMMON.DERIV'
7655       include 'COMMON.LOCAL'
7656       include 'COMMON.INTERACT'
7657       include 'COMMON.VAR'
7658       include 'COMMON.IOUNITS'
7659 c      include 'COMMON.MD'
7660       include 'COMMON.CONTROL'
7661       include 'COMMON.HOMOLOGY'
7662       include 'COMMON.QRESTR'
7663 c
7664 c     From subroutine Econstr_back
7665 c
7666       include 'COMMON.NAMES'
7667       include 'COMMON.TIME1'
7668 c
7669
7670
7671       do i=1,max_template
7672         distancek(i)=9999999.9
7673       enddo
7674
7675
7676       odleg=0.0d0
7677
7678 c Pseudo-energy and gradient from homology restraints (MODELLER-like
7679 c function)
7680 C AL 5/2/14 - Introduce list of restraints
7681 c     write(iout,*) "waga_theta",waga_theta,"waga_d",waga_d
7682 #ifdef DEBUG
7683       write(iout,*) "------- dist restrs start -------"
7684 #endif
7685       do ii = link_start_homo,link_end_homo
7686          i = ires_homo(ii)
7687          j = jres_homo(ii)
7688          dij=dist(i,j)
7689 c        write (iout,*) "dij(",i,j,") =",dij
7690          nexl=0
7691          do k=1,constr_homology
7692 c           write(iout,*) ii,k,i,j,l_homo(k,ii),dij,odl(k,ii)
7693            if(.not.l_homo(k,ii)) then
7694              nexl=nexl+1
7695              cycle
7696            endif
7697            distance(k)=odl(k,ii)-dij
7698 c          write (iout,*) "distance(",k,") =",distance(k)
7699 c
7700 c          For Gaussian-type Urestr
7701 c
7702            distancek(k)=0.5d0*distance(k)**2*sigma_odl(k,ii) ! waga_dist rmvd from Gaussian argument
7703 c          write (iout,*) "sigma_odl(",k,ii,") =",sigma_odl(k,ii)
7704 c          write (iout,*) "distancek(",k,") =",distancek(k)
7705 c          distancek(k)=0.5d0*waga_dist*distance(k)**2*sigma_odl(k,ii)
7706 c
7707 c          For Lorentzian-type Urestr
7708 c
7709            if (waga_dist.lt.0.0d0) then
7710               sigma_odlir(k,ii)=dsqrt(1/sigma_odl(k,ii))
7711               distancek(k)=distance(k)**2/(sigma_odlir(k,ii)*
7712      &                     (distance(k)**2+sigma_odlir(k,ii)**2))
7713            endif
7714          enddo
7715
7716 c         min_odl=minval(distancek)
7717          if (nexl.gt.0) then
7718            min_odl=0.0d0
7719          else
7720            do kk=1,constr_homology
7721             if(l_homo(kk,ii)) then
7722               min_odl=distancek(kk)
7723               exit
7724             endif
7725            enddo
7726            do kk=1,constr_homology
7727             if(l_homo(kk,ii) .and. distancek(kk).lt.min_odl)
7728      &              min_odl=distancek(kk)
7729            enddo
7730          endif
7731
7732 c        write (iout,* )"min_odl",min_odl
7733 #ifdef DEBUG
7734          write (iout,*) "ij dij",i,j,dij
7735          write (iout,*) "distance",(distance(k),k=1,constr_homology)
7736          write (iout,*) "distancek",(distancek(k),k=1,constr_homology)
7737          write (iout,* )"min_odl",min_odl
7738 #endif
7739 #ifdef OLDRESTR
7740          odleg2=0.0d0
7741 #else
7742          if (waga_dist.ge.0.0d0) then
7743            odleg2=nexl
7744          else
7745            odleg2=0.0d0
7746          endif
7747 #endif
7748          do k=1,constr_homology
7749 c Nie wiem po co to liczycie jeszcze raz!
7750 c            odleg3=-waga_dist(iset)*((distance(i,j,k)**2)/
7751 c     &              (2*(sigma_odl(i,j,k))**2))
7752            if(.not.l_homo(k,ii)) cycle
7753            if (waga_dist.ge.0.0d0) then
7754 c
7755 c          For Gaussian-type Urestr
7756 c
7757             godl(k)=dexp(-distancek(k)+min_odl)
7758             odleg2=odleg2+godl(k)
7759 c
7760 c          For Lorentzian-type Urestr
7761 c
7762            else
7763             odleg2=odleg2+distancek(k)
7764            endif
7765
7766 ccc       write(iout,779) i,j,k, "odleg2=",odleg2, "odleg3=", odleg3,
7767 ccc     & "dEXP(odleg3)=", dEXP(odleg3),"distance(i,j,k)^2=",
7768 ccc     & distance(i,j,k)**2, "dist(i+1,j+1)=", dist(i+1,j+1),
7769 ccc     & "sigma_odl(i,j,k)=", sigma_odl(i,j,k)
7770
7771          enddo
7772 c        write (iout,*) "godl",(godl(k),k=1,constr_homology) ! exponents
7773 c        write (iout,*) "ii i j",ii,i,j," odleg2",odleg2 ! sum of exps
7774 #ifdef DEBUG
7775          write (iout,*) "godl",(godl(k),k=1,constr_homology) ! exponents
7776          write (iout,*) "ii i j",ii,i,j," odleg2",odleg2 ! sum of exps
7777 #endif
7778            if (waga_dist.ge.0.0d0) then
7779 c
7780 c          For Gaussian-type Urestr
7781 c
7782               odleg=odleg-dLOG(odleg2/constr_homology)+min_odl
7783 c
7784 c          For Lorentzian-type Urestr
7785 c
7786            else
7787               odleg=odleg+odleg2/constr_homology
7788            endif
7789 c
7790 c        write (iout,*) "odleg",odleg ! sum of -ln-s
7791 c Gradient
7792 c
7793 c          For Gaussian-type Urestr
7794 c
7795          if (waga_dist.ge.0.0d0) sum_godl=odleg2
7796          sum_sgodl=0.0d0
7797          do k=1,constr_homology
7798 c            godl=dexp(((-(distance(i,j,k)**2)/(2*(sigma_odl(i,j,k))**2))
7799 c     &           *waga_dist)+min_odl
7800 c          sgodl=-godl(k)*distance(k)*sigma_odl(k,ii)*waga_dist
7801 c
7802          if(.not.l_homo(k,ii)) cycle
7803          if (waga_dist.ge.0.0d0) then
7804 c          For Gaussian-type Urestr
7805 c
7806            sgodl=-godl(k)*distance(k)*sigma_odl(k,ii) ! waga_dist rmvd
7807 c
7808 c          For Lorentzian-type Urestr
7809 c
7810          else
7811            sgodl=-2*sigma_odlir(k,ii)*(distance(k)/(distance(k)**2+
7812      &           sigma_odlir(k,ii)**2)**2)
7813          endif
7814            sum_sgodl=sum_sgodl+sgodl
7815
7816 c            sgodl2=sgodl2+sgodl
7817 c      write(iout,*) i, j, k, distance(i,j,k), "W GRADIENCIE1"
7818 c      write(iout,*) "constr_homology=",constr_homology
7819 c      write(iout,*) i, j, k, "TEST K"
7820          enddo
7821          if (waga_dist.ge.0.0d0) then
7822 c
7823 c          For Gaussian-type Urestr
7824 c
7825             grad_odl3=waga_homology(iset)*waga_dist
7826      &                *sum_sgodl/(sum_godl*dij)
7827 c
7828 c          For Lorentzian-type Urestr
7829 c
7830          else
7831 c Original grad expr modified by analogy w Gaussian-type Urestr grad
7832 c           grad_odl3=-waga_homology(iset)*waga_dist*sum_sgodl
7833             grad_odl3=-waga_homology(iset)*waga_dist*
7834      &                sum_sgodl/(constr_homology*dij)
7835          endif
7836 c
7837 c        grad_odl3=sum_sgodl/(sum_godl*dij)
7838
7839
7840 c      write(iout,*) i, j, k, distance(i,j,k), "W GRADIENCIE2"
7841 c      write(iout,*) (distance(i,j,k)**2), (2*(sigma_odl(i,j,k))**2),
7842 c     &              (-(distance(i,j,k)**2)/(2*(sigma_odl(i,j,k))**2))
7843
7844 ccc      write(iout,*) godl, sgodl, grad_odl3
7845
7846 c          grad_odl=grad_odl+grad_odl3
7847
7848          do jik=1,3
7849             ggodl=grad_odl3*(c(jik,i)-c(jik,j))
7850 ccc      write(iout,*) c(jik,i+1), c(jik,j+1), (c(jik,i+1)-c(jik,j+1))
7851 ccc      write(iout,746) "GRAD_ODL_1", i, j, jik, ggodl,
7852 ccc     &              ghpbc(jik,i+1), ghpbc(jik,j+1)
7853             ghpbc(jik,i)=ghpbc(jik,i)+ggodl
7854             ghpbc(jik,j)=ghpbc(jik,j)-ggodl
7855 ccc      write(iout,746) "GRAD_ODL_2", i, j, jik, ggodl,
7856 ccc     &              ghpbc(jik,i+1), ghpbc(jik,j+1)
7857 c         if (i.eq.25.and.j.eq.27) then
7858 c         write(iout,*) "jik",jik,"i",i,"j",j
7859 c         write(iout,*) "sum_sgodl",sum_sgodl,"sgodl",sgodl
7860 c         write(iout,*) "grad_odl3",grad_odl3
7861 c         write(iout,*) "c(",jik,i,")",c(jik,i),"c(",jik,j,")",c(jik,j)
7862 c         write(iout,*) "ggodl",ggodl
7863 c         write(iout,*) "ghpbc(",jik,i,")",
7864 c     &                 ghpbc(jik,i),"ghpbc(",jik,j,")",
7865 c     &                 ghpbc(jik,j)
7866 c         endif
7867          enddo
7868 ccc       write(iout,778)"TEST: odleg2=", odleg2, "DLOG(odleg2)=",
7869 ccc     & dLOG(odleg2),"-odleg=", -odleg
7870
7871       enddo ! ii-loop for dist
7872 #ifdef DEBUG
7873       write(iout,*) "------- dist restrs end -------"
7874 c     if (waga_angle.eq.1.0d0 .or. waga_theta.eq.1.0d0 .or.
7875 c    &     waga_d.eq.1.0d0) call sum_gradient
7876 #endif
7877 c Pseudo-energy and gradient from dihedral-angle restraints from
7878 c homology templates
7879 c      write (iout,*) "End of distance loop"
7880 c      call flush(iout)
7881       kat=0.0d0
7882 c      write (iout,*) idihconstr_start_homo,idihconstr_end_homo
7883 #ifdef DEBUG
7884       write(iout,*) "------- dih restrs start -------"
7885       do i=idihconstr_start_homo,idihconstr_end_homo
7886         write (iout,*) "gloc_init(",i,icg,")",gloc(i,icg)
7887       enddo
7888 #endif
7889       do i=idihconstr_start_homo,idihconstr_end_homo
7890         kat2=0.0d0
7891 c        betai=beta(i,i+1,i+2,i+3)
7892         betai = phi(i)
7893 c       write (iout,*) "betai =",betai
7894         do k=1,constr_homology
7895           dih_diff(k)=pinorm(dih(k,i)-betai)
7896 cd          write (iout,'(a8,2i4,2f15.8)') "dih_diff",i,k,dih_diff(k)
7897 cd     &                  ,sigma_dih(k,i)
7898 c          if (dih_diff(i,k).gt.3.14159) dih_diff(i,k)=
7899 c     &                                   -(6.28318-dih_diff(i,k))
7900 c          if (dih_diff(i,k).lt.-3.14159) dih_diff(i,k)=
7901 c     &                                   6.28318+dih_diff(i,k)
7902 #ifdef OLD_DIHED
7903           kat3=-0.5d0*dih_diff(k)**2*sigma_dih(k,i) ! waga_angle rmvd from Gaussian argument
7904 #else
7905           kat3=(dcos(dih_diff(k))-1)*sigma_dih(k,i) ! waga_angle rmvd from Gaussian argument
7906 #endif
7907 c         kat3=-0.5d0*waga_angle*dih_diff(k)**2*sigma_dih(k,i)
7908           gdih(k)=dexp(kat3)
7909           kat2=kat2+gdih(k)
7910 c          write(iout,*) "kat2=", kat2, "exp(kat3)=", exp(kat3)
7911 c          write(*,*)""
7912         enddo
7913 c       write (iout,*) "gdih",(gdih(k),k=1,constr_homology) ! exps
7914 c       write (iout,*) "i",i," betai",betai," kat2",kat2 ! sum of exps
7915 #ifdef DEBUG
7916         write (iout,*) "i",i," betai",betai," kat2",kat2
7917         write (iout,*) "gdih",(gdih(k),k=1,constr_homology)
7918 #endif
7919         if (kat2.le.1.0d-14) cycle
7920         kat=kat-dLOG(kat2/constr_homology)
7921 c       write (iout,*) "kat",kat ! sum of -ln-s
7922
7923 ccc       write(iout,778)"TEST: kat2=", kat2, "DLOG(kat2)=",
7924 ccc     & dLOG(kat2), "-kat=", -kat
7925
7926 c ----------------------------------------------------------------------
7927 c Gradient
7928 c ----------------------------------------------------------------------
7929
7930         sum_gdih=kat2
7931         sum_sgdih=0.0d0
7932         do k=1,constr_homology
7933 #ifdef OLD_DIHED
7934           sgdih=-gdih(k)*dih_diff(k)*sigma_dih(k,i)  ! waga_angle rmvd
7935 #else
7936           sgdih=-gdih(k)*dsin(dih_diff(k))*sigma_dih(k,i)  ! waga_angle rmvd
7937 #endif
7938 c         sgdih=-gdih(k)*dih_diff(k)*sigma_dih(k,i)*waga_angle
7939           sum_sgdih=sum_sgdih+sgdih
7940         enddo
7941 c       grad_dih3=sum_sgdih/sum_gdih
7942         grad_dih3=waga_homology(iset)*waga_angle*sum_sgdih/sum_gdih
7943
7944 c      write(iout,*)i,k,gdih,sgdih,beta(i+1,i+2,i+3,i+4),grad_dih3
7945 ccc      write(iout,747) "GRAD_KAT_1", i, nphi, icg, grad_dih3,
7946 ccc     & gloc(nphi+i-3,icg)
7947         gloc(i-3,icg)=gloc(i-3,icg)+grad_dih3
7948 c        if (i.eq.25) then
7949 c        write(iout,*) "i",i,"icg",icg,"gloc(",i,icg,")",gloc(i,icg)
7950 c        endif
7951 ccc      write(iout,747) "GRAD_KAT_2", i, nphi, icg, grad_dih3,
7952 ccc     & gloc(nphi+i-3,icg)
7953
7954       enddo ! i-loop for dih
7955 #ifdef DEBUG
7956       write(iout,*) "------- dih restrs end -------"
7957 #endif
7958
7959 c Pseudo-energy and gradient for theta angle restraints from
7960 c homology templates
7961 c FP 01/15 - inserted from econstr_local_test.F, loop structure
7962 c adapted
7963
7964 c
7965 c     For constr_homology reference structures (FP)
7966 c
7967 c     Uconst_back_tot=0.0d0
7968       Eval=0.0d0
7969       Erot=0.0d0
7970 c     Econstr_back legacy
7971       do i=1,nres
7972 c     do i=ithet_start,ithet_end
7973        dutheta(i)=0.0d0
7974 c     enddo
7975 c     do i=loc_start,loc_end
7976         do j=1,3
7977           duscdiff(j,i)=0.0d0
7978           duscdiffx(j,i)=0.0d0
7979         enddo
7980       enddo
7981 c
7982 c     do iref=1,nref
7983 c     write (iout,*) "ithet_start =",ithet_start,"ithet_end =",ithet_end
7984 c     write (iout,*) "waga_theta",waga_theta
7985       if (waga_theta.gt.0.0d0) then
7986 #ifdef DEBUG
7987       write (iout,*) "usampl",usampl
7988       write(iout,*) "------- theta restrs start -------"
7989 c     do i=ithet_start,ithet_end
7990 c       write (iout,*) "gloc_init(",nphi+i,icg,")",gloc(nphi+i,icg)
7991 c     enddo
7992 #endif
7993 c     write (iout,*) "maxres",maxres,"nres",nres
7994
7995       do i=ithet_start,ithet_end
7996 c
7997 c     do i=1,nfrag_back
7998 c       ii = ifrag_back(2,i,iset)-ifrag_back(1,i,iset)
7999 c
8000 c Deviation of theta angles wrt constr_homology ref structures
8001 c
8002         utheta_i=0.0d0 ! argument of Gaussian for single k
8003         gutheta_i=0.0d0 ! Sum of Gaussians over constr_homology ref structures
8004 c       do j=ifrag_back(1,i,iset)+2,ifrag_back(2,i,iset) ! original loop
8005 c       over residues in a fragment
8006 c       write (iout,*) "theta(",i,")=",theta(i)
8007         do k=1,constr_homology
8008 c
8009 c         dtheta_i=theta(j)-thetaref(j,iref)
8010 c         dtheta_i=thetaref(k,i)-theta(i) ! original form without indexing
8011           theta_diff(k)=thetatpl(k,i)-theta(i)
8012 cd          write (iout,'(a8,2i4,2f15.8)') "theta_diff",i,k,theta_diff(k)
8013 cd     &                  ,sigma_theta(k,i)
8014
8015 c
8016           utheta_i=-0.5d0*theta_diff(k)**2*sigma_theta(k,i) ! waga_theta rmvd from Gaussian argument
8017 c         utheta_i=-0.5d0*waga_theta*theta_diff(k)**2*sigma_theta(k,i) ! waga_theta?
8018           gtheta(k)=dexp(utheta_i) ! + min_utheta_i?
8019           gutheta_i=gutheta_i+gtheta(k)  ! Sum of Gaussians (pk)
8020 c         Gradient for single Gaussian restraint in subr Econstr_back
8021 c         dutheta(j-2)=dutheta(j-2)+wfrag_back(1,i,iset)*dtheta_i/(ii-1)
8022 c
8023         enddo
8024 c       write (iout,*) "gtheta",(gtheta(k),k=1,constr_homology) ! exps
8025 c       write (iout,*) "i",i," gutheta_i",gutheta_i ! sum of exps
8026
8027 c
8028 c         Gradient for multiple Gaussian restraint
8029         sum_gtheta=gutheta_i
8030         sum_sgtheta=0.0d0
8031         do k=1,constr_homology
8032 c        New generalized expr for multiple Gaussian from Econstr_back
8033          sgtheta=-gtheta(k)*theta_diff(k)*sigma_theta(k,i) ! waga_theta rmvd
8034 c
8035 c        sgtheta=-gtheta(k)*theta_diff(k)*sigma_theta(k,i)*waga_theta ! right functional form?
8036           sum_sgtheta=sum_sgtheta+sgtheta ! cum variable
8037         enddo
8038 c       Final value of gradient using same var as in Econstr_back
8039         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)
8040      &      +sum_sgtheta/sum_gtheta*waga_theta
8041      &               *waga_homology(iset)
8042 c        dutheta(i-2)=sum_sgtheta/sum_gtheta*waga_theta
8043 c     &               *waga_homology(iset)
8044 c       dutheta(i)=sum_sgtheta/sum_gtheta
8045 c
8046 c       Uconst_back=Uconst_back+waga_theta*utheta(i) ! waga_theta added as weight
8047         Eval=Eval-dLOG(gutheta_i/constr_homology)
8048 c       write (iout,*) "utheta(",i,")=",utheta(i) ! -ln of sum of exps
8049 c       write (iout,*) "Uconst_back",Uconst_back ! sum of -ln-s
8050 c       Uconst_back=Uconst_back+utheta(i)
8051       enddo ! (i-loop for theta)
8052 #ifdef DEBUG
8053       write(iout,*) "------- theta restrs end -------"
8054 #endif
8055       endif
8056 c
8057 c Deviation of local SC geometry
8058 c
8059 c Separation of two i-loops (instructed by AL - 11/3/2014)
8060 c
8061 c     write (iout,*) "loc_start =",loc_start,"loc_end =",loc_end
8062 c     write (iout,*) "waga_d",waga_d
8063
8064 #ifdef DEBUG
8065       write(iout,*) "------- SC restrs start -------"
8066       write (iout,*) "Initial duscdiff,duscdiffx"
8067       do i=loc_start,loc_end
8068         write (iout,*) i,(duscdiff(jik,i),jik=1,3),
8069      &                 (duscdiffx(jik,i),jik=1,3)
8070       enddo
8071 #endif
8072       do i=loc_start,loc_end
8073         usc_diff_i=0.0d0 ! argument of Gaussian for single k
8074         guscdiff(i)=0.0d0 ! Sum of Gaussians over constr_homology ref structures
8075 c       do j=ifrag_back(1,i,iset)+1,ifrag_back(2,i,iset)-1 ! Econstr_back legacy
8076 c       write(iout,*) "xxtab, yytab, zztab"
8077 c       write(iout,'(i5,3f8.2)') i,xxtab(i),yytab(i),zztab(i)
8078         do k=1,constr_homology
8079 c
8080           dxx=-xxtpl(k,i)+xxtab(i) ! Diff b/w x component of ith SC vector in model and kth ref str?
8081 c                                    Original sign inverted for calc of gradients (s. Econstr_back)
8082           dyy=-yytpl(k,i)+yytab(i) ! ibid y
8083           dzz=-zztpl(k,i)+zztab(i) ! ibid z
8084 c         write(iout,*) "dxx, dyy, dzz"
8085 cd          write(iout,'(2i5,4f8.2)') k,i,dxx,dyy,dzz,sigma_d(k,i)
8086 c
8087           usc_diff_i=-0.5d0*(dxx**2+dyy**2+dzz**2)*sigma_d(k,i)  ! waga_d rmvd from Gaussian argument
8088 c         usc_diff(i)=-0.5d0*waga_d*(dxx**2+dyy**2+dzz**2)*sigma_d(k,i) ! waga_d?
8089 c         uscdiffk(k)=usc_diff(i)
8090           guscdiff2(k)=dexp(usc_diff_i) ! without min_scdiff
8091 c          write(iout,*) "i",i," k",k," sigma_d",sigma_d(k,i),
8092 c     &       " guscdiff2",guscdiff2(k)
8093           guscdiff(i)=guscdiff(i)+guscdiff2(k)  !Sum of Gaussians (pk)
8094 c          write (iout,'(i5,6f10.5)') j,xxtab(j),yytab(j),zztab(j),
8095 c     &      xxref(j),yyref(j),zzref(j)
8096         enddo
8097 c
8098 c       Gradient
8099 c
8100 c       Generalized expression for multiple Gaussian acc to that for a single
8101 c       Gaussian in Econstr_back as instructed by AL (FP - 03/11/2014)
8102 c
8103 c       Original implementation
8104 c       sum_guscdiff=guscdiff(i)
8105 c
8106 c       sum_sguscdiff=0.0d0
8107 c       do k=1,constr_homology
8108 c          sguscdiff=-guscdiff2(k)*dscdiff(k)*sigma_d(k,i)*waga_d !waga_d?
8109 c          sguscdiff=-guscdiff3(k)*dscdiff(k)*sigma_d(k,i)*waga_d ! w min_uscdiff
8110 c          sum_sguscdiff=sum_sguscdiff+sguscdiff
8111 c       enddo
8112 c
8113 c       Implementation of new expressions for gradient (Jan. 2015)
8114 c
8115 c       grad_uscdiff=sum_sguscdiff/(sum_guscdiff*dtab) !?
8116         do k=1,constr_homology
8117 c
8118 c       New calculation of dxx, dyy, and dzz corrected by AL (07/11), was missing and wrong
8119 c       before. Now the drivatives should be correct
8120 c
8121           dxx=-xxtpl(k,i)+xxtab(i) ! Diff b/w x component of ith SC vector in model and kth ref str?
8122 c                                  Original sign inverted for calc of gradients (s. Econstr_back)
8123           dyy=-yytpl(k,i)+yytab(i) ! ibid y
8124           dzz=-zztpl(k,i)+zztab(i) ! ibid z
8125 c
8126 c         New implementation
8127 c
8128           sum_guscdiff=guscdiff2(k)*!(dsqrt(dxx*dxx+dyy*dyy+dzz*dzz))* -> wrong!
8129      &                 sigma_d(k,i) ! for the grad wrt r'
8130 c         sum_sguscdiff=sum_sguscdiff+sum_guscdiff
8131 c
8132 c
8133 c        New implementation
8134          sum_guscdiff = waga_homology(iset)*waga_d*sum_guscdiff
8135          do jik=1,3
8136             duscdiff(jik,i-1)=duscdiff(jik,i-1)+
8137      &      sum_guscdiff*(dXX_C1tab(jik,i)*dxx+
8138      &      dYY_C1tab(jik,i)*dyy+dZZ_C1tab(jik,i)*dzz)/guscdiff(i)
8139             duscdiff(jik,i)=duscdiff(jik,i)+
8140      &      sum_guscdiff*(dXX_Ctab(jik,i)*dxx+
8141      &      dYY_Ctab(jik,i)*dyy+dZZ_Ctab(jik,i)*dzz)/guscdiff(i)
8142             duscdiffx(jik,i)=duscdiffx(jik,i)+
8143      &      sum_guscdiff*(dXX_XYZtab(jik,i)*dxx+
8144      &      dYY_XYZtab(jik,i)*dyy+dZZ_XYZtab(jik,i)*dzz)/guscdiff(i)
8145 c
8146 #ifdef DEBUG
8147              write(iout,*) "jik",jik,"i",i
8148              write(iout,*) "dxx, dyy, dzz"
8149              write(iout,'(2i5,3f8.2)') k,i,dxx,dyy,dzz
8150              write(iout,*) "guscdiff2(",k,")",guscdiff2(k)
8151 c            write(iout,*) "sum_sguscdiff",sum_sguscdiff
8152 cc           write(iout,*) "dXX_Ctab(",jik,i,")",dXX_Ctab(jik,i)
8153 c            write(iout,*) "dYY_Ctab(",jik,i,")",dYY_Ctab(jik,i)
8154 c            write(iout,*) "dZZ_Ctab(",jik,i,")",dZZ_Ctab(jik,i)
8155 c            write(iout,*) "dXX_C1tab(",jik,i,")",dXX_C1tab(jik,i)
8156 c            write(iout,*) "dYY_C1tab(",jik,i,")",dYY_C1tab(jik,i)
8157 c            write(iout,*) "dZZ_C1tab(",jik,i,")",dZZ_C1tab(jik,i)
8158 c            write(iout,*) "dXX_XYZtab(",jik,i,")",dXX_XYZtab(jik,i)
8159 c            write(iout,*) "dYY_XYZtab(",jik,i,")",dYY_XYZtab(jik,i)
8160 c            write(iout,*) "dZZ_XYZtab(",jik,i,")",dZZ_XYZtab(jik,i)
8161 c            write(iout,*) "duscdiff(",jik,i-1,")",duscdiff(jik,i-1)
8162 c            write(iout,*) "duscdiff(",jik,i,")",duscdiff(jik,i)
8163 c            write(iout,*) "duscdiffx(",jik,i,")",duscdiffx(jik,i)
8164 c            endif
8165 #endif
8166          enddo
8167         enddo
8168 c
8169 c       uscdiff(i)=-dLOG(guscdiff(i)/(ii-1))      ! Weighting by (ii-1) required?
8170 c        usc_diff(i)=-dLOG(guscdiff(i)/constr_homology) ! + min_uscdiff ?
8171 c
8172 c        write (iout,*) i," uscdiff",uscdiff(i)
8173 c
8174 c Put together deviations from local geometry
8175
8176 c       Uconst_back=Uconst_back+wfrag_back(1,i,iset)*utheta(i)+
8177 c      &            wfrag_back(3,i,iset)*uscdiff(i)
8178         Erot=Erot-dLOG(guscdiff(i)/constr_homology)
8179 c       write (iout,*) "usc_diff(",i,")=",usc_diff(i) ! -ln of sum of exps
8180 c       write (iout,*) "Uconst_back",Uconst_back ! cum sum of -ln-s
8181 c       Uconst_back=Uconst_back+usc_diff(i)
8182 c
8183 c     Gradient of multiple Gaussian restraint (FP - 04/11/2014 - right?)
8184 c
8185 c     New implment: multiplied by sum_sguscdiff
8186 c
8187
8188       enddo ! (i-loop for dscdiff)
8189
8190 c      endif
8191
8192 #ifdef DEBUG
8193       write(iout,*) "------- SC restrs end -------"
8194         write (iout,*) "------ After SC loop in e_modeller ------"
8195         do i=loc_start,loc_end
8196          write (iout,*) "i",i," gradc",(gradc(j,i,icg),j=1,3)
8197          write (iout,*) "i",i," gradx",(gradx(j,i,icg),j=1,3)
8198         enddo
8199       if (waga_theta.eq.1.0d0) then
8200       write (iout,*) "in e_modeller after SC restr end: dutheta"
8201       do i=ithet_start,ithet_end
8202         write (iout,*) i,dutheta(i)
8203       enddo
8204       endif
8205       if (waga_d.eq.1.0d0) then
8206       write (iout,*) "e_modeller after SC loop: duscdiff/x"
8207       do i=1,nres
8208         write (iout,*) i,(duscdiff(j,i),j=1,3)
8209         write (iout,*) i,(duscdiffx(j,i),j=1,3)
8210       enddo
8211       endif
8212 #endif
8213
8214 c Total energy from homology restraints
8215 #ifdef DEBUG
8216       write (iout,*) "odleg",odleg," kat",kat
8217 #endif
8218 c
8219 c Addition of energy of theta angle and SC local geom over constr_homologs ref strs
8220 c
8221 c     ehomology_constr=odleg+kat
8222 c
8223 c     For Lorentzian-type Urestr
8224 c
8225
8226       if (waga_dist.ge.0.0d0) then
8227 c
8228 c          For Gaussian-type Urestr
8229 c
8230         ehomology_constr=(waga_dist*odleg+waga_angle*kat+
8231      &              waga_theta*Eval+waga_d*Erot)*waga_homology(iset)
8232 c     write (iout,*) "ehomology_constr=",ehomology_constr
8233       else
8234 c
8235 c          For Lorentzian-type Urestr
8236 c
8237         ehomology_constr=(-waga_dist*odleg+waga_angle*kat+
8238      &              waga_theta*Eval+waga_d*Erot)*waga_homology(iset)
8239 c     write (iout,*) "ehomology_constr=",ehomology_constr
8240       endif
8241 #ifdef DEBUG
8242       write (iout,*) "odleg",waga_dist,odleg," kat",waga_angle,kat,
8243      & "Eval",waga_theta,eval,
8244      &   "Erot",waga_d,Erot
8245       write (iout,*) "ehomology_constr",ehomology_constr
8246 #endif
8247       return
8248 c
8249 c FP 01/15 end
8250 c
8251   748 format(a8,f12.3,a6,f12.3,a7,f12.3)
8252   747 format(a12,i4,i4,i4,f8.3,f8.3)
8253   746 format(a12,i4,i4,i4,f8.3,f8.3,f8.3)
8254   778 format(a7,1X,f10.3,1X,a4,1X,f10.3,1X,a5,1X,f10.3)
8255   779 format(i3,1X,i3,1X,i2,1X,a7,1X,f7.3,1X,a7,1X,f7.3,1X,a13,1X,
8256      &       f7.3,1X,a17,1X,f9.3,1X,a10,1X,f8.3,1X,a10,1X,f8.3)
8257       end
8258 c----------------------------------------------------------------------------
8259 C The rigorous attempt to derive energy function
8260       subroutine ebend_kcc(etheta)
8261
8262       implicit real*8 (a-h,o-z)
8263       include 'DIMENSIONS'
8264       include 'COMMON.VAR'
8265       include 'COMMON.GEO'
8266       include 'COMMON.LOCAL'
8267       include 'COMMON.TORSION'
8268       include 'COMMON.INTERACT'
8269       include 'COMMON.DERIV'
8270       include 'COMMON.CHAIN'
8271       include 'COMMON.NAMES'
8272       include 'COMMON.IOUNITS'
8273       include 'COMMON.FFIELD'
8274       include 'COMMON.TORCNSTR'
8275       include 'COMMON.CONTROL'
8276       logical lprn
8277       double precision thybt1(maxang_kcc)
8278 C Set lprn=.true. for debugging
8279       lprn=energy_dec
8280 c     lprn=.true.
8281 C      print *,"wchodze kcc"
8282       if (lprn) write (iout,*) "ebend_kcc tor_mode",tor_mode
8283       etheta=0.0D0
8284       do i=ithet_start,ithet_end
8285 c        print *,i,itype(i-1),itype(i),itype(i-2)
8286         if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
8287      &  .or.itype(i).eq.ntyp1) cycle
8288         iti=iabs(itortyp(itype(i-1)))
8289         sinthet=dsin(theta(i))
8290         costhet=dcos(theta(i))
8291         do j=1,nbend_kcc_Tb(iti)
8292           thybt1(j)=v1bend_chyb(j,iti)
8293         enddo
8294         sumth1thyb=v1bend_chyb(0,iti)+
8295      &    tschebyshev(1,nbend_kcc_Tb(iti),thybt1(1),costhet)
8296         if (lprn) write (iout,*) i-1,itype(i-1),iti,theta(i)*rad2deg,
8297      &    sumth1thyb
8298         ihelp=nbend_kcc_Tb(iti)-1
8299         gradthybt1=gradtschebyshev(0,ihelp,thybt1(1),costhet)
8300         etheta=etheta+sumth1thyb
8301 C        print *,sumth1thyb,gradthybt1,sinthet*(-0.5d0)
8302         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)-wang*gradthybt1*sinthet
8303       enddo
8304       return
8305       end
8306 c-------------------------------------------------------------------------------------
8307       subroutine etheta_constr(ethetacnstr)
8308
8309       implicit real*8 (a-h,o-z)
8310       include 'DIMENSIONS'
8311       include 'COMMON.VAR'
8312       include 'COMMON.GEO'
8313       include 'COMMON.LOCAL'
8314       include 'COMMON.TORSION'
8315       include 'COMMON.INTERACT'
8316       include 'COMMON.DERIV'
8317       include 'COMMON.CHAIN'
8318       include 'COMMON.NAMES'
8319       include 'COMMON.IOUNITS'
8320       include 'COMMON.FFIELD'
8321       include 'COMMON.TORCNSTR'
8322       include 'COMMON.CONTROL'
8323       ethetacnstr=0.0d0
8324 C      print *,ithetaconstr_start,ithetaconstr_end,"TU"
8325       do i=ithetaconstr_start,ithetaconstr_end
8326         itheta=itheta_constr(i)
8327         thetiii=theta(itheta)
8328         difi=pinorm(thetiii-theta_constr0(i))
8329         if (difi.gt.theta_drange(i)) then
8330           difi=difi-theta_drange(i)
8331           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
8332           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
8333      &    +for_thet_constr(i)*difi**3
8334         else if (difi.lt.-drange(i)) then
8335           difi=difi+drange(i)
8336           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
8337           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
8338      &    +for_thet_constr(i)*difi**3
8339         else
8340           difi=0.0
8341         endif
8342        if (energy_dec) then
8343         write (iout,'(a6,2i5,4f8.3,2e14.5)') "ethetc",
8344      &    i,itheta,rad2deg*thetiii,
8345      &    rad2deg*theta_constr0(i),  rad2deg*theta_drange(i),
8346      &    rad2deg*difi,0.25d0*for_thet_constr(i)*difi**4,
8347      &    gloc(itheta+nphi-2,icg)
8348         endif
8349       enddo
8350       return
8351       end
8352 c------------------------------------------------------------------------------
8353       subroutine eback_sc_corr(esccor)
8354 c 7/21/2007 Correlations between the backbone-local and side-chain-local
8355 c        conformational states; temporarily implemented as differences
8356 c        between UNRES torsional potentials (dependent on three types of
8357 c        residues) and the torsional potentials dependent on all 20 types
8358 c        of residues computed from AM1  energy surfaces of terminally-blocked
8359 c        amino-acid residues.
8360       implicit real*8 (a-h,o-z)
8361       include 'DIMENSIONS'
8362       include 'COMMON.VAR'
8363       include 'COMMON.GEO'
8364       include 'COMMON.LOCAL'
8365       include 'COMMON.TORSION'
8366       include 'COMMON.SCCOR'
8367       include 'COMMON.INTERACT'
8368       include 'COMMON.DERIV'
8369       include 'COMMON.CHAIN'
8370       include 'COMMON.NAMES'
8371       include 'COMMON.IOUNITS'
8372       include 'COMMON.FFIELD'
8373       include 'COMMON.CONTROL'
8374       logical lprn
8375 C Set lprn=.true. for debugging
8376       lprn=.false.
8377 c      lprn=.true.
8378 c      write (iout,*) "EBACK_SC_COR",itau_start,itau_end
8379       esccor=0.0D0
8380       do i=itau_start,itau_end
8381         if ((itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)) cycle
8382         esccor_ii=0.0D0
8383         isccori=isccortyp(itype(i-2))
8384         isccori1=isccortyp(itype(i-1))
8385 c      write (iout,*) "EBACK_SC_COR",i,nterm_sccor(isccori,isccori1)
8386         phii=phi(i)
8387         do intertyp=1,3 !intertyp
8388 cc Added 09 May 2012 (Adasko)
8389 cc  Intertyp means interaction type of backbone mainchain correlation:
8390 c   1 = SC...Ca...Ca...Ca
8391 c   2 = Ca...Ca...Ca...SC
8392 c   3 = SC...Ca...Ca...SCi
8393         gloci=0.0D0
8394         if (((intertyp.eq.3).and.((itype(i-2).eq.10).or.
8395      &      (itype(i-1).eq.10).or.(itype(i-2).eq.ntyp1).or.
8396      &      (itype(i-1).eq.ntyp1)))
8397      &    .or. ((intertyp.eq.1).and.((itype(i-2).eq.10)
8398      &     .or.(itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)
8399      &     .or.(itype(i).eq.ntyp1)))
8400      &    .or.((intertyp.eq.2).and.((itype(i-1).eq.10).or.
8401      &      (itype(i-1).eq.ntyp1).or.(itype(i-2).eq.ntyp1).or.
8402      &      (itype(i-3).eq.ntyp1)))) cycle
8403         if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1).eq.ntyp1)) cycle
8404         if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres).eq.ntyp1))
8405      & cycle
8406        do j=1,nterm_sccor(isccori,isccori1)
8407           v1ij=v1sccor(j,intertyp,isccori,isccori1)
8408           v2ij=v2sccor(j,intertyp,isccori,isccori1)
8409           cosphi=dcos(j*tauangle(intertyp,i))
8410           sinphi=dsin(j*tauangle(intertyp,i))
8411           esccor=esccor+v1ij*cosphi+v2ij*sinphi
8412           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
8413         enddo
8414 c      write (iout,*) "EBACK_SC_COR",i,v1ij*cosphi+v2ij*sinphi,intertyp
8415         gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci
8416         if (lprn)
8417      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
8418      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,isccori,isccori1,
8419      &  (v1sccor(j,intertyp,isccori,isccori1),j=1,6)
8420      & ,(v2sccor(j,intertyp,isccori,isccori1),j=1,6)
8421         gsccor_loc(i-3)=gsccor_loc(i-3)+gloci
8422        enddo !intertyp
8423       enddo
8424
8425       return
8426       end
8427 #ifdef FOURBODY
8428 c----------------------------------------------------------------------------
8429       subroutine multibody(ecorr)
8430 C This subroutine calculates multi-body contributions to energy following
8431 C the idea of Skolnick et al. If side chains I and J make a contact and
8432 C at the same time side chains I+1 and J+1 make a contact, an extra
8433 C contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
8434       implicit real*8 (a-h,o-z)
8435       include 'DIMENSIONS'
8436       include 'COMMON.IOUNITS'
8437       include 'COMMON.DERIV'
8438       include 'COMMON.INTERACT'
8439       include 'COMMON.CONTACTS'
8440       include 'COMMON.CONTMAT'
8441       include 'COMMON.CORRMAT'
8442       double precision gx(3),gx1(3)
8443       logical lprn
8444
8445 C Set lprn=.true. for debugging
8446       lprn=.false.
8447
8448       if (lprn) then
8449         write (iout,'(a)') 'Contact function values:'
8450         do i=nnt,nct-2
8451           write (iout,'(i2,20(1x,i2,f10.5))')
8452      &        i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
8453         enddo
8454       endif
8455       ecorr=0.0D0
8456       do i=nnt,nct
8457         do j=1,3
8458           gradcorr(j,i)=0.0D0
8459           gradxorr(j,i)=0.0D0
8460         enddo
8461       enddo
8462       do i=nnt,nct-2
8463
8464         DO ISHIFT = 3,4
8465
8466         i1=i+ishift
8467         num_conti=num_cont(i)
8468         num_conti1=num_cont(i1)
8469         do jj=1,num_conti
8470           j=jcont(jj,i)
8471           do kk=1,num_conti1
8472             j1=jcont(kk,i1)
8473             if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
8474 cd          write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
8475 cd   &                   ' ishift=',ishift
8476 C Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
8477 C The system gains extra energy.
8478               ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
8479             endif   ! j1==j+-ishift
8480           enddo     ! kk
8481         enddo       ! jj
8482
8483         ENDDO ! ISHIFT
8484
8485       enddo         ! i
8486       return
8487       end
8488 c------------------------------------------------------------------------------
8489       double precision function esccorr(i,j,k,l,jj,kk)
8490       implicit real*8 (a-h,o-z)
8491       include 'DIMENSIONS'
8492       include 'COMMON.IOUNITS'
8493       include 'COMMON.DERIV'
8494       include 'COMMON.INTERACT'
8495       include 'COMMON.CONTACTS'
8496       include 'COMMON.CONTMAT'
8497       include 'COMMON.CORRMAT'
8498       include 'COMMON.SHIELD'
8499       double precision gx(3),gx1(3)
8500       logical lprn
8501       lprn=.false.
8502       eij=facont(jj,i)
8503       ekl=facont(kk,k)
8504 cd    write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
8505 C Calculate the multi-body contribution to energy.
8506 C Calculate multi-body contributions to the gradient.
8507 cd    write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
8508 cd   & k,l,(gacont(m,kk,k),m=1,3)
8509       do m=1,3
8510         gx(m) =ekl*gacont(m,jj,i)
8511         gx1(m)=eij*gacont(m,kk,k)
8512         gradxorr(m,i)=gradxorr(m,i)-gx(m)
8513         gradxorr(m,j)=gradxorr(m,j)+gx(m)
8514         gradxorr(m,k)=gradxorr(m,k)-gx1(m)
8515         gradxorr(m,l)=gradxorr(m,l)+gx1(m)
8516       enddo
8517       do m=i,j-1
8518         do ll=1,3
8519           gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
8520         enddo
8521       enddo
8522       do m=k,l-1
8523         do ll=1,3
8524           gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
8525         enddo
8526       enddo
8527       esccorr=-eij*ekl
8528       return
8529       end
8530 c------------------------------------------------------------------------------
8531       subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
8532 C This subroutine calculates multi-body contributions to hydrogen-bonding
8533       implicit real*8 (a-h,o-z)
8534       include 'DIMENSIONS'
8535       include 'COMMON.IOUNITS'
8536 #ifdef MPI
8537       include "mpif.h"
8538       parameter (max_cont=maxconts)
8539       parameter (max_dim=26)
8540       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
8541       double precision zapas(max_dim,maxconts,max_fg_procs),
8542      &  zapas_recv(max_dim,maxconts,max_fg_procs)
8543       common /przechowalnia/ zapas
8544       integer status(MPI_STATUS_SIZE),req(maxconts*2),
8545      &  status_array(MPI_STATUS_SIZE,maxconts*2)
8546 #endif
8547       include 'COMMON.SETUP'
8548       include 'COMMON.FFIELD'
8549       include 'COMMON.DERIV'
8550       include 'COMMON.INTERACT'
8551       include 'COMMON.CONTACTS'
8552       include 'COMMON.CONTMAT'
8553       include 'COMMON.CORRMAT'
8554       include 'COMMON.CONTROL'
8555       include 'COMMON.LOCAL'
8556       double precision gx(3),gx1(3),time00
8557       logical lprn,ldone
8558
8559 C Set lprn=.true. for debugging
8560       lprn=.false.
8561 #ifdef MPI
8562       n_corr=0
8563       n_corr1=0
8564       if (nfgtasks.le.1) goto 30
8565       if (lprn) then
8566         write (iout,'(a)') 'Contact function values before RECEIVE:'
8567         do i=nnt,nct-2
8568           write (iout,'(2i3,50(1x,i2,f5.2))')
8569      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
8570      &    j=1,num_cont_hb(i))
8571         enddo
8572         call flush(iout)
8573       endif
8574       do i=1,ntask_cont_from
8575         ncont_recv(i)=0
8576       enddo
8577       do i=1,ntask_cont_to
8578         ncont_sent(i)=0
8579       enddo
8580 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
8581 c     & ntask_cont_to
8582 C Make the list of contacts to send to send to other procesors
8583 c      write (iout,*) "limits",max0(iturn4_end-1,iatel_s),iturn3_end
8584 c      call flush(iout)
8585       do i=iturn3_start,iturn3_end
8586 c        write (iout,*) "make contact list turn3",i," num_cont",
8587 c     &    num_cont_hb(i)
8588         call add_hb_contact(i,i+2,iturn3_sent_local(1,i))
8589       enddo
8590       do i=iturn4_start,iturn4_end
8591 c        write (iout,*) "make contact list turn4",i," num_cont",
8592 c     &   num_cont_hb(i)
8593         call add_hb_contact(i,i+3,iturn4_sent_local(1,i))
8594       enddo
8595       do ii=1,nat_sent
8596         i=iat_sent(ii)
8597 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
8598 c     &    num_cont_hb(i)
8599         do j=1,num_cont_hb(i)
8600         do k=1,4
8601           jjc=jcont_hb(j,i)
8602           iproc=iint_sent_local(k,jjc,ii)
8603 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
8604           if (iproc.gt.0) then
8605             ncont_sent(iproc)=ncont_sent(iproc)+1
8606             nn=ncont_sent(iproc)
8607             zapas(1,nn,iproc)=i
8608             zapas(2,nn,iproc)=jjc
8609             zapas(3,nn,iproc)=facont_hb(j,i)
8610             zapas(4,nn,iproc)=ees0p(j,i)
8611             zapas(5,nn,iproc)=ees0m(j,i)
8612             zapas(6,nn,iproc)=gacont_hbr(1,j,i)
8613             zapas(7,nn,iproc)=gacont_hbr(2,j,i)
8614             zapas(8,nn,iproc)=gacont_hbr(3,j,i)
8615             zapas(9,nn,iproc)=gacontm_hb1(1,j,i)
8616             zapas(10,nn,iproc)=gacontm_hb1(2,j,i)
8617             zapas(11,nn,iproc)=gacontm_hb1(3,j,i)
8618             zapas(12,nn,iproc)=gacontp_hb1(1,j,i)
8619             zapas(13,nn,iproc)=gacontp_hb1(2,j,i)
8620             zapas(14,nn,iproc)=gacontp_hb1(3,j,i)
8621             zapas(15,nn,iproc)=gacontm_hb2(1,j,i)
8622             zapas(16,nn,iproc)=gacontm_hb2(2,j,i)
8623             zapas(17,nn,iproc)=gacontm_hb2(3,j,i)
8624             zapas(18,nn,iproc)=gacontp_hb2(1,j,i)
8625             zapas(19,nn,iproc)=gacontp_hb2(2,j,i)
8626             zapas(20,nn,iproc)=gacontp_hb2(3,j,i)
8627             zapas(21,nn,iproc)=gacontm_hb3(1,j,i)
8628             zapas(22,nn,iproc)=gacontm_hb3(2,j,i)
8629             zapas(23,nn,iproc)=gacontm_hb3(3,j,i)
8630             zapas(24,nn,iproc)=gacontp_hb3(1,j,i)
8631             zapas(25,nn,iproc)=gacontp_hb3(2,j,i)
8632             zapas(26,nn,iproc)=gacontp_hb3(3,j,i)
8633           endif
8634         enddo
8635         enddo
8636       enddo
8637       if (lprn) then
8638       write (iout,*)
8639      &  "Numbers of contacts to be sent to other processors",
8640      &  (ncont_sent(i),i=1,ntask_cont_to)
8641       write (iout,*) "Contacts sent"
8642       do ii=1,ntask_cont_to
8643         nn=ncont_sent(ii)
8644         iproc=itask_cont_to(ii)
8645         write (iout,*) nn," contacts to processor",iproc,
8646      &   " of CONT_TO_COMM group"
8647         do i=1,nn
8648           write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
8649         enddo
8650       enddo
8651       call flush(iout)
8652       endif
8653       CorrelType=477
8654       CorrelID=fg_rank+1
8655       CorrelType1=478
8656       CorrelID1=nfgtasks+fg_rank+1
8657       ireq=0
8658 C Receive the numbers of needed contacts from other processors
8659       do ii=1,ntask_cont_from
8660         iproc=itask_cont_from(ii)
8661         ireq=ireq+1
8662         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
8663      &    FG_COMM,req(ireq),IERR)
8664       enddo
8665 c      write (iout,*) "IRECV ended"
8666 c      call flush(iout)
8667 C Send the number of contacts needed by other processors
8668       do ii=1,ntask_cont_to
8669         iproc=itask_cont_to(ii)
8670         ireq=ireq+1
8671         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
8672      &    FG_COMM,req(ireq),IERR)
8673       enddo
8674 c      write (iout,*) "ISEND ended"
8675 c      write (iout,*) "number of requests (nn)",ireq
8676 c      call flush(iout)
8677       if (ireq.gt.0)
8678      &  call MPI_Waitall(ireq,req,status_array,ierr)
8679 c      write (iout,*)
8680 c     &  "Numbers of contacts to be received from other processors",
8681 c     &  (ncont_recv(i),i=1,ntask_cont_from)
8682 c      call flush(iout)
8683 C Receive contacts
8684       ireq=0
8685       do ii=1,ntask_cont_from
8686         iproc=itask_cont_from(ii)
8687         nn=ncont_recv(ii)
8688 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
8689 c     &   " of CONT_TO_COMM group"
8690 c        call flush(iout)
8691         if (nn.gt.0) then
8692           ireq=ireq+1
8693           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
8694      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
8695 c          write (iout,*) "ireq,req",ireq,req(ireq)
8696         endif
8697       enddo
8698 C Send the contacts to processors that need them
8699       do ii=1,ntask_cont_to
8700         iproc=itask_cont_to(ii)
8701         nn=ncont_sent(ii)
8702 c        write (iout,*) nn," contacts to processor",iproc,
8703 c     &   " of CONT_TO_COMM group"
8704         if (nn.gt.0) then
8705           ireq=ireq+1
8706           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
8707      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
8708 c          write (iout,*) "ireq,req",ireq,req(ireq)
8709 c          do i=1,nn
8710 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
8711 c          enddo
8712         endif
8713       enddo
8714 c      write (iout,*) "number of requests (contacts)",ireq
8715 c      write (iout,*) "req",(req(i),i=1,4)
8716 c      call flush(iout)
8717       if (ireq.gt.0)
8718      & call MPI_Waitall(ireq,req,status_array,ierr)
8719       do iii=1,ntask_cont_from
8720         iproc=itask_cont_from(iii)
8721         nn=ncont_recv(iii)
8722         if (lprn) then
8723         write (iout,*) "Received",nn," contacts from processor",iproc,
8724      &   " of CONT_FROM_COMM group"
8725         call flush(iout)
8726         do i=1,nn
8727           write(iout,'(2f5.0,4f10.5)')(zapas_recv(j,i,iii),j=1,5)
8728         enddo
8729         call flush(iout)
8730         endif
8731         do i=1,nn
8732           ii=zapas_recv(1,i,iii)
8733 c Flag the received contacts to prevent double-counting
8734           jj=-zapas_recv(2,i,iii)
8735 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
8736 c          call flush(iout)
8737           nnn=num_cont_hb(ii)+1
8738           num_cont_hb(ii)=nnn
8739           jcont_hb(nnn,ii)=jj
8740           facont_hb(nnn,ii)=zapas_recv(3,i,iii)
8741           ees0p(nnn,ii)=zapas_recv(4,i,iii)
8742           ees0m(nnn,ii)=zapas_recv(5,i,iii)
8743           gacont_hbr(1,nnn,ii)=zapas_recv(6,i,iii)
8744           gacont_hbr(2,nnn,ii)=zapas_recv(7,i,iii)
8745           gacont_hbr(3,nnn,ii)=zapas_recv(8,i,iii)
8746           gacontm_hb1(1,nnn,ii)=zapas_recv(9,i,iii)
8747           gacontm_hb1(2,nnn,ii)=zapas_recv(10,i,iii)
8748           gacontm_hb1(3,nnn,ii)=zapas_recv(11,i,iii)
8749           gacontp_hb1(1,nnn,ii)=zapas_recv(12,i,iii)
8750           gacontp_hb1(2,nnn,ii)=zapas_recv(13,i,iii)
8751           gacontp_hb1(3,nnn,ii)=zapas_recv(14,i,iii)
8752           gacontm_hb2(1,nnn,ii)=zapas_recv(15,i,iii)
8753           gacontm_hb2(2,nnn,ii)=zapas_recv(16,i,iii)
8754           gacontm_hb2(3,nnn,ii)=zapas_recv(17,i,iii)
8755           gacontp_hb2(1,nnn,ii)=zapas_recv(18,i,iii)
8756           gacontp_hb2(2,nnn,ii)=zapas_recv(19,i,iii)
8757           gacontp_hb2(3,nnn,ii)=zapas_recv(20,i,iii)
8758           gacontm_hb3(1,nnn,ii)=zapas_recv(21,i,iii)
8759           gacontm_hb3(2,nnn,ii)=zapas_recv(22,i,iii)
8760           gacontm_hb3(3,nnn,ii)=zapas_recv(23,i,iii)
8761           gacontp_hb3(1,nnn,ii)=zapas_recv(24,i,iii)
8762           gacontp_hb3(2,nnn,ii)=zapas_recv(25,i,iii)
8763           gacontp_hb3(3,nnn,ii)=zapas_recv(26,i,iii)
8764         enddo
8765       enddo
8766       if (lprn) then
8767         write (iout,'(a)') 'Contact function values after receive:'
8768         do i=nnt,nct-2
8769           write (iout,'(2i3,50(1x,i3,f5.2))')
8770      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
8771      &    j=1,num_cont_hb(i))
8772         enddo
8773         call flush(iout)
8774       endif
8775    30 continue
8776 #endif
8777       if (lprn) then
8778         write (iout,'(a)') 'Contact function values:'
8779         do i=nnt,nct-2
8780           write (iout,'(2i3,50(1x,i3,f5.2))')
8781      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
8782      &    j=1,num_cont_hb(i))
8783         enddo
8784         call flush(iout)
8785       endif
8786       ecorr=0.0D0
8787 C Remove the loop below after debugging !!!
8788       do i=nnt,nct
8789         do j=1,3
8790           gradcorr(j,i)=0.0D0
8791           gradxorr(j,i)=0.0D0
8792         enddo
8793       enddo
8794 C Calculate the local-electrostatic correlation terms
8795       do i=min0(iatel_s,iturn4_start),max0(iatel_e,iturn3_end)
8796         i1=i+1
8797         num_conti=num_cont_hb(i)
8798         num_conti1=num_cont_hb(i+1)
8799         do jj=1,num_conti
8800           j=jcont_hb(jj,i)
8801           jp=iabs(j)
8802           do kk=1,num_conti1
8803             j1=jcont_hb(kk,i1)
8804             jp1=iabs(j1)
8805 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
8806 c     &         ' jj=',jj,' kk=',kk
8807 c            call flush(iout)
8808             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
8809      &          .or. j.lt.0 .and. j1.gt.0) .and.
8810      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
8811 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
8812 C The system gains extra energy.
8813               ecorr=ecorr+ehbcorr(i,jp,i+1,jp1,jj,kk,0.72D0,0.32D0)
8814               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
8815      &            'ecorrh',i,j,ehbcorr(i,j,i+1,j1,jj,kk,0.72D0,0.32D0)
8816               n_corr=n_corr+1
8817             else if (j1.eq.j) then
8818 C Contacts I-J and I-(J+1) occur simultaneously.
8819 C The system loses extra energy.
8820 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
8821             endif
8822           enddo ! kk
8823           do kk=1,num_conti
8824             j1=jcont_hb(kk,i)
8825 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
8826 c    &         ' jj=',jj,' kk=',kk
8827             if (j1.eq.j+1) then
8828 C Contacts I-J and (I+1)-J occur simultaneously.
8829 C The system loses extra energy.
8830 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
8831             endif ! j1==j+1
8832           enddo ! kk
8833         enddo ! jj
8834       enddo ! i
8835       return
8836       end
8837 c------------------------------------------------------------------------------
8838       subroutine add_hb_contact(ii,jj,itask)
8839       implicit real*8 (a-h,o-z)
8840       include "DIMENSIONS"
8841       include "COMMON.IOUNITS"
8842       integer max_cont
8843       integer max_dim
8844       parameter (max_cont=maxconts)
8845       parameter (max_dim=26)
8846       include "COMMON.CONTACTS"
8847       include 'COMMON.CONTMAT'
8848       include 'COMMON.CORRMAT'
8849       double precision zapas(max_dim,maxconts,max_fg_procs),
8850      &  zapas_recv(max_dim,maxconts,max_fg_procs)
8851       common /przechowalnia/ zapas
8852       integer i,j,ii,jj,iproc,itask(4),nn
8853 c      write (iout,*) "itask",itask
8854       do i=1,2
8855         iproc=itask(i)
8856         if (iproc.gt.0) then
8857           do j=1,num_cont_hb(ii)
8858             jjc=jcont_hb(j,ii)
8859 c            write (iout,*) "i",ii," j",jj," jjc",jjc
8860             if (jjc.eq.jj) then
8861               ncont_sent(iproc)=ncont_sent(iproc)+1
8862               nn=ncont_sent(iproc)
8863               zapas(1,nn,iproc)=ii
8864               zapas(2,nn,iproc)=jjc
8865               zapas(3,nn,iproc)=facont_hb(j,ii)
8866               zapas(4,nn,iproc)=ees0p(j,ii)
8867               zapas(5,nn,iproc)=ees0m(j,ii)
8868               zapas(6,nn,iproc)=gacont_hbr(1,j,ii)
8869               zapas(7,nn,iproc)=gacont_hbr(2,j,ii)
8870               zapas(8,nn,iproc)=gacont_hbr(3,j,ii)
8871               zapas(9,nn,iproc)=gacontm_hb1(1,j,ii)
8872               zapas(10,nn,iproc)=gacontm_hb1(2,j,ii)
8873               zapas(11,nn,iproc)=gacontm_hb1(3,j,ii)
8874               zapas(12,nn,iproc)=gacontp_hb1(1,j,ii)
8875               zapas(13,nn,iproc)=gacontp_hb1(2,j,ii)
8876               zapas(14,nn,iproc)=gacontp_hb1(3,j,ii)
8877               zapas(15,nn,iproc)=gacontm_hb2(1,j,ii)
8878               zapas(16,nn,iproc)=gacontm_hb2(2,j,ii)
8879               zapas(17,nn,iproc)=gacontm_hb2(3,j,ii)
8880               zapas(18,nn,iproc)=gacontp_hb2(1,j,ii)
8881               zapas(19,nn,iproc)=gacontp_hb2(2,j,ii)
8882               zapas(20,nn,iproc)=gacontp_hb2(3,j,ii)
8883               zapas(21,nn,iproc)=gacontm_hb3(1,j,ii)
8884               zapas(22,nn,iproc)=gacontm_hb3(2,j,ii)
8885               zapas(23,nn,iproc)=gacontm_hb3(3,j,ii)
8886               zapas(24,nn,iproc)=gacontp_hb3(1,j,ii)
8887               zapas(25,nn,iproc)=gacontp_hb3(2,j,ii)
8888               zapas(26,nn,iproc)=gacontp_hb3(3,j,ii)
8889               exit
8890             endif
8891           enddo
8892         endif
8893       enddo
8894       return
8895       end
8896 c------------------------------------------------------------------------------
8897       subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,
8898      &  n_corr1)
8899 C This subroutine calculates multi-body contributions to hydrogen-bonding
8900       implicit real*8 (a-h,o-z)
8901       include 'DIMENSIONS'
8902       include 'COMMON.IOUNITS'
8903 #ifdef MPI
8904       include "mpif.h"
8905       parameter (max_cont=maxconts)
8906       parameter (max_dim=70)
8907       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
8908       double precision zapas(max_dim,maxconts,max_fg_procs),
8909      &  zapas_recv(max_dim,maxconts,max_fg_procs)
8910       common /przechowalnia/ zapas
8911       integer status(MPI_STATUS_SIZE),req(maxconts*2),
8912      &  status_array(MPI_STATUS_SIZE,maxconts*2)
8913 #endif
8914       include 'COMMON.SETUP'
8915       include 'COMMON.FFIELD'
8916       include 'COMMON.DERIV'
8917       include 'COMMON.LOCAL'
8918       include 'COMMON.INTERACT'
8919       include 'COMMON.CONTACTS'
8920       include 'COMMON.CONTMAT'
8921       include 'COMMON.CORRMAT'
8922       include 'COMMON.CHAIN'
8923       include 'COMMON.CONTROL'
8924       include 'COMMON.SHIELD'
8925       double precision gx(3),gx1(3)
8926       integer num_cont_hb_old(maxres)
8927       logical lprn,ldone
8928       double precision eello4,eello5,eelo6,eello_turn6
8929       external eello4,eello5,eello6,eello_turn6
8930 C Set lprn=.true. for debugging
8931       lprn=.false.
8932       eturn6=0.0d0
8933 #ifdef MPI
8934       do i=1,nres
8935         num_cont_hb_old(i)=num_cont_hb(i)
8936       enddo
8937       n_corr=0
8938       n_corr1=0
8939       if (nfgtasks.le.1) goto 30
8940       if (lprn) then
8941         write (iout,'(a)') 'Contact function values before RECEIVE:'
8942         do i=nnt,nct-2
8943           write (iout,'(2i3,50(1x,i2,f5.2))')
8944      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
8945      &    j=1,num_cont_hb(i))
8946         enddo
8947       endif
8948       do i=1,ntask_cont_from
8949         ncont_recv(i)=0
8950       enddo
8951       do i=1,ntask_cont_to
8952         ncont_sent(i)=0
8953       enddo
8954 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
8955 c     & ntask_cont_to
8956 C Make the list of contacts to send to send to other procesors
8957       do i=iturn3_start,iturn3_end
8958 c        write (iout,*) "make contact list turn3",i," num_cont",
8959 c     &    num_cont_hb(i)
8960         call add_hb_contact_eello(i,i+2,iturn3_sent_local(1,i))
8961       enddo
8962       do i=iturn4_start,iturn4_end
8963 c        write (iout,*) "make contact list turn4",i," num_cont",
8964 c     &   num_cont_hb(i)
8965         call add_hb_contact_eello(i,i+3,iturn4_sent_local(1,i))
8966       enddo
8967       do ii=1,nat_sent
8968         i=iat_sent(ii)
8969 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
8970 c     &    num_cont_hb(i)
8971         do j=1,num_cont_hb(i)
8972         do k=1,4
8973           jjc=jcont_hb(j,i)
8974           iproc=iint_sent_local(k,jjc,ii)
8975 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
8976           if (iproc.ne.0) then
8977             ncont_sent(iproc)=ncont_sent(iproc)+1
8978             nn=ncont_sent(iproc)
8979             zapas(1,nn,iproc)=i
8980             zapas(2,nn,iproc)=jjc
8981             zapas(3,nn,iproc)=d_cont(j,i)
8982             ind=3
8983             do kk=1,3
8984               ind=ind+1
8985               zapas(ind,nn,iproc)=grij_hb_cont(kk,j,i)
8986             enddo
8987             do kk=1,2
8988               do ll=1,2
8989                 ind=ind+1
8990                 zapas(ind,nn,iproc)=a_chuj(ll,kk,j,i)
8991               enddo
8992             enddo
8993             do jj=1,5
8994               do kk=1,3
8995                 do ll=1,2
8996                   do mm=1,2
8997                     ind=ind+1
8998                     zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,i)
8999                   enddo
9000                 enddo
9001               enddo
9002             enddo
9003           endif
9004         enddo
9005         enddo
9006       enddo
9007       if (lprn) then
9008       write (iout,*)
9009      &  "Numbers of contacts to be sent to other processors",
9010      &  (ncont_sent(i),i=1,ntask_cont_to)
9011       write (iout,*) "Contacts sent"
9012       do ii=1,ntask_cont_to
9013         nn=ncont_sent(ii)
9014         iproc=itask_cont_to(ii)
9015         write (iout,*) nn," contacts to processor",iproc,
9016      &   " of CONT_TO_COMM group"
9017         do i=1,nn
9018           write(iout,'(2f5.0,10f10.5)')(zapas(j,i,ii),j=1,10)
9019         enddo
9020       enddo
9021       call flush(iout)
9022       endif
9023       CorrelType=477
9024       CorrelID=fg_rank+1
9025       CorrelType1=478
9026       CorrelID1=nfgtasks+fg_rank+1
9027       ireq=0
9028 C Receive the numbers of needed contacts from other processors
9029       do ii=1,ntask_cont_from
9030         iproc=itask_cont_from(ii)
9031         ireq=ireq+1
9032         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
9033      &    FG_COMM,req(ireq),IERR)
9034       enddo
9035 c      write (iout,*) "IRECV ended"
9036 c      call flush(iout)
9037 C Send the number of contacts needed by other processors
9038       do ii=1,ntask_cont_to
9039         iproc=itask_cont_to(ii)
9040         ireq=ireq+1
9041         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
9042      &    FG_COMM,req(ireq),IERR)
9043       enddo
9044 c      write (iout,*) "ISEND ended"
9045 c      write (iout,*) "number of requests (nn)",ireq
9046 c      call flush(iout)
9047       if (ireq.gt.0)
9048      &  call MPI_Waitall(ireq,req,status_array,ierr)
9049 c      write (iout,*)
9050 c     &  "Numbers of contacts to be received from other processors",
9051 c     &  (ncont_recv(i),i=1,ntask_cont_from)
9052 c      call flush(iout)
9053 C Receive contacts
9054       ireq=0
9055       do ii=1,ntask_cont_from
9056         iproc=itask_cont_from(ii)
9057         nn=ncont_recv(ii)
9058 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
9059 c     &   " of CONT_TO_COMM group"
9060 c        call flush(iout)
9061         if (nn.gt.0) then
9062           ireq=ireq+1
9063           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
9064      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
9065 c          write (iout,*) "ireq,req",ireq,req(ireq)
9066         endif
9067       enddo
9068 C Send the contacts to processors that need them
9069       do ii=1,ntask_cont_to
9070         iproc=itask_cont_to(ii)
9071         nn=ncont_sent(ii)
9072 c        write (iout,*) nn," contacts to processor",iproc,
9073 c     &   " of CONT_TO_COMM group"
9074         if (nn.gt.0) then
9075           ireq=ireq+1
9076           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
9077      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
9078 c          write (iout,*) "ireq,req",ireq,req(ireq)
9079 c          do i=1,nn
9080 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
9081 c          enddo
9082         endif
9083       enddo
9084 c      write (iout,*) "number of requests (contacts)",ireq
9085 c      write (iout,*) "req",(req(i),i=1,4)
9086 c      call flush(iout)
9087       if (ireq.gt.0)
9088      & call MPI_Waitall(ireq,req,status_array,ierr)
9089       do iii=1,ntask_cont_from
9090         iproc=itask_cont_from(iii)
9091         nn=ncont_recv(iii)
9092         if (lprn) then
9093         write (iout,*) "Received",nn," contacts from processor",iproc,
9094      &   " of CONT_FROM_COMM group"
9095         call flush(iout)
9096         do i=1,nn
9097           write(iout,'(2f5.0,10f10.5)')(zapas_recv(j,i,iii),j=1,10)
9098         enddo
9099         call flush(iout)
9100         endif
9101         do i=1,nn
9102           ii=zapas_recv(1,i,iii)
9103 c Flag the received contacts to prevent double-counting
9104           jj=-zapas_recv(2,i,iii)
9105 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
9106 c          call flush(iout)
9107           nnn=num_cont_hb(ii)+1
9108           num_cont_hb(ii)=nnn
9109           jcont_hb(nnn,ii)=jj
9110           d_cont(nnn,ii)=zapas_recv(3,i,iii)
9111           ind=3
9112           do kk=1,3
9113             ind=ind+1
9114             grij_hb_cont(kk,nnn,ii)=zapas_recv(ind,i,iii)
9115           enddo
9116           do kk=1,2
9117             do ll=1,2
9118               ind=ind+1
9119               a_chuj(ll,kk,nnn,ii)=zapas_recv(ind,i,iii)
9120             enddo
9121           enddo
9122           do jj=1,5
9123             do kk=1,3
9124               do ll=1,2
9125                 do mm=1,2
9126                   ind=ind+1
9127                   a_chuj_der(mm,ll,kk,jj,nnn,ii)=zapas_recv(ind,i,iii)
9128                 enddo
9129               enddo
9130             enddo
9131           enddo
9132         enddo
9133       enddo
9134       if (lprn) then
9135         write (iout,'(a)') 'Contact function values after receive:'
9136         do i=nnt,nct-2
9137           write (iout,'(2i3,50(1x,i3,5f6.3))')
9138      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
9139      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
9140         enddo
9141         call flush(iout)
9142       endif
9143    30 continue
9144 #endif
9145       if (lprn) then
9146         write (iout,'(a)') 'Contact function values:'
9147         do i=nnt,nct-2
9148           write (iout,'(2i3,50(1x,i2,5f6.3))')
9149      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
9150      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
9151         enddo
9152       endif
9153       ecorr=0.0D0
9154       ecorr5=0.0d0
9155       ecorr6=0.0d0
9156 C Remove the loop below after debugging !!!
9157       do i=nnt,nct
9158         do j=1,3
9159           gradcorr(j,i)=0.0D0
9160           gradxorr(j,i)=0.0D0
9161         enddo
9162       enddo
9163 C Calculate the dipole-dipole interaction energies
9164       if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
9165       do i=iatel_s,iatel_e+1
9166         num_conti=num_cont_hb(i)
9167         do jj=1,num_conti
9168           j=jcont_hb(jj,i)
9169 #ifdef MOMENT
9170           call dipole(i,j,jj)
9171 #endif
9172         enddo
9173       enddo
9174       endif
9175 C Calculate the local-electrostatic correlation terms
9176 c                write (iout,*) "gradcorr5 in eello5 before loop"
9177 c                do iii=1,nres
9178 c                  write (iout,'(i5,3f10.5)')
9179 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
9180 c                enddo
9181       do i=min0(iatel_s,iturn4_start),max0(iatel_e+1,iturn3_end+1)
9182 c        write (iout,*) "corr loop i",i
9183         i1=i+1
9184         num_conti=num_cont_hb(i)
9185         num_conti1=num_cont_hb(i+1)
9186         do jj=1,num_conti
9187           j=jcont_hb(jj,i)
9188           jp=iabs(j)
9189           do kk=1,num_conti1
9190             j1=jcont_hb(kk,i1)
9191             jp1=iabs(j1)
9192 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
9193 c     &         ' jj=',jj,' kk=',kk
9194 c            if (j1.eq.j+1 .or. j1.eq.j-1) then
9195             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
9196      &          .or. j.lt.0 .and. j1.gt.0) .and.
9197      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
9198 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
9199 C The system gains extra energy.
9200               n_corr=n_corr+1
9201               sqd1=dsqrt(d_cont(jj,i))
9202               sqd2=dsqrt(d_cont(kk,i1))
9203               sred_geom = sqd1*sqd2
9204               IF (sred_geom.lt.cutoff_corr) THEN
9205                 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,
9206      &            ekont,fprimcont)
9207 cd               write (iout,*) 'i=',i,' j=',jp,' i1=',i1,' j1=',jp1,
9208 cd     &         ' jj=',jj,' kk=',kk
9209                 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
9210                 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
9211                 do l=1,3
9212                   g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
9213                   g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
9214                 enddo
9215                 n_corr1=n_corr1+1
9216 cd               write (iout,*) 'sred_geom=',sred_geom,
9217 cd     &          ' ekont=',ekont,' fprim=',fprimcont,
9218 cd     &          ' fac_prim1',fac_prim1,' fac_prim2',fac_prim2
9219 cd               write (iout,*) "g_contij",g_contij
9220 cd               write (iout,*) "grij_hb_cont i",grij_hb_cont(:,jj,i)
9221 cd               write (iout,*) "grij_hb_cont i1",grij_hb_cont(:,jj,i1)
9222                 call calc_eello(i,jp,i+1,jp1,jj,kk)
9223                 if (wcorr4.gt.0.0d0)
9224      &            ecorr=ecorr+eello4(i,jp,i+1,jp1,jj,kk)
9225 CC     &            *fac_shield(i)**2*fac_shield(j)**2
9226                   if (energy_dec.and.wcorr4.gt.0.0d0)
9227      1                 write (iout,'(a6,4i5,0pf7.3)')
9228      2                'ecorr4',i,j,i+1,j1,eello4(i,jp,i+1,jp1,jj,kk)
9229 c                write (iout,*) "gradcorr5 before eello5"
9230 c                do iii=1,nres
9231 c                  write (iout,'(i5,3f10.5)')
9232 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
9233 c                enddo
9234                 if (wcorr5.gt.0.0d0)
9235      &            ecorr5=ecorr5+eello5(i,jp,i+1,jp1,jj,kk)
9236 c                write (iout,*) "gradcorr5 after eello5"
9237 c                do iii=1,nres
9238 c                  write (iout,'(i5,3f10.5)')
9239 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
9240 c                enddo
9241                   if (energy_dec.and.wcorr5.gt.0.0d0)
9242      1                 write (iout,'(a6,4i5,0pf7.3)')
9243      2                'ecorr5',i,j,i+1,j1,eello5(i,jp,i+1,jp1,jj,kk)
9244 cd                write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
9245 cd                write(2,*)'ijkl',i,jp,i+1,jp1
9246                 if (wcorr6.gt.0.0d0 .and. (jp.ne.i+4 .or. jp1.ne.i+3
9247      &               .or. wturn6.eq.0.0d0))then
9248 cd                  write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
9249                   ecorr6=ecorr6+eello6(i,jp,i+1,jp1,jj,kk)
9250                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
9251      1                'ecorr6',i,j,i+1,j1,eello6(i,jp,i+1,jp1,jj,kk)
9252 cd                write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
9253 cd     &            'ecorr6=',ecorr6
9254 cd                write (iout,'(4e15.5)') sred_geom,
9255 cd     &          dabs(eello4(i,jp,i+1,jp1,jj,kk)),
9256 cd     &          dabs(eello5(i,jp,i+1,jp1,jj,kk)),
9257 cd     &          dabs(eello6(i,jp,i+1,jp1,jj,kk))
9258                 else if (wturn6.gt.0.0d0
9259      &            .and. (jp.eq.i+4 .and. jp1.eq.i+3)) then
9260 cd                  write (iout,*) '******eturn6: i,j,i+1,j1',i,jip,i+1,jp1
9261                   eturn6=eturn6+eello_turn6(i,jj,kk)
9262                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
9263      1                 'eturn6',i,j,i+1,j1,eello_turn6(i,jj,kk)
9264 cd                  write (2,*) 'multibody_eello:eturn6',eturn6
9265                 endif
9266               ENDIF
9267 1111          continue
9268             endif
9269           enddo ! kk
9270         enddo ! jj
9271       enddo ! i
9272       do i=1,nres
9273         num_cont_hb(i)=num_cont_hb_old(i)
9274       enddo
9275 c                write (iout,*) "gradcorr5 in eello5"
9276 c                do iii=1,nres
9277 c                  write (iout,'(i5,3f10.5)')
9278 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
9279 c                enddo
9280       return
9281       end
9282 c------------------------------------------------------------------------------
9283       subroutine add_hb_contact_eello(ii,jj,itask)
9284       implicit real*8 (a-h,o-z)
9285       include "DIMENSIONS"
9286       include "COMMON.IOUNITS"
9287       integer max_cont
9288       integer max_dim
9289       parameter (max_cont=maxconts)
9290       parameter (max_dim=70)
9291       include "COMMON.CONTACTS"
9292       include 'COMMON.CONTMAT'
9293       include 'COMMON.CORRMAT'
9294       double precision zapas(max_dim,maxconts,max_fg_procs),
9295      &  zapas_recv(max_dim,maxconts,max_fg_procs)
9296       common /przechowalnia/ zapas
9297       integer i,j,ii,jj,iproc,itask(4),nn
9298 c      write (iout,*) "itask",itask
9299       do i=1,2
9300         iproc=itask(i)
9301         if (iproc.gt.0) then
9302           do j=1,num_cont_hb(ii)
9303             jjc=jcont_hb(j,ii)
9304 c            write (iout,*) "send turns i",ii," j",jj," jjc",jjc
9305             if (jjc.eq.jj) then
9306               ncont_sent(iproc)=ncont_sent(iproc)+1
9307               nn=ncont_sent(iproc)
9308               zapas(1,nn,iproc)=ii
9309               zapas(2,nn,iproc)=jjc
9310               zapas(3,nn,iproc)=d_cont(j,ii)
9311               ind=3
9312               do kk=1,3
9313                 ind=ind+1
9314                 zapas(ind,nn,iproc)=grij_hb_cont(kk,j,ii)
9315               enddo
9316               do kk=1,2
9317                 do ll=1,2
9318                   ind=ind+1
9319                   zapas(ind,nn,iproc)=a_chuj(ll,kk,j,ii)
9320                 enddo
9321               enddo
9322               do jj=1,5
9323                 do kk=1,3
9324                   do ll=1,2
9325                     do mm=1,2
9326                       ind=ind+1
9327                       zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,ii)
9328                     enddo
9329                   enddo
9330                 enddo
9331               enddo
9332               exit
9333             endif
9334           enddo
9335         endif
9336       enddo
9337       return
9338       end
9339 c------------------------------------------------------------------------------
9340       double precision function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
9341       implicit real*8 (a-h,o-z)
9342       include 'DIMENSIONS'
9343       include 'COMMON.IOUNITS'
9344       include 'COMMON.DERIV'
9345       include 'COMMON.INTERACT'
9346       include 'COMMON.CONTACTS'
9347       include 'COMMON.CONTMAT'
9348       include 'COMMON.CORRMAT'
9349       include 'COMMON.SHIELD'
9350       include 'COMMON.CONTROL'
9351       double precision gx(3),gx1(3)
9352       logical lprn
9353       lprn=.false.
9354 C      print *,"wchodze",fac_shield(i),shield_mode
9355       eij=facont_hb(jj,i)
9356       ekl=facont_hb(kk,k)
9357       ees0pij=ees0p(jj,i)
9358       ees0pkl=ees0p(kk,k)
9359       ees0mij=ees0m(jj,i)
9360       ees0mkl=ees0m(kk,k)
9361       ekont=eij*ekl
9362       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
9363 C*
9364 C     & fac_shield(i)**2*fac_shield(j)**2
9365 cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
9366 C Following 4 lines for diagnostics.
9367 cd    ees0pkl=0.0D0
9368 cd    ees0pij=1.0D0
9369 cd    ees0mkl=0.0D0
9370 cd    ees0mij=1.0D0
9371 c      write (iout,'(2(a,2i3,a,f10.5,a,2f10.5),a,f10.5,a,$)')
9372 c     & 'Contacts ',i,j,
9373 c     & ' eij',eij,' eesij',ees0pij,ees0mij,' and ',k,l
9374 c     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' energy=',ekont*ees,
9375 c     & 'gradcorr_long'
9376 C Calculate the multi-body contribution to energy.
9377 C      ecorr=ecorr+ekont*ees
9378 C Calculate multi-body contributions to the gradient.
9379       coeffpees0pij=coeffp*ees0pij
9380       coeffmees0mij=coeffm*ees0mij
9381       coeffpees0pkl=coeffp*ees0pkl
9382       coeffmees0mkl=coeffm*ees0mkl
9383       do ll=1,3
9384 cgrad        ghalfi=ees*ekl*gacont_hbr(ll,jj,i)
9385         gradcorr(ll,i)=gradcorr(ll,i)!+0.5d0*ghalfi
9386      &  -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+
9387      &  coeffmees0mkl*gacontm_hb1(ll,jj,i))
9388         gradcorr(ll,j)=gradcorr(ll,j)!+0.5d0*ghalfi
9389      &  -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+
9390      &  coeffmees0mkl*gacontm_hb2(ll,jj,i))
9391 cgrad        ghalfk=ees*eij*gacont_hbr(ll,kk,k)
9392         gradcorr(ll,k)=gradcorr(ll,k)!+0.5d0*ghalfk
9393      &  -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+
9394      &  coeffmees0mij*gacontm_hb1(ll,kk,k))
9395         gradcorr(ll,l)=gradcorr(ll,l)!+0.5d0*ghalfk
9396      &  -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+
9397      &  coeffmees0mij*gacontm_hb2(ll,kk,k))
9398         gradlongij=ees*ekl*gacont_hbr(ll,jj,i)-
9399      &     ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+
9400      &     coeffmees0mkl*gacontm_hb3(ll,jj,i))
9401         gradcorr_long(ll,j)=gradcorr_long(ll,j)+gradlongij
9402         gradcorr_long(ll,i)=gradcorr_long(ll,i)-gradlongij
9403         gradlongkl=ees*eij*gacont_hbr(ll,kk,k)-
9404      &     ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+
9405      &     coeffmees0mij*gacontm_hb3(ll,kk,k))
9406         gradcorr_long(ll,l)=gradcorr_long(ll,l)+gradlongkl
9407         gradcorr_long(ll,k)=gradcorr_long(ll,k)-gradlongkl
9408 c        write (iout,'(2f10.5,2x,$)') gradlongij,gradlongkl
9409       enddo
9410 c      write (iout,*)
9411 cgrad      do m=i+1,j-1
9412 cgrad        do ll=1,3
9413 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
9414 cgrad     &     ees*ekl*gacont_hbr(ll,jj,i)-
9415 cgrad     &     ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
9416 cgrad     &     coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
9417 cgrad        enddo
9418 cgrad      enddo
9419 cgrad      do m=k+1,l-1
9420 cgrad        do ll=1,3
9421 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
9422 cgrad     &     ees*eij*gacont_hbr(ll,kk,k)-
9423 cgrad     &     ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
9424 cgrad     &     coeffm*ees0mij*gacontm_hb3(ll,kk,k))
9425 cgrad        enddo
9426 cgrad      enddo
9427 c      write (iout,*) "ehbcorr",ekont*ees
9428 C      print *,ekont,ees,i,k
9429       ehbcorr=ekont*ees
9430 C now gradient over shielding
9431 C      return
9432       if (shield_mode.gt.0) then
9433        j=ees0plist(jj,i)
9434        l=ees0plist(kk,k)
9435 C        print *,i,j,fac_shield(i),fac_shield(j),
9436 C     &fac_shield(k),fac_shield(l)
9437         if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
9438      &      (fac_shield(k).gt.0).and.(fac_shield(l).gt.0)) then
9439           do ilist=1,ishield_list(i)
9440            iresshield=shield_list(ilist,i)
9441            do m=1,3
9442            rlocshield=grad_shield_side(m,ilist,i)*ehbcorr/fac_shield(i)
9443 C     &      *2.0
9444            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
9445      &              rlocshield
9446      & +grad_shield_loc(m,ilist,i)*ehbcorr/fac_shield(i)
9447             gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
9448      &+rlocshield
9449            enddo
9450           enddo
9451           do ilist=1,ishield_list(j)
9452            iresshield=shield_list(ilist,j)
9453            do m=1,3
9454            rlocshield=grad_shield_side(m,ilist,j)*ehbcorr/fac_shield(j)
9455 C     &     *2.0
9456            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
9457      &              rlocshield
9458      & +grad_shield_loc(m,ilist,j)*ehbcorr/fac_shield(j)
9459            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
9460      &     +rlocshield
9461            enddo
9462           enddo
9463
9464           do ilist=1,ishield_list(k)
9465            iresshield=shield_list(ilist,k)
9466            do m=1,3
9467            rlocshield=grad_shield_side(m,ilist,k)*ehbcorr/fac_shield(k)
9468 C     &     *2.0
9469            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
9470      &              rlocshield
9471      & +grad_shield_loc(m,ilist,k)*ehbcorr/fac_shield(k)
9472            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
9473      &     +rlocshield
9474            enddo
9475           enddo
9476           do ilist=1,ishield_list(l)
9477            iresshield=shield_list(ilist,l)
9478            do m=1,3
9479            rlocshield=grad_shield_side(m,ilist,l)*ehbcorr/fac_shield(l)
9480 C     &     *2.0
9481            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
9482      &              rlocshield
9483      & +grad_shield_loc(m,ilist,l)*ehbcorr/fac_shield(l)
9484            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
9485      &     +rlocshield
9486            enddo
9487           enddo
9488 C          print *,gshieldx(m,iresshield)
9489           do m=1,3
9490             gshieldc_ec(m,i)=gshieldc_ec(m,i)+
9491      &              grad_shield(m,i)*ehbcorr/fac_shield(i)
9492             gshieldc_ec(m,j)=gshieldc_ec(m,j)+
9493      &              grad_shield(m,j)*ehbcorr/fac_shield(j)
9494             gshieldc_ec(m,i-1)=gshieldc_ec(m,i-1)+
9495      &              grad_shield(m,i)*ehbcorr/fac_shield(i)
9496             gshieldc_ec(m,j-1)=gshieldc_ec(m,j-1)+
9497      &              grad_shield(m,j)*ehbcorr/fac_shield(j)
9498
9499             gshieldc_ec(m,k)=gshieldc_ec(m,k)+
9500      &              grad_shield(m,k)*ehbcorr/fac_shield(k)
9501             gshieldc_ec(m,l)=gshieldc_ec(m,l)+
9502      &              grad_shield(m,l)*ehbcorr/fac_shield(l)
9503             gshieldc_ec(m,k-1)=gshieldc_ec(m,k-1)+
9504      &              grad_shield(m,k)*ehbcorr/fac_shield(k)
9505             gshieldc_ec(m,l-1)=gshieldc_ec(m,l-1)+
9506      &              grad_shield(m,l)*ehbcorr/fac_shield(l)
9507
9508            enddo
9509       endif
9510       endif
9511       return
9512       end
9513 #ifdef MOMENT
9514 C---------------------------------------------------------------------------
9515       subroutine dipole(i,j,jj)
9516       implicit real*8 (a-h,o-z)
9517       include 'DIMENSIONS'
9518       include 'COMMON.IOUNITS'
9519       include 'COMMON.CHAIN'
9520       include 'COMMON.FFIELD'
9521       include 'COMMON.DERIV'
9522       include 'COMMON.INTERACT'
9523       include 'COMMON.CONTACTS'
9524       include 'COMMON.CONTMAT'
9525       include 'COMMON.CORRMAT'
9526       include 'COMMON.TORSION'
9527       include 'COMMON.VAR'
9528       include 'COMMON.GEO'
9529       dimension dipi(2,2),dipj(2,2),dipderi(2),dipderj(2),auxvec(2),
9530      &  auxmat(2,2)
9531       iti1 = itortyp(itype(i+1))
9532       if (j.lt.nres-1) then
9533         itj1 = itype2loc(itype(j+1))
9534       else
9535         itj1=nloctyp
9536       endif
9537       do iii=1,2
9538         dipi(iii,1)=Ub2(iii,i)
9539         dipderi(iii)=Ub2der(iii,i)
9540         dipi(iii,2)=b1(iii,i+1)
9541         dipj(iii,1)=Ub2(iii,j)
9542         dipderj(iii)=Ub2der(iii,j)
9543         dipj(iii,2)=b1(iii,j+1)
9544       enddo
9545       kkk=0
9546       do iii=1,2
9547         call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
9548         do jjj=1,2
9549           kkk=kkk+1
9550           dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
9551         enddo
9552       enddo
9553       do kkk=1,5
9554         do lll=1,3
9555           mmm=0
9556           do iii=1,2
9557             call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),
9558      &        auxvec(1))
9559             do jjj=1,2
9560               mmm=mmm+1
9561               dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
9562             enddo
9563           enddo
9564         enddo
9565       enddo
9566       call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
9567       call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
9568       do iii=1,2
9569         dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
9570       enddo
9571       call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
9572       do iii=1,2
9573         dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
9574       enddo
9575       return
9576       end
9577 #endif
9578 C---------------------------------------------------------------------------
9579       subroutine calc_eello(i,j,k,l,jj,kk)
9580 C
9581 C This subroutine computes matrices and vectors needed to calculate
9582 C the fourth-, fifth-, and sixth-order local-electrostatic terms.
9583 C
9584       implicit real*8 (a-h,o-z)
9585       include 'DIMENSIONS'
9586       include 'COMMON.IOUNITS'
9587       include 'COMMON.CHAIN'
9588       include 'COMMON.DERIV'
9589       include 'COMMON.INTERACT'
9590       include 'COMMON.CONTACTS'
9591       include 'COMMON.CONTMAT'
9592       include 'COMMON.CORRMAT'
9593       include 'COMMON.TORSION'
9594       include 'COMMON.VAR'
9595       include 'COMMON.GEO'
9596       include 'COMMON.FFIELD'
9597       double precision aa1(2,2),aa2(2,2),aa1t(2,2),aa2t(2,2),
9598      &  aa1tder(2,2,3,5),aa2tder(2,2,3,5),auxmat(2,2)
9599       logical lprn
9600       common /kutas/ lprn
9601 cd      write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
9602 cd     & ' jj=',jj,' kk=',kk
9603 cd      if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
9604 cd      write (iout,*) "a_chujij",((a_chuj(iii,jjj,jj,i),iii=1,2),jjj=1,2)
9605 cd      write (iout,*) "a_chujkl",((a_chuj(iii,jjj,kk,k),iii=1,2),jjj=1,2)
9606       do iii=1,2
9607         do jjj=1,2
9608           aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
9609           aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
9610         enddo
9611       enddo
9612       call transpose2(aa1(1,1),aa1t(1,1))
9613       call transpose2(aa2(1,1),aa2t(1,1))
9614       do kkk=1,5
9615         do lll=1,3
9616           call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),
9617      &      aa1tder(1,1,lll,kkk))
9618           call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),
9619      &      aa2tder(1,1,lll,kkk))
9620         enddo
9621       enddo
9622       if (l.eq.j+1) then
9623 C parallel orientation of the two CA-CA-CA frames.
9624         if (i.gt.1) then
9625           iti=itype2loc(itype(i))
9626         else
9627           iti=nloctyp
9628         endif
9629         itk1=itype2loc(itype(k+1))
9630         itj=itype2loc(itype(j))
9631         if (l.lt.nres-1) then
9632           itl1=itype2loc(itype(l+1))
9633         else
9634           itl1=nloctyp
9635         endif
9636 C A1 kernel(j+1) A2T
9637 cd        do iii=1,2
9638 cd          write (iout,'(3f10.5,5x,3f10.5)')
9639 cd     &     (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
9640 cd        enddo
9641         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9642      &   aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),
9643      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
9644 C Following matrices are needed only for 6-th order cumulants
9645         IF (wcorr6.gt.0.0d0) THEN
9646         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9647      &   aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),
9648      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
9649         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9650      &   aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),
9651      &   Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
9652      &   ADtEAderx(1,1,1,1,1,1))
9653         lprn=.false.
9654         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9655      &   aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),
9656      &   DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
9657      &   ADtEA1derx(1,1,1,1,1,1))
9658         ENDIF
9659 C End 6-th order cumulants
9660 cd        lprn=.false.
9661 cd        if (lprn) then
9662 cd        write (2,*) 'In calc_eello6'
9663 cd        do iii=1,2
9664 cd          write (2,*) 'iii=',iii
9665 cd          do kkk=1,5
9666 cd            write (2,*) 'kkk=',kkk
9667 cd            do jjj=1,2
9668 cd              write (2,'(3(2f10.5),5x)')
9669 cd     &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
9670 cd            enddo
9671 cd          enddo
9672 cd        enddo
9673 cd        endif
9674         call transpose2(EUgder(1,1,k),auxmat(1,1))
9675         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
9676         call transpose2(EUg(1,1,k),auxmat(1,1))
9677         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
9678         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
9679 C AL 4/16/16: Derivatives of the quantitied related to matrices C, D, and E
9680 c    in theta; to be sriten later.
9681 c#ifdef NEWCORR
9682 c        call transpose2(gtEE(1,1,k),auxmat(1,1))
9683 c        call matmat2(auxmat(1,1),AEA(1,1,1),EAEAdert(1,1,1,1))
9684 c        call transpose2(EUg(1,1,k),auxmat(1,1))
9685 c        call matmat2(auxmat(1,1),AEAdert(1,1,1),EAEAdert(1,1,2,1))
9686 c#endif
9687         do iii=1,2
9688           do kkk=1,5
9689             do lll=1,3
9690               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
9691      &          EAEAderx(1,1,lll,kkk,iii,1))
9692             enddo
9693           enddo
9694         enddo
9695 C A1T kernel(i+1) A2
9696         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
9697      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),
9698      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
9699 C Following matrices are needed only for 6-th order cumulants
9700         IF (wcorr6.gt.0.0d0) THEN
9701         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
9702      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),
9703      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
9704         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
9705      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),
9706      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
9707      &   ADtEAderx(1,1,1,1,1,2))
9708         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
9709      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),
9710      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
9711      &   ADtEA1derx(1,1,1,1,1,2))
9712         ENDIF
9713 C End 6-th order cumulants
9714         call transpose2(EUgder(1,1,l),auxmat(1,1))
9715         call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
9716         call transpose2(EUg(1,1,l),auxmat(1,1))
9717         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
9718         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
9719         do iii=1,2
9720           do kkk=1,5
9721             do lll=1,3
9722               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
9723      &          EAEAderx(1,1,lll,kkk,iii,2))
9724             enddo
9725           enddo
9726         enddo
9727 C AEAb1 and AEAb2
9728 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
9729 C They are needed only when the fifth- or the sixth-order cumulants are
9730 C indluded.
9731         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
9732         call transpose2(AEA(1,1,1),auxmat(1,1))
9733         call matvec2(auxmat(1,1),b1(1,i),AEAb1(1,1,1))
9734         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
9735         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
9736         call transpose2(AEAderg(1,1,1),auxmat(1,1))
9737         call matvec2(auxmat(1,1),b1(1,i),AEAb1derg(1,1,1))
9738         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
9739         call matvec2(AEA(1,1,1),b1(1,k+1),AEAb1(1,2,1))
9740         call matvec2(AEAderg(1,1,1),b1(1,k+1),AEAb1derg(1,2,1))
9741         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
9742         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
9743         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
9744         call transpose2(AEA(1,1,2),auxmat(1,1))
9745         call matvec2(auxmat(1,1),b1(1,j),AEAb1(1,1,2))
9746         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
9747         call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
9748         call transpose2(AEAderg(1,1,2),auxmat(1,1))
9749         call matvec2(auxmat(1,1),b1(1,j),AEAb1derg(1,1,2))
9750         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
9751         call matvec2(AEA(1,1,2),b1(1,l+1),AEAb1(1,2,2))
9752         call matvec2(AEAderg(1,1,2),b1(1,l+1),AEAb1derg(1,2,2))
9753         call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
9754         call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
9755         call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
9756 C Calculate the Cartesian derivatives of the vectors.
9757         do iii=1,2
9758           do kkk=1,5
9759             do lll=1,3
9760               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
9761               call matvec2(auxmat(1,1),b1(1,i),
9762      &          AEAb1derx(1,lll,kkk,iii,1,1))
9763               call matvec2(auxmat(1,1),Ub2(1,i),
9764      &          AEAb2derx(1,lll,kkk,iii,1,1))
9765               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
9766      &          AEAb1derx(1,lll,kkk,iii,2,1))
9767               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
9768      &          AEAb2derx(1,lll,kkk,iii,2,1))
9769               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
9770               call matvec2(auxmat(1,1),b1(1,j),
9771      &          AEAb1derx(1,lll,kkk,iii,1,2))
9772               call matvec2(auxmat(1,1),Ub2(1,j),
9773      &          AEAb2derx(1,lll,kkk,iii,1,2))
9774               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,l+1),
9775      &          AEAb1derx(1,lll,kkk,iii,2,2))
9776               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),
9777      &          AEAb2derx(1,lll,kkk,iii,2,2))
9778             enddo
9779           enddo
9780         enddo
9781         ENDIF
9782 C End vectors
9783       else
9784 C Antiparallel orientation of the two CA-CA-CA frames.
9785         if (i.gt.1) then
9786           iti=itype2loc(itype(i))
9787         else
9788           iti=nloctyp
9789         endif
9790         itk1=itype2loc(itype(k+1))
9791         itl=itype2loc(itype(l))
9792         itj=itype2loc(itype(j))
9793         if (j.lt.nres-1) then
9794           itj1=itype2loc(itype(j+1))
9795         else
9796           itj1=nloctyp
9797         endif
9798 C A2 kernel(j-1)T A1T
9799         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9800      &   aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),
9801      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
9802 C Following matrices are needed only for 6-th order cumulants
9803         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
9804      &     j.eq.i+4 .and. l.eq.i+3)) THEN
9805         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9806      &   aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),
9807      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
9808         call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9809      &   aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),
9810      &   Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
9811      &   ADtEAderx(1,1,1,1,1,1))
9812         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9813      &   aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),
9814      &   DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
9815      &   ADtEA1derx(1,1,1,1,1,1))
9816         ENDIF
9817 C End 6-th order cumulants
9818         call transpose2(EUgder(1,1,k),auxmat(1,1))
9819         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
9820         call transpose2(EUg(1,1,k),auxmat(1,1))
9821         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
9822         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
9823         do iii=1,2
9824           do kkk=1,5
9825             do lll=1,3
9826               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
9827      &          EAEAderx(1,1,lll,kkk,iii,1))
9828             enddo
9829           enddo
9830         enddo
9831 C A2T kernel(i+1)T A1
9832         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
9833      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),
9834      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
9835 C Following matrices are needed only for 6-th order cumulants
9836         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
9837      &     j.eq.i+4 .and. l.eq.i+3)) THEN
9838         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
9839      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),
9840      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
9841         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
9842      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),
9843      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
9844      &   ADtEAderx(1,1,1,1,1,2))
9845         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
9846      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),
9847      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
9848      &   ADtEA1derx(1,1,1,1,1,2))
9849         ENDIF
9850 C End 6-th order cumulants
9851         call transpose2(EUgder(1,1,j),auxmat(1,1))
9852         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
9853         call transpose2(EUg(1,1,j),auxmat(1,1))
9854         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
9855         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
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,2),
9860      &          EAEAderx(1,1,lll,kkk,iii,2))
9861             enddo
9862           enddo
9863         enddo
9864 C AEAb1 and AEAb2
9865 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
9866 C They are needed only when the fifth- or the sixth-order cumulants are
9867 C indluded.
9868         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or.
9869      &    (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
9870         call transpose2(AEA(1,1,1),auxmat(1,1))
9871         call matvec2(auxmat(1,1),b1(1,i),AEAb1(1,1,1))
9872         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
9873         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
9874         call transpose2(AEAderg(1,1,1),auxmat(1,1))
9875         call matvec2(auxmat(1,1),b1(1,i),AEAb1derg(1,1,1))
9876         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
9877         call matvec2(AEA(1,1,1),b1(1,k+1),AEAb1(1,2,1))
9878         call matvec2(AEAderg(1,1,1),b1(1,k+1),AEAb1derg(1,2,1))
9879         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
9880         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
9881         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
9882         call transpose2(AEA(1,1,2),auxmat(1,1))
9883         call matvec2(auxmat(1,1),b1(1,j+1),AEAb1(1,1,2))
9884         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
9885         call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
9886         call transpose2(AEAderg(1,1,2),auxmat(1,1))
9887         call matvec2(auxmat(1,1),b1(1,l),AEAb1(1,1,2))
9888         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
9889         call matvec2(AEA(1,1,2),b1(1,j+1),AEAb1(1,2,2))
9890         call matvec2(AEAderg(1,1,2),b1(1,j+1),AEAb1derg(1,2,2))
9891         call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
9892         call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
9893         call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
9894 C Calculate the Cartesian derivatives of the vectors.
9895         do iii=1,2
9896           do kkk=1,5
9897             do lll=1,3
9898               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
9899               call matvec2(auxmat(1,1),b1(1,i),
9900      &          AEAb1derx(1,lll,kkk,iii,1,1))
9901               call matvec2(auxmat(1,1),Ub2(1,i),
9902      &          AEAb2derx(1,lll,kkk,iii,1,1))
9903               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
9904      &          AEAb1derx(1,lll,kkk,iii,2,1))
9905               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
9906      &          AEAb2derx(1,lll,kkk,iii,2,1))
9907               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
9908               call matvec2(auxmat(1,1),b1(1,l),
9909      &          AEAb1derx(1,lll,kkk,iii,1,2))
9910               call matvec2(auxmat(1,1),Ub2(1,l),
9911      &          AEAb2derx(1,lll,kkk,iii,1,2))
9912               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,j+1),
9913      &          AEAb1derx(1,lll,kkk,iii,2,2))
9914               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),
9915      &          AEAb2derx(1,lll,kkk,iii,2,2))
9916             enddo
9917           enddo
9918         enddo
9919         ENDIF
9920 C End vectors
9921       endif
9922       return
9923       end
9924 C---------------------------------------------------------------------------
9925       subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,
9926      &  KK,KKderg,AKA,AKAderg,AKAderx)
9927       implicit none
9928       integer nderg
9929       logical transp
9930       double precision aa1(2,2),aa2t(2,2),aa1derx(2,2,3,5),
9931      &  aa2tderx(2,2,3,5),KK(2,2),KKderg(2,2,nderg),AKA(2,2),
9932      &  AKAderg(2,2,nderg),AKAderx(2,2,3,5,2)
9933       integer iii,kkk,lll
9934       integer jjj,mmm
9935       logical lprn
9936       common /kutas/ lprn
9937       call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
9938       do iii=1,nderg
9939         call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,
9940      &    AKAderg(1,1,iii))
9941       enddo
9942 cd      if (lprn) write (2,*) 'In kernel'
9943       do kkk=1,5
9944 cd        if (lprn) write (2,*) 'kkk=',kkk
9945         do lll=1,3
9946           call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),
9947      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
9948 cd          if (lprn) then
9949 cd            write (2,*) 'lll=',lll
9950 cd            write (2,*) 'iii=1'
9951 cd            do jjj=1,2
9952 cd              write (2,'(3(2f10.5),5x)')
9953 cd     &        (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
9954 cd            enddo
9955 cd          endif
9956           call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),
9957      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
9958 cd          if (lprn) then
9959 cd            write (2,*) 'lll=',lll
9960 cd            write (2,*) 'iii=2'
9961 cd            do jjj=1,2
9962 cd              write (2,'(3(2f10.5),5x)')
9963 cd     &        (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
9964 cd            enddo
9965 cd          endif
9966         enddo
9967       enddo
9968       return
9969       end
9970 C---------------------------------------------------------------------------
9971       double precision function eello4(i,j,k,l,jj,kk)
9972       implicit real*8 (a-h,o-z)
9973       include 'DIMENSIONS'
9974       include 'COMMON.IOUNITS'
9975       include 'COMMON.CHAIN'
9976       include 'COMMON.DERIV'
9977       include 'COMMON.INTERACT'
9978       include 'COMMON.CONTACTS'
9979       include 'COMMON.CONTMAT'
9980       include 'COMMON.CORRMAT'
9981       include 'COMMON.TORSION'
9982       include 'COMMON.VAR'
9983       include 'COMMON.GEO'
9984       double precision pizda(2,2),ggg1(3),ggg2(3)
9985 cd      if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
9986 cd        eello4=0.0d0
9987 cd        return
9988 cd      endif
9989 cd      print *,'eello4:',i,j,k,l,jj,kk
9990 cd      write (2,*) 'i',i,' j',j,' k',k,' l',l
9991 cd      call checkint4(i,j,k,l,jj,kk,eel4_num)
9992 cold      eij=facont_hb(jj,i)
9993 cold      ekl=facont_hb(kk,k)
9994 cold      ekont=eij*ekl
9995       eel4=-EAEA(1,1,1)-EAEA(2,2,1)
9996 cd      eel41=-EAEA(1,1,2)-EAEA(2,2,2)
9997       gcorr_loc(k-1)=gcorr_loc(k-1)
9998      &   -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
9999       if (l.eq.j+1) then
10000         gcorr_loc(l-1)=gcorr_loc(l-1)
10001      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
10002 C Al 4/16/16: Derivatives in theta, to be added later.
10003 c#ifdef NEWCORR
10004 c        gcorr_loc(nphi+l-1)=gcorr_loc(nphi+l-1)
10005 c     &     -ekont*(EAEAdert(1,1,2,1)+EAEAdert(2,2,2,1))
10006 c#endif
10007       else
10008         gcorr_loc(j-1)=gcorr_loc(j-1)
10009      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
10010 c#ifdef NEWCORR
10011 c        gcorr_loc(nphi+j-1)=gcorr_loc(nphi+j-1)
10012 c     &     -ekont*(EAEAdert(1,1,2,1)+EAEAdert(2,2,2,1))
10013 c#endif
10014       endif
10015       do iii=1,2
10016         do kkk=1,5
10017           do lll=1,3
10018             derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1)
10019      &                        -EAEAderx(2,2,lll,kkk,iii,1)
10020 cd            derx(lll,kkk,iii)=0.0d0
10021           enddo
10022         enddo
10023       enddo
10024 cd      gcorr_loc(l-1)=0.0d0
10025 cd      gcorr_loc(j-1)=0.0d0
10026 cd      gcorr_loc(k-1)=0.0d0
10027 cd      eel4=1.0d0
10028 cd      write (iout,*)'Contacts have occurred for peptide groups',
10029 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l,
10030 cd     &  ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
10031       if (j.lt.nres-1) then
10032         j1=j+1
10033         j2=j-1
10034       else
10035         j1=j-1
10036         j2=j-2
10037       endif
10038       if (l.lt.nres-1) then
10039         l1=l+1
10040         l2=l-1
10041       else
10042         l1=l-1
10043         l2=l-2
10044       endif
10045       do ll=1,3
10046 cgrad        ggg1(ll)=eel4*g_contij(ll,1)
10047 cgrad        ggg2(ll)=eel4*g_contij(ll,2)
10048         glongij=eel4*g_contij(ll,1)+ekont*derx(ll,1,1)
10049         glongkl=eel4*g_contij(ll,2)+ekont*derx(ll,1,2)
10050 cgrad        ghalf=0.5d0*ggg1(ll)
10051         gradcorr(ll,i)=gradcorr(ll,i)+ekont*derx(ll,2,1)
10052         gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
10053         gradcorr(ll,j)=gradcorr(ll,j)+ekont*derx(ll,4,1)
10054         gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
10055         gradcorr_long(ll,j)=gradcorr_long(ll,j)+glongij
10056         gradcorr_long(ll,i)=gradcorr_long(ll,i)-glongij
10057 cgrad        ghalf=0.5d0*ggg2(ll)
10058         gradcorr(ll,k)=gradcorr(ll,k)+ekont*derx(ll,2,2)
10059         gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
10060         gradcorr(ll,l)=gradcorr(ll,l)+ekont*derx(ll,4,2)
10061         gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
10062         gradcorr_long(ll,l)=gradcorr_long(ll,l)+glongkl
10063         gradcorr_long(ll,k)=gradcorr_long(ll,k)-glongkl
10064       enddo
10065 cgrad      do m=i+1,j-1
10066 cgrad        do ll=1,3
10067 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
10068 cgrad        enddo
10069 cgrad      enddo
10070 cgrad      do m=k+1,l-1
10071 cgrad        do ll=1,3
10072 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
10073 cgrad        enddo
10074 cgrad      enddo
10075 cgrad      do m=i+2,j2
10076 cgrad        do ll=1,3
10077 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
10078 cgrad        enddo
10079 cgrad      enddo
10080 cgrad      do m=k+2,l2
10081 cgrad        do ll=1,3
10082 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
10083 cgrad        enddo
10084 cgrad      enddo
10085 cd      do iii=1,nres-3
10086 cd        write (2,*) iii,gcorr_loc(iii)
10087 cd      enddo
10088       eello4=ekont*eel4
10089 cd      write (2,*) 'ekont',ekont
10090 cd      write (iout,*) 'eello4',ekont*eel4
10091       return
10092       end
10093 C---------------------------------------------------------------------------
10094       double precision function eello5(i,j,k,l,jj,kk)
10095       implicit real*8 (a-h,o-z)
10096       include 'DIMENSIONS'
10097       include 'COMMON.IOUNITS'
10098       include 'COMMON.CHAIN'
10099       include 'COMMON.DERIV'
10100       include 'COMMON.INTERACT'
10101       include 'COMMON.CONTACTS'
10102       include 'COMMON.CONTMAT'
10103       include 'COMMON.CORRMAT'
10104       include 'COMMON.TORSION'
10105       include 'COMMON.VAR'
10106       include 'COMMON.GEO'
10107       double precision pizda(2,2),auxmat(2,2),auxmat1(2,2),vv(2)
10108       double precision ggg1(3),ggg2(3)
10109 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10110 C                                                                              C
10111 C                            Parallel chains                                   C
10112 C                                                                              C
10113 C          o             o                   o             o                   C
10114 C         /l\           / \             \   / \           / \   /              C
10115 C        /   \         /   \             \ /   \         /   \ /               C
10116 C       j| o |l1       | o |              o| o |         | o |o                C
10117 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
10118 C      \i/   \         /   \ /             /   \         /   \                 C
10119 C       o    k1             o                                                  C
10120 C         (I)          (II)                (III)          (IV)                 C
10121 C                                                                              C
10122 C      eello5_1        eello5_2            eello5_3       eello5_4             C
10123 C                                                                              C
10124 C                            Antiparallel chains                               C
10125 C                                                                              C
10126 C          o             o                   o             o                   C
10127 C         /j\           / \             \   / \           / \   /              C
10128 C        /   \         /   \             \ /   \         /   \ /               C
10129 C      j1| o |l        | o |              o| o |         | o |o                C
10130 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
10131 C      \i/   \         /   \ /             /   \         /   \                 C
10132 C       o     k1            o                                                  C
10133 C         (I)          (II)                (III)          (IV)                 C
10134 C                                                                              C
10135 C      eello5_1        eello5_2            eello5_3       eello5_4             C
10136 C                                                                              C
10137 C o denotes a local interaction, vertical lines an electrostatic interaction.  C
10138 C                                                                              C
10139 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10140 cd      if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
10141 cd        eello5=0.0d0
10142 cd        return
10143 cd      endif
10144 cd      write (iout,*)
10145 cd     &   'EELLO5: Contacts have occurred for peptide groups',i,j,
10146 cd     &   ' and',k,l
10147       itk=itype2loc(itype(k))
10148       itl=itype2loc(itype(l))
10149       itj=itype2loc(itype(j))
10150       eello5_1=0.0d0
10151       eello5_2=0.0d0
10152       eello5_3=0.0d0
10153       eello5_4=0.0d0
10154 cd      call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
10155 cd     &   eel5_3_num,eel5_4_num)
10156       do iii=1,2
10157         do kkk=1,5
10158           do lll=1,3
10159             derx(lll,kkk,iii)=0.0d0
10160           enddo
10161         enddo
10162       enddo
10163 cd      eij=facont_hb(jj,i)
10164 cd      ekl=facont_hb(kk,k)
10165 cd      ekont=eij*ekl
10166 cd      write (iout,*)'Contacts have occurred for peptide groups',
10167 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l
10168 cd      goto 1111
10169 C Contribution from the graph I.
10170 cd      write (2,*) 'AEA  ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
10171 cd      write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
10172       call transpose2(EUg(1,1,k),auxmat(1,1))
10173       call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
10174       vv(1)=pizda(1,1)-pizda(2,2)
10175       vv(2)=pizda(1,2)+pizda(2,1)
10176       eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k))
10177      & +0.5d0*scalar2(vv(1),Dtobr2(1,i))
10178 C Explicit gradient in virtual-dihedral angles.
10179       if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1)
10180      & +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k))
10181      & +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
10182       call transpose2(EUgder(1,1,k),auxmat1(1,1))
10183       call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
10184       vv(1)=pizda(1,1)-pizda(2,2)
10185       vv(2)=pizda(1,2)+pizda(2,1)
10186       g_corr5_loc(k-1)=g_corr5_loc(k-1)
10187      & +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k))
10188      & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
10189       call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
10190       vv(1)=pizda(1,1)-pizda(2,2)
10191       vv(2)=pizda(1,2)+pizda(2,1)
10192       if (l.eq.j+1) then
10193         if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1)
10194      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
10195      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
10196       else
10197         if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1)
10198      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
10199      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
10200       endif
10201 C Cartesian gradient
10202       do iii=1,2
10203         do kkk=1,5
10204           do lll=1,3
10205             call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),
10206      &        pizda(1,1))
10207             vv(1)=pizda(1,1)-pizda(2,2)
10208             vv(2)=pizda(1,2)+pizda(2,1)
10209             derx(lll,kkk,iii)=derx(lll,kkk,iii)
10210      &       +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k))
10211      &       +0.5d0*scalar2(vv(1),Dtobr2(1,i))
10212           enddo
10213         enddo
10214       enddo
10215 c      goto 1112
10216 c1111  continue
10217 C Contribution from graph II
10218       call transpose2(EE(1,1,k),auxmat(1,1))
10219       call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
10220       vv(1)=pizda(1,1)+pizda(2,2)
10221       vv(2)=pizda(2,1)-pizda(1,2)
10222       eello5_2=scalar2(AEAb1(1,2,1),b1(1,k))
10223      & -0.5d0*scalar2(vv(1),Ctobr(1,k))
10224 C Explicit gradient in virtual-dihedral angles.
10225       g_corr5_loc(k-1)=g_corr5_loc(k-1)
10226      & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
10227       call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
10228       vv(1)=pizda(1,1)+pizda(2,2)
10229       vv(2)=pizda(2,1)-pizda(1,2)
10230       if (l.eq.j+1) then
10231         g_corr5_loc(l-1)=g_corr5_loc(l-1)
10232      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,k))
10233      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
10234       else
10235         g_corr5_loc(j-1)=g_corr5_loc(j-1)
10236      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,k))
10237      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
10238       endif
10239 C Cartesian gradient
10240       do iii=1,2
10241         do kkk=1,5
10242           do lll=1,3
10243             call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
10244      &        pizda(1,1))
10245             vv(1)=pizda(1,1)+pizda(2,2)
10246             vv(2)=pizda(2,1)-pizda(1,2)
10247             derx(lll,kkk,iii)=derx(lll,kkk,iii)
10248      &       +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,k))
10249      &       -0.5d0*scalar2(vv(1),Ctobr(1,k))
10250           enddo
10251         enddo
10252       enddo
10253 cd      goto 1112
10254 cd1111  continue
10255       if (l.eq.j+1) then
10256 cd        goto 1110
10257 C Parallel orientation
10258 C Contribution from graph III
10259         call transpose2(EUg(1,1,l),auxmat(1,1))
10260         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
10261         vv(1)=pizda(1,1)-pizda(2,2)
10262         vv(2)=pizda(1,2)+pizda(2,1)
10263         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l))
10264      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j))
10265 C Explicit gradient in virtual-dihedral angles.
10266         g_corr5_loc(j-1)=g_corr5_loc(j-1)
10267      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l))
10268      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
10269         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
10270         vv(1)=pizda(1,1)-pizda(2,2)
10271         vv(2)=pizda(1,2)+pizda(2,1)
10272         g_corr5_loc(k-1)=g_corr5_loc(k-1)
10273      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l))
10274      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
10275         call transpose2(EUgder(1,1,l),auxmat1(1,1))
10276         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
10277         vv(1)=pizda(1,1)-pizda(2,2)
10278         vv(2)=pizda(1,2)+pizda(2,1)
10279         g_corr5_loc(l-1)=g_corr5_loc(l-1)
10280      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l))
10281      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
10282 C Cartesian gradient
10283         do iii=1,2
10284           do kkk=1,5
10285             do lll=1,3
10286               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
10287      &          pizda(1,1))
10288               vv(1)=pizda(1,1)-pizda(2,2)
10289               vv(2)=pizda(1,2)+pizda(2,1)
10290               derx(lll,kkk,iii)=derx(lll,kkk,iii)
10291      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l))
10292      &         +0.5d0*scalar2(vv(1),Dtobr2(1,j))
10293             enddo
10294           enddo
10295         enddo
10296 cd        goto 1112
10297 C Contribution from graph IV
10298 cd1110    continue
10299         call transpose2(EE(1,1,l),auxmat(1,1))
10300         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
10301         vv(1)=pizda(1,1)+pizda(2,2)
10302         vv(2)=pizda(2,1)-pizda(1,2)
10303         eello5_4=scalar2(AEAb1(1,2,2),b1(1,l))
10304      &   -0.5d0*scalar2(vv(1),Ctobr(1,l))
10305 C Explicit gradient in virtual-dihedral angles.
10306         g_corr5_loc(l-1)=g_corr5_loc(l-1)
10307      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
10308         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
10309         vv(1)=pizda(1,1)+pizda(2,2)
10310         vv(2)=pizda(2,1)-pizda(1,2)
10311         g_corr5_loc(k-1)=g_corr5_loc(k-1)
10312      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,l))
10313      &   -0.5d0*scalar2(vv(1),Ctobr(1,l)))
10314 C Cartesian gradient
10315         do iii=1,2
10316           do kkk=1,5
10317             do lll=1,3
10318               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
10319      &          pizda(1,1))
10320               vv(1)=pizda(1,1)+pizda(2,2)
10321               vv(2)=pizda(2,1)-pizda(1,2)
10322               derx(lll,kkk,iii)=derx(lll,kkk,iii)
10323      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,l))
10324      &         -0.5d0*scalar2(vv(1),Ctobr(1,l))
10325             enddo
10326           enddo
10327         enddo
10328       else
10329 C Antiparallel orientation
10330 C Contribution from graph III
10331 c        goto 1110
10332         call transpose2(EUg(1,1,j),auxmat(1,1))
10333         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
10334         vv(1)=pizda(1,1)-pizda(2,2)
10335         vv(2)=pizda(1,2)+pizda(2,1)
10336         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j))
10337      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l))
10338 C Explicit gradient in virtual-dihedral angles.
10339         g_corr5_loc(l-1)=g_corr5_loc(l-1)
10340      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j))
10341      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
10342         call matmat2(AEAderg(1,1,2),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         g_corr5_loc(k-1)=g_corr5_loc(k-1)
10346      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j))
10347      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
10348         call transpose2(EUgder(1,1,j),auxmat1(1,1))
10349         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
10350         vv(1)=pizda(1,1)-pizda(2,2)
10351         vv(2)=pizda(1,2)+pizda(2,1)
10352         g_corr5_loc(j-1)=g_corr5_loc(j-1)
10353      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j))
10354      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
10355 C Cartesian gradient
10356         do iii=1,2
10357           do kkk=1,5
10358             do lll=1,3
10359               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
10360      &          pizda(1,1))
10361               vv(1)=pizda(1,1)-pizda(2,2)
10362               vv(2)=pizda(1,2)+pizda(2,1)
10363               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
10364      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j))
10365      &         +0.5d0*scalar2(vv(1),Dtobr2(1,l))
10366             enddo
10367           enddo
10368         enddo
10369 cd        goto 1112
10370 C Contribution from graph IV
10371 1110    continue
10372         call transpose2(EE(1,1,j),auxmat(1,1))
10373         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
10374         vv(1)=pizda(1,1)+pizda(2,2)
10375         vv(2)=pizda(2,1)-pizda(1,2)
10376         eello5_4=scalar2(AEAb1(1,2,2),b1(1,j))
10377      &   -0.5d0*scalar2(vv(1),Ctobr(1,j))
10378 C Explicit gradient in virtual-dihedral angles.
10379         g_corr5_loc(j-1)=g_corr5_loc(j-1)
10380      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
10381         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
10382         vv(1)=pizda(1,1)+pizda(2,2)
10383         vv(2)=pizda(2,1)-pizda(1,2)
10384         g_corr5_loc(k-1)=g_corr5_loc(k-1)
10385      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,j))
10386      &   -0.5d0*scalar2(vv(1),Ctobr(1,j)))
10387 C Cartesian gradient
10388         do iii=1,2
10389           do kkk=1,5
10390             do lll=1,3
10391               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
10392      &          pizda(1,1))
10393               vv(1)=pizda(1,1)+pizda(2,2)
10394               vv(2)=pizda(2,1)-pizda(1,2)
10395               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
10396      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,j))
10397      &         -0.5d0*scalar2(vv(1),Ctobr(1,j))
10398             enddo
10399           enddo
10400         enddo
10401       endif
10402 1112  continue
10403       eel5=eello5_1+eello5_2+eello5_3+eello5_4
10404 cd      if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
10405 cd        write (2,*) 'ijkl',i,j,k,l
10406 cd        write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
10407 cd     &     ' eello5_3',eello5_3,' eello5_4',eello5_4
10408 cd      endif
10409 cd      write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
10410 cd      write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
10411 cd      write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
10412 cd      write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
10413       if (j.lt.nres-1) then
10414         j1=j+1
10415         j2=j-1
10416       else
10417         j1=j-1
10418         j2=j-2
10419       endif
10420       if (l.lt.nres-1) then
10421         l1=l+1
10422         l2=l-1
10423       else
10424         l1=l-1
10425         l2=l-2
10426       endif
10427 cd      eij=1.0d0
10428 cd      ekl=1.0d0
10429 cd      ekont=1.0d0
10430 cd      write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
10431 C 2/11/08 AL Gradients over DC's connecting interacting sites will be
10432 C        summed up outside the subrouine as for the other subroutines
10433 C        handling long-range interactions. The old code is commented out
10434 C        with "cgrad" to keep track of changes.
10435       do ll=1,3
10436 cgrad        ggg1(ll)=eel5*g_contij(ll,1)
10437 cgrad        ggg2(ll)=eel5*g_contij(ll,2)
10438         gradcorr5ij=eel5*g_contij(ll,1)+ekont*derx(ll,1,1)
10439         gradcorr5kl=eel5*g_contij(ll,2)+ekont*derx(ll,1,2)
10440 c        write (iout,'(a,3i3,a,5f8.3,2i3,a,5f8.3,a,f8.3)')
10441 c     &   "ecorr5",ll,i,j," derx",derx(ll,2,1),derx(ll,3,1),derx(ll,4,1),
10442 c     &   derx(ll,5,1),k,l," derx",derx(ll,2,2),derx(ll,3,2),
10443 c     &   derx(ll,4,2),derx(ll,5,2)," ekont",ekont
10444 c        write (iout,'(a,3i3,a,3f8.3,2i3,a,3f8.3)')
10445 c     &   "ecorr5",ll,i,j," gradcorr5",g_contij(ll,1),derx(ll,1,1),
10446 c     &   gradcorr5ij,
10447 c     &   k,l," gradcorr5",g_contij(ll,2),derx(ll,1,2),gradcorr5kl
10448 cold        ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
10449 cgrad        ghalf=0.5d0*ggg1(ll)
10450 cd        ghalf=0.0d0
10451         gradcorr5(ll,i)=gradcorr5(ll,i)+ekont*derx(ll,2,1)
10452         gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
10453         gradcorr5(ll,j)=gradcorr5(ll,j)+ekont*derx(ll,4,1)
10454         gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
10455         gradcorr5_long(ll,j)=gradcorr5_long(ll,j)+gradcorr5ij
10456         gradcorr5_long(ll,i)=gradcorr5_long(ll,i)-gradcorr5ij
10457 cold        ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
10458 cgrad        ghalf=0.5d0*ggg2(ll)
10459 cd        ghalf=0.0d0
10460         gradcorr5(ll,k)=gradcorr5(ll,k)+ekont*derx(ll,2,2)
10461         gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
10462         gradcorr5(ll,l)=gradcorr5(ll,l)+ekont*derx(ll,4,2)
10463         gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
10464         gradcorr5_long(ll,l)=gradcorr5_long(ll,l)+gradcorr5kl
10465         gradcorr5_long(ll,k)=gradcorr5_long(ll,k)-gradcorr5kl
10466       enddo
10467 cd      goto 1112
10468 cgrad      do m=i+1,j-1
10469 cgrad        do ll=1,3
10470 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
10471 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
10472 cgrad        enddo
10473 cgrad      enddo
10474 cgrad      do m=k+1,l-1
10475 cgrad        do ll=1,3
10476 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
10477 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
10478 cgrad        enddo
10479 cgrad      enddo
10480 c1112  continue
10481 cgrad      do m=i+2,j2
10482 cgrad        do ll=1,3
10483 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
10484 cgrad        enddo
10485 cgrad      enddo
10486 cgrad      do m=k+2,l2
10487 cgrad        do ll=1,3
10488 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
10489 cgrad        enddo
10490 cgrad      enddo
10491 cd      do iii=1,nres-3
10492 cd        write (2,*) iii,g_corr5_loc(iii)
10493 cd      enddo
10494       eello5=ekont*eel5
10495 cd      write (2,*) 'ekont',ekont
10496 cd      write (iout,*) 'eello5',ekont*eel5
10497       return
10498       end
10499 c--------------------------------------------------------------------------
10500       double precision function eello6(i,j,k,l,jj,kk)
10501       implicit real*8 (a-h,o-z)
10502       include 'DIMENSIONS'
10503       include 'COMMON.IOUNITS'
10504       include 'COMMON.CHAIN'
10505       include 'COMMON.DERIV'
10506       include 'COMMON.INTERACT'
10507       include 'COMMON.CONTACTS'
10508       include 'COMMON.CONTMAT'
10509       include 'COMMON.CORRMAT'
10510       include 'COMMON.TORSION'
10511       include 'COMMON.VAR'
10512       include 'COMMON.GEO'
10513       include 'COMMON.FFIELD'
10514       double precision ggg1(3),ggg2(3)
10515 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
10516 cd        eello6=0.0d0
10517 cd        return
10518 cd      endif
10519 cd      write (iout,*)
10520 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
10521 cd     &   ' and',k,l
10522       eello6_1=0.0d0
10523       eello6_2=0.0d0
10524       eello6_3=0.0d0
10525       eello6_4=0.0d0
10526       eello6_5=0.0d0
10527       eello6_6=0.0d0
10528 cd      call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
10529 cd     &   eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
10530       do iii=1,2
10531         do kkk=1,5
10532           do lll=1,3
10533             derx(lll,kkk,iii)=0.0d0
10534           enddo
10535         enddo
10536       enddo
10537 cd      eij=facont_hb(jj,i)
10538 cd      ekl=facont_hb(kk,k)
10539 cd      ekont=eij*ekl
10540 cd      eij=1.0d0
10541 cd      ekl=1.0d0
10542 cd      ekont=1.0d0
10543       if (l.eq.j+1) then
10544         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
10545         eello6_2=eello6_graph1(j,i,l,k,2,.false.)
10546         eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
10547         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
10548         eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
10549         eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
10550       else
10551         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
10552         eello6_2=eello6_graph1(l,k,j,i,2,.true.)
10553         eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
10554         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
10555         if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
10556           eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
10557         else
10558           eello6_5=0.0d0
10559         endif
10560         eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
10561       endif
10562 C If turn contributions are considered, they will be handled separately.
10563       eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
10564 cd      write(iout,*) 'eello6_1',eello6_1!,' eel6_1_num',16*eel6_1_num
10565 cd      write(iout,*) 'eello6_2',eello6_2!,' eel6_2_num',16*eel6_2_num
10566 cd      write(iout,*) 'eello6_3',eello6_3!,' eel6_3_num',16*eel6_3_num
10567 cd      write(iout,*) 'eello6_4',eello6_4!,' eel6_4_num',16*eel6_4_num
10568 cd      write(iout,*) 'eello6_5',eello6_5!,' eel6_5_num',16*eel6_5_num
10569 cd      write(iout,*) 'eello6_6',eello6_6!,' eel6_6_num',16*eel6_6_num
10570 cd      goto 1112
10571       if (j.lt.nres-1) then
10572         j1=j+1
10573         j2=j-1
10574       else
10575         j1=j-1
10576         j2=j-2
10577       endif
10578       if (l.lt.nres-1) then
10579         l1=l+1
10580         l2=l-1
10581       else
10582         l1=l-1
10583         l2=l-2
10584       endif
10585       do ll=1,3
10586 cgrad        ggg1(ll)=eel6*g_contij(ll,1)
10587 cgrad        ggg2(ll)=eel6*g_contij(ll,2)
10588 cold        ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
10589 cgrad        ghalf=0.5d0*ggg1(ll)
10590 cd        ghalf=0.0d0
10591         gradcorr6ij=eel6*g_contij(ll,1)+ekont*derx(ll,1,1)
10592         gradcorr6kl=eel6*g_contij(ll,2)+ekont*derx(ll,1,2)
10593         gradcorr6(ll,i)=gradcorr6(ll,i)+ekont*derx(ll,2,1)
10594         gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
10595         gradcorr6(ll,j)=gradcorr6(ll,j)+ekont*derx(ll,4,1)
10596         gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
10597         gradcorr6_long(ll,j)=gradcorr6_long(ll,j)+gradcorr6ij
10598         gradcorr6_long(ll,i)=gradcorr6_long(ll,i)-gradcorr6ij
10599 cgrad        ghalf=0.5d0*ggg2(ll)
10600 cold        ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
10601 cd        ghalf=0.0d0
10602         gradcorr6(ll,k)=gradcorr6(ll,k)+ekont*derx(ll,2,2)
10603         gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
10604         gradcorr6(ll,l)=gradcorr6(ll,l)+ekont*derx(ll,4,2)
10605         gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
10606         gradcorr6_long(ll,l)=gradcorr6_long(ll,l)+gradcorr6kl
10607         gradcorr6_long(ll,k)=gradcorr6_long(ll,k)-gradcorr6kl
10608       enddo
10609 cd      goto 1112
10610 cgrad      do m=i+1,j-1
10611 cgrad        do ll=1,3
10612 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
10613 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
10614 cgrad        enddo
10615 cgrad      enddo
10616 cgrad      do m=k+1,l-1
10617 cgrad        do ll=1,3
10618 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
10619 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
10620 cgrad        enddo
10621 cgrad      enddo
10622 cgrad1112  continue
10623 cgrad      do m=i+2,j2
10624 cgrad        do ll=1,3
10625 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
10626 cgrad        enddo
10627 cgrad      enddo
10628 cgrad      do m=k+2,l2
10629 cgrad        do ll=1,3
10630 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
10631 cgrad        enddo
10632 cgrad      enddo
10633 cd      do iii=1,nres-3
10634 cd        write (2,*) iii,g_corr6_loc(iii)
10635 cd      enddo
10636       eello6=ekont*eel6
10637 cd      write (2,*) 'ekont',ekont
10638 cd      write (iout,*) 'eello6',ekont*eel6
10639       return
10640       end
10641 c--------------------------------------------------------------------------
10642       double precision function eello6_graph1(i,j,k,l,imat,swap)
10643       implicit real*8 (a-h,o-z)
10644       include 'DIMENSIONS'
10645       include 'COMMON.IOUNITS'
10646       include 'COMMON.CHAIN'
10647       include 'COMMON.DERIV'
10648       include 'COMMON.INTERACT'
10649       include 'COMMON.CONTACTS'
10650       include 'COMMON.CONTMAT'
10651       include 'COMMON.CORRMAT'
10652       include 'COMMON.TORSION'
10653       include 'COMMON.VAR'
10654       include 'COMMON.GEO'
10655       double precision vv(2),vv1(2),pizda(2,2),auxmat(2,2),pizda1(2,2)
10656       logical swap
10657       logical lprn
10658       common /kutas/ lprn
10659 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10660 C                                                                              C
10661 C      Parallel       Antiparallel                                             C
10662 C                                                                              C
10663 C          o             o                                                     C
10664 C         /l\           /j\                                                    C
10665 C        /   \         /   \                                                   C
10666 C       /| o |         | o |\                                                  C
10667 C     \ j|/k\|  /   \  |/k\|l /                                                C
10668 C      \ /   \ /     \ /   \ /                                                 C
10669 C       o     o       o     o                                                  C
10670 C       i             i                                                        C
10671 C                                                                              C
10672 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10673       itk=itype2loc(itype(k))
10674       s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
10675       s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
10676       s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
10677       call transpose2(EUgC(1,1,k),auxmat(1,1))
10678       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
10679       vv1(1)=pizda1(1,1)-pizda1(2,2)
10680       vv1(2)=pizda1(1,2)+pizda1(2,1)
10681       s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
10682       vv(1)=AEAb1(1,2,imat)*b1(1,k)-AEAb1(2,2,imat)*b1(2,k)
10683       vv(2)=AEAb1(1,2,imat)*b1(2,k)+AEAb1(2,2,imat)*b1(1,k)
10684       s5=scalar2(vv(1),Dtobr2(1,i))
10685 cd      write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
10686       eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
10687       if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1)
10688      & -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i))
10689      & -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k))
10690      & +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k))
10691      & +0.5d0*scalar2(vv1(1),Dtobr2der(1,i))
10692      & +scalar2(vv(1),Dtobr2der(1,i)))
10693       call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
10694       vv1(1)=pizda1(1,1)-pizda1(2,2)
10695       vv1(2)=pizda1(1,2)+pizda1(2,1)
10696       vv(1)=AEAb1derg(1,2,imat)*b1(1,k)-AEAb1derg(2,2,imat)*b1(2,k)
10697       vv(2)=AEAb1derg(1,2,imat)*b1(2,k)+AEAb1derg(2,2,imat)*b1(1,k)
10698       if (l.eq.j+1) then
10699         g_corr6_loc(l-1)=g_corr6_loc(l-1)
10700      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
10701      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
10702      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
10703      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
10704       else
10705         g_corr6_loc(j-1)=g_corr6_loc(j-1)
10706      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
10707      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
10708      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
10709      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
10710       endif
10711       call transpose2(EUgCder(1,1,k),auxmat(1,1))
10712       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
10713       vv1(1)=pizda1(1,1)-pizda1(2,2)
10714       vv1(2)=pizda1(1,2)+pizda1(2,1)
10715       if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1)
10716      & +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k))
10717      & +scalar2(AEAb2(1,1,imat),CUgb2der(1,k))
10718      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
10719       do iii=1,2
10720         if (swap) then
10721           ind=3-iii
10722         else
10723           ind=iii
10724         endif
10725         do kkk=1,5
10726           do lll=1,3
10727             s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
10728             s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
10729             s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
10730             call transpose2(EUgC(1,1,k),auxmat(1,1))
10731             call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
10732      &        pizda1(1,1))
10733             vv1(1)=pizda1(1,1)-pizda1(2,2)
10734             vv1(2)=pizda1(1,2)+pizda1(2,1)
10735             s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
10736             vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,k)
10737      &       -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,k)
10738             vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,k)
10739      &       +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,k)
10740             s5=scalar2(vv(1),Dtobr2(1,i))
10741             derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
10742           enddo
10743         enddo
10744       enddo
10745       return
10746       end
10747 c----------------------------------------------------------------------------
10748       double precision function eello6_graph2(i,j,k,l,jj,kk,swap)
10749       implicit real*8 (a-h,o-z)
10750       include 'DIMENSIONS'
10751       include 'COMMON.IOUNITS'
10752       include 'COMMON.CHAIN'
10753       include 'COMMON.DERIV'
10754       include 'COMMON.INTERACT'
10755       include 'COMMON.CONTACTS'
10756       include 'COMMON.CONTMAT'
10757       include 'COMMON.CORRMAT'
10758       include 'COMMON.TORSION'
10759       include 'COMMON.VAR'
10760       include 'COMMON.GEO'
10761       logical swap
10762       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
10763      & auxvec1(2),auxvec2(2),auxmat1(2,2)
10764       logical lprn
10765       common /kutas/ lprn
10766 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10767 C                                                                              C
10768 C      Parallel       Antiparallel                                             C
10769 C                                                                              C
10770 C          o             o                                                     C
10771 C     \   /l\           /j\   /                                                C
10772 C      \ /   \         /   \ /                                                 C
10773 C       o| o |         | o |o                                                  C
10774 C     \ j|/k\|      \  |/k\|l                                                  C
10775 C      \ /   \       \ /   \                                                   C
10776 C       o             o                                                        C
10777 C       i             i                                                        C
10778 C                                                                              C
10779 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10780 cd      write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
10781 C AL 7/4/01 s1 would occur in the sixth-order moment,
10782 C           but not in a cluster cumulant
10783 #ifdef MOMENT
10784       s1=dip(1,jj,i)*dip(1,kk,k)
10785 #endif
10786       call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
10787       s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
10788       call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
10789       s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
10790       call transpose2(EUg(1,1,k),auxmat(1,1))
10791       call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
10792       vv(1)=pizda(1,1)-pizda(2,2)
10793       vv(2)=pizda(1,2)+pizda(2,1)
10794       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
10795 cd      write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
10796 #ifdef MOMENT
10797       eello6_graph2=-(s1+s2+s3+s4)
10798 #else
10799       eello6_graph2=-(s2+s3+s4)
10800 #endif
10801 c      eello6_graph2=-s3
10802 C Derivatives in gamma(i-1)
10803       if (i.gt.1) then
10804 #ifdef MOMENT
10805         s1=dipderg(1,jj,i)*dip(1,kk,k)
10806 #endif
10807         s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
10808         call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
10809         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
10810         s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
10811 #ifdef MOMENT
10812         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
10813 #else
10814         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
10815 #endif
10816 c        g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
10817       endif
10818 C Derivatives in gamma(k-1)
10819 #ifdef MOMENT
10820       s1=dip(1,jj,i)*dipderg(1,kk,k)
10821 #endif
10822       call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
10823       s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
10824       call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
10825       s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
10826       call transpose2(EUgder(1,1,k),auxmat1(1,1))
10827       call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
10828       vv(1)=pizda(1,1)-pizda(2,2)
10829       vv(2)=pizda(1,2)+pizda(2,1)
10830       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
10831 #ifdef MOMENT
10832       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
10833 #else
10834       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
10835 #endif
10836 c      g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
10837 C Derivatives in gamma(j-1) or gamma(l-1)
10838       if (j.gt.1) then
10839 #ifdef MOMENT
10840         s1=dipderg(3,jj,i)*dip(1,kk,k)
10841 #endif
10842         call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
10843         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
10844         s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
10845         call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
10846         vv(1)=pizda(1,1)-pizda(2,2)
10847         vv(2)=pizda(1,2)+pizda(2,1)
10848         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
10849 #ifdef MOMENT
10850         if (swap) then
10851           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
10852         else
10853           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
10854         endif
10855 #endif
10856         g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
10857 c        g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
10858       endif
10859 C Derivatives in gamma(l-1) or gamma(j-1)
10860       if (l.gt.1) then
10861 #ifdef MOMENT
10862         s1=dip(1,jj,i)*dipderg(3,kk,k)
10863 #endif
10864         call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
10865         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
10866         call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
10867         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
10868         call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
10869         vv(1)=pizda(1,1)-pizda(2,2)
10870         vv(2)=pizda(1,2)+pizda(2,1)
10871         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
10872 #ifdef MOMENT
10873         if (swap) then
10874           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
10875         else
10876           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
10877         endif
10878 #endif
10879         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
10880 c        g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
10881       endif
10882 C Cartesian derivatives.
10883       if (lprn) then
10884         write (2,*) 'In eello6_graph2'
10885         do iii=1,2
10886           write (2,*) 'iii=',iii
10887           do kkk=1,5
10888             write (2,*) 'kkk=',kkk
10889             do jjj=1,2
10890               write (2,'(3(2f10.5),5x)')
10891      &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
10892             enddo
10893           enddo
10894         enddo
10895       endif
10896       do iii=1,2
10897         do kkk=1,5
10898           do lll=1,3
10899 #ifdef MOMENT
10900             if (iii.eq.1) then
10901               s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
10902             else
10903               s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
10904             endif
10905 #endif
10906             call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),
10907      &        auxvec(1))
10908             s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
10909             call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),
10910      &        auxvec(1))
10911             s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
10912             call transpose2(EUg(1,1,k),auxmat(1,1))
10913             call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),
10914      &        pizda(1,1))
10915             vv(1)=pizda(1,1)-pizda(2,2)
10916             vv(2)=pizda(1,2)+pizda(2,1)
10917             s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
10918 cd            write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
10919 #ifdef MOMENT
10920             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
10921 #else
10922             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
10923 #endif
10924             if (swap) then
10925               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
10926             else
10927               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
10928             endif
10929           enddo
10930         enddo
10931       enddo
10932       return
10933       end
10934 c----------------------------------------------------------------------------
10935       double precision function eello6_graph3(i,j,k,l,jj,kk,swap)
10936       implicit real*8 (a-h,o-z)
10937       include 'DIMENSIONS'
10938       include 'COMMON.IOUNITS'
10939       include 'COMMON.CHAIN'
10940       include 'COMMON.DERIV'
10941       include 'COMMON.INTERACT'
10942       include 'COMMON.CONTACTS'
10943       include 'COMMON.CONTMAT'
10944       include 'COMMON.CORRMAT'
10945       include 'COMMON.TORSION'
10946       include 'COMMON.VAR'
10947       include 'COMMON.GEO'
10948       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2)
10949       logical swap
10950 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10951 C                                                                              C
10952 C      Parallel       Antiparallel                                             C
10953 C                                                                              C
10954 C          o             o                                                     C
10955 C         /l\   /   \   /j\                                                    C
10956 C        /   \ /     \ /   \                                                   C
10957 C       /| o |o       o| o |\                                                  C
10958 C       j|/k\|  /      |/k\|l /                                                C
10959 C        /   \ /       /   \ /                                                 C
10960 C       /     o       /     o                                                  C
10961 C       i             i                                                        C
10962 C                                                                              C
10963 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10964 C
10965 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
10966 C           energy moment and not to the cluster cumulant.
10967       iti=itortyp(itype(i))
10968       if (j.lt.nres-1) then
10969         itj1=itype2loc(itype(j+1))
10970       else
10971         itj1=nloctyp
10972       endif
10973       itk=itype2loc(itype(k))
10974       itk1=itype2loc(itype(k+1))
10975       if (l.lt.nres-1) then
10976         itl1=itype2loc(itype(l+1))
10977       else
10978         itl1=nloctyp
10979       endif
10980 #ifdef MOMENT
10981       s1=dip(4,jj,i)*dip(4,kk,k)
10982 #endif
10983       call matvec2(AECA(1,1,1),b1(1,k+1),auxvec(1))
10984       s2=0.5d0*scalar2(b1(1,k),auxvec(1))
10985       call matvec2(AECA(1,1,2),b1(1,l+1),auxvec(1))
10986       s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
10987       call transpose2(EE(1,1,k),auxmat(1,1))
10988       call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
10989       vv(1)=pizda(1,1)+pizda(2,2)
10990       vv(2)=pizda(2,1)-pizda(1,2)
10991       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
10992 cd      write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4,
10993 cd     & "sum",-(s2+s3+s4)
10994 #ifdef MOMENT
10995       eello6_graph3=-(s1+s2+s3+s4)
10996 #else
10997       eello6_graph3=-(s2+s3+s4)
10998 #endif
10999 c      eello6_graph3=-s4
11000 C Derivatives in gamma(k-1)
11001       call matvec2(AECAderg(1,1,2),b1(1,l+1),auxvec(1))
11002       s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
11003       s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
11004       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
11005 C Derivatives in gamma(l-1)
11006       call matvec2(AECAderg(1,1,1),b1(1,k+1),auxvec(1))
11007       s2=0.5d0*scalar2(b1(1,k),auxvec(1))
11008       call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
11009       vv(1)=pizda(1,1)+pizda(2,2)
11010       vv(2)=pizda(2,1)-pizda(1,2)
11011       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
11012       g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
11013 C Cartesian derivatives.
11014       do iii=1,2
11015         do kkk=1,5
11016           do lll=1,3
11017 #ifdef MOMENT
11018             if (iii.eq.1) then
11019               s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
11020             else
11021               s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
11022             endif
11023 #endif
11024             call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
11025      &        auxvec(1))
11026             s2=0.5d0*scalar2(b1(1,k),auxvec(1))
11027             call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,l+1),
11028      &        auxvec(1))
11029             s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
11030             call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),
11031      &        pizda(1,1))
11032             vv(1)=pizda(1,1)+pizda(2,2)
11033             vv(2)=pizda(2,1)-pizda(1,2)
11034             s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
11035 #ifdef MOMENT
11036             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
11037 #else
11038             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
11039 #endif
11040             if (swap) then
11041               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
11042             else
11043               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
11044             endif
11045 c            derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
11046           enddo
11047         enddo
11048       enddo
11049       return
11050       end
11051 c----------------------------------------------------------------------------
11052       double precision function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
11053       implicit real*8 (a-h,o-z)
11054       include 'DIMENSIONS'
11055       include 'COMMON.IOUNITS'
11056       include 'COMMON.CHAIN'
11057       include 'COMMON.DERIV'
11058       include 'COMMON.INTERACT'
11059       include 'COMMON.CONTACTS'
11060       include 'COMMON.CONTMAT'
11061       include 'COMMON.CORRMAT'
11062       include 'COMMON.TORSION'
11063       include 'COMMON.VAR'
11064       include 'COMMON.GEO'
11065       include 'COMMON.FFIELD'
11066       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
11067      & auxvec1(2),auxmat1(2,2)
11068       logical swap
11069 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
11070 C                                                                              C
11071 C      Parallel       Antiparallel                                             C
11072 C                                                                              C
11073 C          o             o                                                     C
11074 C         /l\   /   \   /j\                                                    C
11075 C        /   \ /     \ /   \                                                   C
11076 C       /| o |o       o| o |\                                                  C
11077 C     \ j|/k\|      \  |/k\|l                                                  C
11078 C      \ /   \       \ /   \                                                   C
11079 C       o     \       o     \                                                  C
11080 C       i             i                                                        C
11081 C                                                                              C
11082 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
11083 C
11084 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
11085 C           energy moment and not to the cluster cumulant.
11086 cd      write (2,*) 'eello_graph4: wturn6',wturn6
11087       iti=itype2loc(itype(i))
11088       itj=itype2loc(itype(j))
11089       if (j.lt.nres-1) then
11090         itj1=itype2loc(itype(j+1))
11091       else
11092         itj1=nloctyp
11093       endif
11094       itk=itype2loc(itype(k))
11095       if (k.lt.nres-1) then
11096         itk1=itype2loc(itype(k+1))
11097       else
11098         itk1=nloctyp
11099       endif
11100       itl=itype2loc(itype(l))
11101       if (l.lt.nres-1) then
11102         itl1=itype2loc(itype(l+1))
11103       else
11104         itl1=nloctyp
11105       endif
11106 cd      write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
11107 cd      write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
11108 cd     & ' itl',itl,' itl1',itl1
11109 #ifdef MOMENT
11110       if (imat.eq.1) then
11111         s1=dip(3,jj,i)*dip(3,kk,k)
11112       else
11113         s1=dip(2,jj,j)*dip(2,kk,l)
11114       endif
11115 #endif
11116       call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
11117       s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
11118       if (j.eq.l+1) then
11119         call matvec2(ADtEA1(1,1,3-imat),b1(1,j+1),auxvec1(1))
11120         s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
11121       else
11122         call matvec2(ADtEA1(1,1,3-imat),b1(1,l+1),auxvec1(1))
11123         s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
11124       endif
11125       call transpose2(EUg(1,1,k),auxmat(1,1))
11126       call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
11127       vv(1)=pizda(1,1)-pizda(2,2)
11128       vv(2)=pizda(2,1)+pizda(1,2)
11129       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
11130 cd      write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
11131 #ifdef MOMENT
11132       eello6_graph4=-(s1+s2+s3+s4)
11133 #else
11134       eello6_graph4=-(s2+s3+s4)
11135 #endif
11136 C Derivatives in gamma(i-1)
11137       if (i.gt.1) then
11138 #ifdef MOMENT
11139         if (imat.eq.1) then
11140           s1=dipderg(2,jj,i)*dip(3,kk,k)
11141         else
11142           s1=dipderg(4,jj,j)*dip(2,kk,l)
11143         endif
11144 #endif
11145         s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
11146         if (j.eq.l+1) then
11147           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,j+1),auxvec1(1))
11148           s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
11149         else
11150           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,l+1),auxvec1(1))
11151           s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
11152         endif
11153         s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
11154         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
11155 cd          write (2,*) 'turn6 derivatives'
11156 #ifdef MOMENT
11157           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
11158 #else
11159           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
11160 #endif
11161         else
11162 #ifdef MOMENT
11163           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
11164 #else
11165           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
11166 #endif
11167         endif
11168       endif
11169 C Derivatives in gamma(k-1)
11170 #ifdef MOMENT
11171       if (imat.eq.1) then
11172         s1=dip(3,jj,i)*dipderg(2,kk,k)
11173       else
11174         s1=dip(2,jj,j)*dipderg(4,kk,l)
11175       endif
11176 #endif
11177       call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
11178       s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
11179       if (j.eq.l+1) then
11180         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,j+1),auxvec1(1))
11181         s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
11182       else
11183         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,l+1),auxvec1(1))
11184         s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
11185       endif
11186       call transpose2(EUgder(1,1,k),auxmat1(1,1))
11187       call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
11188       vv(1)=pizda(1,1)-pizda(2,2)
11189       vv(2)=pizda(2,1)+pizda(1,2)
11190       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
11191       if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
11192 #ifdef MOMENT
11193         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
11194 #else
11195         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
11196 #endif
11197       else
11198 #ifdef MOMENT
11199         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
11200 #else
11201         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
11202 #endif
11203       endif
11204 C Derivatives in gamma(j-1) or gamma(l-1)
11205       if (l.eq.j+1 .and. l.gt.1) then
11206         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
11207         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
11208         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
11209         vv(1)=pizda(1,1)-pizda(2,2)
11210         vv(2)=pizda(2,1)+pizda(1,2)
11211         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
11212         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
11213       else if (j.gt.1) then
11214         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
11215         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
11216         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
11217         vv(1)=pizda(1,1)-pizda(2,2)
11218         vv(2)=pizda(2,1)+pizda(1,2)
11219         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
11220         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
11221           gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
11222         else
11223           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
11224         endif
11225       endif
11226 C Cartesian derivatives.
11227       do iii=1,2
11228         do kkk=1,5
11229           do lll=1,3
11230 #ifdef MOMENT
11231             if (iii.eq.1) then
11232               if (imat.eq.1) then
11233                 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
11234               else
11235                 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
11236               endif
11237             else
11238               if (imat.eq.1) then
11239                 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
11240               else
11241                 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
11242               endif
11243             endif
11244 #endif
11245             call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),
11246      &        auxvec(1))
11247             s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
11248             if (j.eq.l+1) then
11249               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
11250      &          b1(1,j+1),auxvec(1))
11251               s3=-0.5d0*scalar2(b1(1,j),auxvec(1))
11252             else
11253               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
11254      &          b1(1,l+1),auxvec(1))
11255               s3=-0.5d0*scalar2(b1(1,l),auxvec(1))
11256             endif
11257             call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
11258      &        pizda(1,1))
11259             vv(1)=pizda(1,1)-pizda(2,2)
11260             vv(2)=pizda(2,1)+pizda(1,2)
11261             s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
11262             if (swap) then
11263               if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
11264 #ifdef MOMENT
11265                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
11266      &             -(s1+s2+s4)
11267 #else
11268                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
11269      &             -(s2+s4)
11270 #endif
11271                 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
11272               else
11273 #ifdef MOMENT
11274                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
11275 #else
11276                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
11277 #endif
11278                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
11279               endif
11280             else
11281 #ifdef MOMENT
11282               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
11283 #else
11284               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
11285 #endif
11286               if (l.eq.j+1) then
11287                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
11288               else
11289                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
11290               endif
11291             endif
11292           enddo
11293         enddo
11294       enddo
11295       return
11296       end
11297 c----------------------------------------------------------------------------
11298       double precision function eello_turn6(i,jj,kk)
11299       implicit real*8 (a-h,o-z)
11300       include 'DIMENSIONS'
11301       include 'COMMON.IOUNITS'
11302       include 'COMMON.CHAIN'
11303       include 'COMMON.DERIV'
11304       include 'COMMON.INTERACT'
11305       include 'COMMON.CONTACTS'
11306       include 'COMMON.CONTMAT'
11307       include 'COMMON.CORRMAT'
11308       include 'COMMON.TORSION'
11309       include 'COMMON.VAR'
11310       include 'COMMON.GEO'
11311       double precision vtemp1(2),vtemp2(2),vtemp3(2),vtemp4(2),
11312      &  atemp(2,2),auxmat(2,2),achuj_temp(2,2),gtemp(2,2),gvec(2),
11313      &  ggg1(3),ggg2(3)
11314       double precision vtemp1d(2),vtemp2d(2),vtemp3d(2),vtemp4d(2),
11315      &  atempd(2,2),auxmatd(2,2),achuj_tempd(2,2),gtempd(2,2),gvecd(2)
11316 C 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
11317 C           the respective energy moment and not to the cluster cumulant.
11318       s1=0.0d0
11319       s8=0.0d0
11320       s13=0.0d0
11321 c
11322       eello_turn6=0.0d0
11323       j=i+4
11324       k=i+1
11325       l=i+3
11326       iti=itype2loc(itype(i))
11327       itk=itype2loc(itype(k))
11328       itk1=itype2loc(itype(k+1))
11329       itl=itype2loc(itype(l))
11330       itj=itype2loc(itype(j))
11331 cd      write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
11332 cd      write (2,*) 'i',i,' k',k,' j',j,' l',l
11333 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
11334 cd        eello6=0.0d0
11335 cd        return
11336 cd      endif
11337 cd      write (iout,*)
11338 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
11339 cd     &   ' and',k,l
11340 cd      call checkint_turn6(i,jj,kk,eel_turn6_num)
11341       do iii=1,2
11342         do kkk=1,5
11343           do lll=1,3
11344             derx_turn(lll,kkk,iii)=0.0d0
11345           enddo
11346         enddo
11347       enddo
11348 cd      eij=1.0d0
11349 cd      ekl=1.0d0
11350 cd      ekont=1.0d0
11351       eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
11352 cd      eello6_5=0.0d0
11353 cd      write (2,*) 'eello6_5',eello6_5
11354 #ifdef MOMENT
11355       call transpose2(AEA(1,1,1),auxmat(1,1))
11356       call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
11357       ss1=scalar2(Ub2(1,i+2),b1(1,l))
11358       s1 = (auxmat(1,1)+auxmat(2,2))*ss1
11359 #endif
11360       call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1(1))
11361       call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
11362       s2 = scalar2(b1(1,k),vtemp1(1))
11363 #ifdef MOMENT
11364       call transpose2(AEA(1,1,2),atemp(1,1))
11365       call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
11366       call matvec2(Ug2(1,1,i+2),dd(1,1,k+1),vtemp2(1))
11367       s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,l),vtemp2(1))
11368 #endif
11369       call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
11370       call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
11371       s12 = scalar2(Ub2(1,i+2),vtemp3(1))
11372 #ifdef MOMENT
11373       call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
11374       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
11375       call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
11376       call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
11377       ss13 = scalar2(b1(1,k),vtemp4(1))
11378       s13 = (gtemp(1,1)+gtemp(2,2))*ss13
11379 #endif
11380 c      write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
11381 c      s1=0.0d0
11382 c      s2=0.0d0
11383 c      s8=0.0d0
11384 c      s12=0.0d0
11385 c      s13=0.0d0
11386       eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
11387 C Derivatives in gamma(i+2)
11388       s1d =0.0d0
11389       s8d =0.0d0
11390 #ifdef MOMENT
11391       call transpose2(AEA(1,1,1),auxmatd(1,1))
11392       call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
11393       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
11394       call transpose2(AEAderg(1,1,2),atempd(1,1))
11395       call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
11396       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,l),vtemp2(1))
11397 #endif
11398       call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
11399       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
11400       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
11401 c      s1d=0.0d0
11402 c      s2d=0.0d0
11403 c      s8d=0.0d0
11404 c      s12d=0.0d0
11405 c      s13d=0.0d0
11406       gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
11407 C Derivatives in gamma(i+3)
11408 #ifdef MOMENT
11409       call transpose2(AEA(1,1,1),auxmatd(1,1))
11410       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
11411       ss1d=scalar2(Ub2der(1,i+2),b1(1,l))
11412       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
11413 #endif
11414       call matvec2(EUgder(1,1,i+2),b1(1,l),vtemp1d(1))
11415       call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
11416       s2d = scalar2(b1(1,k),vtemp1d(1))
11417 #ifdef MOMENT
11418       call matvec2(Ug2der(1,1,i+2),dd(1,1,k+1),vtemp2d(1))
11419       s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,l),vtemp2d(1))
11420 #endif
11421       s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
11422 #ifdef MOMENT
11423       call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
11424       call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
11425       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
11426 #endif
11427 c      s1d=0.0d0
11428 c      s2d=0.0d0
11429 c      s8d=0.0d0
11430 c      s12d=0.0d0
11431 c      s13d=0.0d0
11432 #ifdef MOMENT
11433       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
11434      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
11435 #else
11436       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
11437      &               -0.5d0*ekont*(s2d+s12d)
11438 #endif
11439 C Derivatives in gamma(i+4)
11440       call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
11441       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
11442       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
11443 #ifdef MOMENT
11444       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
11445       call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
11446       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
11447 #endif
11448 c      s1d=0.0d0
11449 c      s2d=0.0d0
11450 c      s8d=0.0d0
11451 C      s12d=0.0d0
11452 c      s13d=0.0d0
11453 #ifdef MOMENT
11454       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
11455 #else
11456       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
11457 #endif
11458 C Derivatives in gamma(i+5)
11459 #ifdef MOMENT
11460       call transpose2(AEAderg(1,1,1),auxmatd(1,1))
11461       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
11462       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
11463 #endif
11464       call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1d(1))
11465       call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
11466       s2d = scalar2(b1(1,k),vtemp1d(1))
11467 #ifdef MOMENT
11468       call transpose2(AEA(1,1,2),atempd(1,1))
11469       call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
11470       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,l),vtemp2(1))
11471 #endif
11472       call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
11473       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
11474 #ifdef MOMENT
11475       call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
11476       ss13d = scalar2(b1(1,k),vtemp4d(1))
11477       s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
11478 #endif
11479 c      s1d=0.0d0
11480 c      s2d=0.0d0
11481 c      s8d=0.0d0
11482 c      s12d=0.0d0
11483 c      s13d=0.0d0
11484 #ifdef MOMENT
11485       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
11486      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
11487 #else
11488       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
11489      &               -0.5d0*ekont*(s2d+s12d)
11490 #endif
11491 C Cartesian derivatives
11492       do iii=1,2
11493         do kkk=1,5
11494           do lll=1,3
11495 #ifdef MOMENT
11496             call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
11497             call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
11498             s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
11499 #endif
11500             call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1(1))
11501             call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),
11502      &          vtemp1d(1))
11503             s2d = scalar2(b1(1,k),vtemp1d(1))
11504 #ifdef MOMENT
11505             call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
11506             call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
11507             s8d = -(atempd(1,1)+atempd(2,2))*
11508      &           scalar2(cc(1,1,l),vtemp2(1))
11509 #endif
11510             call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),
11511      &           auxmatd(1,1))
11512             call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
11513             s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
11514 c      s1d=0.0d0
11515 c      s2d=0.0d0
11516 c      s8d=0.0d0
11517 c      s12d=0.0d0
11518 c      s13d=0.0d0
11519 #ifdef MOMENT
11520             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
11521      &        - 0.5d0*(s1d+s2d)
11522 #else
11523             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
11524      &        - 0.5d0*s2d
11525 #endif
11526 #ifdef MOMENT
11527             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
11528      &        - 0.5d0*(s8d+s12d)
11529 #else
11530             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
11531      &        - 0.5d0*s12d
11532 #endif
11533           enddo
11534         enddo
11535       enddo
11536 #ifdef MOMENT
11537       do kkk=1,5
11538         do lll=1,3
11539           call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),
11540      &      achuj_tempd(1,1))
11541           call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
11542           call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
11543           s13d=(gtempd(1,1)+gtempd(2,2))*ss13
11544           derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
11545           call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),
11546      &      vtemp4d(1))
11547           ss13d = scalar2(b1(1,k),vtemp4d(1))
11548           s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
11549           derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
11550         enddo
11551       enddo
11552 #endif
11553 cd      write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
11554 cd     &  16*eel_turn6_num
11555 cd      goto 1112
11556       if (j.lt.nres-1) then
11557         j1=j+1
11558         j2=j-1
11559       else
11560         j1=j-1
11561         j2=j-2
11562       endif
11563       if (l.lt.nres-1) then
11564         l1=l+1
11565         l2=l-1
11566       else
11567         l1=l-1
11568         l2=l-2
11569       endif
11570       do ll=1,3
11571 cgrad        ggg1(ll)=eel_turn6*g_contij(ll,1)
11572 cgrad        ggg2(ll)=eel_turn6*g_contij(ll,2)
11573 cgrad        ghalf=0.5d0*ggg1(ll)
11574 cd        ghalf=0.0d0
11575         gturn6ij=eel_turn6*g_contij(ll,1)+ekont*derx_turn(ll,1,1)
11576         gturn6kl=eel_turn6*g_contij(ll,2)+ekont*derx_turn(ll,1,2)
11577         gcorr6_turn(ll,i)=gcorr6_turn(ll,i)!+ghalf
11578      &    +ekont*derx_turn(ll,2,1)
11579         gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
11580         gcorr6_turn(ll,j)=gcorr6_turn(ll,j)!+ghalf
11581      &    +ekont*derx_turn(ll,4,1)
11582         gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
11583         gcorr6_turn_long(ll,j)=gcorr6_turn_long(ll,j)+gturn6ij
11584         gcorr6_turn_long(ll,i)=gcorr6_turn_long(ll,i)-gturn6ij
11585 cgrad        ghalf=0.5d0*ggg2(ll)
11586 cd        ghalf=0.0d0
11587         gcorr6_turn(ll,k)=gcorr6_turn(ll,k)!+ghalf
11588      &    +ekont*derx_turn(ll,2,2)
11589         gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
11590         gcorr6_turn(ll,l)=gcorr6_turn(ll,l)!+ghalf
11591      &    +ekont*derx_turn(ll,4,2)
11592         gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
11593         gcorr6_turn_long(ll,l)=gcorr6_turn_long(ll,l)+gturn6kl
11594         gcorr6_turn_long(ll,k)=gcorr6_turn_long(ll,k)-gturn6kl
11595       enddo
11596 cd      goto 1112
11597 cgrad      do m=i+1,j-1
11598 cgrad        do ll=1,3
11599 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
11600 cgrad        enddo
11601 cgrad      enddo
11602 cgrad      do m=k+1,l-1
11603 cgrad        do ll=1,3
11604 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
11605 cgrad        enddo
11606 cgrad      enddo
11607 cgrad1112  continue
11608 cgrad      do m=i+2,j2
11609 cgrad        do ll=1,3
11610 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
11611 cgrad        enddo
11612 cgrad      enddo
11613 cgrad      do m=k+2,l2
11614 cgrad        do ll=1,3
11615 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
11616 cgrad        enddo
11617 cgrad      enddo
11618 cd      do iii=1,nres-3
11619 cd        write (2,*) iii,g_corr6_loc(iii)
11620 cd      enddo
11621       eello_turn6=ekont*eel_turn6
11622 cd      write (2,*) 'ekont',ekont
11623 cd      write (2,*) 'eel_turn6',ekont*eel_turn6
11624       return
11625       end
11626 C-----------------------------------------------------------------------------
11627 #endif
11628       double precision function scalar(u,v)
11629 !DIR$ INLINEALWAYS scalar
11630 #ifndef OSF
11631 cDEC$ ATTRIBUTES FORCEINLINE::scalar
11632 #endif
11633       implicit none
11634       double precision u(3),v(3)
11635 cd      double precision sc
11636 cd      integer i
11637 cd      sc=0.0d0
11638 cd      do i=1,3
11639 cd        sc=sc+u(i)*v(i)
11640 cd      enddo
11641 cd      scalar=sc
11642
11643       scalar=u(1)*v(1)+u(2)*v(2)+u(3)*v(3)
11644       return
11645       end
11646 crc-------------------------------------------------
11647       SUBROUTINE MATVEC2(A1,V1,V2)
11648 !DIR$ INLINEALWAYS MATVEC2
11649 #ifndef OSF
11650 cDEC$ ATTRIBUTES FORCEINLINE::MATVEC2
11651 #endif
11652       implicit real*8 (a-h,o-z)
11653       include 'DIMENSIONS'
11654       DIMENSION A1(2,2),V1(2),V2(2)
11655 c      DO 1 I=1,2
11656 c        VI=0.0
11657 c        DO 3 K=1,2
11658 c    3     VI=VI+A1(I,K)*V1(K)
11659 c        Vaux(I)=VI
11660 c    1 CONTINUE
11661
11662       vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
11663       vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
11664
11665       v2(1)=vaux1
11666       v2(2)=vaux2
11667       END
11668 C---------------------------------------
11669       SUBROUTINE MATMAT2(A1,A2,A3)
11670 #ifndef OSF
11671 cDEC$ ATTRIBUTES FORCEINLINE::MATMAT2
11672 #endif
11673       implicit real*8 (a-h,o-z)
11674       include 'DIMENSIONS'
11675       DIMENSION A1(2,2),A2(2,2),A3(2,2)
11676 c      DIMENSION AI3(2,2)
11677 c        DO  J=1,2
11678 c          A3IJ=0.0
11679 c          DO K=1,2
11680 c           A3IJ=A3IJ+A1(I,K)*A2(K,J)
11681 c          enddo
11682 c          A3(I,J)=A3IJ
11683 c       enddo
11684 c      enddo
11685
11686       ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
11687       ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
11688       ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
11689       ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
11690
11691       A3(1,1)=AI3_11
11692       A3(2,1)=AI3_21
11693       A3(1,2)=AI3_12
11694       A3(2,2)=AI3_22
11695       END
11696
11697 c-------------------------------------------------------------------------
11698       double precision function scalar2(u,v)
11699 !DIR$ INLINEALWAYS scalar2
11700       implicit none
11701       double precision u(2),v(2)
11702       double precision sc
11703       integer i
11704       scalar2=u(1)*v(1)+u(2)*v(2)
11705       return
11706       end
11707
11708 C-----------------------------------------------------------------------------
11709
11710       subroutine transpose2(a,at)
11711 !DIR$ INLINEALWAYS transpose2
11712 #ifndef OSF
11713 cDEC$ ATTRIBUTES FORCEINLINE::transpose2
11714 #endif
11715       implicit none
11716       double precision a(2,2),at(2,2)
11717       at(1,1)=a(1,1)
11718       at(1,2)=a(2,1)
11719       at(2,1)=a(1,2)
11720       at(2,2)=a(2,2)
11721       return
11722       end
11723 c--------------------------------------------------------------------------
11724       subroutine transpose(n,a,at)
11725       implicit none
11726       integer n,i,j
11727       double precision a(n,n),at(n,n)
11728       do i=1,n
11729         do j=1,n
11730           at(j,i)=a(i,j)
11731         enddo
11732       enddo
11733       return
11734       end
11735 C---------------------------------------------------------------------------
11736       subroutine prodmat3(a1,a2,kk,transp,prod)
11737 !DIR$ INLINEALWAYS prodmat3
11738 #ifndef OSF
11739 cDEC$ ATTRIBUTES FORCEINLINE::prodmat3
11740 #endif
11741       implicit none
11742       integer i,j
11743       double precision a1(2,2),a2(2,2),a2t(2,2),kk(2,2),prod(2,2)
11744       logical transp
11745 crc      double precision auxmat(2,2),prod_(2,2)
11746
11747       if (transp) then
11748 crc        call transpose2(kk(1,1),auxmat(1,1))
11749 crc        call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
11750 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
11751
11752            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1)
11753      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
11754            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2)
11755      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
11756            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1)
11757      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
11758            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2)
11759      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
11760
11761       else
11762 crc        call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
11763 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
11764
11765            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1)
11766      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
11767            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2)
11768      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
11769            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1)
11770      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
11771            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2)
11772      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
11773
11774       endif
11775 c      call transpose2(a2(1,1),a2t(1,1))
11776
11777 crc      print *,transp
11778 crc      print *,((prod_(i,j),i=1,2),j=1,2)
11779 crc      print *,((prod(i,j),i=1,2),j=1,2)
11780
11781       return
11782       end
11783 CCC----------------------------------------------
11784       subroutine Eliptransfer(eliptran)
11785       implicit real*8 (a-h,o-z)
11786       include 'DIMENSIONS'
11787       include 'COMMON.GEO'
11788       include 'COMMON.VAR'
11789       include 'COMMON.LOCAL'
11790       include 'COMMON.CHAIN'
11791       include 'COMMON.DERIV'
11792       include 'COMMON.NAMES'
11793       include 'COMMON.INTERACT'
11794       include 'COMMON.IOUNITS'
11795       include 'COMMON.CALC'
11796       include 'COMMON.CONTROL'
11797       include 'COMMON.SPLITELE'
11798       include 'COMMON.SBRIDGE'
11799 C this is done by Adasko
11800 C      print *,"wchodze"
11801 C structure of box:
11802 C      water
11803 C--bordliptop-- buffore starts
11804 C--bufliptop--- here true lipid starts
11805 C      lipid
11806 C--buflipbot--- lipid ends buffore starts
11807 C--bordlipbot--buffore ends
11808       eliptran=0.0
11809       do i=ilip_start,ilip_end
11810 C       do i=1,1
11811         if (itype(i).eq.ntyp1) cycle
11812
11813         positi=(mod(((c(3,i)+c(3,i+1))/2.0d0),boxzsize))
11814         if (positi.le.0.0) positi=positi+boxzsize
11815 C        print *,i
11816 C first for peptide groups
11817 c for each residue check if it is in lipid or lipid water border area
11818        if ((positi.gt.bordlipbot)
11819      &.and.(positi.lt.bordliptop)) then
11820 C the energy transfer exist
11821         if (positi.lt.buflipbot) then
11822 C what fraction I am in
11823          fracinbuf=1.0d0-
11824      &        ((positi-bordlipbot)/lipbufthick)
11825 C lipbufthick is thickenes of lipid buffore
11826          sslip=sscalelip(fracinbuf)
11827          ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
11828          eliptran=eliptran+sslip*pepliptran
11829          gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
11830          gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
11831 C         gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
11832
11833 C        print *,"doing sccale for lower part"
11834 C         print *,i,sslip,fracinbuf,ssgradlip
11835         elseif (positi.gt.bufliptop) then
11836          fracinbuf=1.0d0-((bordliptop-positi)/lipbufthick)
11837          sslip=sscalelip(fracinbuf)
11838          ssgradlip=sscagradlip(fracinbuf)/lipbufthick
11839          eliptran=eliptran+sslip*pepliptran
11840          gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
11841          gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
11842 C         gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
11843 C          print *, "doing sscalefor top part"
11844 C         print *,i,sslip,fracinbuf,ssgradlip
11845         else
11846          eliptran=eliptran+pepliptran
11847 C         print *,"I am in true lipid"
11848         endif
11849 C       else
11850 C       eliptran=elpitran+0.0 ! I am in water
11851        endif
11852        enddo
11853 C       print *, "nic nie bylo w lipidzie?"
11854 C now multiply all by the peptide group transfer factor
11855 C       eliptran=eliptran*pepliptran
11856 C now the same for side chains
11857 CV       do i=1,1
11858        do i=ilip_start,ilip_end
11859         if (itype(i).eq.ntyp1) cycle
11860         positi=(mod(c(3,i+nres),boxzsize))
11861         if (positi.le.0) positi=positi+boxzsize
11862 C       print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop
11863 c for each residue check if it is in lipid or lipid water border area
11864 C       respos=mod(c(3,i+nres),boxzsize)
11865 C       print *,positi,bordlipbot,buflipbot
11866        if ((positi.gt.bordlipbot)
11867      & .and.(positi.lt.bordliptop)) then
11868 C the energy transfer exist
11869         if (positi.lt.buflipbot) then
11870          fracinbuf=1.0d0-
11871      &     ((positi-bordlipbot)/lipbufthick)
11872 C lipbufthick is thickenes of lipid buffore
11873          sslip=sscalelip(fracinbuf)
11874          ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
11875          eliptran=eliptran+sslip*liptranene(itype(i))
11876          gliptranx(3,i)=gliptranx(3,i)
11877      &+ssgradlip*liptranene(itype(i))
11878          gliptranc(3,i-1)= gliptranc(3,i-1)
11879      &+ssgradlip*liptranene(itype(i))
11880 C         print *,"doing sccale for lower part"
11881         elseif (positi.gt.bufliptop) then
11882          fracinbuf=1.0d0-
11883      &((bordliptop-positi)/lipbufthick)
11884          sslip=sscalelip(fracinbuf)
11885          ssgradlip=sscagradlip(fracinbuf)/lipbufthick
11886          eliptran=eliptran+sslip*liptranene(itype(i))
11887          gliptranx(3,i)=gliptranx(3,i)
11888      &+ssgradlip*liptranene(itype(i))
11889          gliptranc(3,i-1)= gliptranc(3,i-1)
11890      &+ssgradlip*liptranene(itype(i))
11891 C          print *, "doing sscalefor top part",sslip,fracinbuf
11892         else
11893          eliptran=eliptran+liptranene(itype(i))
11894 C         print *,"I am in true lipid"
11895         endif
11896         endif ! if in lipid or buffor
11897 C       else
11898 C       eliptran=elpitran+0.0 ! I am in water
11899        enddo
11900        return
11901        end
11902 C---------------------------------------------------------
11903 C AFM soubroutine for constant force
11904        subroutine AFMforce(Eafmforce)
11905        implicit real*8 (a-h,o-z)
11906       include 'DIMENSIONS'
11907       include 'COMMON.GEO'
11908       include 'COMMON.VAR'
11909       include 'COMMON.LOCAL'
11910       include 'COMMON.CHAIN'
11911       include 'COMMON.DERIV'
11912       include 'COMMON.NAMES'
11913       include 'COMMON.INTERACT'
11914       include 'COMMON.IOUNITS'
11915       include 'COMMON.CALC'
11916       include 'COMMON.CONTROL'
11917       include 'COMMON.SPLITELE'
11918       include 'COMMON.SBRIDGE'
11919       real*8 diffafm(3)
11920       dist=0.0d0
11921       Eafmforce=0.0d0
11922       do i=1,3
11923       diffafm(i)=c(i,afmend)-c(i,afmbeg)
11924       dist=dist+diffafm(i)**2
11925       enddo
11926       dist=dsqrt(dist)
11927       Eafmforce=-forceAFMconst*(dist-distafminit)
11928       do i=1,3
11929       gradafm(i,afmend-1)=-forceAFMconst*diffafm(i)/dist
11930       gradafm(i,afmbeg-1)=forceAFMconst*diffafm(i)/dist
11931       enddo
11932 C      print *,'AFM',Eafmforce
11933       return
11934       end
11935 C---------------------------------------------------------
11936 C AFM subroutine with pseudoconstant velocity
11937        subroutine AFMvel(Eafmforce)
11938        implicit real*8 (a-h,o-z)
11939       include 'DIMENSIONS'
11940       include 'COMMON.GEO'
11941       include 'COMMON.VAR'
11942       include 'COMMON.LOCAL'
11943       include 'COMMON.CHAIN'
11944       include 'COMMON.DERIV'
11945       include 'COMMON.NAMES'
11946       include 'COMMON.INTERACT'
11947       include 'COMMON.IOUNITS'
11948       include 'COMMON.CALC'
11949       include 'COMMON.CONTROL'
11950       include 'COMMON.SPLITELE'
11951       include 'COMMON.SBRIDGE'
11952       real*8 diffafm(3)
11953 C Only for check grad COMMENT if not used for checkgrad
11954 C      totT=3.0d0
11955 C--------------------------------------------------------
11956 C      print *,"wchodze"
11957       dist=0.0d0
11958       Eafmforce=0.0d0
11959       do i=1,3
11960       diffafm(i)=c(i,afmend)-c(i,afmbeg)
11961       dist=dist+diffafm(i)**2
11962       enddo
11963       dist=dsqrt(dist)
11964       Eafmforce=0.5d0*forceAFMconst
11965      & *(distafminit+totTafm*velAFMconst-dist)**2
11966 C      Eafmforce=-forceAFMconst*(dist-distafminit)
11967       do i=1,3
11968       gradafm(i,afmend-1)=-forceAFMconst*
11969      &(distafminit+totTafm*velAFMconst-dist)
11970      &*diffafm(i)/dist
11971       gradafm(i,afmbeg-1)=forceAFMconst*
11972      &(distafminit+totTafm*velAFMconst-dist)
11973      &*diffafm(i)/dist
11974       enddo
11975 C      print *,'AFM',Eafmforce,totTafm*velAFMconst,dist
11976       return
11977       end
11978 C-----------------------------------------------------------
11979 C first for shielding is setting of function of side-chains
11980        subroutine set_shield_fac
11981       implicit real*8 (a-h,o-z)
11982       include 'DIMENSIONS'
11983       include 'COMMON.CHAIN'
11984       include 'COMMON.DERIV'
11985       include 'COMMON.IOUNITS'
11986       include 'COMMON.SHIELD'
11987       include 'COMMON.INTERACT'
11988 C this is the squar root 77 devided by 81 the epislion in lipid (in protein)
11989       double precision div77_81/0.974996043d0/,
11990      &div4_81/0.2222222222d0/,sh_frac_dist_grad(3)
11991
11992 C the vector between center of side_chain and peptide group
11993        double precision pep_side(3),long,side_calf(3),
11994      &pept_group(3),costhet_grad(3),cosphi_grad_long(3),
11995      &cosphi_grad_loc(3),pep_side_norm(3),side_calf_norm(3)
11996 C the line belowe needs to be changed for FGPROC>1
11997       do i=1,nres-1
11998       if ((itype(i).eq.ntyp1).and.itype(i+1).eq.ntyp1) cycle
11999       ishield_list(i)=0
12000 Cif there two consequtive dummy atoms there is no peptide group between them
12001 C the line below has to be changed for FGPROC>1
12002       VolumeTotal=0.0
12003       do k=1,nres
12004        if ((itype(k).eq.ntyp1).or.(itype(k).eq.10)) cycle
12005        dist_pep_side=0.0
12006        dist_side_calf=0.0
12007        do j=1,3
12008 C first lets set vector conecting the ithe side-chain with kth side-chain
12009       pep_side(j)=c(j,k+nres)-(c(j,i)+c(j,i+1))/2.0d0
12010 C      pep_side(j)=2.0d0
12011 C and vector conecting the side-chain with its proper calfa
12012       side_calf(j)=c(j,k+nres)-c(j,k)
12013 C      side_calf(j)=2.0d0
12014       pept_group(j)=c(j,i)-c(j,i+1)
12015 C lets have their lenght
12016       dist_pep_side=pep_side(j)**2+dist_pep_side
12017       dist_side_calf=dist_side_calf+side_calf(j)**2
12018       dist_pept_group=dist_pept_group+pept_group(j)**2
12019       enddo
12020        dist_pep_side=dsqrt(dist_pep_side)
12021        dist_pept_group=dsqrt(dist_pept_group)
12022        dist_side_calf=dsqrt(dist_side_calf)
12023       do j=1,3
12024         pep_side_norm(j)=pep_side(j)/dist_pep_side
12025         side_calf_norm(j)=dist_side_calf
12026       enddo
12027 C now sscale fraction
12028        sh_frac_dist=-(dist_pep_side-rpp(1,1)-buff_shield)/buff_shield
12029 C       print *,buff_shield,"buff"
12030 C now sscale
12031         if (sh_frac_dist.le.0.0) cycle
12032 C If we reach here it means that this side chain reaches the shielding sphere
12033 C Lets add him to the list for gradient
12034         ishield_list(i)=ishield_list(i)+1
12035 C ishield_list is a list of non 0 side-chain that contribute to factor gradient
12036 C this list is essential otherwise problem would be O3
12037         shield_list(ishield_list(i),i)=k
12038 C Lets have the sscale value
12039         if (sh_frac_dist.gt.1.0) then
12040          scale_fac_dist=1.0d0
12041          do j=1,3
12042          sh_frac_dist_grad(j)=0.0d0
12043          enddo
12044         else
12045          scale_fac_dist=-sh_frac_dist*sh_frac_dist
12046      &                   *(2.0*sh_frac_dist-3.0d0)
12047          fac_help_scale=6.0*(sh_frac_dist-sh_frac_dist**2)
12048      &                  /dist_pep_side/buff_shield*0.5
12049 C remember for the final gradient multiply sh_frac_dist_grad(j)
12050 C for side_chain by factor -2 !
12051          do j=1,3
12052          sh_frac_dist_grad(j)=fac_help_scale*pep_side(j)
12053 C         print *,"jestem",scale_fac_dist,fac_help_scale,
12054 C     &                    sh_frac_dist_grad(j)
12055          enddo
12056         endif
12057 C        if ((i.eq.3).and.(k.eq.2)) then
12058 C        print *,i,sh_frac_dist,dist_pep,fac_help_scale,scale_fac_dist
12059 C     & ,"TU"
12060 C        endif
12061
12062 C this is what is now we have the distance scaling now volume...
12063       short=short_r_sidechain(itype(k))
12064       long=long_r_sidechain(itype(k))
12065       costhet=1.0d0/dsqrt(1.0+short**2/dist_pep_side**2)
12066 C now costhet_grad
12067 C       costhet=0.0d0
12068        costhet_fac=costhet**3*short**2*(-0.5)/dist_pep_side**4
12069 C       costhet_fac=0.0d0
12070        do j=1,3
12071          costhet_grad(j)=costhet_fac*pep_side(j)
12072        enddo
12073 C remember for the final gradient multiply costhet_grad(j)
12074 C for side_chain by factor -2 !
12075 C fac alfa is angle between CB_k,CA_k, CA_i,CA_i+1
12076 C pep_side0pept_group is vector multiplication
12077       pep_side0pept_group=0.0
12078       do j=1,3
12079       pep_side0pept_group=pep_side0pept_group+pep_side(j)*side_calf(j)
12080       enddo
12081       cosalfa=(pep_side0pept_group/
12082      & (dist_pep_side*dist_side_calf))
12083       fac_alfa_sin=1.0-cosalfa**2
12084       fac_alfa_sin=dsqrt(fac_alfa_sin)
12085       rkprim=fac_alfa_sin*(long-short)+short
12086 C now costhet_grad
12087        cosphi=1.0d0/dsqrt(1.0+rkprim**2/dist_pep_side**2)
12088        cosphi_fac=cosphi**3*rkprim**2*(-0.5)/dist_pep_side**4
12089
12090        do j=1,3
12091          cosphi_grad_long(j)=cosphi_fac*pep_side(j)
12092      &+cosphi**3*0.5/dist_pep_side**2*(-rkprim)
12093      &*(long-short)/fac_alfa_sin*cosalfa/
12094      &((dist_pep_side*dist_side_calf))*
12095      &((side_calf(j))-cosalfa*
12096      &((pep_side(j)/dist_pep_side)*dist_side_calf))
12097
12098         cosphi_grad_loc(j)=cosphi**3*0.5/dist_pep_side**2*(-rkprim)
12099      &*(long-short)/fac_alfa_sin*cosalfa
12100      &/((dist_pep_side*dist_side_calf))*
12101      &(pep_side(j)-
12102      &cosalfa*side_calf(j)/dist_side_calf*dist_pep_side)
12103        enddo
12104
12105       VofOverlap=VSolvSphere/2.0d0*(1.0-costhet)*(1.0-cosphi)
12106      &                    /VSolvSphere_div
12107      &                    *wshield
12108 C now the gradient...
12109 C grad_shield is gradient of Calfa for peptide groups
12110 C      write(iout,*) "shield_compon",i,k,VSolvSphere,scale_fac_dist,
12111 C     &               costhet,cosphi
12112 C       write(iout,*) "cosphi_compon",i,k,pep_side0pept_group,
12113 C     & dist_pep_side,dist_side_calf,c(1,k+nres),c(1,k),itype(k)
12114       do j=1,3
12115       grad_shield(j,i)=grad_shield(j,i)
12116 C gradient po skalowaniu
12117      &                +(sh_frac_dist_grad(j)
12118 C  gradient po costhet
12119      &-scale_fac_dist*costhet_grad(j)/(1.0-costhet)
12120      &-scale_fac_dist*(cosphi_grad_long(j))
12121      &/(1.0-cosphi) )*div77_81
12122      &*VofOverlap
12123 C grad_shield_side is Cbeta sidechain gradient
12124       grad_shield_side(j,ishield_list(i),i)=
12125      &        (sh_frac_dist_grad(j)*(-2.0d0)
12126      &       +scale_fac_dist*costhet_grad(j)*2.0d0/(1.0-costhet)
12127      &       +scale_fac_dist*(cosphi_grad_long(j))
12128      &        *2.0d0/(1.0-cosphi))
12129      &        *div77_81*VofOverlap
12130
12131        grad_shield_loc(j,ishield_list(i),i)=
12132      &   scale_fac_dist*cosphi_grad_loc(j)
12133      &        *2.0d0/(1.0-cosphi)
12134      &        *div77_81*VofOverlap
12135       enddo
12136       VolumeTotal=VolumeTotal+VofOverlap*scale_fac_dist
12137       enddo
12138       fac_shield(i)=VolumeTotal*div77_81+div4_81
12139 c      write(2,*) "TOTAL VOLUME",i,VolumeTotal,fac_shield(i)
12140       enddo
12141       return
12142       end
12143 C--------------------------------------------------------------------------
12144       double precision function tschebyshev(m,n,x,y)
12145       implicit none
12146       include "DIMENSIONS"
12147       integer i,m,n
12148       double precision x(n),y,yy(0:maxvar),aux
12149 c Tschebyshev polynomial. Note that the first term is omitted
12150 c m=0: the constant term is included
12151 c m=1: the constant term is not included
12152       yy(0)=1.0d0
12153       yy(1)=y
12154       do i=2,n
12155         yy(i)=2*yy(1)*yy(i-1)-yy(i-2)
12156       enddo
12157       aux=0.0d0
12158       do i=m,n
12159         aux=aux+x(i)*yy(i)
12160       enddo
12161       tschebyshev=aux
12162       return
12163       end
12164 C--------------------------------------------------------------------------
12165       double precision function gradtschebyshev(m,n,x,y)
12166       implicit none
12167       include "DIMENSIONS"
12168       integer i,m,n
12169       double precision x(n+1),y,yy(0:maxvar),aux
12170 c Tschebyshev polynomial. Note that the first term is omitted
12171 c m=0: the constant term is included
12172 c m=1: the constant term is not included
12173       yy(0)=1.0d0
12174       yy(1)=2.0d0*y
12175       do i=2,n
12176         yy(i)=2*y*yy(i-1)-yy(i-2)
12177       enddo
12178       aux=0.0d0
12179       do i=m,n
12180         aux=aux+x(i+1)*yy(i)*(i+1)
12181 C        print *, x(i+1),yy(i),i
12182       enddo
12183       gradtschebyshev=aux
12184       return
12185       end
12186 C------------------------------------------------------------------------
12187 C first for shielding is setting of function of side-chains
12188        subroutine set_shield_fac2
12189       implicit real*8 (a-h,o-z)
12190       include 'DIMENSIONS'
12191       include 'COMMON.CHAIN'
12192       include 'COMMON.DERIV'
12193       include 'COMMON.IOUNITS'
12194       include 'COMMON.SHIELD'
12195       include 'COMMON.INTERACT'
12196 C this is the squar root 77 devided by 81 the epislion in lipid (in protein)
12197       double precision div77_81/0.974996043d0/,
12198      &div4_81/0.2222222222d0/,sh_frac_dist_grad(3)
12199
12200 C the vector between center of side_chain and peptide group
12201        double precision pep_side(3),long,side_calf(3),
12202      &pept_group(3),costhet_grad(3),cosphi_grad_long(3),
12203      &cosphi_grad_loc(3),pep_side_norm(3),side_calf_norm(3)
12204 C the line belowe needs to be changed for FGPROC>1
12205       do i=1,nres-1
12206       if ((itype(i).eq.ntyp1).and.itype(i+1).eq.ntyp1) cycle
12207       ishield_list(i)=0
12208 Cif there two consequtive dummy atoms there is no peptide group between them
12209 C the line below has to be changed for FGPROC>1
12210       VolumeTotal=0.0
12211       do k=1,nres
12212        if ((itype(k).eq.ntyp1).or.(itype(k).eq.10)) cycle
12213        dist_pep_side=0.0
12214        dist_side_calf=0.0
12215        do j=1,3
12216 C first lets set vector conecting the ithe side-chain with kth side-chain
12217       pep_side(j)=c(j,k+nres)-(c(j,i)+c(j,i+1))/2.0d0
12218 C      pep_side(j)=2.0d0
12219 C and vector conecting the side-chain with its proper calfa
12220       side_calf(j)=c(j,k+nres)-c(j,k)
12221 C      side_calf(j)=2.0d0
12222       pept_group(j)=c(j,i)-c(j,i+1)
12223 C lets have their lenght
12224       dist_pep_side=pep_side(j)**2+dist_pep_side
12225       dist_side_calf=dist_side_calf+side_calf(j)**2
12226       dist_pept_group=dist_pept_group+pept_group(j)**2
12227       enddo
12228        dist_pep_side=dsqrt(dist_pep_side)
12229        dist_pept_group=dsqrt(dist_pept_group)
12230        dist_side_calf=dsqrt(dist_side_calf)
12231       do j=1,3
12232         pep_side_norm(j)=pep_side(j)/dist_pep_side
12233         side_calf_norm(j)=dist_side_calf
12234       enddo
12235 C now sscale fraction
12236        sh_frac_dist=-(dist_pep_side-rpp(1,1)-buff_shield)/buff_shield
12237 C       print *,buff_shield,"buff"
12238 C now sscale
12239         if (sh_frac_dist.le.0.0) cycle
12240 C If we reach here it means that this side chain reaches the shielding sphere
12241 C Lets add him to the list for gradient
12242         ishield_list(i)=ishield_list(i)+1
12243 C ishield_list is a list of non 0 side-chain that contribute to factor gradient
12244 C this list is essential otherwise problem would be O3
12245         shield_list(ishield_list(i),i)=k
12246 C Lets have the sscale value
12247         if (sh_frac_dist.gt.1.0) then
12248          scale_fac_dist=1.0d0
12249          do j=1,3
12250          sh_frac_dist_grad(j)=0.0d0
12251          enddo
12252         else
12253          scale_fac_dist=-sh_frac_dist*sh_frac_dist
12254      &                   *(2.0d0*sh_frac_dist-3.0d0)
12255          fac_help_scale=6.0d0*(sh_frac_dist-sh_frac_dist**2)
12256      &                  /dist_pep_side/buff_shield*0.5d0
12257 C remember for the final gradient multiply sh_frac_dist_grad(j)
12258 C for side_chain by factor -2 !
12259          do j=1,3
12260          sh_frac_dist_grad(j)=fac_help_scale*pep_side(j)
12261 C         sh_frac_dist_grad(j)=0.0d0
12262 C         scale_fac_dist=1.0d0
12263 C         print *,"jestem",scale_fac_dist,fac_help_scale,
12264 C     &                    sh_frac_dist_grad(j)
12265          enddo
12266         endif
12267 C this is what is now we have the distance scaling now volume...
12268       short=short_r_sidechain(itype(k))
12269       long=long_r_sidechain(itype(k))
12270       costhet=1.0d0/dsqrt(1.0d0+short**2/dist_pep_side**2)
12271       sinthet=short/dist_pep_side*costhet
12272 C now costhet_grad
12273 C       costhet=0.6d0
12274 C       sinthet=0.8
12275        costhet_fac=costhet**3*short**2*(-0.5d0)/dist_pep_side**4
12276 C       sinthet_fac=costhet**2*0.5d0*(short**3/dist_pep_side**4*costhet
12277 C     &             -short/dist_pep_side**2/costhet)
12278 C       costhet_fac=0.0d0
12279        do j=1,3
12280          costhet_grad(j)=costhet_fac*pep_side(j)
12281        enddo
12282 C remember for the final gradient multiply costhet_grad(j)
12283 C for side_chain by factor -2 !
12284 C fac alfa is angle between CB_k,CA_k, CA_i,CA_i+1
12285 C pep_side0pept_group is vector multiplication
12286       pep_side0pept_group=0.0d0
12287       do j=1,3
12288       pep_side0pept_group=pep_side0pept_group+pep_side(j)*side_calf(j)
12289       enddo
12290       cosalfa=(pep_side0pept_group/
12291      & (dist_pep_side*dist_side_calf))
12292       fac_alfa_sin=1.0d0-cosalfa**2
12293       fac_alfa_sin=dsqrt(fac_alfa_sin)
12294       rkprim=fac_alfa_sin*(long-short)+short
12295 C      rkprim=short
12296
12297 C now costhet_grad
12298        cosphi=1.0d0/dsqrt(1.0d0+rkprim**2/dist_pep_side**2)
12299 C       cosphi=0.6
12300        cosphi_fac=cosphi**3*rkprim**2*(-0.5d0)/dist_pep_side**4
12301        sinphi=rkprim/dist_pep_side/dsqrt(1.0d0+rkprim**2/
12302      &      dist_pep_side**2)
12303 C       sinphi=0.8
12304        do j=1,3
12305          cosphi_grad_long(j)=cosphi_fac*pep_side(j)
12306      &+cosphi**3*0.5d0/dist_pep_side**2*(-rkprim)
12307      &*(long-short)/fac_alfa_sin*cosalfa/
12308      &((dist_pep_side*dist_side_calf))*
12309      &((side_calf(j))-cosalfa*
12310      &((pep_side(j)/dist_pep_side)*dist_side_calf))
12311 C       cosphi_grad_long(j)=0.0d0
12312         cosphi_grad_loc(j)=cosphi**3*0.5d0/dist_pep_side**2*(-rkprim)
12313      &*(long-short)/fac_alfa_sin*cosalfa
12314      &/((dist_pep_side*dist_side_calf))*
12315      &(pep_side(j)-
12316      &cosalfa*side_calf(j)/dist_side_calf*dist_pep_side)
12317 C       cosphi_grad_loc(j)=0.0d0
12318        enddo
12319 C      print *,sinphi,sinthet
12320 c      write (iout,*) "VSolvSphere",VSolvSphere," VSolvSphere_div",
12321 c     &  VSolvSphere_div," sinphi",sinphi," sinthet",sinthet
12322       VofOverlap=VSolvSphere/2.0d0*(1.0d0-dsqrt(1.0d0-sinphi*sinthet))
12323      &                    /VSolvSphere_div
12324 C     &                    *wshield
12325 C now the gradient...
12326       do j=1,3
12327       grad_shield(j,i)=grad_shield(j,i)
12328 C gradient po skalowaniu
12329      &                +(sh_frac_dist_grad(j)*VofOverlap
12330 C  gradient po costhet
12331      &       +scale_fac_dist*VSolvSphere/VSolvSphere_div/4.0d0*
12332      &(1.0d0/(-dsqrt(1.0d0-sinphi*sinthet))*(
12333      &       sinphi/sinthet*costhet*costhet_grad(j)
12334      &      +sinthet/sinphi*cosphi*cosphi_grad_long(j)))
12335      & )*wshield
12336 C grad_shield_side is Cbeta sidechain gradient
12337       grad_shield_side(j,ishield_list(i),i)=
12338      &        (sh_frac_dist_grad(j)*(-2.0d0)
12339      &        *VofOverlap
12340      &       -scale_fac_dist*VSolvSphere/VSolvSphere_div/2.0d0*
12341      &(1.0d0/(-dsqrt(1.0d0-sinphi*sinthet))*(
12342      &       sinphi/sinthet*costhet*costhet_grad(j)
12343      &      +sinthet/sinphi*cosphi*cosphi_grad_long(j)))
12344      &       )*wshield
12345
12346        grad_shield_loc(j,ishield_list(i),i)=
12347      &       scale_fac_dist*VSolvSphere/VSolvSphere_div/2.0d0*
12348      &(1.0d0/(dsqrt(1.0d0-sinphi*sinthet))*(
12349      &       sinthet/sinphi*cosphi*cosphi_grad_loc(j)
12350      &        ))
12351      &        *wshield
12352       enddo
12353 c      write (iout,*) "VofOverlap",VofOverlap," scale_fac_dist",
12354 c     & scale_fac_dist
12355       VolumeTotal=VolumeTotal+VofOverlap*scale_fac_dist
12356       enddo
12357       fac_shield(i)=VolumeTotal*wshield+(1.0d0-wshield)
12358 c      write(2,*) "TOTAL VOLUME",i,VolumeTotal,fac_shield(i),
12359 c     &  " wshield",wshield
12360 c      write(2,*) "TU",rpp(1,1),short,long,buff_shield
12361       enddo
12362       return
12363       end
12364 C-----------------------------------------------------------------------
12365 C-----------------------------------------------------------
12366 C This subroutine is to mimic the histone like structure but as well can be
12367 C utilizet to nanostructures (infinit) small modification has to be used to
12368 C make it finite (z gradient at the ends has to be changes as well as the x,y
12369 C gradient has to be modified at the ends
12370 C The energy function is Kihara potential
12371 C E=4esp*((sigma/(r-r0))^12 - (sigma/(r-r0))^6)
12372 C 4eps is depth of well sigma is r_minimum r is distance from center of tube
12373 C and r0 is the excluded size of nanotube (can be set to 0 if we want just a
12374 C simple Kihara potential
12375       subroutine calctube(Etube)
12376        implicit real*8 (a-h,o-z)
12377       include 'DIMENSIONS'
12378       include 'COMMON.GEO'
12379       include 'COMMON.VAR'
12380       include 'COMMON.LOCAL'
12381       include 'COMMON.CHAIN'
12382       include 'COMMON.DERIV'
12383       include 'COMMON.NAMES'
12384       include 'COMMON.INTERACT'
12385       include 'COMMON.IOUNITS'
12386       include 'COMMON.CALC'
12387       include 'COMMON.CONTROL'
12388       include 'COMMON.SPLITELE'
12389       include 'COMMON.SBRIDGE'
12390       double precision tub_r,vectube(3),enetube(maxres*2)
12391       Etube=0.0d0
12392       do i=1,2*nres
12393         enetube(i)=0.0d0
12394       enddo
12395 C first we calculate the distance from tube center
12396 C first sugare-phosphate group for NARES this would be peptide group
12397 C for UNRES
12398       do i=1,nres
12399 C lets ommit dummy atoms for now
12400        if ((itype(i).eq.ntyp1).or.(itype(i+1).eq.ntyp1)) cycle
12401 C now calculate distance from center of tube and direction vectors
12402       vectube(1)=mod((c(1,i)+c(1,i+1))/2.0d0,boxxsize)
12403           if (vectube(1).lt.0) vectube(1)=vectube(1)+boxxsize
12404       vectube(2)=mod((c(2,i)+c(2,i+1))/2.0d0,boxxsize)
12405           if (vectube(2).lt.0) vectube(2)=vectube(2)+boxxsize
12406       vectube(1)=vectube(1)-tubecenter(1)
12407       vectube(2)=vectube(2)-tubecenter(2)
12408
12409 C      print *,"x",(c(1,i)+c(1,i+1))/2.0d0,tubecenter(1)
12410 C      print *,"y",(c(2,i)+c(2,i+1))/2.0d0,tubecenter(2)
12411
12412 C as the tube is infinity we do not calculate the Z-vector use of Z
12413 C as chosen axis
12414       vectube(3)=0.0d0
12415 C now calculte the distance
12416        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
12417 C now normalize vector
12418       vectube(1)=vectube(1)/tub_r
12419       vectube(2)=vectube(2)/tub_r
12420 C calculte rdiffrence between r and r0
12421       rdiff=tub_r-tubeR0
12422 C and its 6 power
12423       rdiff6=rdiff**6.0d0
12424 C for vectorization reasons we will sumup at the end to avoid depenence of previous
12425        enetube(i)=pep_aa_tube/rdiff6**2.0d0-pep_bb_tube/rdiff6
12426 C       write(iout,*) "TU13",i,rdiff6,enetube(i)
12427 C       print *,rdiff,rdiff6,pep_aa_tube
12428 C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
12429 C now we calculate gradient
12430        fac=(-12.0d0*pep_aa_tube/rdiff6+
12431      &       6.0d0*pep_bb_tube)/rdiff6/rdiff
12432 C       write(iout,'(a5,i4,f12.1,3f12.5)') "TU13",i,rdiff6,enetube(i),
12433 C     &rdiff,fac
12434
12435 C now direction of gg_tube vector
12436         do j=1,3
12437         gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac/2.0d0
12438         gg_tube(j,i)=gg_tube(j,i)+vectube(j)*fac/2.0d0
12439         enddo
12440         enddo
12441 C basically thats all code now we split for side-chains (REMEMBER to sum up at the END)
12442         do i=1,nres
12443 C Lets not jump over memory as we use many times iti
12444          iti=itype(i)
12445 C lets ommit dummy atoms for now
12446          if ((iti.eq.ntyp1)
12447 C in UNRES uncomment the line below as GLY has no side-chain...
12448 C      .or.(iti.eq.10)
12449      &   ) cycle
12450           vectube(1)=c(1,i+nres)
12451           vectube(1)=mod(vectube(1),boxxsize)
12452           if (vectube(1).lt.0) vectube(1)=vectube(1)+boxxsize
12453           vectube(2)=c(2,i+nres)
12454           vectube(2)=mod(vectube(2),boxxsize)
12455           if (vectube(2).lt.0) vectube(2)=vectube(2)+boxxsize
12456
12457       vectube(1)=vectube(1)-tubecenter(1)
12458       vectube(2)=vectube(2)-tubecenter(2)
12459
12460 C as the tube is infinity we do not calculate the Z-vector use of Z
12461 C as chosen axis
12462       vectube(3)=0.0d0
12463 C now calculte the distance
12464        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
12465 C now normalize vector
12466       vectube(1)=vectube(1)/tub_r
12467       vectube(2)=vectube(2)/tub_r
12468 C calculte rdiffrence between r and r0
12469       rdiff=tub_r-tubeR0
12470 C and its 6 power
12471       rdiff6=rdiff**6.0d0
12472 C for vectorization reasons we will sumup at the end to avoid depenence of previous
12473        sc_aa_tube=sc_aa_tube_par(iti)
12474        sc_bb_tube=sc_bb_tube_par(iti)
12475        enetube(i+nres)=sc_aa_tube/rdiff6**2.0d0-sc_bb_tube/rdiff6
12476 C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
12477 C now we calculate gradient
12478        fac=-12.0d0*sc_aa_tube/rdiff6**2.0d0/rdiff+
12479      &       6.0d0*sc_bb_tube/rdiff6/rdiff
12480 C now direction of gg_tube vector
12481          do j=1,3
12482           gg_tube_SC(j,i)=gg_tube_SC(j,i)+vectube(j)*fac
12483           gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac
12484          enddo
12485         enddo
12486         do i=1,2*nres
12487           Etube=Etube+enetube(i)
12488         enddo
12489 C        print *,"ETUBE", etube
12490         return
12491         end
12492 C TO DO 1) add to total energy
12493 C       2) add to gradient summation
12494 C       3) add reading parameters (AND of course oppening of PARAM file)
12495 C       4) add reading the center of tube
12496 C       5) add COMMONs
12497 C       6) add to zerograd
12498
12499 C-----------------------------------------------------------------------
12500 C-----------------------------------------------------------
12501 C This subroutine is to mimic the histone like structure but as well can be
12502 C utilizet to nanostructures (infinit) small modification has to be used to
12503 C make it finite (z gradient at the ends has to be changes as well as the x,y
12504 C gradient has to be modified at the ends
12505 C The energy function is Kihara potential
12506 C E=4esp*((sigma/(r-r0))^12 - (sigma/(r-r0))^6)
12507 C 4eps is depth of well sigma is r_minimum r is distance from center of tube
12508 C and r0 is the excluded size of nanotube (can be set to 0 if we want just a
12509 C simple Kihara potential
12510       subroutine calctube2(Etube)
12511        implicit real*8 (a-h,o-z)
12512       include 'DIMENSIONS'
12513       include 'COMMON.GEO'
12514       include 'COMMON.VAR'
12515       include 'COMMON.LOCAL'
12516       include 'COMMON.CHAIN'
12517       include 'COMMON.DERIV'
12518       include 'COMMON.NAMES'
12519       include 'COMMON.INTERACT'
12520       include 'COMMON.IOUNITS'
12521       include 'COMMON.CALC'
12522       include 'COMMON.CONTROL'
12523       include 'COMMON.SPLITELE'
12524       include 'COMMON.SBRIDGE'
12525       double precision tub_r,vectube(3),enetube(maxres*2)
12526       Etube=0.0d0
12527       do i=1,2*nres
12528         enetube(i)=0.0d0
12529       enddo
12530 C first we calculate the distance from tube center
12531 C first sugare-phosphate group for NARES this would be peptide group
12532 C for UNRES
12533       do i=1,nres
12534 C lets ommit dummy atoms for now
12535        if ((itype(i).eq.ntyp1).or.(itype(i+1).eq.ntyp1)) cycle
12536 C now calculate distance from center of tube and direction vectors
12537       vectube(1)=mod((c(1,i)+c(1,i+1))/2.0d0,boxxsize)
12538           if (vectube(1).lt.0) vectube(1)=vectube(1)+boxxsize
12539       vectube(2)=mod((c(2,i)+c(2,i+1))/2.0d0,boxxsize)
12540           if (vectube(2).lt.0) vectube(2)=vectube(2)+boxxsize
12541       vectube(1)=vectube(1)-tubecenter(1)
12542       vectube(2)=vectube(2)-tubecenter(2)
12543
12544 C      print *,"x",(c(1,i)+c(1,i+1))/2.0d0,tubecenter(1)
12545 C      print *,"y",(c(2,i)+c(2,i+1))/2.0d0,tubecenter(2)
12546
12547 C as the tube is infinity we do not calculate the Z-vector use of Z
12548 C as chosen axis
12549       vectube(3)=0.0d0
12550 C now calculte the distance
12551        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
12552 C now normalize vector
12553       vectube(1)=vectube(1)/tub_r
12554       vectube(2)=vectube(2)/tub_r
12555 C calculte rdiffrence between r and r0
12556       rdiff=tub_r-tubeR0
12557 C and its 6 power
12558       rdiff6=rdiff**6.0d0
12559 C for vectorization reasons we will sumup at the end to avoid depenence of previous
12560        enetube(i)=pep_aa_tube/rdiff6**2.0d0-pep_bb_tube/rdiff6
12561 C       write(iout,*) "TU13",i,rdiff6,enetube(i)
12562 C       print *,rdiff,rdiff6,pep_aa_tube
12563 C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
12564 C now we calculate gradient
12565        fac=(-12.0d0*pep_aa_tube/rdiff6+
12566      &       6.0d0*pep_bb_tube)/rdiff6/rdiff
12567 C       write(iout,'(a5,i4,f12.1,3f12.5)') "TU13",i,rdiff6,enetube(i),
12568 C     &rdiff,fac
12569
12570 C now direction of gg_tube vector
12571         do j=1,3
12572         gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac/2.0d0
12573         gg_tube(j,i)=gg_tube(j,i)+vectube(j)*fac/2.0d0
12574         enddo
12575         enddo
12576 C basically thats all code now we split for side-chains (REMEMBER to sum up at the END)
12577         do i=1,nres
12578 C Lets not jump over memory as we use many times iti
12579          iti=itype(i)
12580 C lets ommit dummy atoms for now
12581          if ((iti.eq.ntyp1)
12582 C in UNRES uncomment the line below as GLY has no side-chain...
12583      &      .or.(iti.eq.10)
12584      &   ) cycle
12585           vectube(1)=c(1,i+nres)
12586           vectube(1)=mod(vectube(1),boxxsize)
12587           if (vectube(1).lt.0) vectube(1)=vectube(1)+boxxsize
12588           vectube(2)=c(2,i+nres)
12589           vectube(2)=mod(vectube(2),boxxsize)
12590           if (vectube(2).lt.0) vectube(2)=vectube(2)+boxxsize
12591
12592       vectube(1)=vectube(1)-tubecenter(1)
12593       vectube(2)=vectube(2)-tubecenter(2)
12594 C THIS FRAGMENT MAKES TUBE FINITE
12595         positi=(mod(c(3,i+nres),boxzsize))
12596         if (positi.le.0) positi=positi+boxzsize
12597 C       print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop
12598 c for each residue check if it is in lipid or lipid water border area
12599 C       respos=mod(c(3,i+nres),boxzsize)
12600        print *,positi,bordtubebot,buftubebot,bordtubetop
12601        if ((positi.gt.bordtubebot)
12602      & .and.(positi.lt.bordtubetop)) then
12603 C the energy transfer exist
12604         if (positi.lt.buftubebot) then
12605          fracinbuf=1.0d0-
12606      &     ((positi-bordtubebot)/tubebufthick)
12607 C lipbufthick is thickenes of lipid buffore
12608          sstube=sscalelip(fracinbuf)
12609          ssgradtube=-sscagradlip(fracinbuf)/tubebufthick
12610          print *,ssgradtube, sstube,tubetranene(itype(i))
12611          enetube(i+nres)=enetube(i+nres)+sstube*tubetranene(itype(i))
12612          gg_tube_SC(3,i)=gg_tube_SC(3,i)
12613      &+ssgradtube*tubetranene(itype(i))
12614          gg_tube(3,i-1)= gg_tube(3,i-1)
12615      &+ssgradtube*tubetranene(itype(i))
12616 C         print *,"doing sccale for lower part"
12617         elseif (positi.gt.buftubetop) then
12618          fracinbuf=1.0d0-
12619      &((bordtubetop-positi)/tubebufthick)
12620          sstube=sscalelip(fracinbuf)
12621          ssgradtube=sscagradlip(fracinbuf)/tubebufthick
12622          enetube(i+nres)=enetube(i+nres)+sstube*tubetranene(itype(i))
12623 C         gg_tube_SC(3,i)=gg_tube_SC(3,i)
12624 C     &+ssgradtube*tubetranene(itype(i))
12625 C         gg_tube(3,i-1)= gg_tube(3,i-1)
12626 C     &+ssgradtube*tubetranene(itype(i))
12627 C          print *, "doing sscalefor top part",sslip,fracinbuf
12628         else
12629          sstube=1.0d0
12630          ssgradtube=0.0d0
12631          enetube(i+nres)=enetube(i+nres)+sstube*tubetranene(itype(i))
12632 C         print *,"I am in true lipid"
12633         endif
12634         else
12635 C          sstube=0.0d0
12636 C          ssgradtube=0.0d0
12637         cycle
12638         endif ! if in lipid or buffor
12639 CEND OF FINITE FRAGMENT
12640 C as the tube is infinity we do not calculate the Z-vector use of Z
12641 C as chosen axis
12642       vectube(3)=0.0d0
12643 C now calculte the distance
12644        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
12645 C now normalize vector
12646       vectube(1)=vectube(1)/tub_r
12647       vectube(2)=vectube(2)/tub_r
12648 C calculte rdiffrence between r and r0
12649       rdiff=tub_r-tubeR0
12650 C and its 6 power
12651       rdiff6=rdiff**6.0d0
12652 C for vectorization reasons we will sumup at the end to avoid depenence of previous
12653        sc_aa_tube=sc_aa_tube_par(iti)
12654        sc_bb_tube=sc_bb_tube_par(iti)
12655        enetube(i+nres)=(sc_aa_tube/rdiff6**2.0d0-sc_bb_tube/rdiff6)
12656      &                 *sstube+enetube(i+nres)
12657 C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
12658 C now we calculate gradient
12659        fac=(-12.0d0*sc_aa_tube/rdiff6**2.0d0/rdiff+
12660      &       6.0d0*sc_bb_tube/rdiff6/rdiff)*sstube
12661 C now direction of gg_tube vector
12662          do j=1,3
12663           gg_tube_SC(j,i)=gg_tube_SC(j,i)+vectube(j)*fac
12664           gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac
12665          enddo
12666          gg_tube_SC(3,i)=gg_tube_SC(3,i)
12667      &+ssgradtube*enetube(i+nres)/sstube
12668          gg_tube(3,i-1)= gg_tube(3,i-1)
12669      &+ssgradtube*enetube(i+nres)/sstube
12670
12671         enddo
12672         do i=1,2*nres
12673           Etube=Etube+enetube(i)
12674         enddo
12675 C        print *,"ETUBE", etube
12676         return
12677         end
12678 C TO DO 1) add to total energy
12679 C       2) add to gradient summation
12680 C       3) add reading parameters (AND of course oppening of PARAM file)
12681 C       4) add reading the center of tube
12682 C       5) add COMMONs
12683 C       6) add to zerograd
12684 c----------------------------------------------------------------------------
12685       subroutine e_saxs(Esaxs_constr)
12686       implicit none
12687       include 'DIMENSIONS'
12688 #ifdef MPI
12689       include "mpif.h"
12690       include "COMMON.SETUP"
12691       integer IERR
12692 #endif
12693       include 'COMMON.SBRIDGE'
12694       include 'COMMON.CHAIN'
12695       include 'COMMON.GEO'
12696       include 'COMMON.DERIV'
12697       include 'COMMON.LOCAL'
12698       include 'COMMON.INTERACT'
12699       include 'COMMON.VAR'
12700       include 'COMMON.IOUNITS'
12701 c      include 'COMMON.MD'
12702 #ifdef LANG0
12703 #ifdef FIVEDIAG
12704       include 'COMMON.LANGEVIN.lang0.5diag'
12705 #else
12706       include 'COMMON.LANGEVIN.lang0'
12707 #endif
12708 #else
12709       include 'COMMON.LANGEVIN'
12710 #endif
12711       include 'COMMON.CONTROL'
12712       include 'COMMON.SAXS'
12713       include 'COMMON.NAMES'
12714       include 'COMMON.TIME1'
12715       include 'COMMON.FFIELD'
12716 c
12717       double precision Esaxs_constr
12718       integer i,iint,j,k,l
12719       double precision PgradC(maxSAXS,3,maxres),
12720      &  PgradX(maxSAXS,3,maxres),Pcalc(maxSAXS)
12721 #ifdef MPI
12722       double precision PgradC_(maxSAXS,3,maxres),
12723      &  PgradX_(maxSAXS,3,maxres),Pcalc_(maxSAXS)
12724 #endif
12725       double precision dk,dijCACA,dijCASC,dijSCCA,dijSCSC,
12726      & sigma2CACA,sigma2CASC,sigma2SCCA,sigma2SCSC,expCACA,expCASC,
12727      & expSCCA,expSCSC,CASCgrad,SCCAgrad,SCSCgrad,aux,auxC,auxC1,
12728      & auxX,auxX1,CACAgrad,Cnorm,sigmaCACA,threesig
12729       double precision sss2,ssgrad2,rrr,sscalgrad2,sscale2
12730       double precision dist,mygauss,mygaussder
12731       external dist
12732       integer llicz,lllicz
12733       double precision time01
12734 c  SAXS restraint penalty function
12735 #ifdef DEBUG
12736       write(iout,*) "------- SAXS penalty function start -------"
12737       write (iout,*) "nsaxs",nsaxs
12738       write (iout,*) "Esaxs: iatsc_s",iatsc_s," iatsc_e",iatsc_e
12739       write (iout,*) "Psaxs"
12740       do i=1,nsaxs
12741         write (iout,'(i5,e15.5)') i, Psaxs(i)
12742       enddo
12743 #endif
12744 #ifdef TIMING
12745       time01=MPI_Wtime()
12746 #endif
12747       Esaxs_constr = 0.0d0
12748       do k=1,nsaxs
12749         Pcalc(k)=0.0d0
12750         do j=1,nres
12751           do l=1,3
12752             PgradC(k,l,j)=0.0d0
12753             PgradX(k,l,j)=0.0d0
12754           enddo
12755         enddo
12756       enddo
12757 c      lllicz=0
12758       do i=iatsc_s,iatsc_e
12759        if (itype(i).eq.ntyp1) cycle
12760        do iint=1,nint_gr(i)
12761          do j=istart(i,iint),iend(i,iint)
12762            if (itype(j).eq.ntyp1) cycle
12763 #ifdef ALLSAXS
12764            dijCACA=dist(i,j)
12765            dijCASC=dist(i,j+nres)
12766            dijSCCA=dist(i+nres,j)
12767            dijSCSC=dist(i+nres,j+nres)
12768            sigma2CACA=2.0d0/(pstok**2)
12769            sigma2CASC=4.0d0/(pstok**2+restok(itype(j))**2)
12770            sigma2SCCA=4.0d0/(pstok**2+restok(itype(i))**2)
12771            sigma2SCSC=4.0d0/(restok(itype(j))**2+restok(itype(i))**2)
12772            do k=1,nsaxs
12773              dk = distsaxs(k)
12774              expCACA = dexp(-0.5d0*sigma2CACA*(dijCACA-dk)**2)
12775              if (itype(j).ne.10) then
12776              expCASC = dexp(-0.5d0*sigma2CASC*(dijCASC-dk)**2)
12777              else
12778              endif
12779              expCASC = 0.0d0
12780              if (itype(i).ne.10) then
12781              expSCCA = dexp(-0.5d0*sigma2SCCA*(dijSCCA-dk)**2)
12782              else
12783              expSCCA = 0.0d0
12784              endif
12785              if (itype(i).ne.10 .and. itype(j).ne.10) then
12786              expSCSC = dexp(-0.5d0*sigma2SCSC*(dijSCSC-dk)**2)
12787              else
12788              expSCSC = 0.0d0
12789              endif
12790              Pcalc(k) = Pcalc(k)+expCACA+expCASC+expSCCA+expSCSC
12791 #ifdef DEBUG
12792              write(iout,*) "i j k Pcalc",i,j,Pcalc(k)
12793 #endif
12794              CACAgrad = sigma2CACA*(dijCACA-dk)*expCACA
12795              CASCgrad = sigma2CASC*(dijCASC-dk)*expCASC
12796              SCCAgrad = sigma2SCCA*(dijSCCA-dk)*expSCCA
12797              SCSCgrad = sigma2SCSC*(dijSCSC-dk)*expSCSC
12798              do l=1,3
12799 c CA CA
12800                aux = CACAgrad*(C(l,j)-C(l,i))/dijCACA
12801                PgradC(k,l,i) = PgradC(k,l,i)-aux
12802                PgradC(k,l,j) = PgradC(k,l,j)+aux
12803 c CA SC
12804                if (itype(j).ne.10) then
12805                aux = CASCgrad*(C(l,j+nres)-C(l,i))/dijCASC
12806                PgradC(k,l,i) = PgradC(k,l,i)-aux
12807                PgradC(k,l,j) = PgradC(k,l,j)+aux
12808                PgradX(k,l,j) = PgradX(k,l,j)+aux
12809                endif
12810 c SC CA
12811                if (itype(i).ne.10) then
12812                aux = SCCAgrad*(C(l,j)-C(l,i+nres))/dijSCCA
12813                PgradX(k,l,i) = PgradX(k,l,i)-aux
12814                PgradC(k,l,i) = PgradC(k,l,i)-aux
12815                PgradC(k,l,j) = PgradC(k,l,j)+aux
12816                endif
12817 c SC SC
12818                if (itype(i).ne.10 .and. itype(j).ne.10) then
12819                aux = SCSCgrad*(C(l,j+nres)-C(l,i+nres))/dijSCSC
12820                PgradC(k,l,i) = PgradC(k,l,i)-aux
12821                PgradC(k,l,j) = PgradC(k,l,j)+aux
12822                PgradX(k,l,i) = PgradX(k,l,i)-aux
12823                PgradX(k,l,j) = PgradX(k,l,j)+aux
12824                endif
12825              enddo ! l
12826            enddo ! k
12827 #else
12828            dijCACA=dist(i,j)
12829            sigma2CACA=scal_rad**2*0.25d0/
12830      &        (restok(itype(j))**2+restok(itype(i))**2)
12831 c           write (iout,*) "scal_rad",scal_rad," restok",restok(itype(j))
12832 c     &       ,restok(itype(i)),"sigma",1.0d0/dsqrt(sigma2CACA)
12833 #ifdef MYGAUSS
12834            sigmaCACA=dsqrt(sigma2CACA)
12835            threesig=3.0d0/sigmaCACA
12836 c           llicz=0
12837            do k=1,nsaxs
12838              dk = distsaxs(k)
12839              if (dabs(dijCACA-dk).ge.threesig) cycle
12840 c             llicz=llicz+1
12841 c             lllicz=lllicz+1
12842              aux = sigmaCACA*(dijCACA-dk)
12843              expCACA = mygauss(aux)
12844 c             if (expcaca.eq.0.0d0) cycle
12845              Pcalc(k) = Pcalc(k)+expCACA
12846              CACAgrad = -sigmaCACA*mygaussder(aux)
12847 c             write (iout,*) "i,j,k,aux",i,j,k,CACAgrad
12848              do l=1,3
12849                aux = CACAgrad*(C(l,j)-C(l,i))/dijCACA
12850                PgradC(k,l,i) = PgradC(k,l,i)-aux
12851                PgradC(k,l,j) = PgradC(k,l,j)+aux
12852              enddo ! l
12853            enddo ! k
12854 c           write (iout,*) "i",i," j",j," llicz",llicz
12855 #else
12856            IF (saxs_cutoff.eq.0) THEN
12857            do k=1,nsaxs
12858              dk = distsaxs(k)
12859              expCACA = dexp(-0.5d0*sigma2CACA*(dijCACA-dk)**2)
12860              Pcalc(k) = Pcalc(k)+expCACA
12861              CACAgrad = sigma2CACA*(dijCACA-dk)*expCACA
12862              do l=1,3
12863                aux = CACAgrad*(C(l,j)-C(l,i))/dijCACA
12864                PgradC(k,l,i) = PgradC(k,l,i)-aux
12865                PgradC(k,l,j) = PgradC(k,l,j)+aux
12866              enddo ! l
12867            enddo ! k
12868            ELSE
12869            rrr = saxs_cutoff*2.0d0/dsqrt(sigma2CACA)
12870            do k=1,nsaxs
12871              dk = distsaxs(k)
12872 c             write (2,*) "ijk",i,j,k
12873              sss2 = sscale2(dijCACA,rrr,dk,0.3d0)
12874              if (sss2.eq.0.0d0) cycle
12875              ssgrad2 = sscalgrad2(dijCACA,rrr,dk,0.3d0)
12876              if (energy_dec) write(iout,'(a4,3i5,8f10.4)')
12877      &          'saxs',i,j,k,dijCACA,restok(itype(i)),restok(itype(j)),
12878      &          1.0d0/dsqrt(sigma2CACA),rrr,dk,
12879      &           sss2,ssgrad2
12880              expCACA = dexp(-0.5d0*sigma2CACA*(dijCACA-dk)**2)*sss2
12881              Pcalc(k) = Pcalc(k)+expCACA
12882 #ifdef DEBUG
12883              write(iout,*) "i j k Pcalc",i,j,Pcalc(k)
12884 #endif
12885              CACAgrad = -sigma2CACA*(dijCACA-dk)*expCACA+
12886      &             ssgrad2*expCACA/sss2
12887              do l=1,3
12888 c CA CA
12889                aux = CACAgrad*(C(l,j)-C(l,i))/dijCACA
12890                PgradC(k,l,i) = PgradC(k,l,i)+aux
12891                PgradC(k,l,j) = PgradC(k,l,j)-aux
12892              enddo ! l
12893            enddo ! k
12894            ENDIF
12895 #endif
12896 #endif
12897          enddo ! j
12898        enddo ! iint
12899       enddo ! i
12900 c#ifdef TIMING
12901 c      time_SAXS=time_SAXS+MPI_Wtime()-time01
12902 c#endif
12903 c      write (iout,*) "lllicz",lllicz
12904 c#ifdef TIMING
12905 c      time01=MPI_Wtime()
12906 c#endif
12907 #ifdef MPI
12908       if (nfgtasks.gt.1) then
12909        call MPI_AllReduce(Pcalc(1),Pcalc_(1),nsaxs,MPI_DOUBLE_PRECISION,
12910      &    MPI_SUM,FG_COMM,IERR)
12911 c        if (fg_rank.eq.king) then
12912           do k=1,nsaxs
12913             Pcalc(k) = Pcalc_(k)
12914           enddo
12915 c        endif
12916 c        call MPI_AllReduce(PgradC(k,1,1),PgradC_(k,1,1),3*maxsaxs*nres,
12917 c     &    MPI_DOUBLE_PRECISION,MPI_SUM,FG_COMM,IERR)
12918 c        if (fg_rank.eq.king) then
12919 c          do i=1,nres
12920 c            do l=1,3
12921 c              do k=1,nsaxs
12922 c                PgradC(k,l,i) = PgradC_(k,l,i)
12923 c              enddo
12924 c            enddo
12925 c          enddo
12926 c        endif
12927 #ifdef ALLSAXS
12928 c        call MPI_AllReduce(PgradX(k,1,1),PgradX_(k,1,1),3*maxsaxs*nres,
12929 c     &    MPI_DOUBLE_PRECISION,MPI_SUM,FG_COMM,IERR)
12930 c        if (fg_rank.eq.king) then
12931 c          do i=1,nres
12932 c            do l=1,3
12933 c              do k=1,nsaxs
12934 c                PgradX(k,l,i) = PgradX_(k,l,i)
12935 c              enddo
12936 c            enddo
12937 c          enddo
12938 c        endif
12939 #endif
12940       endif
12941 #endif
12942       Cnorm = 0.0d0
12943       do k=1,nsaxs
12944         Cnorm = Cnorm + Pcalc(k)
12945       enddo
12946 #ifdef MPI
12947       if (fg_rank.eq.king) then
12948 #endif
12949       Esaxs_constr = dlog(Cnorm)-wsaxs0
12950       do k=1,nsaxs
12951         if (Pcalc(k).gt.0.0d0)
12952      &  Esaxs_constr = Esaxs_constr - Psaxs(k)*dlog(Pcalc(k))
12953 #ifdef DEBUG
12954         write (iout,*) "k",k," Esaxs_constr",Esaxs_constr
12955 #endif
12956       enddo
12957 #ifdef DEBUG
12958       write (iout,*) "Cnorm",Cnorm," Esaxs_constr",Esaxs_constr
12959 #endif
12960 #ifdef MPI
12961       endif
12962 #endif
12963       gsaxsC=0.0d0
12964       gsaxsX=0.0d0
12965       do i=nnt,nct
12966         do l=1,3
12967           auxC=0.0d0
12968           auxC1=0.0d0
12969           auxX=0.0d0
12970           auxX1=0.d0
12971           do k=1,nsaxs
12972             if (Pcalc(k).gt.0)
12973      &      auxC  = auxC +Psaxs(k)*PgradC(k,l,i)/Pcalc(k)
12974             auxC1 = auxC1+PgradC(k,l,i)
12975 #ifdef ALLSAXS
12976             auxX  = auxX +Psaxs(k)*PgradX(k,l,i)/Pcalc(k)
12977             auxX1 = auxX1+PgradX(k,l,i)
12978 #endif
12979           enddo
12980           gsaxsC(l,i) = auxC - auxC1/Cnorm
12981 #ifdef ALLSAXS
12982           gsaxsX(l,i) = auxX - auxX1/Cnorm
12983 #endif
12984 c          write (iout,*) "l i",l,i," gradC",wsaxs*(auxC - auxC1/Cnorm),
12985 c     *     " gradX",wsaxs*(auxX - auxX1/Cnorm)
12986 c          write (iout,*) "l i",l,i," gradC",wsaxs*gsaxsC(l,i),
12987 c     *     " gradX",wsaxs*gsaxsX(l,i)
12988         enddo
12989       enddo
12990 #ifdef TIMING
12991       time_SAXS=time_SAXS+MPI_Wtime()-time01
12992 #endif
12993 #ifdef DEBUG
12994       write (iout,*) "gsaxsc"
12995       do i=nnt,nct
12996         write (iout,'(i5,3e15.5)') i,(gsaxsc(j,i),j=1,3)
12997       enddo
12998 #endif
12999 #ifdef MPI
13000 c      endif
13001 #endif
13002       return
13003       end
13004 c----------------------------------------------------------------------------
13005       subroutine e_saxsC(Esaxs_constr)
13006       implicit none
13007       include 'DIMENSIONS'
13008 #ifdef MPI
13009       include "mpif.h"
13010       include "COMMON.SETUP"
13011       integer IERR
13012 #endif
13013       include 'COMMON.SBRIDGE'
13014       include 'COMMON.CHAIN'
13015       include 'COMMON.GEO'
13016       include 'COMMON.DERIV'
13017       include 'COMMON.LOCAL'
13018       include 'COMMON.INTERACT'
13019       include 'COMMON.VAR'
13020       include 'COMMON.IOUNITS'
13021 c      include 'COMMON.MD'
13022 #ifdef LANG0
13023 #ifdef FIVEDIAG
13024       include 'COMMON.LANGEVIN.lang0.5diag'
13025 #else
13026       include 'COMMON.LANGEVIN.lang0'
13027 #endif
13028 #else
13029       include 'COMMON.LANGEVIN'
13030 #endif
13031       include 'COMMON.CONTROL'
13032       include 'COMMON.SAXS'
13033       include 'COMMON.NAMES'
13034       include 'COMMON.TIME1'
13035       include 'COMMON.FFIELD'
13036 c
13037       double precision Esaxs_constr
13038       integer i,iint,j,k,l
13039       double precision PgradC(3,maxres),PgradX(3,maxres),Pcalc,logPtot
13040 #ifdef MPI
13041       double precision gsaxsc_(3,maxres),gsaxsx_(3,maxres),logPtot_
13042 #endif
13043       double precision dk,dijCASPH,dijSCSPH,
13044      & sigma2CA,sigma2SC,expCASPH,expSCSPH,
13045      & CASPHgrad,SCSPHgrad,aux,auxC,auxC1,
13046      & auxX,auxX1,Cnorm
13047 c  SAXS restraint penalty function
13048 #ifdef DEBUG
13049       write(iout,*) "------- SAXS penalty function start -------"
13050       write (iout,*) "nsaxs",nsaxs
13051
13052       do i=nnt,nct
13053         print *,MyRank,"C",i,(C(j,i),j=1,3)
13054       enddo
13055       do i=nnt,nct
13056         print *,MyRank,"CSaxs",i,(Csaxs(j,i),j=1,3)
13057       enddo
13058 #endif
13059       Esaxs_constr = 0.0d0
13060       logPtot=0.0d0
13061       do j=isaxs_start,isaxs_end
13062         Pcalc=0.0d0
13063         do i=1,nres
13064           do l=1,3
13065             PgradC(l,i)=0.0d0
13066             PgradX(l,i)=0.0d0
13067           enddo
13068         enddo
13069         do i=nnt,nct
13070           if (itype(i).eq.ntyp1) cycle
13071           dijCASPH=0.0d0
13072           dijSCSPH=0.0d0
13073           do l=1,3
13074             dijCASPH=dijCASPH+(C(l,i)-Csaxs(l,j))**2
13075           enddo
13076           if (itype(i).ne.10) then
13077           do l=1,3
13078             dijSCSPH=dijSCSPH+(C(l,i+nres)-Csaxs(l,j))**2
13079           enddo
13080           endif
13081           sigma2CA=2.0d0/pstok**2
13082           sigma2SC=4.0d0/restok(itype(i))**2
13083           expCASPH = dexp(-0.5d0*sigma2CA*dijCASPH)
13084           expSCSPH = dexp(-0.5d0*sigma2SC*dijSCSPH)
13085           Pcalc = Pcalc+expCASPH+expSCSPH
13086 #ifdef DEBUG
13087           write(*,*) "processor i j Pcalc",
13088      &       MyRank,i,j,dijCASPH,dijSCSPH, Pcalc
13089 #endif
13090           CASPHgrad = sigma2CA*expCASPH
13091           SCSPHgrad = sigma2SC*expSCSPH
13092           do l=1,3
13093             aux = (C(l,i+nres)-Csaxs(l,j))*SCSPHgrad
13094             PgradX(l,i) = PgradX(l,i) + aux
13095             PgradC(l,i) = PgradC(l,i)+(C(l,i)-Csaxs(l,j))*CASPHgrad+aux
13096           enddo ! l
13097         enddo ! i
13098         do i=nnt,nct
13099           do l=1,3
13100             gsaxsc(l,i)=gsaxsc(l,i)+PgradC(l,i)/Pcalc
13101             gsaxsx(l,i)=gsaxsx(l,i)+PgradX(l,i)/Pcalc
13102           enddo
13103         enddo
13104         logPtot = logPtot - dlog(Pcalc)
13105 c        print *,"me",me,MyRank," j",j," logPcalc",-dlog(Pcalc),
13106 c     &    " logPtot",logPtot
13107       enddo ! j
13108 #ifdef MPI
13109       if (nfgtasks.gt.1) then
13110 c        write (iout,*) "logPtot before reduction",logPtot
13111         call MPI_Reduce(logPtot,logPtot_,1,MPI_DOUBLE_PRECISION,
13112      &    MPI_SUM,king,FG_COMM,IERR)
13113         logPtot = logPtot_
13114 c        write (iout,*) "logPtot after reduction",logPtot
13115         call MPI_Reduce(gsaxsC(1,1),gsaxsC_(1,1),3*nres,
13116      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
13117         if (fg_rank.eq.king) then
13118           do i=1,nres
13119             do l=1,3
13120               gsaxsC(l,i) = gsaxsC_(l,i)
13121             enddo
13122           enddo
13123         endif
13124         call MPI_Reduce(gsaxsX(1,1),gsaxsX_(1,1),3*nres,
13125      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
13126         if (fg_rank.eq.king) then
13127           do i=1,nres
13128             do l=1,3
13129               gsaxsX(l,i) = gsaxsX_(l,i)
13130             enddo
13131           enddo
13132         endif
13133       endif
13134 #endif
13135       Esaxs_constr = logPtot
13136       return
13137       end
13138 c----------------------------------------------------------------------------
13139       double precision function sscale2(r,r_cut,r0,rlamb)
13140       implicit none
13141       double precision r,gamm,r_cut,r0,rlamb,rr
13142       rr = dabs(r-r0)
13143 c      write (2,*) "r",r," r_cut",r_cut," r0",r0," rlamb",rlamb
13144 c      write (2,*) "rr",rr
13145       if(rr.lt.r_cut-rlamb) then
13146         sscale2=1.0d0
13147       else if(rr.le.r_cut.and.rr.ge.r_cut-rlamb) then
13148         gamm=(rr-(r_cut-rlamb))/rlamb
13149         sscale2=1.0d0+gamm*gamm*(2*gamm-3.0d0)
13150       else
13151         sscale2=0d0
13152       endif
13153       return
13154       end
13155 C-----------------------------------------------------------------------
13156       double precision function sscalgrad2(r,r_cut,r0,rlamb)
13157       implicit none
13158       double precision r,gamm,r_cut,r0,rlamb,rr
13159       rr = dabs(r-r0)
13160       if(rr.lt.r_cut-rlamb) then
13161         sscalgrad2=0.0d0
13162       else if(rr.le.r_cut.and.rr.ge.r_cut-rlamb) then
13163         gamm=(rr-(r_cut-rlamb))/rlamb
13164         if (r.ge.r0) then
13165           sscalgrad2=gamm*(6*gamm-6.0d0)/rlamb
13166         else
13167           sscalgrad2=-gamm*(6*gamm-6.0d0)/rlamb
13168         endif
13169       else
13170         sscalgrad2=0.0d0
13171       endif
13172       return
13173       end
13174 c------------------------------------------------------------------------
13175       double precision function boxshift(x,boxsize)
13176       implicit none
13177       double precision x,boxsize
13178       double precision xtemp
13179       xtemp=dmod(x,boxsize)
13180       if (dabs(xtemp-boxsize).lt.dabs(xtemp)) then
13181         boxshift=xtemp-boxsize
13182       else if (dabs(xtemp+boxsize).lt.dabs(xtemp)) then
13183         boxshift=xtemp+boxsize
13184       else
13185         boxshift=xtemp
13186       endif
13187       return
13188       end
13189 c--------------------------------------------------------------------------
13190       subroutine closest_img(xi,yi,zi,xj,yj,zj)
13191       include 'DIMENSIONS'
13192       include 'COMMON.CHAIN'
13193       integer xshift,yshift,zshift,subchap
13194       double precision dist_init,xj_safe,yj_safe,zj_safe,
13195      & xj_temp,yj_temp,zj_temp,dist_temp
13196       xj_safe=xj
13197       yj_safe=yj
13198       zj_safe=zj
13199       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
13200       subchap=0
13201       do xshift=-1,1
13202         do yshift=-1,1
13203           do zshift=-1,1
13204             xj=xj_safe+xshift*boxxsize
13205             yj=yj_safe+yshift*boxysize
13206             zj=zj_safe+zshift*boxzsize
13207             dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
13208             if(dist_temp.lt.dist_init) then
13209               dist_init=dist_temp
13210               xj_temp=xj
13211               yj_temp=yj
13212               zj_temp=zj
13213               subchap=1
13214             endif
13215           enddo
13216         enddo
13217       enddo
13218       if (subchap.eq.1) then
13219         xj=xj_temp-xi
13220         yj=yj_temp-yi
13221         zj=zj_temp-zi
13222       else
13223         xj=xj_safe-xi
13224         yj=yj_safe-yi
13225         zj=zj_safe-zi
13226       endif
13227       return
13228       end
13229 c--------------------------------------------------------------------------
13230       subroutine to_box(xi,yi,zi)
13231       implicit none
13232       include 'DIMENSIONS'
13233       include 'COMMON.CHAIN'
13234       double precision xi,yi,zi
13235       xi=dmod(xi,boxxsize)
13236       if (xi.lt.0.0d0) xi=xi+boxxsize
13237       yi=dmod(yi,boxysize)
13238       if (yi.lt.0.0d0) yi=yi+boxysize
13239       zi=dmod(zi,boxzsize)
13240       if (zi.lt.0.0d0) zi=zi+boxzsize
13241       return
13242       end
13243 c--------------------------------------------------------------------------
13244       subroutine lipid_layer(xi,yi,zi,sslipi,ssgradlipi)
13245       implicit none
13246       include 'DIMENSIONS'
13247       include 'COMMON.CHAIN'
13248       double precision xi,yi,zi,sslipi,ssgradlipi
13249       double precision fracinbuf
13250       double precision sscalelip,sscagradlip
13251
13252       if ((zi.gt.bordlipbot).and.(zi.lt.bordliptop)) then
13253 C the energy transfer exist
13254         if (zi.lt.buflipbot) then
13255 C what fraction I am in
13256           fracinbuf=1.0d0-((zi-bordlipbot)/lipbufthick)
13257 C lipbufthick is thickenes of lipid buffore
13258           sslipi=sscalelip(fracinbuf)
13259           ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
13260         elseif (zi.gt.bufliptop) then
13261           fracinbuf=1.0d0-((bordliptop-zi)/lipbufthick)
13262           sslipi=sscalelip(fracinbuf)
13263           ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
13264         else
13265           sslipi=1.0d0
13266           ssgradlipi=0.0
13267         endif
13268       else
13269         sslipi=0.0d0
13270         ssgradlipi=0.0
13271       endif
13272       return
13273       end