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         call make_SCSC_inter_list
 122         call make_pp_inter_list
 123         call make_pp_vdw_inter_list
 124       endif
 125 c      print *,'Processor',myrank,' calling etotal ipot=',ipot
 126 c      print *,'Processor',myrank,' nnt=',nnt,' nct=',nct
 127 #else
 128 c      if (modecalc.eq.12.or.modecalc.eq.14) then
 129 c        call int_from_cart1(.false.)
 130 c      endif
 131 #endif
 132 #ifdef TIMING
 133       time00=MPI_Wtime()
 134 #endif
 135
 136 #ifndef DFA
 137       edfadis=0.0d0
 138       edfator=0.0d0
 139       edfanei=0.0d0
 140       edfabet=0.0d0
 141 #endif
 142 C
 143 C Compute the side-chain and electrostatic interaction energy
 144 C
 145 C      print *,ipot
 146       goto (101,102,103,104,105,106) ipot
 147 C Lennard-Jones potential.
 148   101 call elj(evdw)
 149 cd    print '(a)','Exit ELJ'
 150       goto 107
 151 C Lennard-Jones-Kihara potential (shifted).
 152   102 call eljk(evdw)
 153       goto 107
 154 C Berne-Pechukas potential (dilated LJ, angular dependence).
 155   103 call ebp(evdw)
 156       goto 107
 157 C Gay-Berne potential (shifted LJ, angular dependence).
 158   104 call egb(evdw)
 159 C      print *,"bylem w egb"
 160       goto 107
 161 C Gay-Berne-Vorobjev potential (shifted LJ, angular dependence).
 162   105 call egbv(evdw)
 163       goto 107
 164 C Soft-sphere potential
 165   106 call e_softsphere(evdw)
 166 C
 167 C Calculate electrostatic (H-bonding) energy of the main chain.
 168 C
 169   107 continue
 170 #ifdef DFA
 171 C     BARTEK for dfa test!
 172       if (wdfa_dist.gt.0) then
 173         call edfad(edfadis)
 174       else
 175         edfadis=0
 176       endif
 177 c      print*, 'edfad is finished!', edfadis
 178       if (wdfa_tor.gt.0) then
 179         call edfat(edfator)
 180       else
 181         edfator=0
 182       endif
 183 c      print*, 'edfat is finished!', edfator
 184       if (wdfa_nei.gt.0) then
 185         call edfan(edfanei)
 186       else
 187         edfanei=0
 188       endif
 189 c      print*, 'edfan is finished!', edfanei
 190       if (wdfa_beta.gt.0) then
 191         call edfab(edfabet)
 192       else
 193         edfabet=0
 194       endif
 195 #endif
 196 cmc
 197 cmc Sep-06: egb takes care of dynamic ss bonds too
 198 cmc
 199 c      if (dyn_ss) call dyn_set_nss
 200
 201 c      print *,"Processor",myrank," computed USCSC"
 202 #ifdef TIMING
 203       time01=MPI_Wtime()
 204 #endif
 205       call vec_and_deriv
 206 #ifdef TIMING
 207       time_vec=time_vec+MPI_Wtime()-time01
 208 #endif
 209 C Introduction of shielding effect first for each peptide group
 210 C the shielding factor is set this factor is describing how each
 211 C peptide group is shielded by side-chains
 212 C the matrix - shield_fac(i) the i index describe the ith between i and i+1
 213 C      write (iout,*) "shield_mode",shield_mode
 214       if (shield_mode.eq.1) then
 215        call set_shield_fac
 216       else if  (shield_mode.eq.2) then
 217        call set_shield_fac2
 218       endif
 219 c      print *,"Processor",myrank," left VEC_AND_DERIV"
 220       if (ipot.lt.6) then
 221 #ifdef SPLITELE
 222          if (welec.gt.0d0.or.wvdwpp.gt.0d0.or.wel_loc.gt.0d0.or.
 223      &       wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0
 224      &       .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0
 225      &       .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
 226 #else
 227          if (welec.gt.0d0.or.wel_loc.gt.0d0.or.
 228      &       wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0
 229      &       .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0
 230      &       .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
 231 #endif
 232             call eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
 233          else
 234             ees=0.0d0
 235             evdw1=0.0d0
 236             eel_loc=0.0d0
 237             eello_turn3=0.0d0
 238             eello_turn4=0.0d0
 239          endif
 240       else
 241         write (iout,*) "Soft-spheer ELEC potential"
 242 c        call eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,
 243 c     &   eello_turn4)
 244       endif
 245 c#ifdef TIMING
 246 c      time_enecalc=time_enecalc+MPI_Wtime()-time00
 247 c#endif
 248 c      print *,"Processor",myrank," computed UELEC"
 249 C
 250 C Calculate excluded-volume interaction energy between peptide groups
 251 C and side chains.
 252 C
 253       if (ipot.lt.6) then
 254        if(wscp.gt.0d0) then
 255         call escp(evdw2,evdw2_14)
 256        else
 257         evdw2=0
 258         evdw2_14=0
 259        endif
 260       else
 261 c        write (iout,*) "Soft-sphere SCP potential"
 262         call escp_soft_sphere(evdw2,evdw2_14)
 263       endif
 264 c
 265 c Calculate the bond-stretching energy
 266 c
 267       call ebond(estr)
 268 C
 269 C Calculate the disulfide-bridge and other energy and the contributions
 270 C from other distance constraints.
 271 cd      write (iout,*) 'Calling EHPB'
 272       call edis(ehpb)
 273 cd    print *,'EHPB exitted succesfully.'
 274 C
 275 C Calculate the virtual-bond-angle energy.
 276 C
 277       if (wang.gt.0d0) then
 278        if (tor_mode.eq.0) then
 279          call ebend(ebe)
 280        else
 281 C ebend kcc is Kubo cumulant clustered rigorous attemp to derive the
 282 C energy function
 283          call ebend_kcc(ebe)
 284        endif
 285       else
 286         ebe=0.0d0
 287       endif
 288       ethetacnstr=0.0d0
 289       if (with_theta_constr) call etheta_constr(ethetacnstr)
 290 c      print *,"Processor",myrank," computed UB"
 291 C
 292 C Calculate the SC local energy.
 293 C
 294 C      print *,"TU DOCHODZE?"
 295       call esc(escloc)
 296 c      print *,"Processor",myrank," computed USC"
 297 C
 298 C Calculate the virtual-bond torsional energy.
 299 C
 300 cd    print *,'nterm=',nterm
 301 C      print *,"tor",tor_mode
 302       if (wtor.gt.0.0d0) then
 303          if (tor_mode.eq.0) then
 304            call etor(etors)
 305          else
 306 C etor kcc is Kubo cumulant clustered rigorous attemp to derive the
 307 C energy function
 308            call etor_kcc(etors)
 309          endif
 310       else
 311         etors=0.0d0
 312       endif
 313       edihcnstr=0.0d0
 314       if (ndih_constr.gt.0) call etor_constr(edihcnstr)
 315 c      print *,"Processor",myrank," computed Utor"
 316       if (constr_homology.ge.1) then
 317         call e_modeller(ehomology_constr)
 318 c        print *,'iset=',iset,'me=',me,ehomology_constr,
 319 c     &  'Processor',fg_rank,' CG group',kolor,
 320 c     &  ' absolute rank',MyRank
 321       else
 322         ehomology_constr=0.0d0
 323       endif
 324 C
 325 C 6/23/01 Calculate double-torsional energy
 326 C
 327       if ((wtor_d.gt.0.0d0).and.(tor_mode.eq.0)) then
 328         call etor_d(etors_d)
 329       else
 330         etors_d=0
 331       endif
 332 c      print *,"Processor",myrank," computed Utord"
 333 C
 334 C 21/5/07 Calculate local sicdechain correlation energy
 335 C
 336       if (wsccor.gt.0.0d0) then
 337         call eback_sc_corr(esccor)
 338       else
 339         esccor=0.0d0
 340       endif
 341 #ifdef FOURBODY
 342 C      print *,"PRZED MULIt"
 343 c      print *,"Processor",myrank," computed Usccorr"
 344 C
 345 C 12/1/95 Multi-body terms
 346 C
 347       n_corr=0
 348       n_corr1=0
 349       if ((wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0
 350      &    .or. wturn6.gt.0.0d0) .and. ipot.lt.6) then
 351          call multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1)
 352 c         write(2,*)'MULTIBODY_EELLO n_corr=',n_corr,' n_corr1=',n_corr1,
 353 c     &" ecorr",ecorr," ecorr5",ecorr5," ecorr6",ecorr6," eturn6",eturn6
 354 c        call flush(iout)
 355       else
 356          ecorr=0.0d0
 357          ecorr5=0.0d0
 358          ecorr6=0.0d0
 359          eturn6=0.0d0
 360       endif
 361       if ((wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) .and. ipot.lt.6) then
 362 c         write (iout,*) "Before MULTIBODY_HB ecorr",ecorr,ecorr5,ecorr6,
 363 c     &     n_corr,n_corr1
 364 c         call flush(iout)
 365          call multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
 366 c         write (iout,*) "MULTIBODY_HB ecorr",ecorr,ecorr5,ecorr6,n_corr,
 367 c     &     n_corr1
 368 c         call flush(iout)
 369       endif
 370 #endif
 371 c      print *,"Processor",myrank," computed Ucorr"
 372 c      write (iout,*) "nsaxs",nsaxs," saxs_mode",saxs_mode
 373       if (nsaxs.gt.0 .and. saxs_mode.eq.0) then
 374         call e_saxs(Esaxs_constr)
 375 c        write (iout,*) "From Esaxs: Esaxs_constr",Esaxs_constr
 376       else if (nsaxs.gt.0 .and. saxs_mode.gt.0) then
 377         call e_saxsC(Esaxs_constr)
 378 c        write (iout,*) "From EsaxsC: Esaxs_constr",Esaxs_constr
 379       else
 380         Esaxs_constr = 0.0d0
 381       endif
 382 C
 383 C If performing constraint dynamics, call the constraint energy
 384 C  after the equilibration time
 385 c      if(usampl.and.totT.gt.eq_time) then
 386 c      write (iout,*) "usampl",usampl
 387       if(usampl) then
 388          call EconstrQ
 389          if (loc_qlike) then
 390            call Econstr_back_qlike
 391          else
 392            call Econstr_back
 393          endif
 394       else
 395          Uconst=0.0d0
 396          Uconst_back=0.0d0
 397       endif
 398 C 01/27/2015 added by adasko
 399 C the energy component below is energy transfer into lipid environment
 400 C based on partition function
 401 C      print *,"przed lipidami"
 402       if (wliptran.gt.0) then
 403         call Eliptransfer(eliptran)
 404       else
 405         eliptran=0.0d0
 406       endif
 407 C      print *,"za lipidami"
 408       if (AFMlog.gt.0) then
 409         call AFMforce(Eafmforce)
 410       else if (selfguide.gt.0) then
 411         call AFMvel(Eafmforce)
 412       endif
 413       if (TUBElog.eq.1) then
 414 C      print *,"just before call"
 415         call calctube(Etube)
 416        elseif (TUBElog.eq.2) then
 417         call calctube2(Etube)
 418        else
 419        Etube=0.0d0
 420        endif
 421
 422 #ifdef TIMING
 423       time_enecalc=time_enecalc+MPI_Wtime()-time00
 424 #endif
 425 c      print *,"Processor",myrank," computed Uconstr"
 426 #ifdef TIMING
 427       time00=MPI_Wtime()
 428 #endif
 429 c
 430 C Sum the energies
 431 C
 432       energia(1)=evdw
 433 #ifdef SCP14
 434       energia(2)=evdw2-evdw2_14
 435       energia(18)=evdw2_14
 436 #else
 437       energia(2)=evdw2
 438       energia(18)=0.0d0
 439 #endif
 440 #ifdef SPLITELE
 441       energia(3)=ees
 442       energia(16)=evdw1
 443 #else
 444       energia(3)=ees+evdw1
 445       energia(16)=0.0d0
 446 #endif
 447       energia(4)=ecorr
 448       energia(5)=ecorr5
 449       energia(6)=ecorr6
 450       energia(7)=eel_loc
 451       energia(8)=eello_turn3
 452       energia(9)=eello_turn4
 453       energia(10)=eturn6
 454       energia(11)=ebe
 455       energia(12)=escloc
 456       energia(13)=etors
 457       energia(14)=etors_d
 458       energia(15)=ehpb
 459       energia(19)=edihcnstr
 460       energia(17)=estr
 461       energia(20)=Uconst+Uconst_back
 462       energia(21)=esccor
 463       energia(22)=eliptran
 464       energia(23)=Eafmforce
 465       energia(24)=ethetacnstr
 466       energia(25)=Etube
 467       energia(26)=Esaxs_constr
 468       energia(27)=ehomology_constr
 469       energia(28)=edfadis
 470       energia(29)=edfator
 471       energia(30)=edfanei
 472       energia(31)=edfabet
 473 c      write (iout,*) "esaxs_constr",energia(26)
 474 c    Here are the energies showed per procesor if the are more processors
 475 c    per molecule then we sum it up in sum_energy subroutine
 476 c      print *," Processor",myrank," calls SUM_ENERGY"
 477       call sum_energy(energia,.true.)
 478 c      write (iout,*) "After sum_energy: esaxs_constr",energia(26)
 479       if (dyn_ss) call dyn_set_nss
 480 c      print *," Processor",myrank," left SUM_ENERGY"
 481 #ifdef TIMING
 482       time_sumene=time_sumene+MPI_Wtime()-time00
 483 #endif
 484       return
 485       end
 486 c-------------------------------------------------------------------------------
 487       subroutine sum_energy(energia,reduce)
 488       implicit none
 489       include 'DIMENSIONS'
 490 #ifndef ISNAN
 491       external proc_proc
 492 #ifdef WINPGI
 493 cMS$ATTRIBUTES C ::  proc_proc
 494 #endif
 495 #endif
 496 #ifdef MPI
 497       include "mpif.h"
 498       integer ierr
 499       double precision time00
 500 #endif
 501       include 'COMMON.SETUP'
 502       include 'COMMON.IOUNITS'
 503       double precision energia(0:n_ene),enebuff(0:n_ene+1)
 504       include 'COMMON.FFIELD'
 505       include 'COMMON.DERIV'
 506       include 'COMMON.INTERACT'
 507       include 'COMMON.SBRIDGE'
 508       include 'COMMON.CHAIN'
 509       include 'COMMON.VAR'
 510       include 'COMMON.CONTROL'
 511       include 'COMMON.TIME1'
 512       logical reduce
 513       integer i
 514       double precision evdw,evdw1,evdw2,evdw2_14,ees,eel_loc,
 515      & eello_turn3,eello_turn4,edfadis,estr,ehpb,ebe,ethetacnstr,
 516      & escloc,etors,edihcnstr,etors_d,esccor,ecorr,ecorr5,ecorr6,eturn6,
 517      & eliptran,Eafmforce,Etube,
 518      & esaxs_constr,ehomology_constr,edfator,edfanei,edfabet
 519       double precision Uconst,etot
 520 #ifdef MPI
 521       if (nfgtasks.gt.1 .and. reduce) then
 522 #ifdef DEBUG
 523         write (iout,*) "energies before REDUCE"
 524         call enerprint(energia)
 525         call flush(iout)
 526 #endif
 527         do i=0,n_ene
 528           enebuff(i)=energia(i)
 529         enddo
 530         time00=MPI_Wtime()
 531         call MPI_Barrier(FG_COMM,IERR)
 532         time_barrier_e=time_barrier_e+MPI_Wtime()-time00
 533         time00=MPI_Wtime()
 534         call MPI_Reduce(enebuff(0),energia(0),n_ene+1,
 535      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 536 #ifdef DEBUG
 537         write (iout,*) "energies after REDUCE"
 538         call enerprint(energia)
 539         call flush(iout)
 540 #endif
 541         time_Reduce=time_Reduce+MPI_Wtime()-time00
 542       endif
 543       if (fg_rank.eq.0) then
 544 #endif
 545       evdw=energia(1)
 546 #ifdef SCP14
 547       evdw2=energia(2)+energia(18)
 548       evdw2_14=energia(18)
 549 #else
 550       evdw2=energia(2)
 551 #endif
 552 #ifdef SPLITELE
 553       ees=energia(3)
 554       evdw1=energia(16)
 555 #else
 556       ees=energia(3)
 557       evdw1=0.0d0
 558 #endif
 559       ecorr=energia(4)
 560       ecorr5=energia(5)
 561       ecorr6=energia(6)
 562       eel_loc=energia(7)
 563       eello_turn3=energia(8)
 564       eello_turn4=energia(9)
 565       eturn6=energia(10)
 566       ebe=energia(11)
 567       escloc=energia(12)
 568       etors=energia(13)
 569       etors_d=energia(14)
 570       ehpb=energia(15)
 571       edihcnstr=energia(19)
 572       estr=energia(17)
 573       Uconst=energia(20)
 574       esccor=energia(21)
 575       eliptran=energia(22)
 576       Eafmforce=energia(23)
 577       ethetacnstr=energia(24)
 578       Etube=energia(25)
 579       esaxs_constr=energia(26)
 580       ehomology_constr=energia(27)
 581       edfadis=energia(28)
 582       edfator=energia(29)
 583       edfanei=energia(30)
 584       edfabet=energia(31)
 585 #ifdef SPLITELE
 586       etot=wsc*evdw+wscp*evdw2+welec*ees+wvdwpp*evdw1
 587      & +wang*ebe+wtor*etors+wscloc*escloc
 588      & +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5
 589      & +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3
 590      & +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d
 591      & +wbond*estr+wumb*Uconst+wsccor*esccor+wliptran*eliptran+Eafmforce
 592      & +ethetacnstr+wtube*Etube+wsaxs*esaxs_constr+ehomology_constr
 593      & +wdfa_dist*edfadis+wdfa_tor*edfator+wdfa_nei*edfanei
 594      & +wdfa_beta*edfabet
 595 #else
 596       etot=wsc*evdw+wscp*evdw2+welec*(ees+evdw1)
 597      & +wang*ebe+wtor*etors+wscloc*escloc
 598      & +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5
 599      & +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3
 600      & +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d
 601      & +wbond*estr+wumb*Uconst+wsccor*esccor+wliptran*eliptran
 602      & +Eafmforce
 603      & +ethetacnstr+wtube*Etube+wsaxs*esaxs_constr+ehomology_constr
 604      & +wdfa_dist*edfadis+wdfa_tor*edfator+wdfa_nei*edfanei
 605      & +wdfa_beta*edfabet
 606 #endif
 607       energia(0)=etot
 608 c detecting NaNQ
 609 #ifdef ISNAN
 610 #ifdef AIX
 611       if (isnan(etot).ne.0) energia(0)=1.0d+99
 612 #else
 613       if (isnan(etot)) energia(0)=1.0d+99
 614 #endif
 615 #else
 616       i=0
 617 #ifdef WINPGI
 618       idumm=proc_proc(etot,i)
 619 #else
 620       call proc_proc(etot,i)
 621 #endif
 622       if(i.eq.1)energia(0)=1.0d+99
 623 #endif
 624 #ifdef MPI
 625       endif
 626 #endif
 627       return
 628       end
 629 c-------------------------------------------------------------------------------
 630       subroutine sum_gradient
 631       implicit none
 632       include 'DIMENSIONS'
 633 #ifndef ISNAN
 634       external proc_proc
 635 #ifdef WINPGI
 636 cMS$ATTRIBUTES C ::  proc_proc
 637 #endif
 638 #endif
 639 #ifdef MPI
 640       include 'mpif.h'
 641       integer ierror,ierr
 642       double precision time00,time01
 643 #endif
 644       double precision gradbufc(3,-1:maxres),gradbufx(3,-1:maxres),
 645      & glocbuf(4*maxres),gradbufc_sum(3,-1:maxres)
 646      & ,gloc_scbuf(3,-1:maxres)
 647       include 'COMMON.SETUP'
 648       include 'COMMON.IOUNITS'
 649       include 'COMMON.FFIELD'
 650       include 'COMMON.DERIV'
 651       include 'COMMON.INTERACT'
 652       include 'COMMON.SBRIDGE'
 653       include 'COMMON.CHAIN'
 654       include 'COMMON.VAR'
 655       include 'COMMON.CONTROL'
 656       include 'COMMON.TIME1'
 657       include 'COMMON.MAXGRAD'
 658       include 'COMMON.SCCOR'
 659 c      include 'COMMON.MD'
 660       include 'COMMON.QRESTR'
 661       integer i,j,k
 662       double precision scalar
 663       double precision gvdwc_norm,gvdwc_scp_norm,gelc_norm,gvdwpp_norm,
 664      &gradb_norm,ghpbc_norm,gradcorr_norm,gel_loc_norm,gcorr3_turn_norm,
 665      &gcorr4_turn_norm,gradcorr5_norm,gradcorr6_norm,
 666      &gcorr6_turn_norm,gsccorrc_norm,gscloc_norm,gvdwx_norm,
 667      &gradx_scp_norm,ghpbx_norm,gradxorr_norm,gsccorrx_norm,
 668      &gsclocx_norm
 669 #ifdef TIMING
 670       time01=MPI_Wtime()
 671 #endif
 672 #ifdef DEBUG
 673       write (iout,*) "sum_gradient gvdwc, gvdwx"
 674       do i=1,nres
 675         write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)')
 676      &   i,(gvdwx(j,i),j=1,3),(gvdwc(j,i),j=1,3)
 677       enddo
 678       call flush(iout)
 679 #endif
 680 #ifdef DEBUG
 681       write (iout,*) "sum_gradient gsaxsc, gsaxsx"
 682       do i=0,nres
 683         write (iout,'(i3,3e15.5,5x,3e15.5)')
 684      &   i,(gsaxsc(j,i),j=1,3),(gsaxsx(j,i),j=1,3)
 685       enddo
 686       call flush(iout)
 687 #endif
 688 #ifdef MPI
 689 C FG slaves call the following matching MPI_Bcast in ERGASTULUM
 690         if (nfgtasks.gt.1 .and. fg_rank.eq.0)
 691      &    call MPI_Bcast(1,1,MPI_INTEGER,king,FG_COMM,IERROR)
 692 #endif
 693 C
 694 C 9/29/08 AL Transform parts of gradients in site coordinates to the gradient
 695 C            in virtual-bond-vector coordinates
 696 C
 697 #ifdef DEBUG
 698 c      write (iout,*) "gel_loc gel_loc_long and gel_loc_loc"
 699 c      do i=1,nres-1
 700 c        write (iout,'(i5,3f10.5,2x,3f10.5,2x,f10.5)')
 701 c     &   i,(gel_loc(j,i),j=1,3),(gel_loc_long(j,i),j=1,3),gel_loc_loc(i)
 702 c      enddo
 703 c      write (iout,*) "gel_loc_tur3 gel_loc_turn4"
 704 c      do i=1,nres-1
 705 c        write (iout,'(i5,3f10.5,2x,f10.5)')
 706 c     &  i,(gcorr4_turn(j,i),j=1,3),gel_loc_turn4(i)
 707 c      enddo
 708       write (iout,*) "gradcorr5 gradcorr5_long gradcorr5_loc"
 709       do i=1,nres
 710         write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)')
 711      &   i,(gradcorr5(j,i),j=1,3),(gradcorr5_long(j,i),j=1,3),
 712      &   g_corr5_loc(i)
 713       enddo
 714       call flush(iout)
 715 #endif
 716 #ifdef DEBUG
 717       write (iout,*) "gsaxsc"
 718       do i=1,nres
 719         write (iout,'(i3,3f10.5)') i,(wsaxs*gsaxsc(j,i),j=1,3)
 720       enddo
 721       call flush(iout)
 722 #endif
 723 #ifdef SPLITELE
 724       do i=0,nct
 725         do j=1,3
 726           gradbufc(j,i)=wsc*gvdwc(j,i)+
 727      &                wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+
 728      &                welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+
 729      &                wel_loc*gel_loc_long(j,i)+
 730      &                wcorr*gradcorr_long(j,i)+
 731      &                wcorr5*gradcorr5_long(j,i)+
 732      &                wcorr6*gradcorr6_long(j,i)+
 733      &                wturn6*gcorr6_turn_long(j,i)+
 734      &                wstrain*ghpbc(j,i)
 735      &                +wliptran*gliptranc(j,i)
 736      &                +gradafm(j,i)
 737      &                +welec*gshieldc(j,i)
 738      &                +wcorr*gshieldc_ec(j,i)
 739      &                +wturn3*gshieldc_t3(j,i)
 740      &                +wturn4*gshieldc_t4(j,i)
 741      &                +wel_loc*gshieldc_ll(j,i)
 742      &                +wtube*gg_tube(j,i)
 743      &                +wsaxs*gsaxsc(j,i)
 744         enddo
 745       enddo
 746 #else
 747       do i=0,nct
 748         do j=1,3
 749           gradbufc(j,i)=wsc*gvdwc(j,i)+
 750      &                wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+
 751      &                welec*gelc_long(j,i)+
 752      &                wbond*gradb(j,i)+
 753      &                wel_loc*gel_loc_long(j,i)+
 754      &                wcorr*gradcorr_long(j,i)+
 755      &                wcorr5*gradcorr5_long(j,i)+
 756      &                wcorr6*gradcorr6_long(j,i)+
 757      &                wturn6*gcorr6_turn_long(j,i)+
 758      &                wstrain*ghpbc(j,i)
 759      &                +wliptran*gliptranc(j,i)
 760      &                +gradafm(j,i)
 761      &                 +welec*gshieldc(j,i)
 762      &                 +wcorr*gshieldc_ec(j,i)
 763      &                 +wturn4*gshieldc_t4(j,i)
 764      &                 +wel_loc*gshieldc_ll(j,i)
 765      &                +wtube*gg_tube(j,i)
 766      &                +wsaxs*gsaxsc(j,i)
 767         enddo
 768       enddo
 769 #endif
 770       do i=1,nct
 771         do j=1,3
 772           gradbufc(j,i)=gradbufc(j,i)+
 773      &                wdfa_dist*gdfad(j,i)+
 774      &                wdfa_tor*gdfat(j,i)+
 775      &                wdfa_nei*gdfan(j,i)+
 776      &                wdfa_beta*gdfab(j,i)
 777         enddo
 778       enddo
 779 #ifdef DEBUG
 780       write (iout,*) "gradc from gradbufc"
 781       do i=1,nres
 782         write (iout,'(i3,3f10.5)') i,(gradc(j,i,icg),j=1,3)
 783       enddo
 784       call flush(iout)
 785 #endif
 786 #ifdef MPI
 787       if (nfgtasks.gt.1) then
 788       time00=MPI_Wtime()
 789 #ifdef DEBUG
 790       write (iout,*) "gradbufc before allreduce"
 791       do i=1,nres
 792         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 793       enddo
 794       call flush(iout)
 795 #endif
 796       do i=0,nres
 797         do j=1,3
 798           gradbufc_sum(j,i)=gradbufc(j,i)
 799         enddo
 800       enddo
 801 c      call MPI_AllReduce(gradbufc(1,1),gradbufc_sum(1,1),3*nres,
 802 c     &    MPI_DOUBLE_PRECISION,MPI_SUM,FG_COMM,IERR)
 803 c      time_reduce=time_reduce+MPI_Wtime()-time00
 804 #ifdef DEBUG
 805 c      write (iout,*) "gradbufc_sum after allreduce"
 806 c      do i=1,nres
 807 c        write (iout,'(i3,3f10.5)') i,(gradbufc_sum(j,i),j=1,3)
 808 c      enddo
 809 c      call flush(iout)
 810 #endif
 811 #ifdef TIMING
 812 c      time_allreduce=time_allreduce+MPI_Wtime()-time00
 813 #endif
 814       do i=nnt,nres
 815         do k=1,3
 816           gradbufc(k,i)=0.0d0
 817         enddo
 818       enddo
 819 #ifdef DEBUG
 820       write (iout,*) "igrad_start",igrad_start," igrad_end",igrad_end
 821       write (iout,*) (i," jgrad_start",jgrad_start(i),
 822      &                  " jgrad_end  ",jgrad_end(i),
 823      &                  i=igrad_start,igrad_end)
 824 #endif
 825 c
 826 c Obsolete and inefficient code; we can make the effort O(n) and, therefore,
 827 c do not parallelize this part.
 828 c
 829 c      do i=igrad_start,igrad_end
 830 c        do j=jgrad_start(i),jgrad_end(i)
 831 c          do k=1,3
 832 c            gradbufc(k,i)=gradbufc(k,i)+gradbufc_sum(k,j)
 833 c          enddo
 834 c        enddo
 835 c      enddo
 836       do j=1,3
 837         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
 838       enddo
 839       do i=nres-2,-1,-1
 840         do j=1,3
 841           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
 842         enddo
 843       enddo
 844 #ifdef DEBUG
 845       write (iout,*) "gradbufc after summing"
 846       do i=1,nres
 847         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 848       enddo
 849       call flush(iout)
 850 #endif
 851       else
 852 #endif
 853 #ifdef DEBUG
 854       write (iout,*) "gradbufc"
 855       do i=1,nres
 856         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 857       enddo
 858       call flush(iout)
 859 #endif
 860       do i=-1,nres
 861         do j=1,3
 862           gradbufc_sum(j,i)=gradbufc(j,i)
 863           gradbufc(j,i)=0.0d0
 864         enddo
 865       enddo
 866       do j=1,3
 867         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
 868       enddo
 869       do i=nres-2,-1,-1
 870         do j=1,3
 871           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
 872         enddo
 873       enddo
 874 c      do i=nnt,nres-1
 875 c        do k=1,3
 876 c          gradbufc(k,i)=0.0d0
 877 c        enddo
 878 c        do j=i+1,nres
 879 c          do k=1,3
 880 c            gradbufc(k,i)=gradbufc(k,i)+gradbufc(k,j)
 881 c          enddo
 882 c        enddo
 883 c      enddo
 884 #ifdef DEBUG
 885       write (iout,*) "gradbufc after summing"
 886       do i=1,nres
 887         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 888       enddo
 889       call flush(iout)
 890 #endif
 891 #ifdef MPI
 892       endif
 893 #endif
 894       do k=1,3
 895         gradbufc(k,nres)=0.0d0
 896       enddo
 897       do i=-1,nct
 898         do j=1,3
 899 #ifdef SPLITELE
 900 C          print *,gradbufc(1,13)
 901 C          print *,welec*gelc(1,13)
 902 C          print *,wel_loc*gel_loc(1,13)
 903 C          print *,0.5d0*(wscp*gvdwc_scpp(1,13))
 904 C          print *,welec*gelc_long(1,13)+wvdwpp*gvdwpp(1,13)
 905 C          print *,wel_loc*gel_loc_long(1,13)
 906 C          print *,gradafm(1,13),"AFM"
 907           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+
 908      &                wel_loc*gel_loc(j,i)+
 909      &                0.5d0*(wscp*gvdwc_scpp(j,i)+
 910      &                welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+
 911      &                wel_loc*gel_loc_long(j,i)+
 912      &                wcorr*gradcorr_long(j,i)+
 913      &                wcorr5*gradcorr5_long(j,i)+
 914      &                wcorr6*gradcorr6_long(j,i)+
 915      &                wturn6*gcorr6_turn_long(j,i))+
 916      &                wbond*gradb(j,i)+
 917      &                wcorr*gradcorr(j,i)+
 918      &                wturn3*gcorr3_turn(j,i)+
 919      &                wturn4*gcorr4_turn(j,i)+
 920      &                wcorr5*gradcorr5(j,i)+
 921      &                wcorr6*gradcorr6(j,i)+
 922      &                wturn6*gcorr6_turn(j,i)+
 923      &                wsccor*gsccorc(j,i)
 924      &               +wscloc*gscloc(j,i)
 925      &               +wliptran*gliptranc(j,i)
 926      &                +gradafm(j,i)
 927      &                 +welec*gshieldc(j,i)
 928      &                 +welec*gshieldc_loc(j,i)
 929      &                 +wcorr*gshieldc_ec(j,i)
 930      &                 +wcorr*gshieldc_loc_ec(j,i)
 931      &                 +wturn3*gshieldc_t3(j,i)
 932      &                 +wturn3*gshieldc_loc_t3(j,i)
 933      &                 +wturn4*gshieldc_t4(j,i)
 934      &                 +wturn4*gshieldc_loc_t4(j,i)
 935      &                 +wel_loc*gshieldc_ll(j,i)
 936      &                 +wel_loc*gshieldc_loc_ll(j,i)
 937      &                +wtube*gg_tube(j,i)
 938
 939 #else
 940           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+
 941      &                wel_loc*gel_loc(j,i)+
 942      &                0.5d0*(wscp*gvdwc_scpp(j,i)+
 943      &                welec*gelc_long(j,i)+
 944      &                wel_loc*gel_loc_long(j,i)+
 945      &                wcorr*gcorr_long(j,i)+
 946      &                wcorr5*gradcorr5_long(j,i)+
 947      &                wcorr6*gradcorr6_long(j,i)+
 948      &                wturn6*gcorr6_turn_long(j,i))+
 949      &                wbond*gradb(j,i)+
 950      &                wcorr*gradcorr(j,i)+
 951      &                wturn3*gcorr3_turn(j,i)+
 952      &                wturn4*gcorr4_turn(j,i)+
 953      &                wcorr5*gradcorr5(j,i)+
 954      &                wcorr6*gradcorr6(j,i)+
 955      &                wturn6*gcorr6_turn(j,i)+
 956      &                wsccor*gsccorc(j,i)
 957      &               +wscloc*gscloc(j,i)
 958      &               +wliptran*gliptranc(j,i)
 959      &                +gradafm(j,i)
 960      &                 +welec*gshieldc(j,i)
 961      &                 +welec*gshieldc_loc(j,i)
 962      &                 +wcorr*gshieldc_ec(j,i)
 963      &                 +wcorr*gshieldc_loc_ec(j,i)
 964      &                 +wturn3*gshieldc_t3(j,i)
 965      &                 +wturn3*gshieldc_loc_t3(j,i)
 966      &                 +wturn4*gshieldc_t4(j,i)
 967      &                 +wturn4*gshieldc_loc_t4(j,i)
 968      &                 +wel_loc*gshieldc_ll(j,i)
 969      &                 +wel_loc*gshieldc_loc_ll(j,i)
 970      &                +wtube*gg_tube(j,i)
 971
 972
 973 #endif
 974           gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+
 975      &                  wbond*gradbx(j,i)+
 976      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
 977      &                  wsccor*gsccorx(j,i)
 978      &                 +wscloc*gsclocx(j,i)
 979      &                 +wliptran*gliptranx(j,i)
 980      &                 +welec*gshieldx(j,i)
 981      &                 +wcorr*gshieldx_ec(j,i)
 982      &                 +wturn3*gshieldx_t3(j,i)
 983      &                 +wturn4*gshieldx_t4(j,i)
 984      &                 +wel_loc*gshieldx_ll(j,i)
 985      &                 +wtube*gg_tube_sc(j,i)
 986      &                 +wsaxs*gsaxsx(j,i)
 987
 988
 989
 990         enddo
 991       enddo
 992       if (constr_homology.gt.0) then
 993         do i=1,nct
 994           do j=1,3
 995             gradc(j,i,icg)=gradc(j,i,icg)+duscdiff(j,i)
 996             gradx(j,i,icg)=gradx(j,i,icg)+duscdiffx(j,i)
 997           enddo
 998         enddo
 999       endif
1000 #ifdef DEBUG
1001       write (iout,*) "gradc gradx gloc after adding"
1002       do i=1,nres
1003         write (iout,'(i5,3f10.5,5x,3f10.5,5x,f10.5)')
1004      &   i,(gradc(j,i,icg),j=1,3),(gradx(j,i,icg),j=1,3),gloc(i,icg)
1005       enddo
1006 #endif
1007 #ifdef DEBUG
1008       write (iout,*) "gloc before adding corr"
1009       do i=1,4*nres
1010         write (iout,*) i,gloc(i,icg)
1011       enddo
1012 #endif
1013       do i=1,nres-3
1014         gloc(i,icg)=gloc(i,icg)+wcorr*gcorr_loc(i)
1015      &   +wcorr5*g_corr5_loc(i)
1016      &   +wcorr6*g_corr6_loc(i)
1017      &   +wturn4*gel_loc_turn4(i)
1018      &   +wturn3*gel_loc_turn3(i)
1019      &   +wturn6*gel_loc_turn6(i)
1020      &   +wel_loc*gel_loc_loc(i)
1021       enddo
1022 #ifdef DEBUG
1023       write (iout,*) "gloc after adding corr"
1024       do i=1,4*nres
1025         write (iout,*) i,gloc(i,icg)
1026       enddo
1027 #endif
1028 #ifdef MPI
1029       if (nfgtasks.gt.1) then
1030         do j=1,3
1031           do i=1,nres
1032             gradbufc(j,i)=gradc(j,i,icg)
1033             gradbufx(j,i)=gradx(j,i,icg)
1034           enddo
1035         enddo
1036         do i=1,4*nres
1037           glocbuf(i)=gloc(i,icg)
1038         enddo
1039 c#define DEBUG
1040 #ifdef DEBUG
1041       write (iout,*) "gloc_sc before reduce"
1042       do i=1,nres
1043        do j=1,1
1044         write (iout,*) i,j,gloc_sc(j,i,icg)
1045        enddo
1046       enddo
1047 #endif
1048 c#undef DEBUG
1049         do i=1,nres
1050          do j=1,3
1051           gloc_scbuf(j,i)=gloc_sc(j,i,icg)
1052          enddo
1053         enddo
1054         time00=MPI_Wtime()
1055         call MPI_Barrier(FG_COMM,IERR)
1056         time_barrier_g=time_barrier_g+MPI_Wtime()-time00
1057         time00=MPI_Wtime()
1058         call MPI_Reduce(gradbufc(1,1),gradc(1,1,icg),3*nres,
1059      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
1060         call MPI_Reduce(gradbufx(1,1),gradx(1,1,icg),3*nres,
1061      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
1062         call MPI_Reduce(glocbuf(1),gloc(1,icg),4*nres,
1063      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
1064         time_reduce=time_reduce+MPI_Wtime()-time00
1065         call MPI_Reduce(gloc_scbuf(1,1),gloc_sc(1,1,icg),3*nres,
1066      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
1067         time_reduce=time_reduce+MPI_Wtime()-time00
1068 #ifdef DEBUG
1069       write (iout,*) "gradc after reduce"
1070       do i=1,nres
1071        do j=1,3
1072         write (iout,*) i,j,gradc(j,i,icg)
1073        enddo
1074       enddo
1075 #endif
1076 #ifdef DEBUG
1077       write (iout,*) "gloc_sc after reduce"
1078       do i=1,nres
1079        do j=1,1
1080         write (iout,*) i,j,gloc_sc(j,i,icg)
1081        enddo
1082       enddo
1083 #endif
1084 #ifdef DEBUG
1085       write (iout,*) "gloc after reduce"
1086       do i=1,4*nres
1087         write (iout,*) i,gloc(i,icg)
1088       enddo
1089 #endif
1090       endif
1091 #endif
1092       if (gnorm_check) then
1093 c
1094 c Compute the maximum elements of the gradient
1095 c
1096       gvdwc_max=0.0d0
1097       gvdwc_scp_max=0.0d0
1098       gelc_max=0.0d0
1099       gvdwpp_max=0.0d0
1100       gradb_max=0.0d0
1101       ghpbc_max=0.0d0
1102       gradcorr_max=0.0d0
1103       gel_loc_max=0.0d0
1104       gcorr3_turn_max=0.0d0
1105       gcorr4_turn_max=0.0d0
1106       gradcorr5_max=0.0d0
1107       gradcorr6_max=0.0d0
1108       gcorr6_turn_max=0.0d0
1109       gsccorrc_max=0.0d0
1110       gscloc_max=0.0d0
1111       gvdwx_max=0.0d0
1112       gradx_scp_max=0.0d0
1113       ghpbx_max=0.0d0
1114       gradxorr_max=0.0d0
1115       gsccorrx_max=0.0d0
1116       gsclocx_max=0.0d0
1117       do i=1,nct
1118         gvdwc_norm=dsqrt(scalar(gvdwc(1,i),gvdwc(1,i)))
1119         if (gvdwc_norm.gt.gvdwc_max) gvdwc_max=gvdwc_norm
1120         gvdwc_scp_norm=dsqrt(scalar(gvdwc_scp(1,i),gvdwc_scp(1,i)))
1121         if (gvdwc_scp_norm.gt.gvdwc_scp_max)
1122      &   gvdwc_scp_max=gvdwc_scp_norm
1123         gelc_norm=dsqrt(scalar(gelc(1,i),gelc(1,i)))
1124         if (gelc_norm.gt.gelc_max) gelc_max=gelc_norm
1125         gvdwpp_norm=dsqrt(scalar(gvdwpp(1,i),gvdwpp(1,i)))
1126         if (gvdwpp_norm.gt.gvdwpp_max) gvdwpp_max=gvdwpp_norm
1127         gradb_norm=dsqrt(scalar(gradb(1,i),gradb(1,i)))
1128         if (gradb_norm.gt.gradb_max) gradb_max=gradb_norm
1129         ghpbc_norm=dsqrt(scalar(ghpbc(1,i),ghpbc(1,i)))
1130         if (ghpbc_norm.gt.ghpbc_max) ghpbc_max=ghpbc_norm
1131         gradcorr_norm=dsqrt(scalar(gradcorr(1,i),gradcorr(1,i)))
1132         if (gradcorr_norm.gt.gradcorr_max) gradcorr_max=gradcorr_norm
1133         gel_loc_norm=dsqrt(scalar(gel_loc(1,i),gel_loc(1,i)))
1134         if (gel_loc_norm.gt.gel_loc_max) gel_loc_max=gel_loc_norm
1135         gcorr3_turn_norm=dsqrt(scalar(gcorr3_turn(1,i),
1136      &    gcorr3_turn(1,i)))
1137         if (gcorr3_turn_norm.gt.gcorr3_turn_max)
1138      &    gcorr3_turn_max=gcorr3_turn_norm
1139         gcorr4_turn_norm=dsqrt(scalar(gcorr4_turn(1,i),
1140      &    gcorr4_turn(1,i)))
1141         if (gcorr4_turn_norm.gt.gcorr4_turn_max)
1142      &    gcorr4_turn_max=gcorr4_turn_norm
1143         gradcorr5_norm=dsqrt(scalar(gradcorr5(1,i),gradcorr5(1,i)))
1144         if (gradcorr5_norm.gt.gradcorr5_max)
1145      &    gradcorr5_max=gradcorr5_norm
1146         gradcorr6_norm=dsqrt(scalar(gradcorr6(1,i),gradcorr6(1,i)))
1147         if (gradcorr6_norm.gt.gradcorr6_max)gradcorr6_max=gradcorr6_norm
1148         gcorr6_turn_norm=dsqrt(scalar(gcorr6_turn(1,i),
1149      &    gcorr6_turn(1,i)))
1150         if (gcorr6_turn_norm.gt.gcorr6_turn_max)
1151      &    gcorr6_turn_max=gcorr6_turn_norm
1152         gsccorrc_norm=dsqrt(scalar(gsccorc(1,i),gsccorc(1,i)))
1153         if (gsccorrc_norm.gt.gsccorrc_max) gsccorrc_max=gsccorrc_norm
1154         gscloc_norm=dsqrt(scalar(gscloc(1,i),gscloc(1,i)))
1155         if (gscloc_norm.gt.gscloc_max) gscloc_max=gscloc_norm
1156         gvdwx_norm=dsqrt(scalar(gvdwx(1,i),gvdwx(1,i)))
1157         if (gvdwx_norm.gt.gvdwx_max) gvdwx_max=gvdwx_norm
1158         gradx_scp_norm=dsqrt(scalar(gradx_scp(1,i),gradx_scp(1,i)))
1159         if (gradx_scp_norm.gt.gradx_scp_max)
1160      &    gradx_scp_max=gradx_scp_norm
1161         ghpbx_norm=dsqrt(scalar(ghpbx(1,i),ghpbx(1,i)))
1162         if (ghpbx_norm.gt.ghpbx_max) ghpbx_max=ghpbx_norm
1163         gradxorr_norm=dsqrt(scalar(gradxorr(1,i),gradxorr(1,i)))
1164         if (gradxorr_norm.gt.gradxorr_max) gradxorr_max=gradxorr_norm
1165         gsccorrx_norm=dsqrt(scalar(gsccorx(1,i),gsccorx(1,i)))
1166         if (gsccorrx_norm.gt.gsccorrx_max) gsccorrx_max=gsccorrx_norm
1167         gsclocx_norm=dsqrt(scalar(gsclocx(1,i),gsclocx(1,i)))
1168         if (gsclocx_norm.gt.gsclocx_max) gsclocx_max=gsclocx_norm
1169       enddo
1170       if (gradout) then
1171 #if (defined AIX || defined CRAY)
1172         open(istat,file=statname,position="append")
1173 #else
1174         open(istat,file=statname,access="append")
1175 #endif
1176         write (istat,'(1h#,21f10.2)') gvdwc_max,gvdwc_scp_max,
1177      &     gelc_max,gvdwpp_max,gradb_max,ghpbc_max,
1178      &     gradcorr_max,gel_loc_max,gcorr3_turn_max,gcorr4_turn_max,
1179      &     gradcorr5_max,gradcorr6_max,gcorr6_turn_max,gsccorrc_max,
1180      &     gscloc_max,gvdwx_max,gradx_scp_max,ghpbx_max,gradxorr_max,
1181      &     gsccorrx_max,gsclocx_max
1182         close(istat)
1183         if (gvdwc_max.gt.1.0d4) then
1184           write (iout,*) "gvdwc gvdwx gradb gradbx"
1185           do i=nnt,nct
1186             write(iout,'(i5,4(3f10.2,5x))') i,(gvdwc(j,i),gvdwx(j,i),
1187      &        gradb(j,i),gradbx(j,i),j=1,3)
1188           enddo
1189           call pdbout(0.0d0,'cipiszcze',iout)
1190           call flush(iout)
1191         endif
1192       endif
1193       endif
1194 #ifdef DEBUG
1195       write (iout,*) "gradc gradx gloc"
1196       do i=1,nres
1197         write (iout,'(i5,3f10.5,5x,3f10.5,5x,f10.5)')
1198      &   i,(gradc(j,i,icg),j=1,3),(gradx(j,i,icg),j=1,3),gloc(i,icg)
1199       enddo
1200 #endif
1201 #ifdef TIMING
1202       time_sumgradient=time_sumgradient+MPI_Wtime()-time01
1203 #endif
1204       return
1205       end
1206 c-------------------------------------------------------------------------------
1207       subroutine rescale_weights(t_bath)
1208       implicit none
1209 #ifdef MPI
1210       include 'mpif.h'
1211       integer ierror
1212 #endif
1213       include 'DIMENSIONS'
1214       include 'COMMON.IOUNITS'
1215       include 'COMMON.FFIELD'
1216       include 'COMMON.SBRIDGE'
1217       include 'COMMON.CONTROL'
1218       double precision t_bath
1219       double precision facT,facT2,facT3,facT4,facT5
1220       double precision kfac /2.4d0/
1221       double precision x,x2,x3,x4,x5,licznik /1.12692801104297249644/
1222 c      facT=temp0/t_bath
1223 c      facT=2*temp0/(t_bath+temp0)
1224       if (rescale_mode.eq.0) then
1225         facT=1.0d0
1226         facT2=1.0d0
1227         facT3=1.0d0
1228         facT4=1.0d0
1229         facT5=1.0d0
1230       else if (rescale_mode.eq.1) then
1231         facT=kfac/(kfac-1.0d0+t_bath/temp0)
1232         facT2=kfac**2/(kfac**2-1.0d0+(t_bath/temp0)**2)
1233         facT3=kfac**3/(kfac**3-1.0d0+(t_bath/temp0)**3)
1234         facT4=kfac**4/(kfac**4-1.0d0+(t_bath/temp0)**4)
1235         facT5=kfac**5/(kfac**5-1.0d0+(t_bath/temp0)**5)
1236       else if (rescale_mode.eq.2) then
1237         x=t_bath/temp0
1238         x2=x*x
1239         x3=x2*x
1240         x4=x3*x
1241         x5=x4*x
1242         facT=licznik/dlog(dexp(x)+dexp(-x))
1243         facT2=licznik/dlog(dexp(x2)+dexp(-x2))
1244         facT3=licznik/dlog(dexp(x3)+dexp(-x3))
1245         facT4=licznik/dlog(dexp(x4)+dexp(-x4))
1246         facT5=licznik/dlog(dexp(x5)+dexp(-x5))
1247       else
1248         write (iout,*) "Wrong RESCALE_MODE",rescale_mode
1249         write (*,*) "Wrong RESCALE_MODE",rescale_mode
1250 #ifdef MPI
1251        call MPI_Finalize(MPI_COMM_WORLD,IERROR)
1252 #endif
1253        stop 555
1254       endif
1255       if (shield_mode.gt.0) then
1256        wscp=weights(2)*fact
1257        wsc=weights(1)*fact
1258        wvdwpp=weights(16)*fact
1259       endif
1260       welec=weights(3)*fact
1261       wcorr=weights(4)*fact3
1262       wcorr5=weights(5)*fact4
1263       wcorr6=weights(6)*fact5
1264       wel_loc=weights(7)*fact2
1265       wturn3=weights(8)*fact2
1266       wturn4=weights(9)*fact3
1267       wturn6=weights(10)*fact5
1268       wtor=weights(13)*fact
1269       wtor_d=weights(14)*fact2
1270       wsccor=weights(21)*fact
1271       if (scale_umb) wumb=t_bath/temp0
1272 c      write (iout,*) "scale_umb",scale_umb
1273 c      write (iout,*) "t_bath",t_bath," temp0",temp0," wumb",wumb
1274
1275       return
1276       end
1277 C------------------------------------------------------------------------
1278       subroutine enerprint(energia)
1279       implicit none
1280       include 'DIMENSIONS'
1281       include 'COMMON.IOUNITS'
1282       include 'COMMON.FFIELD'
1283       include 'COMMON.SBRIDGE'
1284       include 'COMMON.QRESTR'
1285       double precision energia(0:n_ene)
1286       double precision evdw,evdw1,evdw2,evdw2_14,ees,eel_loc,
1287      & eello_turn3,eello_turn4,edfadis,estr,ehpb,ebe,ethetacnstr,
1288      & escloc,etors,edihcnstr,etors_d,esccor,ecorr,ecorr5,ecorr6,
1289      & eello_turn6,
1290      & eliptran,Eafmforce,Etube,
1291      & esaxs,ehomology_constr,edfator,edfanei,edfabet,etot
1292       etot=energia(0)
1293       evdw=energia(1)
1294       evdw2=energia(2)
1295 #ifdef SCP14
1296       evdw2=energia(2)+energia(18)
1297 #else
1298       evdw2=energia(2)
1299 #endif
1300       ees=energia(3)
1301 #ifdef SPLITELE
1302       evdw1=energia(16)
1303 #endif
1304       ecorr=energia(4)
1305       ecorr5=energia(5)
1306       ecorr6=energia(6)
1307       eel_loc=energia(7)
1308       eello_turn3=energia(8)
1309       eello_turn4=energia(9)
1310       eello_turn6=energia(10)
1311       ebe=energia(11)
1312       escloc=energia(12)
1313       etors=energia(13)
1314       etors_d=energia(14)
1315       ehpb=energia(15)
1316       edihcnstr=energia(19)
1317       estr=energia(17)
1318       Uconst=energia(20)
1319       esccor=energia(21)
1320       eliptran=energia(22)
1321       Eafmforce=energia(23)
1322       ethetacnstr=energia(24)
1323       etube=energia(25)
1324       esaxs=energia(26)
1325       ehomology_constr=energia(27)
1326 C     Bartek
1327       edfadis = energia(28)
1328       edfator = energia(29)
1329       edfanei = energia(30)
1330       edfabet = energia(31)
1331 #ifdef SPLITELE
1332       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,evdw1,wvdwpp,
1333      &  estr,wbond,ebe,wang,
1334      &  escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,
1335 #ifdef FOURBODY
1336      &  ecorr,wcorr,
1337      &  ecorr5,wcorr5,ecorr6,wcorr6,
1338 #endif
1339      &  eel_loc,wel_loc,eello_turn3,wturn3,
1340      &  eello_turn4,wturn4,
1341 #ifdef FOURBODY
1342      &  eello_turn6,wturn6,
1343 #endif
1344      &  esccor,wsccor,edihcnstr,
1345      &  ethetacnstr,ebr*nss,Uconst,wumb,eliptran,wliptran,Eafmforce,
1346      &  etube,wtube,esaxs,wsaxs,ehomology_constr,
1347      &  edfadis,wdfa_dist,edfator,wdfa_tor,edfanei,wdfa_nei,
1348      &  edfabet,wdfa_beta,
1349      &  etot
1350    10 format (/'Virtual-chain energies:'//
1351      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pE16.6,' (SC-SC)'/
1352      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pE16.6,' (SC-p)'/
1353      & 'EES=   ',1pE16.6,' WEIGHT=',1pE16.6,' (p-p)'/
1354      & 'EVDWPP=',1pE16.6,' WEIGHT=',1pE16.6,' (p-p VDW)'/
1355      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pE16.6,' (stretching)'/
1356      & 'EBE=   ',1pE16.6,' WEIGHT=',1pE16.6,' (bending)'/
1357      & 'ESC=   ',1pE16.6,' WEIGHT=',1pE16.6,' (SC local)'/
1358      & 'ETORS= ',1pE16.6,' WEIGHT=',1pE16.6,' (torsional)'/
1359      & 'ETORSD=',1pE16.6,' WEIGHT=',1pE16.6,' (double torsional)'/
1360      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pE16.6,
1361      & ' (SS bridges & dist. cnstr.)'/
1362 #ifdef FOURBODY
1363      & 'ECORR4=',1pE16.6,' WEIGHT=',1pE16.6,' (multi-body)'/
1364      & 'ECORR5=',1pE16.6,' WEIGHT=',1pE16.6,' (multi-body)'/
1365      & 'ECORR6=',1pE16.6,' WEIGHT=',1pE16.6,' (multi-body)'/
1366 #endif
1367      & 'EELLO= ',1pE16.6,' WEIGHT=',1pE16.6,' (electrostatic-local)'/
1368      & 'ETURN3=',1pE16.6,' WEIGHT=',1pE16.6,' (turns, 3rd order)'/
1369      & 'ETURN4=',1pE16.6,' WEIGHT=',1pE16.6,' (turns, 4th order)'/
1370 #ifdef FOURBODY
1371      & 'ETURN6=',1pE16.6,' WEIGHT=',1pE16.6,' (turns, 6th order)'/
1372 #endif
1373      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pE16.6,' (backbone-rotamer corr)'/
1374      & 'EDIHC= ',1pE16.6,' (virtual-bond dihedral angle restraints)'/
1375      & 'ETHETC=',1pE16.6,' (virtual-bond angle restraints)'/
1376      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
1377      & 'UCONST=',1pE16.6,' WEIGHT=',1pE16.6' (umbrella restraints)'/
1378      & 'ELT=   ',1pE16.6,' WEIGHT=',1pE16.6,' (Lipid transfer)'/
1379      & 'EAFM=  ',1pE16.6,' (atomic-force microscopy)'/
1380      & 'ETUBE= ',1pE16.6,' WEIGHT=',1pE16.6,' (tube confinment)'/
1381      & 'E_SAXS=',1pE16.6,' WEIGHT=',1pE16.6,' (SAXS restraints)'/
1382      & 'H_CONS=',1pE16.6,' (Homology model constraints energy)'/
1383      & 'EDFAD= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA distance energy)'/
1384      & 'EDFAT= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA torsion energy)'/
1385      & 'EDFAN= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA NCa energy)'/
1386      & 'EDFAB= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA Beta energy)'/
1387      & 'ETOT=  ',1pE16.6,' (total)')
1388
1389 #else
1390       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,
1391      &  estr,wbond,ebe,wang,
1392      &  escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,
1393 #ifdef FOURBODY
1394      &  ecorr,wcorr,
1395      &  ecorr5,wcorr5,ecorr6,wcorr6,
1396 #endif
1397      &  eel_loc,wel_loc,eello_turn3,wturn3,
1398      &  eello_turn4,wturn4,
1399 #ifdef FOURBODY
1400      &  eello_turn6,wturn6,
1401 #endif
1402      &  esccor,wsccor,edihcnstr,
1403      &  ethetacnstr,ebr*nss,Uconst,wumb,eliptran,wliptran,Eafmforc,
1404      &  etube,wtube,esaxs,wsaxs,ehomology_constr,
1405      &  edfadis,wdfa_dist,edfator,wdfa_tor,edfanei,wdfa_nei,
1406      &  edfabet,wdfa_beta,
1407      &  etot
1408    10 format (/'Virtual-chain energies:'//
1409      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pE16.6,' (SC-SC)'/
1410      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pE16.6,' (SC-p)'/
1411      & 'EES=   ',1pE16.6,' WEIGHT=',1pE16.6,' (p-p)'/
1412      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pE16.6,' (stretching)'/
1413      & 'EBE=   ',1pE16.6,' WEIGHT=',1pE16.6,' (bending)'/
1414      & 'ESC=   ',1pE16.6,' WEIGHT=',1pE16.6,' (SC local)'/
1415      & 'ETORS= ',1pE16.6,' WEIGHT=',1pE16.6,' (torsional)'/
1416      & 'ETORSD=',1pE16.6,' WEIGHT=',1pE16.6,' (double torsional)'/
1417      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pE16.6,
1418      & ' (SS bridges & dist. restr.)'/
1419 #ifdef FOURBODY
1420      & 'ECORR4=',1pE16.6,' WEIGHT=',1pE16.6,' (multi-body)'/
1421      & 'ECORR5=',1pE16.6,' WEIGHT=',1pE16.6,' (multi-body)'/
1422      & 'ECORR6=',1pE16.6,' WEIGHT=',1pE16.6,' (multi-body)'/
1423 #endif
1424      & 'EELLO= ',1pE16.6,' WEIGHT=',1pE16.6,' (electrostatic-local)'/
1425      & 'ETURN3=',1pE16.6,' WEIGHT=',1pE16.6,' (turns, 3rd order)'/
1426      & 'ETURN4=',1pE16.6,' WEIGHT=',1pE16.6,' (turns, 4th order)'/
1427 #ifdef FOURBODY
1428      & 'ETURN6=',1pE16.6,' WEIGHT=',1pE16.6,' (turns, 6th order)'/
1429 #endif
1430      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pE16.6,' (backbone-rotamer corr)'/
1431      & 'EDIHC= ',1pE16.6,' (virtual-bond dihedral angle restraints)'/
1432      & 'ETHETC=',1pE16.6,' (virtual-bond angle restraints)'/
1433      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
1434      & 'UCONST=',1pE16.6,' WEIGHT=',1pE16.6' (umbrella restraints)'/
1435      & 'ELT=   ',1pE16.6,' WEIGHT=',1pE16.6,' (Lipid transfer)'/
1436      & 'EAFM=  ',1pE16.6,' (atomic-force microscopy)'/
1437      & 'ETUBE= ',1pE16.6,' WEIGHT=',1pE16.6,' (tube confinment)'/
1438      & 'E_SAXS=',1pE16.6,' WEIGHT=',1pE16.6,' (SAXS restraints)'/
1439      & 'H_CONS=',1pE16.6,' (Homology model constraints energy)'/
1440      & 'EDFAD= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA distance energy)'/
1441      & 'EDFAT= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA torsion energy)'/
1442      & 'EDFAN= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA NCa energy)'/
1443      & 'EDFAB= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA Beta energy)'/
1444      & 'ETOT=  ',1pE16.6,' (total)')
1445 #endif
1446       return
1447       end
1448 C-----------------------------------------------------------------------
1449       subroutine elj(evdw)
1450 C
1451 C This subroutine calculates the interaction energy of nonbonded side chains
1452 C assuming the LJ potential of interaction.
1453 C
1454       implicit none
1455       double precision accur
1456       include 'DIMENSIONS'
1457       parameter (accur=1.0d-10)
1458       include 'COMMON.GEO'
1459       include 'COMMON.VAR'
1460       include 'COMMON.LOCAL'
1461       include 'COMMON.CHAIN'
1462       include 'COMMON.DERIV'
1463       include 'COMMON.INTERACT'
1464       include 'COMMON.TORSION'
1465       include 'COMMON.SBRIDGE'
1466       include 'COMMON.NAMES'
1467       include 'COMMON.IOUNITS'
1468       include 'COMMON.SPLITELE'
1469 #ifdef FOURBODY
1470       include 'COMMON.CONTACTS'
1471       include 'COMMON.CONTMAT'
1472 #endif
1473       double precision gg(3)
1474       double precision evdw,evdwij
1475       integer i,j,k,itypi,itypj,itypi1,num_conti,iint,ikont
1476       double precision xi,yi,zi,xj,yj,zj,rij,eps0ij,fac,e1,e2,rrij,
1477      & sigij,r0ij,rcut,sqrij,sss1,sssgrad1
1478       double precision fcont,fprimcont
1479       double precision sscale,sscagrad
1480       double precision boxshift
1481 c      write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
1482       evdw=0.0D0
1483 c      do i=iatsc_s,iatsc_e
1484       do ikont=g_listscsc_start,g_listscsc_end
1485         i=newcontlisti(ikont)
1486         j=newcontlistj(ikont)
1487         itypi=iabs(itype(i))
1488         if (itypi.eq.ntyp1) cycle
1489         itypi1=iabs(itype(i+1))
1490         xi=c(1,nres+i)
1491         yi=c(2,nres+i)
1492         zi=c(3,nres+i)
1493         call to_box(xi,yi,zi)
1494 C Change 12/1/95
1495         num_conti=0
1496 C
1497 C Calculate SC interaction energy.
1498 C
1499 c        do iint=1,nint_gr(i)
1500 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
1501 cd   &                  'iend=',iend(i,iint)
1502 c          do j=istart(i,iint),iend(i,iint)
1503             itypj=iabs(itype(j))
1504             if (itypj.eq.ntyp1) cycle
1505             xj=c(1,nres+j)
1506             yj=c(2,nres+j)
1507             zj=c(3,nres+j)
1508             call to_box(xj,yj,zj)
1509             xj=boxshift(xj-xi,boxxsize)
1510             yj=boxshift(yj-yi,boxysize)
1511             zj=boxshift(zj-zi,boxzsize)
1512 C Change 12/1/95 to calculate four-body interactions
1513             rij=xj*xj+yj*yj+zj*zj
1514             rrij=1.0D0/rij
1515             sqrij=dsqrt(rij)
1516             sss1=sscale(sqrij,r_cut_int)
1517             if (sss1.eq.0.0d0) cycle
1518             sssgrad1=sscagrad(sqrij,r_cut_int)
1519
1520 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
1521             eps0ij=eps(itypi,itypj)
1522             fac=rrij**expon2
1523 C have you changed here?
1524             e1=fac*fac*aa
1525             e2=fac*bb
1526             evdwij=e1+e2
1527 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1528 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1529 cd          write (iout,'(2(a3,i3,2x),6(1pd12.4)/2(3(1pd12.4),5x)/)')
1530 cd   &        restyp(itypi),i,restyp(itypj),j,a(itypi,itypj),
1531 cd   &        bb(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,epsi,sigm,
1532 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1533             evdw=evdw+sss1*evdwij
1534 C
1535 C Calculate the components of the gradient in DC and X
1536 C
1537             fac=-rrij*(e1+evdwij)*sss1
1538      &          +evdwij*sssgrad1/sqrij/expon
1539             gg(1)=xj*fac
1540             gg(2)=yj*fac
1541             gg(3)=zj*fac
1542             do k=1,3
1543               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1544               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1545               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1546               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1547             enddo
1548 cgrad            do k=i,j-1
1549 cgrad              do l=1,3
1550 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1551 cgrad              enddo
1552 cgrad            enddo
1553 C
1554 #ifdef FOURBODY
1555 C 12/1/95, revised on 5/20/97
1556 C
1557 C Calculate the contact function. The ith column of the array JCONT will
1558 C contain the numbers of atoms that make contacts with the atom I (of numbers
1559 C greater than I). The arrays FACONT and GACONT will contain the values of
1560 C the contact function and its derivative.
1561 C
1562 C Uncomment next line, if the correlation interactions include EVDW explicitly.
1563 c           if (j.gt.i+1 .and. evdwij.le.0.0D0) then
1564 C Uncomment next line, if the correlation interactions are contact function only
1565             if (j.gt.i+1.and. eps0ij.gt.0.0D0) then
1566               rij=dsqrt(rij)
1567               sigij=sigma(itypi,itypj)
1568               r0ij=rs0(itypi,itypj)
1569 C
1570 C Check whether the SC's are not too far to make a contact.
1571 C
1572               rcut=1.5d0*r0ij
1573               call gcont(rij,rcut,1.0d0,0.2d0*rcut,fcont,fprimcont)
1574 C Add a new contact, if the SC's are close enough, but not too close (r<sigma).
1575 C
1576               if (fcont.gt.0.0D0) then
1577 C If the SC-SC distance if close to sigma, apply spline.
1578 cAdam           call gcont(-rij,-1.03d0*sigij,2.0d0*sigij,1.0d0,
1579 cAdam &             fcont1,fprimcont1)
1580 cAdam           fcont1=1.0d0-fcont1
1581 cAdam           if (fcont1.gt.0.0d0) then
1582 cAdam             fprimcont=fprimcont*fcont1+fcont*fprimcont1
1583 cAdam             fcont=fcont*fcont1
1584 cAdam           endif
1585 C Uncomment following 4 lines to have the geometric average of the epsilon0's
1586 cga             eps0ij=1.0d0/dsqrt(eps0ij)
1587 cga             do k=1,3
1588 cga               gg(k)=gg(k)*eps0ij
1589 cga             enddo
1590 cga             eps0ij=-evdwij*eps0ij
1591 C Uncomment for AL's type of SC correlation interactions.
1592 cadam           eps0ij=-evdwij
1593                 num_conti=num_conti+1
1594                 jcont(num_conti,i)=j
1595                 facont(num_conti,i)=fcont*eps0ij
1596                 fprimcont=eps0ij*fprimcont/rij
1597                 fcont=expon*fcont
1598 cAdam           gacont(1,num_conti,i)=-fprimcont*xj+fcont*gg(1)
1599 cAdam           gacont(2,num_conti,i)=-fprimcont*yj+fcont*gg(2)
1600 cAdam           gacont(3,num_conti,i)=-fprimcont*zj+fcont*gg(3)
1601 C Uncomment following 3 lines for Skolnick's type of SC correlation.
1602                 gacont(1,num_conti,i)=-fprimcont*xj
1603                 gacont(2,num_conti,i)=-fprimcont*yj
1604                 gacont(3,num_conti,i)=-fprimcont*zj
1605 cd              write (iout,'(2i5,2f10.5)') i,j,rij,facont(num_conti,i)
1606 cd              write (iout,'(2i3,3f10.5)')
1607 cd   &           i,j,(gacont(kk,num_conti,i),kk=1,3)
1608               endif
1609             endif
1610 #endif
1611 c          enddo      ! j
1612 c        enddo        ! iint
1613 C Change 12/1/95
1614 #ifdef FOURBODY
1615         num_cont(i)=num_conti
1616 #endif
1617       enddo          ! i
1618       do i=1,nct
1619         do j=1,3
1620           gvdwc(j,i)=expon*gvdwc(j,i)
1621           gvdwx(j,i)=expon*gvdwx(j,i)
1622         enddo
1623       enddo
1624 C******************************************************************************
1625 C
1626 C                              N O T E !!!
1627 C
1628 C To save time, the factor of EXPON has been extracted from ALL components
1629 C of GVDWC and GRADX. Remember to multiply them by this factor before further
1630 C use!
1631 C
1632 C******************************************************************************
1633       return
1634       end
1635 C-----------------------------------------------------------------------------
1636       subroutine eljk(evdw)
1637 C
1638 C This subroutine calculates the interaction energy of nonbonded side chains
1639 C assuming the LJK potential of interaction.
1640 C
1641       implicit none
1642       include 'DIMENSIONS'
1643       include 'COMMON.GEO'
1644       include 'COMMON.VAR'
1645       include 'COMMON.LOCAL'
1646       include 'COMMON.CHAIN'
1647       include 'COMMON.DERIV'
1648       include 'COMMON.INTERACT'
1649       include 'COMMON.IOUNITS'
1650       include 'COMMON.NAMES'
1651       include 'COMMON.SPLITELE'
1652       double precision gg(3)
1653       double precision evdw,evdwij
1654       integer i,j,k,itypi,itypj,itypi1,iint,ikont
1655       double precision xi,yi,zi,xj,yj,zj,rij,eps0ij,fac,e1,e2,rrij,
1656      & fac_augm,e_augm,r_inv_ij,r_shift_inv,sss1,sssgrad1
1657       logical scheck
1658       double precision sscale,sscagrad
1659       double precision boxshift
1660 c     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
1661       evdw=0.0D0
1662 c      do i=iatsc_s,iatsc_e
1663       do ikont=g_listscsc_start,g_listscsc_end
1664         i=newcontlisti(ikont)
1665         j=newcontlistj(ikont)
1666         itypi=iabs(itype(i))
1667         if (itypi.eq.ntyp1) cycle
1668         itypi1=iabs(itype(i+1))
1669         xi=c(1,nres+i)
1670         yi=c(2,nres+i)
1671         zi=c(3,nres+i)
1672         call to_box(xi,yi,zi)
1673 C
1674 C Calculate SC interaction energy.
1675 C
1676 c        do iint=1,nint_gr(i)
1677 c          do j=istart(i,iint),iend(i,iint)
1678             itypj=iabs(itype(j))
1679             if (itypj.eq.ntyp1) cycle
1680             xj=c(1,nres+j)
1681             yj=c(2,nres+j)
1682             zj=c(3,nres+j)
1683             call to_box(xj,yj,zj)
1684             xj=boxshift(xj-xi,boxxsize)
1685             yj=boxshift(yj-yi,boxysize)
1686             zj=boxshift(zj-zi,boxzsize)
1687             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1688             fac_augm=rrij**expon
1689             e_augm=augm(itypi,itypj)*fac_augm
1690             r_inv_ij=dsqrt(rrij)
1691             rij=1.0D0/r_inv_ij
1692             sss1=sscale(rij,r_cut_int)
1693             if (sss1.eq.0.0d0) cycle
1694             sssgrad1=sscagrad(rij,r_cut_int)
1695             r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
1696             fac=r_shift_inv**expon
1697 C have you changed here?
1698             e1=fac*fac*aa
1699             e2=fac*bb
1700             evdwij=e_augm+e1+e2
1701 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1702 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1703 cd          write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
1704 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
1705 cd   &        bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
1706 cd   &        sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
1707 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1708             evdw=evdw+evdwij*sss1
1709 C
1710 C Calculate the components of the gradient in DC and X
1711 C
1712             fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
1713      &          +evdwij*sssgrad1*r_inv_ij/expon
1714             gg(1)=xj*fac
1715             gg(2)=yj*fac
1716             gg(3)=zj*fac
1717             do k=1,3
1718               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1719               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1720               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1721               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1722             enddo
1723 cgrad            do k=i,j-1
1724 cgrad              do l=1,3
1725 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1726 cgrad              enddo
1727 cgrad            enddo
1728 c          enddo      ! j
1729 c        enddo        ! iint
1730       enddo          ! i
1731       do i=1,nct
1732         do j=1,3
1733           gvdwc(j,i)=expon*gvdwc(j,i)
1734           gvdwx(j,i)=expon*gvdwx(j,i)
1735         enddo
1736       enddo
1737       return
1738       end
1739 C-----------------------------------------------------------------------------
1740       subroutine ebp(evdw)
1741 C
1742 C This subroutine calculates the interaction energy of nonbonded side chains
1743 C assuming the Berne-Pechukas potential of interaction.
1744 C
1745       implicit none
1746       include 'DIMENSIONS'
1747       include 'COMMON.GEO'
1748       include 'COMMON.VAR'
1749       include 'COMMON.LOCAL'
1750       include 'COMMON.CHAIN'
1751       include 'COMMON.DERIV'
1752       include 'COMMON.NAMES'
1753       include 'COMMON.INTERACT'
1754       include 'COMMON.IOUNITS'
1755       include 'COMMON.CALC'
1756       include 'COMMON.SPLITELE'
1757       integer icall
1758       common /srutu/ icall
1759       double precision evdw
1760       integer itypi,itypj,itypi1,iint,ind,ikont
1761       double precision eps0ij,epsi,sigm,fac,e1,e2,rrij,xi,yi,zi,
1762      & sss1,sssgrad1
1763       double precision sscale,sscagrad
1764       double precision boxshift
1765 c     double precision rrsave(maxdim)
1766       logical lprn
1767       evdw=0.0D0
1768 c     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
1769       evdw=0.0D0
1770 c     if (icall.eq.0) then
1771 c       lprn=.true.
1772 c     else
1773         lprn=.false.
1774 c     endif
1775       ind=0
1776 c      do i=iatsc_s,iatsc_e
1777       do ikont=g_listscsc_start,g_listscsc_end
1778         i=newcontlisti(ikont)
1779         j=newcontlistj(ikont)
1780         itypi=iabs(itype(i))
1781         if (itypi.eq.ntyp1) cycle
1782         itypi1=iabs(itype(i+1))
1783         xi=c(1,nres+i)
1784         yi=c(2,nres+i)
1785         zi=c(3,nres+i)
1786         call to_box(xi,yi,zi)
1787         dxi=dc_norm(1,nres+i)
1788         dyi=dc_norm(2,nres+i)
1789         dzi=dc_norm(3,nres+i)
1790 c        dsci_inv=dsc_inv(itypi)
1791         dsci_inv=vbld_inv(i+nres)
1792 C
1793 C Calculate SC interaction energy.
1794 C
1795 c        do iint=1,nint_gr(i)
1796 c          do j=istart(i,iint),iend(i,iint)
1797             ind=ind+1
1798             itypj=iabs(itype(j))
1799             if (itypj.eq.ntyp1) cycle
1800 c            dscj_inv=dsc_inv(itypj)
1801             dscj_inv=vbld_inv(j+nres)
1802             chi1=chi(itypi,itypj)
1803             chi2=chi(itypj,itypi)
1804             chi12=chi1*chi2
1805             chip1=chip(itypi)
1806             chip2=chip(itypj)
1807             chip12=chip1*chip2
1808             alf1=alp(itypi)
1809             alf2=alp(itypj)
1810             alf12=0.5D0*(alf1+alf2)
1811 C For diagnostics only!!!
1812 c           chi1=0.0D0
1813 c           chi2=0.0D0
1814 c           chi12=0.0D0
1815 c           chip1=0.0D0
1816 c           chip2=0.0D0
1817 c           chip12=0.0D0
1818 c           alf1=0.0D0
1819 c           alf2=0.0D0
1820 c           alf12=0.0D0
1821             xj=c(1,nres+j)
1822             yj=c(2,nres+j)
1823             zj=c(3,nres+j)
1824             call to_box(xj,yj,zj)
1825             xj=boxshift(xj-xi,boxxsize)
1826             yj=boxshift(yj-yi,boxysize)
1827             zj=boxshift(zj-zi,boxzsize)
1828             dxj=dc_norm(1,nres+j)
1829             dyj=dc_norm(2,nres+j)
1830             dzj=dc_norm(3,nres+j)
1831             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1832 cd          if (icall.eq.0) then
1833 cd            rrsave(ind)=rrij
1834 cd          else
1835 cd            rrij=rrsave(ind)
1836 cd          endif
1837             rij=dsqrt(rrij)
1838             sss1=sscale(1.0d0/rij,r_cut_int)
1839             if (sss1.eq.0.0d0) cycle
1840             sssgrad1=sscagrad(1.0d0/rij,r_cut_int)
1841 C Calculate the angle-dependent terms of energy & contributions to derivatives.
1842             call sc_angular
1843 C Calculate whole angle-dependent part of epsilon and contributions
1844 C to its derivatives
1845 C have you changed here?
1846             fac=(rrij*sigsq)**expon2
1847             e1=fac*fac*aa
1848             e2=fac*bb
1849             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1850             eps2der=evdwij*eps3rt
1851             eps3der=evdwij*eps2rt
1852             evdwij=evdwij*eps2rt*eps3rt
1853             evdw=evdw+sss1*evdwij
1854             if (lprn) then
1855             sigm=dabs(aa/bb)**(1.0D0/6.0D0)
1856             epsi=bb**2/aa
1857 cd            write (iout,'(2(a3,i3,2x),15(0pf7.3))')
1858 cd     &        restyp(itypi),i,restyp(itypj),j,
1859 cd     &        epsi,sigm,chi1,chi2,chip1,chip2,
1860 cd     &        eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
1861 cd     &        om1,om2,om12,1.0D0/dsqrt(rrij),
1862 cd     &        evdwij
1863             endif
1864 C Calculate gradient components.
1865             e1=e1*eps1*eps2rt**2*eps3rt**2
1866             fac=-expon*(e1+evdwij)
1867             sigder=fac/sigsq
1868             fac=rrij*fac
1869      &          +evdwij*sssgrad1/sss1*rij
1870 C Calculate radial part of the gradient
1871             gg(1)=xj*fac
1872             gg(2)=yj*fac
1873             gg(3)=zj*fac
1874 C Calculate the angular part of the gradient and sum add the contributions
1875 C to the appropriate components of the Cartesian gradient.
1876             call sc_grad
1877 !          enddo      ! j
1878 !        enddo        ! iint
1879       enddo          ! i
1880 c     stop
1881       return
1882       end
1883 C-----------------------------------------------------------------------------
1884       subroutine egb(evdw)
1885 C
1886 C This subroutine calculates the interaction energy of nonbonded side chains
1887 C assuming the Gay-Berne potential of interaction.
1888 C
1889       implicit none
1890       include 'DIMENSIONS'
1891       include 'COMMON.GEO'
1892       include 'COMMON.VAR'
1893       include 'COMMON.LOCAL'
1894       include 'COMMON.CHAIN'
1895       include 'COMMON.DERIV'
1896       include 'COMMON.NAMES'
1897       include 'COMMON.INTERACT'
1898       include 'COMMON.IOUNITS'
1899       include 'COMMON.CALC'
1900       include 'COMMON.CONTROL'
1901       include 'COMMON.SPLITELE'
1902       include 'COMMON.SBRIDGE'
1903       logical lprn
1904       double precision evdw
1905       integer itypi,itypj,itypi1,iint,ind,ikont
1906       double precision eps0ij,epsi,sigm,fac,e1,e2,rrij,xi,yi,zi
1907       double precision fracinbuf,sslipi,evdwij_przed_tri,sig0ij,
1908      & sslipj,ssgradlipj,ssgradlipi,sig,rij_shift,faclip
1909       double precision dist,sscale,sscagrad,sscagradlip,sscalelip
1910       double precision boxshift
1911       evdw=0.0D0
1912 ccccc      energy_dec=.false.
1913 C      print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1914       evdw=0.0D0
1915       lprn=.false.
1916 c     if (icall.eq.0) lprn=.false.
1917       ind=0
1918 C the loop over all 27 posible neigbours (for xshift=0,yshift=0,zshift=0
1919 C we have the original box)
1920 C      do xshift=-1,1
1921 C      do yshift=-1,1
1922 C      do zshift=-1,1
1923 c      do i=iatsc_s,iatsc_e
1924       do ikont=g_listscsc_start,g_listscsc_end
1925         i=newcontlisti(ikont)
1926         j=newcontlistj(ikont)
1927         itypi=iabs(itype(i))
1928         if (itypi.eq.ntyp1) cycle
1929         itypi1=iabs(itype(i+1))
1930         xi=c(1,nres+i)
1931         yi=c(2,nres+i)
1932         zi=c(3,nres+i)
1933         call to_box(xi,yi,zi)
1934 C define scaling factor for lipids
1935
1936 C        if (positi.le.0) positi=positi+boxzsize
1937 C        print *,i
1938 C first for peptide groups
1939 c for each residue check if it is in lipid or lipid water border area
1940         call lipid_layer(xi,yi,zi,sslipi,ssgradlipi)
1941 C          xi=xi+xshift*boxxsize
1942 C          yi=yi+yshift*boxysize
1943 C          zi=zi+zshift*boxzsize
1944
1945         dxi=dc_norm(1,nres+i)
1946         dyi=dc_norm(2,nres+i)
1947         dzi=dc_norm(3,nres+i)
1948 c        dsci_inv=dsc_inv(itypi)
1949         dsci_inv=vbld_inv(i+nres)
1950 c        write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)
1951 c        write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi
1952 C
1953 C Calculate SC interaction energy.
1954 C
1955 c        do iint=1,nint_gr(i)
1956 c          do j=istart(i,iint),iend(i,iint)
1957             IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN
1958
1959 c              write(iout,*) "PRZED ZWYKLE", evdwij
1960               call dyn_ssbond_ene(i,j,evdwij)
1961 c              write(iout,*) "PO ZWYKLE", evdwij
1962
1963               evdw=evdw+evdwij
1964               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)')
1965      &                        'evdw',i,j,evdwij,' ss'
1966 C triple bond artifac removal
1967               do k=j+1,iend(i,iint)
1968 C search over all next residues
1969                 if (dyn_ss_mask(k)) then
1970 C check if they are cysteins
1971 C              write(iout,*) 'k=',k
1972
1973 c              write(iout,*) "PRZED TRI", evdwij
1974                   evdwij_przed_tri=evdwij
1975                   call triple_ssbond_ene(i,j,k,evdwij)
1976 c               if(evdwij_przed_tri.ne.evdwij) then
1977 c                 write (iout,*) "TRI:", evdwij, evdwij_przed_tri
1978 c               endif
1979
1980 c              write(iout,*) "PO TRI", evdwij
1981 C call the energy function that removes the artifical triple disulfide
1982 C bond the soubroutine is located in ssMD.F
1983                   evdw=evdw+evdwij
1984                   if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)')
1985      &                        'evdw',i,j,evdwij,'tss'
1986                 endif!dyn_ss_mask(k)
1987               enddo! k
1988             ELSE
1989               ind=ind+1
1990               itypj=iabs(itype(j))
1991               if (itypj.eq.ntyp1) cycle
1992 c            dscj_inv=dsc_inv(itypj)
1993               dscj_inv=vbld_inv(j+nres)
1994 c            write (iout,*) "j",j,dsc_inv(itypj),dscj_inv,
1995 c     &       1.0d0/vbld(j+nres)
1996 c            write (iout,*) "i",i," j", j," itype",itype(i),itype(j)
1997               sig0ij=sigma(itypi,itypj)
1998               chi1=chi(itypi,itypj)
1999               chi2=chi(itypj,itypi)
2000               chi12=chi1*chi2
2001               chip1=chip(itypi)
2002               chip2=chip(itypj)
2003               chip12=chip1*chip2
2004               alf1=alp(itypi)
2005               alf2=alp(itypj)
2006               alf12=0.5D0*(alf1+alf2)
2007 C For diagnostics only!!!
2008 c           chi1=0.0D0
2009 c           chi2=0.0D0
2010 c           chi12=0.0D0
2011 c           chip1=0.0D0
2012 c           chip2=0.0D0
2013 c           chip12=0.0D0
2014 c           alf1=0.0D0
2015 c           alf2=0.0D0
2016 c           alf12=0.0D0
2017               xj=c(1,nres+j)
2018               yj=c(2,nres+j)
2019               zj=c(3,nres+j)
2020               call to_box(xj,yj,zj)
2021               call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
2022               aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
2023      &          +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
2024               bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
2025      &          +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
2026 C      write(iout,*) "tu,", i,j,aa_lip(itypi,itypj),bb_lip(itypi,itypj)
2027 C      if (aa.ne.aa_aq(itypi,itypj)) write(63,'(2e10.5)')
2028 C     &(aa-aa_aq(itypi,itypj)),(bb-bb_aq(itypi,itypj))
2029 C      if (ssgradlipj.gt.0.0d0) print *,"??WTF??"
2030 C      print *,sslipi,sslipj,bordlipbot,zi,zj
2031               xj=boxshift(xj-xi,boxxsize)
2032               yj=boxshift(yj-yi,boxysize)
2033               zj=boxshift(zj-zi,boxzsize)
2034               dxj=dc_norm(1,nres+j)
2035               dyj=dc_norm(2,nres+j)
2036               dzj=dc_norm(3,nres+j)
2037 C            xj=xj-xi
2038 C            yj=yj-yi
2039 C            zj=zj-zi
2040 c            write (iout,*) "dcnorj",dxi*dxi+dyi*dyi+dzi*dzi
2041 c            write (iout,*) "j",j," dc_norm",
2042 c     &       dc_norm(1,nres+j),dc_norm(2,nres+j),dc_norm(3,nres+j)
2043               rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
2044               rij=dsqrt(rrij)
2045               sss=sscale(1.0d0/rij,r_cut_int)
2046 c            write (iout,'(a7,4f8.3)')
2047 c    &      "ssscale",sss,((1.0d0/rij)/sigma(itypi,itypj)),r_cut,rlamb
2048               if (sss.eq.0.0d0) cycle
2049               sssgrad=sscagrad(1.0d0/rij,r_cut_int)
2050 C Calculate angle-dependent terms of energy and contributions to their
2051 C derivatives.
2052               call sc_angular
2053               sigsq=1.0D0/sigsq
2054               sig=sig0ij*dsqrt(sigsq)
2055               rij_shift=1.0D0/rij-sig+sig0ij
2056 c              if (energy_dec)
2057 c     &        write (iout,*) "rij",1.0d0/rij," rij_shift",rij_shift,
2058 c     &       " sig",sig," sig0ij",sig0ij
2059 c for diagnostics; uncomment
2060 c            rij_shift=1.2*sig0ij
2061 C I hate to put IF's in the loops, but here don't have another choice!!!!
2062               if (rij_shift.le.0.0D0) then
2063                 evdw=1.0D20
2064 cd              write (iout,'(2(a3,i3,2x),17(0pf7.3))')
2065 cd     &        restyp(itypi),i,restyp(itypj),j,
2066 cd     &        rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq)
2067 c                return
2068               endif
2069               sigder=-sig*sigsq
2070 c---------------------------------------------------------------
2071               rij_shift=1.0D0/rij_shift
2072               fac=rij_shift**expon
2073 C here to start with
2074 C            if (c(i,3).gt.
2075               faclip=fac
2076               e1=fac*fac*aa
2077               e2=fac*bb
2078               evdwij=eps1*eps2rt*eps3rt*(e1+e2)
2079               eps2der=evdwij*eps3rt
2080               eps3der=evdwij*eps2rt
2081 C       write(63,'(2i3,2e10.3,2f10.5)') i,j,aa,bb, evdwij,
2082 C     &((sslipi+sslipj)/2.0d0+
2083 C     &(2.0d0-sslipi-sslipj)/2.0d0)
2084 c            write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt,
2085 c     &        " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2
2086               evdwij=evdwij*eps2rt*eps3rt
2087               evdw=evdw+evdwij*sss
2088               if (lprn) then
2089                 sigm=dabs(aa/bb)**(1.0D0/6.0D0)
2090                 epsi=bb**2/aa
2091                 write (iout,'(2(a3,i3,2x),17(0pf7.3))')
2092      &           restyp(itypi),i,restyp(itypj),j,
2093      &           epsi,sigm,chi1,chi2,chip1,chip2,
2094      &           eps1,eps2rt**2,eps3rt**2,sig,sig0ij,
2095      &           om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
2096      &           evdwij
2097               endif
2098
2099               if (energy_dec) write (iout,'(a,2i5,2f10.5,e15.5)')
2100      &                    'r sss evdw',i,j,1.0d0/rij,sss,evdwij
2101
2102 C Calculate gradient components.
2103               e1=e1*eps1*eps2rt**2*eps3rt**2
2104               fac=-expon*(e1+evdwij)*rij_shift
2105               sigder=fac*sigder
2106               fac=rij*fac
2107 c            print '(2i4,6f8.4)',i,j,sss,sssgrad*
2108 c     &      evdwij,fac,sigma(itypi,itypj),expon
2109               fac=fac+evdwij*sssgrad/sss*rij
2110 c            fac=0.0d0
2111 C Calculate the radial part of the gradient
2112               gg_lipi(3)=eps1*(eps2rt*eps2rt)
2113      &          *(eps3rt*eps3rt)*sss/2.0d0*(faclip*faclip*
2114      &           (aa_lip(itypi,itypj)-aa_aq(itypi,itypj))
2115      &          +faclip*(bb_lip(itypi,itypj)-bb_aq(itypi,itypj)))
2116               gg_lipj(3)=ssgradlipj*gg_lipi(3)
2117               gg_lipi(3)=gg_lipi(3)*ssgradlipi
2118 C            gg_lipi(3)=0.0d0
2119 C            gg_lipj(3)=0.0d0
2120               gg(1)=xj*fac
2121               gg(2)=yj*fac
2122               gg(3)=zj*fac
2123 C Calculate angular part of the gradient.
2124 c            call sc_grad_scale(sss)
2125               call sc_grad
2126             ENDIF    ! dyn_ss
2127 c          enddo      ! j
2128 c        enddo        ! iint
2129       enddo          ! i
2130 C      enddo          ! zshift
2131 C      enddo          ! yshift
2132 C      enddo          ! xshift
2133 c      write (iout,*) "Number of loop steps in EGB:",ind
2134 cccc      energy_dec=.false.
2135       return
2136       end
2137 C-----------------------------------------------------------------------------
2138       subroutine egbv(evdw)
2139 C
2140 C This subroutine calculates the interaction energy of nonbonded side chains
2141 C assuming the Gay-Berne-Vorobjev potential of interaction.
2142 C
2143       implicit none
2144       include 'DIMENSIONS'
2145       include 'COMMON.GEO'
2146       include 'COMMON.VAR'
2147       include 'COMMON.LOCAL'
2148       include 'COMMON.CHAIN'
2149       include 'COMMON.DERIV'
2150       include 'COMMON.NAMES'
2151       include 'COMMON.INTERACT'
2152       include 'COMMON.IOUNITS'
2153       include 'COMMON.CALC'
2154       include 'COMMON.SPLITELE'
2155       double precision boxshift
2156       integer icall
2157       common /srutu/ icall
2158       logical lprn
2159       double precision evdw
2160       integer itypi,itypj,itypi1,iint,ind,ikont
2161       double precision eps0ij,epsi,sigm,fac,e1,e2,rrij,r0ij,
2162      & xi,yi,zi,fac_augm,e_augm
2163       double precision fracinbuf,sslipi,evdwij_przed_tri,sig0ij,
2164      & sslipj,ssgradlipj,ssgradlipi,sig,rij_shift,faclip,sssgrad1
2165       double precision dist,sscale,sscagrad,sscagradlip,sscalelip
2166       evdw=0.0D0
2167 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
2168       evdw=0.0D0
2169       lprn=.false.
2170 c     if (icall.eq.0) lprn=.true.
2171       ind=0
2172 c      do i=iatsc_s,iatsc_e
2173       do ikont=g_listscsc_start,g_listscsc_end
2174         i=newcontlisti(ikont)
2175         j=newcontlistj(ikont)
2176         itypi=iabs(itype(i))
2177         if (itypi.eq.ntyp1) cycle
2178         itypi1=iabs(itype(i+1))
2179         xi=c(1,nres+i)
2180         yi=c(2,nres+i)
2181         zi=c(3,nres+i)
2182         call to_box(xi,yi,zi)
2183 C define scaling factor for lipids
2184
2185 C        if (positi.le.0) positi=positi+boxzsize
2186 C        print *,i
2187 C first for peptide groups
2188 c for each residue check if it is in lipid or lipid water border area
2189         call lipid_layer(xi,yi,zi,sslipi,ssgradlipi)
2190         dxi=dc_norm(1,nres+i)
2191         dyi=dc_norm(2,nres+i)
2192         dzi=dc_norm(3,nres+i)
2193 c        dsci_inv=dsc_inv(itypi)
2194         dsci_inv=vbld_inv(i+nres)
2195 C
2196 C Calculate SC interaction energy.
2197 C
2198 c        do iint=1,nint_gr(i)
2199 c          do j=istart(i,iint),iend(i,iint)
2200             ind=ind+1
2201             itypj=iabs(itype(j))
2202             if (itypj.eq.ntyp1) cycle
2203 c            dscj_inv=dsc_inv(itypj)
2204             dscj_inv=vbld_inv(j+nres)
2205             sig0ij=sigma(itypi,itypj)
2206             r0ij=r0(itypi,itypj)
2207             chi1=chi(itypi,itypj)
2208             chi2=chi(itypj,itypi)
2209             chi12=chi1*chi2
2210             chip1=chip(itypi)
2211             chip2=chip(itypj)
2212             chip12=chip1*chip2
2213             alf1=alp(itypi)
2214             alf2=alp(itypj)
2215             alf12=0.5D0*(alf1+alf2)
2216 C For diagnostics only!!!
2217 c           chi1=0.0D0
2218 c           chi2=0.0D0
2219 c           chi12=0.0D0
2220 c           chip1=0.0D0
2221 c           chip2=0.0D0
2222 c           chip12=0.0D0
2223 c           alf1=0.0D0
2224 c           alf2=0.0D0
2225 c           alf12=0.0D0
2226            xj=c(1,nres+j)
2227            yj=c(2,nres+j)
2228            zj=c(3,nres+j)
2229            call to_box(xj,yj,zj)
2230            call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
2231            aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
2232      &       +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
2233            bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
2234      &       +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
2235 C      if (aa.ne.aa_aq(itypi,itypj)) write(63,'2e10.5')
2236 C     &(aa-aa_aq(itypi,itypj)),(bb-bb_aq(itypi,itypj))
2237 C      write(iout,*) "tu,", i,j,aa,bb,aa_lip(itypi,itypj),sslipi,sslipj
2238            xj=boxshift(xj-xi,boxxsize)
2239            yj=boxshift(yj-yi,boxysize)
2240            zj=boxshift(zj-zi,boxzsize)
2241            dxj=dc_norm(1,nres+j)
2242            dyj=dc_norm(2,nres+j)
2243            dzj=dc_norm(3,nres+j)
2244            rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
2245            rij=dsqrt(rrij)
2246            sss=sscale(1.0d0/rij,r_cut_int)
2247            if (sss.eq.0.0d0) cycle
2248            sssgrad=sscagrad(1.0d0/rij,r_cut_int)
2249 C Calculate angle-dependent terms of energy and contributions to their
2250 C derivatives.
2251            call sc_angular
2252            sigsq=1.0D0/sigsq
2253            sig=sig0ij*dsqrt(sigsq)
2254            rij_shift=1.0D0/rij-sig+r0ij
2255 C I hate to put IF's in the loops, but here don't have another choice!!!!
2256            if (rij_shift.le.0.0D0) then
2257              evdw=1.0D20
2258              return
2259            endif
2260            sigder=-sig*sigsq
2261 c---------------------------------------------------------------
2262            rij_shift=1.0D0/rij_shift
2263            fac=rij_shift**expon
2264            e1=fac*fac*aa
2265            e2=fac*bb
2266            evdwij=eps1*eps2rt*eps3rt*(e1+e2)
2267            eps2der=evdwij*eps3rt
2268            eps3der=evdwij*eps2rt
2269            fac_augm=rrij**expon
2270            e_augm=augm(itypi,itypj)*fac_augm
2271            evdwij=evdwij*eps2rt*eps3rt
2272            evdw=evdw+evdwij+e_augm
2273            if (lprn) then
2274              sigm=dabs(aa/bb)**(1.0D0/6.0D0)
2275              epsi=bb**2/aa
2276              write (iout,'(2(a3,i3,2x),17(0pf7.3))')
2277      &        restyp(itypi),i,restyp(itypj),j,
2278      &        epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),
2279      &        chi1,chi2,chip1,chip2,
2280      &        eps1,eps2rt**2,eps3rt**2,
2281      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
2282      &        evdwij+e_augm
2283            endif
2284 C Calculate gradient components.
2285            e1=e1*eps1*eps2rt**2*eps3rt**2
2286            fac=-expon*(e1+evdwij)*rij_shift
2287            sigder=fac*sigder
2288            fac=rij*fac-2*expon*rrij*e_augm
2289            fac=fac+(evdwij+e_augm)*sssgrad/sss*rij
2290 C Calculate the radial part of the gradient
2291            gg(1)=xj*fac
2292            gg(2)=yj*fac
2293            gg(3)=zj*fac
2294 C Calculate angular part of the gradient.
2295 c            call sc_grad_scale(sss)
2296            call sc_grad
2297 c          enddo      ! j
2298 c        enddo        ! iint
2299       enddo          ! i
2300       end
2301 C-----------------------------------------------------------------------------
2302       subroutine sc_angular
2303 C Calculate eps1,eps2,eps3,sigma, and parts of their derivatives in om1,om2,
2304 C om12. Called by ebp, egb, and egbv.
2305       implicit none
2306       include 'COMMON.CALC'
2307       include 'COMMON.IOUNITS'
2308       erij(1)=xj*rij
2309       erij(2)=yj*rij
2310       erij(3)=zj*rij
2311       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
2312       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
2313       om12=dxi*dxj+dyi*dyj+dzi*dzj
2314       chiom12=chi12*om12
2315 C Calculate eps1(om12) and its derivative in om12
2316       faceps1=1.0D0-om12*chiom12
2317       faceps1_inv=1.0D0/faceps1
2318       eps1=dsqrt(faceps1_inv)
2319 C Following variable is eps1*deps1/dom12
2320       eps1_om12=faceps1_inv*chiom12
2321 c diagnostics only
2322 c      faceps1_inv=om12
2323 c      eps1=om12
2324 c      eps1_om12=1.0d0
2325 c      write (iout,*) "om12",om12," eps1",eps1
2326 C Calculate sigma(om1,om2,om12) and the derivatives of sigma**2 in om1,om2,
2327 C and om12.
2328       om1om2=om1*om2
2329       chiom1=chi1*om1
2330       chiom2=chi2*om2
2331       facsig=om1*chiom1+om2*chiom2-2.0D0*om1om2*chiom12
2332       sigsq=1.0D0-facsig*faceps1_inv
2333       sigsq_om1=(chiom1-chiom12*om2)*faceps1_inv
2334       sigsq_om2=(chiom2-chiom12*om1)*faceps1_inv
2335       sigsq_om12=-chi12*(om1om2*faceps1-om12*facsig)*faceps1_inv**2
2336 c diagnostics only
2337 c      sigsq=1.0d0
2338 c      sigsq_om1=0.0d0
2339 c      sigsq_om2=0.0d0
2340 c      sigsq_om12=0.0d0
2341 c      write (iout,*) "chiom1",chiom1," chiom2",chiom2," chiom12",chiom12
2342 c      write (iout,*) "faceps1",faceps1," faceps1_inv",faceps1_inv,
2343 c     &    " eps1",eps1
2344 C Calculate eps2 and its derivatives in om1, om2, and om12.
2345       chipom1=chip1*om1
2346       chipom2=chip2*om2
2347       chipom12=chip12*om12
2348       facp=1.0D0-om12*chipom12
2349       facp_inv=1.0D0/facp
2350       facp1=om1*chipom1+om2*chipom2-2.0D0*om1om2*chipom12
2351 c      write (iout,*) "chipom1",chipom1," chipom2",chipom2,
2352 c     &  " chipom12",chipom12," facp",facp," facp_inv",facp_inv
2353 C Following variable is the square root of eps2
2354       eps2rt=1.0D0-facp1*facp_inv
2355 C Following three variables are the derivatives of the square root of eps
2356 C in om1, om2, and om12.
2357       eps2rt_om1=-4.0D0*(chipom1-chipom12*om2)*facp_inv
2358       eps2rt_om2=-4.0D0*(chipom2-chipom12*om1)*facp_inv
2359       eps2rt_om12=4.0D0*chip12*(om1om2*facp-om12*facp1)*facp_inv**2
2360 C Evaluate the "asymmetric" factor in the VDW constant, eps3
2361       eps3rt=1.0D0-alf1*om1+alf2*om2-alf12*om12
2362 c      write (iout,*) "eps2rt",eps2rt," eps3rt",eps3rt
2363 c      write (iout,*) "eps2rt_om1",eps2rt_om1," eps2rt_om2",eps2rt_om2,
2364 c     &  " eps2rt_om12",eps2rt_om12
2365 C Calculate whole angle-dependent part of epsilon and contributions
2366 C to its derivatives
2367       return
2368       end
2369 C----------------------------------------------------------------------------
2370       subroutine sc_grad
2371       implicit real*8 (a-h,o-z)
2372       include 'DIMENSIONS'
2373       include 'COMMON.CHAIN'
2374       include 'COMMON.DERIV'
2375       include 'COMMON.CALC'
2376       include 'COMMON.IOUNITS'
2377       double precision dcosom1(3),dcosom2(3)
2378 cc      print *,'sss=',sss
2379       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
2380       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
2381       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12
2382      &     -2.0D0*alf12*eps3der+sigder*sigsq_om12
2383 c diagnostics only
2384 c      eom1=0.0d0
2385 c      eom2=0.0d0
2386 c      eom12=evdwij*eps1_om12
2387 c end diagnostics
2388 c      write (iout,*) "eps2der",eps2der," eps3der",eps3der,
2389 c     &  " sigder",sigder
2390 c      write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12
2391 c      write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12
2392       do k=1,3
2393         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
2394         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
2395       enddo
2396       do k=1,3
2397         gg(k)=(gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k))*sss
2398       enddo
2399 c      write (iout,*) "gg",(gg(k),k=1,3)
2400       do k=1,3
2401         gvdwx(k,i)=gvdwx(k,i)-gg(k)+gg_lipi(k)
2402      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
2403      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv*sss
2404         gvdwx(k,j)=gvdwx(k,j)+gg(k)+gg_lipj(k)
2405      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
2406      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv*sss
2407 c        write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
2408 c     &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
2409 c        write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
2410 c     &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
2411       enddo
2412 C
2413 C Calculate the components of the gradient in DC and X
2414 C
2415 cgrad      do k=i,j-1
2416 cgrad        do l=1,3
2417 cgrad          gvdwc(l,k)=gvdwc(l,k)+gg(l)
2418 cgrad        enddo
2419 cgrad      enddo
2420       do l=1,3
2421         gvdwc(l,i)=gvdwc(l,i)-gg(l)+gg_lipi(l)
2422         gvdwc(l,j)=gvdwc(l,j)+gg(l)+gg_lipj(l)
2423       enddo
2424       return
2425       end
2426 C-----------------------------------------------------------------------
2427       subroutine e_softsphere(evdw)
2428 C
2429 C This subroutine calculates the interaction energy of nonbonded side chains
2430 C assuming the LJ potential of interaction.
2431 C
2432       implicit real*8 (a-h,o-z)
2433       include 'DIMENSIONS'
2434       parameter (accur=1.0d-10)
2435       include 'COMMON.GEO'
2436       include 'COMMON.VAR'
2437       include 'COMMON.LOCAL'
2438       include 'COMMON.CHAIN'
2439       include 'COMMON.DERIV'
2440       include 'COMMON.INTERACT'
2441       include 'COMMON.TORSION'
2442       include 'COMMON.SBRIDGE'
2443       include 'COMMON.NAMES'
2444       include 'COMMON.IOUNITS'
2445 c      include 'COMMON.CONTACTS'
2446       dimension gg(3)
2447       double precision boxshift
2448 cd    print *,'Entering Esoft_sphere nnt=',nnt,' nct=',nct
2449       evdw=0.0D0
2450 c      do i=iatsc_s,iatsc_e
2451       do ikont=g_listscsc_start,g_listscsc_end
2452         i=newcontlisti(ikont)
2453         j=newcontlistj(ikont)
2454         itypi=iabs(itype(i))
2455         if (itypi.eq.ntyp1) cycle
2456         itypi1=iabs(itype(i+1))
2457         xi=c(1,nres+i)
2458         yi=c(2,nres+i)
2459         zi=c(3,nres+i)
2460         call to_box(xi,yi,zi)
2461 C
2462 C Calculate SC interaction energy.
2463 C
2464 c        do iint=1,nint_gr(i)
2465 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
2466 cd   &                  'iend=',iend(i,iint)
2467 c          do j=istart(i,iint),iend(i,iint)
2468             itypj=iabs(itype(j))
2469             if (itypj.eq.ntyp1) cycle
2470             xj=boxshift(c(1,nres+j)-xi,boxxsize)
2471             yj=boxshift(c(2,nres+j)-yi,boxysize)
2472             zj=boxshift(c(3,nres+j)-zi,boxzsize)
2473             rij=xj*xj+yj*yj+zj*zj
2474 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
2475             r0ij=r0(itypi,itypj)
2476             r0ijsq=r0ij*r0ij
2477 c            print *,i,j,r0ij,dsqrt(rij)
2478             if (rij.lt.r0ijsq) then
2479               evdwij=0.25d0*(rij-r0ijsq)**2
2480               fac=rij-r0ijsq
2481             else
2482               evdwij=0.0d0
2483               fac=0.0d0
2484             endif
2485             evdw=evdw+evdwij
2486 C
2487 C Calculate the components of the gradient in DC and X
2488 C
2489             gg(1)=xj*fac
2490             gg(2)=yj*fac
2491             gg(3)=zj*fac
2492             do k=1,3
2493               gvdwx(k,i)=gvdwx(k,i)-gg(k)
2494               gvdwx(k,j)=gvdwx(k,j)+gg(k)
2495               gvdwc(k,i)=gvdwc(k,i)-gg(k)
2496               gvdwc(k,j)=gvdwc(k,j)+gg(k)
2497             enddo
2498 cgrad            do k=i,j-1
2499 cgrad              do l=1,3
2500 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
2501 cgrad              enddo
2502 cgrad            enddo
2503 c          enddo ! j
2504 c        enddo ! iint
2505       enddo ! i
2506       return
2507       end
2508 C--------------------------------------------------------------------------
2509       subroutine eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,
2510      &              eello_turn4)
2511 C
2512 C Soft-sphere potential of p-p interaction
2513 C
2514       implicit real*8 (a-h,o-z)
2515       include 'DIMENSIONS'
2516       include 'COMMON.CONTROL'
2517       include 'COMMON.IOUNITS'
2518       include 'COMMON.GEO'
2519       include 'COMMON.VAR'
2520       include 'COMMON.LOCAL'
2521       include 'COMMON.CHAIN'
2522       include 'COMMON.DERIV'
2523       include 'COMMON.INTERACT'
2524 c      include 'COMMON.CONTACTS'
2525       include 'COMMON.TORSION'
2526       include 'COMMON.VECTORS'
2527       include 'COMMON.FFIELD'
2528       dimension ggg(3)
2529       double precision boxshift
2530 C      write(iout,*) 'In EELEC_soft_sphere'
2531       ees=0.0D0
2532       evdw1=0.0D0
2533       eel_loc=0.0d0
2534       eello_turn3=0.0d0
2535       eello_turn4=0.0d0
2536       ind=0
2537       do i=iatel_s,iatel_e
2538         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
2539         dxi=dc(1,i)
2540         dyi=dc(2,i)
2541         dzi=dc(3,i)
2542         xmedi=c(1,i)+0.5d0*dxi
2543         ymedi=c(2,i)+0.5d0*dyi
2544         zmedi=c(3,i)+0.5d0*dzi
2545         call to_box(xmedi,ymedi,zmedi)
2546         num_conti=0
2547 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
2548         do j=ielstart(i),ielend(i)
2549           if (itype(j).eq.ntyp1 .or. itype(j+1).eq.ntyp1) cycle
2550           ind=ind+1
2551           iteli=itel(i)
2552           itelj=itel(j)
2553           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
2554           r0ij=rpp(iteli,itelj)
2555           r0ijsq=r0ij*r0ij
2556           dxj=dc(1,j)
2557           dyj=dc(2,j)
2558           dzj=dc(3,j)
2559           xj=c(1,j)+0.5D0*dxj
2560           yj=c(2,j)+0.5D0*dyj
2561           zj=c(3,j)+0.5D0*dzj
2562           call to_box(xj,yj,zj)
2563           xj=boxshift(xj-xmedi,boxxsize)
2564           yj=boxshift(yj-ymedi,boxysize)
2565           zj=boxshift(zj-zmedi,boxzsize)
2566           rij=xj*xj+yj*yj+zj*zj
2567             sss=sscale(sqrt(rij),r_cut_int)
2568             sssgrad=sscagrad(sqrt(rij),r_cut_int)
2569           if (rij.lt.r0ijsq) then
2570             evdw1ij=0.25d0*(rij-r0ijsq)**2
2571             fac=rij-r0ijsq
2572           else
2573             evdw1ij=0.0d0
2574             fac=0.0d0
2575           endif
2576           evdw1=evdw1+evdw1ij*sss
2577 C
2578 C Calculate contributions to the Cartesian gradient.
2579 C
2580           ggg(1)=fac*xj*sssgrad
2581           ggg(2)=fac*yj*sssgrad
2582           ggg(3)=fac*zj*sssgrad
2583           do k=1,3
2584             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
2585             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
2586           enddo
2587 *
2588 * Loop over residues i+1 thru j-1.
2589 *
2590 cgrad          do k=i+1,j-1
2591 cgrad            do l=1,3
2592 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
2593 cgrad            enddo
2594 cgrad          enddo
2595         enddo ! j
2596       enddo   ! i
2597 cgrad      do i=nnt,nct-1
2598 cgrad        do k=1,3
2599 cgrad          gelc(k,i)=gelc(k,i)+0.5d0*gelc(k,i)
2600 cgrad        enddo
2601 cgrad        do j=i+1,nct-1
2602 cgrad          do k=1,3
2603 cgrad            gelc(k,i)=gelc(k,i)+gelc(k,j)
2604 cgrad          enddo
2605 cgrad        enddo
2606 cgrad      enddo
2607       return
2608       end
2609 c------------------------------------------------------------------------------
2610       subroutine vec_and_deriv
2611       implicit real*8 (a-h,o-z)
2612       include 'DIMENSIONS'
2613 #ifdef MPI
2614       include 'mpif.h'
2615 #endif
2616       include 'COMMON.IOUNITS'
2617       include 'COMMON.GEO'
2618       include 'COMMON.VAR'
2619       include 'COMMON.LOCAL'
2620       include 'COMMON.CHAIN'
2621       include 'COMMON.VECTORS'
2622       include 'COMMON.SETUP'
2623       include 'COMMON.TIME1'
2624       dimension uyder(3,3,2),uzder(3,3,2),vbld_inv_temp(2)
2625 C Compute the local reference systems. For reference system (i), the
2626 C X-axis points from CA(i) to CA(i+1), the Y axis is in the
2627 C CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
2628 #ifdef PARVEC
2629       do i=ivec_start,ivec_end
2630 #else
2631       do i=1,nres-1
2632 #endif
2633           if (i.eq.nres-1) then
2634 C Case of the last full residue
2635 C Compute the Z-axis
2636             call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
2637             costh=dcos(pi-theta(nres))
2638             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2639             do k=1,3
2640               uz(k,i)=fac*uz(k,i)
2641             enddo
2642 C Compute the derivatives of uz
2643             uzder(1,1,1)= 0.0d0
2644             uzder(2,1,1)=-dc_norm(3,i-1)
2645             uzder(3,1,1)= dc_norm(2,i-1)
2646             uzder(1,2,1)= dc_norm(3,i-1)
2647             uzder(2,2,1)= 0.0d0
2648             uzder(3,2,1)=-dc_norm(1,i-1)
2649             uzder(1,3,1)=-dc_norm(2,i-1)
2650             uzder(2,3,1)= dc_norm(1,i-1)
2651             uzder(3,3,1)= 0.0d0
2652             uzder(1,1,2)= 0.0d0
2653             uzder(2,1,2)= dc_norm(3,i)
2654             uzder(3,1,2)=-dc_norm(2,i)
2655             uzder(1,2,2)=-dc_norm(3,i)
2656             uzder(2,2,2)= 0.0d0
2657             uzder(3,2,2)= dc_norm(1,i)
2658             uzder(1,3,2)= dc_norm(2,i)
2659             uzder(2,3,2)=-dc_norm(1,i)
2660             uzder(3,3,2)= 0.0d0
2661 C Compute the Y-axis
2662             facy=fac
2663             do k=1,3
2664               uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
2665             enddo
2666 C Compute the derivatives of uy
2667             do j=1,3
2668               do k=1,3
2669                 uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i)
2670      &                        -dc_norm(k,i)*dc_norm(j,i-1)
2671                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2672               enddo
2673               uyder(j,j,1)=uyder(j,j,1)-costh
2674               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2675             enddo
2676             do j=1,2
2677               do k=1,3
2678                 do l=1,3
2679                   uygrad(l,k,j,i)=uyder(l,k,j)
2680                   uzgrad(l,k,j,i)=uzder(l,k,j)
2681                 enddo
2682               enddo
2683             enddo
2684             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2685             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2686             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2687             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2688           else
2689 C Other residues
2690 C Compute the Z-axis
2691             call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
2692             costh=dcos(pi-theta(i+2))
2693             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2694             do k=1,3
2695               uz(k,i)=fac*uz(k,i)
2696             enddo
2697 C Compute the derivatives of uz
2698             uzder(1,1,1)= 0.0d0
2699             uzder(2,1,1)=-dc_norm(3,i+1)
2700             uzder(3,1,1)= dc_norm(2,i+1)
2701             uzder(1,2,1)= dc_norm(3,i+1)
2702             uzder(2,2,1)= 0.0d0
2703             uzder(3,2,1)=-dc_norm(1,i+1)
2704             uzder(1,3,1)=-dc_norm(2,i+1)
2705             uzder(2,3,1)= dc_norm(1,i+1)
2706             uzder(3,3,1)= 0.0d0
2707             uzder(1,1,2)= 0.0d0
2708             uzder(2,1,2)= dc_norm(3,i)
2709             uzder(3,1,2)=-dc_norm(2,i)
2710             uzder(1,2,2)=-dc_norm(3,i)
2711             uzder(2,2,2)= 0.0d0
2712             uzder(3,2,2)= dc_norm(1,i)
2713             uzder(1,3,2)= dc_norm(2,i)
2714             uzder(2,3,2)=-dc_norm(1,i)
2715             uzder(3,3,2)= 0.0d0
2716 C Compute the Y-axis
2717             facy=fac
2718             do k=1,3
2719               uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
2720             enddo
2721 C Compute the derivatives of uy
2722             do j=1,3
2723               do k=1,3
2724                 uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i)
2725      &                        -dc_norm(k,i)*dc_norm(j,i+1)
2726                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2727               enddo
2728               uyder(j,j,1)=uyder(j,j,1)-costh
2729               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2730             enddo
2731             do j=1,2
2732               do k=1,3
2733                 do l=1,3
2734                   uygrad(l,k,j,i)=uyder(l,k,j)
2735                   uzgrad(l,k,j,i)=uzder(l,k,j)
2736                 enddo
2737               enddo
2738             enddo
2739             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2740             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2741             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2742             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2743           endif
2744       enddo
2745       do i=1,nres-1
2746         vbld_inv_temp(1)=vbld_inv(i+1)
2747         if (i.lt.nres-1) then
2748           vbld_inv_temp(2)=vbld_inv(i+2)
2749           else
2750           vbld_inv_temp(2)=vbld_inv(i)
2751           endif
2752         do j=1,2
2753           do k=1,3
2754             do l=1,3
2755               uygrad(l,k,j,i)=vbld_inv_temp(j)*uygrad(l,k,j,i)
2756               uzgrad(l,k,j,i)=vbld_inv_temp(j)*uzgrad(l,k,j,i)
2757             enddo
2758           enddo
2759         enddo
2760       enddo
2761 #if defined(PARVEC) && defined(MPI)
2762       if (nfgtasks1.gt.1) then
2763         time00=MPI_Wtime()
2764 c        print *,"Processor",fg_rank1,kolor1," ivec_start",ivec_start,
2765 c     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks1-1),
2766 c     &   " ivec_count",(ivec_count(i),i=0,nfgtasks1-1)
2767         call MPI_Allgatherv(uy(1,ivec_start),ivec_count(fg_rank1),
2768      &   MPI_UYZ,uy(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
2769      &   FG_COMM1,IERR)
2770         call MPI_Allgatherv(uz(1,ivec_start),ivec_count(fg_rank1),
2771      &   MPI_UYZ,uz(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
2772      &   FG_COMM1,IERR)
2773         call MPI_Allgatherv(uygrad(1,1,1,ivec_start),
2774      &   ivec_count(fg_rank1),MPI_UYZGRAD,uygrad(1,1,1,1),ivec_count(0),
2775      &   ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2776         call MPI_Allgatherv(uzgrad(1,1,1,ivec_start),
2777      &   ivec_count(fg_rank1),MPI_UYZGRAD,uzgrad(1,1,1,1),ivec_count(0),
2778      &   ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2779         time_gather=time_gather+MPI_Wtime()-time00
2780       endif
2781 #endif
2782 #ifdef DEBUG
2783       if (fg_rank.eq.0) then
2784         write (iout,*) "Arrays UY and UZ"
2785         do i=1,nres-1
2786           write (iout,'(i5,3f10.5,5x,3f10.5)') i,(uy(k,i),k=1,3),
2787      &     (uz(k,i),k=1,3)
2788         enddo
2789       endif
2790 #endif
2791       return
2792       end
2793 C--------------------------------------------------------------------------
2794       subroutine set_matrices
2795       implicit real*8 (a-h,o-z)
2796       include 'DIMENSIONS'
2797 #ifdef MPI
2798       include "mpif.h"
2799       include "COMMON.SETUP"
2800       integer IERR
2801       integer status(MPI_STATUS_SIZE)
2802 #endif
2803       include 'COMMON.IOUNITS'
2804       include 'COMMON.GEO'
2805       include 'COMMON.VAR'
2806       include 'COMMON.LOCAL'
2807       include 'COMMON.CHAIN'
2808       include 'COMMON.DERIV'
2809       include 'COMMON.INTERACT'
2810       include 'COMMON.CORRMAT'
2811       include 'COMMON.TORSION'
2812       include 'COMMON.VECTORS'
2813       include 'COMMON.FFIELD'
2814       double precision auxvec(2),auxmat(2,2)
2815 C
2816 C Compute the virtual-bond-torsional-angle dependent quantities needed
2817 C to calculate the el-loc multibody terms of various order.
2818 C
2819 c      write(iout,*) 'nphi=',nphi,nres
2820 c      write(iout,*) "itype2loc",itype2loc
2821 #ifdef PARMAT
2822       do i=ivec_start+2,ivec_end+2
2823 #else
2824       do i=3,nres+1
2825 #endif
2826         ii=ireschain(i-2)
2827 c        write (iout,*) "i",i,i-2," ii",ii
2828         if (ii.eq.0) cycle
2829         innt=chain_border(1,ii)
2830         inct=chain_border(2,ii)
2831 c        write (iout,*) "i",i,i-2," ii",ii," innt",innt," inct",inct
2832 c        if (i.gt. nnt+2 .and. i.lt.nct+2) then
2833         if (i.gt. innt+2 .and. i.lt.inct+2) then
2834           iti = itype2loc(itype(i-2))
2835         else
2836           iti=nloctyp
2837         endif
2838 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2839         if (i.gt. innt+1 .and. i.lt.inct+1) then
2840           iti1 = itype2loc(itype(i-1))
2841         else
2842           iti1=nloctyp
2843         endif
2844 c        write(iout,*),"i",i,i-2," iti",itype(i-2),iti,
2845 c     &  " iti1",itype(i-1),iti1
2846 #ifdef NEWCORR
2847         cost1=dcos(theta(i-1))
2848         sint1=dsin(theta(i-1))
2849         sint1sq=sint1*sint1
2850         sint1cub=sint1sq*sint1
2851         sint1cost1=2*sint1*cost1
2852 c        write (iout,*) "bnew1",i,iti
2853 c        write (iout,*) (bnew1(k,1,iti),k=1,3)
2854 c        write (iout,*) (bnew1(k,2,iti),k=1,3)
2855 c        write (iout,*) "bnew2",i,iti
2856 c        write (iout,*) (bnew2(k,1,iti),k=1,3)
2857 c        write (iout,*) (bnew2(k,2,iti),k=1,3)
2858         do k=1,2
2859           b1k=bnew1(1,k,iti)+(bnew1(2,k,iti)+bnew1(3,k,iti)*cost1)*cost1
2860           b1(k,i-2)=sint1*b1k
2861           gtb1(k,i-2)=cost1*b1k-sint1sq*
2862      &              (bnew1(2,k,iti)+2*bnew1(3,k,iti)*cost1)
2863           b2k=bnew2(1,k,iti)+(bnew2(2,k,iti)+bnew2(3,k,iti)*cost1)*cost1
2864           b2(k,i-2)=sint1*b2k
2865           gtb2(k,i-2)=cost1*b2k-sint1sq*
2866      &              (bnew2(2,k,iti)+2*bnew2(3,k,iti)*cost1)
2867         enddo
2868         do k=1,2
2869           aux=ccnew(1,k,iti)+(ccnew(2,k,iti)+ccnew(3,k,iti)*cost1)*cost1
2870           cc(1,k,i-2)=sint1sq*aux
2871           gtcc(1,k,i-2)=sint1cost1*aux-sint1cub*
2872      &              (ccnew(2,k,iti)+2*ccnew(3,k,iti)*cost1)
2873           aux=ddnew(1,k,iti)+(ddnew(2,k,iti)+ddnew(3,k,iti)*cost1)*cost1
2874           dd(1,k,i-2)=sint1sq*aux
2875           gtdd(1,k,i-2)=sint1cost1*aux-sint1cub*
2876      &              (ddnew(2,k,iti)+2*ddnew(3,k,iti)*cost1)
2877         enddo
2878         cc(2,1,i-2)=cc(1,2,i-2)
2879         cc(2,2,i-2)=-cc(1,1,i-2)
2880         gtcc(2,1,i-2)=gtcc(1,2,i-2)
2881         gtcc(2,2,i-2)=-gtcc(1,1,i-2)
2882         dd(2,1,i-2)=dd(1,2,i-2)
2883         dd(2,2,i-2)=-dd(1,1,i-2)
2884         gtdd(2,1,i-2)=gtdd(1,2,i-2)
2885         gtdd(2,2,i-2)=-gtdd(1,1,i-2)
2886         do k=1,2
2887           do l=1,2
2888             aux=eenew(1,l,k,iti)+eenew(2,l,k,iti)*cost1
2889             EE(l,k,i-2)=sint1sq*aux
2890             gtEE(l,k,i-2)=sint1cost1*aux-sint1cub*eenew(2,l,k,iti)
2891           enddo
2892         enddo
2893         EE(1,1,i-2)=EE(1,1,i-2)+e0new(1,iti)*cost1
2894         EE(1,2,i-2)=EE(1,2,i-2)+e0new(2,iti)+e0new(3,iti)*cost1
2895         EE(2,1,i-2)=EE(2,1,i-2)+e0new(2,iti)*cost1+e0new(3,iti)
2896         EE(2,2,i-2)=EE(2,2,i-2)-e0new(1,iti)
2897         gtEE(1,1,i-2)=gtEE(1,1,i-2)-e0new(1,iti)*sint1
2898         gtEE(1,2,i-2)=gtEE(1,2,i-2)-e0new(3,iti)*sint1
2899         gtEE(2,1,i-2)=gtEE(2,1,i-2)-e0new(2,iti)*sint1
2900 c        b1tilde(1,i-2)=b1(1,i-2)
2901 c        b1tilde(2,i-2)=-b1(2,i-2)
2902 c        b2tilde(1,i-2)=b2(1,i-2)
2903 c        b2tilde(2,i-2)=-b2(2,i-2)
2904 #ifdef DEBUG
2905         write (iout,*) 'i=',i-2,gtb1(2,i-2),gtb1(1,i-2)
2906         write(iout,*)  'b1=',(b1(k,i-2),k=1,2)
2907         write(iout,*)  'b2=',(b2(k,i-2),k=1,2)
2908         write (iout,*) 'theta=', theta(i-1)
2909 #endif
2910 #else
2911         if (i.gt. innt+2 .and. i.lt.inct+2) then
2912 c        if (i.gt. nnt+2 .and. i.lt.nct+2) then
2913           iti = itype2loc(itype(i-2))
2914         else
2915           iti=nloctyp
2916         endif
2917 c        write (iout,*) "i",i-1," itype",itype(i-2)," iti",iti
2918 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2919         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2920           iti1 = itype2loc(itype(i-1))
2921         else
2922           iti1=nloctyp
2923         endif
2924         b1(1,i-2)=b(3,iti)
2925         b1(2,i-2)=b(5,iti)
2926         b2(1,i-2)=b(2,iti)
2927         b2(2,i-2)=b(4,iti)
2928         do k=1,2
2929           do l=1,2
2930            CC(k,l,i-2)=ccold(k,l,iti)
2931            DD(k,l,i-2)=ddold(k,l,iti)
2932            EE(k,l,i-2)=eeold(k,l,iti)
2933            gtEE(k,l,i-2)=0.0d0
2934           enddo
2935         enddo
2936 #endif
2937         b1tilde(1,i-2)= b1(1,i-2)
2938         b1tilde(2,i-2)=-b1(2,i-2)
2939         b2tilde(1,i-2)= b2(1,i-2)
2940         b2tilde(2,i-2)=-b2(2,i-2)
2941 c
2942         Ctilde(1,1,i-2)= CC(1,1,i-2)
2943         Ctilde(1,2,i-2)= CC(1,2,i-2)
2944         Ctilde(2,1,i-2)=-CC(2,1,i-2)
2945         Ctilde(2,2,i-2)=-CC(2,2,i-2)
2946 c
2947         Dtilde(1,1,i-2)= DD(1,1,i-2)
2948         Dtilde(1,2,i-2)= DD(1,2,i-2)
2949         Dtilde(2,1,i-2)=-DD(2,1,i-2)
2950         Dtilde(2,2,i-2)=-DD(2,2,i-2)
2951 #ifdef DEBUG
2952         write(iout,*) "i",i," iti",iti
2953         write(iout,*)  'b1=',(b1(k,i-2),k=1,2)
2954         write(iout,*)  'b2=',(b2(k,i-2),k=1,2)
2955 #endif
2956       enddo
2957       mu=0.0d0
2958 #ifdef PARMAT
2959       do i=ivec_start+2,ivec_end+2
2960 #else
2961       do i=3,nres+1
2962 #endif
2963 c        if (itype(i-1).eq.ntyp1 .and. itype(i).eq.ntyp1) cycle
2964         if (i .lt. nres+1 .and. itype(i-1).lt.ntyp1) then
2965           sin1=dsin(phi(i))
2966           cos1=dcos(phi(i))
2967           sintab(i-2)=sin1
2968           costab(i-2)=cos1
2969           obrot(1,i-2)=cos1
2970           obrot(2,i-2)=sin1
2971           sin2=dsin(2*phi(i))
2972           cos2=dcos(2*phi(i))
2973           sintab2(i-2)=sin2
2974           costab2(i-2)=cos2
2975           obrot2(1,i-2)=cos2
2976           obrot2(2,i-2)=sin2
2977           Ug(1,1,i-2)=-cos1
2978           Ug(1,2,i-2)=-sin1
2979           Ug(2,1,i-2)=-sin1
2980           Ug(2,2,i-2)= cos1
2981           Ug2(1,1,i-2)=-cos2
2982           Ug2(1,2,i-2)=-sin2
2983           Ug2(2,1,i-2)=-sin2
2984           Ug2(2,2,i-2)= cos2
2985         else
2986           costab(i-2)=1.0d0
2987           sintab(i-2)=0.0d0
2988           obrot(1,i-2)=1.0d0
2989           obrot(2,i-2)=0.0d0
2990           obrot2(1,i-2)=0.0d0
2991           obrot2(2,i-2)=0.0d0
2992           Ug(1,1,i-2)=1.0d0
2993           Ug(1,2,i-2)=0.0d0
2994           Ug(2,1,i-2)=0.0d0
2995           Ug(2,2,i-2)=1.0d0
2996           Ug2(1,1,i-2)=0.0d0
2997           Ug2(1,2,i-2)=0.0d0
2998           Ug2(2,1,i-2)=0.0d0
2999           Ug2(2,2,i-2)=0.0d0
3000         endif
3001         if (i .gt. 3) then
3002           obrot_der(1,i-2)=-sin1
3003           obrot_der(2,i-2)= cos1
3004           Ugder(1,1,i-2)= sin1
3005           Ugder(1,2,i-2)=-cos1
3006           Ugder(2,1,i-2)=-cos1
3007           Ugder(2,2,i-2)=-sin1
3008           dwacos2=cos2+cos2
3009           dwasin2=sin2+sin2
3010           obrot2_der(1,i-2)=-dwasin2
3011           obrot2_der(2,i-2)= dwacos2
3012           Ug2der(1,1,i-2)= dwasin2
3013           Ug2der(1,2,i-2)=-dwacos2
3014           Ug2der(2,1,i-2)=-dwacos2
3015           Ug2der(2,2,i-2)=-dwasin2
3016         else
3017           obrot_der(1,i-2)=0.0d0
3018           obrot_der(2,i-2)=0.0d0
3019           Ugder(1,1,i-2)=0.0d0
3020           Ugder(1,2,i-2)=0.0d0
3021           Ugder(2,1,i-2)=0.0d0
3022           Ugder(2,2,i-2)=0.0d0
3023           obrot2_der(1,i-2)=0.0d0
3024           obrot2_der(2,i-2)=0.0d0
3025           Ug2der(1,1,i-2)=0.0d0
3026           Ug2der(1,2,i-2)=0.0d0
3027           Ug2der(2,1,i-2)=0.0d0
3028           Ug2der(2,2,i-2)=0.0d0
3029         endif
3030 c        if (i.gt. iatel_s+2 .and. i.lt.iatel_e+5) then
3031 c        if (i.gt. nnt+2 .and. i.lt.nct+2) then
3032         if (i.gt.nnt+2 .and.i.lt.nct+2) then
3033           iti = itype2loc(itype(i-2))
3034         else
3035           iti=nloctyp
3036         endif
3037 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
3038         if (i.gt. nnt+1 .and. i.lt.nct+1) then
3039           iti1 = itype2loc(itype(i-1))
3040         else
3041           iti1=nloctyp
3042         endif
3043 cd        write (iout,*) '*******i',i,' iti1',iti
3044 cd        write (iout,*) 'b1',b1(:,iti)
3045 cd        write (iout,*) 'b2',b2(:,iti)
3046 cd        write (iout,*) 'Ug',Ug(:,:,i-2)
3047 c        if (i .gt. iatel_s+2) then
3048         if (i .gt. nnt+2) then
3049           call matvec2(Ug(1,1,i-2),b2(1,i-2),Ub2(1,i-2))
3050 #ifdef NEWCORR
3051           call matvec2(Ug(1,1,i-2),gtb2(1,i-2),gUb2(1,i-2))
3052 c          write (iout,*) Ug(1,1,i-2),gtb2(1,i-2),gUb2(1,i-2),"chuj"
3053 #endif
3054 c          write(iout,*) "co jest kurwa", iti, EE(1,1,i),EE(2,1,i),
3055 c     &    EE(1,2,iti),EE(2,2,i)
3056           call matmat2(EE(1,1,i-2),Ug(1,1,i-2),EUg(1,1,i-2))
3057           call matmat2(gtEE(1,1,i-2),Ug(1,1,i-2),gtEUg(1,1,i-2))
3058 c          write(iout,*) "Macierz EUG",
3059 c     &    eug(1,1,i-2),eug(1,2,i-2),eug(2,1,i-2),
3060 c     &    eug(2,2,i-2)
3061 #ifdef FOURBODY
3062           if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
3063      &    then
3064           call matmat2(CC(1,1,i-2),Ug(1,1,i-2),CUg(1,1,i-2))
3065           call matmat2(DD(1,1,i-2),Ug(1,1,i-2),DUg(1,1,i-2))
3066           call matmat2(Dtilde(1,1,i-2),Ug2(1,1,i-2),DtUg2(1,1,i-2))
3067           call matvec2(Ctilde(1,1,i-1),obrot(1,i-2),Ctobr(1,i-2))
3068           call matvec2(Dtilde(1,1,i-2),obrot2(1,i-2),Dtobr2(1,i-2))
3069           endif
3070 #endif
3071         else
3072           do k=1,2
3073             Ub2(k,i-2)=0.0d0
3074             Ctobr(k,i-2)=0.0d0
3075             Dtobr2(k,i-2)=0.0d0
3076             do l=1,2
3077               EUg(l,k,i-2)=0.0d0
3078               CUg(l,k,i-2)=0.0d0
3079               DUg(l,k,i-2)=0.0d0
3080               DtUg2(l,k,i-2)=0.0d0
3081             enddo
3082           enddo
3083         endif
3084         call matvec2(Ugder(1,1,i-2),b2(1,i-2),Ub2der(1,i-2))
3085         call matmat2(EE(1,1,i-2),Ugder(1,1,i-2),EUgder(1,1,i-2))
3086         do k=1,2
3087           muder(k,i-2)=Ub2der(k,i-2)
3088         enddo
3089 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
3090         if (i.gt. nnt+1 .and. i.lt.nct+1) then
3091           if (itype(i-1).le.ntyp) then
3092             iti1 = itype2loc(itype(i-1))
3093           else
3094             iti1=nloctyp
3095           endif
3096         else
3097           iti1=nloctyp
3098         endif
3099         do k=1,2
3100           mu(k,i-2)=Ub2(k,i-2)+b1(k,i-1)
3101 c          mu(k,i-2)=b1(k,i-1)
3102 c          mu(k,i-2)=Ub2(k,i-2)
3103         enddo
3104 #ifdef MUOUT
3105         write (iout,'(2hmu,i3,3f8.1,12f10.5)') i-2,rad2deg*theta(i-1),
3106      &     rad2deg*theta(i),rad2deg*phi(i),mu(1,i-2),mu(2,i-2),
3107      &       -b2(1,i-2),b2(2,i-2),b1(1,i-2),b1(2,i-2),
3108      &       dsqrt(b2(1,i-1)**2+b2(2,i-1)**2)
3109      &      +dsqrt(b1(1,i-1)**2+b1(2,i-1)**2),
3110      &      ((ee(l,k,i-2),l=1,2),k=1,2)
3111 #endif
3112 cd        write (iout,*) 'mu1',mu1(:,i-2)
3113 cd        write (iout,*) 'mu2',mu2(:,i-2)
3114 cd        write (iout,*) 'mu',i-2,mu(:,i-2)
3115 #ifdef FOURBODY
3116         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
3117      &  then
3118         call matmat2(CC(1,1,i-1),Ugder(1,1,i-2),CUgder(1,1,i-2))
3119         call matmat2(DD(1,1,i-2),Ugder(1,1,i-2),DUgder(1,1,i-2))
3120         call matmat2(Dtilde(1,1,i-2),Ug2der(1,1,i-2),DtUg2der(1,1,i-2))
3121         call matvec2(Ctilde(1,1,i-1),obrot_der(1,i-2),Ctobrder(1,i-2))
3122         call matvec2(Dtilde(1,1,i-2),obrot2_der(1,i-2),Dtobr2der(1,i-2))
3123 C Vectors and matrices dependent on a single virtual-bond dihedral.
3124         call matvec2(DD(1,1,i-2),b1tilde(1,i-1),auxvec(1))
3125         call matvec2(Ug2(1,1,i-2),auxvec(1),Ug2Db1t(1,i-2))
3126         call matvec2(Ug2der(1,1,i-2),auxvec(1),Ug2Db1tder(1,i-2))
3127         call matvec2(CC(1,1,i-1),Ub2(1,i-2),CUgb2(1,i-2))
3128         call matvec2(CC(1,1,i-1),Ub2der(1,i-2),CUgb2der(1,i-2))
3129         call matmat2(EUg(1,1,i-2),CC(1,1,i-1),EUgC(1,1,i-2))
3130         call matmat2(EUgder(1,1,i-2),CC(1,1,i-1),EUgCder(1,1,i-2))
3131         call matmat2(EUg(1,1,i-2),DD(1,1,i-1),EUgD(1,1,i-2))
3132         call matmat2(EUgder(1,1,i-2),DD(1,1,i-1),EUgDder(1,1,i-2))
3133         endif
3134 #endif
3135       enddo
3136 #ifdef FOURBODY
3137 C Matrices dependent on two consecutive virtual-bond dihedrals.
3138 C The order of matrices is from left to right.
3139       if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
3140      &then
3141 c      do i=max0(ivec_start,2),ivec_end
3142       do i=2,nres-1
3143         call matmat2(DtUg2(1,1,i-1),EUg(1,1,i),DtUg2EUg(1,1,i))
3144         call matmat2(DtUg2der(1,1,i-1),EUg(1,1,i),DtUg2EUgder(1,1,1,i))
3145         call matmat2(DtUg2(1,1,i-1),EUgder(1,1,i),DtUg2EUgder(1,1,2,i))
3146         call transpose2(DtUg2(1,1,i-1),auxmat(1,1))
3147         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUg(1,1,i))
3148         call matmat2(auxmat(1,1),EUgder(1,1,i),Ug2DtEUgder(1,1,2,i))
3149         call transpose2(DtUg2der(1,1,i-1),auxmat(1,1))
3150         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUgder(1,1,1,i))
3151       enddo
3152       endif
3153 #endif
3154 #if defined(MPI) && defined(PARMAT)
3155 #ifdef DEBUG
3156 c      if (fg_rank.eq.0) then
3157         write (iout,*) "Arrays UG and UGDER before GATHER"
3158         do i=1,nres-1
3159           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3160      &     ((ug(l,k,i),l=1,2),k=1,2),
3161      &     ((ugder(l,k,i),l=1,2),k=1,2)
3162         enddo
3163         write (iout,*) "Arrays UG2 and UG2DER"
3164         do i=1,nres-1
3165           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3166      &     ((ug2(l,k,i),l=1,2),k=1,2),
3167      &     ((ug2der(l,k,i),l=1,2),k=1,2)
3168         enddo
3169         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
3170         do i=1,nres-1
3171           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3172      &     (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
3173      &     (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
3174         enddo
3175         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
3176         do i=1,nres-1
3177           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3178      &     costab(i),sintab(i),costab2(i),sintab2(i)
3179         enddo
3180         write (iout,*) "Array MUDER"
3181         do i=1,nres-1
3182           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
3183         enddo
3184 c      endif
3185 #endif
3186       if (nfgtasks.gt.1) then
3187         time00=MPI_Wtime()
3188 c        write(iout,*)"Processor",fg_rank,kolor," ivec_start",ivec_start,
3189 c     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks-1),
3190 c     &   " ivec_count",(ivec_count(i),i=0,nfgtasks-1)
3191 #ifdef MATGATHER
3192         call MPI_Allgatherv(Ub2(1,ivec_start),ivec_count(fg_rank1),
3193      &   MPI_MU,Ub2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3194      &   FG_COMM1,IERR)
3195         call MPI_Allgatherv(Ub2der(1,ivec_start),ivec_count(fg_rank1),
3196      &   MPI_MU,Ub2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3197      &   FG_COMM1,IERR)
3198         call MPI_Allgatherv(mu(1,ivec_start),ivec_count(fg_rank1),
3199      &   MPI_MU,mu(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3200      &   FG_COMM1,IERR)
3201         call MPI_Allgatherv(muder(1,ivec_start),ivec_count(fg_rank1),
3202      &   MPI_MU,muder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3203      &   FG_COMM1,IERR)
3204         call MPI_Allgatherv(Eug(1,1,ivec_start),ivec_count(fg_rank1),
3205      &   MPI_MAT1,Eug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3206      &   FG_COMM1,IERR)
3207         call MPI_Allgatherv(Eugder(1,1,ivec_start),ivec_count(fg_rank1),
3208      &   MPI_MAT1,Eugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3209      &   FG_COMM1,IERR)
3210         call MPI_Allgatherv(costab(ivec_start),ivec_count(fg_rank1),
3211      &   MPI_DOUBLE_PRECISION,costab(1),ivec_count(0),ivec_displ(0),
3212      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3213         call MPI_Allgatherv(sintab(ivec_start),ivec_count(fg_rank1),
3214      &   MPI_DOUBLE_PRECISION,sintab(1),ivec_count(0),ivec_displ(0),
3215      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3216         call MPI_Allgatherv(costab2(ivec_start),ivec_count(fg_rank1),
3217      &   MPI_DOUBLE_PRECISION,costab2(1),ivec_count(0),ivec_displ(0),
3218      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3219         call MPI_Allgatherv(sintab2(ivec_start),ivec_count(fg_rank1),
3220      &   MPI_DOUBLE_PRECISION,sintab2(1),ivec_count(0),ivec_displ(0),
3221      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3222 #ifdef FOURBODY
3223         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
3224      &  then
3225         call MPI_Allgatherv(Ctobr(1,ivec_start),ivec_count(fg_rank1),
3226      &   MPI_MU,Ctobr(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3227      &   FG_COMM1,IERR)
3228         call MPI_Allgatherv(Ctobrder(1,ivec_start),ivec_count(fg_rank1),
3229      &   MPI_MU,Ctobrder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3230      &   FG_COMM1,IERR)
3231         call MPI_Allgatherv(Dtobr2(1,ivec_start),ivec_count(fg_rank1),
3232      &   MPI_MU,Dtobr2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3233      &   FG_COMM1,IERR)
3234        call MPI_Allgatherv(Dtobr2der(1,ivec_start),ivec_count(fg_rank1),
3235      &   MPI_MU,Dtobr2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3236      &   FG_COMM1,IERR)
3237         call MPI_Allgatherv(Ug2Db1t(1,ivec_start),ivec_count(fg_rank1),
3238      &   MPI_MU,Ug2Db1t(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3239      &   FG_COMM1,IERR)
3240         call MPI_Allgatherv(Ug2Db1tder(1,ivec_start),
3241      &   ivec_count(fg_rank1),
3242      &   MPI_MU,Ug2Db1tder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3243      &   FG_COMM1,IERR)
3244         call MPI_Allgatherv(CUgb2(1,ivec_start),ivec_count(fg_rank1),
3245      &   MPI_MU,CUgb2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3246      &   FG_COMM1,IERR)
3247         call MPI_Allgatherv(CUgb2der(1,ivec_start),ivec_count(fg_rank1),
3248      &   MPI_MU,CUgb2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3249      &   FG_COMM1,IERR)
3250         call MPI_Allgatherv(Cug(1,1,ivec_start),ivec_count(fg_rank1),
3251      &   MPI_MAT1,Cug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3252      &   FG_COMM1,IERR)
3253         call MPI_Allgatherv(Cugder(1,1,ivec_start),ivec_count(fg_rank1),
3254      &   MPI_MAT1,Cugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3255      &   FG_COMM1,IERR)
3256         call MPI_Allgatherv(Dug(1,1,ivec_start),ivec_count(fg_rank1),
3257      &   MPI_MAT1,Dug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3258      &   FG_COMM1,IERR)
3259         call MPI_Allgatherv(Dugder(1,1,ivec_start),ivec_count(fg_rank1),
3260      &   MPI_MAT1,Dugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3261      &   FG_COMM1,IERR)
3262         call MPI_Allgatherv(Dtug2(1,1,ivec_start),ivec_count(fg_rank1),
3263      &   MPI_MAT1,Dtug2(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3264      &   FG_COMM1,IERR)
3265         call MPI_Allgatherv(Dtug2der(1,1,ivec_start),
3266      &   ivec_count(fg_rank1),
3267      &   MPI_MAT1,Dtug2der(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3268      &   FG_COMM1,IERR)
3269         call MPI_Allgatherv(EugC(1,1,ivec_start),ivec_count(fg_rank1),
3270      &   MPI_MAT1,EugC(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3271      &   FG_COMM1,IERR)
3272        call MPI_Allgatherv(EugCder(1,1,ivec_start),ivec_count(fg_rank1),
3273      &   MPI_MAT1,EugCder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3274      &   FG_COMM1,IERR)
3275         call MPI_Allgatherv(EugD(1,1,ivec_start),ivec_count(fg_rank1),
3276      &   MPI_MAT1,EugD(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3277      &   FG_COMM1,IERR)
3278        call MPI_Allgatherv(EugDder(1,1,ivec_start),ivec_count(fg_rank1),
3279      &   MPI_MAT1,EugDder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3280      &   FG_COMM1,IERR)
3281         call MPI_Allgatherv(DtUg2EUg(1,1,ivec_start),
3282      &   ivec_count(fg_rank1),
3283      &   MPI_MAT1,DtUg2EUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3284      &   FG_COMM1,IERR)
3285         call MPI_Allgatherv(Ug2DtEUg(1,1,ivec_start),
3286      &   ivec_count(fg_rank1),
3287      &   MPI_MAT1,Ug2DtEUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3288      &   FG_COMM1,IERR)
3289         call MPI_Allgatherv(DtUg2EUgder(1,1,1,ivec_start),
3290      &   ivec_count(fg_rank1),
3291      &   MPI_MAT2,DtUg2EUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
3292      &   MPI_MAT2,FG_COMM1,IERR)
3293         call MPI_Allgatherv(Ug2DtEUgder(1,1,1,ivec_start),
3294      &   ivec_count(fg_rank1),
3295      &   MPI_MAT2,Ug2DtEUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
3296      &   MPI_MAT2,FG_COMM1,IERR)
3297         endif
3298 #endif
3299 #else
3300 c Passes matrix info through the ring
3301       isend=fg_rank1
3302       irecv=fg_rank1-1
3303       if (irecv.lt.0) irecv=nfgtasks1-1
3304       iprev=irecv
3305       inext=fg_rank1+1
3306       if (inext.ge.nfgtasks1) inext=0
3307       do i=1,nfgtasks1-1
3308 c        write (iout,*) "isend",isend," irecv",irecv
3309 c        call flush(iout)
3310         lensend=lentyp(isend)
3311         lenrecv=lentyp(irecv)
3312 c        write (iout,*) "lensend",lensend," lenrecv",lenrecv
3313 c        call MPI_SENDRECV(ug(1,1,ivec_displ(isend)+1),1,
3314 c     &   MPI_ROTAT1(lensend),inext,2200+isend,
3315 c     &   ug(1,1,ivec_displ(irecv)+1),1,MPI_ROTAT1(lenrecv),
3316 c     &   iprev,2200+irecv,FG_COMM,status,IERR)
3317 c        write (iout,*) "Gather ROTAT1"
3318 c        call flush(iout)
3319 c        call MPI_SENDRECV(obrot(1,ivec_displ(isend)+1),1,
3320 c     &   MPI_ROTAT2(lensend),inext,3300+isend,
3321 c     &   obrot(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
3322 c     &   iprev,3300+irecv,FG_COMM,status,IERR)
3323 c        write (iout,*) "Gather ROTAT2"
3324 c        call flush(iout)
3325         call MPI_SENDRECV(costab(ivec_displ(isend)+1),1,
3326      &   MPI_ROTAT_OLD(lensend),inext,4400+isend,
3327      &   costab(ivec_displ(irecv)+1),1,MPI_ROTAT_OLD(lenrecv),
3328      &   iprev,4400+irecv,FG_COMM,status,IERR)
3329 c        write (iout,*) "Gather ROTAT_OLD"
3330 c        call flush(iout)
3331         call MPI_SENDRECV(mu(1,ivec_displ(isend)+1),1,
3332      &   MPI_PRECOMP11(lensend),inext,5500+isend,
3333      &   mu(1,ivec_displ(irecv)+1),1,MPI_PRECOMP11(lenrecv),
3334      &   iprev,5500+irecv,FG_COMM,status,IERR)
3335 c        write (iout,*) "Gather PRECOMP11"
3336 c        call flush(iout)
3337         call MPI_SENDRECV(Eug(1,1,ivec_displ(isend)+1),1,
3338      &   MPI_PRECOMP12(lensend),inext,6600+isend,
3339      &   Eug(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP12(lenrecv),
3340      &   iprev,6600+irecv,FG_COMM,status,IERR)
3341 c        write (iout,*) "Gather PRECOMP12"
3342 c        call flush(iout)
3343 #ifdef FOURBODY
3344         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
3345      &  then
3346         call MPI_SENDRECV(ug2db1t(1,ivec_displ(isend)+1),1,
3347      &   MPI_ROTAT2(lensend),inext,7700+isend,
3348      &   ug2db1t(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
3349      &   iprev,7700+irecv,FG_COMM,status,IERR)
3350 c        write (iout,*) "Gather PRECOMP21"
3351 c        call flush(iout)
3352         call MPI_SENDRECV(EUgC(1,1,ivec_displ(isend)+1),1,
3353      &   MPI_PRECOMP22(lensend),inext,8800+isend,
3354      &   EUgC(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP22(lenrecv),
3355      &   iprev,8800+irecv,FG_COMM,status,IERR)
3356 c        write (iout,*) "Gather PRECOMP22"
3357 c        call flush(iout)
3358         call MPI_SENDRECV(Ug2DtEUgder(1,1,1,ivec_displ(isend)+1),1,
3359      &   MPI_PRECOMP23(lensend),inext,9900+isend,
3360      &   Ug2DtEUgder(1,1,1,ivec_displ(irecv)+1),1,
3361      &   MPI_PRECOMP23(lenrecv),
3362      &   iprev,9900+irecv,FG_COMM,status,IERR)
3363 #endif
3364 c        write (iout,*) "Gather PRECOMP23"
3365 c        call flush(iout)
3366         endif
3367         isend=irecv
3368         irecv=irecv-1
3369         if (irecv.lt.0) irecv=nfgtasks1-1
3370       enddo
3371 #endif
3372         time_gather=time_gather+MPI_Wtime()-time00
3373       endif
3374 #ifdef DEBUG
3375 c      if (fg_rank.eq.0) then
3376         write (iout,*) "Arrays UG and UGDER"
3377         do i=1,nres-1
3378           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3379      &     ((ug(l,k,i),l=1,2),k=1,2),
3380      &     ((ugder(l,k,i),l=1,2),k=1,2)
3381         enddo
3382         write (iout,*) "Arrays UG2 and UG2DER"
3383         do i=1,nres-1
3384           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3385      &     ((ug2(l,k,i),l=1,2),k=1,2),
3386      &     ((ug2der(l,k,i),l=1,2),k=1,2)
3387         enddo
3388         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
3389         do i=1,nres-1
3390           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3391      &     (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
3392      &     (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
3393         enddo
3394         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
3395         do i=1,nres-1
3396           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3397      &     costab(i),sintab(i),costab2(i),sintab2(i)
3398         enddo
3399         write (iout,*) "Array MUDER"
3400         do i=1,nres-1
3401           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
3402         enddo
3403 c      endif
3404 #endif
3405 #endif
3406 cd      do i=1,nres
3407 cd        iti = itype2loc(itype(i))
3408 cd        write (iout,*) i
3409 cd        do j=1,2
3410 cd        write (iout,'(2f10.5,5x,2f10.5,5x,2f10.5)')
3411 cd     &  (EE(j,k,i),k=1,2),(Ug(j,k,i),k=1,2),(EUg(j,k,i),k=1,2)
3412 cd        enddo
3413 cd      enddo
3414       return
3415       end
3416 C-----------------------------------------------------------------------------
3417       subroutine eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
3418 C
3419 C This subroutine calculates the average interaction energy and its gradient
3420 C in the virtual-bond vectors between non-adjacent peptide groups, based on
3421 C the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
3422 C The potential depends both on the distance of peptide-group centers and on
3423 C the orientation of the CA-CA virtual bonds.
3424 C
3425       implicit real*8 (a-h,o-z)
3426 #ifdef MPI
3427       include 'mpif.h'
3428 #endif
3429       include 'DIMENSIONS'
3430       include 'COMMON.CONTROL'
3431       include 'COMMON.SETUP'
3432       include 'COMMON.IOUNITS'
3433       include 'COMMON.GEO'
3434       include 'COMMON.VAR'
3435       include 'COMMON.LOCAL'
3436       include 'COMMON.CHAIN'
3437       include 'COMMON.DERIV'
3438       include 'COMMON.INTERACT'
3439 #ifdef FOURBODY
3440       include 'COMMON.CONTACTS'
3441       include 'COMMON.CONTMAT'
3442 #endif
3443       include 'COMMON.CORRMAT'
3444       include 'COMMON.TORSION'
3445       include 'COMMON.VECTORS'
3446       include 'COMMON.FFIELD'
3447       include 'COMMON.TIME1'
3448       include 'COMMON.SPLITELE'
3449       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
3450      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
3451       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
3452      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4),gmuij(4)
3453       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3454      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3455      &    num_conti,j1,j2
3456 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
3457 #ifdef MOMENT
3458       double precision scal_el /1.0d0/
3459 #else
3460       double precision scal_el /0.5d0/
3461 #endif
3462 C 12/13/98
3463 C 13-go grudnia roku pamietnego...
3464       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
3465      &                   0.0d0,1.0d0,0.0d0,
3466      &                   0.0d0,0.0d0,1.0d0/
3467 cd      write(iout,*) 'In EELEC'
3468 cd      do i=1,nloctyp
3469 cd        write(iout,*) 'Type',i
3470 cd        write(iout,*) 'B1',B1(:,i)
3471 cd        write(iout,*) 'B2',B2(:,i)
3472 cd        write(iout,*) 'CC',CC(:,:,i)
3473 cd        write(iout,*) 'DD',DD(:,:,i)
3474 cd        write(iout,*) 'EE',EE(:,:,i)
3475 cd      enddo
3476 cd      call check_vecgrad
3477 cd      stop
3478       if (icheckgrad.eq.1) then
3479         do i=1,nres-1
3480           fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
3481           do k=1,3
3482             dc_norm(k,i)=dc(k,i)*fac
3483           enddo
3484 c          write (iout,*) 'i',i,' fac',fac
3485         enddo
3486       endif
3487       if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
3488      &    .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or.
3489      &    wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
3490 c        call vec_and_deriv
3491 #ifdef TIMING
3492         time01=MPI_Wtime()
3493 #endif
3494         call set_matrices
3495 #ifdef TIMING
3496         time_mat=time_mat+MPI_Wtime()-time01
3497 #endif
3498       endif
3499 cd      do i=1,nres-1
3500 cd        write (iout,*) 'i=',i
3501 cd        do k=1,3
3502 cd        write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
3503 cd        enddo
3504 cd        do k=1,3
3505 cd          write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
3506 cd     &     uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
3507 cd        enddo
3508 cd      enddo
3509       t_eelecij=0.0d0
3510       ees=0.0D0
3511       evdw1=0.0D0
3512       eel_loc=0.0d0
3513       eello_turn3=0.0d0
3514       eello_turn4=0.0d0
3515       ind=0
3516 #ifdef FOURBODY
3517       do i=1,nres
3518         num_cont_hb(i)=0
3519       enddo
3520 #endif
3521 cd      print '(a)','Enter EELEC'
3522 cd      write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
3523       do i=1,nres
3524         gel_loc_loc(i)=0.0d0
3525         gcorr_loc(i)=0.0d0
3526       enddo
3527 c
3528 c
3529 c 9/27/08 AL Split the interaction loop to ensure load balancing of turn terms
3530 C
3531 C Loop over i,i+2 and i,i+3 pairs of the peptide groups
3532 C
3533 C 14/01/2014 TURN3,TUNR4 does no go under periodic boundry condition
3534       do i=iturn3_start,iturn3_end
3535 c        if (i.le.1) cycle
3536 C        write(iout,*) "tu jest i",i
3537         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
3538 C changes suggested by Ana to avoid out of bounds
3539 C Adam: Unnecessary: handled by iturn3_end and iturn3_start
3540 c     & .or.((i+4).gt.nres)
3541 c     & .or.((i-1).le.0)
3542 C end of changes by Ana
3543      &  .or. itype(i+2).eq.ntyp1
3544      &  .or. itype(i+3).eq.ntyp1) cycle
3545 C Adam: Instructions below will switch off existing interactions
3546 c        if(i.gt.1)then
3547 c          if(itype(i-1).eq.ntyp1)cycle
3548 c        end if
3549 c        if(i.LT.nres-3)then
3550 c          if (itype(i+4).eq.ntyp1) cycle
3551 c        end if
3552         dxi=dc(1,i)
3553         dyi=dc(2,i)
3554         dzi=dc(3,i)
3555         dx_normi=dc_norm(1,i)
3556         dy_normi=dc_norm(2,i)
3557         dz_normi=dc_norm(3,i)
3558         xmedi=c(1,i)+0.5d0*dxi
3559         ymedi=c(2,i)+0.5d0*dyi
3560         zmedi=c(3,i)+0.5d0*dzi
3561         call to_box(xmedi,ymedi,zmedi)
3562         num_conti=0
3563         call eelecij(i,i+2,ees,evdw1,eel_loc)
3564         if (wturn3.gt.0.0d0) call eturn3(i,eello_turn3)
3565 #ifdef FOURBODY
3566         num_cont_hb(i)=num_conti
3567 #endif
3568       enddo
3569       do i=iturn4_start,iturn4_end
3570         if (i.lt.1) cycle
3571         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
3572 C changes suggested by Ana to avoid out of bounds
3573 c     & .or.((i+5).gt.nres)
3574 c     & .or.((i-1).le.0)
3575 C end of changes suggested by Ana
3576      &    .or. itype(i+3).eq.ntyp1
3577      &    .or. itype(i+4).eq.ntyp1
3578 c     &    .or. itype(i+5).eq.ntyp1
3579 c     &    .or. itype(i).eq.ntyp1
3580 c     &    .or. itype(i-1).eq.ntyp1
3581      &                             ) cycle
3582         dxi=dc(1,i)
3583         dyi=dc(2,i)
3584         dzi=dc(3,i)
3585         dx_normi=dc_norm(1,i)
3586         dy_normi=dc_norm(2,i)
3587         dz_normi=dc_norm(3,i)
3588         xmedi=c(1,i)+0.5d0*dxi
3589         ymedi=c(2,i)+0.5d0*dyi
3590         zmedi=c(3,i)+0.5d0*dzi
3591 C Return atom into box, boxxsize is size of box in x dimension
3592 c  194   continue
3593 c        if (xmedi.gt.((0.5d0)*boxxsize)) xmedi=xmedi-boxxsize
3594 c        if (xmedi.lt.((-0.5d0)*boxxsize)) xmedi=xmedi+boxxsize
3595 C Condition for being inside the proper box
3596 c        if ((xmedi.gt.((0.5d0)*boxxsize)).or.
3597 c     &       (xmedi.lt.((-0.5d0)*boxxsize))) then
3598 c        go to 194
3599 c        endif
3600 c  195   continue
3601 c        if (ymedi.gt.((0.5d0)*boxysize)) ymedi=ymedi-boxysize
3602 c        if (ymedi.lt.((-0.5d0)*boxysize)) ymedi=ymedi+boxysize
3603 C Condition for being inside the proper box
3604 c        if ((ymedi.gt.((0.5d0)*boxysize)).or.
3605 c     &       (ymedi.lt.((-0.5d0)*boxysize))) then
3606 c        go to 195
3607 c        endif
3608 c  196   continue
3609 c        if (zmedi.gt.((0.5d0)*boxzsize)) zmedi=zmedi-boxzsize
3610 c        if (zmedi.lt.((-0.5d0)*boxzsize)) zmedi=zmedi+boxzsize
3611 C Condition for being inside the proper box
3612 c        if ((zmedi.gt.((0.5d0)*boxzsize)).or.
3613 c     &       (zmedi.lt.((-0.5d0)*boxzsize))) then
3614 c        go to 196
3615 c        endif
3616         call to_box(xmedi,ymedi,zmedi)
3617 #ifdef FOURBODY
3618         num_conti=num_cont_hb(i)
3619 #endif
3620 c        write(iout,*) "JESTEM W PETLI"
3621         call eelecij(i,i+3,ees,evdw1,eel_loc)
3622         if (wturn4.gt.0.0d0 .and. itype(i+2).ne.ntyp1)
3623      &   call eturn4(i,eello_turn4)
3624 #ifdef FOURBODY
3625         num_cont_hb(i)=num_conti
3626 #endif
3627       enddo   ! i
3628 C Loop over all neighbouring boxes
3629 C      do xshift=-1,1
3630 C      do yshift=-1,1
3631 C      do zshift=-1,1
3632 c
3633 c Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
3634 c
3635 CTU KURWA
3636 c      do i=iatel_s,iatel_e
3637       do ikont=g_listpp_start,g_listpp_end
3638         i=newcontlistppi(ikont)
3639         j=newcontlistppj(ikont)
3640 C        do i=75,75
3641 c        if (i.le.1) cycle
3642         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
3643 C changes suggested by Ana to avoid out of bounds
3644 c     & .or.((i+2).gt.nres)
3645 c     & .or.((i-1).le.0)
3646 C end of changes by Ana
3647 c     &  .or. itype(i+2).eq.ntyp1
3648 c     &  .or. itype(i-1).eq.ntyp1
3649      &                ) cycle
3650         dxi=dc(1,i)
3651         dyi=dc(2,i)
3652         dzi=dc(3,i)
3653         dx_normi=dc_norm(1,i)
3654         dy_normi=dc_norm(2,i)
3655         dz_normi=dc_norm(3,i)
3656         xmedi=c(1,i)+0.5d0*dxi
3657         ymedi=c(2,i)+0.5d0*dyi
3658         zmedi=c(3,i)+0.5d0*dzi
3659         call to_box(xmedi,ymedi,zmedi)
3660 C          xmedi=xmedi+xshift*boxxsize
3661 C          ymedi=ymedi+yshift*boxysize
3662 C          zmedi=zmedi+zshift*boxzsize
3663
3664 C Return tom into box, boxxsize is size of box in x dimension
3665 c  164   continue
3666 c        if (xmedi.gt.((xshift+0.5d0)*boxxsize)) xmedi=xmedi-boxxsize
3667 c        if (xmedi.lt.((xshift-0.5d0)*boxxsize)) xmedi=xmedi+boxxsize
3668 C Condition for being inside the proper box
3669 c        if ((xmedi.gt.((xshift+0.5d0)*boxxsize)).or.
3670 c     &       (xmedi.lt.((xshift-0.5d0)*boxxsize))) then
3671 c        go to 164
3672 c        endif
3673 c  165   continue
3674 c        if (ymedi.gt.((yshift+0.5d0)*boxysize)) ymedi=ymedi-boxysize
3675 c        if (ymedi.lt.((yshift-0.5d0)*boxysize)) ymedi=ymedi+boxysize
3676 C Condition for being inside the proper box
3677 c        if ((ymedi.gt.((yshift+0.5d0)*boxysize)).or.
3678 c     &       (ymedi.lt.((yshift-0.5d0)*boxysize))) then
3679 c        go to 165
3680 c        endif
3681 c  166   continue
3682 c        if (zmedi.gt.((zshift+0.5d0)*boxzsize)) zmedi=zmedi-boxzsize
3683 c        if (zmedi.lt.((zshift-0.5d0)*boxzsize)) zmedi=zmedi+boxzsize
3684 cC Condition for being inside the proper box
3685 c        if ((zmedi.gt.((zshift+0.5d0)*boxzsize)).or.
3686 c     &       (zmedi.lt.((zshift-0.5d0)*boxzsize))) then
3687 c        go to 166
3688 c        endif
3689
3690 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
3691 #ifdef FOURBODY
3692         num_conti=num_cont_hb(i)
3693 #endif
3694 C I TU KURWA
3695 c        do j=ielstart(i),ielend(i)
3696 C          do j=16,17
3697 C          write (iout,*) i,j
3698 C         if (j.le.1) cycle
3699         if (itype(j).eq.ntyp1.or. itype(j+1).eq.ntyp1
3700 C changes suggested by Ana to avoid out of bounds
3701 c     & .or.((j+2).gt.nres)
3702 c     & .or.((j-1).le.0)
3703 C end of changes by Ana
3704 c     & .or.itype(j+2).eq.ntyp1
3705 c     & .or.itype(j-1).eq.ntyp1
3706      &) cycle
3707         call eelecij(i,j,ees,evdw1,eel_loc)
3708 c        enddo ! j
3709 #ifdef FOURBODY
3710         num_cont_hb(i)=num_conti
3711 #endif
3712       enddo   ! i
3713 C     enddo   ! zshift
3714 C      enddo   ! yshift
3715 C      enddo   ! xshift
3716
3717 c      write (iout,*) "Number of loop steps in EELEC:",ind
3718 cd      do i=1,nres
3719 cd        write (iout,'(i3,3f10.5,5x,3f10.5)')
3720 cd     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
3721 cd      enddo
3722 c 12/7/99 Adam eello_turn3 will be considered as a separate energy term
3723 ccc      eel_loc=eel_loc+eello_turn3
3724 cd      print *,"Processor",fg_rank," t_eelecij",t_eelecij
3725       return
3726       end
3727 C-------------------------------------------------------------------------------
3728       subroutine eelecij(i,j,ees,evdw1,eel_loc)
3729       implicit none
3730       include 'DIMENSIONS'
3731 #ifdef MPI
3732       include "mpif.h"
3733 #endif
3734       include 'COMMON.CONTROL'
3735       include 'COMMON.IOUNITS'
3736       include 'COMMON.GEO'
3737       include 'COMMON.VAR'
3738       include 'COMMON.LOCAL'
3739       include 'COMMON.CHAIN'
3740       include 'COMMON.DERIV'
3741       include 'COMMON.INTERACT'
3742 #ifdef FOURBODY
3743       include 'COMMON.CONTACTS'
3744       include 'COMMON.CONTMAT'
3745 #endif
3746       include 'COMMON.CORRMAT'
3747       include 'COMMON.TORSION'
3748       include 'COMMON.VECTORS'
3749       include 'COMMON.FFIELD'
3750       include 'COMMON.TIME1'
3751       include 'COMMON.SPLITELE'
3752       include 'COMMON.SHIELD'
3753       double precision ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
3754      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
3755       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
3756      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4),gmuij1(4),gmuji1(4),
3757      &    gmuij2(4),gmuji2(4)
3758       double precision dxi,dyi,dzi
3759       double precision dx_normi,dy_normi,dz_normi,aux
3760       integer j1,j2,lll,num_conti
3761       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3762      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3763      &    num_conti,j1,j2
3764       integer k,i,j,iteli,itelj,kkk,l,kkll,m,isubchap,ilist,iresshield
3765       double precision ael6i,rrmij,rmij,r0ij,fcont,fprimcont,ees0tmp
3766       double precision ees,evdw1,eel_loc,aaa,bbb,ael3i
3767       double precision dxj,dyj,dzj,dx_normj,dy_normj,dz_normj,xj,yj,zj,
3768      &  rij,r3ij,r6ij,cosa,cosb,cosg,fac,ev1,ev2,fac3,fac4,
3769      &  evdwij,el1,el2,eesij,ees0ij,facvdw,facel,fac1,ecosa,
3770      &  ecosb,ecosg,ury,urz,vry,vrz,facr,a22der,a23der,a32der,
3771      &  a33der,eel_loc_ij,cosa4,wij,cosbg1,cosbg2,ees0pij,
3772      &  ees0pij1,ees0mij,ees0mij1,fac3p,ees0mijp,ees0pijp,
3773      &  ecosa1,ecosb1,ecosg1,ecosa2,ecosb2,ecosg2,ecosap,ecosbp,
3774      &  ecosgp,ecosam,ecosbm,ecosgm,ghalf,rlocshield
3775       double precision a22,a23,a32,a33,geel_loc_ij,geel_loc_ji
3776       double precision xmedi,ymedi,zmedi
3777       double precision sscale,sscagrad,scalar
3778       double precision boxshift
3779 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
3780 #ifdef MOMENT
3781       double precision scal_el /1.0d0/
3782 #else
3783       double precision scal_el /0.5d0/
3784 #endif
3785 C 12/13/98
3786 C 13-go grudnia roku pamietnego...
3787       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
3788      &                   0.0d0,1.0d0,0.0d0,
3789      &                   0.0d0,0.0d0,1.0d0/
3790 c          time00=MPI_Wtime()
3791 cd      write (iout,*) "eelecij",i,j
3792 c          ind=ind+1
3793           iteli=itel(i)
3794           itelj=itel(j)
3795           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
3796           aaa=app(iteli,itelj)
3797           bbb=bpp(iteli,itelj)
3798           ael6i=ael6(iteli,itelj)
3799           ael3i=ael3(iteli,itelj)
3800           dxj=dc(1,j)
3801           dyj=dc(2,j)
3802           dzj=dc(3,j)
3803           dx_normj=dc_norm(1,j)
3804           dy_normj=dc_norm(2,j)
3805           dz_normj=dc_norm(3,j)
3806 C          xj=c(1,j)+0.5D0*dxj-xmedi
3807 C          yj=c(2,j)+0.5D0*dyj-ymedi
3808 C          zj=c(3,j)+0.5D0*dzj-zmedi
3809           xj=c(1,j)+0.5D0*dxj
3810           yj=c(2,j)+0.5D0*dyj
3811           zj=c(3,j)+0.5D0*dzj
3812           call to_box(xj,yj,zj)
3813           xj=boxshift(xj-xmedi,boxxsize)
3814           yj=boxshift(yj-ymedi,boxysize)
3815           zj=boxshift(zj-zmedi,boxzsize)
3816 C        if ((i+3).lt.j) then !this condition keeps for turn3 and turn4 not subject to PBC
3817 c  174   continue
3818           rij=xj*xj+yj*yj+zj*zj
3819
3820           sss=sscale(dsqrt(rij),r_cut_int)
3821           if (sss.eq.0.0d0) return
3822           sssgrad=sscagrad(dsqrt(rij),r_cut_int)
3823 c            if (sss.gt.0.0d0) then
3824           rrmij=1.0D0/rij
3825           rij=dsqrt(rij)
3826           rmij=1.0D0/rij
3827           r3ij=rrmij*rmij
3828           r6ij=r3ij*r3ij
3829           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
3830           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
3831           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
3832           fac=cosa-3.0D0*cosb*cosg
3833           ev1=aaa*r6ij*r6ij
3834 c 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
3835           if (j.eq.i+2) ev1=scal_el*ev1
3836           ev2=bbb*r6ij
3837           fac3=ael6i*r6ij
3838           fac4=ael3i*r3ij
3839           evdwij=(ev1+ev2)
3840           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
3841           el2=fac4*fac
3842 C MARYSIA
3843 C          eesij=(el1+el2)
3844 C 12/26/95 - for the evaluation of multi-body H-bonding interactions
3845           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
3846           if (shield_mode.gt.0) then
3847 C          fac_shield(i)=0.4
3848 C          fac_shield(j)=0.6
3849           el1=el1*fac_shield(i)**2*fac_shield(j)**2
3850           el2=el2*fac_shield(i)**2*fac_shield(j)**2
3851           eesij=(el1+el2)
3852           ees=ees+eesij
3853           else
3854           fac_shield(i)=1.0
3855           fac_shield(j)=1.0
3856           eesij=(el1+el2)
3857           ees=ees+eesij*sss
3858           endif
3859           evdw1=evdw1+evdwij*sss
3860 cd          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
3861 cd     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
3862 cd     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
3863 cd     &      xmedi,ymedi,zmedi,xj,yj,zj
3864
3865           if (energy_dec) then
3866             write (iout,'(a6,2i5,0pf7.3,2i5,e11.3,3f10.5)')
3867      &        'evdw1',i,j,evdwij,iteli,itelj,aaa,evdw1,sss,rij
3868             write (iout,'(a6,2i5,0pf7.3,2f8.3)') 'ees',i,j,eesij,
3869      &        fac_shield(i),fac_shield(j)
3870           endif
3871
3872 C
3873 C Calculate contributions to the Cartesian gradient.
3874 C
3875 #ifdef SPLITELE
3876           facvdw=-6*rrmij*(ev1+evdwij)*sss
3877           facel=-3*rrmij*(el1+eesij)
3878           fac1=fac
3879           erij(1)=xj*rmij
3880           erij(2)=yj*rmij
3881           erij(3)=zj*rmij
3882
3883 *
3884 * Radial derivatives. First process both termini of the fragment (i,j)
3885 *
3886           aux=facel*sss+rmij*sssgrad*eesij
3887           ggg(1)=aux*xj
3888           ggg(2)=aux*yj
3889           ggg(3)=aux*zj
3890           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
3891      &  (shield_mode.gt.0)) then
3892 C          print *,i,j
3893           do ilist=1,ishield_list(i)
3894            iresshield=shield_list(ilist,i)
3895            do k=1,3
3896            rlocshield=grad_shield_side(k,ilist,i)*eesij/fac_shield(i)
3897      &      *2.0
3898            gshieldx(k,iresshield)=gshieldx(k,iresshield)+
3899      &              rlocshield
3900      & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)*2.0
3901             gshieldc(k,iresshield-1)=gshieldc(k,iresshield-1)+rlocshield
3902 C           gshieldc_loc(k,iresshield)=gshieldc_loc(k,iresshield)
3903 C     & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)
3904 C             if (iresshield.gt.i) then
3905 C               do ishi=i+1,iresshield-1
3906 C                gshieldc(k,ishi)=gshieldc(k,ishi)+rlocshield
3907 C     & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)
3908 C
3909 C              enddo
3910 C             else
3911 C               do ishi=iresshield,i
3912 C                gshieldc(k,ishi)=gshieldc(k,ishi)-rlocshield
3913 C     & -grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)
3914 C
3915 C               enddo
3916 C              endif
3917            enddo
3918           enddo
3919           do ilist=1,ishield_list(j)
3920            iresshield=shield_list(ilist,j)
3921            do k=1,3
3922            rlocshield=grad_shield_side(k,ilist,j)*eesij/fac_shield(j)
3923      &     *2.0*sss
3924            gshieldx(k,iresshield)=gshieldx(k,iresshield)+
3925      &              rlocshield
3926      & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)*2.0*sss
3927            gshieldc(k,iresshield-1)=gshieldc(k,iresshield-1)+rlocshield
3928
3929 C     & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
3930 C           gshieldc_loc(k,iresshield)=gshieldc_loc(k,iresshield)
3931 C     & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
3932 C             if (iresshield.gt.j) then
3933 C               do ishi=j+1,iresshield-1
3934 C                gshieldc(k,ishi)=gshieldc(k,ishi)+rlocshield
3935 C     & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
3936 C
3937 C               enddo
3938 C            else
3939 C               do ishi=iresshield,j
3940 C                gshieldc(k,ishi)=gshieldc(k,ishi)-rlocshield
3941 C     & -grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
3942 C               enddo
3943 C              endif
3944            enddo
3945           enddo
3946
3947           do k=1,3
3948             gshieldc(k,i)=gshieldc(k,i)+
3949      &              grad_shield(k,i)*eesij/fac_shield(i)*2.0*sss
3950             gshieldc(k,j)=gshieldc(k,j)+
3951      &              grad_shield(k,j)*eesij/fac_shield(j)*2.0*sss
3952             gshieldc(k,i-1)=gshieldc(k,i-1)+
3953      &              grad_shield(k,i)*eesij/fac_shield(i)*2.0*sss
3954             gshieldc(k,j-1)=gshieldc(k,j-1)+
3955      &              grad_shield(k,j)*eesij/fac_shield(j)*2.0*sss
3956
3957            enddo
3958            endif
3959 c          do k=1,3
3960 c            ghalf=0.5D0*ggg(k)
3961 c            gelc(k,i)=gelc(k,i)+ghalf
3962 c            gelc(k,j)=gelc(k,j)+ghalf
3963 c          enddo
3964 c 9/28/08 AL Gradient compotents will be summed only at the end
3965 C           print *,"before", gelc_long(1,i), gelc_long(1,j)
3966           do k=1,3
3967             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
3968 C     &                    +grad_shield(k,j)*eesij/fac_shield(j)
3969             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
3970 C     &                    +grad_shield(k,i)*eesij/fac_shield(i)
3971 C            gelc_long(k,i-1)=gelc_long(k,i-1)
3972 C     &                    +grad_shield(k,i)*eesij/fac_shield(i)
3973 C            gelc_long(k,j-1)=gelc_long(k,j-1)
3974 C     &                    +grad_shield(k,j)*eesij/fac_shield(j)
3975           enddo
3976 C           print *,"bafter", gelc_long(1,i), gelc_long(1,j)
3977
3978 *
3979 * Loop over residues i+1 thru j-1.
3980 *
3981 cgrad          do k=i+1,j-1
3982 cgrad            do l=1,3
3983 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3984 cgrad            enddo
3985 cgrad          enddo
3986           facvdw=facvdw+sssgrad*rmij*evdwij
3987           ggg(1)=facvdw*xj
3988           ggg(2)=facvdw*yj
3989           ggg(3)=facvdw*zj
3990 c          do k=1,3
3991 c            ghalf=0.5D0*ggg(k)
3992 c            gvdwpp(k,i)=gvdwpp(k,i)+ghalf
3993 c            gvdwpp(k,j)=gvdwpp(k,j)+ghalf
3994 c          enddo
3995 c 9/28/08 AL Gradient compotents will be summed only at the end
3996           do k=1,3
3997             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
3998             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
3999           enddo
4000 *
4001 * Loop over residues i+1 thru j-1.
4002 *
4003 cgrad          do k=i+1,j-1
4004 cgrad            do l=1,3
4005 cgrad              gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
4006 cgrad            enddo
4007 cgrad          enddo
4008 #else
4009 C MARYSIA
4010           facvdw=(ev1+evdwij)
4011           facel=(el1+eesij)
4012           fac1=fac
4013           fac=-3*rrmij*(facvdw+facvdw+facel)*sss
4014      &       +(evdwij+eesij)*sssgrad*rrmij
4015           erij(1)=xj*rmij
4016           erij(2)=yj*rmij
4017           erij(3)=zj*rmij
4018 *
4019 * Radial derivatives. First process both termini of the fragment (i,j)
4020 *
4021           ggg(1)=fac*xj
4022 C+eesij*grad_shield(1,i)+eesij*grad_shield(1,j)
4023           ggg(2)=fac*yj
4024 C+eesij*grad_shield(2,i)+eesij*grad_shield(2,j)
4025           ggg(3)=fac*zj
4026 C+eesij*grad_shield(3,i)+eesij*grad_shield(3,j)
4027 c          do k=1,3
4028 c            ghalf=0.5D0*ggg(k)
4029 c            gelc(k,i)=gelc(k,i)+ghalf
4030 c            gelc(k,j)=gelc(k,j)+ghalf
4031 c          enddo
4032 c 9/28/08 AL Gradient compotents will be summed only at the end
4033           do k=1,3
4034             gelc_long(k,j)=gelc(k,j)+ggg(k)
4035             gelc_long(k,i)=gelc(k,i)-ggg(k)
4036           enddo
4037 *
4038 * Loop over residues i+1 thru j-1.
4039 *
4040 cgrad          do k=i+1,j-1
4041 cgrad            do l=1,3
4042 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
4043 cgrad            enddo
4044 cgrad          enddo
4045 c 9/28/08 AL Gradient compotents will be summed only at the end
4046           ggg(1)=facvdw*xj+sssgrad*rmij*evdwij*xj
4047           ggg(2)=facvdw*yj+sssgrad*rmij*evdwij*yj
4048           ggg(3)=facvdw*zj+sssgrad*rmij*evdwij*zj
4049           do k=1,3
4050             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
4051             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
4052           enddo
4053 #endif
4054 *
4055 * Angular part
4056 *
4057           ecosa=2.0D0*fac3*fac1+fac4
4058           fac4=-3.0D0*fac4
4059           fac3=-6.0D0*fac3
4060           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
4061           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
4062           do k=1,3
4063             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
4064             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
4065           enddo
4066 cd        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
4067 cd   &          (dcosg(k),k=1,3)
4068           do k=1,3
4069             ggg(k)=(ecosb*dcosb(k)+ecosg*dcosg(k))*
4070      &      fac_shield(i)**2*fac_shield(j)**2*sss
4071           enddo
4072 c          do k=1,3
4073 c            ghalf=0.5D0*ggg(k)
4074 c            gelc(k,i)=gelc(k,i)+ghalf
4075 c     &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
4076 c     &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
4077 c            gelc(k,j)=gelc(k,j)+ghalf
4078 c     &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
4079 c     &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
4080 c          enddo
4081 cgrad          do k=i+1,j-1
4082 cgrad            do l=1,3
4083 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
4084 cgrad            enddo
4085 cgrad          enddo
4086 C                     print *,"before22", gelc_long(1,i), gelc_long(1,j)
4087           do k=1,3
4088             gelc(k,i)=gelc(k,i)
4089      &           +((ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
4090      &           + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1))*sss
4091      &           *fac_shield(i)**2*fac_shield(j)**2
4092             gelc(k,j)=gelc(k,j)
4093      &           +((ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
4094      &           + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1))*sss
4095      &           *fac_shield(i)**2*fac_shield(j)**2
4096             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
4097             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
4098           enddo
4099 C           print *,"before33", gelc_long(1,i), gelc_long(1,j)
4100
4101 C MARYSIA
4102 c          endif !sscale
4103           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
4104      &        .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0
4105      &        .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
4106 C
4107 C 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
4108 C   energy of a peptide unit is assumed in the form of a second-order
4109 C   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
4110 C   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
4111 C   are computed for EVERY pair of non-contiguous peptide groups.
4112 C
4113
4114           if (j.lt.nres-1) then
4115             j1=j+1
4116             j2=j-1
4117           else
4118             j1=j-1
4119             j2=j-2
4120           endif
4121           kkk=0
4122           lll=0
4123           do k=1,2
4124             do l=1,2
4125               kkk=kkk+1
4126               muij(kkk)=mu(k,i)*mu(l,j)
4127 c              write(iout,*) 'mumu=', mu(k,i),mu(l,j),i,j,k,l
4128 #ifdef NEWCORR
4129              gmuij1(kkk)=gtb1(k,i+1)*mu(l,j)
4130 c             write(iout,*) 'k=',k,i,gtb1(k,i+1),gtb1(k,i+1)*mu(l,j)
4131              gmuij2(kkk)=gUb2(k,i)*mu(l,j)
4132              gmuji1(kkk)=mu(k,i)*gtb1(l,j+1)
4133 c             write(iout,*) 'l=',l,j,gtb1(l,j+1),gtb1(l,j+1)*mu(k,i)
4134              gmuji2(kkk)=mu(k,i)*gUb2(l,j)
4135 #endif
4136             enddo
4137           enddo
4138 #ifdef DEBUG
4139           write (iout,*) 'EELEC: i',i,' j',j
4140           write (iout,*) 'j',j,' j1',j1,' j2',j2
4141           write(iout,*) 'muij',muij
4142 #endif
4143           ury=scalar(uy(1,i),erij)
4144           urz=scalar(uz(1,i),erij)
4145           vry=scalar(uy(1,j),erij)
4146           vrz=scalar(uz(1,j),erij)
4147           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
4148           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
4149           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
4150           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
4151           fac=dsqrt(-ael6i)*r3ij
4152 #ifdef DEBUG
4153           write (iout,*) "ury",ury," urz",urz," vry",vry," vrz",vrz
4154           write (iout,*) "uyvy",scalar(uy(1,i),uy(1,j)),
4155      &      "uyvz",scalar(uy(1,i),uz(1,j)),
4156      &      "uzvy",scalar(uz(1,i),uy(1,j)),
4157      &      "uzvz",scalar(uz(1,i),uz(1,j))
4158           write (iout,*) "a22",a22," a23",a23," a32",a32," a33",a33
4159           write (iout,*) "fac",fac
4160 #endif
4161           a22=a22*fac
4162           a23=a23*fac
4163           a32=a32*fac
4164           a33=a33*fac
4165 #ifdef DEBUG
4166           write (iout,*) "a22",a22," a23",a23," a32",a32," a33",a33
4167 #endif
4168 #undef DEBUG
4169 cd          write (iout,'(4i5,4f10.5)')
4170 cd     &     i,itortyp(itype(i)),j,itortyp(itype(j)),a22,a23,a32,a33
4171 cd          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
4172 cd          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') uy(:,i),uz(:,i),
4173 cd     &      uy(:,j),uz(:,j)
4174 cd          write (iout,'(4f10.5)')
4175 cd     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
4176 cd     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
4177 cd          write (iout,'(4f10.5)') ury,urz,vry,vrz
4178 cd           write (iout,'(9f10.5/)')
4179 cd     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
4180 C Derivatives of the elements of A in virtual-bond vectors
4181           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
4182           do k=1,3
4183             uryg(k,1)=scalar(erder(1,k),uy(1,i))
4184             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
4185             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
4186             urzg(k,1)=scalar(erder(1,k),uz(1,i))
4187             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
4188             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
4189             vryg(k,1)=scalar(erder(1,k),uy(1,j))
4190             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
4191             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
4192             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
4193             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
4194             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
4195           enddo
4196 C Compute radial contributions to the gradient
4197           facr=-3.0d0*rrmij
4198           a22der=a22*facr
4199           a23der=a23*facr
4200           a32der=a32*facr
4201           a33der=a33*facr
4202           agg(1,1)=a22der*xj
4203           agg(2,1)=a22der*yj
4204           agg(3,1)=a22der*zj
4205           agg(1,2)=a23der*xj
4206           agg(2,2)=a23der*yj
4207           agg(3,2)=a23der*zj
4208           agg(1,3)=a32der*xj
4209           agg(2,3)=a32der*yj
4210           agg(3,3)=a32der*zj
4211           agg(1,4)=a33der*xj
4212           agg(2,4)=a33der*yj
4213           agg(3,4)=a33der*zj
4214 C Add the contributions coming from er
4215           fac3=-3.0d0*fac
4216           do k=1,3
4217             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
4218             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
4219             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
4220             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
4221           enddo
4222           do k=1,3
4223 C Derivatives in DC(i)
4224 cgrad            ghalf1=0.5d0*agg(k,1)
4225 cgrad            ghalf2=0.5d0*agg(k,2)
4226 cgrad            ghalf3=0.5d0*agg(k,3)
4227 cgrad            ghalf4=0.5d0*agg(k,4)
4228             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j))
4229      &      -3.0d0*uryg(k,2)*vry)!+ghalf1
4230             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j))
4231      &      -3.0d0*uryg(k,2)*vrz)!+ghalf2
4232             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j))
4233      &      -3.0d0*urzg(k,2)*vry)!+ghalf3
4234             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j))
4235      &      -3.0d0*urzg(k,2)*vrz)!+ghalf4
4236 C Derivatives in DC(i+1)
4237             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j))
4238      &      -3.0d0*uryg(k,3)*vry)!+agg(k,1)
4239             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j))
4240      &      -3.0d0*uryg(k,3)*vrz)!+agg(k,2)
4241             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j))
4242      &      -3.0d0*urzg(k,3)*vry)!+agg(k,3)
4243             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j))
4244      &      -3.0d0*urzg(k,3)*vrz)!+agg(k,4)
4245 C Derivatives in DC(j)
4246             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i))
4247      &      -3.0d0*vryg(k,2)*ury)!+ghalf1
4248             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i))
4249      &      -3.0d0*vrzg(k,2)*ury)!+ghalf2
4250             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i))
4251      &      -3.0d0*vryg(k,2)*urz)!+ghalf3
4252             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i))
4253      &      -3.0d0*vrzg(k,2)*urz)!+ghalf4
4254 C Derivatives in DC(j+1) or DC(nres-1)
4255             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i))
4256      &      -3.0d0*vryg(k,3)*ury)
4257             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i))
4258      &      -3.0d0*vrzg(k,3)*ury)
4259             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i))
4260      &      -3.0d0*vryg(k,3)*urz)
4261             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i))
4262      &      -3.0d0*vrzg(k,3)*urz)
4263 cgrad            if (j.eq.nres-1 .and. i.lt.j-2) then
4264 cgrad              do l=1,4
4265 cgrad                aggj1(k,l)=aggj1(k,l)+agg(k,l)
4266 cgrad              enddo
4267 cgrad            endif
4268           enddo
4269           acipa(1,1)=a22
4270           acipa(1,2)=a23
4271           acipa(2,1)=a32
4272           acipa(2,2)=a33
4273           a22=-a22
4274           a23=-a23
4275           do l=1,2
4276             do k=1,3
4277               agg(k,l)=-agg(k,l)
4278               aggi(k,l)=-aggi(k,l)
4279               aggi1(k,l)=-aggi1(k,l)
4280               aggj(k,l)=-aggj(k,l)
4281               aggj1(k,l)=-aggj1(k,l)
4282             enddo
4283           enddo
4284           if (j.lt.nres-1) then
4285             a22=-a22
4286             a32=-a32
4287             do l=1,3,2
4288               do k=1,3
4289                 agg(k,l)=-agg(k,l)
4290                 aggi(k,l)=-aggi(k,l)
4291                 aggi1(k,l)=-aggi1(k,l)
4292                 aggj(k,l)=-aggj(k,l)
4293                 aggj1(k,l)=-aggj1(k,l)
4294               enddo
4295             enddo
4296           else
4297             a22=-a22
4298             a23=-a23
4299             a32=-a32
4300             a33=-a33
4301             do l=1,4
4302               do k=1,3
4303                 agg(k,l)=-agg(k,l)
4304                 aggi(k,l)=-aggi(k,l)
4305                 aggi1(k,l)=-aggi1(k,l)
4306                 aggj(k,l)=-aggj(k,l)
4307                 aggj1(k,l)=-aggj1(k,l)
4308               enddo
4309             enddo
4310           endif
4311           ENDIF ! WCORR
4312           IF (wel_loc.gt.0.0d0) THEN
4313 C Contribution to the local-electrostatic energy coming from the i-j pair
4314           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3)
4315      &     +a33*muij(4)
4316 #ifdef DEBUG
4317           write (iout,*) "muij",muij," a22",a22," a23",a23," a32",a32,
4318      &     " a33",a33
4319           write (iout,*) "ij",i,j," eel_loc_ij",eel_loc_ij,
4320      &     " wel_loc",wel_loc
4321 #endif
4322           if (shield_mode.eq.0) then
4323            fac_shield(i)=1.0
4324            fac_shield(j)=1.0
4325 C          else
4326 C           fac_shield(i)=0.4
4327 C           fac_shield(j)=0.6
4328           endif
4329           eel_loc_ij=eel_loc_ij
4330      &    *fac_shield(i)*fac_shield(j)*sss
4331 c          if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
4332 c     &            'eelloc',i,j,eel_loc_ij
4333 C Now derivative over eel_loc
4334           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
4335      &  (shield_mode.gt.0)) then
4336 C          print *,i,j
4337
4338           do ilist=1,ishield_list(i)
4339            iresshield=shield_list(ilist,i)
4340            do k=1,3
4341            rlocshield=grad_shield_side(k,ilist,i)*eel_loc_ij
4342      &                                          /fac_shield(i)
4343 C     &      *2.0
4344            gshieldx_ll(k,iresshield)=gshieldx_ll(k,iresshield)+
4345      &              rlocshield
4346      & +grad_shield_loc(k,ilist,i)*eel_loc_ij/fac_shield(i)
4347             gshieldc_ll(k,iresshield-1)=gshieldc_ll(k,iresshield-1)
4348      &      +rlocshield
4349            enddo
4350           enddo
4351           do ilist=1,ishield_list(j)
4352            iresshield=shield_list(ilist,j)
4353            do k=1,3
4354            rlocshield=grad_shield_side(k,ilist,j)*eel_loc_ij
4355      &                                       /fac_shield(j)
4356 C     &     *2.0
4357            gshieldx_ll(k,iresshield)=gshieldx_ll(k,iresshield)+
4358      &              rlocshield
4359      & +grad_shield_loc(k,ilist,j)*eel_loc_ij/fac_shield(j)
4360            gshieldc_ll(k,iresshield-1)=gshieldc_ll(k,iresshield-1)
4361      &             +rlocshield
4362
4363            enddo
4364           enddo
4365
4366           do k=1,3
4367             gshieldc_ll(k,i)=gshieldc_ll(k,i)+
4368      &              grad_shield(k,i)*eel_loc_ij/fac_shield(i)
4369             gshieldc_ll(k,j)=gshieldc_ll(k,j)+
4370      &              grad_shield(k,j)*eel_loc_ij/fac_shield(j)
4371             gshieldc_ll(k,i-1)=gshieldc_ll(k,i-1)+
4372      &              grad_shield(k,i)*eel_loc_ij/fac_shield(i)
4373             gshieldc_ll(k,j-1)=gshieldc_ll(k,j-1)+
4374      &              grad_shield(k,j)*eel_loc_ij/fac_shield(j)
4375            enddo
4376            endif
4377
4378
4379 c          write (iout,*) 'i',i,' j',j,itype(i),itype(j),
4380 c     &                     ' eel_loc_ij',eel_loc_ij
4381 C          write(iout,*) 'muije=',i,j,muij(1),muij(2),muij(3),muij(4)
4382 C Calculate patrial derivative for theta angle
4383 #ifdef NEWCORR
4384          geel_loc_ij=(a22*gmuij1(1)
4385      &     +a23*gmuij1(2)
4386      &     +a32*gmuij1(3)
4387      &     +a33*gmuij1(4))
4388      &    *fac_shield(i)*fac_shield(j)*sss
4389 c         write(iout,*) "derivative over thatai"
4390 c         write(iout,*) a22*gmuij1(1), a23*gmuij1(2) ,a32*gmuij1(3),
4391 c     &   a33*gmuij1(4)
4392          gloc(nphi+i,icg)=gloc(nphi+i,icg)+
4393      &      geel_loc_ij*wel_loc
4394 c         write(iout,*) "derivative over thatai-1"
4395 c         write(iout,*) a22*gmuij2(1), a23*gmuij2(2) ,a32*gmuij2(3),
4396 c     &   a33*gmuij2(4)
4397          geel_loc_ij=
4398      &     a22*gmuij2(1)
4399      &     +a23*gmuij2(2)
4400      &     +a32*gmuij2(3)
4401      &     +a33*gmuij2(4)
4402          gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
4403      &      geel_loc_ij*wel_loc
4404      &    *fac_shield(i)*fac_shield(j)*sss
4405
4406 c  Derivative over j residue
4407          geel_loc_ji=a22*gmuji1(1)
4408      &     +a23*gmuji1(2)
4409      &     +a32*gmuji1(3)
4410      &     +a33*gmuji1(4)
4411 c         write(iout,*) "derivative over thataj"
4412 c         write(iout,*) a22*gmuji1(1), a23*gmuji1(2) ,a32*gmuji1(3),
4413 c     &   a33*gmuji1(4)
4414
4415         gloc(nphi+j,icg)=gloc(nphi+j,icg)+
4416      &      geel_loc_ji*wel_loc
4417      &    *fac_shield(i)*fac_shield(j)*sss
4418
4419          geel_loc_ji=
4420      &     +a22*gmuji2(1)
4421      &     +a23*gmuji2(2)
4422      &     +a32*gmuji2(3)
4423      &     +a33*gmuji2(4)
4424 c         write(iout,*) "derivative over thataj-1"
4425 c         write(iout,*) a22*gmuji2(1), a23*gmuji2(2) ,a32*gmuji2(3),
4426 c     &   a33*gmuji2(4)
4427          gloc(nphi+j-1,icg)=gloc(nphi+j-1,icg)+
4428      &      geel_loc_ji*wel_loc
4429      &    *fac_shield(i)*fac_shield(j)*sss
4430 #endif
4431 cd          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
4432
4433           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
4434      &            'eelloc',i,j,eel_loc_ij
4435 c           if (eel_loc_ij.ne.0)
4436 c     &      write (iout,'(a4,2i4,8f9.5)')'chuj',
4437 c     &     i,j,a22,muij(1),a23,muij(2),a32,muij(3),a33,muij(4)
4438
4439           eel_loc=eel_loc+eel_loc_ij
4440 C Partial derivatives in virtual-bond dihedral angles gamma
4441           if (i.gt.1)
4442      &    gel_loc_loc(i-1)=gel_loc_loc(i-1)+
4443      &            (a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j)
4444      &           +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j))
4445      &    *fac_shield(i)*fac_shield(j)*sss
4446
4447           gel_loc_loc(j-1)=gel_loc_loc(j-1)+
4448      &           (a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j)
4449      &           +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j))
4450      &    *fac_shield(i)*fac_shield(j)*sss
4451 C Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
4452           aux=eel_loc_ij/sss*sssgrad*rmij
4453           ggg(1)=aux*xj
4454           ggg(2)=aux*yj
4455           ggg(3)=aux*zj
4456           do l=1,3
4457             ggg(l)=ggg(l)+(agg(l,1)*muij(1)+
4458      &          agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4))
4459      &    *fac_shield(i)*fac_shield(j)*sss
4460             gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l)
4461             gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l)
4462 cgrad            ghalf=0.5d0*ggg(l)
4463 cgrad            gel_loc(l,i)=gel_loc(l,i)+ghalf
4464 cgrad            gel_loc(l,j)=gel_loc(l,j)+ghalf
4465           enddo
4466 cgrad          do k=i+1,j2
4467 cgrad            do l=1,3
4468 cgrad              gel_loc(l,k)=gel_loc(l,k)+ggg(l)
4469 cgrad            enddo
4470 cgrad          enddo
4471 C Remaining derivatives of eello
4472           do l=1,3
4473             gel_loc(l,i)=gel_loc(l,i)+(aggi(l,1)*muij(1)+
4474      &        aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4))
4475      &    *fac_shield(i)*fac_shield(j)*sss
4476
4477             gel_loc(l,i+1)=gel_loc(l,i+1)+(aggi1(l,1)*muij(1)+
4478      &     aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4))
4479      &    *fac_shield(i)*fac_shield(j)*sss
4480
4481             gel_loc(l,j)=gel_loc(l,j)+(aggj(l,1)*muij(1)+
4482      &       aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4))
4483      &    *fac_shield(i)*fac_shield(j)*sss
4484
4485             gel_loc(l,j1)=gel_loc(l,j1)+(aggj1(l,1)*muij(1)+
4486      &     aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4))
4487      &    *fac_shield(i)*fac_shield(j)*sss
4488
4489           enddo
4490           ENDIF
4491 C Change 12/26/95 to calculate four-body contributions to H-bonding energy
4492 c          if (j.gt.i+1 .and. num_conti.le.maxconts) then
4493 #ifdef FOURBODY
4494           if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0
4495      &       .and. num_conti.le.maxconts) then
4496 c            write (iout,*) i,j," entered corr"
4497 C
4498 C Calculate the contact function. The ith column of the array JCONT will
4499 C contain the numbers of atoms that make contacts with the atom I (of numbers
4500 C greater than I). The arrays FACONT and GACONT will contain the values of
4501 C the contact function and its derivative.
4502 c           r0ij=1.02D0*rpp(iteli,itelj)
4503 c           r0ij=1.11D0*rpp(iteli,itelj)
4504             r0ij=2.20D0*rpp(iteli,itelj)
4505 c           r0ij=1.55D0*rpp(iteli,itelj)
4506             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
4507             if (fcont.gt.0.0D0) then
4508               num_conti=num_conti+1
4509               if (num_conti.gt.maxconts) then
4510                 write (iout,*) 'WARNING - max. # of contacts exceeded;',
4511      &                         ' will skip next contacts for this conf.'
4512               else
4513                 jcont_hb(num_conti,i)=j
4514 cd                write (iout,*) "i",i," j",j," num_conti",num_conti,
4515 cd     &           " jcont_hb",jcont_hb(num_conti,i)
4516                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.
4517      &          wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
4518 C 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
4519 C  terms.
4520                 d_cont(num_conti,i)=rij
4521 cd                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
4522 C     --- Electrostatic-interaction matrix ---
4523                 a_chuj(1,1,num_conti,i)=a22
4524                 a_chuj(1,2,num_conti,i)=a23
4525                 a_chuj(2,1,num_conti,i)=a32
4526                 a_chuj(2,2,num_conti,i)=a33
4527 C     --- Gradient of rij
4528                 do kkk=1,3
4529                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
4530                 enddo
4531                 kkll=0
4532                 do k=1,2
4533                   do l=1,2
4534                     kkll=kkll+1
4535                     do m=1,3
4536                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
4537                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
4538                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
4539                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
4540                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
4541                     enddo
4542                   enddo
4543                 enddo
4544                 ENDIF
4545                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
4546 C Calculate contact energies
4547                 cosa4=4.0D0*cosa
4548                 wij=cosa-3.0D0*cosb*cosg
4549                 cosbg1=cosb+cosg
4550                 cosbg2=cosb-cosg
4551 c               fac3=dsqrt(-ael6i)/r0ij**3
4552                 fac3=dsqrt(-ael6i)*r3ij
4553 c                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
4554                 ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
4555                 if (ees0tmp.gt.0) then
4556                   ees0pij=dsqrt(ees0tmp)
4557                 else
4558                   ees0pij=0
4559                 endif
4560 c                ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
4561                 ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
4562                 if (ees0tmp.gt.0) then
4563                   ees0mij=dsqrt(ees0tmp)
4564                 else
4565                   ees0mij=0
4566                 endif
4567 c               ees0mij=0.0D0
4568                 if (shield_mode.eq.0) then
4569                 fac_shield(i)=1.0d0
4570                 fac_shield(j)=1.0d0
4571                 else
4572                 ees0plist(num_conti,i)=j
4573 C                fac_shield(i)=0.4d0
4574 C                fac_shield(j)=0.6d0
4575                 endif
4576                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij)
4577      &          *fac_shield(i)*fac_shield(j)*sss
4578                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij)
4579      &          *fac_shield(i)*fac_shield(j)*sss
4580 C Diagnostics. Comment out or remove after debugging!
4581 c               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
4582 c               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
4583 c               ees0m(num_conti,i)=0.0D0
4584 C End diagnostics.
4585 c               write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
4586 c    & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
4587 C Angular derivatives of the contact function
4588                 ees0pij1=fac3/ees0pij
4589                 ees0mij1=fac3/ees0mij
4590                 fac3p=-3.0D0*fac3*rrmij
4591                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
4592                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
4593 c               ees0mij1=0.0D0
4594                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
4595                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
4596                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
4597                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
4598                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
4599                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
4600                 ecosap=ecosa1+ecosa2
4601                 ecosbp=ecosb1+ecosb2
4602                 ecosgp=ecosg1+ecosg2
4603                 ecosam=ecosa1-ecosa2
4604                 ecosbm=ecosb1-ecosb2
4605                 ecosgm=ecosg1-ecosg2
4606 C Diagnostics
4607 c               ecosap=ecosa1
4608 c               ecosbp=ecosb1
4609 c               ecosgp=ecosg1
4610 c               ecosam=0.0D0
4611 c               ecosbm=0.0D0
4612 c               ecosgm=0.0D0
4613 C End diagnostics
4614                 facont_hb(num_conti,i)=fcont
4615                 fprimcont=fprimcont/rij
4616 cd              facont_hb(num_conti,i)=1.0D0
4617 C Following line is for diagnostics.
4618 cd              fprimcont=0.0D0
4619                 do k=1,3
4620                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
4621                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
4622                 enddo
4623                 do k=1,3
4624                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
4625                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
4626                 enddo
4627                 gggp(1)=gggp(1)+ees0pijp*xj
4628      &          +ees0p(num_conti,i)/sss*rmij*xj*sssgrad
4629                 gggp(2)=gggp(2)+ees0pijp*yj
4630      &          +ees0p(num_conti,i)/sss*rmij*yj*sssgrad
4631                 gggp(3)=gggp(3)+ees0pijp*zj
4632      &          +ees0p(num_conti,i)/sss*rmij*zj*sssgrad
4633                 gggm(1)=gggm(1)+ees0mijp*xj
4634      &          +ees0m(num_conti,i)/sss*rmij*xj*sssgrad
4635                 gggm(2)=gggm(2)+ees0mijp*yj
4636      &          +ees0m(num_conti,i)/sss*rmij*yj*sssgrad
4637                 gggm(3)=gggm(3)+ees0mijp*zj
4638      &          +ees0m(num_conti,i)/sss*rmij*zj*sssgrad
4639 C Derivatives due to the contact function
4640                 gacont_hbr(1,num_conti,i)=fprimcont*xj
4641                 gacont_hbr(2,num_conti,i)=fprimcont*yj
4642                 gacont_hbr(3,num_conti,i)=fprimcont*zj
4643                 do k=1,3
4644 c
4645 c 10/24/08 cgrad and ! comments indicate the parts of the code removed
4646 c          following the change of gradient-summation algorithm.
4647 c
4648 cgrad                  ghalfp=0.5D0*gggp(k)
4649 cgrad                  ghalfm=0.5D0*gggm(k)
4650                   gacontp_hb1(k,num_conti,i)=!ghalfp
4651      &              +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i))
4652      &              + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
4653      &          *fac_shield(i)*fac_shield(j)*sss
4654
4655                   gacontp_hb2(k,num_conti,i)=!ghalfp
4656      &              +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j))
4657      &              + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
4658      &          *fac_shield(i)*fac_shield(j)*sss
4659
4660                   gacontp_hb3(k,num_conti,i)=gggp(k)
4661      &          *fac_shield(i)*fac_shield(j)*sss
4662
4663                   gacontm_hb1(k,num_conti,i)=!ghalfm
4664      &              +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i))
4665      &              + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
4666      &          *fac_shield(i)*fac_shield(j)*sss
4667
4668                   gacontm_hb2(k,num_conti,i)=!ghalfm
4669      &              +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j))
4670      &              + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
4671      &          *fac_shield(i)*fac_shield(j)*sss
4672
4673                   gacontm_hb3(k,num_conti,i)=gggm(k)
4674      &          *fac_shield(i)*fac_shield(j)*sss
4675
4676                 enddo
4677 C Diagnostics. Comment out or remove after debugging!
4678 cdiag           do k=1,3
4679 cdiag             gacontp_hb1(k,num_conti,i)=0.0D0
4680 cdiag             gacontp_hb2(k,num_conti,i)=0.0D0
4681 cdiag             gacontp_hb3(k,num_conti,i)=0.0D0
4682 cdiag             gacontm_hb1(k,num_conti,i)=0.0D0
4683 cdiag             gacontm_hb2(k,num_conti,i)=0.0D0
4684 cdiag             gacontm_hb3(k,num_conti,i)=0.0D0
4685 cdiag           enddo
4686               ENDIF ! wcorr
4687               endif  ! num_conti.le.maxconts
4688             endif  ! fcont.gt.0
4689           endif    ! j.gt.i+1
4690 #endif
4691           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
4692             do k=1,4
4693               do l=1,3
4694                 ghalf=0.5d0*agg(l,k)
4695                 aggi(l,k)=aggi(l,k)+ghalf
4696                 aggi1(l,k)=aggi1(l,k)+agg(l,k)
4697                 aggj(l,k)=aggj(l,k)+ghalf
4698               enddo
4699             enddo
4700             if (j.eq.nres-1 .and. i.lt.j-2) then
4701               do k=1,4
4702                 do l=1,3
4703                   aggj1(l,k)=aggj1(l,k)+agg(l,k)
4704                 enddo
4705               enddo
4706             endif
4707           endif
4708 c          t_eelecij=t_eelecij+MPI_Wtime()-time00
4709       return
4710       end
4711 C-----------------------------------------------------------------------------
4712       subroutine eturn3(i,eello_turn3)
4713 C Third- and fourth-order contributions from turns
4714       implicit real*8 (a-h,o-z)
4715       include 'DIMENSIONS'
4716       include 'COMMON.IOUNITS'
4717       include 'COMMON.GEO'
4718       include 'COMMON.VAR'
4719       include 'COMMON.LOCAL'
4720       include 'COMMON.CHAIN'
4721       include 'COMMON.DERIV'
4722       include 'COMMON.INTERACT'
4723       include 'COMMON.CORRMAT'
4724       include 'COMMON.TORSION'
4725       include 'COMMON.VECTORS'
4726       include 'COMMON.FFIELD'
4727       include 'COMMON.CONTROL'
4728       include 'COMMON.SHIELD'
4729       dimension ggg(3)
4730       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
4731      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
4732      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2),gpizda1(2,2),
4733      &  gpizda2(2,2),auxgmat1(2,2),auxgmatt1(2,2),
4734      &  auxgmat2(2,2),auxgmatt2(2,2)
4735       double precision agg(3,4),aggi(3,4),aggi1(3,4),
4736      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
4737       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
4738      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
4739      &    num_conti,j1,j2
4740       j=i+2
4741 c      write (iout,*) "eturn3",i,j,j1,j2
4742       a_temp(1,1)=a22
4743       a_temp(1,2)=a23
4744       a_temp(2,1)=a32
4745       a_temp(2,2)=a33
4746 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4747 C
4748 C               Third-order contributions
4749 C
4750 C                 (i+2)o----(i+3)
4751 C                      | |
4752 C                      | |
4753 C                 (i+1)o----i
4754 C
4755 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4756 cd        call checkint_turn3(i,a_temp,eello_turn3_num)
4757         call matmat2(EUg(1,1,i+1),EUg(1,1,i+2),auxmat(1,1))
4758 c auxalary matices for theta gradient
4759 c auxalary matrix for i+1 and constant i+2
4760         call matmat2(gtEUg(1,1,i+1),EUg(1,1,i+2),auxgmat1(1,1))
4761 c auxalary matrix for i+2 and constant i+1
4762         call matmat2(EUg(1,1,i+1),gtEUg(1,1,i+2),auxgmat2(1,1))
4763         call transpose2(auxmat(1,1),auxmat1(1,1))
4764         call transpose2(auxgmat1(1,1),auxgmatt1(1,1))
4765         call transpose2(auxgmat2(1,1),auxgmatt2(1,1))
4766         call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4767         call matmat2(a_temp(1,1),auxgmatt1(1,1),gpizda1(1,1))
4768         call matmat2(a_temp(1,1),auxgmatt2(1,1),gpizda2(1,1))
4769         if (shield_mode.eq.0) then
4770         fac_shield(i)=1.0
4771         fac_shield(j)=1.0
4772 C        else
4773 C        fac_shield(i)=0.4
4774 C        fac_shield(j)=0.6
4775         endif
4776         eello_turn3=eello_turn3+0.5d0*(pizda(1,1)+pizda(2,2))
4777      &  *fac_shield(i)*fac_shield(j)
4778         eello_t3=0.5d0*(pizda(1,1)+pizda(2,2))
4779      &  *fac_shield(i)*fac_shield(j)
4780         if (energy_dec) write (iout,'(6heturn3,2i5,0pf7.3)') i,i+2,
4781      &    eello_t3
4782 C#ifdef NEWCORR
4783 C Derivatives in theta
4784         gloc(nphi+i,icg)=gloc(nphi+i,icg)
4785      &  +0.5d0*(gpizda1(1,1)+gpizda1(2,2))*wturn3
4786      &   *fac_shield(i)*fac_shield(j)
4787         gloc(nphi+i+1,icg)=gloc(nphi+i+1,icg)
4788      &  +0.5d0*(gpizda2(1,1)+gpizda2(2,2))*wturn3
4789      &   *fac_shield(i)*fac_shield(j)
4790 C#endif
4791
4792 C Derivatives in shield mode
4793           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
4794      &  (shield_mode.gt.0)) then
4795 C          print *,i,j
4796
4797           do ilist=1,ishield_list(i)
4798            iresshield=shield_list(ilist,i)
4799            do k=1,3
4800            rlocshield=grad_shield_side(k,ilist,i)*eello_t3/fac_shield(i)
4801 C     &      *2.0
4802            gshieldx_t3(k,iresshield)=gshieldx_t3(k,iresshield)+
4803      &              rlocshield
4804      & +grad_shield_loc(k,ilist,i)*eello_t3/fac_shield(i)
4805             gshieldc_t3(k,iresshield-1)=gshieldc_t3(k,iresshield-1)
4806      &      +rlocshield
4807            enddo
4808           enddo
4809           do ilist=1,ishield_list(j)
4810            iresshield=shield_list(ilist,j)
4811            do k=1,3
4812            rlocshield=grad_shield_side(k,ilist,j)*eello_t3/fac_shield(j)
4813 C     &     *2.0
4814            gshieldx_t3(k,iresshield)=gshieldx_t3(k,iresshield)+
4815      &              rlocshield
4816      & +grad_shield_loc(k,ilist,j)*eello_t3/fac_shield(j)
4817            gshieldc_t3(k,iresshield-1)=gshieldc_t3(k,iresshield-1)
4818      &             +rlocshield
4819
4820            enddo
4821           enddo
4822
4823           do k=1,3
4824             gshieldc_t3(k,i)=gshieldc_t3(k,i)+
4825      &              grad_shield(k,i)*eello_t3/fac_shield(i)
4826             gshieldc_t3(k,j)=gshieldc_t3(k,j)+
4827      &              grad_shield(k,j)*eello_t3/fac_shield(j)
4828             gshieldc_t3(k,i-1)=gshieldc_t3(k,i-1)+
4829      &              grad_shield(k,i)*eello_t3/fac_shield(i)
4830             gshieldc_t3(k,j-1)=gshieldc_t3(k,j-1)+
4831      &              grad_shield(k,j)*eello_t3/fac_shield(j)
4832            enddo
4833            endif
4834
4835 C        if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
4836 cd        write (2,*) 'i,',i,' j',j,'eello_turn3',
4837 cd     &    0.5d0*(pizda(1,1)+pizda(2,2)),
4838 cd     &    ' eello_turn3_num',4*eello_turn3_num
4839 C Derivatives in gamma(i)
4840         call matmat2(EUgder(1,1,i+1),EUg(1,1,i+2),auxmat2(1,1))
4841         call transpose2(auxmat2(1,1),auxmat3(1,1))
4842         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
4843         gel_loc_turn3(i)=gel_loc_turn3(i)+0.5d0*(pizda(1,1)+pizda(2,2))
4844      &   *fac_shield(i)*fac_shield(j)
4845 C Derivatives in gamma(i+1)
4846         call matmat2(EUg(1,1,i+1),EUgder(1,1,i+2),auxmat2(1,1))
4847         call transpose2(auxmat2(1,1),auxmat3(1,1))
4848         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
4849         gel_loc_turn3(i+1)=gel_loc_turn3(i+1)
4850      &    +0.5d0*(pizda(1,1)+pizda(2,2))
4851      &   *fac_shield(i)*fac_shield(j)
4852 C Cartesian derivatives
4853         do l=1,3
4854 c            ghalf1=0.5d0*agg(l,1)
4855 c            ghalf2=0.5d0*agg(l,2)
4856 c            ghalf3=0.5d0*agg(l,3)
4857 c            ghalf4=0.5d0*agg(l,4)
4858           a_temp(1,1)=aggi(l,1)!+ghalf1
4859           a_temp(1,2)=aggi(l,2)!+ghalf2
4860           a_temp(2,1)=aggi(l,3)!+ghalf3
4861           a_temp(2,2)=aggi(l,4)!+ghalf4
4862           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4863           gcorr3_turn(l,i)=gcorr3_turn(l,i)
4864      &      +0.5d0*(pizda(1,1)+pizda(2,2))
4865      &   *fac_shield(i)*fac_shield(j)
4866
4867           a_temp(1,1)=aggi1(l,1)!+agg(l,1)
4868           a_temp(1,2)=aggi1(l,2)!+agg(l,2)
4869           a_temp(2,1)=aggi1(l,3)!+agg(l,3)
4870           a_temp(2,2)=aggi1(l,4)!+agg(l,4)
4871           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4872           gcorr3_turn(l,i+1)=gcorr3_turn(l,i+1)
4873      &      +0.5d0*(pizda(1,1)+pizda(2,2))
4874      &   *fac_shield(i)*fac_shield(j)
4875           a_temp(1,1)=aggj(l,1)!+ghalf1
4876           a_temp(1,2)=aggj(l,2)!+ghalf2
4877           a_temp(2,1)=aggj(l,3)!+ghalf3
4878           a_temp(2,2)=aggj(l,4)!+ghalf4
4879           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4880           gcorr3_turn(l,j)=gcorr3_turn(l,j)
4881      &      +0.5d0*(pizda(1,1)+pizda(2,2))
4882      &   *fac_shield(i)*fac_shield(j)
4883           a_temp(1,1)=aggj1(l,1)
4884           a_temp(1,2)=aggj1(l,2)
4885           a_temp(2,1)=aggj1(l,3)
4886           a_temp(2,2)=aggj1(l,4)
4887           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4888           gcorr3_turn(l,j1)=gcorr3_turn(l,j1)
4889      &      +0.5d0*(pizda(1,1)+pizda(2,2))
4890      &   *fac_shield(i)*fac_shield(j)
4891         enddo
4892       return
4893       end
4894 C-------------------------------------------------------------------------------
4895       subroutine eturn4(i,eello_turn4)
4896 C Third- and fourth-order contributions from turns
4897       implicit real*8 (a-h,o-z)
4898       include 'DIMENSIONS'
4899       include 'COMMON.IOUNITS'
4900       include 'COMMON.GEO'
4901       include 'COMMON.VAR'
4902       include 'COMMON.LOCAL'
4903       include 'COMMON.CHAIN'
4904       include 'COMMON.DERIV'
4905       include 'COMMON.INTERACT'
4906       include 'COMMON.CORRMAT'
4907       include 'COMMON.TORSION'
4908       include 'COMMON.VECTORS'
4909       include 'COMMON.FFIELD'
4910       include 'COMMON.CONTROL'
4911       include 'COMMON.SHIELD'
4912       dimension ggg(3)
4913       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
4914      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
4915      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2),auxgvec(2),
4916      &  auxgEvec1(2),auxgEvec2(2),auxgEvec3(2),
4917      &  gte1t(2,2),gte2t(2,2),gte3t(2,2),
4918      &  gte1a(2,2),gtae3(2,2),gtae3e2(2,2), ae3gte2(2,2),
4919      &  gtEpizda1(2,2),gtEpizda2(2,2),gtEpizda3(2,2)
4920       double precision agg(3,4),aggi(3,4),aggi1(3,4),
4921      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
4922       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
4923      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
4924      &    num_conti,j1,j2
4925       j=i+3
4926 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4927 C
4928 C               Fourth-order contributions
4929 C
4930 C                 (i+3)o----(i+4)
4931 C                     /  |
4932 C               (i+2)o   |
4933 C                     \  |
4934 C                 (i+1)o----i
4935 C
4936 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4937 cd        call checkint_turn4(i,a_temp,eello_turn4_num)
4938 c        write (iout,*) "eturn4 i",i," j",j," j1",j1," j2",j2
4939 c        write(iout,*)"WCHODZE W PROGRAM"
4940         a_temp(1,1)=a22
4941         a_temp(1,2)=a23
4942         a_temp(2,1)=a32
4943         a_temp(2,2)=a33
4944         iti1=itype2loc(itype(i+1))
4945         iti2=itype2loc(itype(i+2))
4946         iti3=itype2loc(itype(i+3))
4947 c        write(iout,*) "iti1",iti1," iti2",iti2," iti3",iti3
4948         call transpose2(EUg(1,1,i+1),e1t(1,1))
4949         call transpose2(Eug(1,1,i+2),e2t(1,1))
4950         call transpose2(Eug(1,1,i+3),e3t(1,1))
4951 C Ematrix derivative in theta
4952         call transpose2(gtEUg(1,1,i+1),gte1t(1,1))
4953         call transpose2(gtEug(1,1,i+2),gte2t(1,1))
4954         call transpose2(gtEug(1,1,i+3),gte3t(1,1))
4955         call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4956 c       eta1 in derivative theta
4957         call matmat2(gte1t(1,1),a_temp(1,1),gte1a(1,1))
4958         call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4959 c       auxgvec is derivative of Ub2 so i+3 theta
4960         call matvec2(e1a(1,1),gUb2(1,i+3),auxgvec(1))
4961 c       auxalary matrix of E i+1
4962         call matvec2(gte1a(1,1),Ub2(1,i+3),auxgEvec1(1))
4963 c        s1=0.0
4964 c        gs1=0.0
4965         s1=scalar2(b1(1,i+2),auxvec(1))
4966 c derivative of theta i+2 with constant i+3
4967         gs23=scalar2(gtb1(1,i+2),auxvec(1))
4968 c derivative of theta i+2 with constant i+2
4969         gs32=scalar2(b1(1,i+2),auxgvec(1))
4970 c derivative of E matix in theta of i+1
4971         gsE13=scalar2(b1(1,i+2),auxgEvec1(1))
4972
4973         call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4974 c       ea31 in derivative theta
4975         call matmat2(a_temp(1,1),gte3t(1,1),gtae3(1,1))
4976         call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4977 c auxilary matrix auxgvec of Ub2 with constant E matirx
4978         call matvec2(ae3(1,1),gUb2(1,i+2),auxgvec(1))
4979 c auxilary matrix auxgEvec1 of E matix with Ub2 constant
4980         call matvec2(gtae3(1,1),Ub2(1,i+2),auxgEvec3(1))
4981
4982 c        s2=0.0
4983 c        gs2=0.0
4984         s2=scalar2(b1(1,i+1),auxvec(1))
4985 c derivative of theta i+1 with constant i+3
4986         gs13=scalar2(gtb1(1,i+1),auxvec(1))
4987 c derivative of theta i+2 with constant i+1
4988         gs21=scalar2(b1(1,i+1),auxgvec(1))
4989 c derivative of theta i+3 with constant i+1
4990         gsE31=scalar2(b1(1,i+1),auxgEvec3(1))
4991 c        write(iout,*) gs1,gs2,'i=',i,auxgvec(1),gUb2(1,i+2),gtb1(1,i+2),
4992 c     &  gtb1(1,i+1)
4993         call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4994 c two derivatives over diffetent matrices
4995 c gtae3e2 is derivative over i+3
4996         call matmat2(gtae3(1,1),e2t(1,1),gtae3e2(1,1))
4997 c ae3gte2 is derivative over i+2
4998         call matmat2(ae3(1,1),gte2t(1,1),ae3gte2(1,1))
4999         call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5000 c three possible derivative over theta E matices
5001 c i+1
5002         call matmat2(ae3e2(1,1),gte1t(1,1),gtEpizda1(1,1))
5003 c i+2
5004         call matmat2(ae3gte2(1,1),e1t(1,1),gtEpizda2(1,1))
5005 c i+3
5006         call matmat2(gtae3e2(1,1),e1t(1,1),gtEpizda3(1,1))
5007         s3=0.5d0*(pizda(1,1)+pizda(2,2))
5008
5009         gsEE1=0.5d0*(gtEpizda1(1,1)+gtEpizda1(2,2))
5010         gsEE2=0.5d0*(gtEpizda2(1,1)+gtEpizda2(2,2))
5011         gsEE3=0.5d0*(gtEpizda3(1,1)+gtEpizda3(2,2))
5012         if (shield_mode.eq.0) then
5013         fac_shield(i)=1.0
5014         fac_shield(j)=1.0
5015 C        else
5016 C        fac_shield(i)=0.6
5017 C        fac_shield(j)=0.4
5018         endif
5019         eello_turn4=eello_turn4-(s1+s2+s3)
5020      &  *fac_shield(i)*fac_shield(j)
5021         eello_t4=-(s1+s2+s3)
5022      &  *fac_shield(i)*fac_shield(j)
5023 c             write(iout,*)'chujOWO', auxvec(1),b1(1,iti2)
5024         if (energy_dec) write (iout,'(a6,2i5,0pf7.3,3f7.3)')
5025      &      'eturn4',i,j,-(s1+s2+s3),s1,s2,s3
5026 C Now derivative over shield:
5027           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
5028      &  (shield_mode.gt.0)) then
5029 C          print *,i,j
5030
5031           do ilist=1,ishield_list(i)
5032            iresshield=shield_list(ilist,i)
5033            do k=1,3
5034            rlocshield=grad_shield_side(k,ilist,i)*eello_t4/fac_shield(i)
5035 C     &      *2.0
5036            gshieldx_t4(k,iresshield)=gshieldx_t4(k,iresshield)+
5037      &              rlocshield
5038      & +grad_shield_loc(k,ilist,i)*eello_t4/fac_shield(i)
5039             gshieldc_t4(k,iresshield-1)=gshieldc_t4(k,iresshield-1)
5040      &      +rlocshield
5041            enddo
5042           enddo
5043           do ilist=1,ishield_list(j)
5044            iresshield=shield_list(ilist,j)
5045            do k=1,3
5046            rlocshield=grad_shield_side(k,ilist,j)*eello_t4/fac_shield(j)
5047 C     &     *2.0
5048            gshieldx_t4(k,iresshield)=gshieldx_t4(k,iresshield)+
5049      &              rlocshield
5050      & +grad_shield_loc(k,ilist,j)*eello_t4/fac_shield(j)
5051            gshieldc_t4(k,iresshield-1)=gshieldc_t4(k,iresshield-1)
5052      &             +rlocshield
5053
5054            enddo
5055           enddo
5056
5057           do k=1,3
5058             gshieldc_t4(k,i)=gshieldc_t4(k,i)+
5059      &              grad_shield(k,i)*eello_t4/fac_shield(i)
5060             gshieldc_t4(k,j)=gshieldc_t4(k,j)+
5061      &              grad_shield(k,j)*eello_t4/fac_shield(j)
5062             gshieldc_t4(k,i-1)=gshieldc_t4(k,i-1)+
5063      &              grad_shield(k,i)*eello_t4/fac_shield(i)
5064             gshieldc_t4(k,j-1)=gshieldc_t4(k,j-1)+
5065      &              grad_shield(k,j)*eello_t4/fac_shield(j)
5066            enddo
5067            endif
5068
5069
5070
5071
5072
5073
5074 cd        write (2,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
5075 cd     &    ' eello_turn4_num',8*eello_turn4_num
5076 #ifdef NEWCORR
5077         gloc(nphi+i,icg)=gloc(nphi+i,icg)
5078      &                  -(gs13+gsE13+gsEE1)*wturn4
5079      &  *fac_shield(i)*fac_shield(j)
5080         gloc(nphi+i+1,icg)= gloc(nphi+i+1,icg)
5081      &                    -(gs23+gs21+gsEE2)*wturn4
5082      &  *fac_shield(i)*fac_shield(j)
5083
5084         gloc(nphi+i+2,icg)= gloc(nphi+i+2,icg)
5085      &                    -(gs32+gsE31+gsEE3)*wturn4
5086      &  *fac_shield(i)*fac_shield(j)
5087
5088 c         gloc(nphi+i+1,icg)=gloc(nphi+i+1,icg)-
5089 c     &   gs2
5090 #endif
5091         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
5092      &      'eturn4',i,j,-(s1+s2+s3)
5093 c        write (iout,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
5094 c     &    ' eello_turn4_num',8*eello_turn4_num
5095 C Derivatives in gamma(i)
5096         call transpose2(EUgder(1,1,i+1),e1tder(1,1))
5097         call matmat2(e1tder(1,1),a_temp(1,1),auxmat(1,1))
5098         call matvec2(auxmat(1,1),Ub2(1,i+3),auxvec(1))
5099         s1=scalar2(b1(1,i+2),auxvec(1))
5100         call matmat2(ae3e2(1,1),e1tder(1,1),pizda(1,1))
5101         s3=0.5d0*(pizda(1,1)+pizda(2,2))
5102         gel_loc_turn4(i)=gel_loc_turn4(i)-(s1+s3)
5103      &  *fac_shield(i)*fac_shield(j)
5104 C Derivatives in gamma(i+1)
5105         call transpose2(EUgder(1,1,i+2),e2tder(1,1))
5106         call matvec2(ae3(1,1),Ub2der(1,i+2),auxvec(1))
5107         s2=scalar2(b1(1,i+1),auxvec(1))
5108         call matmat2(ae3(1,1),e2tder(1,1),auxmat(1,1))
5109         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
5110         s3=0.5d0*(pizda(1,1)+pizda(2,2))
5111         gel_loc_turn4(i+1)=gel_loc_turn4(i+1)-(s2+s3)
5112      &  *fac_shield(i)*fac_shield(j)
5113 C Derivatives in gamma(i+2)
5114         call transpose2(EUgder(1,1,i+3),e3tder(1,1))
5115         call matvec2(e1a(1,1),Ub2der(1,i+3),auxvec(1))
5116         s1=scalar2(b1(1,i+2),auxvec(1))
5117         call matmat2(a_temp(1,1),e3tder(1,1),auxmat(1,1))
5118         call matvec2(auxmat(1,1),Ub2(1,i+2),auxvec(1))
5119         s2=scalar2(b1(1,i+1),auxvec(1))
5120         call matmat2(auxmat(1,1),e2t(1,1),auxmat3(1,1))
5121         call matmat2(auxmat3(1,1),e1t(1,1),pizda(1,1))
5122         s3=0.5d0*(pizda(1,1)+pizda(2,2))
5123         gel_loc_turn4(i+2)=gel_loc_turn4(i+2)-(s1+s2+s3)
5124      &  *fac_shield(i)*fac_shield(j)
5125 C Cartesian derivatives
5126 C Derivatives of this turn contributions in DC(i+2)
5127         if (j.lt.nres-1) then
5128           do l=1,3
5129             a_temp(1,1)=agg(l,1)
5130             a_temp(1,2)=agg(l,2)
5131             a_temp(2,1)=agg(l,3)
5132             a_temp(2,2)=agg(l,4)
5133             call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5134             call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5135             s1=scalar2(b1(1,i+2),auxvec(1))
5136             call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5137             call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5138             s2=scalar2(b1(1,i+1),auxvec(1))
5139             call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5140             call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5141             s3=0.5d0*(pizda(1,1)+pizda(2,2))
5142             ggg(l)=-(s1+s2+s3)
5143             gcorr4_turn(l,i+2)=gcorr4_turn(l,i+2)-(s1+s2+s3)
5144      &  *fac_shield(i)*fac_shield(j)
5145           enddo
5146         endif
5147 C Remaining derivatives of this turn contribution
5148         do l=1,3
5149           a_temp(1,1)=aggi(l,1)
5150           a_temp(1,2)=aggi(l,2)
5151           a_temp(2,1)=aggi(l,3)
5152           a_temp(2,2)=aggi(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           gcorr4_turn(l,i)=gcorr4_turn(l,i)-(s1+s2+s3)
5163      &  *fac_shield(i)*fac_shield(j)
5164           a_temp(1,1)=aggi1(l,1)
5165           a_temp(1,2)=aggi1(l,2)
5166           a_temp(2,1)=aggi1(l,3)
5167           a_temp(2,2)=aggi1(l,4)
5168           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5169           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5170           s1=scalar2(b1(1,i+2),auxvec(1))
5171           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5172           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5173           s2=scalar2(b1(1,i+1),auxvec(1))
5174           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5175           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5176           s3=0.5d0*(pizda(1,1)+pizda(2,2))
5177           gcorr4_turn(l,i+1)=gcorr4_turn(l,i+1)-(s1+s2+s3)
5178      &  *fac_shield(i)*fac_shield(j)
5179           a_temp(1,1)=aggj(l,1)
5180           a_temp(1,2)=aggj(l,2)
5181           a_temp(2,1)=aggj(l,3)
5182           a_temp(2,2)=aggj(l,4)
5183           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5184           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5185           s1=scalar2(b1(1,i+2),auxvec(1))
5186           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5187           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5188           s2=scalar2(b1(1,i+1),auxvec(1))
5189           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5190           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5191           s3=0.5d0*(pizda(1,1)+pizda(2,2))
5192           gcorr4_turn(l,j)=gcorr4_turn(l,j)-(s1+s2+s3)
5193      &  *fac_shield(i)*fac_shield(j)
5194           a_temp(1,1)=aggj1(l,1)
5195           a_temp(1,2)=aggj1(l,2)
5196           a_temp(2,1)=aggj1(l,3)
5197           a_temp(2,2)=aggj1(l,4)
5198           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5199           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5200           s1=scalar2(b1(1,i+2),auxvec(1))
5201           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5202           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5203           s2=scalar2(b1(1,i+1),auxvec(1))
5204           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5205           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5206           s3=0.5d0*(pizda(1,1)+pizda(2,2))
5207 c          write (iout,*) "s1",s1," s2",s2," s3",s3," s1+s2+s3",s1+s2+s3
5208           gcorr4_turn(l,j1)=gcorr4_turn(l,j1)-(s1+s2+s3)
5209      &  *fac_shield(i)*fac_shield(j)
5210         enddo
5211       return
5212       end
5213 C-----------------------------------------------------------------------------
5214       subroutine vecpr(u,v,w)
5215       implicit real*8(a-h,o-z)
5216       dimension u(3),v(3),w(3)
5217       w(1)=u(2)*v(3)-u(3)*v(2)
5218       w(2)=-u(1)*v(3)+u(3)*v(1)
5219       w(3)=u(1)*v(2)-u(2)*v(1)
5220       return
5221       end
5222 C-----------------------------------------------------------------------------
5223       subroutine unormderiv(u,ugrad,unorm,ungrad)
5224 C This subroutine computes the derivatives of a normalized vector u, given
5225 C the derivatives computed without normalization conditions, ugrad. Returns
5226 C ungrad.
5227       implicit none
5228       double precision u(3),ugrad(3,3),unorm,ungrad(3,3)
5229       double precision vec(3)
5230       double precision scalar
5231       integer i,j
5232 c      write (2,*) 'ugrad',ugrad
5233 c      write (2,*) 'u',u
5234       do i=1,3
5235         vec(i)=scalar(ugrad(1,i),u(1))
5236       enddo
5237 c      write (2,*) 'vec',vec
5238       do i=1,3
5239         do j=1,3
5240           ungrad(j,i)=(ugrad(j,i)-u(j)*vec(i))*unorm
5241         enddo
5242       enddo
5243 c      write (2,*) 'ungrad',ungrad
5244       return
5245       end
5246 C-----------------------------------------------------------------------------
5247       subroutine escp_soft_sphere(evdw2,evdw2_14)
5248 C
5249 C This subroutine calculates the excluded-volume interaction energy between
5250 C peptide-group centers and side chains and its gradient in virtual-bond and
5251 C side-chain vectors.
5252 C
5253       implicit real*8 (a-h,o-z)
5254       include 'DIMENSIONS'
5255       include 'COMMON.GEO'
5256       include 'COMMON.VAR'
5257       include 'COMMON.LOCAL'
5258       include 'COMMON.CHAIN'
5259       include 'COMMON.DERIV'
5260       include 'COMMON.INTERACT'
5261       include 'COMMON.FFIELD'
5262       include 'COMMON.IOUNITS'
5263       include 'COMMON.CONTROL'
5264       dimension ggg(3)
5265       double precision boxshift
5266       evdw2=0.0D0
5267       evdw2_14=0.0d0
5268       r0_scp=4.5d0
5269 cd    print '(a)','Enter ESCP'
5270 cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
5271 C      do xshift=-1,1
5272 C      do yshift=-1,1
5273 C      do zshift=-1,1
5274 c      do i=iatscp_s,iatscp_e
5275       do ikont=g_listscp_start,g_listscp_end
5276         i=newcontlistscpi(ikont)
5277         j=newcontlistscpj(ikont)
5278         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
5279         iteli=itel(i)
5280         xi=0.5D0*(c(1,i)+c(1,i+1))
5281         yi=0.5D0*(c(2,i)+c(2,i+1))
5282         zi=0.5D0*(c(3,i)+c(3,i+1))
5283 C Return atom into box, boxxsize is size of box in x dimension
5284 c  134   continue
5285 c        if (xi.gt.((xshift+0.5d0)*boxxsize)) xi=xi-boxxsize
5286 c        if (xi.lt.((xshift-0.5d0)*boxxsize)) xi=xi+boxxsize
5287 C Condition for being inside the proper box
5288 c        if ((xi.gt.((xshift+0.5d0)*boxxsize)).or.
5289 c     &       (xi.lt.((xshift-0.5d0)*boxxsize))) then
5290 c        go to 134
5291 c        endif
5292 c  135   continue
5293 c        if (yi.gt.((yshift+0.5d0)*boxysize)) yi=yi-boxysize
5294 c        if (yi.lt.((yshift-0.5d0)*boxysize)) yi=yi+boxysize
5295 C Condition for being inside the proper box
5296 c        if ((yi.gt.((yshift+0.5d0)*boxysize)).or.
5297 c     &       (yi.lt.((yshift-0.5d0)*boxysize))) then
5298 c        go to 135
5299 c c       endif
5300 c  136   continue
5301 c        if (zi.gt.((zshift+0.5d0)*boxzsize)) zi=zi-boxzsize
5302 c        if (zi.lt.((zshift-0.5d0)*boxzsize)) zi=zi+boxzsize
5303 cC Condition for being inside the proper box
5304 c        if ((zi.gt.((zshift+0.5d0)*boxzsize)).or.
5305 c     &       (zi.lt.((zshift-0.5d0)*boxzsize))) then
5306 c        go to 136
5307 c        endif
5308           call to_box(xi,yi,zi)
5309 C          xi=xi+xshift*boxxsize
5310 C          yi=yi+yshift*boxysize
5311 C          zi=zi+zshift*boxzsize
5312 c        do iint=1,nscp_gr(i)
5313
5314 c        do j=iscpstart(i,iint),iscpend(i,iint)
5315           if (itype(j).eq.ntyp1) cycle
5316           itypj=iabs(itype(j))
5317 C Uncomment following three lines for SC-p interactions
5318 c         xj=c(1,nres+j)-xi
5319 c         yj=c(2,nres+j)-yi
5320 c         zj=c(3,nres+j)-zi
5321 C Uncomment following three lines for Ca-p interactions
5322           xj=c(1,j)
5323           yj=c(2,j)
5324           zj=c(3,j)
5325           call to_box(xj,yj,zj)
5326           xj=boxshift(xj-xi,boxxsize)
5327           yj=boxshift(yj-yi,boxysize)
5328           zj=boxshift(zj-zi,boxzsize)
5329 C          xj=xj-xi
5330 C          yj=yj-yi
5331 C          zj=zj-zi
5332           rij=xj*xj+yj*yj+zj*zj
5333
5334           r0ij=r0_scp
5335           r0ijsq=r0ij*r0ij
5336           if (rij.lt.r0ijsq) then
5337             evdwij=0.25d0*(rij-r0ijsq)**2
5338             fac=rij-r0ijsq
5339           else
5340             evdwij=0.0d0
5341             fac=0.0d0
5342           endif
5343           evdw2=evdw2+evdwij
5344 C
5345 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
5346 C
5347           ggg(1)=xj*fac
5348           ggg(2)=yj*fac
5349           ggg(3)=zj*fac
5350           do k=1,3
5351             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
5352             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
5353           enddo
5354 c        enddo
5355
5356 c        enddo ! iint
5357       enddo ! i
5358 C      enddo !zshift
5359 C      enddo !yshift
5360 C      enddo !xshift
5361       return
5362       end
5363 C-----------------------------------------------------------------------------
5364       subroutine escp(evdw2,evdw2_14)
5365 C
5366 C This subroutine calculates the excluded-volume interaction energy between
5367 C peptide-group centers and side chains and its gradient in virtual-bond and
5368 C side-chain vectors.
5369 C
5370       implicit none
5371       include 'DIMENSIONS'
5372       include 'COMMON.GEO'
5373       include 'COMMON.VAR'
5374       include 'COMMON.LOCAL'
5375       include 'COMMON.CHAIN'
5376       include 'COMMON.DERIV'
5377       include 'COMMON.INTERACT'
5378       include 'COMMON.FFIELD'
5379       include 'COMMON.IOUNITS'
5380       include 'COMMON.CONTROL'
5381       include 'COMMON.SPLITELE'
5382       double precision ggg(3)
5383       integer i,iint,j,k,iteli,itypj,subchap,ikont
5384       double precision xi,yi,zi,xj,yj,zj,rrij,sss1,sssgrad1,
5385      & fac,e1,e2,rij
5386       double precision evdw2,evdw2_14,evdwij
5387       double precision sscale,sscagrad
5388       double precision boxshift
5389       evdw2=0.0D0
5390       evdw2_14=0.0d0
5391 c        print *,boxxsize,boxysize,boxzsize,'wymiary pudla'
5392 cd    print '(a)','Enter ESCP'
5393 cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
5394 C      do xshift=-1,1
5395 C      do yshift=-1,1
5396 C      do zshift=-1,1
5397       if (energy_dec) write (iout,*) "escp:",r_cut_int,rlamb
5398 c      do i=iatscp_s,iatscp_e
5399       do ikont=g_listscp_start,g_listscp_end
5400         i=newcontlistscpi(ikont)
5401         j=newcontlistscpj(ikont)
5402         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
5403         iteli=itel(i)
5404         xi=0.5D0*(c(1,i)+c(1,i+1))
5405         yi=0.5D0*(c(2,i)+c(2,i+1))
5406         zi=0.5D0*(c(3,i)+c(3,i+1))
5407         call to_box(xi,yi,zi)
5408 c        do iint=1,nscp_gr(i)
5409
5410 c        do j=iscpstart(i,iint),iscpend(i,iint)
5411           itypj=iabs(itype(j))
5412           if (itypj.eq.ntyp1) cycle
5413 C Uncomment following three lines for SC-p interactions
5414 c         xj=c(1,nres+j)-xi
5415 c         yj=c(2,nres+j)-yi
5416 c         zj=c(3,nres+j)-zi
5417 C Uncomment following three lines for Ca-p interactions
5418           xj=c(1,j)
5419           yj=c(2,j)
5420           zj=c(3,j)
5421           call to_box(xj,yj,zj)
5422           xj=boxshift(xj-xi,boxxsize)
5423           yj=boxshift(yj-yi,boxysize)
5424           zj=boxshift(zj-zi,boxzsize)
5425 c          print *,xj,yj,zj,'polozenie j'
5426           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
5427 c          print *,rrij
5428           sss=sscale(1.0d0/(dsqrt(rrij)),r_cut_int)
5429 c          print *,r_cut,1.0d0/dsqrt(rrij),sss,'tu patrz'
5430 c          if (sss.eq.0) print *,'czasem jest OK'
5431           if (sss.le.0.0d0) cycle
5432           sssgrad=sscagrad(1.0d0/(dsqrt(rrij)),r_cut_int)
5433           fac=rrij**expon2
5434           e1=fac*fac*aad(itypj,iteli)
5435           e2=fac*bad(itypj,iteli)
5436           if (iabs(j-i) .le. 2) then
5437             e1=scal14*e1
5438             e2=scal14*e2
5439             evdw2_14=evdw2_14+(e1+e2)*sss
5440           endif
5441           evdwij=e1+e2
5442           evdw2=evdw2+evdwij*sss
5443           if (energy_dec) write (iout,'(a6,2i5,3f7.3,2i3,3e11.3)')
5444      &        'evdw2',i,j,1.0d0/dsqrt(rrij),sss,
5445      &       evdwij,iteli,itypj,fac,aad(itypj,iteli),
5446      &       bad(itypj,iteli)
5447 C
5448 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
5449 C
5450           fac=-(evdwij+e1)*rrij*sss
5451           fac=fac+(evdwij)*sssgrad*dsqrt(rrij)/expon
5452           ggg(1)=xj*fac
5453           ggg(2)=yj*fac
5454           ggg(3)=zj*fac
5455 cgrad          if (j.lt.i) then
5456 cd          write (iout,*) 'j<i'
5457 C Uncomment following three lines for SC-p interactions
5458 c           do k=1,3
5459 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
5460 c           enddo
5461 cgrad          else
5462 cd          write (iout,*) 'j>i'
5463 cgrad            do k=1,3
5464 cgrad              ggg(k)=-ggg(k)
5465 C Uncomment following line for SC-p interactions
5466 ccgrad             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
5467 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
5468 cgrad            enddo
5469 cgrad          endif
5470 cgrad          do k=1,3
5471 cgrad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
5472 cgrad          enddo
5473 cgrad          kstart=min0(i+1,j)
5474 cgrad          kend=max0(i-1,j-1)
5475 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
5476 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
5477 cgrad          do k=kstart,kend
5478 cgrad            do l=1,3
5479 cgrad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
5480 cgrad            enddo
5481 cgrad          enddo
5482           do k=1,3
5483             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
5484             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
5485           enddo
5486 c        endif !endif for sscale cutoff
5487 c        enddo ! j
5488
5489 c        enddo ! iint
5490       enddo ! i
5491 c      enddo !zshift
5492 c      enddo !yshift
5493 c      enddo !xshift
5494       do i=1,nct
5495         do j=1,3
5496           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
5497           gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
5498           gradx_scp(j,i)=expon*gradx_scp(j,i)
5499         enddo
5500       enddo
5501 C******************************************************************************
5502 C
5503 C                              N O T E !!!
5504 C
5505 C To save time the factor EXPON has been extracted from ALL components
5506 C of GVDWC and GRADX. Remember to multiply them by this factor before further
5507 C use!
5508 C
5509 C******************************************************************************
5510       return
5511       end
5512 C--------------------------------------------------------------------------
5513       subroutine edis(ehpb)
5514 C
5515 C Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors.
5516 C
5517       implicit real*8 (a-h,o-z)
5518       include 'DIMENSIONS'
5519       include 'COMMON.SBRIDGE'
5520       include 'COMMON.CHAIN'
5521       include 'COMMON.DERIV'
5522       include 'COMMON.VAR'
5523       include 'COMMON.INTERACT'
5524       include 'COMMON.IOUNITS'
5525       include 'COMMON.CONTROL'
5526       dimension ggg(3),ggg_peak(3,1000)
5527       ehpb=0.0D0
5528       do i=1,3
5529        ggg(i)=0.0d0
5530       enddo
5531 c 8/21/18 AL: added explicit restraints on reference coords
5532 c      write (iout,*) "restr_on_coord",restr_on_coord
5533       if (restr_on_coord) then
5534
5535       do i=nnt,nct
5536         ecoor=0.0d0
5537         if (itype(i).eq.ntyp1) cycle
5538         do j=1,3
5539           ecoor=ecoor+(c(j,i)-cref(j,i))**2
5540           ghpbc(j,i)=ghpbc(j,i)+bfac(i)*(c(j,i)-cref(j,i))
5541         enddo
5542         if (itype(i).ne.10) then
5543           do j=1,3
5544             ecoor=ecoor+(c(j,i+nres)-cref(j,i+nres))**2
5545             ghpbx(j,i)=ghpbx(j,i)+bfac(i)*(c(j,i+nres)-cref(j,i+nres))
5546           enddo
5547         endif
5548         if (energy_dec) write (iout,*)
5549      &     "i",i," bfac",bfac(i)," ecoor",ecoor
5550         ehpb=ehpb+0.5d0*bfac(i)*ecoor
5551       enddo
5552
5553       endif
5554 C      write (iout,*) ,"link_end",link_end,constr_dist
5555 cd      write(iout,*)'edis: nhpb=',nhpb,' fbr=',fbr
5556 c      write(iout,*)'link_start=',link_start,' link_end=',link_end,
5557 c     &  " constr_dist",constr_dist," link_start_peak",link_start_peak,
5558 c     &  " link_end_peak",link_end_peak
5559       if (link_end.eq.0.and.link_end_peak.eq.0) return
5560       do i=link_start_peak,link_end_peak
5561         ehpb_peak=0.0d0
5562 c        print *,"i",i," link_end_peak",link_end_peak," ipeak",
5563 c     &   ipeak(1,i),ipeak(2,i)
5564         do ip=ipeak(1,i),ipeak(2,i)
5565           ii=ihpb_peak(ip)
5566           jj=jhpb_peak(ip)
5567           dd=dist(ii,jj)
5568           iip=ip-ipeak(1,i)+1
5569 C iii and jjj point to the residues for which the distance is assigned.
5570 c          if (ii.gt.nres) then
5571 c            iii=ii-nres
5572 c            jjj=jj-nres
5573 c          else
5574 c            iii=ii
5575 c            jjj=jj
5576 c          endif
5577           if (ii.gt.nres) then
5578             iii=ii-nres
5579           else
5580             iii=ii
5581           endif
5582           if (jj.gt.nres) then
5583             jjj=jj-nres
5584           else
5585             jjj=jj
5586           endif
5587           aux=rlornmr1(dd,dhpb_peak(ip),dhpb1_peak(ip),forcon_peak(ip))
5588           aux=dexp(-scal_peak*aux)
5589           ehpb_peak=ehpb_peak+aux
5590           fac=rlornmr1prim(dd,dhpb_peak(ip),dhpb1_peak(ip),
5591      &      forcon_peak(ip))*aux/dd
5592           do j=1,3
5593             ggg_peak(j,iip)=fac*(c(j,jj)-c(j,ii))
5594           enddo
5595           if (energy_dec) write (iout,'(a6,3i5,6f10.3,i5)')
5596      &      "edisL",i,ii,jj,dd,dhpb_peak(ip),dhpb1_peak(ip),
5597      &      forcon_peak(ip),fordepth_peak(ip),ehpb_peak
5598         enddo
5599 c        write (iout,*) "ehpb_peak",ehpb_peak," scal_peak",scal_peak
5600         ehpb=ehpb-fordepth_peak(ipeak(1,i))*dlog(ehpb_peak)/scal_peak
5601         do ip=ipeak(1,i),ipeak(2,i)
5602           iip=ip-ipeak(1,i)+1
5603           do j=1,3
5604             ggg(j)=ggg_peak(j,iip)/ehpb_peak
5605           enddo
5606           ii=ihpb_peak(ip)
5607           jj=jhpb_peak(ip)
5608 C iii and jjj point to the residues for which the distance is assigned.
5609 c          if (ii.gt.nres) then
5610 c            iii=ii-nres
5611 c            jjj=jj-nres
5612 c          else
5613 c            iii=ii
5614 c            jjj=jj
5615 c          endif
5616           if (ii.gt.nres) then
5617             iii=ii-nres
5618           else
5619             iii=ii
5620           endif
5621           if (jj.gt.nres) then
5622             jjj=jj-nres
5623           else
5624             jjj=jj
5625           endif
5626           if (iii.lt.ii) then
5627             do j=1,3
5628               ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
5629             enddo
5630           endif
5631           if (jjj.lt.jj) then
5632             do j=1,3
5633               ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
5634             enddo
5635           endif
5636           do k=1,3
5637             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
5638             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
5639           enddo
5640         enddo
5641       enddo
5642       do i=link_start,link_end
5643 C If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a
5644 C CA-CA distance used in regularization of structure.
5645         ii=ihpb(i)
5646         jj=jhpb(i)
5647 C iii and jjj point to the residues for which the distance is assigned.
5648         if (ii.gt.nres) then
5649           iii=ii-nres
5650         else
5651           iii=ii
5652         endif
5653         if (jj.gt.nres) then
5654           jjj=jj-nres
5655         else
5656           jjj=jj
5657         endif
5658 c        write (iout,*) "i",i," ii",ii," iii",iii," jj",jj," jjj",jjj,
5659 c     &    dhpb(i),dhpb1(i),forcon(i)
5660 C 24/11/03 AL: SS bridges handled separately because of introducing a specific
5661 C    distance and angle dependent SS bond potential.
5662 C        if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and.
5663 C     & iabs(itype(jjj)).eq.1) then
5664 cmc        if (ii.gt.nres .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then
5665 C 18/07/06 MC: Use the convention that the first nss pairs are SS bonds
5666         if (.not.dyn_ss .and. i.le.nss) then
5667 C 15/02/13 CC dynamic SSbond - additional check
5668           if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and.
5669      &        iabs(itype(jjj)).eq.1) then
5670            call ssbond_ene(iii,jjj,eij)
5671            ehpb=ehpb+2*eij
5672          endif
5673 cd          write (iout,*) "eij",eij
5674 cd   &   ' waga=',waga,' fac=',fac
5675 !        else if (ii.gt.nres .and. jj.gt.nres) then
5676         else
5677 C Calculate the distance between the two points and its difference from the
5678 C target distance.
5679           dd=dist(ii,jj)
5680           if (irestr_type(i).eq.11) then
5681             ehpb=ehpb+fordepth(i)!**4.0d0
5682      &           *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i))
5683             fac=fordepth(i)!**4.0d0
5684      &           *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd
5685             if (energy_dec) write (iout,'(a6,2i5,6f10.3,i5)')
5686      &        "edisL",ii,jj,dd,dhpb(i),dhpb1(i),forcon(i),fordepth(i),
5687      &        ehpb,irestr_type(i)
5688           else if (irestr_type(i).eq.10) then
5689 c AL 6//19/2018 cross-link restraints
5690             xdis = 0.5d0*(dd/forcon(i))**2
5691             expdis = dexp(-xdis)
5692 c            aux=(dhpb(i)+dhpb1(i)*xdis)*expdis+fordepth(i)
5693             aux=(dhpb(i)+dhpb1(i)*xdis*xdis)*expdis+fordepth(i)
5694 c            write (iout,*)"HERE: xdis",xdis," expdis",expdis," aux",aux,
5695 c     &          " wboltzd",wboltzd
5696             ehpb=ehpb-wboltzd*xlscore(i)*dlog(aux)
5697 c            fac=-wboltzd*(dhpb1(i)*(1.0d0-xdis)-dhpb(i))
5698             fac=-wboltzd*xlscore(i)*(dhpb1(i)*(2.0d0-xdis)*xdis-dhpb(i))
5699      &           *expdis/(aux*forcon(i)**2)
5700             if (energy_dec) write(iout,'(a6,2i5,6f10.3,i5)')
5701      &        "edisX",ii,jj,dd,dhpb(i),dhpb1(i),forcon(i),fordepth(i),
5702      &        -wboltzd*xlscore(i)*dlog(aux),irestr_type(i)
5703           else if (irestr_type(i).eq.2) then
5704 c Quartic restraints
5705             ehpb=ehpb+forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
5706             if (energy_dec) write(iout,'(a6,2i5,5f10.3,i5)')
5707      &      "edisQ",ii,jj,dd,dhpb(i),dhpb1(i),forcon(i),
5708      &      forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i)),irestr_type(i)
5709             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
5710           else
5711 c Quadratic restraints
5712             rdis=dd-dhpb(i)
5713 C Get the force constant corresponding to this distance.
5714             waga=forcon(i)
5715 C Calculate the contribution to energy.
5716             ehpb=ehpb+0.5d0*waga*rdis*rdis
5717             if (energy_dec) write(iout,'(a6,2i5,5f10.3,i5)')
5718      &      "edisS",ii,jj,dd,dhpb(i),dhpb1(i),forcon(i),
5719      &       0.5d0*waga*rdis*rdis,irestr_type(i)
5720 C
5721 C Evaluate gradient.
5722 C
5723             fac=waga*rdis/dd
5724           endif
5725 c Calculate Cartesian gradient
5726           do j=1,3
5727             ggg(j)=fac*(c(j,jj)-c(j,ii))
5728           enddo
5729 cd      print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
5730 C If this is a SC-SC distance, we need to calculate the contributions to the
5731 C Cartesian gradient in the SC vectors (ghpbx).
5732           if (iii.lt.ii) then
5733             do j=1,3
5734               ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
5735             enddo
5736           endif
5737           if (jjj.lt.jj) then
5738             do j=1,3
5739               ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
5740             enddo
5741           endif
5742           do k=1,3
5743             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
5744             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
5745           enddo
5746         endif
5747       enddo
5748       return
5749       end
5750 C--------------------------------------------------------------------------
5751       subroutine ssbond_ene(i,j,eij)
5752 C
5753 C Calculate the distance and angle dependent SS-bond potential energy
5754 C using a free-energy function derived based on RHF/6-31G** ab initio
5755 C calculations of diethyl disulfide.
5756 C
5757 C A. Liwo and U. Kozlowska, 11/24/03
5758 C
5759       implicit real*8 (a-h,o-z)
5760       include 'DIMENSIONS'
5761       include 'COMMON.SBRIDGE'
5762       include 'COMMON.CHAIN'
5763       include 'COMMON.DERIV'
5764       include 'COMMON.LOCAL'
5765       include 'COMMON.INTERACT'
5766       include 'COMMON.VAR'
5767       include 'COMMON.IOUNITS'
5768       double precision erij(3),dcosom1(3),dcosom2(3),gg(3)
5769       itypi=iabs(itype(i))
5770       xi=c(1,nres+i)
5771       yi=c(2,nres+i)
5772       zi=c(3,nres+i)
5773       dxi=dc_norm(1,nres+i)
5774       dyi=dc_norm(2,nres+i)
5775       dzi=dc_norm(3,nres+i)
5776 c      dsci_inv=dsc_inv(itypi)
5777       dsci_inv=vbld_inv(nres+i)
5778       itypj=iabs(itype(j))
5779 c      dscj_inv=dsc_inv(itypj)
5780       dscj_inv=vbld_inv(nres+j)
5781       xj=c(1,nres+j)-xi
5782       yj=c(2,nres+j)-yi
5783       zj=c(3,nres+j)-zi
5784       dxj=dc_norm(1,nres+j)
5785       dyj=dc_norm(2,nres+j)
5786       dzj=dc_norm(3,nres+j)
5787       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
5788       rij=dsqrt(rrij)
5789       erij(1)=xj*rij
5790       erij(2)=yj*rij
5791       erij(3)=zj*rij
5792       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
5793       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
5794       om12=dxi*dxj+dyi*dyj+dzi*dzj
5795       do k=1,3
5796         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
5797         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
5798       enddo
5799       rij=1.0d0/rij
5800       deltad=rij-d0cm
5801       deltat1=1.0d0-om1
5802       deltat2=1.0d0+om2
5803       deltat12=om2-om1+2.0d0
5804       cosphi=om12-om1*om2
5805       eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2)
5806      &  +akct*deltad*deltat12
5807      &  +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi+ebr
5808 c      write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth,
5809 c     &  " akct",akct," deltad",deltad," deltat",deltat1,deltat2,
5810 c     &  " deltat12",deltat12," eij",eij
5811       ed=2*akcm*deltad+akct*deltat12
5812       pom1=akct*deltad
5813       pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
5814       eom1=-2*akth*deltat1-pom1-om2*pom2
5815       eom2= 2*akth*deltat2+pom1-om1*pom2
5816       eom12=pom2
5817       do k=1,3
5818         ggk=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
5819         ghpbx(k,i)=ghpbx(k,i)-ggk
5820      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
5821      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
5822         ghpbx(k,j)=ghpbx(k,j)+ggk
5823      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
5824      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
5825         ghpbc(k,i)=ghpbc(k,i)-ggk
5826         ghpbc(k,j)=ghpbc(k,j)+ggk
5827       enddo
5828 C
5829 C Calculate the components of the gradient in DC and X
5830 C
5831 cgrad      do k=i,j-1
5832 cgrad        do l=1,3
5833 cgrad          ghpbc(l,k)=ghpbc(l,k)+gg(l)
5834 cgrad        enddo
5835 cgrad      enddo
5836       return
5837       end
5838 C--------------------------------------------------------------------------
5839       subroutine ebond(estr)
5840 c
5841 c Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
5842 c
5843       implicit real*8 (a-h,o-z)
5844       include 'DIMENSIONS'
5845       include 'COMMON.LOCAL'
5846       include 'COMMON.GEO'
5847       include 'COMMON.INTERACT'
5848       include 'COMMON.DERIV'
5849       include 'COMMON.VAR'
5850       include 'COMMON.CHAIN'
5851       include 'COMMON.IOUNITS'
5852       include 'COMMON.NAMES'
5853       include 'COMMON.FFIELD'
5854       include 'COMMON.CONTROL'
5855       include 'COMMON.SETUP'
5856       double precision u(3),ud(3)
5857       estr=0.0d0
5858       estr1=0.0d0
5859       do i=ibondp_start,ibondp_end
5860 c  3/4/2020 Adam: removed dummy bond graient if Calpha and SC coords are
5861 c      used
5862 #ifdef FIVEDIAG
5863         if (itype(i-1).eq.ntyp1 .or. itype(i).eq.ntyp1) cycle
5864         diff = vbld(i)-vbldp0
5865 #else
5866         if (itype(i-1).eq.ntyp1 .and. itype(i).eq.ntyp1) cycle
5867 c          estr1=estr1+gnmr1(vbld(i),-1.0d0,distchainmax)
5868 c          do j=1,3
5869 c          gradb(j,i-1)=gnmr1prim(vbld(i),-1.0d0,distchainmax)
5870 c     &      *dc(j,i-1)/vbld(i)
5871 c          enddo
5872 c          if (energy_dec) write(iout,*)
5873 c     &       "estr1",i,gnmr1(vbld(i),-1.0d0,distchainmax)
5874 c        else
5875 C       Checking if it involves dummy (NH3+ or COO-) group
5876         if (itype(i-1).eq.ntyp1 .or. itype(i).eq.ntyp1) then
5877 C YES   vbldpDUM is the equlibrium length of spring for Dummy atom
5878           diff = vbld(i)-vbldpDUM
5879           if (energy_dec) write(iout,*) "dum_bond",i,diff
5880         else
5881 C NO    vbldp0 is the equlibrium length of spring for peptide group
5882           diff = vbld(i)-vbldp0
5883         endif
5884 #endif
5885         if (energy_dec) write (iout,'(a7,i5,4f7.3)')
5886      &     "estr bb",i,vbld(i),vbldp0,diff,AKP*diff*diff
5887         estr=estr+diff*diff
5888         do j=1,3
5889           gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)
5890         enddo
5891 c        write (iout,'(i5,3f10.5)') i,(gradb(j,i-1),j=1,3)
5892 c        endif
5893       enddo
5894
5895       estr=0.5d0*AKP*estr+estr1
5896 c
5897 c 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included
5898 c
5899       do i=ibond_start,ibond_end
5900         iti=iabs(itype(i))
5901         if (iti.ne.10 .and. iti.ne.ntyp1) then
5902           nbi=nbondterm(iti)
5903           if (nbi.eq.1) then
5904             diff=vbld(i+nres)-vbldsc0(1,iti)
5905             if (energy_dec)  write (iout,*)
5906      &      "estr sc",i,iti,vbld(i+nres),vbldsc0(1,iti),diff,
5907      &      AKSC(1,iti),AKSC(1,iti)*diff*diff
5908             estr=estr+0.5d0*AKSC(1,iti)*diff*diff
5909             do j=1,3
5910               gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
5911             enddo
5912           else
5913             do j=1,nbi
5914               diff=vbld(i+nres)-vbldsc0(j,iti)
5915               ud(j)=aksc(j,iti)*diff
5916               u(j)=abond0(j,iti)+0.5d0*ud(j)*diff
5917             enddo
5918             uprod=u(1)
5919             do j=2,nbi
5920               uprod=uprod*u(j)
5921             enddo
5922             usum=0.0d0
5923             usumsqder=0.0d0
5924             do j=1,nbi
5925               uprod1=1.0d0
5926               uprod2=1.0d0
5927               do k=1,nbi
5928                 if (k.ne.j) then
5929                   uprod1=uprod1*u(k)
5930                   uprod2=uprod2*u(k)*u(k)
5931                 endif
5932               enddo
5933               usum=usum+uprod1
5934               usumsqder=usumsqder+ud(j)*uprod2
5935             enddo
5936             estr=estr+uprod/usum
5937             do j=1,3
5938              gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
5939             enddo
5940           endif
5941         endif
5942       enddo
5943       return
5944       end
5945 #ifdef CRYST_THETA
5946 C--------------------------------------------------------------------------
5947       subroutine ebend(etheta)
5948 C
5949 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
5950 C angles gamma and its derivatives in consecutive thetas and gammas.
5951 C
5952       implicit real*8 (a-h,o-z)
5953       include 'DIMENSIONS'
5954       include 'COMMON.LOCAL'
5955       include 'COMMON.GEO'
5956       include 'COMMON.INTERACT'
5957       include 'COMMON.DERIV'
5958       include 'COMMON.VAR'
5959       include 'COMMON.CHAIN'
5960       include 'COMMON.IOUNITS'
5961       include 'COMMON.NAMES'
5962       include 'COMMON.FFIELD'
5963       include 'COMMON.CONTROL'
5964       include 'COMMON.TORCNSTR'
5965       common /calcthet/ term1,term2,termm,diffak,ratak,
5966      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
5967      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
5968       double precision y(2),z(2)
5969       delta=0.02d0*pi
5970 c      time11=dexp(-2*time)
5971 c      time12=1.0d0
5972       etheta=0.0D0
5973 c     write (*,'(a,i2)') 'EBEND ICG=',icg
5974       do i=ithet_start,ithet_end
5975         if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
5976      &  .or.itype(i).eq.ntyp1) cycle
5977 C Zero the energy function and its derivative at 0 or pi.
5978         call splinthet(theta(i),0.5d0*delta,ss,ssd)
5979         it=itype(i-1)
5980         ichir1=isign(1,itype(i-2))
5981         ichir2=isign(1,itype(i))
5982          if (itype(i-2).eq.10) ichir1=isign(1,itype(i-1))
5983          if (itype(i).eq.10) ichir2=isign(1,itype(i-1))
5984          if (itype(i-1).eq.10) then
5985           itype1=isign(10,itype(i-2))
5986           ichir11=isign(1,itype(i-2))
5987           ichir12=isign(1,itype(i-2))
5988           itype2=isign(10,itype(i))
5989           ichir21=isign(1,itype(i))
5990           ichir22=isign(1,itype(i))
5991          endif
5992
5993         if (i.gt.3 .and. itype(i-3).ne.ntyp1) then
5994 #ifdef OSF
5995           phii=phi(i)
5996           if (phii.ne.phii) phii=150.0
5997 #else
5998           phii=phi(i)
5999 #endif
6000           y(1)=dcos(phii)
6001           y(2)=dsin(phii)
6002         else
6003           y(1)=0.0D0
6004           y(2)=0.0D0
6005         endif
6006         if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
6007 #ifdef OSF
6008           phii1=phi(i+1)
6009           if (phii1.ne.phii1) phii1=150.0
6010           phii1=pinorm(phii1)
6011           z(1)=cos(phii1)
6012 #else
6013           phii1=phi(i+1)
6014 #endif
6015           z(1)=dcos(phii1)
6016           z(2)=dsin(phii1)
6017         else
6018           z(1)=0.0D0
6019           z(2)=0.0D0
6020         endif
6021 C Calculate the "mean" value of theta from the part of the distribution
6022 C dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2).
6023 C In following comments this theta will be referred to as t_c.
6024         thet_pred_mean=0.0d0
6025         do k=1,2
6026             athetk=athet(k,it,ichir1,ichir2)
6027             bthetk=bthet(k,it,ichir1,ichir2)
6028           if (it.eq.10) then
6029              athetk=athet(k,itype1,ichir11,ichir12)
6030              bthetk=bthet(k,itype2,ichir21,ichir22)
6031           endif
6032          thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k)
6033 c         write(iout,*) 'chuj tu', y(k),z(k)
6034         enddo
6035         dthett=thet_pred_mean*ssd
6036         thet_pred_mean=thet_pred_mean*ss+a0thet(it)
6037 C Derivatives of the "mean" values in gamma1 and gamma2.
6038         dthetg1=(-athet(1,it,ichir1,ichir2)*y(2)
6039      &+athet(2,it,ichir1,ichir2)*y(1))*ss
6040          dthetg2=(-bthet(1,it,ichir1,ichir2)*z(2)
6041      &          +bthet(2,it,ichir1,ichir2)*z(1))*ss
6042          if (it.eq.10) then
6043       dthetg1=(-athet(1,itype1,ichir11,ichir12)*y(2)
6044      &+athet(2,itype1,ichir11,ichir12)*y(1))*ss
6045         dthetg2=(-bthet(1,itype2,ichir21,ichir22)*z(2)
6046      &         +bthet(2,itype2,ichir21,ichir22)*z(1))*ss
6047          endif
6048         if (theta(i).gt.pi-delta) then
6049           call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,
6050      &         E_tc0)
6051           call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0)
6052           call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
6053           call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,
6054      &        E_theta)
6055           call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,
6056      &        E_tc)
6057         else if (theta(i).lt.delta) then
6058           call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0)
6059           call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
6060           call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,
6061      &        E_theta)
6062           call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0)
6063           call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,
6064      &        E_tc)
6065         else
6066           call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,
6067      &        E_theta,E_tc)
6068         endif
6069         etheta=etheta+ethetai
6070         if (energy_dec) write (iout,'(a6,i5,0pf7.3,f7.3,i5)')
6071      &      'ebend',i,ethetai,theta(i),itype(i)
6072         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1
6073         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2
6074         gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)+gloc(nphi+i-2,icg)
6075       enddo
6076
6077 C Ufff.... We've done all this!!!
6078       return
6079       end
6080 C---------------------------------------------------------------------------
6081       subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,
6082      &     E_tc)
6083       implicit real*8 (a-h,o-z)
6084       include 'DIMENSIONS'
6085       include 'COMMON.LOCAL'
6086       include 'COMMON.IOUNITS'
6087       common /calcthet/ term1,term2,termm,diffak,ratak,
6088      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
6089      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
6090 C Calculate the contributions to both Gaussian lobes.
6091 C 6/6/97 - Deform the Gaussians using the factor of 1/(1+time)
6092 C The "polynomial part" of the "standard deviation" of this part of
6093 C the distributioni.
6094 ccc        write (iout,*) thetai,thet_pred_mean
6095         sig=polthet(3,it)
6096         do j=2,0,-1
6097           sig=sig*thet_pred_mean+polthet(j,it)
6098         enddo
6099 C Derivative of the "interior part" of the "standard deviation of the"
6100 C gamma-dependent Gaussian lobe in t_c.
6101         sigtc=3*polthet(3,it)
6102         do j=2,1,-1
6103           sigtc=sigtc*thet_pred_mean+j*polthet(j,it)
6104         enddo
6105         sigtc=sig*sigtc
6106 C Set the parameters of both Gaussian lobes of the distribution.
6107 C "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc)
6108         fac=sig*sig+sigc0(it)
6109         sigcsq=fac+fac
6110         sigc=1.0D0/sigcsq
6111 C Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c
6112         sigsqtc=-4.0D0*sigcsq*sigtc
6113 c       print *,i,sig,sigtc,sigsqtc
6114 C Following variable (sigtc) is d[sigma(t_c)]/dt_c
6115         sigtc=-sigtc/(fac*fac)
6116 C Following variable is sigma(t_c)**(-2)
6117         sigcsq=sigcsq*sigcsq
6118         sig0i=sig0(it)
6119         sig0inv=1.0D0/sig0i**2
6120         delthec=thetai-thet_pred_mean
6121         delthe0=thetai-theta0i
6122         term1=-0.5D0*sigcsq*delthec*delthec
6123         term2=-0.5D0*sig0inv*delthe0*delthe0
6124 C        write (iout,*)'term1',term1,term2,sigcsq,delthec,sig0inv,delthe0
6125 C Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and
6126 C NaNs in taking the logarithm. We extract the largest exponent which is added
6127 C to the energy (this being the log of the distribution) at the end of energy
6128 C term evaluation for this virtual-bond angle.
6129         if (term1.gt.term2) then
6130           termm=term1
6131           term2=dexp(term2-termm)
6132           term1=1.0d0
6133         else
6134           termm=term2
6135           term1=dexp(term1-termm)
6136           term2=1.0d0
6137         endif
6138 C The ratio between the gamma-independent and gamma-dependent lobes of
6139 C the distribution is a Gaussian function of thet_pred_mean too.
6140         diffak=gthet(2,it)-thet_pred_mean
6141         ratak=diffak/gthet(3,it)**2
6142         ak=dexp(gthet(1,it)-0.5D0*diffak*ratak)
6143 C Let's differentiate it in thet_pred_mean NOW.
6144         aktc=ak*ratak
6145 C Now put together the distribution terms to make complete distribution.
6146         termexp=term1+ak*term2
6147         termpre=sigc+ak*sig0i
6148 C Contribution of the bending energy from this theta is just the -log of
6149 C the sum of the contributions from the two lobes and the pre-exponential
6150 C factor. Simple enough, isn't it?
6151         ethetai=(-dlog(termexp)-termm+dlog(termpre))
6152 C       write (iout,*) 'termexp',termexp,termm,termpre,i
6153 C NOW the derivatives!!!
6154 C 6/6/97 Take into account the deformation.
6155         E_theta=(delthec*sigcsq*term1
6156      &       +ak*delthe0*sig0inv*term2)/termexp
6157         E_tc=((sigtc+aktc*sig0i)/termpre
6158      &      -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+
6159      &       aktc*term2)/termexp)
6160       return
6161       end
6162 c-----------------------------------------------------------------------------
6163       subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)
6164       implicit real*8 (a-h,o-z)
6165       include 'DIMENSIONS'
6166       include 'COMMON.LOCAL'
6167       include 'COMMON.IOUNITS'
6168       common /calcthet/ term1,term2,termm,diffak,ratak,
6169      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
6170      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
6171       delthec=thetai-thet_pred_mean
6172       delthe0=thetai-theta0i
6173 C "Thank you" to MAPLE (probably spared one day of hand-differentiation).
6174       t3 = thetai-thet_pred_mean
6175       t6 = t3**2
6176       t9 = term1
6177       t12 = t3*sigcsq
6178       t14 = t12+t6*sigsqtc
6179       t16 = 1.0d0
6180       t21 = thetai-theta0i
6181       t23 = t21**2
6182       t26 = term2
6183       t27 = t21*t26
6184       t32 = termexp
6185       t40 = t32**2
6186       E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9
6187      & -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40
6188      & *(-t12*t9-ak*sig0inv*t27)
6189       return
6190       end
6191 #else
6192 C--------------------------------------------------------------------------
6193       subroutine ebend(etheta)
6194 C
6195 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
6196 C angles gamma and its derivatives in consecutive thetas and gammas.
6197 C ab initio-derived potentials from
6198 c Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203
6199 C
6200       implicit real*8 (a-h,o-z)
6201       include 'DIMENSIONS'
6202       include 'COMMON.LOCAL'
6203       include 'COMMON.GEO'
6204       include 'COMMON.INTERACT'
6205       include 'COMMON.DERIV'
6206       include 'COMMON.VAR'
6207       include 'COMMON.CHAIN'
6208       include 'COMMON.IOUNITS'
6209       include 'COMMON.NAMES'
6210       include 'COMMON.FFIELD'
6211       include 'COMMON.CONTROL'
6212       include 'COMMON.TORCNSTR'
6213       double precision coskt(mmaxtheterm),sinkt(mmaxtheterm),
6214      & cosph1(maxsingle),sinph1(maxsingle),cosph2(maxsingle),
6215      & sinph2(maxsingle),cosph1ph2(maxdouble,maxdouble),
6216      & sinph1ph2(maxdouble,maxdouble)
6217       logical lprn /.false./, lprn1 /.false./
6218       etheta=0.0D0
6219       do i=ithet_start,ithet_end
6220 c        print *,i,itype(i-1),itype(i),itype(i-2)
6221         if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
6222      &  .or.itype(i).eq.ntyp1) cycle
6223 C        print *,i,theta(i)
6224         if (iabs(itype(i+1)).eq.20) iblock=2
6225         if (iabs(itype(i+1)).ne.20) iblock=1
6226         dethetai=0.0d0
6227         dephii=0.0d0
6228         dephii1=0.0d0
6229         theti2=0.5d0*theta(i)
6230         ityp2=ithetyp((itype(i-1)))
6231         do k=1,nntheterm
6232           coskt(k)=dcos(k*theti2)
6233           sinkt(k)=dsin(k*theti2)
6234         enddo
6235 C        print *,ethetai
6236         if (i.gt.3 .and. itype(i-3).ne.ntyp1) then
6237 #ifdef OSF
6238           phii=phi(i)
6239           if (phii.ne.phii) phii=150.0
6240 #else
6241           phii=phi(i)
6242 #endif
6243           ityp1=ithetyp((itype(i-2)))
6244 C propagation of chirality for glycine type
6245           do k=1,nsingle
6246             cosph1(k)=dcos(k*phii)
6247             sinph1(k)=dsin(k*phii)
6248           enddo
6249         else
6250           phii=0.0d0
6251           do k=1,nsingle
6252           ityp1=ithetyp((itype(i-2)))
6253             cosph1(k)=0.0d0
6254             sinph1(k)=0.0d0
6255           enddo
6256         endif
6257         if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
6258 #ifdef OSF
6259           phii1=phi(i+1)
6260           if (phii1.ne.phii1) phii1=150.0
6261           phii1=pinorm(phii1)
6262 #else
6263           phii1=phi(i+1)
6264 #endif
6265           ityp3=ithetyp((itype(i)))
6266           do k=1,nsingle
6267             cosph2(k)=dcos(k*phii1)
6268             sinph2(k)=dsin(k*phii1)
6269           enddo
6270         else
6271           phii1=0.0d0
6272           ityp3=ithetyp((itype(i)))
6273           do k=1,nsingle
6274             cosph2(k)=0.0d0
6275             sinph2(k)=0.0d0
6276           enddo
6277         endif
6278         ethetai=aa0thet(ityp1,ityp2,ityp3,iblock)
6279         do k=1,ndouble
6280           do l=1,k-1
6281             ccl=cosph1(l)*cosph2(k-l)
6282             ssl=sinph1(l)*sinph2(k-l)
6283             scl=sinph1(l)*cosph2(k-l)
6284             csl=cosph1(l)*sinph2(k-l)
6285             cosph1ph2(l,k)=ccl-ssl
6286             cosph1ph2(k,l)=ccl+ssl
6287             sinph1ph2(l,k)=scl+csl
6288             sinph1ph2(k,l)=scl-csl
6289           enddo
6290         enddo
6291         if (lprn) then
6292         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,
6293      &    " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
6294         write (iout,*) "coskt and sinkt"
6295         do k=1,nntheterm
6296           write (iout,*) k,coskt(k),sinkt(k)
6297         enddo
6298         endif
6299         do k=1,ntheterm
6300           ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3,iblock)*sinkt(k)
6301           dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3,iblock)
6302      &      *coskt(k)
6303           if (lprn)
6304      &    write (iout,*) "k",k,"
6305      &     aathet",aathet(k,ityp1,ityp2,ityp3,iblock),
6306      &     " ethetai",ethetai
6307         enddo
6308         if (lprn) then
6309         write (iout,*) "cosph and sinph"
6310         do k=1,nsingle
6311           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
6312         enddo
6313         write (iout,*) "cosph1ph2 and sinph2ph2"
6314         do k=2,ndouble
6315           do l=1,k-1
6316             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),
6317      &         sinph1ph2(l,k),sinph1ph2(k,l)
6318           enddo
6319         enddo
6320         write(iout,*) "ethetai",ethetai
6321         endif
6322 C       print *,ethetai
6323         do m=1,ntheterm2
6324           do k=1,nsingle
6325             aux=bbthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)
6326      &         +ccthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k)
6327      &         +ddthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)
6328      &         +eethet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k)
6329             ethetai=ethetai+sinkt(m)*aux
6330             dethetai=dethetai+0.5d0*m*aux*coskt(m)
6331             dephii=dephii+k*sinkt(m)*(
6332      &          ccthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)-
6333      &          bbthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k))
6334             dephii1=dephii1+k*sinkt(m)*(
6335      &          eethet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)-
6336      &          ddthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k))
6337             if (lprn)
6338      &      write (iout,*) "m",m," k",k," bbthet",
6339      &         bbthet(k,m,ityp1,ityp2,ityp3,iblock)," ccthet",
6340      &         ccthet(k,m,ityp1,ityp2,ityp3,iblock)," ddthet",
6341      &         ddthet(k,m,ityp1,ityp2,ityp3,iblock)," eethet",
6342      &         eethet(k,m,ityp1,ityp2,ityp3,iblock)," ethetai",ethetai
6343 C        print *,"tu",cosph1(k),sinph1(k),cosph2(k),sinph2(k)
6344           enddo
6345         enddo
6346 C        print *,"cosph1", (cosph1(k), k=1,nsingle)
6347 C        print *,"cosph2", (cosph2(k), k=1,nsingle)
6348 C        print *,"sinph1", (sinph1(k), k=1,nsingle)
6349 C        print *,"sinph2", (sinph2(k), k=1,nsingle)
6350         if (lprn)
6351      &  write(iout,*) "ethetai",ethetai
6352 C        print *,"tu",cosph1(k),sinph1(k),cosph2(k),sinph2(k)
6353         do m=1,ntheterm3
6354           do k=2,ndouble
6355             do l=1,k-1
6356               aux=ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
6357      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l)+
6358      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
6359      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)
6360               ethetai=ethetai+sinkt(m)*aux
6361               dethetai=dethetai+0.5d0*m*coskt(m)*aux
6362               dephii=dephii+l*sinkt(m)*(
6363      &           -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)-
6364      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
6365      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
6366      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
6367               dephii1=dephii1+(k-l)*sinkt(m)*(
6368      &           -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
6369      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
6370      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)-
6371      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
6372               if (lprn) then
6373               write (iout,*) "m",m," k",k," l",l," ffthet",
6374      &            ffthet(l,k,m,ityp1,ityp2,ityp3,iblock),
6375      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)," ggthet",
6376      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock),
6377      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock),
6378      &            " ethetai",ethetai
6379               write (iout,*) cosph1ph2(l,k)*sinkt(m),
6380      &            cosph1ph2(k,l)*sinkt(m),
6381      &            sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
6382               endif
6383             enddo
6384           enddo
6385         enddo
6386 10      continue
6387 c        lprn1=.true.
6388 C        print *,ethetai
6389         if (lprn1)
6390      &    write (iout,'(i2,3f8.1,9h ethetai ,f10.5)')
6391      &   i,theta(i)*rad2deg,phii*rad2deg,
6392      &   phii1*rad2deg,ethetai
6393 c        lprn1=.false.
6394         etheta=etheta+ethetai
6395         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
6396         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
6397         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)+wang*dethetai
6398       enddo
6399
6400       return
6401       end
6402 #endif
6403 #ifdef CRYST_SC
6404 c-----------------------------------------------------------------------------
6405       subroutine esc(escloc)
6406 C Calculate the local energy of a side chain and its derivatives in the
6407 C corresponding virtual-bond valence angles THETA and the spherical angles
6408 C ALPHA and OMEGA.
6409       implicit real*8 (a-h,o-z)
6410       include 'DIMENSIONS'
6411       include 'COMMON.GEO'
6412       include 'COMMON.LOCAL'
6413       include 'COMMON.VAR'
6414       include 'COMMON.INTERACT'
6415       include 'COMMON.DERIV'
6416       include 'COMMON.CHAIN'
6417       include 'COMMON.IOUNITS'
6418       include 'COMMON.NAMES'
6419       include 'COMMON.FFIELD'
6420       include 'COMMON.CONTROL'
6421       double precision x(3),dersc(3),xemp(3),dersc0(3),dersc1(3),
6422      &     ddersc0(3),ddummy(3),xtemp(3),temp(3)
6423       common /sccalc/ time11,time12,time112,theti,it,nlobit
6424       delta=0.02d0*pi
6425       escloc=0.0D0
6426 c     write (iout,'(a)') 'ESC'
6427       do i=loc_start,loc_end
6428         it=itype(i)
6429         if (it.eq.ntyp1) cycle
6430         if (it.eq.10) goto 1
6431         nlobit=nlob(iabs(it))
6432 c       print *,'i=',i,' it=',it,' nlobit=',nlobit
6433 c       write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
6434         theti=theta(i+1)-pipol
6435         x(1)=dtan(theti)
6436         x(2)=alph(i)
6437         x(3)=omeg(i)
6438
6439         if (x(2).gt.pi-delta) then
6440           xtemp(1)=x(1)
6441           xtemp(2)=pi-delta
6442           xtemp(3)=x(3)
6443           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
6444           xtemp(2)=pi
6445           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
6446           call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),
6447      &        escloci,dersc(2))
6448           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
6449      &        ddersc0(1),dersc(1))
6450           call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),
6451      &        ddersc0(3),dersc(3))
6452           xtemp(2)=pi-delta
6453           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
6454           xtemp(2)=pi
6455           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
6456           call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,
6457      &            dersc0(2),esclocbi,dersc02)
6458           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
6459      &            dersc12,dersc01)
6460           call splinthet(x(2),0.5d0*delta,ss,ssd)
6461           dersc0(1)=dersc01
6462           dersc0(2)=dersc02
6463           dersc0(3)=0.0d0
6464           do k=1,3
6465             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
6466           enddo
6467           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
6468 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
6469 c    &             esclocbi,ss,ssd
6470           escloci=ss*escloci+(1.0d0-ss)*esclocbi
6471 c         escloci=esclocbi
6472 c         write (iout,*) escloci
6473         else if (x(2).lt.delta) then
6474           xtemp(1)=x(1)
6475           xtemp(2)=delta
6476           xtemp(3)=x(3)
6477           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
6478           xtemp(2)=0.0d0
6479           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
6480           call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),
6481      &        escloci,dersc(2))
6482           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
6483      &        ddersc0(1),dersc(1))
6484           call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),
6485      &        ddersc0(3),dersc(3))
6486           xtemp(2)=delta
6487           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
6488           xtemp(2)=0.0d0
6489           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
6490           call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,
6491      &            dersc0(2),esclocbi,dersc02)
6492           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
6493      &            dersc12,dersc01)
6494           dersc0(1)=dersc01
6495           dersc0(2)=dersc02
6496           dersc0(3)=0.0d0
6497           call splinthet(x(2),0.5d0*delta,ss,ssd)
6498           do k=1,3
6499             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
6500           enddo
6501           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
6502 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
6503 c    &             esclocbi,ss,ssd
6504           escloci=ss*escloci+(1.0d0-ss)*esclocbi
6505 c         write (iout,*) escloci
6506         else
6507           call enesc(x,escloci,dersc,ddummy,.false.)
6508         endif
6509
6510         escloc=escloc+escloci
6511         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
6512      &     'escloc',i,escloci
6513 c       write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
6514
6515         gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
6516      &   wscloc*dersc(1)
6517         gloc(ialph(i,1),icg)=wscloc*dersc(2)
6518         gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
6519     1   continue
6520       enddo
6521       return
6522       end
6523 C---------------------------------------------------------------------------
6524       subroutine enesc(x,escloci,dersc,ddersc,mixed)
6525       implicit real*8 (a-h,o-z)
6526       include 'DIMENSIONS'
6527       include 'COMMON.GEO'
6528       include 'COMMON.LOCAL'
6529       include 'COMMON.IOUNITS'
6530       common /sccalc/ time11,time12,time112,theti,it,nlobit
6531       double precision x(3),z(3),Ax(3,maxlob,-1:1),dersc(3),ddersc(3)
6532       double precision contr(maxlob,-1:1)
6533       logical mixed
6534 c       write (iout,*) 'it=',it,' nlobit=',nlobit
6535         escloc_i=0.0D0
6536         do j=1,3
6537           dersc(j)=0.0D0
6538           if (mixed) ddersc(j)=0.0d0
6539         enddo
6540         x3=x(3)
6541
6542 C Because of periodicity of the dependence of the SC energy in omega we have
6543 C to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
6544 C To avoid underflows, first compute & store the exponents.
6545
6546         do iii=-1,1
6547
6548           x(3)=x3+iii*dwapi
6549
6550           do j=1,nlobit
6551             do k=1,3
6552               z(k)=x(k)-censc(k,j,it)
6553             enddo
6554             do k=1,3
6555               Axk=0.0D0
6556               do l=1,3
6557                 Axk=Axk+gaussc(l,k,j,it)*z(l)
6558               enddo
6559               Ax(k,j,iii)=Axk
6560             enddo
6561             expfac=0.0D0
6562             do k=1,3
6563               expfac=expfac+Ax(k,j,iii)*z(k)
6564             enddo
6565             contr(j,iii)=expfac
6566           enddo ! j
6567
6568         enddo ! iii
6569
6570         x(3)=x3
6571 C As in the case of ebend, we want to avoid underflows in exponentiation and
6572 C subsequent NaNs and INFs in energy calculation.
6573 C Find the largest exponent
6574         emin=contr(1,-1)
6575         do iii=-1,1
6576           do j=1,nlobit
6577             if (emin.gt.contr(j,iii)) emin=contr(j,iii)
6578           enddo
6579         enddo
6580         emin=0.5D0*emin
6581 cd      print *,'it=',it,' emin=',emin
6582
6583 C Compute the contribution to SC energy and derivatives
6584         do iii=-1,1
6585
6586           do j=1,nlobit
6587 #ifdef OSF
6588             adexp=bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin
6589             if(adexp.ne.adexp) adexp=1.0
6590             expfac=dexp(adexp)
6591 #else
6592             expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin)
6593 #endif
6594 cd          print *,'j=',j,' expfac=',expfac
6595             escloc_i=escloc_i+expfac
6596             do k=1,3
6597               dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
6598             enddo
6599             if (mixed) then
6600               do k=1,3,2
6601                 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii)
6602      &            +gaussc(k,2,j,it))*expfac
6603               enddo
6604             endif
6605           enddo
6606
6607         enddo ! iii
6608
6609         dersc(1)=dersc(1)/cos(theti)**2
6610         ddersc(1)=ddersc(1)/cos(theti)**2
6611         ddersc(3)=ddersc(3)
6612
6613         escloci=-(dlog(escloc_i)-emin)
6614         do j=1,3
6615           dersc(j)=dersc(j)/escloc_i
6616         enddo
6617         if (mixed) then
6618           do j=1,3,2
6619             ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
6620           enddo
6621         endif
6622       return
6623       end
6624 C------------------------------------------------------------------------------
6625       subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
6626       implicit real*8 (a-h,o-z)
6627       include 'DIMENSIONS'
6628       include 'COMMON.GEO'
6629       include 'COMMON.LOCAL'
6630       include 'COMMON.IOUNITS'
6631       common /sccalc/ time11,time12,time112,theti,it,nlobit
6632       double precision x(3),z(3),Ax(3,maxlob),dersc(3)
6633       double precision contr(maxlob)
6634       logical mixed
6635
6636       escloc_i=0.0D0
6637
6638       do j=1,3
6639         dersc(j)=0.0D0
6640       enddo
6641
6642       do j=1,nlobit
6643         do k=1,2
6644           z(k)=x(k)-censc(k,j,it)
6645         enddo
6646         z(3)=dwapi
6647         do k=1,3
6648           Axk=0.0D0
6649           do l=1,3
6650             Axk=Axk+gaussc(l,k,j,it)*z(l)
6651           enddo
6652           Ax(k,j)=Axk
6653         enddo
6654         expfac=0.0D0
6655         do k=1,3
6656           expfac=expfac+Ax(k,j)*z(k)
6657         enddo
6658         contr(j)=expfac
6659       enddo ! j
6660
6661 C As in the case of ebend, we want to avoid underflows in exponentiation and
6662 C subsequent NaNs and INFs in energy calculation.
6663 C Find the largest exponent
6664       emin=contr(1)
6665       do j=1,nlobit
6666         if (emin.gt.contr(j)) emin=contr(j)
6667       enddo
6668       emin=0.5D0*emin
6669
6670 C Compute the contribution to SC energy and derivatives
6671
6672       dersc12=0.0d0
6673       do j=1,nlobit
6674         expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j)+emin)
6675         escloc_i=escloc_i+expfac
6676         do k=1,2
6677           dersc(k)=dersc(k)+Ax(k,j)*expfac
6678         enddo
6679         if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j)
6680      &            +gaussc(1,2,j,it))*expfac
6681         dersc(3)=0.0d0
6682       enddo
6683
6684       dersc(1)=dersc(1)/cos(theti)**2
6685       dersc12=dersc12/cos(theti)**2
6686       escloci=-(dlog(escloc_i)-emin)
6687       do j=1,2
6688         dersc(j)=dersc(j)/escloc_i
6689       enddo
6690       if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
6691       return
6692       end
6693 #else
6694 c----------------------------------------------------------------------------------
6695       subroutine esc(escloc)
6696 C Calculate the local energy of a side chain and its derivatives in the
6697 C corresponding virtual-bond valence angles THETA and the spherical angles
6698 C ALPHA and OMEGA derived from AM1 all-atom calculations.
6699 C added by Urszula Kozlowska. 07/11/2007
6700 C
6701       implicit real*8 (a-h,o-z)
6702       include 'DIMENSIONS'
6703       include 'COMMON.GEO'
6704       include 'COMMON.LOCAL'
6705       include 'COMMON.VAR'
6706       include 'COMMON.SCROT'
6707       include 'COMMON.INTERACT'
6708       include 'COMMON.DERIV'
6709       include 'COMMON.CHAIN'
6710       include 'COMMON.IOUNITS'
6711       include 'COMMON.NAMES'
6712       include 'COMMON.FFIELD'
6713       include 'COMMON.CONTROL'
6714       include 'COMMON.VECTORS'
6715       double precision x_prime(3),y_prime(3),z_prime(3)
6716      &    , sumene,dsc_i,dp2_i,x(65),
6717      &     xx,yy,zz,sumene1,sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6,
6718      &    de_dxx,de_dyy,de_dzz,de_dt
6719       double precision s1_t,s1_6_t,s2_t,s2_6_t
6720       double precision
6721      & dXX_Ci1(3),dYY_Ci1(3),dZZ_Ci1(3),dXX_Ci(3),
6722      & dYY_Ci(3),dZZ_Ci(3),dXX_XYZ(3),dYY_XYZ(3),dZZ_XYZ(3),
6723      & dt_dCi(3),dt_dCi1(3)
6724       common /sccalc/ time11,time12,time112,theti,it,nlobit
6725       delta=0.02d0*pi
6726       escloc=0.0D0
6727       do i=loc_start,loc_end
6728         if (itype(i).eq.ntyp1) cycle
6729         costtab(i+1) =dcos(theta(i+1))
6730         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
6731         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
6732         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
6733         cosfac2=0.5d0/(1.0d0+costtab(i+1))
6734         cosfac=dsqrt(cosfac2)
6735         sinfac2=0.5d0/(1.0d0-costtab(i+1))
6736         sinfac=dsqrt(sinfac2)
6737         it=iabs(itype(i))
6738         if (it.eq.10) goto 1
6739 c
6740 C  Compute the axes of tghe local cartesian coordinates system; store in
6741 c   x_prime, y_prime and z_prime
6742 c
6743         do j=1,3
6744           x_prime(j) = 0.00
6745           y_prime(j) = 0.00
6746           z_prime(j) = 0.00
6747         enddo
6748 C        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
6749 C     &   dc_norm(3,i+nres)
6750         do j = 1,3
6751           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
6752           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
6753         enddo
6754         do j = 1,3
6755           z_prime(j) = -uz(j,i-1)*dsign(1.0d0,dfloat(itype(i)))
6756         enddo
6757 c       write (2,*) "i",i
6758 c       write (2,*) "x_prime",(x_prime(j),j=1,3)
6759 c       write (2,*) "y_prime",(y_prime(j),j=1,3)
6760 c       write (2,*) "z_prime",(z_prime(j),j=1,3)
6761 c       write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
6762 c      & " xy",scalar(x_prime(1),y_prime(1)),
6763 c      & " xz",scalar(x_prime(1),z_prime(1)),
6764 c      & " yy",scalar(y_prime(1),y_prime(1)),
6765 c      & " yz",scalar(y_prime(1),z_prime(1)),
6766 c      & " zz",scalar(z_prime(1),z_prime(1))
6767 c
6768 C Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
6769 C to local coordinate system. Store in xx, yy, zz.
6770 c
6771         xx=0.0d0
6772         yy=0.0d0
6773         zz=0.0d0
6774         do j = 1,3
6775           xx = xx + x_prime(j)*dc_norm(j,i+nres)
6776           yy = yy + y_prime(j)*dc_norm(j,i+nres)
6777           zz = zz + z_prime(j)*dc_norm(j,i+nres)
6778         enddo
6779
6780         xxtab(i)=xx
6781         yytab(i)=yy
6782         zztab(i)=zz
6783 C
6784 C Compute the energy of the ith side cbain
6785 C
6786 c        write (2,*) "xx",xx," yy",yy," zz",zz
6787         it=iabs(itype(i))
6788         do j = 1,65
6789           x(j) = sc_parmin(j,it)
6790         enddo
6791 #ifdef CHECK_COORD
6792 Cc diagnostics - remove later
6793         xx1 = dcos(alph(2))
6794         yy1 = dsin(alph(2))*dcos(omeg(2))
6795         zz1 = -dsign(1.0,dfloat(itype(i)))*dsin(alph(2))*dsin(omeg(2))
6796         write(2,'(3f8.1,3f9.3,1x,3f9.3)')
6797      &    alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,
6798      &    xx1,yy1,zz1
6799 C,"  --- ", xx_w,yy_w,zz_w
6800 c end diagnostics
6801 #endif
6802         sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
6803      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
6804      &   + x(10)*yy*zz
6805         sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
6806      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
6807      & + x(20)*yy*zz
6808         sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
6809      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
6810      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
6811      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
6812      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
6813      &  +x(40)*xx*yy*zz
6814         sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
6815      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
6816      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
6817      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
6818      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
6819      &  +x(60)*xx*yy*zz
6820         dsc_i   = 0.743d0+x(61)
6821         dp2_i   = 1.9d0+x(62)
6822         dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
6823      &          *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
6824         dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
6825      &          *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
6826         s1=(1+x(63))/(0.1d0 + dscp1)
6827         s1_6=(1+x(64))/(0.1d0 + dscp1**6)
6828         s2=(1+x(65))/(0.1d0 + dscp2)
6829         s2_6=(1+x(65))/(0.1d0 + dscp2**6)
6830         sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6)
6831      & + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
6832 c        write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
6833 c     &   sumene4,
6834 c     &   dscp1,dscp2,sumene
6835 c        sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6836         escloc = escloc + sumene
6837         if (energy_dec) write (2,*) "i",i," itype",itype(i)," it",it,
6838      &   " escloc",sumene,escloc,it,itype(i)
6839 c     & ,zz,xx,yy
6840 c#define DEBUG
6841 #ifdef DEBUG
6842 C
6843 C This section to check the numerical derivatives of the energy of ith side
6844 C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
6845 C #define DEBUG in the code to turn it on.
6846 C
6847         write (2,*) "sumene               =",sumene
6848         aincr=1.0d-7
6849         xxsave=xx
6850         xx=xx+aincr
6851         write (2,*) xx,yy,zz
6852         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6853         de_dxx_num=(sumenep-sumene)/aincr
6854         xx=xxsave
6855         write (2,*) "xx+ sumene from enesc=",sumenep
6856         yysave=yy
6857         yy=yy+aincr
6858         write (2,*) xx,yy,zz
6859         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6860         de_dyy_num=(sumenep-sumene)/aincr
6861         yy=yysave
6862         write (2,*) "yy+ sumene from enesc=",sumenep
6863         zzsave=zz
6864         zz=zz+aincr
6865         write (2,*) xx,yy,zz
6866         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6867         de_dzz_num=(sumenep-sumene)/aincr
6868         zz=zzsave
6869         write (2,*) "zz+ sumene from enesc=",sumenep
6870         costsave=cost2tab(i+1)
6871         sintsave=sint2tab(i+1)
6872         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
6873         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
6874         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6875         de_dt_num=(sumenep-sumene)/aincr
6876         write (2,*) " t+ sumene from enesc=",sumenep
6877         cost2tab(i+1)=costsave
6878         sint2tab(i+1)=sintsave
6879 C End of diagnostics section.
6880 #endif
6881 C
6882 C Compute the gradient of esc
6883 C
6884 c        zz=zz*dsign(1.0,dfloat(itype(i)))
6885         pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
6886         pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
6887         pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
6888         pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
6889         pom_dx=dsc_i*dp2_i*cost2tab(i+1)
6890         pom_dy=dsc_i*dp2_i*sint2tab(i+1)
6891         pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
6892         pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
6893         pom1=(sumene3*sint2tab(i+1)+sumene1)
6894      &     *(pom_s1/dscp1+pom_s16*dscp1**4)
6895         pom2=(sumene4*cost2tab(i+1)+sumene2)
6896      &     *(pom_s2/dscp2+pom_s26*dscp2**4)
6897         sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
6898         sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2
6899      &  +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2)
6900      &  +x(40)*yy*zz
6901         sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
6902         sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2
6903      &  +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2)
6904      &  +x(60)*yy*zz
6905         de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6)
6906      &        +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6)
6907      &        +(pom1+pom2)*pom_dx
6908 #ifdef DEBUG
6909         write(2,*), "de_dxx = ", de_dxx,de_dxx_num,itype(i)
6910 #endif
6911 C
6912         sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
6913         sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2
6914      &  +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2)
6915      &  +x(40)*xx*zz
6916         sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
6917         sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz
6918      &  +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz
6919      &  +x(59)*zz**2 +x(60)*xx*zz
6920         de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6)
6921      &        +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6)
6922      &        +(pom1-pom2)*pom_dy
6923 #ifdef DEBUG
6924         write(2,*), "de_dyy = ", de_dyy,de_dyy_num,itype(i)
6925 #endif
6926 C
6927         de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy
6928      &  +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx
6929      &  +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6)
6930      &  +(x(4) + 2*x(7)*zz+  x(8)*xx + x(10)*yy)*(s1+s1_6)
6931      &  +(x(44)+2*x(47)*zz +x(48)*xx   +x(50)*yy  +3*x(53)*zz**2
6932      &  +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy
6933      &  +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6)
6934      &  + ( x(14) + 2*x(17)*zz+  x(18)*xx + x(20)*yy)*(s2+s2_6)
6935 #ifdef DEBUG
6936         write(2,*), "de_dzz = ", de_dzz,de_dzz_num,itype(i)
6937 #endif
6938 C
6939         de_dt =  0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6)
6940      &  -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6)
6941      &  +pom1*pom_dt1+pom2*pom_dt2
6942 #ifdef DEBUG
6943         write(2,*), "de_dt = ", de_dt,de_dt_num,itype(i)
6944 #endif
6945 c#undef DEBUG
6946 c
6947 C
6948        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
6949        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
6950        cosfac2xx=cosfac2*xx
6951        sinfac2yy=sinfac2*yy
6952        do k = 1,3
6953          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))*
6954      &      vbld_inv(i+1)
6955          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))*
6956      &      vbld_inv(i)
6957          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
6958          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
6959 c         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
6960 c     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
6961 c         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
6962 c     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
6963          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
6964          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
6965          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
6966          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
6967          dZZ_Ci1(k)=0.0d0
6968          dZZ_Ci(k)=0.0d0
6969          do j=1,3
6970            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)
6971      &     *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
6972            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)
6973      &     *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
6974          enddo
6975
6976          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
6977          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
6978          dZZ_XYZ(k)=vbld_inv(i+nres)*
6979      &   (z_prime(k)-zz*dC_norm(k,i+nres))
6980 c
6981          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
6982          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
6983        enddo
6984
6985        do k=1,3
6986          dXX_Ctab(k,i)=dXX_Ci(k)
6987          dXX_C1tab(k,i)=dXX_Ci1(k)
6988          dYY_Ctab(k,i)=dYY_Ci(k)
6989          dYY_C1tab(k,i)=dYY_Ci1(k)
6990          dZZ_Ctab(k,i)=dZZ_Ci(k)
6991          dZZ_C1tab(k,i)=dZZ_Ci1(k)
6992          dXX_XYZtab(k,i)=dXX_XYZ(k)
6993          dYY_XYZtab(k,i)=dYY_XYZ(k)
6994          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
6995        enddo
6996
6997        do k = 1,3
6998 c         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
6999 c     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
7000 c         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
7001 c     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
7002 c         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
7003 c     &    dt_dci(k)
7004 c         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
7005 c     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
7006          gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k)
7007      &    +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
7008          gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k)
7009      &    +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
7010          gsclocx(k,i)=                 de_dxx*dxx_XYZ(k)
7011      &    +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
7012        enddo
7013 c       write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
7014 c     &  (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
7015
7016 C to check gradient call subroutine check_grad
7017
7018     1 continue
7019       enddo
7020       return
7021       end
7022 c------------------------------------------------------------------------------
7023       double precision function enesc(x,xx,yy,zz,cost2,sint2)
7024       implicit none
7025       double precision x(65),xx,yy,zz,cost2,sint2,sumene1,sumene2,
7026      & sumene3,sumene4,sumene,dsc_i,dp2_i,dscp1,dscp2,s1,s1_6,s2,s2_6
7027       sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
7028      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
7029      &   + x(10)*yy*zz
7030       sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
7031      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
7032      & + x(20)*yy*zz
7033       sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
7034      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
7035      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
7036      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
7037      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
7038      &  +x(40)*xx*yy*zz
7039       sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
7040      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
7041      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
7042      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
7043      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
7044      &  +x(60)*xx*yy*zz
7045       dsc_i   = 0.743d0+x(61)
7046       dp2_i   = 1.9d0+x(62)
7047       dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
7048      &          *(xx*cost2+yy*sint2))
7049       dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
7050      &          *(xx*cost2-yy*sint2))
7051       s1=(1+x(63))/(0.1d0 + dscp1)
7052       s1_6=(1+x(64))/(0.1d0 + dscp1**6)
7053       s2=(1+x(65))/(0.1d0 + dscp2)
7054       s2_6=(1+x(65))/(0.1d0 + dscp2**6)
7055       sumene = ( sumene3*sint2 + sumene1)*(s1+s1_6)
7056      & + (sumene4*cost2 +sumene2)*(s2+s2_6)
7057       enesc=sumene
7058       return
7059       end
7060 #endif
7061 c------------------------------------------------------------------------------
7062       subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
7063 C
7064 C This procedure calculates two-body contact function g(rij) and its derivative:
7065 C
7066 C           eps0ij                                     !       x < -1
7067 C g(rij) =  esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5)  ! -1 =< x =< 1
7068 C            0                                         !       x > 1
7069 C
7070 C where x=(rij-r0ij)/delta
7071 C
7072 C rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
7073 C
7074       implicit none
7075       double precision rij,r0ij,eps0ij,fcont,fprimcont
7076       double precision x,x2,x4,delta
7077 c     delta=0.02D0*r0ij
7078 c      delta=0.2D0*r0ij
7079       x=(rij-r0ij)/delta
7080       if (x.lt.-1.0D0) then
7081         fcont=eps0ij
7082         fprimcont=0.0D0
7083       else if (x.le.1.0D0) then
7084         x2=x*x
7085         x4=x2*x2
7086         fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
7087         fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
7088       else
7089         fcont=0.0D0
7090         fprimcont=0.0D0
7091       endif
7092       return
7093       end
7094 c------------------------------------------------------------------------------
7095       subroutine splinthet(theti,delta,ss,ssder)
7096       implicit real*8 (a-h,o-z)
7097       include 'DIMENSIONS'
7098       include 'COMMON.VAR'
7099       include 'COMMON.GEO'
7100       thetup=pi-delta
7101       thetlow=delta
7102       if (theti.gt.pipol) then
7103         call gcont(theti,thetup,1.0d0,delta,ss,ssder)
7104       else
7105         call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
7106         ssder=-ssder
7107       endif
7108       return
7109       end
7110 c------------------------------------------------------------------------------
7111       subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
7112       implicit none
7113       double precision x,x0,delta,f0,f1,fprim0,f,fprim
7114       double precision ksi,ksi2,ksi3,a1,a2,a3
7115       a1=fprim0*delta/(f1-f0)
7116       a2=3.0d0-2.0d0*a1
7117       a3=a1-2.0d0
7118       ksi=(x-x0)/delta
7119       ksi2=ksi*ksi
7120       ksi3=ksi2*ksi
7121       f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
7122       fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
7123       return
7124       end
7125 c------------------------------------------------------------------------------
7126       subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
7127       implicit none
7128       double precision x,x0,delta,f0x,f1x,fprim0x,fx
7129       double precision ksi,ksi2,ksi3,a1,a2,a3
7130       ksi=(x-x0)/delta
7131       ksi2=ksi*ksi
7132       ksi3=ksi2*ksi
7133       a1=fprim0x*delta
7134       a2=3*(f1x-f0x)-2*fprim0x*delta
7135       a3=fprim0x*delta-2*(f1x-f0x)
7136       fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
7137       return
7138       end
7139 C-----------------------------------------------------------------------------
7140 #ifdef CRYST_TOR
7141 C-----------------------------------------------------------------------------
7142       subroutine etor(etors)
7143       implicit real*8 (a-h,o-z)
7144       include 'DIMENSIONS'
7145       include 'COMMON.VAR'
7146       include 'COMMON.GEO'
7147       include 'COMMON.LOCAL'
7148       include 'COMMON.TORSION'
7149       include 'COMMON.INTERACT'
7150       include 'COMMON.DERIV'
7151       include 'COMMON.CHAIN'
7152       include 'COMMON.NAMES'
7153       include 'COMMON.IOUNITS'
7154       include 'COMMON.FFIELD'
7155       include 'COMMON.TORCNSTR'
7156       include 'COMMON.CONTROL'
7157       logical lprn
7158 C Set lprn=.true. for debugging
7159       lprn=.false.
7160 c      lprn=.true.
7161       etors=0.0D0
7162       do i=iphi_start,iphi_end
7163       etors_ii=0.0D0
7164         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
7165      &      .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
7166         itori=itortyp(itype(i-2))
7167         itori1=itortyp(itype(i-1))
7168         phii=phi(i)
7169         gloci=0.0D0
7170 C Proline-Proline pair is a special case...
7171         if (itori.eq.3 .and. itori1.eq.3) then
7172           if (phii.gt.-dwapi3) then
7173             cosphi=dcos(3*phii)
7174             fac=1.0D0/(1.0D0-cosphi)
7175             etorsi=v1(1,3,3)*fac
7176             etorsi=etorsi+etorsi
7177             etors=etors+etorsi-v1(1,3,3)
7178             if (energy_dec) etors_ii=etors_ii+etorsi-v1(1,3,3)
7179             gloci=gloci-3*fac*etorsi*dsin(3*phii)
7180           endif
7181           do j=1,3
7182             v1ij=v1(j+1,itori,itori1)
7183             v2ij=v2(j+1,itori,itori1)
7184             cosphi=dcos(j*phii)
7185             sinphi=dsin(j*phii)
7186             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7187             if (energy_dec) etors_ii=etors_ii+
7188      &                              v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7189             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7190           enddo
7191         else
7192           do j=1,nterm_old
7193             v1ij=v1(j,itori,itori1)
7194             v2ij=v2(j,itori,itori1)
7195             cosphi=dcos(j*phii)
7196             sinphi=dsin(j*phii)
7197             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7198             if (energy_dec) etors_ii=etors_ii+
7199      &                  v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7200             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7201           enddo
7202         endif
7203         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
7204              'etor',i,etors_ii
7205         if (lprn)
7206      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
7207      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
7208      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
7209         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
7210 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
7211       enddo
7212       return
7213       end
7214 c------------------------------------------------------------------------------
7215       subroutine etor_d(etors_d)
7216       etors_d=0.0d0
7217       return
7218       end
7219 c----------------------------------------------------------------------------
7220 c LICZENIE WIEZOW Z ROWNANIA ENERGII MODELLERA
7221       subroutine e_modeller(ehomology_constr)
7222       ehomology_constr=0.0d0
7223       write (iout,*) "!!!!!UWAGA, JESTEM W DZIWNEJ PETLI, TEST!!!!!"
7224       return
7225       end
7226 C !!!!!!!! NIE CZYTANE !!!!!!!!!!!
7227
7228 c------------------------------------------------------------------------------
7229       subroutine etor_d(etors_d)
7230       etors_d=0.0d0
7231       return
7232       end
7233 c----------------------------------------------------------------------------
7234 #else
7235       subroutine etor(etors)
7236       implicit real*8 (a-h,o-z)
7237       include 'DIMENSIONS'
7238       include 'COMMON.VAR'
7239       include 'COMMON.GEO'
7240       include 'COMMON.LOCAL'
7241       include 'COMMON.TORSION'
7242       include 'COMMON.INTERACT'
7243       include 'COMMON.DERIV'
7244       include 'COMMON.CHAIN'
7245       include 'COMMON.NAMES'
7246       include 'COMMON.IOUNITS'
7247       include 'COMMON.FFIELD'
7248       include 'COMMON.TORCNSTR'
7249       include 'COMMON.CONTROL'
7250       logical lprn
7251 C Set lprn=.true. for debugging
7252       lprn=.false.
7253 c     lprn=.true.
7254       etors=0.0D0
7255       do i=iphi_start,iphi_end
7256 C ANY TWO ARE DUMMY ATOMS in row CYCLE
7257 c        if (((itype(i-3).eq.ntyp1).and.(itype(i-2).eq.ntyp1)).or.
7258 c     &      ((itype(i-2).eq.ntyp1).and.(itype(i-1).eq.ntyp1))  .or.
7259 c     &      ((itype(i-1).eq.ntyp1).and.(itype(i).eq.ntyp1))) cycle
7260         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
7261      &      .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
7262 C In current verion the ALL DUMMY ATOM POTENTIALS ARE OFF
7263 C For introducing the NH3+ and COO- group please check the etor_d for reference
7264 C and guidance
7265         etors_ii=0.0D0
7266          if (iabs(itype(i)).eq.20) then
7267          iblock=2
7268          else
7269          iblock=1
7270          endif
7271         itori=itortyp(itype(i-2))
7272         itori1=itortyp(itype(i-1))
7273         phii=phi(i)
7274         gloci=0.0D0
7275 C Regular cosine and sine terms
7276         do j=1,nterm(itori,itori1,iblock)
7277           v1ij=v1(j,itori,itori1,iblock)
7278           v2ij=v2(j,itori,itori1,iblock)
7279           cosphi=dcos(j*phii)
7280           sinphi=dsin(j*phii)
7281           etors=etors+v1ij*cosphi+v2ij*sinphi
7282           if (energy_dec) etors_ii=etors_ii+
7283      &                v1ij*cosphi+v2ij*sinphi
7284           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7285         enddo
7286 C Lorentz terms
7287 C                         v1
7288 C  E = SUM ----------------------------------- - v1
7289 C          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
7290 C
7291         cosphi=dcos(0.5d0*phii)
7292         sinphi=dsin(0.5d0*phii)
7293         do j=1,nlor(itori,itori1,iblock)
7294           vl1ij=vlor1(j,itori,itori1)
7295           vl2ij=vlor2(j,itori,itori1)
7296           vl3ij=vlor3(j,itori,itori1)
7297           pom=vl2ij*cosphi+vl3ij*sinphi
7298           pom1=1.0d0/(pom*pom+1.0d0)
7299           etors=etors+vl1ij*pom1
7300           if (energy_dec) etors_ii=etors_ii+
7301      &                vl1ij*pom1
7302           pom=-pom*pom1*pom1
7303           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
7304         enddo
7305 C Subtract the constant term
7306         etors=etors-v0(itori,itori1,iblock)
7307           if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
7308      &         'etor',i,etors_ii-v0(itori,itori1,iblock)
7309         if (lprn)
7310      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
7311      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
7312      &  (v1(j,itori,itori1,iblock),j=1,6),
7313      &  (v2(j,itori,itori1,iblock),j=1,6)
7314         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
7315 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
7316       enddo
7317       return
7318       end
7319 c----------------------------------------------------------------------------
7320       subroutine etor_d(etors_d)
7321 C 6/23/01 Compute double torsional energy
7322       implicit real*8 (a-h,o-z)
7323       include 'DIMENSIONS'
7324       include 'COMMON.VAR'
7325       include 'COMMON.GEO'
7326       include 'COMMON.LOCAL'
7327       include 'COMMON.TORSION'
7328       include 'COMMON.INTERACT'
7329       include 'COMMON.DERIV'
7330       include 'COMMON.CHAIN'
7331       include 'COMMON.NAMES'
7332       include 'COMMON.IOUNITS'
7333       include 'COMMON.FFIELD'
7334       include 'COMMON.TORCNSTR'
7335       logical lprn
7336 C Set lprn=.true. for debugging
7337       lprn=.false.
7338 c     lprn=.true.
7339       etors_d=0.0D0
7340 c      write(iout,*) "a tu??"
7341       do i=iphid_start,iphid_end
7342 C ANY TWO ARE DUMMY ATOMS in row CYCLE
7343 C        if (((itype(i-3).eq.ntyp1).and.(itype(i-2).eq.ntyp1)).or.
7344 C     &      ((itype(i-2).eq.ntyp1).and.(itype(i-1).eq.ntyp1)).or.
7345 C     &      ((itype(i-1).eq.ntyp1).and.(itype(i).eq.ntyp1))  .or.
7346 C     &      ((itype(i).eq.ntyp1).and.(itype(i+1).eq.ntyp1))) cycle
7347          if ((itype(i-2).eq.ntyp1).or.itype(i-3).eq.ntyp1.or.
7348      &  (itype(i-1).eq.ntyp1).or.(itype(i).eq.ntyp1).or.
7349      &  (itype(i+1).eq.ntyp1)) cycle
7350 C In current verion the ALL DUMMY ATOM POTENTIALS ARE OFF
7351         itori=itortyp(itype(i-2))
7352         itori1=itortyp(itype(i-1))
7353         itori2=itortyp(itype(i))
7354         phii=phi(i)
7355         phii1=phi(i+1)
7356         gloci1=0.0D0
7357         gloci2=0.0D0
7358         iblock=1
7359         if (iabs(itype(i+1)).eq.20) iblock=2
7360 C Iblock=2 Proline type
7361 C ADASKO: WHEN PARAMETERS FOR THIS TYPE OF BLOCKING GROUP IS READY UNCOMMENT
7362 C CHECK WEATHER THERE IS NECCESITY FOR iblock=3 for COO-
7363 C        if (itype(i+1).eq.ntyp1) iblock=3
7364 C The problem of NH3+ group can be resolved by adding new parameters please note if there
7365 C IS or IS NOT need for this
7366 C IF Yes uncomment below and add to parmread.F appropriate changes and to v1cij and so on
7367 C        is (itype(i-3).eq.ntyp1) ntblock=2
7368 C        ntblock is N-terminal blocking group
7369
7370 C Regular cosine and sine terms
7371         do j=1,ntermd_1(itori,itori1,itori2,iblock)
7372 C Example of changes for NH3+ blocking group
7373 C       do j=1,ntermd_1(itori,itori1,itori2,iblock,ntblock)
7374 C          v1cij=v1c(1,j,itori,itori1,itori2,iblock,ntblock)
7375           v1cij=v1c(1,j,itori,itori1,itori2,iblock)
7376           v1sij=v1s(1,j,itori,itori1,itori2,iblock)
7377           v2cij=v1c(2,j,itori,itori1,itori2,iblock)
7378           v2sij=v1s(2,j,itori,itori1,itori2,iblock)
7379           cosphi1=dcos(j*phii)
7380           sinphi1=dsin(j*phii)
7381           cosphi2=dcos(j*phii1)
7382           sinphi2=dsin(j*phii1)
7383           etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+
7384      &     v2cij*cosphi2+v2sij*sinphi2
7385           gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
7386           gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
7387         enddo
7388         do k=2,ntermd_2(itori,itori1,itori2,iblock)
7389           do l=1,k-1
7390             v1cdij = v2c(k,l,itori,itori1,itori2,iblock)
7391             v2cdij = v2c(l,k,itori,itori1,itori2,iblock)
7392             v1sdij = v2s(k,l,itori,itori1,itori2,iblock)
7393             v2sdij = v2s(l,k,itori,itori1,itori2,iblock)
7394             cosphi1p2=dcos(l*phii+(k-l)*phii1)
7395             cosphi1m2=dcos(l*phii-(k-l)*phii1)
7396             sinphi1p2=dsin(l*phii+(k-l)*phii1)
7397             sinphi1m2=dsin(l*phii-(k-l)*phii1)
7398             etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+
7399      &        v1sdij*sinphi1p2+v2sdij*sinphi1m2
7400             gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2
7401      &        -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
7402             gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2
7403      &        -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
7404           enddo
7405         enddo
7406         gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*gloci1
7407         gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*gloci2
7408       enddo
7409       return
7410       end
7411 #endif
7412 C----------------------------------------------------------------------------------
7413 C The rigorous attempt to derive energy function
7414       subroutine etor_kcc(etors)
7415       implicit real*8 (a-h,o-z)
7416       include 'DIMENSIONS'
7417       include 'COMMON.VAR'
7418       include 'COMMON.GEO'
7419       include 'COMMON.LOCAL'
7420       include 'COMMON.TORSION'
7421       include 'COMMON.INTERACT'
7422       include 'COMMON.DERIV'
7423       include 'COMMON.CHAIN'
7424       include 'COMMON.NAMES'
7425       include 'COMMON.IOUNITS'
7426       include 'COMMON.FFIELD'
7427       include 'COMMON.TORCNSTR'
7428       include 'COMMON.CONTROL'
7429       double precision c1(0:maxval_kcc),c2(0:maxval_kcc)
7430       logical lprn
7431 c      double precision thybt1(maxtermkcc),thybt2(maxtermkcc)
7432 C Set lprn=.true. for debugging
7433       lprn=energy_dec
7434 c     lprn=.true.
7435 C      print *,"wchodze kcc"
7436       if (lprn) write (iout,*) "etor_kcc tor_mode",tor_mode
7437       etors=0.0D0
7438       do i=iphi_start,iphi_end
7439 C ANY TWO ARE DUMMY ATOMS in row CYCLE
7440 c        if (((itype(i-3).eq.ntyp1).and.(itype(i-2).eq.ntyp1)).or.
7441 c     &      ((itype(i-2).eq.ntyp1).and.(itype(i-1).eq.ntyp1))  .or.
7442 c     &      ((itype(i-1).eq.ntyp1).and.(itype(i).eq.ntyp1))) cycle
7443         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
7444      &      .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
7445         itori=itortyp(itype(i-2))
7446         itori1=itortyp(itype(i-1))
7447         phii=phi(i)
7448         glocig=0.0D0
7449         glocit1=0.0d0
7450         glocit2=0.0d0
7451 C to avoid multiple devision by 2
7452 c        theti22=0.5d0*theta(i)
7453 C theta 12 is the theta_1 /2
7454 C theta 22 is theta_2 /2
7455 c        theti12=0.5d0*theta(i-1)
7456 C and appropriate sinus function
7457         sinthet1=dsin(theta(i-1))
7458         sinthet2=dsin(theta(i))
7459         costhet1=dcos(theta(i-1))
7460         costhet2=dcos(theta(i))
7461 C to speed up lets store its mutliplication
7462         sint1t2=sinthet2*sinthet1
7463         sint1t2n=1.0d0
7464 C \sum_{i=1}^n (sin(theta_1) * sin(theta_2))^n * (c_n* cos(n*gamma)
7465 C +d_n*sin(n*gamma)) *
7466 C \sum_{i=1}^m (1+a_m*Tb_m(cos(theta_1 /2))+b_m*Tb_m(cos(theta_2 /2)))
7467 C we have two sum 1) Non-Chebyshev which is with n and gamma
7468         nval=nterm_kcc_Tb(itori,itori1)
7469         c1(0)=0.0d0
7470         c2(0)=0.0d0
7471         c1(1)=1.0d0
7472         c2(1)=1.0d0
7473         do j=2,nval
7474           c1(j)=c1(j-1)*costhet1
7475           c2(j)=c2(j-1)*costhet2
7476         enddo
7477         etori=0.0d0
7478         do j=1,nterm_kcc(itori,itori1)
7479           cosphi=dcos(j*phii)
7480           sinphi=dsin(j*phii)
7481           sint1t2n1=sint1t2n
7482           sint1t2n=sint1t2n*sint1t2
7483           sumvalc=0.0d0
7484           gradvalct1=0.0d0
7485           gradvalct2=0.0d0
7486           do k=1,nval
7487             do l=1,nval
7488               sumvalc=sumvalc+v1_kcc(l,k,j,itori1,itori)*c1(k)*c2(l)
7489               gradvalct1=gradvalct1+
7490      &           (k-1)*v1_kcc(l,k,j,itori1,itori)*c1(k-1)*c2(l)
7491               gradvalct2=gradvalct2+
7492      &           (l-1)*v1_kcc(l,k,j,itori1,itori)*c1(k)*c2(l-1)
7493             enddo
7494           enddo
7495           gradvalct1=-gradvalct1*sinthet1
7496           gradvalct2=-gradvalct2*sinthet2
7497           sumvals=0.0d0
7498           gradvalst1=0.0d0
7499           gradvalst2=0.0d0
7500           do k=1,nval
7501             do l=1,nval
7502               sumvals=sumvals+v2_kcc(l,k,j,itori1,itori)*c1(k)*c2(l)
7503               gradvalst1=gradvalst1+
7504      &           (k-1)*v2_kcc(l,k,j,itori1,itori)*c1(k-1)*c2(l)
7505               gradvalst2=gradvalst2+
7506      &           (l-1)*v2_kcc(l,k,j,itori1,itori)*c1(k)*c2(l-1)
7507             enddo
7508           enddo
7509           gradvalst1=-gradvalst1*sinthet1
7510           gradvalst2=-gradvalst2*sinthet2
7511           if (lprn) write (iout,*)j,"sumvalc",sumvalc," sumvals",sumvals
7512           etori=etori+sint1t2n*(sumvalc*cosphi+sumvals*sinphi)
7513 C glocig is the gradient local i site in gamma
7514           glocig=glocig+j*sint1t2n*(sumvals*cosphi-sumvalc*sinphi)
7515 C now gradient over theta_1
7516           glocit1=glocit1+sint1t2n*(gradvalct1*cosphi+gradvalst1*sinphi)
7517      &   +j*sint1t2n1*costhet1*sinthet2*(sumvalc*cosphi+sumvals*sinphi)
7518           glocit2=glocit2+sint1t2n*(gradvalct2*cosphi+gradvalst2*sinphi)
7519      &   +j*sint1t2n1*sinthet1*costhet2*(sumvalc*cosphi+sumvals*sinphi)
7520         enddo ! j
7521         etors=etors+etori
7522 C derivative over gamma
7523         gloc(i-3,icg)=gloc(i-3,icg)+wtor*glocig
7524 C derivative over theta1
7525         gloc(nphi+i-3,icg)=gloc(nphi+i-3,icg)+wtor*glocit1
7526 C now derivative over theta2
7527         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)+wtor*glocit2
7528         if (lprn) then
7529           write (iout,*) i-2,i-1,itype(i-2),itype(i-1),itori,itori1,
7530      &       theta(i-1)*rad2deg,theta(i)*rad2deg,phii*rad2deg,etori
7531           write (iout,*) "c1",(c1(k),k=0,nval),
7532      &    " c2",(c2(k),k=0,nval)
7533         endif
7534       enddo
7535       return
7536       end
7537 c---------------------------------------------------------------------------------------------
7538       subroutine etor_constr(edihcnstr)
7539       implicit real*8 (a-h,o-z)
7540       include 'DIMENSIONS'
7541       include 'COMMON.VAR'
7542       include 'COMMON.GEO'
7543       include 'COMMON.LOCAL'
7544       include 'COMMON.TORSION'
7545       include 'COMMON.INTERACT'
7546       include 'COMMON.DERIV'
7547       include 'COMMON.CHAIN'
7548       include 'COMMON.NAMES'
7549       include 'COMMON.IOUNITS'
7550       include 'COMMON.FFIELD'
7551       include 'COMMON.TORCNSTR'
7552       include 'COMMON.BOUNDS'
7553       include 'COMMON.CONTROL'
7554 ! 6/20/98 - dihedral angle constraints
7555       edihcnstr=0.0d0
7556 c      do i=1,ndih_constr
7557       if (raw_psipred) then
7558         do i=idihconstr_start,idihconstr_end
7559           itori=idih_constr(i)
7560           phii=phi(itori)
7561           gaudih_i=vpsipred(1,i)
7562           gauder_i=0.0d0
7563           do j=1,2
7564             s = sdihed(j,i)
7565             cos_i=(1.0d0-dcos(phii-phibound(j,i)))/s**2
7566             dexpcos_i=dexp(-cos_i*cos_i)
7567             gaudih_i=gaudih_i+vpsipred(j+1,i)*dexpcos_i
7568             gauder_i=gauder_i-2*vpsipred(j+1,i)*dsin(phii-phibound(j,i))
7569      &            *cos_i*dexpcos_i/s**2
7570           enddo
7571           edihcnstr=edihcnstr-wdihc*dlog(gaudih_i)
7572           gloc(itori-3,icg)=gloc(itori-3,icg)-wdihc*gauder_i/gaudih_i
7573           if (energy_dec)
7574      &     write (iout,'(2i5,f8.3,f8.5,2(f8.5,2f8.3),f10.5)')
7575      &     i,itori,phii*rad2deg,vpsipred(1,i),vpsipred(2,i),
7576      &     phibound(1,i)*rad2deg,sdihed(1,i)*rad2deg,vpsipred(3,i),
7577      &     phibound(2,i)*rad2deg,sdihed(2,i)*rad2deg,
7578      &     -wdihc*dlog(gaudih_i)
7579         enddo
7580       else
7581
7582       do i=idihconstr_start,idihconstr_end
7583         itori=idih_constr(i)
7584         phii=phi(itori)
7585         difi=pinorm(phii-phi0(i))
7586         if (difi.gt.drange(i)) then
7587           difi=difi-drange(i)
7588           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
7589           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
7590         else if (difi.lt.-drange(i)) then
7591           difi=difi+drange(i)
7592           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
7593           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
7594         else
7595           difi=0.0
7596         endif
7597       enddo
7598
7599       endif
7600
7601       return
7602       end
7603 c----------------------------------------------------------------------------
7604 c MODELLER restraint function
7605       subroutine e_modeller(ehomology_constr)
7606       implicit none
7607       include 'DIMENSIONS'
7608
7609       double precision ehomology_constr
7610       integer nnn,i,ii,j,k,ijk,jik,ki,kk,nexl,irec,l
7611       integer katy, odleglosci, test7
7612       real*8 odleg, odleg2, odleg3, kat, kat2, kat3, gdih(max_template)
7613       real*8 Eval,Erot
7614       real*8 distance(max_template),distancek(max_template),
7615      &    min_odl,godl(max_template),dih_diff(max_template)
7616
7617 c
7618 c     FP - 30/10/2014 Temporary specifications for homology restraints
7619 c
7620       double precision utheta_i,gutheta_i,sum_gtheta,sum_sgtheta,
7621      &                 sgtheta
7622       double precision, dimension (maxres) :: guscdiff,usc_diff
7623       double precision, dimension (max_template) ::
7624      &           gtheta,dscdiff,uscdiffk,guscdiff2,guscdiff3,
7625      &           theta_diff
7626       double precision sum_godl,sgodl,grad_odl3,ggodl,sum_gdih,
7627      & sum_guscdiff,sum_sgdih,sgdih,grad_dih3,usc_diff_i,dxx,dyy,dzz,
7628      & betai,sum_sgodl,dij
7629       double precision dist,pinorm
7630 c
7631       include 'COMMON.SBRIDGE'
7632       include 'COMMON.CHAIN'
7633       include 'COMMON.GEO'
7634       include 'COMMON.DERIV'
7635       include 'COMMON.LOCAL'
7636       include 'COMMON.INTERACT'
7637       include 'COMMON.VAR'
7638       include 'COMMON.IOUNITS'
7639 c      include 'COMMON.MD'
7640       include 'COMMON.CONTROL'
7641       include 'COMMON.HOMOLOGY'
7642       include 'COMMON.QRESTR'
7643 c
7644 c     From subroutine Econstr_back
7645 c
7646       include 'COMMON.NAMES'
7647       include 'COMMON.TIME1'
7648 c
7649
7650
7651       do i=1,max_template
7652         distancek(i)=9999999.9
7653       enddo
7654
7655
7656       odleg=0.0d0
7657
7658 c Pseudo-energy and gradient from homology restraints (MODELLER-like
7659 c function)
7660 C AL 5/2/14 - Introduce list of restraints
7661 c     write(iout,*) "waga_theta",waga_theta,"waga_d",waga_d
7662 #ifdef DEBUG
7663       write(iout,*) "------- dist restrs start -------"
7664 #endif
7665       do ii = link_start_homo,link_end_homo
7666          i = ires_homo(ii)
7667          j = jres_homo(ii)
7668          dij=dist(i,j)
7669 c        write (iout,*) "dij(",i,j,") =",dij
7670          nexl=0
7671          do k=1,constr_homology
7672 c           write(iout,*) ii,k,i,j,l_homo(k,ii),dij,odl(k,ii)
7673            if(.not.l_homo(k,ii)) then
7674              nexl=nexl+1
7675              cycle
7676            endif
7677            distance(k)=odl(k,ii)-dij
7678 c          write (iout,*) "distance(",k,") =",distance(k)
7679 c
7680 c          For Gaussian-type Urestr
7681 c
7682            distancek(k)=0.5d0*distance(k)**2*sigma_odl(k,ii) ! waga_dist rmvd from Gaussian argument
7683 c          write (iout,*) "sigma_odl(",k,ii,") =",sigma_odl(k,ii)
7684 c          write (iout,*) "distancek(",k,") =",distancek(k)
7685 c          distancek(k)=0.5d0*waga_dist*distance(k)**2*sigma_odl(k,ii)
7686 c
7687 c          For Lorentzian-type Urestr
7688 c
7689            if (waga_dist.lt.0.0d0) then
7690               sigma_odlir(k,ii)=dsqrt(1/sigma_odl(k,ii))
7691               distancek(k)=distance(k)**2/(sigma_odlir(k,ii)*
7692      &                     (distance(k)**2+sigma_odlir(k,ii)**2))
7693            endif
7694          enddo
7695
7696 c         min_odl=minval(distancek)
7697          if (nexl.gt.0) then
7698            min_odl=0.0d0
7699          else
7700            do kk=1,constr_homology
7701             if(l_homo(kk,ii)) then
7702               min_odl=distancek(kk)
7703               exit
7704             endif
7705            enddo
7706            do kk=1,constr_homology
7707             if(l_homo(kk,ii) .and. distancek(kk).lt.min_odl)
7708      &              min_odl=distancek(kk)
7709            enddo
7710          endif
7711
7712 c        write (iout,* )"min_odl",min_odl
7713 #ifdef DEBUG
7714          write (iout,*) "ij dij",i,j,dij
7715          write (iout,*) "distance",(distance(k),k=1,constr_homology)
7716          write (iout,*) "distancek",(distancek(k),k=1,constr_homology)
7717          write (iout,* )"min_odl",min_odl
7718 #endif
7719 #ifdef OLDRESTR
7720          odleg2=0.0d0
7721 #else
7722          if (waga_dist.ge.0.0d0) then
7723            odleg2=nexl
7724          else
7725            odleg2=0.0d0
7726          endif
7727 #endif
7728          do k=1,constr_homology
7729 c Nie wiem po co to liczycie jeszcze raz!
7730 c            odleg3=-waga_dist(iset)*((distance(i,j,k)**2)/
7731 c     &              (2*(sigma_odl(i,j,k))**2))
7732            if(.not.l_homo(k,ii)) cycle
7733            if (waga_dist.ge.0.0d0) then
7734 c
7735 c          For Gaussian-type Urestr
7736 c
7737             godl(k)=dexp(-distancek(k)+min_odl)
7738             odleg2=odleg2+godl(k)
7739 c
7740 c          For Lorentzian-type Urestr
7741 c
7742            else
7743             odleg2=odleg2+distancek(k)
7744            endif
7745
7746 ccc       write(iout,779) i,j,k, "odleg2=",odleg2, "odleg3=", odleg3,
7747 ccc     & "dEXP(odleg3)=", dEXP(odleg3),"distance(i,j,k)^2=",
7748 ccc     & distance(i,j,k)**2, "dist(i+1,j+1)=", dist(i+1,j+1),
7749 ccc     & "sigma_odl(i,j,k)=", sigma_odl(i,j,k)
7750
7751          enddo
7752 c        write (iout,*) "godl",(godl(k),k=1,constr_homology) ! exponents
7753 c        write (iout,*) "ii i j",ii,i,j," odleg2",odleg2 ! sum of exps
7754 #ifdef DEBUG
7755          write (iout,*) "godl",(godl(k),k=1,constr_homology) ! exponents
7756          write (iout,*) "ii i j",ii,i,j," odleg2",odleg2 ! sum of exps
7757 #endif
7758            if (waga_dist.ge.0.0d0) then
7759 c
7760 c          For Gaussian-type Urestr
7761 c
7762               odleg=odleg-dLOG(odleg2/constr_homology)+min_odl
7763 c
7764 c          For Lorentzian-type Urestr
7765 c
7766            else
7767               odleg=odleg+odleg2/constr_homology
7768            endif
7769 c
7770 c        write (iout,*) "odleg",odleg ! sum of -ln-s
7771 c Gradient
7772 c
7773 c          For Gaussian-type Urestr
7774 c
7775          if (waga_dist.ge.0.0d0) sum_godl=odleg2
7776          sum_sgodl=0.0d0
7777          do k=1,constr_homology
7778 c            godl=dexp(((-(distance(i,j,k)**2)/(2*(sigma_odl(i,j,k))**2))
7779 c     &           *waga_dist)+min_odl
7780 c          sgodl=-godl(k)*distance(k)*sigma_odl(k,ii)*waga_dist
7781 c
7782          if(.not.l_homo(k,ii)) cycle
7783          if (waga_dist.ge.0.0d0) then
7784 c          For Gaussian-type Urestr
7785 c
7786            sgodl=-godl(k)*distance(k)*sigma_odl(k,ii) ! waga_dist rmvd
7787 c
7788 c          For Lorentzian-type Urestr
7789 c
7790          else
7791            sgodl=-2*sigma_odlir(k,ii)*(distance(k)/(distance(k)**2+
7792      &           sigma_odlir(k,ii)**2)**2)
7793          endif
7794            sum_sgodl=sum_sgodl+sgodl
7795
7796 c            sgodl2=sgodl2+sgodl
7797 c      write(iout,*) i, j, k, distance(i,j,k), "W GRADIENCIE1"
7798 c      write(iout,*) "constr_homology=",constr_homology
7799 c      write(iout,*) i, j, k, "TEST K"
7800          enddo
7801          if (waga_dist.ge.0.0d0) then
7802 c
7803 c          For Gaussian-type Urestr
7804 c
7805             grad_odl3=waga_homology(iset)*waga_dist
7806      &                *sum_sgodl/(sum_godl*dij)
7807 c
7808 c          For Lorentzian-type Urestr
7809 c
7810          else
7811 c Original grad expr modified by analogy w Gaussian-type Urestr grad
7812 c           grad_odl3=-waga_homology(iset)*waga_dist*sum_sgodl
7813             grad_odl3=-waga_homology(iset)*waga_dist*
7814      &                sum_sgodl/(constr_homology*dij)
7815          endif
7816 c
7817 c        grad_odl3=sum_sgodl/(sum_godl*dij)
7818
7819
7820 c      write(iout,*) i, j, k, distance(i,j,k), "W GRADIENCIE2"
7821 c      write(iout,*) (distance(i,j,k)**2), (2*(sigma_odl(i,j,k))**2),
7822 c     &              (-(distance(i,j,k)**2)/(2*(sigma_odl(i,j,k))**2))
7823
7824 ccc      write(iout,*) godl, sgodl, grad_odl3
7825
7826 c          grad_odl=grad_odl+grad_odl3
7827
7828          do jik=1,3
7829             ggodl=grad_odl3*(c(jik,i)-c(jik,j))
7830 ccc      write(iout,*) c(jik,i+1), c(jik,j+1), (c(jik,i+1)-c(jik,j+1))
7831 ccc      write(iout,746) "GRAD_ODL_1", i, j, jik, ggodl,
7832 ccc     &              ghpbc(jik,i+1), ghpbc(jik,j+1)
7833             ghpbc(jik,i)=ghpbc(jik,i)+ggodl
7834             ghpbc(jik,j)=ghpbc(jik,j)-ggodl
7835 ccc      write(iout,746) "GRAD_ODL_2", i, j, jik, ggodl,
7836 ccc     &              ghpbc(jik,i+1), ghpbc(jik,j+1)
7837 c         if (i.eq.25.and.j.eq.27) then
7838 c         write(iout,*) "jik",jik,"i",i,"j",j
7839 c         write(iout,*) "sum_sgodl",sum_sgodl,"sgodl",sgodl
7840 c         write(iout,*) "grad_odl3",grad_odl3
7841 c         write(iout,*) "c(",jik,i,")",c(jik,i),"c(",jik,j,")",c(jik,j)
7842 c         write(iout,*) "ggodl",ggodl
7843 c         write(iout,*) "ghpbc(",jik,i,")",
7844 c     &                 ghpbc(jik,i),"ghpbc(",jik,j,")",
7845 c     &                 ghpbc(jik,j)
7846 c         endif
7847          enddo
7848 ccc       write(iout,778)"TEST: odleg2=", odleg2, "DLOG(odleg2)=",
7849 ccc     & dLOG(odleg2),"-odleg=", -odleg
7850
7851       enddo ! ii-loop for dist
7852 #ifdef DEBUG
7853       write(iout,*) "------- dist restrs end -------"
7854 c     if (waga_angle.eq.1.0d0 .or. waga_theta.eq.1.0d0 .or.
7855 c    &     waga_d.eq.1.0d0) call sum_gradient
7856 #endif
7857 c Pseudo-energy and gradient from dihedral-angle restraints from
7858 c homology templates
7859 c      write (iout,*) "End of distance loop"
7860 c      call flush(iout)
7861       kat=0.0d0
7862 c      write (iout,*) idihconstr_start_homo,idihconstr_end_homo
7863 #ifdef DEBUG
7864       write(iout,*) "------- dih restrs start -------"
7865       do i=idihconstr_start_homo,idihconstr_end_homo
7866         write (iout,*) "gloc_init(",i,icg,")",gloc(i,icg)
7867       enddo
7868 #endif
7869       do i=idihconstr_start_homo,idihconstr_end_homo
7870         kat2=0.0d0
7871 c        betai=beta(i,i+1,i+2,i+3)
7872         betai = phi(i)
7873 c       write (iout,*) "betai =",betai
7874         do k=1,constr_homology
7875           dih_diff(k)=pinorm(dih(k,i)-betai)
7876 cd          write (iout,'(a8,2i4,2f15.8)') "dih_diff",i,k,dih_diff(k)
7877 cd     &                  ,sigma_dih(k,i)
7878 c          if (dih_diff(i,k).gt.3.14159) dih_diff(i,k)=
7879 c     &                                   -(6.28318-dih_diff(i,k))
7880 c          if (dih_diff(i,k).lt.-3.14159) dih_diff(i,k)=
7881 c     &                                   6.28318+dih_diff(i,k)
7882 #ifdef OLD_DIHED
7883           kat3=-0.5d0*dih_diff(k)**2*sigma_dih(k,i) ! waga_angle rmvd from Gaussian argument
7884 #else
7885           kat3=(dcos(dih_diff(k))-1)*sigma_dih(k,i) ! waga_angle rmvd from Gaussian argument
7886 #endif
7887 c         kat3=-0.5d0*waga_angle*dih_diff(k)**2*sigma_dih(k,i)
7888           gdih(k)=dexp(kat3)
7889           kat2=kat2+gdih(k)
7890 c          write(iout,*) "kat2=", kat2, "exp(kat3)=", exp(kat3)
7891 c          write(*,*)""
7892         enddo
7893 c       write (iout,*) "gdih",(gdih(k),k=1,constr_homology) ! exps
7894 c       write (iout,*) "i",i," betai",betai," kat2",kat2 ! sum of exps
7895 #ifdef DEBUG
7896         write (iout,*) "i",i," betai",betai," kat2",kat2
7897         write (iout,*) "gdih",(gdih(k),k=1,constr_homology)
7898 #endif
7899         if (kat2.le.1.0d-14) cycle
7900         kat=kat-dLOG(kat2/constr_homology)
7901 c       write (iout,*) "kat",kat ! sum of -ln-s
7902
7903 ccc       write(iout,778)"TEST: kat2=", kat2, "DLOG(kat2)=",
7904 ccc     & dLOG(kat2), "-kat=", -kat
7905
7906 c ----------------------------------------------------------------------
7907 c Gradient
7908 c ----------------------------------------------------------------------
7909
7910         sum_gdih=kat2
7911         sum_sgdih=0.0d0
7912         do k=1,constr_homology
7913 #ifdef OLD_DIHED
7914           sgdih=-gdih(k)*dih_diff(k)*sigma_dih(k,i)  ! waga_angle rmvd
7915 #else
7916           sgdih=-gdih(k)*dsin(dih_diff(k))*sigma_dih(k,i)  ! waga_angle rmvd
7917 #endif
7918 c         sgdih=-gdih(k)*dih_diff(k)*sigma_dih(k,i)*waga_angle
7919           sum_sgdih=sum_sgdih+sgdih
7920         enddo
7921 c       grad_dih3=sum_sgdih/sum_gdih
7922         grad_dih3=waga_homology(iset)*waga_angle*sum_sgdih/sum_gdih
7923
7924 c      write(iout,*)i,k,gdih,sgdih,beta(i+1,i+2,i+3,i+4),grad_dih3
7925 ccc      write(iout,747) "GRAD_KAT_1", i, nphi, icg, grad_dih3,
7926 ccc     & gloc(nphi+i-3,icg)
7927         gloc(i-3,icg)=gloc(i-3,icg)+grad_dih3
7928 c        if (i.eq.25) then
7929 c        write(iout,*) "i",i,"icg",icg,"gloc(",i,icg,")",gloc(i,icg)
7930 c        endif
7931 ccc      write(iout,747) "GRAD_KAT_2", i, nphi, icg, grad_dih3,
7932 ccc     & gloc(nphi+i-3,icg)
7933
7934       enddo ! i-loop for dih
7935 #ifdef DEBUG
7936       write(iout,*) "------- dih restrs end -------"
7937 #endif
7938
7939 c Pseudo-energy and gradient for theta angle restraints from
7940 c homology templates
7941 c FP 01/15 - inserted from econstr_local_test.F, loop structure
7942 c adapted
7943
7944 c
7945 c     For constr_homology reference structures (FP)
7946 c
7947 c     Uconst_back_tot=0.0d0
7948       Eval=0.0d0
7949       Erot=0.0d0
7950 c     Econstr_back legacy
7951       do i=1,nres
7952 c     do i=ithet_start,ithet_end
7953        dutheta(i)=0.0d0
7954 c     enddo
7955 c     do i=loc_start,loc_end
7956         do j=1,3
7957           duscdiff(j,i)=0.0d0
7958           duscdiffx(j,i)=0.0d0
7959         enddo
7960       enddo
7961 c
7962 c     do iref=1,nref
7963 c     write (iout,*) "ithet_start =",ithet_start,"ithet_end =",ithet_end
7964 c     write (iout,*) "waga_theta",waga_theta
7965       if (waga_theta.gt.0.0d0) then
7966 #ifdef DEBUG
7967       write (iout,*) "usampl",usampl
7968       write(iout,*) "------- theta restrs start -------"
7969 c     do i=ithet_start,ithet_end
7970 c       write (iout,*) "gloc_init(",nphi+i,icg,")",gloc(nphi+i,icg)
7971 c     enddo
7972 #endif
7973 c     write (iout,*) "maxres",maxres,"nres",nres
7974
7975       do i=ithet_start,ithet_end
7976 c
7977 c     do i=1,nfrag_back
7978 c       ii = ifrag_back(2,i,iset)-ifrag_back(1,i,iset)
7979 c
7980 c Deviation of theta angles wrt constr_homology ref structures
7981 c
7982         utheta_i=0.0d0 ! argument of Gaussian for single k
7983         gutheta_i=0.0d0 ! Sum of Gaussians over constr_homology ref structures
7984 c       do j=ifrag_back(1,i,iset)+2,ifrag_back(2,i,iset) ! original loop
7985 c       over residues in a fragment
7986 c       write (iout,*) "theta(",i,")=",theta(i)
7987         do k=1,constr_homology
7988 c
7989 c         dtheta_i=theta(j)-thetaref(j,iref)
7990 c         dtheta_i=thetaref(k,i)-theta(i) ! original form without indexing
7991           theta_diff(k)=thetatpl(k,i)-theta(i)
7992 cd          write (iout,'(a8,2i4,2f15.8)') "theta_diff",i,k,theta_diff(k)
7993 cd     &                  ,sigma_theta(k,i)
7994
7995 c
7996           utheta_i=-0.5d0*theta_diff(k)**2*sigma_theta(k,i) ! waga_theta rmvd from Gaussian argument
7997 c         utheta_i=-0.5d0*waga_theta*theta_diff(k)**2*sigma_theta(k,i) ! waga_theta?
7998           gtheta(k)=dexp(utheta_i) ! + min_utheta_i?
7999           gutheta_i=gutheta_i+gtheta(k)  ! Sum of Gaussians (pk)
8000 c         Gradient for single Gaussian restraint in subr Econstr_back
8001 c         dutheta(j-2)=dutheta(j-2)+wfrag_back(1,i,iset)*dtheta_i/(ii-1)
8002 c
8003         enddo
8004 c       write (iout,*) "gtheta",(gtheta(k),k=1,constr_homology) ! exps
8005 c       write (iout,*) "i",i," gutheta_i",gutheta_i ! sum of exps
8006
8007 c
8008 c         Gradient for multiple Gaussian restraint
8009         sum_gtheta=gutheta_i
8010         sum_sgtheta=0.0d0
8011         do k=1,constr_homology
8012 c        New generalized expr for multiple Gaussian from Econstr_back
8013          sgtheta=-gtheta(k)*theta_diff(k)*sigma_theta(k,i) ! waga_theta rmvd
8014 c
8015 c        sgtheta=-gtheta(k)*theta_diff(k)*sigma_theta(k,i)*waga_theta ! right functional form?
8016           sum_sgtheta=sum_sgtheta+sgtheta ! cum variable
8017         enddo
8018 c       Final value of gradient using same var as in Econstr_back
8019         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)
8020      &      +sum_sgtheta/sum_gtheta*waga_theta
8021      &               *waga_homology(iset)
8022 c        dutheta(i-2)=sum_sgtheta/sum_gtheta*waga_theta
8023 c     &               *waga_homology(iset)
8024 c       dutheta(i)=sum_sgtheta/sum_gtheta
8025 c
8026 c       Uconst_back=Uconst_back+waga_theta*utheta(i) ! waga_theta added as weight
8027         Eval=Eval-dLOG(gutheta_i/constr_homology)
8028 c       write (iout,*) "utheta(",i,")=",utheta(i) ! -ln of sum of exps
8029 c       write (iout,*) "Uconst_back",Uconst_back ! sum of -ln-s
8030 c       Uconst_back=Uconst_back+utheta(i)
8031       enddo ! (i-loop for theta)
8032 #ifdef DEBUG
8033       write(iout,*) "------- theta restrs end -------"
8034 #endif
8035       endif
8036 c
8037 c Deviation of local SC geometry
8038 c
8039 c Separation of two i-loops (instructed by AL - 11/3/2014)
8040 c
8041 c     write (iout,*) "loc_start =",loc_start,"loc_end =",loc_end
8042 c     write (iout,*) "waga_d",waga_d
8043
8044 #ifdef DEBUG
8045       write(iout,*) "------- SC restrs start -------"
8046       write (iout,*) "Initial duscdiff,duscdiffx"
8047       do i=loc_start,loc_end
8048         write (iout,*) i,(duscdiff(jik,i),jik=1,3),
8049      &                 (duscdiffx(jik,i),jik=1,3)
8050       enddo
8051 #endif
8052       do i=loc_start,loc_end
8053         usc_diff_i=0.0d0 ! argument of Gaussian for single k
8054         guscdiff(i)=0.0d0 ! Sum of Gaussians over constr_homology ref structures
8055 c       do j=ifrag_back(1,i,iset)+1,ifrag_back(2,i,iset)-1 ! Econstr_back legacy
8056 c       write(iout,*) "xxtab, yytab, zztab"
8057 c       write(iout,'(i5,3f8.2)') i,xxtab(i),yytab(i),zztab(i)
8058         do k=1,constr_homology
8059 c
8060           dxx=-xxtpl(k,i)+xxtab(i) ! Diff b/w x component of ith SC vector in model and kth ref str?
8061 c                                    Original sign inverted for calc of gradients (s. Econstr_back)
8062           dyy=-yytpl(k,i)+yytab(i) ! ibid y
8063           dzz=-zztpl(k,i)+zztab(i) ! ibid z
8064 c         write(iout,*) "dxx, dyy, dzz"
8065 cd          write(iout,'(2i5,4f8.2)') k,i,dxx,dyy,dzz,sigma_d(k,i)
8066 c
8067           usc_diff_i=-0.5d0*(dxx**2+dyy**2+dzz**2)*sigma_d(k,i)  ! waga_d rmvd from Gaussian argument
8068 c         usc_diff(i)=-0.5d0*waga_d*(dxx**2+dyy**2+dzz**2)*sigma_d(k,i) ! waga_d?
8069 c         uscdiffk(k)=usc_diff(i)
8070           guscdiff2(k)=dexp(usc_diff_i) ! without min_scdiff
8071 c          write(iout,*) "i",i," k",k," sigma_d",sigma_d(k,i),
8072 c     &       " guscdiff2",guscdiff2(k)
8073           guscdiff(i)=guscdiff(i)+guscdiff2(k)  !Sum of Gaussians (pk)
8074 c          write (iout,'(i5,6f10.5)') j,xxtab(j),yytab(j),zztab(j),
8075 c     &      xxref(j),yyref(j),zzref(j)
8076         enddo
8077 c
8078 c       Gradient
8079 c
8080 c       Generalized expression for multiple Gaussian acc to that for a single
8081 c       Gaussian in Econstr_back as instructed by AL (FP - 03/11/2014)
8082 c
8083 c       Original implementation
8084 c       sum_guscdiff=guscdiff(i)
8085 c
8086 c       sum_sguscdiff=0.0d0
8087 c       do k=1,constr_homology
8088 c          sguscdiff=-guscdiff2(k)*dscdiff(k)*sigma_d(k,i)*waga_d !waga_d?
8089 c          sguscdiff=-guscdiff3(k)*dscdiff(k)*sigma_d(k,i)*waga_d ! w min_uscdiff
8090 c          sum_sguscdiff=sum_sguscdiff+sguscdiff
8091 c       enddo
8092 c
8093 c       Implementation of new expressions for gradient (Jan. 2015)
8094 c
8095 c       grad_uscdiff=sum_sguscdiff/(sum_guscdiff*dtab) !?
8096         do k=1,constr_homology
8097 c
8098 c       New calculation of dxx, dyy, and dzz corrected by AL (07/11), was missing and wrong
8099 c       before. Now the drivatives should be correct
8100 c
8101           dxx=-xxtpl(k,i)+xxtab(i) ! Diff b/w x component of ith SC vector in model and kth ref str?
8102 c                                  Original sign inverted for calc of gradients (s. Econstr_back)
8103           dyy=-yytpl(k,i)+yytab(i) ! ibid y
8104           dzz=-zztpl(k,i)+zztab(i) ! ibid z
8105 c
8106 c         New implementation
8107 c
8108           sum_guscdiff=guscdiff2(k)*!(dsqrt(dxx*dxx+dyy*dyy+dzz*dzz))* -> wrong!
8109      &                 sigma_d(k,i) ! for the grad wrt r'
8110 c         sum_sguscdiff=sum_sguscdiff+sum_guscdiff
8111 c
8112 c
8113 c        New implementation
8114          sum_guscdiff = waga_homology(iset)*waga_d*sum_guscdiff
8115          do jik=1,3
8116             duscdiff(jik,i-1)=duscdiff(jik,i-1)+
8117      &      sum_guscdiff*(dXX_C1tab(jik,i)*dxx+
8118      &      dYY_C1tab(jik,i)*dyy+dZZ_C1tab(jik,i)*dzz)/guscdiff(i)
8119             duscdiff(jik,i)=duscdiff(jik,i)+
8120      &      sum_guscdiff*(dXX_Ctab(jik,i)*dxx+
8121      &      dYY_Ctab(jik,i)*dyy+dZZ_Ctab(jik,i)*dzz)/guscdiff(i)
8122             duscdiffx(jik,i)=duscdiffx(jik,i)+
8123      &      sum_guscdiff*(dXX_XYZtab(jik,i)*dxx+
8124      &      dYY_XYZtab(jik,i)*dyy+dZZ_XYZtab(jik,i)*dzz)/guscdiff(i)
8125 c
8126 #ifdef DEBUG
8127              write(iout,*) "jik",jik,"i",i
8128              write(iout,*) "dxx, dyy, dzz"
8129              write(iout,'(2i5,3f8.2)') k,i,dxx,dyy,dzz
8130              write(iout,*) "guscdiff2(",k,")",guscdiff2(k)
8131 c            write(iout,*) "sum_sguscdiff",sum_sguscdiff
8132 cc           write(iout,*) "dXX_Ctab(",jik,i,")",dXX_Ctab(jik,i)
8133 c            write(iout,*) "dYY_Ctab(",jik,i,")",dYY_Ctab(jik,i)
8134 c            write(iout,*) "dZZ_Ctab(",jik,i,")",dZZ_Ctab(jik,i)
8135 c            write(iout,*) "dXX_C1tab(",jik,i,")",dXX_C1tab(jik,i)
8136 c            write(iout,*) "dYY_C1tab(",jik,i,")",dYY_C1tab(jik,i)
8137 c            write(iout,*) "dZZ_C1tab(",jik,i,")",dZZ_C1tab(jik,i)
8138 c            write(iout,*) "dXX_XYZtab(",jik,i,")",dXX_XYZtab(jik,i)
8139 c            write(iout,*) "dYY_XYZtab(",jik,i,")",dYY_XYZtab(jik,i)
8140 c            write(iout,*) "dZZ_XYZtab(",jik,i,")",dZZ_XYZtab(jik,i)
8141 c            write(iout,*) "duscdiff(",jik,i-1,")",duscdiff(jik,i-1)
8142 c            write(iout,*) "duscdiff(",jik,i,")",duscdiff(jik,i)
8143 c            write(iout,*) "duscdiffx(",jik,i,")",duscdiffx(jik,i)
8144 c            endif
8145 #endif
8146          enddo
8147         enddo
8148 c
8149 c       uscdiff(i)=-dLOG(guscdiff(i)/(ii-1))      ! Weighting by (ii-1) required?
8150 c        usc_diff(i)=-dLOG(guscdiff(i)/constr_homology) ! + min_uscdiff ?
8151 c
8152 c        write (iout,*) i," uscdiff",uscdiff(i)
8153 c
8154 c Put together deviations from local geometry
8155
8156 c       Uconst_back=Uconst_back+wfrag_back(1,i,iset)*utheta(i)+
8157 c      &            wfrag_back(3,i,iset)*uscdiff(i)
8158         Erot=Erot-dLOG(guscdiff(i)/constr_homology)
8159 c       write (iout,*) "usc_diff(",i,")=",usc_diff(i) ! -ln of sum of exps
8160 c       write (iout,*) "Uconst_back",Uconst_back ! cum sum of -ln-s
8161 c       Uconst_back=Uconst_back+usc_diff(i)
8162 c
8163 c     Gradient of multiple Gaussian restraint (FP - 04/11/2014 - right?)
8164 c
8165 c     New implment: multiplied by sum_sguscdiff
8166 c
8167
8168       enddo ! (i-loop for dscdiff)
8169
8170 c      endif
8171
8172 #ifdef DEBUG
8173       write(iout,*) "------- SC restrs end -------"
8174         write (iout,*) "------ After SC loop in e_modeller ------"
8175         do i=loc_start,loc_end
8176          write (iout,*) "i",i," gradc",(gradc(j,i,icg),j=1,3)
8177          write (iout,*) "i",i," gradx",(gradx(j,i,icg),j=1,3)
8178         enddo
8179       if (waga_theta.eq.1.0d0) then
8180       write (iout,*) "in e_modeller after SC restr end: dutheta"
8181       do i=ithet_start,ithet_end
8182         write (iout,*) i,dutheta(i)
8183       enddo
8184       endif
8185       if (waga_d.eq.1.0d0) then
8186       write (iout,*) "e_modeller after SC loop: duscdiff/x"
8187       do i=1,nres
8188         write (iout,*) i,(duscdiff(j,i),j=1,3)
8189         write (iout,*) i,(duscdiffx(j,i),j=1,3)
8190       enddo
8191       endif
8192 #endif
8193
8194 c Total energy from homology restraints
8195 #ifdef DEBUG
8196       write (iout,*) "odleg",odleg," kat",kat
8197 #endif
8198 c
8199 c Addition of energy of theta angle and SC local geom over constr_homologs ref strs
8200 c
8201 c     ehomology_constr=odleg+kat
8202 c
8203 c     For Lorentzian-type Urestr
8204 c
8205
8206       if (waga_dist.ge.0.0d0) then
8207 c
8208 c          For Gaussian-type Urestr
8209 c
8210         ehomology_constr=(waga_dist*odleg+waga_angle*kat+
8211      &              waga_theta*Eval+waga_d*Erot)*waga_homology(iset)
8212 c     write (iout,*) "ehomology_constr=",ehomology_constr
8213       else
8214 c
8215 c          For Lorentzian-type Urestr
8216 c
8217         ehomology_constr=(-waga_dist*odleg+waga_angle*kat+
8218      &              waga_theta*Eval+waga_d*Erot)*waga_homology(iset)
8219 c     write (iout,*) "ehomology_constr=",ehomology_constr
8220       endif
8221 #ifdef DEBUG
8222       write (iout,*) "odleg",waga_dist,odleg," kat",waga_angle,kat,
8223      & "Eval",waga_theta,eval,
8224      &   "Erot",waga_d,Erot
8225       write (iout,*) "ehomology_constr",ehomology_constr
8226 #endif
8227       return
8228 c
8229 c FP 01/15 end
8230 c
8231   748 format(a8,f12.3,a6,f12.3,a7,f12.3)
8232   747 format(a12,i4,i4,i4,f8.3,f8.3)
8233   746 format(a12,i4,i4,i4,f8.3,f8.3,f8.3)
8234   778 format(a7,1X,f10.3,1X,a4,1X,f10.3,1X,a5,1X,f10.3)
8235   779 format(i3,1X,i3,1X,i2,1X,a7,1X,f7.3,1X,a7,1X,f7.3,1X,a13,1X,
8236      &       f7.3,1X,a17,1X,f9.3,1X,a10,1X,f8.3,1X,a10,1X,f8.3)
8237       end
8238 c----------------------------------------------------------------------------
8239 C The rigorous attempt to derive energy function
8240       subroutine ebend_kcc(etheta)
8241
8242       implicit real*8 (a-h,o-z)
8243       include 'DIMENSIONS'
8244       include 'COMMON.VAR'
8245       include 'COMMON.GEO'
8246       include 'COMMON.LOCAL'
8247       include 'COMMON.TORSION'
8248       include 'COMMON.INTERACT'
8249       include 'COMMON.DERIV'
8250       include 'COMMON.CHAIN'
8251       include 'COMMON.NAMES'
8252       include 'COMMON.IOUNITS'
8253       include 'COMMON.FFIELD'
8254       include 'COMMON.TORCNSTR'
8255       include 'COMMON.CONTROL'
8256       logical lprn
8257       double precision thybt1(maxang_kcc)
8258 C Set lprn=.true. for debugging
8259       lprn=energy_dec
8260 c     lprn=.true.
8261 C      print *,"wchodze kcc"
8262       if (lprn) write (iout,*) "ebend_kcc tor_mode",tor_mode
8263       etheta=0.0D0
8264       do i=ithet_start,ithet_end
8265 c        print *,i,itype(i-1),itype(i),itype(i-2)
8266         if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
8267      &  .or.itype(i).eq.ntyp1) cycle
8268         iti=iabs(itortyp(itype(i-1)))
8269         sinthet=dsin(theta(i))
8270         costhet=dcos(theta(i))
8271         do j=1,nbend_kcc_Tb(iti)
8272           thybt1(j)=v1bend_chyb(j,iti)
8273         enddo
8274         sumth1thyb=v1bend_chyb(0,iti)+
8275      &    tschebyshev(1,nbend_kcc_Tb(iti),thybt1(1),costhet)
8276         if (lprn) write (iout,*) i-1,itype(i-1),iti,theta(i)*rad2deg,
8277      &    sumth1thyb
8278         ihelp=nbend_kcc_Tb(iti)-1
8279         gradthybt1=gradtschebyshev(0,ihelp,thybt1(1),costhet)
8280         etheta=etheta+sumth1thyb
8281 C        print *,sumth1thyb,gradthybt1,sinthet*(-0.5d0)
8282         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)-wang*gradthybt1*sinthet
8283       enddo
8284       return
8285       end
8286 c-------------------------------------------------------------------------------------
8287       subroutine etheta_constr(ethetacnstr)
8288
8289       implicit real*8 (a-h,o-z)
8290       include 'DIMENSIONS'
8291       include 'COMMON.VAR'
8292       include 'COMMON.GEO'
8293       include 'COMMON.LOCAL'
8294       include 'COMMON.TORSION'
8295       include 'COMMON.INTERACT'
8296       include 'COMMON.DERIV'
8297       include 'COMMON.CHAIN'
8298       include 'COMMON.NAMES'
8299       include 'COMMON.IOUNITS'
8300       include 'COMMON.FFIELD'
8301       include 'COMMON.TORCNSTR'
8302       include 'COMMON.CONTROL'
8303       ethetacnstr=0.0d0
8304 C      print *,ithetaconstr_start,ithetaconstr_end,"TU"
8305       do i=ithetaconstr_start,ithetaconstr_end
8306         itheta=itheta_constr(i)
8307         thetiii=theta(itheta)
8308         difi=pinorm(thetiii-theta_constr0(i))
8309         if (difi.gt.theta_drange(i)) then
8310           difi=difi-theta_drange(i)
8311           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
8312           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
8313      &    +for_thet_constr(i)*difi**3
8314         else if (difi.lt.-drange(i)) then
8315           difi=difi+drange(i)
8316           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
8317           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
8318      &    +for_thet_constr(i)*difi**3
8319         else
8320           difi=0.0
8321         endif
8322        if (energy_dec) then
8323         write (iout,'(a6,2i5,4f8.3,2e14.5)') "ethetc",
8324      &    i,itheta,rad2deg*thetiii,
8325      &    rad2deg*theta_constr0(i),  rad2deg*theta_drange(i),
8326      &    rad2deg*difi,0.25d0*for_thet_constr(i)*difi**4,
8327      &    gloc(itheta+nphi-2,icg)
8328         endif
8329       enddo
8330       return
8331       end
8332 c------------------------------------------------------------------------------
8333       subroutine eback_sc_corr(esccor)
8334 c 7/21/2007 Correlations between the backbone-local and side-chain-local
8335 c        conformational states; temporarily implemented as differences
8336 c        between UNRES torsional potentials (dependent on three types of
8337 c        residues) and the torsional potentials dependent on all 20 types
8338 c        of residues computed from AM1  energy surfaces of terminally-blocked
8339 c        amino-acid residues.
8340       implicit real*8 (a-h,o-z)
8341       include 'DIMENSIONS'
8342       include 'COMMON.VAR'
8343       include 'COMMON.GEO'
8344       include 'COMMON.LOCAL'
8345       include 'COMMON.TORSION'
8346       include 'COMMON.SCCOR'
8347       include 'COMMON.INTERACT'
8348       include 'COMMON.DERIV'
8349       include 'COMMON.CHAIN'
8350       include 'COMMON.NAMES'
8351       include 'COMMON.IOUNITS'
8352       include 'COMMON.FFIELD'
8353       include 'COMMON.CONTROL'
8354       logical lprn
8355 C Set lprn=.true. for debugging
8356       lprn=.false.
8357 c      lprn=.true.
8358 c      write (iout,*) "EBACK_SC_COR",itau_start,itau_end
8359       esccor=0.0D0
8360       do i=itau_start,itau_end
8361         if ((itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)) cycle
8362         esccor_ii=0.0D0
8363         isccori=isccortyp(itype(i-2))
8364         isccori1=isccortyp(itype(i-1))
8365 c      write (iout,*) "EBACK_SC_COR",i,nterm_sccor(isccori,isccori1)
8366         phii=phi(i)
8367         do intertyp=1,3 !intertyp
8368 cc Added 09 May 2012 (Adasko)
8369 cc  Intertyp means interaction type of backbone mainchain correlation:
8370 c   1 = SC...Ca...Ca...Ca
8371 c   2 = Ca...Ca...Ca...SC
8372 c   3 = SC...Ca...Ca...SCi
8373         gloci=0.0D0
8374         if (((intertyp.eq.3).and.((itype(i-2).eq.10).or.
8375      &      (itype(i-1).eq.10).or.(itype(i-2).eq.ntyp1).or.
8376      &      (itype(i-1).eq.ntyp1)))
8377      &    .or. ((intertyp.eq.1).and.((itype(i-2).eq.10)
8378      &     .or.(itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)
8379      &     .or.(itype(i).eq.ntyp1)))
8380      &    .or.((intertyp.eq.2).and.((itype(i-1).eq.10).or.
8381      &      (itype(i-1).eq.ntyp1).or.(itype(i-2).eq.ntyp1).or.
8382      &      (itype(i-3).eq.ntyp1)))) cycle
8383         if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1).eq.ntyp1)) cycle
8384         if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres).eq.ntyp1))
8385      & cycle
8386        do j=1,nterm_sccor(isccori,isccori1)
8387           v1ij=v1sccor(j,intertyp,isccori,isccori1)
8388           v2ij=v2sccor(j,intertyp,isccori,isccori1)
8389           cosphi=dcos(j*tauangle(intertyp,i))
8390           sinphi=dsin(j*tauangle(intertyp,i))
8391           esccor=esccor+v1ij*cosphi+v2ij*sinphi
8392           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
8393         enddo
8394 c      write (iout,*) "EBACK_SC_COR",i,v1ij*cosphi+v2ij*sinphi,intertyp
8395         gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci
8396         if (lprn)
8397      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
8398      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,isccori,isccori1,
8399      &  (v1sccor(j,intertyp,isccori,isccori1),j=1,6)
8400      & ,(v2sccor(j,intertyp,isccori,isccori1),j=1,6)
8401         gsccor_loc(i-3)=gsccor_loc(i-3)+gloci
8402        enddo !intertyp
8403       enddo
8404
8405       return
8406       end
8407 #ifdef FOURBODY
8408 c----------------------------------------------------------------------------
8409       subroutine multibody(ecorr)
8410 C This subroutine calculates multi-body contributions to energy following
8411 C the idea of Skolnick et al. If side chains I and J make a contact and
8412 C at the same time side chains I+1 and J+1 make a contact, an extra
8413 C contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
8414       implicit real*8 (a-h,o-z)
8415       include 'DIMENSIONS'
8416       include 'COMMON.IOUNITS'
8417       include 'COMMON.DERIV'
8418       include 'COMMON.INTERACT'
8419       include 'COMMON.CONTACTS'
8420       include 'COMMON.CONTMAT'
8421       include 'COMMON.CORRMAT'
8422       double precision gx(3),gx1(3)
8423       logical lprn
8424
8425 C Set lprn=.true. for debugging
8426       lprn=.false.
8427
8428       if (lprn) then
8429         write (iout,'(a)') 'Contact function values:'
8430         do i=nnt,nct-2
8431           write (iout,'(i2,20(1x,i2,f10.5))')
8432      &        i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
8433         enddo
8434       endif
8435       ecorr=0.0D0
8436       do i=nnt,nct
8437         do j=1,3
8438           gradcorr(j,i)=0.0D0
8439           gradxorr(j,i)=0.0D0
8440         enddo
8441       enddo
8442       do i=nnt,nct-2
8443
8444         DO ISHIFT = 3,4
8445
8446         i1=i+ishift
8447         num_conti=num_cont(i)
8448         num_conti1=num_cont(i1)
8449         do jj=1,num_conti
8450           j=jcont(jj,i)
8451           do kk=1,num_conti1
8452             j1=jcont(kk,i1)
8453             if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
8454 cd          write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
8455 cd   &                   ' ishift=',ishift
8456 C Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
8457 C The system gains extra energy.
8458               ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
8459             endif   ! j1==j+-ishift
8460           enddo     ! kk
8461         enddo       ! jj
8462
8463         ENDDO ! ISHIFT
8464
8465       enddo         ! i
8466       return
8467       end
8468 c------------------------------------------------------------------------------
8469       double precision function esccorr(i,j,k,l,jj,kk)
8470       implicit real*8 (a-h,o-z)
8471       include 'DIMENSIONS'
8472       include 'COMMON.IOUNITS'
8473       include 'COMMON.DERIV'
8474       include 'COMMON.INTERACT'
8475       include 'COMMON.CONTACTS'
8476       include 'COMMON.CONTMAT'
8477       include 'COMMON.CORRMAT'
8478       include 'COMMON.SHIELD'
8479       double precision gx(3),gx1(3)
8480       logical lprn
8481       lprn=.false.
8482       eij=facont(jj,i)
8483       ekl=facont(kk,k)
8484 cd    write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
8485 C Calculate the multi-body contribution to energy.
8486 C Calculate multi-body contributions to the gradient.
8487 cd    write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
8488 cd   & k,l,(gacont(m,kk,k),m=1,3)
8489       do m=1,3
8490         gx(m) =ekl*gacont(m,jj,i)
8491         gx1(m)=eij*gacont(m,kk,k)
8492         gradxorr(m,i)=gradxorr(m,i)-gx(m)
8493         gradxorr(m,j)=gradxorr(m,j)+gx(m)
8494         gradxorr(m,k)=gradxorr(m,k)-gx1(m)
8495         gradxorr(m,l)=gradxorr(m,l)+gx1(m)
8496       enddo
8497       do m=i,j-1
8498         do ll=1,3
8499           gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
8500         enddo
8501       enddo
8502       do m=k,l-1
8503         do ll=1,3
8504           gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
8505         enddo
8506       enddo
8507       esccorr=-eij*ekl
8508       return
8509       end
8510 c------------------------------------------------------------------------------
8511       subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
8512 C This subroutine calculates multi-body contributions to hydrogen-bonding
8513       implicit real*8 (a-h,o-z)
8514       include 'DIMENSIONS'
8515       include 'COMMON.IOUNITS'
8516 #ifdef MPI
8517       include "mpif.h"
8518       parameter (max_cont=maxconts)
8519       parameter (max_dim=26)
8520       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
8521       double precision zapas(max_dim,maxconts,max_fg_procs),
8522      &  zapas_recv(max_dim,maxconts,max_fg_procs)
8523       common /przechowalnia/ zapas
8524       integer status(MPI_STATUS_SIZE),req(maxconts*2),
8525      &  status_array(MPI_STATUS_SIZE,maxconts*2)
8526 #endif
8527       include 'COMMON.SETUP'
8528       include 'COMMON.FFIELD'
8529       include 'COMMON.DERIV'
8530       include 'COMMON.INTERACT'
8531       include 'COMMON.CONTACTS'
8532       include 'COMMON.CONTMAT'
8533       include 'COMMON.CORRMAT'
8534       include 'COMMON.CONTROL'
8535       include 'COMMON.LOCAL'
8536       double precision gx(3),gx1(3),time00
8537       logical lprn,ldone
8538
8539 C Set lprn=.true. for debugging
8540       lprn=.false.
8541 #ifdef MPI
8542       n_corr=0
8543       n_corr1=0
8544       if (nfgtasks.le.1) goto 30
8545       if (lprn) then
8546         write (iout,'(a)') 'Contact function values before RECEIVE:'
8547         do i=nnt,nct-2
8548           write (iout,'(2i3,50(1x,i2,f5.2))')
8549      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
8550      &    j=1,num_cont_hb(i))
8551         enddo
8552         call flush(iout)
8553       endif
8554       do i=1,ntask_cont_from
8555         ncont_recv(i)=0
8556       enddo
8557       do i=1,ntask_cont_to
8558         ncont_sent(i)=0
8559       enddo
8560 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
8561 c     & ntask_cont_to
8562 C Make the list of contacts to send to send to other procesors
8563 c      write (iout,*) "limits",max0(iturn4_end-1,iatel_s),iturn3_end
8564 c      call flush(iout)
8565       do i=iturn3_start,iturn3_end
8566 c        write (iout,*) "make contact list turn3",i," num_cont",
8567 c     &    num_cont_hb(i)
8568         call add_hb_contact(i,i+2,iturn3_sent_local(1,i))
8569       enddo
8570       do i=iturn4_start,iturn4_end
8571 c        write (iout,*) "make contact list turn4",i," num_cont",
8572 c     &   num_cont_hb(i)
8573         call add_hb_contact(i,i+3,iturn4_sent_local(1,i))
8574       enddo
8575       do ii=1,nat_sent
8576         i=iat_sent(ii)
8577 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
8578 c     &    num_cont_hb(i)
8579         do j=1,num_cont_hb(i)
8580         do k=1,4
8581           jjc=jcont_hb(j,i)
8582           iproc=iint_sent_local(k,jjc,ii)
8583 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
8584           if (iproc.gt.0) then
8585             ncont_sent(iproc)=ncont_sent(iproc)+1
8586             nn=ncont_sent(iproc)
8587             zapas(1,nn,iproc)=i
8588             zapas(2,nn,iproc)=jjc
8589             zapas(3,nn,iproc)=facont_hb(j,i)
8590             zapas(4,nn,iproc)=ees0p(j,i)
8591             zapas(5,nn,iproc)=ees0m(j,i)
8592             zapas(6,nn,iproc)=gacont_hbr(1,j,i)
8593             zapas(7,nn,iproc)=gacont_hbr(2,j,i)
8594             zapas(8,nn,iproc)=gacont_hbr(3,j,i)
8595             zapas(9,nn,iproc)=gacontm_hb1(1,j,i)
8596             zapas(10,nn,iproc)=gacontm_hb1(2,j,i)
8597             zapas(11,nn,iproc)=gacontm_hb1(3,j,i)
8598             zapas(12,nn,iproc)=gacontp_hb1(1,j,i)
8599             zapas(13,nn,iproc)=gacontp_hb1(2,j,i)
8600             zapas(14,nn,iproc)=gacontp_hb1(3,j,i)
8601             zapas(15,nn,iproc)=gacontm_hb2(1,j,i)
8602             zapas(16,nn,iproc)=gacontm_hb2(2,j,i)
8603             zapas(17,nn,iproc)=gacontm_hb2(3,j,i)
8604             zapas(18,nn,iproc)=gacontp_hb2(1,j,i)
8605             zapas(19,nn,iproc)=gacontp_hb2(2,j,i)
8606             zapas(20,nn,iproc)=gacontp_hb2(3,j,i)
8607             zapas(21,nn,iproc)=gacontm_hb3(1,j,i)
8608             zapas(22,nn,iproc)=gacontm_hb3(2,j,i)
8609             zapas(23,nn,iproc)=gacontm_hb3(3,j,i)
8610             zapas(24,nn,iproc)=gacontp_hb3(1,j,i)
8611             zapas(25,nn,iproc)=gacontp_hb3(2,j,i)
8612             zapas(26,nn,iproc)=gacontp_hb3(3,j,i)
8613           endif
8614         enddo
8615         enddo
8616       enddo
8617       if (lprn) then
8618       write (iout,*)
8619      &  "Numbers of contacts to be sent to other processors",
8620      &  (ncont_sent(i),i=1,ntask_cont_to)
8621       write (iout,*) "Contacts sent"
8622       do ii=1,ntask_cont_to
8623         nn=ncont_sent(ii)
8624         iproc=itask_cont_to(ii)
8625         write (iout,*) nn," contacts to processor",iproc,
8626      &   " of CONT_TO_COMM group"
8627         do i=1,nn
8628           write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
8629         enddo
8630       enddo
8631       call flush(iout)
8632       endif
8633       CorrelType=477
8634       CorrelID=fg_rank+1
8635       CorrelType1=478
8636       CorrelID1=nfgtasks+fg_rank+1
8637       ireq=0
8638 C Receive the numbers of needed contacts from other processors
8639       do ii=1,ntask_cont_from
8640         iproc=itask_cont_from(ii)
8641         ireq=ireq+1
8642         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
8643      &    FG_COMM,req(ireq),IERR)
8644       enddo
8645 c      write (iout,*) "IRECV ended"
8646 c      call flush(iout)
8647 C Send the number of contacts needed by other processors
8648       do ii=1,ntask_cont_to
8649         iproc=itask_cont_to(ii)
8650         ireq=ireq+1
8651         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
8652      &    FG_COMM,req(ireq),IERR)
8653       enddo
8654 c      write (iout,*) "ISEND ended"
8655 c      write (iout,*) "number of requests (nn)",ireq
8656 c      call flush(iout)
8657       if (ireq.gt.0)
8658      &  call MPI_Waitall(ireq,req,status_array,ierr)
8659 c      write (iout,*)
8660 c     &  "Numbers of contacts to be received from other processors",
8661 c     &  (ncont_recv(i),i=1,ntask_cont_from)
8662 c      call flush(iout)
8663 C Receive contacts
8664       ireq=0
8665       do ii=1,ntask_cont_from
8666         iproc=itask_cont_from(ii)
8667         nn=ncont_recv(ii)
8668 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
8669 c     &   " of CONT_TO_COMM group"
8670 c        call flush(iout)
8671         if (nn.gt.0) then
8672           ireq=ireq+1
8673           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
8674      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
8675 c          write (iout,*) "ireq,req",ireq,req(ireq)
8676         endif
8677       enddo
8678 C Send the contacts to processors that need them
8679       do ii=1,ntask_cont_to
8680         iproc=itask_cont_to(ii)
8681         nn=ncont_sent(ii)
8682 c        write (iout,*) nn," contacts to processor",iproc,
8683 c     &   " of CONT_TO_COMM group"
8684         if (nn.gt.0) then
8685           ireq=ireq+1
8686           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
8687      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
8688 c          write (iout,*) "ireq,req",ireq,req(ireq)
8689 c          do i=1,nn
8690 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
8691 c          enddo
8692         endif
8693       enddo
8694 c      write (iout,*) "number of requests (contacts)",ireq
8695 c      write (iout,*) "req",(req(i),i=1,4)
8696 c      call flush(iout)
8697       if (ireq.gt.0)
8698      & call MPI_Waitall(ireq,req,status_array,ierr)
8699       do iii=1,ntask_cont_from
8700         iproc=itask_cont_from(iii)
8701         nn=ncont_recv(iii)
8702         if (lprn) then
8703         write (iout,*) "Received",nn," contacts from processor",iproc,
8704      &   " of CONT_FROM_COMM group"
8705         call flush(iout)
8706         do i=1,nn
8707           write(iout,'(2f5.0,4f10.5)')(zapas_recv(j,i,iii),j=1,5)
8708         enddo
8709         call flush(iout)
8710         endif
8711         do i=1,nn
8712           ii=zapas_recv(1,i,iii)
8713 c Flag the received contacts to prevent double-counting
8714           jj=-zapas_recv(2,i,iii)
8715 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
8716 c          call flush(iout)
8717           nnn=num_cont_hb(ii)+1
8718           num_cont_hb(ii)=nnn
8719           jcont_hb(nnn,ii)=jj
8720           facont_hb(nnn,ii)=zapas_recv(3,i,iii)
8721           ees0p(nnn,ii)=zapas_recv(4,i,iii)
8722           ees0m(nnn,ii)=zapas_recv(5,i,iii)
8723           gacont_hbr(1,nnn,ii)=zapas_recv(6,i,iii)
8724           gacont_hbr(2,nnn,ii)=zapas_recv(7,i,iii)
8725           gacont_hbr(3,nnn,ii)=zapas_recv(8,i,iii)
8726           gacontm_hb1(1,nnn,ii)=zapas_recv(9,i,iii)
8727           gacontm_hb1(2,nnn,ii)=zapas_recv(10,i,iii)
8728           gacontm_hb1(3,nnn,ii)=zapas_recv(11,i,iii)
8729           gacontp_hb1(1,nnn,ii)=zapas_recv(12,i,iii)
8730           gacontp_hb1(2,nnn,ii)=zapas_recv(13,i,iii)
8731           gacontp_hb1(3,nnn,ii)=zapas_recv(14,i,iii)
8732           gacontm_hb2(1,nnn,ii)=zapas_recv(15,i,iii)
8733           gacontm_hb2(2,nnn,ii)=zapas_recv(16,i,iii)
8734           gacontm_hb2(3,nnn,ii)=zapas_recv(17,i,iii)
8735           gacontp_hb2(1,nnn,ii)=zapas_recv(18,i,iii)
8736           gacontp_hb2(2,nnn,ii)=zapas_recv(19,i,iii)
8737           gacontp_hb2(3,nnn,ii)=zapas_recv(20,i,iii)
8738           gacontm_hb3(1,nnn,ii)=zapas_recv(21,i,iii)
8739           gacontm_hb3(2,nnn,ii)=zapas_recv(22,i,iii)
8740           gacontm_hb3(3,nnn,ii)=zapas_recv(23,i,iii)
8741           gacontp_hb3(1,nnn,ii)=zapas_recv(24,i,iii)
8742           gacontp_hb3(2,nnn,ii)=zapas_recv(25,i,iii)
8743           gacontp_hb3(3,nnn,ii)=zapas_recv(26,i,iii)
8744         enddo
8745       enddo
8746       if (lprn) then
8747         write (iout,'(a)') 'Contact function values after receive:'
8748         do i=nnt,nct-2
8749           write (iout,'(2i3,50(1x,i3,f5.2))')
8750      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
8751      &    j=1,num_cont_hb(i))
8752         enddo
8753         call flush(iout)
8754       endif
8755    30 continue
8756 #endif
8757       if (lprn) then
8758         write (iout,'(a)') 'Contact function values:'
8759         do i=nnt,nct-2
8760           write (iout,'(2i3,50(1x,i3,f5.2))')
8761      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
8762      &    j=1,num_cont_hb(i))
8763         enddo
8764         call flush(iout)
8765       endif
8766       ecorr=0.0D0
8767 C Remove the loop below after debugging !!!
8768       do i=nnt,nct
8769         do j=1,3
8770           gradcorr(j,i)=0.0D0
8771           gradxorr(j,i)=0.0D0
8772         enddo
8773       enddo
8774 C Calculate the local-electrostatic correlation terms
8775       do i=min0(iatel_s,iturn4_start),max0(iatel_e,iturn3_end)
8776         i1=i+1
8777         num_conti=num_cont_hb(i)
8778         num_conti1=num_cont_hb(i+1)
8779         do jj=1,num_conti
8780           j=jcont_hb(jj,i)
8781           jp=iabs(j)
8782           do kk=1,num_conti1
8783             j1=jcont_hb(kk,i1)
8784             jp1=iabs(j1)
8785 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
8786 c     &         ' jj=',jj,' kk=',kk
8787 c            call flush(iout)
8788             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
8789      &          .or. j.lt.0 .and. j1.gt.0) .and.
8790      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
8791 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
8792 C The system gains extra energy.
8793               ecorr=ecorr+ehbcorr(i,jp,i+1,jp1,jj,kk,0.72D0,0.32D0)
8794               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
8795      &            'ecorrh',i,j,ehbcorr(i,j,i+1,j1,jj,kk,0.72D0,0.32D0)
8796               n_corr=n_corr+1
8797             else if (j1.eq.j) then
8798 C Contacts I-J and I-(J+1) occur simultaneously.
8799 C The system loses extra energy.
8800 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
8801             endif
8802           enddo ! kk
8803           do kk=1,num_conti
8804             j1=jcont_hb(kk,i)
8805 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
8806 c    &         ' jj=',jj,' kk=',kk
8807             if (j1.eq.j+1) then
8808 C Contacts I-J and (I+1)-J occur simultaneously.
8809 C The system loses extra energy.
8810 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
8811             endif ! j1==j+1
8812           enddo ! kk
8813         enddo ! jj
8814       enddo ! i
8815       return
8816       end
8817 c------------------------------------------------------------------------------
8818       subroutine add_hb_contact(ii,jj,itask)
8819       implicit real*8 (a-h,o-z)
8820       include "DIMENSIONS"
8821       include "COMMON.IOUNITS"
8822       integer max_cont
8823       integer max_dim
8824       parameter (max_cont=maxconts)
8825       parameter (max_dim=26)
8826       include "COMMON.CONTACTS"
8827       include 'COMMON.CONTMAT'
8828       include 'COMMON.CORRMAT'
8829       double precision zapas(max_dim,maxconts,max_fg_procs),
8830      &  zapas_recv(max_dim,maxconts,max_fg_procs)
8831       common /przechowalnia/ zapas
8832       integer i,j,ii,jj,iproc,itask(4),nn
8833 c      write (iout,*) "itask",itask
8834       do i=1,2
8835         iproc=itask(i)
8836         if (iproc.gt.0) then
8837           do j=1,num_cont_hb(ii)
8838             jjc=jcont_hb(j,ii)
8839 c            write (iout,*) "i",ii," j",jj," jjc",jjc
8840             if (jjc.eq.jj) then
8841               ncont_sent(iproc)=ncont_sent(iproc)+1
8842               nn=ncont_sent(iproc)
8843               zapas(1,nn,iproc)=ii
8844               zapas(2,nn,iproc)=jjc
8845               zapas(3,nn,iproc)=facont_hb(j,ii)
8846               zapas(4,nn,iproc)=ees0p(j,ii)
8847               zapas(5,nn,iproc)=ees0m(j,ii)
8848               zapas(6,nn,iproc)=gacont_hbr(1,j,ii)
8849               zapas(7,nn,iproc)=gacont_hbr(2,j,ii)
8850               zapas(8,nn,iproc)=gacont_hbr(3,j,ii)
8851               zapas(9,nn,iproc)=gacontm_hb1(1,j,ii)
8852               zapas(10,nn,iproc)=gacontm_hb1(2,j,ii)
8853               zapas(11,nn,iproc)=gacontm_hb1(3,j,ii)
8854               zapas(12,nn,iproc)=gacontp_hb1(1,j,ii)
8855               zapas(13,nn,iproc)=gacontp_hb1(2,j,ii)
8856               zapas(14,nn,iproc)=gacontp_hb1(3,j,ii)
8857               zapas(15,nn,iproc)=gacontm_hb2(1,j,ii)
8858               zapas(16,nn,iproc)=gacontm_hb2(2,j,ii)
8859               zapas(17,nn,iproc)=gacontm_hb2(3,j,ii)
8860               zapas(18,nn,iproc)=gacontp_hb2(1,j,ii)
8861               zapas(19,nn,iproc)=gacontp_hb2(2,j,ii)
8862               zapas(20,nn,iproc)=gacontp_hb2(3,j,ii)
8863               zapas(21,nn,iproc)=gacontm_hb3(1,j,ii)
8864               zapas(22,nn,iproc)=gacontm_hb3(2,j,ii)
8865               zapas(23,nn,iproc)=gacontm_hb3(3,j,ii)
8866               zapas(24,nn,iproc)=gacontp_hb3(1,j,ii)
8867               zapas(25,nn,iproc)=gacontp_hb3(2,j,ii)
8868               zapas(26,nn,iproc)=gacontp_hb3(3,j,ii)
8869               exit
8870             endif
8871           enddo
8872         endif
8873       enddo
8874       return
8875       end
8876 c------------------------------------------------------------------------------
8877       subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,
8878      &  n_corr1)
8879 C This subroutine calculates multi-body contributions to hydrogen-bonding
8880       implicit real*8 (a-h,o-z)
8881       include 'DIMENSIONS'
8882       include 'COMMON.IOUNITS'
8883 #ifdef MPI
8884       include "mpif.h"
8885       parameter (max_cont=maxconts)
8886       parameter (max_dim=70)
8887       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
8888       double precision zapas(max_dim,maxconts,max_fg_procs),
8889      &  zapas_recv(max_dim,maxconts,max_fg_procs)
8890       common /przechowalnia/ zapas
8891       integer status(MPI_STATUS_SIZE),req(maxconts*2),
8892      &  status_array(MPI_STATUS_SIZE,maxconts*2)
8893 #endif
8894       include 'COMMON.SETUP'
8895       include 'COMMON.FFIELD'
8896       include 'COMMON.DERIV'
8897       include 'COMMON.LOCAL'
8898       include 'COMMON.INTERACT'
8899       include 'COMMON.CONTACTS'
8900       include 'COMMON.CONTMAT'
8901       include 'COMMON.CORRMAT'
8902       include 'COMMON.CHAIN'
8903       include 'COMMON.CONTROL'
8904       include 'COMMON.SHIELD'
8905       double precision gx(3),gx1(3)
8906       integer num_cont_hb_old(maxres)
8907       logical lprn,ldone
8908       double precision eello4,eello5,eelo6,eello_turn6
8909       external eello4,eello5,eello6,eello_turn6
8910 C Set lprn=.true. for debugging
8911       lprn=.false.
8912       eturn6=0.0d0
8913 #ifdef MPI
8914       do i=1,nres
8915         num_cont_hb_old(i)=num_cont_hb(i)
8916       enddo
8917       n_corr=0
8918       n_corr1=0
8919       if (nfgtasks.le.1) goto 30
8920       if (lprn) then
8921         write (iout,'(a)') 'Contact function values before RECEIVE:'
8922         do i=nnt,nct-2
8923           write (iout,'(2i3,50(1x,i2,f5.2))')
8924      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
8925      &    j=1,num_cont_hb(i))
8926         enddo
8927       endif
8928       do i=1,ntask_cont_from
8929         ncont_recv(i)=0
8930       enddo
8931       do i=1,ntask_cont_to
8932         ncont_sent(i)=0
8933       enddo
8934 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
8935 c     & ntask_cont_to
8936 C Make the list of contacts to send to send to other procesors
8937       do i=iturn3_start,iturn3_end
8938 c        write (iout,*) "make contact list turn3",i," num_cont",
8939 c     &    num_cont_hb(i)
8940         call add_hb_contact_eello(i,i+2,iturn3_sent_local(1,i))
8941       enddo
8942       do i=iturn4_start,iturn4_end
8943 c        write (iout,*) "make contact list turn4",i," num_cont",
8944 c     &   num_cont_hb(i)
8945         call add_hb_contact_eello(i,i+3,iturn4_sent_local(1,i))
8946       enddo
8947       do ii=1,nat_sent
8948         i=iat_sent(ii)
8949 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
8950 c     &    num_cont_hb(i)
8951         do j=1,num_cont_hb(i)
8952         do k=1,4
8953           jjc=jcont_hb(j,i)
8954           iproc=iint_sent_local(k,jjc,ii)
8955 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
8956           if (iproc.ne.0) then
8957             ncont_sent(iproc)=ncont_sent(iproc)+1
8958             nn=ncont_sent(iproc)
8959             zapas(1,nn,iproc)=i
8960             zapas(2,nn,iproc)=jjc
8961             zapas(3,nn,iproc)=d_cont(j,i)
8962             ind=3
8963             do kk=1,3
8964               ind=ind+1
8965               zapas(ind,nn,iproc)=grij_hb_cont(kk,j,i)
8966             enddo
8967             do kk=1,2
8968               do ll=1,2
8969                 ind=ind+1
8970                 zapas(ind,nn,iproc)=a_chuj(ll,kk,j,i)
8971               enddo
8972             enddo
8973             do jj=1,5
8974               do kk=1,3
8975                 do ll=1,2
8976                   do mm=1,2
8977                     ind=ind+1
8978                     zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,i)
8979                   enddo
8980                 enddo
8981               enddo
8982             enddo
8983           endif
8984         enddo
8985         enddo
8986       enddo
8987       if (lprn) then
8988       write (iout,*)
8989      &  "Numbers of contacts to be sent to other processors",
8990      &  (ncont_sent(i),i=1,ntask_cont_to)
8991       write (iout,*) "Contacts sent"
8992       do ii=1,ntask_cont_to
8993         nn=ncont_sent(ii)
8994         iproc=itask_cont_to(ii)
8995         write (iout,*) nn," contacts to processor",iproc,
8996      &   " of CONT_TO_COMM group"
8997         do i=1,nn
8998           write(iout,'(2f5.0,10f10.5)')(zapas(j,i,ii),j=1,10)
8999         enddo
9000       enddo
9001       call flush(iout)
9002       endif
9003       CorrelType=477
9004       CorrelID=fg_rank+1
9005       CorrelType1=478
9006       CorrelID1=nfgtasks+fg_rank+1
9007       ireq=0
9008 C Receive the numbers of needed contacts from other processors
9009       do ii=1,ntask_cont_from
9010         iproc=itask_cont_from(ii)
9011         ireq=ireq+1
9012         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
9013      &    FG_COMM,req(ireq),IERR)
9014       enddo
9015 c      write (iout,*) "IRECV ended"
9016 c      call flush(iout)
9017 C Send the number of contacts needed by other processors
9018       do ii=1,ntask_cont_to
9019         iproc=itask_cont_to(ii)
9020         ireq=ireq+1
9021         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
9022      &    FG_COMM,req(ireq),IERR)
9023       enddo
9024 c      write (iout,*) "ISEND ended"
9025 c      write (iout,*) "number of requests (nn)",ireq
9026 c      call flush(iout)
9027       if (ireq.gt.0)
9028      &  call MPI_Waitall(ireq,req,status_array,ierr)
9029 c      write (iout,*)
9030 c     &  "Numbers of contacts to be received from other processors",
9031 c     &  (ncont_recv(i),i=1,ntask_cont_from)
9032 c      call flush(iout)
9033 C Receive contacts
9034       ireq=0
9035       do ii=1,ntask_cont_from
9036         iproc=itask_cont_from(ii)
9037         nn=ncont_recv(ii)
9038 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
9039 c     &   " of CONT_TO_COMM group"
9040 c        call flush(iout)
9041         if (nn.gt.0) then
9042           ireq=ireq+1
9043           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
9044      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
9045 c          write (iout,*) "ireq,req",ireq,req(ireq)
9046         endif
9047       enddo
9048 C Send the contacts to processors that need them
9049       do ii=1,ntask_cont_to
9050         iproc=itask_cont_to(ii)
9051         nn=ncont_sent(ii)
9052 c        write (iout,*) nn," contacts to processor",iproc,
9053 c     &   " of CONT_TO_COMM group"
9054         if (nn.gt.0) then
9055           ireq=ireq+1
9056           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
9057      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
9058 c          write (iout,*) "ireq,req",ireq,req(ireq)
9059 c          do i=1,nn
9060 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
9061 c          enddo
9062         endif
9063       enddo
9064 c      write (iout,*) "number of requests (contacts)",ireq
9065 c      write (iout,*) "req",(req(i),i=1,4)
9066 c      call flush(iout)
9067       if (ireq.gt.0)
9068      & call MPI_Waitall(ireq,req,status_array,ierr)
9069       do iii=1,ntask_cont_from
9070         iproc=itask_cont_from(iii)
9071         nn=ncont_recv(iii)
9072         if (lprn) then
9073         write (iout,*) "Received",nn," contacts from processor",iproc,
9074      &   " of CONT_FROM_COMM group"
9075         call flush(iout)
9076         do i=1,nn
9077           write(iout,'(2f5.0,10f10.5)')(zapas_recv(j,i,iii),j=1,10)
9078         enddo
9079         call flush(iout)
9080         endif
9081         do i=1,nn
9082           ii=zapas_recv(1,i,iii)
9083 c Flag the received contacts to prevent double-counting
9084           jj=-zapas_recv(2,i,iii)
9085 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
9086 c          call flush(iout)
9087           nnn=num_cont_hb(ii)+1
9088           num_cont_hb(ii)=nnn
9089           jcont_hb(nnn,ii)=jj
9090           d_cont(nnn,ii)=zapas_recv(3,i,iii)
9091           ind=3
9092           do kk=1,3
9093             ind=ind+1
9094             grij_hb_cont(kk,nnn,ii)=zapas_recv(ind,i,iii)
9095           enddo
9096           do kk=1,2
9097             do ll=1,2
9098               ind=ind+1
9099               a_chuj(ll,kk,nnn,ii)=zapas_recv(ind,i,iii)
9100             enddo
9101           enddo
9102           do jj=1,5
9103             do kk=1,3
9104               do ll=1,2
9105                 do mm=1,2
9106                   ind=ind+1
9107                   a_chuj_der(mm,ll,kk,jj,nnn,ii)=zapas_recv(ind,i,iii)
9108                 enddo
9109               enddo
9110             enddo
9111           enddo
9112         enddo
9113       enddo
9114       if (lprn) then
9115         write (iout,'(a)') 'Contact function values after receive:'
9116         do i=nnt,nct-2
9117           write (iout,'(2i3,50(1x,i3,5f6.3))')
9118      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
9119      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
9120         enddo
9121         call flush(iout)
9122       endif
9123    30 continue
9124 #endif
9125       if (lprn) then
9126         write (iout,'(a)') 'Contact function values:'
9127         do i=nnt,nct-2
9128           write (iout,'(2i3,50(1x,i2,5f6.3))')
9129      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
9130      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
9131         enddo
9132       endif
9133       ecorr=0.0D0
9134       ecorr5=0.0d0
9135       ecorr6=0.0d0
9136 C Remove the loop below after debugging !!!
9137       do i=nnt,nct
9138         do j=1,3
9139           gradcorr(j,i)=0.0D0
9140           gradxorr(j,i)=0.0D0
9141         enddo
9142       enddo
9143 C Calculate the dipole-dipole interaction energies
9144       if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
9145       do i=iatel_s,iatel_e+1
9146         num_conti=num_cont_hb(i)
9147         do jj=1,num_conti
9148           j=jcont_hb(jj,i)
9149 #ifdef MOMENT
9150           call dipole(i,j,jj)
9151 #endif
9152         enddo
9153       enddo
9154       endif
9155 C Calculate the local-electrostatic correlation terms
9156 c                write (iout,*) "gradcorr5 in eello5 before loop"
9157 c                do iii=1,nres
9158 c                  write (iout,'(i5,3f10.5)')
9159 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
9160 c                enddo
9161       do i=min0(iatel_s,iturn4_start),max0(iatel_e+1,iturn3_end+1)
9162 c        write (iout,*) "corr loop i",i
9163         i1=i+1
9164         num_conti=num_cont_hb(i)
9165         num_conti1=num_cont_hb(i+1)
9166         do jj=1,num_conti
9167           j=jcont_hb(jj,i)
9168           jp=iabs(j)
9169           do kk=1,num_conti1
9170             j1=jcont_hb(kk,i1)
9171             jp1=iabs(j1)
9172 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
9173 c     &         ' jj=',jj,' kk=',kk
9174 c            if (j1.eq.j+1 .or. j1.eq.j-1) then
9175             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
9176      &          .or. j.lt.0 .and. j1.gt.0) .and.
9177      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
9178 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
9179 C The system gains extra energy.
9180               n_corr=n_corr+1
9181               sqd1=dsqrt(d_cont(jj,i))
9182               sqd2=dsqrt(d_cont(kk,i1))
9183               sred_geom = sqd1*sqd2
9184               IF (sred_geom.lt.cutoff_corr) THEN
9185                 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,
9186      &            ekont,fprimcont)
9187 cd               write (iout,*) 'i=',i,' j=',jp,' i1=',i1,' j1=',jp1,
9188 cd     &         ' jj=',jj,' kk=',kk
9189                 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
9190                 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
9191                 do l=1,3
9192                   g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
9193                   g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
9194                 enddo
9195                 n_corr1=n_corr1+1
9196 cd               write (iout,*) 'sred_geom=',sred_geom,
9197 cd     &          ' ekont=',ekont,' fprim=',fprimcont,
9198 cd     &          ' fac_prim1',fac_prim1,' fac_prim2',fac_prim2
9199 cd               write (iout,*) "g_contij",g_contij
9200 cd               write (iout,*) "grij_hb_cont i",grij_hb_cont(:,jj,i)
9201 cd               write (iout,*) "grij_hb_cont i1",grij_hb_cont(:,jj,i1)
9202                 call calc_eello(i,jp,i+1,jp1,jj,kk)
9203                 if (wcorr4.gt.0.0d0)
9204      &            ecorr=ecorr+eello4(i,jp,i+1,jp1,jj,kk)
9205 CC     &            *fac_shield(i)**2*fac_shield(j)**2
9206                   if (energy_dec.and.wcorr4.gt.0.0d0)
9207      1                 write (iout,'(a6,4i5,0pf7.3)')
9208      2                'ecorr4',i,j,i+1,j1,eello4(i,jp,i+1,jp1,jj,kk)
9209 c                write (iout,*) "gradcorr5 before eello5"
9210 c                do iii=1,nres
9211 c                  write (iout,'(i5,3f10.5)')
9212 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
9213 c                enddo
9214                 if (wcorr5.gt.0.0d0)
9215      &            ecorr5=ecorr5+eello5(i,jp,i+1,jp1,jj,kk)
9216 c                write (iout,*) "gradcorr5 after eello5"
9217 c                do iii=1,nres
9218 c                  write (iout,'(i5,3f10.5)')
9219 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
9220 c                enddo
9221                   if (energy_dec.and.wcorr5.gt.0.0d0)
9222      1                 write (iout,'(a6,4i5,0pf7.3)')
9223      2                'ecorr5',i,j,i+1,j1,eello5(i,jp,i+1,jp1,jj,kk)
9224 cd                write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
9225 cd                write(2,*)'ijkl',i,jp,i+1,jp1
9226                 if (wcorr6.gt.0.0d0 .and. (jp.ne.i+4 .or. jp1.ne.i+3
9227      &               .or. wturn6.eq.0.0d0))then
9228 cd                  write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
9229                   ecorr6=ecorr6+eello6(i,jp,i+1,jp1,jj,kk)
9230                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
9231      1                'ecorr6',i,j,i+1,j1,eello6(i,jp,i+1,jp1,jj,kk)
9232 cd                write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
9233 cd     &            'ecorr6=',ecorr6
9234 cd                write (iout,'(4e15.5)') sred_geom,
9235 cd     &          dabs(eello4(i,jp,i+1,jp1,jj,kk)),
9236 cd     &          dabs(eello5(i,jp,i+1,jp1,jj,kk)),
9237 cd     &          dabs(eello6(i,jp,i+1,jp1,jj,kk))
9238                 else if (wturn6.gt.0.0d0
9239      &            .and. (jp.eq.i+4 .and. jp1.eq.i+3)) then
9240 cd                  write (iout,*) '******eturn6: i,j,i+1,j1',i,jip,i+1,jp1
9241                   eturn6=eturn6+eello_turn6(i,jj,kk)
9242                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
9243      1                 'eturn6',i,j,i+1,j1,eello_turn6(i,jj,kk)
9244 cd                  write (2,*) 'multibody_eello:eturn6',eturn6
9245                 endif
9246               ENDIF
9247 1111          continue
9248             endif
9249           enddo ! kk
9250         enddo ! jj
9251       enddo ! i
9252       do i=1,nres
9253         num_cont_hb(i)=num_cont_hb_old(i)
9254       enddo
9255 c                write (iout,*) "gradcorr5 in eello5"
9256 c                do iii=1,nres
9257 c                  write (iout,'(i5,3f10.5)')
9258 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
9259 c                enddo
9260       return
9261       end
9262 c------------------------------------------------------------------------------
9263       subroutine add_hb_contact_eello(ii,jj,itask)
9264       implicit real*8 (a-h,o-z)
9265       include "DIMENSIONS"
9266       include "COMMON.IOUNITS"
9267       integer max_cont
9268       integer max_dim
9269       parameter (max_cont=maxconts)
9270       parameter (max_dim=70)
9271       include "COMMON.CONTACTS"
9272       include 'COMMON.CONTMAT'
9273       include 'COMMON.CORRMAT'
9274       double precision zapas(max_dim,maxconts,max_fg_procs),
9275      &  zapas_recv(max_dim,maxconts,max_fg_procs)
9276       common /przechowalnia/ zapas
9277       integer i,j,ii,jj,iproc,itask(4),nn
9278 c      write (iout,*) "itask",itask
9279       do i=1,2
9280         iproc=itask(i)
9281         if (iproc.gt.0) then
9282           do j=1,num_cont_hb(ii)
9283             jjc=jcont_hb(j,ii)
9284 c            write (iout,*) "send turns i",ii," j",jj," jjc",jjc
9285             if (jjc.eq.jj) then
9286               ncont_sent(iproc)=ncont_sent(iproc)+1
9287               nn=ncont_sent(iproc)
9288               zapas(1,nn,iproc)=ii
9289               zapas(2,nn,iproc)=jjc
9290               zapas(3,nn,iproc)=d_cont(j,ii)
9291               ind=3
9292               do kk=1,3
9293                 ind=ind+1
9294                 zapas(ind,nn,iproc)=grij_hb_cont(kk,j,ii)
9295               enddo
9296               do kk=1,2
9297                 do ll=1,2
9298                   ind=ind+1
9299                   zapas(ind,nn,iproc)=a_chuj(ll,kk,j,ii)
9300                 enddo
9301               enddo
9302               do jj=1,5
9303                 do kk=1,3
9304                   do ll=1,2
9305                     do mm=1,2
9306                       ind=ind+1
9307                       zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,ii)
9308                     enddo
9309                   enddo
9310                 enddo
9311               enddo
9312               exit
9313             endif
9314           enddo
9315         endif
9316       enddo
9317       return
9318       end
9319 c------------------------------------------------------------------------------
9320       double precision function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
9321       implicit real*8 (a-h,o-z)
9322       include 'DIMENSIONS'
9323       include 'COMMON.IOUNITS'
9324       include 'COMMON.DERIV'
9325       include 'COMMON.INTERACT'
9326       include 'COMMON.CONTACTS'
9327       include 'COMMON.CONTMAT'
9328       include 'COMMON.CORRMAT'
9329       include 'COMMON.SHIELD'
9330       include 'COMMON.CONTROL'
9331       double precision gx(3),gx1(3)
9332       logical lprn
9333       lprn=.false.
9334 C      print *,"wchodze",fac_shield(i),shield_mode
9335       eij=facont_hb(jj,i)
9336       ekl=facont_hb(kk,k)
9337       ees0pij=ees0p(jj,i)
9338       ees0pkl=ees0p(kk,k)
9339       ees0mij=ees0m(jj,i)
9340       ees0mkl=ees0m(kk,k)
9341       ekont=eij*ekl
9342       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
9343 C*
9344 C     & fac_shield(i)**2*fac_shield(j)**2
9345 cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
9346 C Following 4 lines for diagnostics.
9347 cd    ees0pkl=0.0D0
9348 cd    ees0pij=1.0D0
9349 cd    ees0mkl=0.0D0
9350 cd    ees0mij=1.0D0
9351 c      write (iout,'(2(a,2i3,a,f10.5,a,2f10.5),a,f10.5,a,$)')
9352 c     & 'Contacts ',i,j,
9353 c     & ' eij',eij,' eesij',ees0pij,ees0mij,' and ',k,l
9354 c     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' energy=',ekont*ees,
9355 c     & 'gradcorr_long'
9356 C Calculate the multi-body contribution to energy.
9357 C      ecorr=ecorr+ekont*ees
9358 C Calculate multi-body contributions to the gradient.
9359       coeffpees0pij=coeffp*ees0pij
9360       coeffmees0mij=coeffm*ees0mij
9361       coeffpees0pkl=coeffp*ees0pkl
9362       coeffmees0mkl=coeffm*ees0mkl
9363       do ll=1,3
9364 cgrad        ghalfi=ees*ekl*gacont_hbr(ll,jj,i)
9365         gradcorr(ll,i)=gradcorr(ll,i)!+0.5d0*ghalfi
9366      &  -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+
9367      &  coeffmees0mkl*gacontm_hb1(ll,jj,i))
9368         gradcorr(ll,j)=gradcorr(ll,j)!+0.5d0*ghalfi
9369      &  -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+
9370      &  coeffmees0mkl*gacontm_hb2(ll,jj,i))
9371 cgrad        ghalfk=ees*eij*gacont_hbr(ll,kk,k)
9372         gradcorr(ll,k)=gradcorr(ll,k)!+0.5d0*ghalfk
9373      &  -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+
9374      &  coeffmees0mij*gacontm_hb1(ll,kk,k))
9375         gradcorr(ll,l)=gradcorr(ll,l)!+0.5d0*ghalfk
9376      &  -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+
9377      &  coeffmees0mij*gacontm_hb2(ll,kk,k))
9378         gradlongij=ees*ekl*gacont_hbr(ll,jj,i)-
9379      &     ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+
9380      &     coeffmees0mkl*gacontm_hb3(ll,jj,i))
9381         gradcorr_long(ll,j)=gradcorr_long(ll,j)+gradlongij
9382         gradcorr_long(ll,i)=gradcorr_long(ll,i)-gradlongij
9383         gradlongkl=ees*eij*gacont_hbr(ll,kk,k)-
9384      &     ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+
9385      &     coeffmees0mij*gacontm_hb3(ll,kk,k))
9386         gradcorr_long(ll,l)=gradcorr_long(ll,l)+gradlongkl
9387         gradcorr_long(ll,k)=gradcorr_long(ll,k)-gradlongkl
9388 c        write (iout,'(2f10.5,2x,$)') gradlongij,gradlongkl
9389       enddo
9390 c      write (iout,*)
9391 cgrad      do m=i+1,j-1
9392 cgrad        do ll=1,3
9393 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
9394 cgrad     &     ees*ekl*gacont_hbr(ll,jj,i)-
9395 cgrad     &     ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
9396 cgrad     &     coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
9397 cgrad        enddo
9398 cgrad      enddo
9399 cgrad      do m=k+1,l-1
9400 cgrad        do ll=1,3
9401 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
9402 cgrad     &     ees*eij*gacont_hbr(ll,kk,k)-
9403 cgrad     &     ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
9404 cgrad     &     coeffm*ees0mij*gacontm_hb3(ll,kk,k))
9405 cgrad        enddo
9406 cgrad      enddo
9407 c      write (iout,*) "ehbcorr",ekont*ees
9408 C      print *,ekont,ees,i,k
9409       ehbcorr=ekont*ees
9410 C now gradient over shielding
9411 C      return
9412       if (shield_mode.gt.0) then
9413        j=ees0plist(jj,i)
9414        l=ees0plist(kk,k)
9415 C        print *,i,j,fac_shield(i),fac_shield(j),
9416 C     &fac_shield(k),fac_shield(l)
9417         if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
9418      &      (fac_shield(k).gt.0).and.(fac_shield(l).gt.0)) then
9419           do ilist=1,ishield_list(i)
9420            iresshield=shield_list(ilist,i)
9421            do m=1,3
9422            rlocshield=grad_shield_side(m,ilist,i)*ehbcorr/fac_shield(i)
9423 C     &      *2.0
9424            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
9425      &              rlocshield
9426      & +grad_shield_loc(m,ilist,i)*ehbcorr/fac_shield(i)
9427             gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
9428      &+rlocshield
9429            enddo
9430           enddo
9431           do ilist=1,ishield_list(j)
9432            iresshield=shield_list(ilist,j)
9433            do m=1,3
9434            rlocshield=grad_shield_side(m,ilist,j)*ehbcorr/fac_shield(j)
9435 C     &     *2.0
9436            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
9437      &              rlocshield
9438      & +grad_shield_loc(m,ilist,j)*ehbcorr/fac_shield(j)
9439            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
9440      &     +rlocshield
9441            enddo
9442           enddo
9443
9444           do ilist=1,ishield_list(k)
9445            iresshield=shield_list(ilist,k)
9446            do m=1,3
9447            rlocshield=grad_shield_side(m,ilist,k)*ehbcorr/fac_shield(k)
9448 C     &     *2.0
9449            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
9450      &              rlocshield
9451      & +grad_shield_loc(m,ilist,k)*ehbcorr/fac_shield(k)
9452            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
9453      &     +rlocshield
9454            enddo
9455           enddo
9456           do ilist=1,ishield_list(l)
9457            iresshield=shield_list(ilist,l)
9458            do m=1,3
9459            rlocshield=grad_shield_side(m,ilist,l)*ehbcorr/fac_shield(l)
9460 C     &     *2.0
9461            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
9462      &              rlocshield
9463      & +grad_shield_loc(m,ilist,l)*ehbcorr/fac_shield(l)
9464            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
9465      &     +rlocshield
9466            enddo
9467           enddo
9468 C          print *,gshieldx(m,iresshield)
9469           do m=1,3
9470             gshieldc_ec(m,i)=gshieldc_ec(m,i)+
9471      &              grad_shield(m,i)*ehbcorr/fac_shield(i)
9472             gshieldc_ec(m,j)=gshieldc_ec(m,j)+
9473      &              grad_shield(m,j)*ehbcorr/fac_shield(j)
9474             gshieldc_ec(m,i-1)=gshieldc_ec(m,i-1)+
9475      &              grad_shield(m,i)*ehbcorr/fac_shield(i)
9476             gshieldc_ec(m,j-1)=gshieldc_ec(m,j-1)+
9477      &              grad_shield(m,j)*ehbcorr/fac_shield(j)
9478
9479             gshieldc_ec(m,k)=gshieldc_ec(m,k)+
9480      &              grad_shield(m,k)*ehbcorr/fac_shield(k)
9481             gshieldc_ec(m,l)=gshieldc_ec(m,l)+
9482      &              grad_shield(m,l)*ehbcorr/fac_shield(l)
9483             gshieldc_ec(m,k-1)=gshieldc_ec(m,k-1)+
9484      &              grad_shield(m,k)*ehbcorr/fac_shield(k)
9485             gshieldc_ec(m,l-1)=gshieldc_ec(m,l-1)+
9486      &              grad_shield(m,l)*ehbcorr/fac_shield(l)
9487
9488            enddo
9489       endif
9490       endif
9491       return
9492       end
9493 #ifdef MOMENT
9494 C---------------------------------------------------------------------------
9495       subroutine dipole(i,j,jj)
9496       implicit real*8 (a-h,o-z)
9497       include 'DIMENSIONS'
9498       include 'COMMON.IOUNITS'
9499       include 'COMMON.CHAIN'
9500       include 'COMMON.FFIELD'
9501       include 'COMMON.DERIV'
9502       include 'COMMON.INTERACT'
9503       include 'COMMON.CONTACTS'
9504       include 'COMMON.CONTMAT'
9505       include 'COMMON.CORRMAT'
9506       include 'COMMON.TORSION'
9507       include 'COMMON.VAR'
9508       include 'COMMON.GEO'
9509       dimension dipi(2,2),dipj(2,2),dipderi(2),dipderj(2),auxvec(2),
9510      &  auxmat(2,2)
9511       iti1 = itortyp(itype(i+1))
9512       if (j.lt.nres-1) then
9513         itj1 = itype2loc(itype(j+1))
9514       else
9515         itj1=nloctyp
9516       endif
9517       do iii=1,2
9518         dipi(iii,1)=Ub2(iii,i)
9519         dipderi(iii)=Ub2der(iii,i)
9520         dipi(iii,2)=b1(iii,i+1)
9521         dipj(iii,1)=Ub2(iii,j)
9522         dipderj(iii)=Ub2der(iii,j)
9523         dipj(iii,2)=b1(iii,j+1)
9524       enddo
9525       kkk=0
9526       do iii=1,2
9527         call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
9528         do jjj=1,2
9529           kkk=kkk+1
9530           dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
9531         enddo
9532       enddo
9533       do kkk=1,5
9534         do lll=1,3
9535           mmm=0
9536           do iii=1,2
9537             call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),
9538      &        auxvec(1))
9539             do jjj=1,2
9540               mmm=mmm+1
9541               dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
9542             enddo
9543           enddo
9544         enddo
9545       enddo
9546       call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
9547       call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
9548       do iii=1,2
9549         dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
9550       enddo
9551       call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
9552       do iii=1,2
9553         dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
9554       enddo
9555       return
9556       end
9557 #endif
9558 C---------------------------------------------------------------------------
9559       subroutine calc_eello(i,j,k,l,jj,kk)
9560 C
9561 C This subroutine computes matrices and vectors needed to calculate
9562 C the fourth-, fifth-, and sixth-order local-electrostatic terms.
9563 C
9564       implicit real*8 (a-h,o-z)
9565       include 'DIMENSIONS'
9566       include 'COMMON.IOUNITS'
9567       include 'COMMON.CHAIN'
9568       include 'COMMON.DERIV'
9569       include 'COMMON.INTERACT'
9570       include 'COMMON.CONTACTS'
9571       include 'COMMON.CONTMAT'
9572       include 'COMMON.CORRMAT'
9573       include 'COMMON.TORSION'
9574       include 'COMMON.VAR'
9575       include 'COMMON.GEO'
9576       include 'COMMON.FFIELD'
9577       double precision aa1(2,2),aa2(2,2),aa1t(2,2),aa2t(2,2),
9578      &  aa1tder(2,2,3,5),aa2tder(2,2,3,5),auxmat(2,2)
9579       logical lprn
9580       common /kutas/ lprn
9581 cd      write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
9582 cd     & ' jj=',jj,' kk=',kk
9583 cd      if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
9584 cd      write (iout,*) "a_chujij",((a_chuj(iii,jjj,jj,i),iii=1,2),jjj=1,2)
9585 cd      write (iout,*) "a_chujkl",((a_chuj(iii,jjj,kk,k),iii=1,2),jjj=1,2)
9586       do iii=1,2
9587         do jjj=1,2
9588           aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
9589           aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
9590         enddo
9591       enddo
9592       call transpose2(aa1(1,1),aa1t(1,1))
9593       call transpose2(aa2(1,1),aa2t(1,1))
9594       do kkk=1,5
9595         do lll=1,3
9596           call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),
9597      &      aa1tder(1,1,lll,kkk))
9598           call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),
9599      &      aa2tder(1,1,lll,kkk))
9600         enddo
9601       enddo
9602       if (l.eq.j+1) then
9603 C parallel orientation of the two CA-CA-CA frames.
9604         if (i.gt.1) then
9605           iti=itype2loc(itype(i))
9606         else
9607           iti=nloctyp
9608         endif
9609         itk1=itype2loc(itype(k+1))
9610         itj=itype2loc(itype(j))
9611         if (l.lt.nres-1) then
9612           itl1=itype2loc(itype(l+1))
9613         else
9614           itl1=nloctyp
9615         endif
9616 C A1 kernel(j+1) A2T
9617 cd        do iii=1,2
9618 cd          write (iout,'(3f10.5,5x,3f10.5)')
9619 cd     &     (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
9620 cd        enddo
9621         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9622      &   aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),
9623      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
9624 C Following matrices are needed only for 6-th order cumulants
9625         IF (wcorr6.gt.0.0d0) THEN
9626         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9627      &   aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),
9628      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
9629         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9630      &   aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),
9631      &   Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
9632      &   ADtEAderx(1,1,1,1,1,1))
9633         lprn=.false.
9634         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9635      &   aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),
9636      &   DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
9637      &   ADtEA1derx(1,1,1,1,1,1))
9638         ENDIF
9639 C End 6-th order cumulants
9640 cd        lprn=.false.
9641 cd        if (lprn) then
9642 cd        write (2,*) 'In calc_eello6'
9643 cd        do iii=1,2
9644 cd          write (2,*) 'iii=',iii
9645 cd          do kkk=1,5
9646 cd            write (2,*) 'kkk=',kkk
9647 cd            do jjj=1,2
9648 cd              write (2,'(3(2f10.5),5x)')
9649 cd     &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
9650 cd            enddo
9651 cd          enddo
9652 cd        enddo
9653 cd        endif
9654         call transpose2(EUgder(1,1,k),auxmat(1,1))
9655         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
9656         call transpose2(EUg(1,1,k),auxmat(1,1))
9657         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
9658         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
9659 C AL 4/16/16: Derivatives of the quantitied related to matrices C, D, and E
9660 c    in theta; to be sriten later.
9661 c#ifdef NEWCORR
9662 c        call transpose2(gtEE(1,1,k),auxmat(1,1))
9663 c        call matmat2(auxmat(1,1),AEA(1,1,1),EAEAdert(1,1,1,1))
9664 c        call transpose2(EUg(1,1,k),auxmat(1,1))
9665 c        call matmat2(auxmat(1,1),AEAdert(1,1,1),EAEAdert(1,1,2,1))
9666 c#endif
9667         do iii=1,2
9668           do kkk=1,5
9669             do lll=1,3
9670               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
9671      &          EAEAderx(1,1,lll,kkk,iii,1))
9672             enddo
9673           enddo
9674         enddo
9675 C A1T kernel(i+1) A2
9676         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
9677      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),
9678      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
9679 C Following matrices are needed only for 6-th order cumulants
9680         IF (wcorr6.gt.0.0d0) THEN
9681         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
9682      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),
9683      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
9684         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
9685      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),
9686      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
9687      &   ADtEAderx(1,1,1,1,1,2))
9688         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
9689      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),
9690      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
9691      &   ADtEA1derx(1,1,1,1,1,2))
9692         ENDIF
9693 C End 6-th order cumulants
9694         call transpose2(EUgder(1,1,l),auxmat(1,1))
9695         call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
9696         call transpose2(EUg(1,1,l),auxmat(1,1))
9697         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
9698         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
9699         do iii=1,2
9700           do kkk=1,5
9701             do lll=1,3
9702               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
9703      &          EAEAderx(1,1,lll,kkk,iii,2))
9704             enddo
9705           enddo
9706         enddo
9707 C AEAb1 and AEAb2
9708 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
9709 C They are needed only when the fifth- or the sixth-order cumulants are
9710 C indluded.
9711         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
9712         call transpose2(AEA(1,1,1),auxmat(1,1))
9713         call matvec2(auxmat(1,1),b1(1,i),AEAb1(1,1,1))
9714         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
9715         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
9716         call transpose2(AEAderg(1,1,1),auxmat(1,1))
9717         call matvec2(auxmat(1,1),b1(1,i),AEAb1derg(1,1,1))
9718         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
9719         call matvec2(AEA(1,1,1),b1(1,k+1),AEAb1(1,2,1))
9720         call matvec2(AEAderg(1,1,1),b1(1,k+1),AEAb1derg(1,2,1))
9721         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
9722         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
9723         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
9724         call transpose2(AEA(1,1,2),auxmat(1,1))
9725         call matvec2(auxmat(1,1),b1(1,j),AEAb1(1,1,2))
9726         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
9727         call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
9728         call transpose2(AEAderg(1,1,2),auxmat(1,1))
9729         call matvec2(auxmat(1,1),b1(1,j),AEAb1derg(1,1,2))
9730         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
9731         call matvec2(AEA(1,1,2),b1(1,l+1),AEAb1(1,2,2))
9732         call matvec2(AEAderg(1,1,2),b1(1,l+1),AEAb1derg(1,2,2))
9733         call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
9734         call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
9735         call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
9736 C Calculate the Cartesian derivatives of the vectors.
9737         do iii=1,2
9738           do kkk=1,5
9739             do lll=1,3
9740               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
9741               call matvec2(auxmat(1,1),b1(1,i),
9742      &          AEAb1derx(1,lll,kkk,iii,1,1))
9743               call matvec2(auxmat(1,1),Ub2(1,i),
9744      &          AEAb2derx(1,lll,kkk,iii,1,1))
9745               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
9746      &          AEAb1derx(1,lll,kkk,iii,2,1))
9747               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
9748      &          AEAb2derx(1,lll,kkk,iii,2,1))
9749               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
9750               call matvec2(auxmat(1,1),b1(1,j),
9751      &          AEAb1derx(1,lll,kkk,iii,1,2))
9752               call matvec2(auxmat(1,1),Ub2(1,j),
9753      &          AEAb2derx(1,lll,kkk,iii,1,2))
9754               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,l+1),
9755      &          AEAb1derx(1,lll,kkk,iii,2,2))
9756               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),
9757      &          AEAb2derx(1,lll,kkk,iii,2,2))
9758             enddo
9759           enddo
9760         enddo
9761         ENDIF
9762 C End vectors
9763       else
9764 C Antiparallel orientation of the two CA-CA-CA frames.
9765         if (i.gt.1) then
9766           iti=itype2loc(itype(i))
9767         else
9768           iti=nloctyp
9769         endif
9770         itk1=itype2loc(itype(k+1))
9771         itl=itype2loc(itype(l))
9772         itj=itype2loc(itype(j))
9773         if (j.lt.nres-1) then
9774           itj1=itype2loc(itype(j+1))
9775         else
9776           itj1=nloctyp
9777         endif
9778 C A2 kernel(j-1)T A1T
9779         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9780      &   aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),
9781      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
9782 C Following matrices are needed only for 6-th order cumulants
9783         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
9784      &     j.eq.i+4 .and. l.eq.i+3)) THEN
9785         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9786      &   aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),
9787      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
9788         call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9789      &   aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),
9790      &   Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
9791      &   ADtEAderx(1,1,1,1,1,1))
9792         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9793      &   aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),
9794      &   DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
9795      &   ADtEA1derx(1,1,1,1,1,1))
9796         ENDIF
9797 C End 6-th order cumulants
9798         call transpose2(EUgder(1,1,k),auxmat(1,1))
9799         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
9800         call transpose2(EUg(1,1,k),auxmat(1,1))
9801         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
9802         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
9803         do iii=1,2
9804           do kkk=1,5
9805             do lll=1,3
9806               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
9807      &          EAEAderx(1,1,lll,kkk,iii,1))
9808             enddo
9809           enddo
9810         enddo
9811 C A2T kernel(i+1)T A1
9812         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
9813      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),
9814      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
9815 C Following matrices are needed only for 6-th order cumulants
9816         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
9817      &     j.eq.i+4 .and. l.eq.i+3)) THEN
9818         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
9819      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),
9820      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
9821         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
9822      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),
9823      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
9824      &   ADtEAderx(1,1,1,1,1,2))
9825         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
9826      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),
9827      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
9828      &   ADtEA1derx(1,1,1,1,1,2))
9829         ENDIF
9830 C End 6-th order cumulants
9831         call transpose2(EUgder(1,1,j),auxmat(1,1))
9832         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
9833         call transpose2(EUg(1,1,j),auxmat(1,1))
9834         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
9835         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
9836         do iii=1,2
9837           do kkk=1,5
9838             do lll=1,3
9839               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
9840      &          EAEAderx(1,1,lll,kkk,iii,2))
9841             enddo
9842           enddo
9843         enddo
9844 C AEAb1 and AEAb2
9845 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
9846 C They are needed only when the fifth- or the sixth-order cumulants are
9847 C indluded.
9848         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or.
9849      &    (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
9850         call transpose2(AEA(1,1,1),auxmat(1,1))
9851         call matvec2(auxmat(1,1),b1(1,i),AEAb1(1,1,1))
9852         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
9853         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
9854         call transpose2(AEAderg(1,1,1),auxmat(1,1))
9855         call matvec2(auxmat(1,1),b1(1,i),AEAb1derg(1,1,1))
9856         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
9857         call matvec2(AEA(1,1,1),b1(1,k+1),AEAb1(1,2,1))
9858         call matvec2(AEAderg(1,1,1),b1(1,k+1),AEAb1derg(1,2,1))
9859         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
9860         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
9861         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
9862         call transpose2(AEA(1,1,2),auxmat(1,1))
9863         call matvec2(auxmat(1,1),b1(1,j+1),AEAb1(1,1,2))
9864         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
9865         call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
9866         call transpose2(AEAderg(1,1,2),auxmat(1,1))
9867         call matvec2(auxmat(1,1),b1(1,l),AEAb1(1,1,2))
9868         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
9869         call matvec2(AEA(1,1,2),b1(1,j+1),AEAb1(1,2,2))
9870         call matvec2(AEAderg(1,1,2),b1(1,j+1),AEAb1derg(1,2,2))
9871         call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
9872         call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
9873         call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
9874 C Calculate the Cartesian derivatives of the vectors.
9875         do iii=1,2
9876           do kkk=1,5
9877             do lll=1,3
9878               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
9879               call matvec2(auxmat(1,1),b1(1,i),
9880      &          AEAb1derx(1,lll,kkk,iii,1,1))
9881               call matvec2(auxmat(1,1),Ub2(1,i),
9882      &          AEAb2derx(1,lll,kkk,iii,1,1))
9883               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
9884      &          AEAb1derx(1,lll,kkk,iii,2,1))
9885               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
9886      &          AEAb2derx(1,lll,kkk,iii,2,1))
9887               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
9888               call matvec2(auxmat(1,1),b1(1,l),
9889      &          AEAb1derx(1,lll,kkk,iii,1,2))
9890               call matvec2(auxmat(1,1),Ub2(1,l),
9891      &          AEAb2derx(1,lll,kkk,iii,1,2))
9892               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,j+1),
9893      &          AEAb1derx(1,lll,kkk,iii,2,2))
9894               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),
9895      &          AEAb2derx(1,lll,kkk,iii,2,2))
9896             enddo
9897           enddo
9898         enddo
9899         ENDIF
9900 C End vectors
9901       endif
9902       return
9903       end
9904 C---------------------------------------------------------------------------
9905       subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,
9906      &  KK,KKderg,AKA,AKAderg,AKAderx)
9907       implicit none
9908       integer nderg
9909       logical transp
9910       double precision aa1(2,2),aa2t(2,2),aa1derx(2,2,3,5),
9911      &  aa2tderx(2,2,3,5),KK(2,2),KKderg(2,2,nderg),AKA(2,2),
9912      &  AKAderg(2,2,nderg),AKAderx(2,2,3,5,2)
9913       integer iii,kkk,lll
9914       integer jjj,mmm
9915       logical lprn
9916       common /kutas/ lprn
9917       call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
9918       do iii=1,nderg
9919         call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,
9920      &    AKAderg(1,1,iii))
9921       enddo
9922 cd      if (lprn) write (2,*) 'In kernel'
9923       do kkk=1,5
9924 cd        if (lprn) write (2,*) 'kkk=',kkk
9925         do lll=1,3
9926           call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),
9927      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
9928 cd          if (lprn) then
9929 cd            write (2,*) 'lll=',lll
9930 cd            write (2,*) 'iii=1'
9931 cd            do jjj=1,2
9932 cd              write (2,'(3(2f10.5),5x)')
9933 cd     &        (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
9934 cd            enddo
9935 cd          endif
9936           call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),
9937      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
9938 cd          if (lprn) then
9939 cd            write (2,*) 'lll=',lll
9940 cd            write (2,*) 'iii=2'
9941 cd            do jjj=1,2
9942 cd              write (2,'(3(2f10.5),5x)')
9943 cd     &        (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
9944 cd            enddo
9945 cd          endif
9946         enddo
9947       enddo
9948       return
9949       end
9950 C---------------------------------------------------------------------------
9951       double precision function eello4(i,j,k,l,jj,kk)
9952       implicit real*8 (a-h,o-z)
9953       include 'DIMENSIONS'
9954       include 'COMMON.IOUNITS'
9955       include 'COMMON.CHAIN'
9956       include 'COMMON.DERIV'
9957       include 'COMMON.INTERACT'
9958       include 'COMMON.CONTACTS'
9959       include 'COMMON.CONTMAT'
9960       include 'COMMON.CORRMAT'
9961       include 'COMMON.TORSION'
9962       include 'COMMON.VAR'
9963       include 'COMMON.GEO'
9964       double precision pizda(2,2),ggg1(3),ggg2(3)
9965 cd      if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
9966 cd        eello4=0.0d0
9967 cd        return
9968 cd      endif
9969 cd      print *,'eello4:',i,j,k,l,jj,kk
9970 cd      write (2,*) 'i',i,' j',j,' k',k,' l',l
9971 cd      call checkint4(i,j,k,l,jj,kk,eel4_num)
9972 cold      eij=facont_hb(jj,i)
9973 cold      ekl=facont_hb(kk,k)
9974 cold      ekont=eij*ekl
9975       eel4=-EAEA(1,1,1)-EAEA(2,2,1)
9976 cd      eel41=-EAEA(1,1,2)-EAEA(2,2,2)
9977       gcorr_loc(k-1)=gcorr_loc(k-1)
9978      &   -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
9979       if (l.eq.j+1) then
9980         gcorr_loc(l-1)=gcorr_loc(l-1)
9981      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
9982 C Al 4/16/16: Derivatives in theta, to be added later.
9983 c#ifdef NEWCORR
9984 c        gcorr_loc(nphi+l-1)=gcorr_loc(nphi+l-1)
9985 c     &     -ekont*(EAEAdert(1,1,2,1)+EAEAdert(2,2,2,1))
9986 c#endif
9987       else
9988         gcorr_loc(j-1)=gcorr_loc(j-1)
9989      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
9990 c#ifdef NEWCORR
9991 c        gcorr_loc(nphi+j-1)=gcorr_loc(nphi+j-1)
9992 c     &     -ekont*(EAEAdert(1,1,2,1)+EAEAdert(2,2,2,1))
9993 c#endif
9994       endif
9995       do iii=1,2
9996         do kkk=1,5
9997           do lll=1,3
9998             derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1)
9999      &                        -EAEAderx(2,2,lll,kkk,iii,1)
10000 cd            derx(lll,kkk,iii)=0.0d0
10001           enddo
10002         enddo
10003       enddo
10004 cd      gcorr_loc(l-1)=0.0d0
10005 cd      gcorr_loc(j-1)=0.0d0
10006 cd      gcorr_loc(k-1)=0.0d0
10007 cd      eel4=1.0d0
10008 cd      write (iout,*)'Contacts have occurred for peptide groups',
10009 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l,
10010 cd     &  ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
10011       if (j.lt.nres-1) then
10012         j1=j+1
10013         j2=j-1
10014       else
10015         j1=j-1
10016         j2=j-2
10017       endif
10018       if (l.lt.nres-1) then
10019         l1=l+1
10020         l2=l-1
10021       else
10022         l1=l-1
10023         l2=l-2
10024       endif
10025       do ll=1,3
10026 cgrad        ggg1(ll)=eel4*g_contij(ll,1)
10027 cgrad        ggg2(ll)=eel4*g_contij(ll,2)
10028         glongij=eel4*g_contij(ll,1)+ekont*derx(ll,1,1)
10029         glongkl=eel4*g_contij(ll,2)+ekont*derx(ll,1,2)
10030 cgrad        ghalf=0.5d0*ggg1(ll)
10031         gradcorr(ll,i)=gradcorr(ll,i)+ekont*derx(ll,2,1)
10032         gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
10033         gradcorr(ll,j)=gradcorr(ll,j)+ekont*derx(ll,4,1)
10034         gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
10035         gradcorr_long(ll,j)=gradcorr_long(ll,j)+glongij
10036         gradcorr_long(ll,i)=gradcorr_long(ll,i)-glongij
10037 cgrad        ghalf=0.5d0*ggg2(ll)
10038         gradcorr(ll,k)=gradcorr(ll,k)+ekont*derx(ll,2,2)
10039         gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
10040         gradcorr(ll,l)=gradcorr(ll,l)+ekont*derx(ll,4,2)
10041         gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
10042         gradcorr_long(ll,l)=gradcorr_long(ll,l)+glongkl
10043         gradcorr_long(ll,k)=gradcorr_long(ll,k)-glongkl
10044       enddo
10045 cgrad      do m=i+1,j-1
10046 cgrad        do ll=1,3
10047 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
10048 cgrad        enddo
10049 cgrad      enddo
10050 cgrad      do m=k+1,l-1
10051 cgrad        do ll=1,3
10052 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
10053 cgrad        enddo
10054 cgrad      enddo
10055 cgrad      do m=i+2,j2
10056 cgrad        do ll=1,3
10057 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
10058 cgrad        enddo
10059 cgrad      enddo
10060 cgrad      do m=k+2,l2
10061 cgrad        do ll=1,3
10062 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
10063 cgrad        enddo
10064 cgrad      enddo
10065 cd      do iii=1,nres-3
10066 cd        write (2,*) iii,gcorr_loc(iii)
10067 cd      enddo
10068       eello4=ekont*eel4
10069 cd      write (2,*) 'ekont',ekont
10070 cd      write (iout,*) 'eello4',ekont*eel4
10071       return
10072       end
10073 C---------------------------------------------------------------------------
10074       double precision function eello5(i,j,k,l,jj,kk)
10075       implicit real*8 (a-h,o-z)
10076       include 'DIMENSIONS'
10077       include 'COMMON.IOUNITS'
10078       include 'COMMON.CHAIN'
10079       include 'COMMON.DERIV'
10080       include 'COMMON.INTERACT'
10081       include 'COMMON.CONTACTS'
10082       include 'COMMON.CONTMAT'
10083       include 'COMMON.CORRMAT'
10084       include 'COMMON.TORSION'
10085       include 'COMMON.VAR'
10086       include 'COMMON.GEO'
10087       double precision pizda(2,2),auxmat(2,2),auxmat1(2,2),vv(2)
10088       double precision ggg1(3),ggg2(3)
10089 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10090 C                                                                              C
10091 C                            Parallel chains                                   C
10092 C                                                                              C
10093 C          o             o                   o             o                   C
10094 C         /l\           / \             \   / \           / \   /              C
10095 C        /   \         /   \             \ /   \         /   \ /               C
10096 C       j| o |l1       | o |              o| o |         | o |o                C
10097 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
10098 C      \i/   \         /   \ /             /   \         /   \                 C
10099 C       o    k1             o                                                  C
10100 C         (I)          (II)                (III)          (IV)                 C
10101 C                                                                              C
10102 C      eello5_1        eello5_2            eello5_3       eello5_4             C
10103 C                                                                              C
10104 C                            Antiparallel chains                               C
10105 C                                                                              C
10106 C          o             o                   o             o                   C
10107 C         /j\           / \             \   / \           / \   /              C
10108 C        /   \         /   \             \ /   \         /   \ /               C
10109 C      j1| o |l        | o |              o| o |         | o |o                C
10110 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
10111 C      \i/   \         /   \ /             /   \         /   \                 C
10112 C       o     k1            o                                                  C
10113 C         (I)          (II)                (III)          (IV)                 C
10114 C                                                                              C
10115 C      eello5_1        eello5_2            eello5_3       eello5_4             C
10116 C                                                                              C
10117 C o denotes a local interaction, vertical lines an electrostatic interaction.  C
10118 C                                                                              C
10119 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10120 cd      if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
10121 cd        eello5=0.0d0
10122 cd        return
10123 cd      endif
10124 cd      write (iout,*)
10125 cd     &   'EELLO5: Contacts have occurred for peptide groups',i,j,
10126 cd     &   ' and',k,l
10127       itk=itype2loc(itype(k))
10128       itl=itype2loc(itype(l))
10129       itj=itype2loc(itype(j))
10130       eello5_1=0.0d0
10131       eello5_2=0.0d0
10132       eello5_3=0.0d0
10133       eello5_4=0.0d0
10134 cd      call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
10135 cd     &   eel5_3_num,eel5_4_num)
10136       do iii=1,2
10137         do kkk=1,5
10138           do lll=1,3
10139             derx(lll,kkk,iii)=0.0d0
10140           enddo
10141         enddo
10142       enddo
10143 cd      eij=facont_hb(jj,i)
10144 cd      ekl=facont_hb(kk,k)
10145 cd      ekont=eij*ekl
10146 cd      write (iout,*)'Contacts have occurred for peptide groups',
10147 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l
10148 cd      goto 1111
10149 C Contribution from the graph I.
10150 cd      write (2,*) 'AEA  ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
10151 cd      write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
10152       call transpose2(EUg(1,1,k),auxmat(1,1))
10153       call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
10154       vv(1)=pizda(1,1)-pizda(2,2)
10155       vv(2)=pizda(1,2)+pizda(2,1)
10156       eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k))
10157      & +0.5d0*scalar2(vv(1),Dtobr2(1,i))
10158 C Explicit gradient in virtual-dihedral angles.
10159       if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1)
10160      & +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k))
10161      & +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
10162       call transpose2(EUgder(1,1,k),auxmat1(1,1))
10163       call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
10164       vv(1)=pizda(1,1)-pizda(2,2)
10165       vv(2)=pizda(1,2)+pizda(2,1)
10166       g_corr5_loc(k-1)=g_corr5_loc(k-1)
10167      & +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k))
10168      & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
10169       call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
10170       vv(1)=pizda(1,1)-pizda(2,2)
10171       vv(2)=pizda(1,2)+pizda(2,1)
10172       if (l.eq.j+1) then
10173         if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1)
10174      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
10175      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
10176       else
10177         if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1)
10178      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
10179      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
10180       endif
10181 C Cartesian gradient
10182       do iii=1,2
10183         do kkk=1,5
10184           do lll=1,3
10185             call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),
10186      &        pizda(1,1))
10187             vv(1)=pizda(1,1)-pizda(2,2)
10188             vv(2)=pizda(1,2)+pizda(2,1)
10189             derx(lll,kkk,iii)=derx(lll,kkk,iii)
10190      &       +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k))
10191      &       +0.5d0*scalar2(vv(1),Dtobr2(1,i))
10192           enddo
10193         enddo
10194       enddo
10195 c      goto 1112
10196 c1111  continue
10197 C Contribution from graph II
10198       call transpose2(EE(1,1,k),auxmat(1,1))
10199       call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
10200       vv(1)=pizda(1,1)+pizda(2,2)
10201       vv(2)=pizda(2,1)-pizda(1,2)
10202       eello5_2=scalar2(AEAb1(1,2,1),b1(1,k))
10203      & -0.5d0*scalar2(vv(1),Ctobr(1,k))
10204 C Explicit gradient in virtual-dihedral angles.
10205       g_corr5_loc(k-1)=g_corr5_loc(k-1)
10206      & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
10207       call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
10208       vv(1)=pizda(1,1)+pizda(2,2)
10209       vv(2)=pizda(2,1)-pizda(1,2)
10210       if (l.eq.j+1) then
10211         g_corr5_loc(l-1)=g_corr5_loc(l-1)
10212      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,k))
10213      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
10214       else
10215         g_corr5_loc(j-1)=g_corr5_loc(j-1)
10216      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,k))
10217      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
10218       endif
10219 C Cartesian gradient
10220       do iii=1,2
10221         do kkk=1,5
10222           do lll=1,3
10223             call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
10224      &        pizda(1,1))
10225             vv(1)=pizda(1,1)+pizda(2,2)
10226             vv(2)=pizda(2,1)-pizda(1,2)
10227             derx(lll,kkk,iii)=derx(lll,kkk,iii)
10228      &       +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,k))
10229      &       -0.5d0*scalar2(vv(1),Ctobr(1,k))
10230           enddo
10231         enddo
10232       enddo
10233 cd      goto 1112
10234 cd1111  continue
10235       if (l.eq.j+1) then
10236 cd        goto 1110
10237 C Parallel orientation
10238 C Contribution from graph III
10239         call transpose2(EUg(1,1,l),auxmat(1,1))
10240         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
10241         vv(1)=pizda(1,1)-pizda(2,2)
10242         vv(2)=pizda(1,2)+pizda(2,1)
10243         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l))
10244      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j))
10245 C Explicit gradient in virtual-dihedral angles.
10246         g_corr5_loc(j-1)=g_corr5_loc(j-1)
10247      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l))
10248      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
10249         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
10250         vv(1)=pizda(1,1)-pizda(2,2)
10251         vv(2)=pizda(1,2)+pizda(2,1)
10252         g_corr5_loc(k-1)=g_corr5_loc(k-1)
10253      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l))
10254      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
10255         call transpose2(EUgder(1,1,l),auxmat1(1,1))
10256         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
10257         vv(1)=pizda(1,1)-pizda(2,2)
10258         vv(2)=pizda(1,2)+pizda(2,1)
10259         g_corr5_loc(l-1)=g_corr5_loc(l-1)
10260      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l))
10261      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
10262 C Cartesian gradient
10263         do iii=1,2
10264           do kkk=1,5
10265             do lll=1,3
10266               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
10267      &          pizda(1,1))
10268               vv(1)=pizda(1,1)-pizda(2,2)
10269               vv(2)=pizda(1,2)+pizda(2,1)
10270               derx(lll,kkk,iii)=derx(lll,kkk,iii)
10271      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l))
10272      &         +0.5d0*scalar2(vv(1),Dtobr2(1,j))
10273             enddo
10274           enddo
10275         enddo
10276 cd        goto 1112
10277 C Contribution from graph IV
10278 cd1110    continue
10279         call transpose2(EE(1,1,l),auxmat(1,1))
10280         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
10281         vv(1)=pizda(1,1)+pizda(2,2)
10282         vv(2)=pizda(2,1)-pizda(1,2)
10283         eello5_4=scalar2(AEAb1(1,2,2),b1(1,l))
10284      &   -0.5d0*scalar2(vv(1),Ctobr(1,l))
10285 C Explicit gradient in virtual-dihedral angles.
10286         g_corr5_loc(l-1)=g_corr5_loc(l-1)
10287      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
10288         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
10289         vv(1)=pizda(1,1)+pizda(2,2)
10290         vv(2)=pizda(2,1)-pizda(1,2)
10291         g_corr5_loc(k-1)=g_corr5_loc(k-1)
10292      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,l))
10293      &   -0.5d0*scalar2(vv(1),Ctobr(1,l)))
10294 C Cartesian gradient
10295         do iii=1,2
10296           do kkk=1,5
10297             do lll=1,3
10298               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
10299      &          pizda(1,1))
10300               vv(1)=pizda(1,1)+pizda(2,2)
10301               vv(2)=pizda(2,1)-pizda(1,2)
10302               derx(lll,kkk,iii)=derx(lll,kkk,iii)
10303      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,l))
10304      &         -0.5d0*scalar2(vv(1),Ctobr(1,l))
10305             enddo
10306           enddo
10307         enddo
10308       else
10309 C Antiparallel orientation
10310 C Contribution from graph III
10311 c        goto 1110
10312         call transpose2(EUg(1,1,j),auxmat(1,1))
10313         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
10314         vv(1)=pizda(1,1)-pizda(2,2)
10315         vv(2)=pizda(1,2)+pizda(2,1)
10316         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j))
10317      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l))
10318 C Explicit gradient in virtual-dihedral angles.
10319         g_corr5_loc(l-1)=g_corr5_loc(l-1)
10320      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j))
10321      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
10322         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
10323         vv(1)=pizda(1,1)-pizda(2,2)
10324         vv(2)=pizda(1,2)+pizda(2,1)
10325         g_corr5_loc(k-1)=g_corr5_loc(k-1)
10326      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j))
10327      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
10328         call transpose2(EUgder(1,1,j),auxmat1(1,1))
10329         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
10330         vv(1)=pizda(1,1)-pizda(2,2)
10331         vv(2)=pizda(1,2)+pizda(2,1)
10332         g_corr5_loc(j-1)=g_corr5_loc(j-1)
10333      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j))
10334      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
10335 C Cartesian gradient
10336         do iii=1,2
10337           do kkk=1,5
10338             do lll=1,3
10339               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
10340      &          pizda(1,1))
10341               vv(1)=pizda(1,1)-pizda(2,2)
10342               vv(2)=pizda(1,2)+pizda(2,1)
10343               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
10344      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j))
10345      &         +0.5d0*scalar2(vv(1),Dtobr2(1,l))
10346             enddo
10347           enddo
10348         enddo
10349 cd        goto 1112
10350 C Contribution from graph IV
10351 1110    continue
10352         call transpose2(EE(1,1,j),auxmat(1,1))
10353         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
10354         vv(1)=pizda(1,1)+pizda(2,2)
10355         vv(2)=pizda(2,1)-pizda(1,2)
10356         eello5_4=scalar2(AEAb1(1,2,2),b1(1,j))
10357      &   -0.5d0*scalar2(vv(1),Ctobr(1,j))
10358 C Explicit gradient in virtual-dihedral angles.
10359         g_corr5_loc(j-1)=g_corr5_loc(j-1)
10360      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
10361         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
10362         vv(1)=pizda(1,1)+pizda(2,2)
10363         vv(2)=pizda(2,1)-pizda(1,2)
10364         g_corr5_loc(k-1)=g_corr5_loc(k-1)
10365      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,j))
10366      &   -0.5d0*scalar2(vv(1),Ctobr(1,j)))
10367 C Cartesian gradient
10368         do iii=1,2
10369           do kkk=1,5
10370             do lll=1,3
10371               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
10372      &          pizda(1,1))
10373               vv(1)=pizda(1,1)+pizda(2,2)
10374               vv(2)=pizda(2,1)-pizda(1,2)
10375               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
10376      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,j))
10377      &         -0.5d0*scalar2(vv(1),Ctobr(1,j))
10378             enddo
10379           enddo
10380         enddo
10381       endif
10382 1112  continue
10383       eel5=eello5_1+eello5_2+eello5_3+eello5_4
10384 cd      if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
10385 cd        write (2,*) 'ijkl',i,j,k,l
10386 cd        write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
10387 cd     &     ' eello5_3',eello5_3,' eello5_4',eello5_4
10388 cd      endif
10389 cd      write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
10390 cd      write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
10391 cd      write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
10392 cd      write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
10393       if (j.lt.nres-1) then
10394         j1=j+1
10395         j2=j-1
10396       else
10397         j1=j-1
10398         j2=j-2
10399       endif
10400       if (l.lt.nres-1) then
10401         l1=l+1
10402         l2=l-1
10403       else
10404         l1=l-1
10405         l2=l-2
10406       endif
10407 cd      eij=1.0d0
10408 cd      ekl=1.0d0
10409 cd      ekont=1.0d0
10410 cd      write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
10411 C 2/11/08 AL Gradients over DC's connecting interacting sites will be
10412 C        summed up outside the subrouine as for the other subroutines
10413 C        handling long-range interactions. The old code is commented out
10414 C        with "cgrad" to keep track of changes.
10415       do ll=1,3
10416 cgrad        ggg1(ll)=eel5*g_contij(ll,1)
10417 cgrad        ggg2(ll)=eel5*g_contij(ll,2)
10418         gradcorr5ij=eel5*g_contij(ll,1)+ekont*derx(ll,1,1)
10419         gradcorr5kl=eel5*g_contij(ll,2)+ekont*derx(ll,1,2)
10420 c        write (iout,'(a,3i3,a,5f8.3,2i3,a,5f8.3,a,f8.3)')
10421 c     &   "ecorr5",ll,i,j," derx",derx(ll,2,1),derx(ll,3,1),derx(ll,4,1),
10422 c     &   derx(ll,5,1),k,l," derx",derx(ll,2,2),derx(ll,3,2),
10423 c     &   derx(ll,4,2),derx(ll,5,2)," ekont",ekont
10424 c        write (iout,'(a,3i3,a,3f8.3,2i3,a,3f8.3)')
10425 c     &   "ecorr5",ll,i,j," gradcorr5",g_contij(ll,1),derx(ll,1,1),
10426 c     &   gradcorr5ij,
10427 c     &   k,l," gradcorr5",g_contij(ll,2),derx(ll,1,2),gradcorr5kl
10428 cold        ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
10429 cgrad        ghalf=0.5d0*ggg1(ll)
10430 cd        ghalf=0.0d0
10431         gradcorr5(ll,i)=gradcorr5(ll,i)+ekont*derx(ll,2,1)
10432         gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
10433         gradcorr5(ll,j)=gradcorr5(ll,j)+ekont*derx(ll,4,1)
10434         gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
10435         gradcorr5_long(ll,j)=gradcorr5_long(ll,j)+gradcorr5ij
10436         gradcorr5_long(ll,i)=gradcorr5_long(ll,i)-gradcorr5ij
10437 cold        ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
10438 cgrad        ghalf=0.5d0*ggg2(ll)
10439 cd        ghalf=0.0d0
10440         gradcorr5(ll,k)=gradcorr5(ll,k)+ekont*derx(ll,2,2)
10441         gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
10442         gradcorr5(ll,l)=gradcorr5(ll,l)+ekont*derx(ll,4,2)
10443         gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
10444         gradcorr5_long(ll,l)=gradcorr5_long(ll,l)+gradcorr5kl
10445         gradcorr5_long(ll,k)=gradcorr5_long(ll,k)-gradcorr5kl
10446       enddo
10447 cd      goto 1112
10448 cgrad      do m=i+1,j-1
10449 cgrad        do ll=1,3
10450 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
10451 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
10452 cgrad        enddo
10453 cgrad      enddo
10454 cgrad      do m=k+1,l-1
10455 cgrad        do ll=1,3
10456 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
10457 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
10458 cgrad        enddo
10459 cgrad      enddo
10460 c1112  continue
10461 cgrad      do m=i+2,j2
10462 cgrad        do ll=1,3
10463 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
10464 cgrad        enddo
10465 cgrad      enddo
10466 cgrad      do m=k+2,l2
10467 cgrad        do ll=1,3
10468 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
10469 cgrad        enddo
10470 cgrad      enddo
10471 cd      do iii=1,nres-3
10472 cd        write (2,*) iii,g_corr5_loc(iii)
10473 cd      enddo
10474       eello5=ekont*eel5
10475 cd      write (2,*) 'ekont',ekont
10476 cd      write (iout,*) 'eello5',ekont*eel5
10477       return
10478       end
10479 c--------------------------------------------------------------------------
10480       double precision function eello6(i,j,k,l,jj,kk)
10481       implicit real*8 (a-h,o-z)
10482       include 'DIMENSIONS'
10483       include 'COMMON.IOUNITS'
10484       include 'COMMON.CHAIN'
10485       include 'COMMON.DERIV'
10486       include 'COMMON.INTERACT'
10487       include 'COMMON.CONTACTS'
10488       include 'COMMON.CONTMAT'
10489       include 'COMMON.CORRMAT'
10490       include 'COMMON.TORSION'
10491       include 'COMMON.VAR'
10492       include 'COMMON.GEO'
10493       include 'COMMON.FFIELD'
10494       double precision ggg1(3),ggg2(3)
10495 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
10496 cd        eello6=0.0d0
10497 cd        return
10498 cd      endif
10499 cd      write (iout,*)
10500 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
10501 cd     &   ' and',k,l
10502       eello6_1=0.0d0
10503       eello6_2=0.0d0
10504       eello6_3=0.0d0
10505       eello6_4=0.0d0
10506       eello6_5=0.0d0
10507       eello6_6=0.0d0
10508 cd      call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
10509 cd     &   eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
10510       do iii=1,2
10511         do kkk=1,5
10512           do lll=1,3
10513             derx(lll,kkk,iii)=0.0d0
10514           enddo
10515         enddo
10516       enddo
10517 cd      eij=facont_hb(jj,i)
10518 cd      ekl=facont_hb(kk,k)
10519 cd      ekont=eij*ekl
10520 cd      eij=1.0d0
10521 cd      ekl=1.0d0
10522 cd      ekont=1.0d0
10523       if (l.eq.j+1) then
10524         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
10525         eello6_2=eello6_graph1(j,i,l,k,2,.false.)
10526         eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
10527         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
10528         eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
10529         eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
10530       else
10531         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
10532         eello6_2=eello6_graph1(l,k,j,i,2,.true.)
10533         eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
10534         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
10535         if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
10536           eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
10537         else
10538           eello6_5=0.0d0
10539         endif
10540         eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
10541       endif
10542 C If turn contributions are considered, they will be handled separately.
10543       eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
10544 cd      write(iout,*) 'eello6_1',eello6_1!,' eel6_1_num',16*eel6_1_num
10545 cd      write(iout,*) 'eello6_2',eello6_2!,' eel6_2_num',16*eel6_2_num
10546 cd      write(iout,*) 'eello6_3',eello6_3!,' eel6_3_num',16*eel6_3_num
10547 cd      write(iout,*) 'eello6_4',eello6_4!,' eel6_4_num',16*eel6_4_num
10548 cd      write(iout,*) 'eello6_5',eello6_5!,' eel6_5_num',16*eel6_5_num
10549 cd      write(iout,*) 'eello6_6',eello6_6!,' eel6_6_num',16*eel6_6_num
10550 cd      goto 1112
10551       if (j.lt.nres-1) then
10552         j1=j+1
10553         j2=j-1
10554       else
10555         j1=j-1
10556         j2=j-2
10557       endif
10558       if (l.lt.nres-1) then
10559         l1=l+1
10560         l2=l-1
10561       else
10562         l1=l-1
10563         l2=l-2
10564       endif
10565       do ll=1,3
10566 cgrad        ggg1(ll)=eel6*g_contij(ll,1)
10567 cgrad        ggg2(ll)=eel6*g_contij(ll,2)
10568 cold        ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
10569 cgrad        ghalf=0.5d0*ggg1(ll)
10570 cd        ghalf=0.0d0
10571         gradcorr6ij=eel6*g_contij(ll,1)+ekont*derx(ll,1,1)
10572         gradcorr6kl=eel6*g_contij(ll,2)+ekont*derx(ll,1,2)
10573         gradcorr6(ll,i)=gradcorr6(ll,i)+ekont*derx(ll,2,1)
10574         gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
10575         gradcorr6(ll,j)=gradcorr6(ll,j)+ekont*derx(ll,4,1)
10576         gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
10577         gradcorr6_long(ll,j)=gradcorr6_long(ll,j)+gradcorr6ij
10578         gradcorr6_long(ll,i)=gradcorr6_long(ll,i)-gradcorr6ij
10579 cgrad        ghalf=0.5d0*ggg2(ll)
10580 cold        ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
10581 cd        ghalf=0.0d0
10582         gradcorr6(ll,k)=gradcorr6(ll,k)+ekont*derx(ll,2,2)
10583         gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
10584         gradcorr6(ll,l)=gradcorr6(ll,l)+ekont*derx(ll,4,2)
10585         gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
10586         gradcorr6_long(ll,l)=gradcorr6_long(ll,l)+gradcorr6kl
10587         gradcorr6_long(ll,k)=gradcorr6_long(ll,k)-gradcorr6kl
10588       enddo
10589 cd      goto 1112
10590 cgrad      do m=i+1,j-1
10591 cgrad        do ll=1,3
10592 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
10593 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
10594 cgrad        enddo
10595 cgrad      enddo
10596 cgrad      do m=k+1,l-1
10597 cgrad        do ll=1,3
10598 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
10599 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
10600 cgrad        enddo
10601 cgrad      enddo
10602 cgrad1112  continue
10603 cgrad      do m=i+2,j2
10604 cgrad        do ll=1,3
10605 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
10606 cgrad        enddo
10607 cgrad      enddo
10608 cgrad      do m=k+2,l2
10609 cgrad        do ll=1,3
10610 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
10611 cgrad        enddo
10612 cgrad      enddo
10613 cd      do iii=1,nres-3
10614 cd        write (2,*) iii,g_corr6_loc(iii)
10615 cd      enddo
10616       eello6=ekont*eel6
10617 cd      write (2,*) 'ekont',ekont
10618 cd      write (iout,*) 'eello6',ekont*eel6
10619       return
10620       end
10621 c--------------------------------------------------------------------------
10622       double precision function eello6_graph1(i,j,k,l,imat,swap)
10623       implicit real*8 (a-h,o-z)
10624       include 'DIMENSIONS'
10625       include 'COMMON.IOUNITS'
10626       include 'COMMON.CHAIN'
10627       include 'COMMON.DERIV'
10628       include 'COMMON.INTERACT'
10629       include 'COMMON.CONTACTS'
10630       include 'COMMON.CONTMAT'
10631       include 'COMMON.CORRMAT'
10632       include 'COMMON.TORSION'
10633       include 'COMMON.VAR'
10634       include 'COMMON.GEO'
10635       double precision vv(2),vv1(2),pizda(2,2),auxmat(2,2),pizda1(2,2)
10636       logical swap
10637       logical lprn
10638       common /kutas/ lprn
10639 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10640 C                                                                              C
10641 C      Parallel       Antiparallel                                             C
10642 C                                                                              C
10643 C          o             o                                                     C
10644 C         /l\           /j\                                                    C
10645 C        /   \         /   \                                                   C
10646 C       /| o |         | o |\                                                  C
10647 C     \ j|/k\|  /   \  |/k\|l /                                                C
10648 C      \ /   \ /     \ /   \ /                                                 C
10649 C       o     o       o     o                                                  C
10650 C       i             i                                                        C
10651 C                                                                              C
10652 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10653       itk=itype2loc(itype(k))
10654       s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
10655       s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
10656       s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
10657       call transpose2(EUgC(1,1,k),auxmat(1,1))
10658       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
10659       vv1(1)=pizda1(1,1)-pizda1(2,2)
10660       vv1(2)=pizda1(1,2)+pizda1(2,1)
10661       s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
10662       vv(1)=AEAb1(1,2,imat)*b1(1,k)-AEAb1(2,2,imat)*b1(2,k)
10663       vv(2)=AEAb1(1,2,imat)*b1(2,k)+AEAb1(2,2,imat)*b1(1,k)
10664       s5=scalar2(vv(1),Dtobr2(1,i))
10665 cd      write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
10666       eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
10667       if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1)
10668      & -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i))
10669      & -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k))
10670      & +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k))
10671      & +0.5d0*scalar2(vv1(1),Dtobr2der(1,i))
10672      & +scalar2(vv(1),Dtobr2der(1,i)))
10673       call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
10674       vv1(1)=pizda1(1,1)-pizda1(2,2)
10675       vv1(2)=pizda1(1,2)+pizda1(2,1)
10676       vv(1)=AEAb1derg(1,2,imat)*b1(1,k)-AEAb1derg(2,2,imat)*b1(2,k)
10677       vv(2)=AEAb1derg(1,2,imat)*b1(2,k)+AEAb1derg(2,2,imat)*b1(1,k)
10678       if (l.eq.j+1) then
10679         g_corr6_loc(l-1)=g_corr6_loc(l-1)
10680      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
10681      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
10682      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
10683      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
10684       else
10685         g_corr6_loc(j-1)=g_corr6_loc(j-1)
10686      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
10687      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
10688      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
10689      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
10690       endif
10691       call transpose2(EUgCder(1,1,k),auxmat(1,1))
10692       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
10693       vv1(1)=pizda1(1,1)-pizda1(2,2)
10694       vv1(2)=pizda1(1,2)+pizda1(2,1)
10695       if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1)
10696      & +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k))
10697      & +scalar2(AEAb2(1,1,imat),CUgb2der(1,k))
10698      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
10699       do iii=1,2
10700         if (swap) then
10701           ind=3-iii
10702         else
10703           ind=iii
10704         endif
10705         do kkk=1,5
10706           do lll=1,3
10707             s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
10708             s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
10709             s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
10710             call transpose2(EUgC(1,1,k),auxmat(1,1))
10711             call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
10712      &        pizda1(1,1))
10713             vv1(1)=pizda1(1,1)-pizda1(2,2)
10714             vv1(2)=pizda1(1,2)+pizda1(2,1)
10715             s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
10716             vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,k)
10717      &       -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,k)
10718             vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,k)
10719      &       +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,k)
10720             s5=scalar2(vv(1),Dtobr2(1,i))
10721             derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
10722           enddo
10723         enddo
10724       enddo
10725       return
10726       end
10727 c----------------------------------------------------------------------------
10728       double precision function eello6_graph2(i,j,k,l,jj,kk,swap)
10729       implicit real*8 (a-h,o-z)
10730       include 'DIMENSIONS'
10731       include 'COMMON.IOUNITS'
10732       include 'COMMON.CHAIN'
10733       include 'COMMON.DERIV'
10734       include 'COMMON.INTERACT'
10735       include 'COMMON.CONTACTS'
10736       include 'COMMON.CONTMAT'
10737       include 'COMMON.CORRMAT'
10738       include 'COMMON.TORSION'
10739       include 'COMMON.VAR'
10740       include 'COMMON.GEO'
10741       logical swap
10742       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
10743      & auxvec1(2),auxvec2(2),auxmat1(2,2)
10744       logical lprn
10745       common /kutas/ lprn
10746 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10747 C                                                                              C
10748 C      Parallel       Antiparallel                                             C
10749 C                                                                              C
10750 C          o             o                                                     C
10751 C     \   /l\           /j\   /                                                C
10752 C      \ /   \         /   \ /                                                 C
10753 C       o| o |         | o |o                                                  C
10754 C     \ j|/k\|      \  |/k\|l                                                  C
10755 C      \ /   \       \ /   \                                                   C
10756 C       o             o                                                        C
10757 C       i             i                                                        C
10758 C                                                                              C
10759 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10760 cd      write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
10761 C AL 7/4/01 s1 would occur in the sixth-order moment,
10762 C           but not in a cluster cumulant
10763 #ifdef MOMENT
10764       s1=dip(1,jj,i)*dip(1,kk,k)
10765 #endif
10766       call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
10767       s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
10768       call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
10769       s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
10770       call transpose2(EUg(1,1,k),auxmat(1,1))
10771       call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
10772       vv(1)=pizda(1,1)-pizda(2,2)
10773       vv(2)=pizda(1,2)+pizda(2,1)
10774       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
10775 cd      write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
10776 #ifdef MOMENT
10777       eello6_graph2=-(s1+s2+s3+s4)
10778 #else
10779       eello6_graph2=-(s2+s3+s4)
10780 #endif
10781 c      eello6_graph2=-s3
10782 C Derivatives in gamma(i-1)
10783       if (i.gt.1) then
10784 #ifdef MOMENT
10785         s1=dipderg(1,jj,i)*dip(1,kk,k)
10786 #endif
10787         s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
10788         call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
10789         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
10790         s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
10791 #ifdef MOMENT
10792         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
10793 #else
10794         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
10795 #endif
10796 c        g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
10797       endif
10798 C Derivatives in gamma(k-1)
10799 #ifdef MOMENT
10800       s1=dip(1,jj,i)*dipderg(1,kk,k)
10801 #endif
10802       call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
10803       s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
10804       call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
10805       s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
10806       call transpose2(EUgder(1,1,k),auxmat1(1,1))
10807       call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
10808       vv(1)=pizda(1,1)-pizda(2,2)
10809       vv(2)=pizda(1,2)+pizda(2,1)
10810       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
10811 #ifdef MOMENT
10812       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
10813 #else
10814       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
10815 #endif
10816 c      g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
10817 C Derivatives in gamma(j-1) or gamma(l-1)
10818       if (j.gt.1) then
10819 #ifdef MOMENT
10820         s1=dipderg(3,jj,i)*dip(1,kk,k)
10821 #endif
10822         call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
10823         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
10824         s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
10825         call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
10826         vv(1)=pizda(1,1)-pizda(2,2)
10827         vv(2)=pizda(1,2)+pizda(2,1)
10828         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
10829 #ifdef MOMENT
10830         if (swap) then
10831           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
10832         else
10833           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
10834         endif
10835 #endif
10836         g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
10837 c        g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
10838       endif
10839 C Derivatives in gamma(l-1) or gamma(j-1)
10840       if (l.gt.1) then
10841 #ifdef MOMENT
10842         s1=dip(1,jj,i)*dipderg(3,kk,k)
10843 #endif
10844         call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
10845         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
10846         call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
10847         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
10848         call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
10849         vv(1)=pizda(1,1)-pizda(2,2)
10850         vv(2)=pizda(1,2)+pizda(2,1)
10851         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
10852 #ifdef MOMENT
10853         if (swap) then
10854           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
10855         else
10856           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
10857         endif
10858 #endif
10859         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
10860 c        g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
10861       endif
10862 C Cartesian derivatives.
10863       if (lprn) then
10864         write (2,*) 'In eello6_graph2'
10865         do iii=1,2
10866           write (2,*) 'iii=',iii
10867           do kkk=1,5
10868             write (2,*) 'kkk=',kkk
10869             do jjj=1,2
10870               write (2,'(3(2f10.5),5x)')
10871      &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
10872             enddo
10873           enddo
10874         enddo
10875       endif
10876       do iii=1,2
10877         do kkk=1,5
10878           do lll=1,3
10879 #ifdef MOMENT
10880             if (iii.eq.1) then
10881               s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
10882             else
10883               s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
10884             endif
10885 #endif
10886             call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),
10887      &        auxvec(1))
10888             s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
10889             call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),
10890      &        auxvec(1))
10891             s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
10892             call transpose2(EUg(1,1,k),auxmat(1,1))
10893             call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),
10894      &        pizda(1,1))
10895             vv(1)=pizda(1,1)-pizda(2,2)
10896             vv(2)=pizda(1,2)+pizda(2,1)
10897             s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
10898 cd            write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
10899 #ifdef MOMENT
10900             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
10901 #else
10902             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
10903 #endif
10904             if (swap) then
10905               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
10906             else
10907               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
10908             endif
10909           enddo
10910         enddo
10911       enddo
10912       return
10913       end
10914 c----------------------------------------------------------------------------
10915       double precision function eello6_graph3(i,j,k,l,jj,kk,swap)
10916       implicit real*8 (a-h,o-z)
10917       include 'DIMENSIONS'
10918       include 'COMMON.IOUNITS'
10919       include 'COMMON.CHAIN'
10920       include 'COMMON.DERIV'
10921       include 'COMMON.INTERACT'
10922       include 'COMMON.CONTACTS'
10923       include 'COMMON.CONTMAT'
10924       include 'COMMON.CORRMAT'
10925       include 'COMMON.TORSION'
10926       include 'COMMON.VAR'
10927       include 'COMMON.GEO'
10928       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2)
10929       logical swap
10930 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10931 C                                                                              C
10932 C      Parallel       Antiparallel                                             C
10933 C                                                                              C
10934 C          o             o                                                     C
10935 C         /l\   /   \   /j\                                                    C
10936 C        /   \ /     \ /   \                                                   C
10937 C       /| o |o       o| o |\                                                  C
10938 C       j|/k\|  /      |/k\|l /                                                C
10939 C        /   \ /       /   \ /                                                 C
10940 C       /     o       /     o                                                  C
10941 C       i             i                                                        C
10942 C                                                                              C
10943 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10944 C
10945 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
10946 C           energy moment and not to the cluster cumulant.
10947       iti=itortyp(itype(i))
10948       if (j.lt.nres-1) then
10949         itj1=itype2loc(itype(j+1))
10950       else
10951         itj1=nloctyp
10952       endif
10953       itk=itype2loc(itype(k))
10954       itk1=itype2loc(itype(k+1))
10955       if (l.lt.nres-1) then
10956         itl1=itype2loc(itype(l+1))
10957       else
10958         itl1=nloctyp
10959       endif
10960 #ifdef MOMENT
10961       s1=dip(4,jj,i)*dip(4,kk,k)
10962 #endif
10963       call matvec2(AECA(1,1,1),b1(1,k+1),auxvec(1))
10964       s2=0.5d0*scalar2(b1(1,k),auxvec(1))
10965       call matvec2(AECA(1,1,2),b1(1,l+1),auxvec(1))
10966       s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
10967       call transpose2(EE(1,1,k),auxmat(1,1))
10968       call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
10969       vv(1)=pizda(1,1)+pizda(2,2)
10970       vv(2)=pizda(2,1)-pizda(1,2)
10971       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
10972 cd      write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4,
10973 cd     & "sum",-(s2+s3+s4)
10974 #ifdef MOMENT
10975       eello6_graph3=-(s1+s2+s3+s4)
10976 #else
10977       eello6_graph3=-(s2+s3+s4)
10978 #endif
10979 c      eello6_graph3=-s4
10980 C Derivatives in gamma(k-1)
10981       call matvec2(AECAderg(1,1,2),b1(1,l+1),auxvec(1))
10982       s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
10983       s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
10984       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
10985 C Derivatives in gamma(l-1)
10986       call matvec2(AECAderg(1,1,1),b1(1,k+1),auxvec(1))
10987       s2=0.5d0*scalar2(b1(1,k),auxvec(1))
10988       call matmat2(auxmat(1,1),AECAderg(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       g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
10993 C Cartesian derivatives.
10994       do iii=1,2
10995         do kkk=1,5
10996           do lll=1,3
10997 #ifdef MOMENT
10998             if (iii.eq.1) then
10999               s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
11000             else
11001               s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
11002             endif
11003 #endif
11004             call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
11005      &        auxvec(1))
11006             s2=0.5d0*scalar2(b1(1,k),auxvec(1))
11007             call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,l+1),
11008      &        auxvec(1))
11009             s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
11010             call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),
11011      &        pizda(1,1))
11012             vv(1)=pizda(1,1)+pizda(2,2)
11013             vv(2)=pizda(2,1)-pizda(1,2)
11014             s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
11015 #ifdef MOMENT
11016             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
11017 #else
11018             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
11019 #endif
11020             if (swap) then
11021               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
11022             else
11023               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
11024             endif
11025 c            derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
11026           enddo
11027         enddo
11028       enddo
11029       return
11030       end
11031 c----------------------------------------------------------------------------
11032       double precision function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
11033       implicit real*8 (a-h,o-z)
11034       include 'DIMENSIONS'
11035       include 'COMMON.IOUNITS'
11036       include 'COMMON.CHAIN'
11037       include 'COMMON.DERIV'
11038       include 'COMMON.INTERACT'
11039       include 'COMMON.CONTACTS'
11040       include 'COMMON.CONTMAT'
11041       include 'COMMON.CORRMAT'
11042       include 'COMMON.TORSION'
11043       include 'COMMON.VAR'
11044       include 'COMMON.GEO'
11045       include 'COMMON.FFIELD'
11046       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
11047      & auxvec1(2),auxmat1(2,2)
11048       logical swap
11049 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
11050 C                                                                              C
11051 C      Parallel       Antiparallel                                             C
11052 C                                                                              C
11053 C          o             o                                                     C
11054 C         /l\   /   \   /j\                                                    C
11055 C        /   \ /     \ /   \                                                   C
11056 C       /| o |o       o| o |\                                                  C
11057 C     \ j|/k\|      \  |/k\|l                                                  C
11058 C      \ /   \       \ /   \                                                   C
11059 C       o     \       o     \                                                  C
11060 C       i             i                                                        C
11061 C                                                                              C
11062 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
11063 C
11064 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
11065 C           energy moment and not to the cluster cumulant.
11066 cd      write (2,*) 'eello_graph4: wturn6',wturn6
11067       iti=itype2loc(itype(i))
11068       itj=itype2loc(itype(j))
11069       if (j.lt.nres-1) then
11070         itj1=itype2loc(itype(j+1))
11071       else
11072         itj1=nloctyp
11073       endif
11074       itk=itype2loc(itype(k))
11075       if (k.lt.nres-1) then
11076         itk1=itype2loc(itype(k+1))
11077       else
11078         itk1=nloctyp
11079       endif
11080       itl=itype2loc(itype(l))
11081       if (l.lt.nres-1) then
11082         itl1=itype2loc(itype(l+1))
11083       else
11084         itl1=nloctyp
11085       endif
11086 cd      write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
11087 cd      write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
11088 cd     & ' itl',itl,' itl1',itl1
11089 #ifdef MOMENT
11090       if (imat.eq.1) then
11091         s1=dip(3,jj,i)*dip(3,kk,k)
11092       else
11093         s1=dip(2,jj,j)*dip(2,kk,l)
11094       endif
11095 #endif
11096       call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
11097       s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
11098       if (j.eq.l+1) then
11099         call matvec2(ADtEA1(1,1,3-imat),b1(1,j+1),auxvec1(1))
11100         s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
11101       else
11102         call matvec2(ADtEA1(1,1,3-imat),b1(1,l+1),auxvec1(1))
11103         s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
11104       endif
11105       call transpose2(EUg(1,1,k),auxmat(1,1))
11106       call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
11107       vv(1)=pizda(1,1)-pizda(2,2)
11108       vv(2)=pizda(2,1)+pizda(1,2)
11109       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
11110 cd      write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
11111 #ifdef MOMENT
11112       eello6_graph4=-(s1+s2+s3+s4)
11113 #else
11114       eello6_graph4=-(s2+s3+s4)
11115 #endif
11116 C Derivatives in gamma(i-1)
11117       if (i.gt.1) then
11118 #ifdef MOMENT
11119         if (imat.eq.1) then
11120           s1=dipderg(2,jj,i)*dip(3,kk,k)
11121         else
11122           s1=dipderg(4,jj,j)*dip(2,kk,l)
11123         endif
11124 #endif
11125         s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
11126         if (j.eq.l+1) then
11127           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,j+1),auxvec1(1))
11128           s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
11129         else
11130           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,l+1),auxvec1(1))
11131           s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
11132         endif
11133         s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
11134         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
11135 cd          write (2,*) 'turn6 derivatives'
11136 #ifdef MOMENT
11137           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
11138 #else
11139           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
11140 #endif
11141         else
11142 #ifdef MOMENT
11143           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
11144 #else
11145           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
11146 #endif
11147         endif
11148       endif
11149 C Derivatives in gamma(k-1)
11150 #ifdef MOMENT
11151       if (imat.eq.1) then
11152         s1=dip(3,jj,i)*dipderg(2,kk,k)
11153       else
11154         s1=dip(2,jj,j)*dipderg(4,kk,l)
11155       endif
11156 #endif
11157       call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
11158       s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
11159       if (j.eq.l+1) then
11160         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,j+1),auxvec1(1))
11161         s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
11162       else
11163         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,l+1),auxvec1(1))
11164         s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
11165       endif
11166       call transpose2(EUgder(1,1,k),auxmat1(1,1))
11167       call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
11168       vv(1)=pizda(1,1)-pizda(2,2)
11169       vv(2)=pizda(2,1)+pizda(1,2)
11170       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
11171       if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
11172 #ifdef MOMENT
11173         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
11174 #else
11175         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
11176 #endif
11177       else
11178 #ifdef MOMENT
11179         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
11180 #else
11181         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
11182 #endif
11183       endif
11184 C Derivatives in gamma(j-1) or gamma(l-1)
11185       if (l.eq.j+1 .and. l.gt.1) then
11186         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
11187         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
11188         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
11189         vv(1)=pizda(1,1)-pizda(2,2)
11190         vv(2)=pizda(2,1)+pizda(1,2)
11191         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
11192         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
11193       else if (j.gt.1) then
11194         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
11195         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
11196         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
11197         vv(1)=pizda(1,1)-pizda(2,2)
11198         vv(2)=pizda(2,1)+pizda(1,2)
11199         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
11200         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
11201           gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
11202         else
11203           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
11204         endif
11205       endif
11206 C Cartesian derivatives.
11207       do iii=1,2
11208         do kkk=1,5
11209           do lll=1,3
11210 #ifdef MOMENT
11211             if (iii.eq.1) then
11212               if (imat.eq.1) then
11213                 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
11214               else
11215                 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
11216               endif
11217             else
11218               if (imat.eq.1) then
11219                 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
11220               else
11221                 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
11222               endif
11223             endif
11224 #endif
11225             call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),
11226      &        auxvec(1))
11227             s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
11228             if (j.eq.l+1) then
11229               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
11230      &          b1(1,j+1),auxvec(1))
11231               s3=-0.5d0*scalar2(b1(1,j),auxvec(1))
11232             else
11233               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
11234      &          b1(1,l+1),auxvec(1))
11235               s3=-0.5d0*scalar2(b1(1,l),auxvec(1))
11236             endif
11237             call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
11238      &        pizda(1,1))
11239             vv(1)=pizda(1,1)-pizda(2,2)
11240             vv(2)=pizda(2,1)+pizda(1,2)
11241             s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
11242             if (swap) then
11243               if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
11244 #ifdef MOMENT
11245                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
11246      &             -(s1+s2+s4)
11247 #else
11248                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
11249      &             -(s2+s4)
11250 #endif
11251                 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
11252               else
11253 #ifdef MOMENT
11254                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
11255 #else
11256                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
11257 #endif
11258                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
11259               endif
11260             else
11261 #ifdef MOMENT
11262               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
11263 #else
11264               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
11265 #endif
11266               if (l.eq.j+1) then
11267                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
11268               else
11269                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
11270               endif
11271             endif
11272           enddo
11273         enddo
11274       enddo
11275       return
11276       end
11277 c----------------------------------------------------------------------------
11278       double precision function eello_turn6(i,jj,kk)
11279       implicit real*8 (a-h,o-z)
11280       include 'DIMENSIONS'
11281       include 'COMMON.IOUNITS'
11282       include 'COMMON.CHAIN'
11283       include 'COMMON.DERIV'
11284       include 'COMMON.INTERACT'
11285       include 'COMMON.CONTACTS'
11286       include 'COMMON.CONTMAT'
11287       include 'COMMON.CORRMAT'
11288       include 'COMMON.TORSION'
11289       include 'COMMON.VAR'
11290       include 'COMMON.GEO'
11291       double precision vtemp1(2),vtemp2(2),vtemp3(2),vtemp4(2),
11292      &  atemp(2,2),auxmat(2,2),achuj_temp(2,2),gtemp(2,2),gvec(2),
11293      &  ggg1(3),ggg2(3)
11294       double precision vtemp1d(2),vtemp2d(2),vtemp3d(2),vtemp4d(2),
11295      &  atempd(2,2),auxmatd(2,2),achuj_tempd(2,2),gtempd(2,2),gvecd(2)
11296 C 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
11297 C           the respective energy moment and not to the cluster cumulant.
11298       s1=0.0d0
11299       s8=0.0d0
11300       s13=0.0d0
11301 c
11302       eello_turn6=0.0d0
11303       j=i+4
11304       k=i+1
11305       l=i+3
11306       iti=itype2loc(itype(i))
11307       itk=itype2loc(itype(k))
11308       itk1=itype2loc(itype(k+1))
11309       itl=itype2loc(itype(l))
11310       itj=itype2loc(itype(j))
11311 cd      write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
11312 cd      write (2,*) 'i',i,' k',k,' j',j,' l',l
11313 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
11314 cd        eello6=0.0d0
11315 cd        return
11316 cd      endif
11317 cd      write (iout,*)
11318 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
11319 cd     &   ' and',k,l
11320 cd      call checkint_turn6(i,jj,kk,eel_turn6_num)
11321       do iii=1,2
11322         do kkk=1,5
11323           do lll=1,3
11324             derx_turn(lll,kkk,iii)=0.0d0
11325           enddo
11326         enddo
11327       enddo
11328 cd      eij=1.0d0
11329 cd      ekl=1.0d0
11330 cd      ekont=1.0d0
11331       eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
11332 cd      eello6_5=0.0d0
11333 cd      write (2,*) 'eello6_5',eello6_5
11334 #ifdef MOMENT
11335       call transpose2(AEA(1,1,1),auxmat(1,1))
11336       call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
11337       ss1=scalar2(Ub2(1,i+2),b1(1,l))
11338       s1 = (auxmat(1,1)+auxmat(2,2))*ss1
11339 #endif
11340       call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1(1))
11341       call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
11342       s2 = scalar2(b1(1,k),vtemp1(1))
11343 #ifdef MOMENT
11344       call transpose2(AEA(1,1,2),atemp(1,1))
11345       call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
11346       call matvec2(Ug2(1,1,i+2),dd(1,1,k+1),vtemp2(1))
11347       s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,l),vtemp2(1))
11348 #endif
11349       call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
11350       call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
11351       s12 = scalar2(Ub2(1,i+2),vtemp3(1))
11352 #ifdef MOMENT
11353       call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
11354       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
11355       call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
11356       call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
11357       ss13 = scalar2(b1(1,k),vtemp4(1))
11358       s13 = (gtemp(1,1)+gtemp(2,2))*ss13
11359 #endif
11360 c      write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
11361 c      s1=0.0d0
11362 c      s2=0.0d0
11363 c      s8=0.0d0
11364 c      s12=0.0d0
11365 c      s13=0.0d0
11366       eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
11367 C Derivatives in gamma(i+2)
11368       s1d =0.0d0
11369       s8d =0.0d0
11370 #ifdef MOMENT
11371       call transpose2(AEA(1,1,1),auxmatd(1,1))
11372       call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
11373       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
11374       call transpose2(AEAderg(1,1,2),atempd(1,1))
11375       call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
11376       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,l),vtemp2(1))
11377 #endif
11378       call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
11379       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
11380       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
11381 c      s1d=0.0d0
11382 c      s2d=0.0d0
11383 c      s8d=0.0d0
11384 c      s12d=0.0d0
11385 c      s13d=0.0d0
11386       gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
11387 C Derivatives in gamma(i+3)
11388 #ifdef MOMENT
11389       call transpose2(AEA(1,1,1),auxmatd(1,1))
11390       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
11391       ss1d=scalar2(Ub2der(1,i+2),b1(1,l))
11392       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
11393 #endif
11394       call matvec2(EUgder(1,1,i+2),b1(1,l),vtemp1d(1))
11395       call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
11396       s2d = scalar2(b1(1,k),vtemp1d(1))
11397 #ifdef MOMENT
11398       call matvec2(Ug2der(1,1,i+2),dd(1,1,k+1),vtemp2d(1))
11399       s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,l),vtemp2d(1))
11400 #endif
11401       s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
11402 #ifdef MOMENT
11403       call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
11404       call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
11405       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
11406 #endif
11407 c      s1d=0.0d0
11408 c      s2d=0.0d0
11409 c      s8d=0.0d0
11410 c      s12d=0.0d0
11411 c      s13d=0.0d0
11412 #ifdef MOMENT
11413       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
11414      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
11415 #else
11416       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
11417      &               -0.5d0*ekont*(s2d+s12d)
11418 #endif
11419 C Derivatives in gamma(i+4)
11420       call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
11421       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
11422       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
11423 #ifdef MOMENT
11424       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
11425       call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
11426       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
11427 #endif
11428 c      s1d=0.0d0
11429 c      s2d=0.0d0
11430 c      s8d=0.0d0
11431 C      s12d=0.0d0
11432 c      s13d=0.0d0
11433 #ifdef MOMENT
11434       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
11435 #else
11436       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
11437 #endif
11438 C Derivatives in gamma(i+5)
11439 #ifdef MOMENT
11440       call transpose2(AEAderg(1,1,1),auxmatd(1,1))
11441       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
11442       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
11443 #endif
11444       call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1d(1))
11445       call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
11446       s2d = scalar2(b1(1,k),vtemp1d(1))
11447 #ifdef MOMENT
11448       call transpose2(AEA(1,1,2),atempd(1,1))
11449       call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
11450       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,l),vtemp2(1))
11451 #endif
11452       call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
11453       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
11454 #ifdef MOMENT
11455       call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
11456       ss13d = scalar2(b1(1,k),vtemp4d(1))
11457       s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
11458 #endif
11459 c      s1d=0.0d0
11460 c      s2d=0.0d0
11461 c      s8d=0.0d0
11462 c      s12d=0.0d0
11463 c      s13d=0.0d0
11464 #ifdef MOMENT
11465       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
11466      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
11467 #else
11468       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
11469      &               -0.5d0*ekont*(s2d+s12d)
11470 #endif
11471 C Cartesian derivatives
11472       do iii=1,2
11473         do kkk=1,5
11474           do lll=1,3
11475 #ifdef MOMENT
11476             call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
11477             call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
11478             s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
11479 #endif
11480             call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1(1))
11481             call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),
11482      &          vtemp1d(1))
11483             s2d = scalar2(b1(1,k),vtemp1d(1))
11484 #ifdef MOMENT
11485             call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
11486             call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
11487             s8d = -(atempd(1,1)+atempd(2,2))*
11488      &           scalar2(cc(1,1,l),vtemp2(1))
11489 #endif
11490             call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),
11491      &           auxmatd(1,1))
11492             call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
11493             s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
11494 c      s1d=0.0d0
11495 c      s2d=0.0d0
11496 c      s8d=0.0d0
11497 c      s12d=0.0d0
11498 c      s13d=0.0d0
11499 #ifdef MOMENT
11500             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
11501      &        - 0.5d0*(s1d+s2d)
11502 #else
11503             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
11504      &        - 0.5d0*s2d
11505 #endif
11506 #ifdef MOMENT
11507             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
11508      &        - 0.5d0*(s8d+s12d)
11509 #else
11510             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
11511      &        - 0.5d0*s12d
11512 #endif
11513           enddo
11514         enddo
11515       enddo
11516 #ifdef MOMENT
11517       do kkk=1,5
11518         do lll=1,3
11519           call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),
11520      &      achuj_tempd(1,1))
11521           call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
11522           call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
11523           s13d=(gtempd(1,1)+gtempd(2,2))*ss13
11524           derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
11525           call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),
11526      &      vtemp4d(1))
11527           ss13d = scalar2(b1(1,k),vtemp4d(1))
11528           s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
11529           derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
11530         enddo
11531       enddo
11532 #endif
11533 cd      write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
11534 cd     &  16*eel_turn6_num
11535 cd      goto 1112
11536       if (j.lt.nres-1) then
11537         j1=j+1
11538         j2=j-1
11539       else
11540         j1=j-1
11541         j2=j-2
11542       endif
11543       if (l.lt.nres-1) then
11544         l1=l+1
11545         l2=l-1
11546       else
11547         l1=l-1
11548         l2=l-2
11549       endif
11550       do ll=1,3
11551 cgrad        ggg1(ll)=eel_turn6*g_contij(ll,1)
11552 cgrad        ggg2(ll)=eel_turn6*g_contij(ll,2)
11553 cgrad        ghalf=0.5d0*ggg1(ll)
11554 cd        ghalf=0.0d0
11555         gturn6ij=eel_turn6*g_contij(ll,1)+ekont*derx_turn(ll,1,1)
11556         gturn6kl=eel_turn6*g_contij(ll,2)+ekont*derx_turn(ll,1,2)
11557         gcorr6_turn(ll,i)=gcorr6_turn(ll,i)!+ghalf
11558      &    +ekont*derx_turn(ll,2,1)
11559         gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
11560         gcorr6_turn(ll,j)=gcorr6_turn(ll,j)!+ghalf
11561      &    +ekont*derx_turn(ll,4,1)
11562         gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
11563         gcorr6_turn_long(ll,j)=gcorr6_turn_long(ll,j)+gturn6ij
11564         gcorr6_turn_long(ll,i)=gcorr6_turn_long(ll,i)-gturn6ij
11565 cgrad        ghalf=0.5d0*ggg2(ll)
11566 cd        ghalf=0.0d0
11567         gcorr6_turn(ll,k)=gcorr6_turn(ll,k)!+ghalf
11568      &    +ekont*derx_turn(ll,2,2)
11569         gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
11570         gcorr6_turn(ll,l)=gcorr6_turn(ll,l)!+ghalf
11571      &    +ekont*derx_turn(ll,4,2)
11572         gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
11573         gcorr6_turn_long(ll,l)=gcorr6_turn_long(ll,l)+gturn6kl
11574         gcorr6_turn_long(ll,k)=gcorr6_turn_long(ll,k)-gturn6kl
11575       enddo
11576 cd      goto 1112
11577 cgrad      do m=i+1,j-1
11578 cgrad        do ll=1,3
11579 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
11580 cgrad        enddo
11581 cgrad      enddo
11582 cgrad      do m=k+1,l-1
11583 cgrad        do ll=1,3
11584 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
11585 cgrad        enddo
11586 cgrad      enddo
11587 cgrad1112  continue
11588 cgrad      do m=i+2,j2
11589 cgrad        do ll=1,3
11590 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
11591 cgrad        enddo
11592 cgrad      enddo
11593 cgrad      do m=k+2,l2
11594 cgrad        do ll=1,3
11595 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
11596 cgrad        enddo
11597 cgrad      enddo
11598 cd      do iii=1,nres-3
11599 cd        write (2,*) iii,g_corr6_loc(iii)
11600 cd      enddo
11601       eello_turn6=ekont*eel_turn6
11602 cd      write (2,*) 'ekont',ekont
11603 cd      write (2,*) 'eel_turn6',ekont*eel_turn6
11604       return
11605       end
11606 C-----------------------------------------------------------------------------
11607 #endif
11608       double precision function scalar(u,v)
11609 !DIR$ INLINEALWAYS scalar
11610 #ifndef OSF
11611 cDEC$ ATTRIBUTES FORCEINLINE::scalar
11612 #endif
11613       implicit none
11614       double precision u(3),v(3)
11615 cd      double precision sc
11616 cd      integer i
11617 cd      sc=0.0d0
11618 cd      do i=1,3
11619 cd        sc=sc+u(i)*v(i)
11620 cd      enddo
11621 cd      scalar=sc
11622
11623       scalar=u(1)*v(1)+u(2)*v(2)+u(3)*v(3)
11624       return
11625       end
11626 crc-------------------------------------------------
11627       SUBROUTINE MATVEC2(A1,V1,V2)
11628 !DIR$ INLINEALWAYS MATVEC2
11629 #ifndef OSF
11630 cDEC$ ATTRIBUTES FORCEINLINE::MATVEC2
11631 #endif
11632       implicit real*8 (a-h,o-z)
11633       include 'DIMENSIONS'
11634       DIMENSION A1(2,2),V1(2),V2(2)
11635 c      DO 1 I=1,2
11636 c        VI=0.0
11637 c        DO 3 K=1,2
11638 c    3     VI=VI+A1(I,K)*V1(K)
11639 c        Vaux(I)=VI
11640 c    1 CONTINUE
11641
11642       vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
11643       vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
11644
11645       v2(1)=vaux1
11646       v2(2)=vaux2
11647       END
11648 C---------------------------------------
11649       SUBROUTINE MATMAT2(A1,A2,A3)
11650 #ifndef OSF
11651 cDEC$ ATTRIBUTES FORCEINLINE::MATMAT2
11652 #endif
11653       implicit real*8 (a-h,o-z)
11654       include 'DIMENSIONS'
11655       DIMENSION A1(2,2),A2(2,2),A3(2,2)
11656 c      DIMENSION AI3(2,2)
11657 c        DO  J=1,2
11658 c          A3IJ=0.0
11659 c          DO K=1,2
11660 c           A3IJ=A3IJ+A1(I,K)*A2(K,J)
11661 c          enddo
11662 c          A3(I,J)=A3IJ
11663 c       enddo
11664 c      enddo
11665
11666       ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
11667       ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
11668       ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
11669       ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
11670
11671       A3(1,1)=AI3_11
11672       A3(2,1)=AI3_21
11673       A3(1,2)=AI3_12
11674       A3(2,2)=AI3_22
11675       END
11676
11677 c-------------------------------------------------------------------------
11678       double precision function scalar2(u,v)
11679 !DIR$ INLINEALWAYS scalar2
11680       implicit none
11681       double precision u(2),v(2)
11682       double precision sc
11683       integer i
11684       scalar2=u(1)*v(1)+u(2)*v(2)
11685       return
11686       end
11687
11688 C-----------------------------------------------------------------------------
11689
11690       subroutine transpose2(a,at)
11691 !DIR$ INLINEALWAYS transpose2
11692 #ifndef OSF
11693 cDEC$ ATTRIBUTES FORCEINLINE::transpose2
11694 #endif
11695       implicit none
11696       double precision a(2,2),at(2,2)
11697       at(1,1)=a(1,1)
11698       at(1,2)=a(2,1)
11699       at(2,1)=a(1,2)
11700       at(2,2)=a(2,2)
11701       return
11702       end
11703 c--------------------------------------------------------------------------
11704       subroutine transpose(n,a,at)
11705       implicit none
11706       integer n,i,j
11707       double precision a(n,n),at(n,n)
11708       do i=1,n
11709         do j=1,n
11710           at(j,i)=a(i,j)
11711         enddo
11712       enddo
11713       return
11714       end
11715 C---------------------------------------------------------------------------
11716       subroutine prodmat3(a1,a2,kk,transp,prod)
11717 !DIR$ INLINEALWAYS prodmat3
11718 #ifndef OSF
11719 cDEC$ ATTRIBUTES FORCEINLINE::prodmat3
11720 #endif
11721       implicit none
11722       integer i,j
11723       double precision a1(2,2),a2(2,2),a2t(2,2),kk(2,2),prod(2,2)
11724       logical transp
11725 crc      double precision auxmat(2,2),prod_(2,2)
11726
11727       if (transp) then
11728 crc        call transpose2(kk(1,1),auxmat(1,1))
11729 crc        call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
11730 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
11731
11732            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1)
11733      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
11734            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2)
11735      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
11736            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1)
11737      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
11738            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2)
11739      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
11740
11741       else
11742 crc        call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
11743 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
11744
11745            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1)
11746      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
11747            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2)
11748      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
11749            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1)
11750      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
11751            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2)
11752      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
11753
11754       endif
11755 c      call transpose2(a2(1,1),a2t(1,1))
11756
11757 crc      print *,transp
11758 crc      print *,((prod_(i,j),i=1,2),j=1,2)
11759 crc      print *,((prod(i,j),i=1,2),j=1,2)
11760
11761       return
11762       end
11763 CCC----------------------------------------------
11764       subroutine Eliptransfer(eliptran)
11765       implicit real*8 (a-h,o-z)
11766       include 'DIMENSIONS'
11767       include 'COMMON.GEO'
11768       include 'COMMON.VAR'
11769       include 'COMMON.LOCAL'
11770       include 'COMMON.CHAIN'
11771       include 'COMMON.DERIV'
11772       include 'COMMON.NAMES'
11773       include 'COMMON.INTERACT'
11774       include 'COMMON.IOUNITS'
11775       include 'COMMON.CALC'
11776       include 'COMMON.CONTROL'
11777       include 'COMMON.SPLITELE'
11778       include 'COMMON.SBRIDGE'
11779 C this is done by Adasko
11780 C      print *,"wchodze"
11781 C structure of box:
11782 C      water
11783 C--bordliptop-- buffore starts
11784 C--bufliptop--- here true lipid starts
11785 C      lipid
11786 C--buflipbot--- lipid ends buffore starts
11787 C--bordlipbot--buffore ends
11788       eliptran=0.0
11789       do i=ilip_start,ilip_end
11790 C       do i=1,1
11791         if (itype(i).eq.ntyp1) cycle
11792
11793         positi=(mod(((c(3,i)+c(3,i+1))/2.0d0),boxzsize))
11794         if (positi.le.0.0) positi=positi+boxzsize
11795 C        print *,i
11796 C first for peptide groups
11797 c for each residue check if it is in lipid or lipid water border area
11798        if ((positi.gt.bordlipbot)
11799      &.and.(positi.lt.bordliptop)) then
11800 C the energy transfer exist
11801         if (positi.lt.buflipbot) then
11802 C what fraction I am in
11803          fracinbuf=1.0d0-
11804      &        ((positi-bordlipbot)/lipbufthick)
11805 C lipbufthick is thickenes of lipid buffore
11806          sslip=sscalelip(fracinbuf)
11807          ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
11808          eliptran=eliptran+sslip*pepliptran
11809          gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
11810          gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
11811 C         gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
11812
11813 C        print *,"doing sccale for lower part"
11814 C         print *,i,sslip,fracinbuf,ssgradlip
11815         elseif (positi.gt.bufliptop) then
11816          fracinbuf=1.0d0-((bordliptop-positi)/lipbufthick)
11817          sslip=sscalelip(fracinbuf)
11818          ssgradlip=sscagradlip(fracinbuf)/lipbufthick
11819          eliptran=eliptran+sslip*pepliptran
11820          gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
11821          gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
11822 C         gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
11823 C          print *, "doing sscalefor top part"
11824 C         print *,i,sslip,fracinbuf,ssgradlip
11825         else
11826          eliptran=eliptran+pepliptran
11827 C         print *,"I am in true lipid"
11828         endif
11829 C       else
11830 C       eliptran=elpitran+0.0 ! I am in water
11831        endif
11832        enddo
11833 C       print *, "nic nie bylo w lipidzie?"
11834 C now multiply all by the peptide group transfer factor
11835 C       eliptran=eliptran*pepliptran
11836 C now the same for side chains
11837 CV       do i=1,1
11838        do i=ilip_start,ilip_end
11839         if (itype(i).eq.ntyp1) cycle
11840         positi=(mod(c(3,i+nres),boxzsize))
11841         if (positi.le.0) positi=positi+boxzsize
11842 C       print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop
11843 c for each residue check if it is in lipid or lipid water border area
11844 C       respos=mod(c(3,i+nres),boxzsize)
11845 C       print *,positi,bordlipbot,buflipbot
11846        if ((positi.gt.bordlipbot)
11847      & .and.(positi.lt.bordliptop)) then
11848 C the energy transfer exist
11849         if (positi.lt.buflipbot) then
11850          fracinbuf=1.0d0-
11851      &     ((positi-bordlipbot)/lipbufthick)
11852 C lipbufthick is thickenes of lipid buffore
11853          sslip=sscalelip(fracinbuf)
11854          ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
11855          eliptran=eliptran+sslip*liptranene(itype(i))
11856          gliptranx(3,i)=gliptranx(3,i)
11857      &+ssgradlip*liptranene(itype(i))
11858          gliptranc(3,i-1)= gliptranc(3,i-1)
11859      &+ssgradlip*liptranene(itype(i))
11860 C         print *,"doing sccale for lower part"
11861         elseif (positi.gt.bufliptop) then
11862          fracinbuf=1.0d0-
11863      &((bordliptop-positi)/lipbufthick)
11864          sslip=sscalelip(fracinbuf)
11865          ssgradlip=sscagradlip(fracinbuf)/lipbufthick
11866          eliptran=eliptran+sslip*liptranene(itype(i))
11867          gliptranx(3,i)=gliptranx(3,i)
11868      &+ssgradlip*liptranene(itype(i))
11869          gliptranc(3,i-1)= gliptranc(3,i-1)
11870      &+ssgradlip*liptranene(itype(i))
11871 C          print *, "doing sscalefor top part",sslip,fracinbuf
11872         else
11873          eliptran=eliptran+liptranene(itype(i))
11874 C         print *,"I am in true lipid"
11875         endif
11876         endif ! if in lipid or buffor
11877 C       else
11878 C       eliptran=elpitran+0.0 ! I am in water
11879        enddo
11880        return
11881        end
11882 C---------------------------------------------------------
11883 C AFM soubroutine for constant force
11884        subroutine AFMforce(Eafmforce)
11885        implicit real*8 (a-h,o-z)
11886       include 'DIMENSIONS'
11887       include 'COMMON.GEO'
11888       include 'COMMON.VAR'
11889       include 'COMMON.LOCAL'
11890       include 'COMMON.CHAIN'
11891       include 'COMMON.DERIV'
11892       include 'COMMON.NAMES'
11893       include 'COMMON.INTERACT'
11894       include 'COMMON.IOUNITS'
11895       include 'COMMON.CALC'
11896       include 'COMMON.CONTROL'
11897       include 'COMMON.SPLITELE'
11898       include 'COMMON.SBRIDGE'
11899       real*8 diffafm(3)
11900       dist=0.0d0
11901       Eafmforce=0.0d0
11902       do i=1,3
11903       diffafm(i)=c(i,afmend)-c(i,afmbeg)
11904       dist=dist+diffafm(i)**2
11905       enddo
11906       dist=dsqrt(dist)
11907       Eafmforce=-forceAFMconst*(dist-distafminit)
11908       do i=1,3
11909       gradafm(i,afmend-1)=-forceAFMconst*diffafm(i)/dist
11910       gradafm(i,afmbeg-1)=forceAFMconst*diffafm(i)/dist
11911       enddo
11912 C      print *,'AFM',Eafmforce
11913       return
11914       end
11915 C---------------------------------------------------------
11916 C AFM subroutine with pseudoconstant velocity
11917        subroutine AFMvel(Eafmforce)
11918        implicit real*8 (a-h,o-z)
11919       include 'DIMENSIONS'
11920       include 'COMMON.GEO'
11921       include 'COMMON.VAR'
11922       include 'COMMON.LOCAL'
11923       include 'COMMON.CHAIN'
11924       include 'COMMON.DERIV'
11925       include 'COMMON.NAMES'
11926       include 'COMMON.INTERACT'
11927       include 'COMMON.IOUNITS'
11928       include 'COMMON.CALC'
11929       include 'COMMON.CONTROL'
11930       include 'COMMON.SPLITELE'
11931       include 'COMMON.SBRIDGE'
11932       real*8 diffafm(3)
11933 C Only for check grad COMMENT if not used for checkgrad
11934 C      totT=3.0d0
11935 C--------------------------------------------------------
11936 C      print *,"wchodze"
11937       dist=0.0d0
11938       Eafmforce=0.0d0
11939       do i=1,3
11940       diffafm(i)=c(i,afmend)-c(i,afmbeg)
11941       dist=dist+diffafm(i)**2
11942       enddo
11943       dist=dsqrt(dist)
11944       Eafmforce=0.5d0*forceAFMconst
11945      & *(distafminit+totTafm*velAFMconst-dist)**2
11946 C      Eafmforce=-forceAFMconst*(dist-distafminit)
11947       do i=1,3
11948       gradafm(i,afmend-1)=-forceAFMconst*
11949      &(distafminit+totTafm*velAFMconst-dist)
11950      &*diffafm(i)/dist
11951       gradafm(i,afmbeg-1)=forceAFMconst*
11952      &(distafminit+totTafm*velAFMconst-dist)
11953      &*diffafm(i)/dist
11954       enddo
11955 C      print *,'AFM',Eafmforce,totTafm*velAFMconst,dist
11956       return
11957       end
11958 C-----------------------------------------------------------
11959 C first for shielding is setting of function of side-chains
11960        subroutine set_shield_fac
11961       implicit real*8 (a-h,o-z)
11962       include 'DIMENSIONS'
11963       include 'COMMON.CHAIN'
11964       include 'COMMON.DERIV'
11965       include 'COMMON.IOUNITS'
11966       include 'COMMON.SHIELD'
11967       include 'COMMON.INTERACT'
11968 C this is the squar root 77 devided by 81 the epislion in lipid (in protein)
11969       double precision div77_81/0.974996043d0/,
11970      &div4_81/0.2222222222d0/,sh_frac_dist_grad(3)
11971
11972 C the vector between center of side_chain and peptide group
11973        double precision pep_side(3),long,side_calf(3),
11974      &pept_group(3),costhet_grad(3),cosphi_grad_long(3),
11975      &cosphi_grad_loc(3),pep_side_norm(3),side_calf_norm(3)
11976 C the line belowe needs to be changed for FGPROC>1
11977       do i=1,nres-1
11978       if ((itype(i).eq.ntyp1).and.itype(i+1).eq.ntyp1) cycle
11979       ishield_list(i)=0
11980 Cif there two consequtive dummy atoms there is no peptide group between them
11981 C the line below has to be changed for FGPROC>1
11982       VolumeTotal=0.0
11983       do k=1,nres
11984        if ((itype(k).eq.ntyp1).or.(itype(k).eq.10)) cycle
11985        dist_pep_side=0.0
11986        dist_side_calf=0.0
11987        do j=1,3
11988 C first lets set vector conecting the ithe side-chain with kth side-chain
11989       pep_side(j)=c(j,k+nres)-(c(j,i)+c(j,i+1))/2.0d0
11990 C      pep_side(j)=2.0d0
11991 C and vector conecting the side-chain with its proper calfa
11992       side_calf(j)=c(j,k+nres)-c(j,k)
11993 C      side_calf(j)=2.0d0
11994       pept_group(j)=c(j,i)-c(j,i+1)
11995 C lets have their lenght
11996       dist_pep_side=pep_side(j)**2+dist_pep_side
11997       dist_side_calf=dist_side_calf+side_calf(j)**2
11998       dist_pept_group=dist_pept_group+pept_group(j)**2
11999       enddo
12000        dist_pep_side=dsqrt(dist_pep_side)
12001        dist_pept_group=dsqrt(dist_pept_group)
12002        dist_side_calf=dsqrt(dist_side_calf)
12003       do j=1,3
12004         pep_side_norm(j)=pep_side(j)/dist_pep_side
12005         side_calf_norm(j)=dist_side_calf
12006       enddo
12007 C now sscale fraction
12008        sh_frac_dist=-(dist_pep_side-rpp(1,1)-buff_shield)/buff_shield
12009 C       print *,buff_shield,"buff"
12010 C now sscale
12011         if (sh_frac_dist.le.0.0) cycle
12012 C If we reach here it means that this side chain reaches the shielding sphere
12013 C Lets add him to the list for gradient
12014         ishield_list(i)=ishield_list(i)+1
12015 C ishield_list is a list of non 0 side-chain that contribute to factor gradient
12016 C this list is essential otherwise problem would be O3
12017         shield_list(ishield_list(i),i)=k
12018 C Lets have the sscale value
12019         if (sh_frac_dist.gt.1.0) then
12020          scale_fac_dist=1.0d0
12021          do j=1,3
12022          sh_frac_dist_grad(j)=0.0d0
12023          enddo
12024         else
12025          scale_fac_dist=-sh_frac_dist*sh_frac_dist
12026      &                   *(2.0*sh_frac_dist-3.0d0)
12027          fac_help_scale=6.0*(sh_frac_dist-sh_frac_dist**2)
12028      &                  /dist_pep_side/buff_shield*0.5
12029 C remember for the final gradient multiply sh_frac_dist_grad(j)
12030 C for side_chain by factor -2 !
12031          do j=1,3
12032          sh_frac_dist_grad(j)=fac_help_scale*pep_side(j)
12033 C         print *,"jestem",scale_fac_dist,fac_help_scale,
12034 C     &                    sh_frac_dist_grad(j)
12035          enddo
12036         endif
12037 C        if ((i.eq.3).and.(k.eq.2)) then
12038 C        print *,i,sh_frac_dist,dist_pep,fac_help_scale,scale_fac_dist
12039 C     & ,"TU"
12040 C        endif
12041
12042 C this is what is now we have the distance scaling now volume...
12043       short=short_r_sidechain(itype(k))
12044       long=long_r_sidechain(itype(k))
12045       costhet=1.0d0/dsqrt(1.0+short**2/dist_pep_side**2)
12046 C now costhet_grad
12047 C       costhet=0.0d0
12048        costhet_fac=costhet**3*short**2*(-0.5)/dist_pep_side**4
12049 C       costhet_fac=0.0d0
12050        do j=1,3
12051          costhet_grad(j)=costhet_fac*pep_side(j)
12052        enddo
12053 C remember for the final gradient multiply costhet_grad(j)
12054 C for side_chain by factor -2 !
12055 C fac alfa is angle between CB_k,CA_k, CA_i,CA_i+1
12056 C pep_side0pept_group is vector multiplication
12057       pep_side0pept_group=0.0
12058       do j=1,3
12059       pep_side0pept_group=pep_side0pept_group+pep_side(j)*side_calf(j)
12060       enddo
12061       cosalfa=(pep_side0pept_group/
12062      & (dist_pep_side*dist_side_calf))
12063       fac_alfa_sin=1.0-cosalfa**2
12064       fac_alfa_sin=dsqrt(fac_alfa_sin)
12065       rkprim=fac_alfa_sin*(long-short)+short
12066 C now costhet_grad
12067        cosphi=1.0d0/dsqrt(1.0+rkprim**2/dist_pep_side**2)
12068        cosphi_fac=cosphi**3*rkprim**2*(-0.5)/dist_pep_side**4
12069
12070        do j=1,3
12071          cosphi_grad_long(j)=cosphi_fac*pep_side(j)
12072      &+cosphi**3*0.5/dist_pep_side**2*(-rkprim)
12073      &*(long-short)/fac_alfa_sin*cosalfa/
12074      &((dist_pep_side*dist_side_calf))*
12075      &((side_calf(j))-cosalfa*
12076      &((pep_side(j)/dist_pep_side)*dist_side_calf))
12077
12078         cosphi_grad_loc(j)=cosphi**3*0.5/dist_pep_side**2*(-rkprim)
12079      &*(long-short)/fac_alfa_sin*cosalfa
12080      &/((dist_pep_side*dist_side_calf))*
12081      &(pep_side(j)-
12082      &cosalfa*side_calf(j)/dist_side_calf*dist_pep_side)
12083        enddo
12084
12085       VofOverlap=VSolvSphere/2.0d0*(1.0-costhet)*(1.0-cosphi)
12086      &                    /VSolvSphere_div
12087      &                    *wshield
12088 C now the gradient...
12089 C grad_shield is gradient of Calfa for peptide groups
12090 C      write(iout,*) "shield_compon",i,k,VSolvSphere,scale_fac_dist,
12091 C     &               costhet,cosphi
12092 C       write(iout,*) "cosphi_compon",i,k,pep_side0pept_group,
12093 C     & dist_pep_side,dist_side_calf,c(1,k+nres),c(1,k),itype(k)
12094       do j=1,3
12095       grad_shield(j,i)=grad_shield(j,i)
12096 C gradient po skalowaniu
12097      &                +(sh_frac_dist_grad(j)
12098 C  gradient po costhet
12099      &-scale_fac_dist*costhet_grad(j)/(1.0-costhet)
12100      &-scale_fac_dist*(cosphi_grad_long(j))
12101      &/(1.0-cosphi) )*div77_81
12102      &*VofOverlap
12103 C grad_shield_side is Cbeta sidechain gradient
12104       grad_shield_side(j,ishield_list(i),i)=
12105      &        (sh_frac_dist_grad(j)*(-2.0d0)
12106      &       +scale_fac_dist*costhet_grad(j)*2.0d0/(1.0-costhet)
12107      &       +scale_fac_dist*(cosphi_grad_long(j))
12108      &        *2.0d0/(1.0-cosphi))
12109      &        *div77_81*VofOverlap
12110
12111        grad_shield_loc(j,ishield_list(i),i)=
12112      &   scale_fac_dist*cosphi_grad_loc(j)
12113      &        *2.0d0/(1.0-cosphi)
12114      &        *div77_81*VofOverlap
12115       enddo
12116       VolumeTotal=VolumeTotal+VofOverlap*scale_fac_dist
12117       enddo
12118       fac_shield(i)=VolumeTotal*div77_81+div4_81
12119 c      write(2,*) "TOTAL VOLUME",i,VolumeTotal,fac_shield(i)
12120       enddo
12121       return
12122       end
12123 C--------------------------------------------------------------------------
12124       double precision function tschebyshev(m,n,x,y)
12125       implicit none
12126       include "DIMENSIONS"
12127       integer i,m,n
12128       double precision x(n),y,yy(0:maxvar),aux
12129 c Tschebyshev polynomial. Note that the first term is omitted
12130 c m=0: the constant term is included
12131 c m=1: the constant term is not included
12132       yy(0)=1.0d0
12133       yy(1)=y
12134       do i=2,n
12135         yy(i)=2*yy(1)*yy(i-1)-yy(i-2)
12136       enddo
12137       aux=0.0d0
12138       do i=m,n
12139         aux=aux+x(i)*yy(i)
12140       enddo
12141       tschebyshev=aux
12142       return
12143       end
12144 C--------------------------------------------------------------------------
12145       double precision function gradtschebyshev(m,n,x,y)
12146       implicit none
12147       include "DIMENSIONS"
12148       integer i,m,n
12149       double precision x(n+1),y,yy(0:maxvar),aux
12150 c Tschebyshev polynomial. Note that the first term is omitted
12151 c m=0: the constant term is included
12152 c m=1: the constant term is not included
12153       yy(0)=1.0d0
12154       yy(1)=2.0d0*y
12155       do i=2,n
12156         yy(i)=2*y*yy(i-1)-yy(i-2)
12157       enddo
12158       aux=0.0d0
12159       do i=m,n
12160         aux=aux+x(i+1)*yy(i)*(i+1)
12161 C        print *, x(i+1),yy(i),i
12162       enddo
12163       gradtschebyshev=aux
12164       return
12165       end
12166 C------------------------------------------------------------------------
12167 C first for shielding is setting of function of side-chains
12168        subroutine set_shield_fac2
12169       implicit real*8 (a-h,o-z)
12170       include 'DIMENSIONS'
12171       include 'COMMON.CHAIN'
12172       include 'COMMON.DERIV'
12173       include 'COMMON.IOUNITS'
12174       include 'COMMON.SHIELD'
12175       include 'COMMON.INTERACT'
12176 C this is the squar root 77 devided by 81 the epislion in lipid (in protein)
12177       double precision div77_81/0.974996043d0/,
12178      &div4_81/0.2222222222d0/,sh_frac_dist_grad(3)
12179
12180 C the vector between center of side_chain and peptide group
12181        double precision pep_side(3),long,side_calf(3),
12182      &pept_group(3),costhet_grad(3),cosphi_grad_long(3),
12183      &cosphi_grad_loc(3),pep_side_norm(3),side_calf_norm(3)
12184 C the line belowe needs to be changed for FGPROC>1
12185       do i=1,nres-1
12186       if ((itype(i).eq.ntyp1).and.itype(i+1).eq.ntyp1) cycle
12187       ishield_list(i)=0
12188 Cif there two consequtive dummy atoms there is no peptide group between them
12189 C the line below has to be changed for FGPROC>1
12190       VolumeTotal=0.0
12191       do k=1,nres
12192        if ((itype(k).eq.ntyp1).or.(itype(k).eq.10)) cycle
12193        dist_pep_side=0.0
12194        dist_side_calf=0.0
12195        do j=1,3
12196 C first lets set vector conecting the ithe side-chain with kth side-chain
12197       pep_side(j)=c(j,k+nres)-(c(j,i)+c(j,i+1))/2.0d0
12198 C      pep_side(j)=2.0d0
12199 C and vector conecting the side-chain with its proper calfa
12200       side_calf(j)=c(j,k+nres)-c(j,k)
12201 C      side_calf(j)=2.0d0
12202       pept_group(j)=c(j,i)-c(j,i+1)
12203 C lets have their lenght
12204       dist_pep_side=pep_side(j)**2+dist_pep_side
12205       dist_side_calf=dist_side_calf+side_calf(j)**2
12206       dist_pept_group=dist_pept_group+pept_group(j)**2
12207       enddo
12208        dist_pep_side=dsqrt(dist_pep_side)
12209        dist_pept_group=dsqrt(dist_pept_group)
12210        dist_side_calf=dsqrt(dist_side_calf)
12211       do j=1,3
12212         pep_side_norm(j)=pep_side(j)/dist_pep_side
12213         side_calf_norm(j)=dist_side_calf
12214       enddo
12215 C now sscale fraction
12216        sh_frac_dist=-(dist_pep_side-rpp(1,1)-buff_shield)/buff_shield
12217 C       print *,buff_shield,"buff"
12218 C now sscale
12219         if (sh_frac_dist.le.0.0) cycle
12220 C If we reach here it means that this side chain reaches the shielding sphere
12221 C Lets add him to the list for gradient
12222         ishield_list(i)=ishield_list(i)+1
12223 C ishield_list is a list of non 0 side-chain that contribute to factor gradient
12224 C this list is essential otherwise problem would be O3
12225         shield_list(ishield_list(i),i)=k
12226 C Lets have the sscale value
12227         if (sh_frac_dist.gt.1.0) then
12228          scale_fac_dist=1.0d0
12229          do j=1,3
12230          sh_frac_dist_grad(j)=0.0d0
12231          enddo
12232         else
12233          scale_fac_dist=-sh_frac_dist*sh_frac_dist
12234      &                   *(2.0d0*sh_frac_dist-3.0d0)
12235          fac_help_scale=6.0d0*(sh_frac_dist-sh_frac_dist**2)
12236      &                  /dist_pep_side/buff_shield*0.5d0
12237 C remember for the final gradient multiply sh_frac_dist_grad(j)
12238 C for side_chain by factor -2 !
12239          do j=1,3
12240          sh_frac_dist_grad(j)=fac_help_scale*pep_side(j)
12241 C         sh_frac_dist_grad(j)=0.0d0
12242 C         scale_fac_dist=1.0d0
12243 C         print *,"jestem",scale_fac_dist,fac_help_scale,
12244 C     &                    sh_frac_dist_grad(j)
12245          enddo
12246         endif
12247 C this is what is now we have the distance scaling now volume...
12248       short=short_r_sidechain(itype(k))
12249       long=long_r_sidechain(itype(k))
12250       costhet=1.0d0/dsqrt(1.0d0+short**2/dist_pep_side**2)
12251       sinthet=short/dist_pep_side*costhet
12252 C now costhet_grad
12253 C       costhet=0.6d0
12254 C       sinthet=0.8
12255        costhet_fac=costhet**3*short**2*(-0.5d0)/dist_pep_side**4
12256 C       sinthet_fac=costhet**2*0.5d0*(short**3/dist_pep_side**4*costhet
12257 C     &             -short/dist_pep_side**2/costhet)
12258 C       costhet_fac=0.0d0
12259        do j=1,3
12260          costhet_grad(j)=costhet_fac*pep_side(j)
12261        enddo
12262 C remember for the final gradient multiply costhet_grad(j)
12263 C for side_chain by factor -2 !
12264 C fac alfa is angle between CB_k,CA_k, CA_i,CA_i+1
12265 C pep_side0pept_group is vector multiplication
12266       pep_side0pept_group=0.0d0
12267       do j=1,3
12268       pep_side0pept_group=pep_side0pept_group+pep_side(j)*side_calf(j)
12269       enddo
12270       cosalfa=(pep_side0pept_group/
12271      & (dist_pep_side*dist_side_calf))
12272       fac_alfa_sin=1.0d0-cosalfa**2
12273       fac_alfa_sin=dsqrt(fac_alfa_sin)
12274       rkprim=fac_alfa_sin*(long-short)+short
12275 C      rkprim=short
12276
12277 C now costhet_grad
12278        cosphi=1.0d0/dsqrt(1.0d0+rkprim**2/dist_pep_side**2)
12279 C       cosphi=0.6
12280        cosphi_fac=cosphi**3*rkprim**2*(-0.5d0)/dist_pep_side**4
12281        sinphi=rkprim/dist_pep_side/dsqrt(1.0d0+rkprim**2/
12282      &      dist_pep_side**2)
12283 C       sinphi=0.8
12284        do j=1,3
12285          cosphi_grad_long(j)=cosphi_fac*pep_side(j)
12286      &+cosphi**3*0.5d0/dist_pep_side**2*(-rkprim)
12287      &*(long-short)/fac_alfa_sin*cosalfa/
12288      &((dist_pep_side*dist_side_calf))*
12289      &((side_calf(j))-cosalfa*
12290      &((pep_side(j)/dist_pep_side)*dist_side_calf))
12291 C       cosphi_grad_long(j)=0.0d0
12292         cosphi_grad_loc(j)=cosphi**3*0.5d0/dist_pep_side**2*(-rkprim)
12293      &*(long-short)/fac_alfa_sin*cosalfa
12294      &/((dist_pep_side*dist_side_calf))*
12295      &(pep_side(j)-
12296      &cosalfa*side_calf(j)/dist_side_calf*dist_pep_side)
12297 C       cosphi_grad_loc(j)=0.0d0
12298        enddo
12299 C      print *,sinphi,sinthet
12300 c      write (iout,*) "VSolvSphere",VSolvSphere," VSolvSphere_div",
12301 c     &  VSolvSphere_div," sinphi",sinphi," sinthet",sinthet
12302       VofOverlap=VSolvSphere/2.0d0*(1.0d0-dsqrt(1.0d0-sinphi*sinthet))
12303      &                    /VSolvSphere_div
12304 C     &                    *wshield
12305 C now the gradient...
12306       do j=1,3
12307       grad_shield(j,i)=grad_shield(j,i)
12308 C gradient po skalowaniu
12309      &                +(sh_frac_dist_grad(j)*VofOverlap
12310 C  gradient po costhet
12311      &       +scale_fac_dist*VSolvSphere/VSolvSphere_div/4.0d0*
12312      &(1.0d0/(-dsqrt(1.0d0-sinphi*sinthet))*(
12313      &       sinphi/sinthet*costhet*costhet_grad(j)
12314      &      +sinthet/sinphi*cosphi*cosphi_grad_long(j)))
12315      & )*wshield
12316 C grad_shield_side is Cbeta sidechain gradient
12317       grad_shield_side(j,ishield_list(i),i)=
12318      &        (sh_frac_dist_grad(j)*(-2.0d0)
12319      &        *VofOverlap
12320      &       -scale_fac_dist*VSolvSphere/VSolvSphere_div/2.0d0*
12321      &(1.0d0/(-dsqrt(1.0d0-sinphi*sinthet))*(
12322      &       sinphi/sinthet*costhet*costhet_grad(j)
12323      &      +sinthet/sinphi*cosphi*cosphi_grad_long(j)))
12324      &       )*wshield
12325
12326        grad_shield_loc(j,ishield_list(i),i)=
12327      &       scale_fac_dist*VSolvSphere/VSolvSphere_div/2.0d0*
12328      &(1.0d0/(dsqrt(1.0d0-sinphi*sinthet))*(
12329      &       sinthet/sinphi*cosphi*cosphi_grad_loc(j)
12330      &        ))
12331      &        *wshield
12332       enddo
12333 c      write (iout,*) "VofOverlap",VofOverlap," scale_fac_dist",
12334 c     & scale_fac_dist
12335       VolumeTotal=VolumeTotal+VofOverlap*scale_fac_dist
12336       enddo
12337       fac_shield(i)=VolumeTotal*wshield+(1.0d0-wshield)
12338 c      write(2,*) "TOTAL VOLUME",i,VolumeTotal,fac_shield(i),
12339 c     &  " wshield",wshield
12340 c      write(2,*) "TU",rpp(1,1),short,long,buff_shield
12341       enddo
12342       return
12343       end
12344 C-----------------------------------------------------------------------
12345 C-----------------------------------------------------------
12346 C This subroutine is to mimic the histone like structure but as well can be
12347 C utilizet to nanostructures (infinit) small modification has to be used to
12348 C make it finite (z gradient at the ends has to be changes as well as the x,y
12349 C gradient has to be modified at the ends
12350 C The energy function is Kihara potential
12351 C E=4esp*((sigma/(r-r0))^12 - (sigma/(r-r0))^6)
12352 C 4eps is depth of well sigma is r_minimum r is distance from center of tube
12353 C and r0 is the excluded size of nanotube (can be set to 0 if we want just a
12354 C simple Kihara potential
12355       subroutine calctube(Etube)
12356        implicit real*8 (a-h,o-z)
12357       include 'DIMENSIONS'
12358       include 'COMMON.GEO'
12359       include 'COMMON.VAR'
12360       include 'COMMON.LOCAL'
12361       include 'COMMON.CHAIN'
12362       include 'COMMON.DERIV'
12363       include 'COMMON.NAMES'
12364       include 'COMMON.INTERACT'
12365       include 'COMMON.IOUNITS'
12366       include 'COMMON.CALC'
12367       include 'COMMON.CONTROL'
12368       include 'COMMON.SPLITELE'
12369       include 'COMMON.SBRIDGE'
12370       double precision tub_r,vectube(3),enetube(maxres*2)
12371       Etube=0.0d0
12372       do i=1,2*nres
12373         enetube(i)=0.0d0
12374       enddo
12375 C first we calculate the distance from tube center
12376 C first sugare-phosphate group for NARES this would be peptide group
12377 C for UNRES
12378       do i=1,nres
12379 C lets ommit dummy atoms for now
12380        if ((itype(i).eq.ntyp1).or.(itype(i+1).eq.ntyp1)) cycle
12381 C now calculate distance from center of tube and direction vectors
12382       vectube(1)=mod((c(1,i)+c(1,i+1))/2.0d0,boxxsize)
12383           if (vectube(1).lt.0) vectube(1)=vectube(1)+boxxsize
12384       vectube(2)=mod((c(2,i)+c(2,i+1))/2.0d0,boxxsize)
12385           if (vectube(2).lt.0) vectube(2)=vectube(2)+boxxsize
12386       vectube(1)=vectube(1)-tubecenter(1)
12387       vectube(2)=vectube(2)-tubecenter(2)
12388
12389 C      print *,"x",(c(1,i)+c(1,i+1))/2.0d0,tubecenter(1)
12390 C      print *,"y",(c(2,i)+c(2,i+1))/2.0d0,tubecenter(2)
12391
12392 C as the tube is infinity we do not calculate the Z-vector use of Z
12393 C as chosen axis
12394       vectube(3)=0.0d0
12395 C now calculte the distance
12396        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
12397 C now normalize vector
12398       vectube(1)=vectube(1)/tub_r
12399       vectube(2)=vectube(2)/tub_r
12400 C calculte rdiffrence between r and r0
12401       rdiff=tub_r-tubeR0
12402 C and its 6 power
12403       rdiff6=rdiff**6.0d0
12404 C for vectorization reasons we will sumup at the end to avoid depenence of previous
12405        enetube(i)=pep_aa_tube/rdiff6**2.0d0-pep_bb_tube/rdiff6
12406 C       write(iout,*) "TU13",i,rdiff6,enetube(i)
12407 C       print *,rdiff,rdiff6,pep_aa_tube
12408 C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
12409 C now we calculate gradient
12410        fac=(-12.0d0*pep_aa_tube/rdiff6+
12411      &       6.0d0*pep_bb_tube)/rdiff6/rdiff
12412 C       write(iout,'(a5,i4,f12.1,3f12.5)') "TU13",i,rdiff6,enetube(i),
12413 C     &rdiff,fac
12414
12415 C now direction of gg_tube vector
12416         do j=1,3
12417         gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac/2.0d0
12418         gg_tube(j,i)=gg_tube(j,i)+vectube(j)*fac/2.0d0
12419         enddo
12420         enddo
12421 C basically thats all code now we split for side-chains (REMEMBER to sum up at the END)
12422         do i=1,nres
12423 C Lets not jump over memory as we use many times iti
12424          iti=itype(i)
12425 C lets ommit dummy atoms for now
12426          if ((iti.eq.ntyp1)
12427 C in UNRES uncomment the line below as GLY has no side-chain...
12428 C      .or.(iti.eq.10)
12429      &   ) cycle
12430           vectube(1)=c(1,i+nres)
12431           vectube(1)=mod(vectube(1),boxxsize)
12432           if (vectube(1).lt.0) vectube(1)=vectube(1)+boxxsize
12433           vectube(2)=c(2,i+nres)
12434           vectube(2)=mod(vectube(2),boxxsize)
12435           if (vectube(2).lt.0) vectube(2)=vectube(2)+boxxsize
12436
12437       vectube(1)=vectube(1)-tubecenter(1)
12438       vectube(2)=vectube(2)-tubecenter(2)
12439
12440 C as the tube is infinity we do not calculate the Z-vector use of Z
12441 C as chosen axis
12442       vectube(3)=0.0d0
12443 C now calculte the distance
12444        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
12445 C now normalize vector
12446       vectube(1)=vectube(1)/tub_r
12447       vectube(2)=vectube(2)/tub_r
12448 C calculte rdiffrence between r and r0
12449       rdiff=tub_r-tubeR0
12450 C and its 6 power
12451       rdiff6=rdiff**6.0d0
12452 C for vectorization reasons we will sumup at the end to avoid depenence of previous
12453        sc_aa_tube=sc_aa_tube_par(iti)
12454        sc_bb_tube=sc_bb_tube_par(iti)
12455        enetube(i+nres)=sc_aa_tube/rdiff6**2.0d0-sc_bb_tube/rdiff6
12456 C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
12457 C now we calculate gradient
12458        fac=-12.0d0*sc_aa_tube/rdiff6**2.0d0/rdiff+
12459      &       6.0d0*sc_bb_tube/rdiff6/rdiff
12460 C now direction of gg_tube vector
12461          do j=1,3
12462           gg_tube_SC(j,i)=gg_tube_SC(j,i)+vectube(j)*fac
12463           gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac
12464          enddo
12465         enddo
12466         do i=1,2*nres
12467           Etube=Etube+enetube(i)
12468         enddo
12469 C        print *,"ETUBE", etube
12470         return
12471         end
12472 C TO DO 1) add to total energy
12473 C       2) add to gradient summation
12474 C       3) add reading parameters (AND of course oppening of PARAM file)
12475 C       4) add reading the center of tube
12476 C       5) add COMMONs
12477 C       6) add to zerograd
12478
12479 C-----------------------------------------------------------------------
12480 C-----------------------------------------------------------
12481 C This subroutine is to mimic the histone like structure but as well can be
12482 C utilizet to nanostructures (infinit) small modification has to be used to
12483 C make it finite (z gradient at the ends has to be changes as well as the x,y
12484 C gradient has to be modified at the ends
12485 C The energy function is Kihara potential
12486 C E=4esp*((sigma/(r-r0))^12 - (sigma/(r-r0))^6)
12487 C 4eps is depth of well sigma is r_minimum r is distance from center of tube
12488 C and r0 is the excluded size of nanotube (can be set to 0 if we want just a
12489 C simple Kihara potential
12490       subroutine calctube2(Etube)
12491        implicit real*8 (a-h,o-z)
12492       include 'DIMENSIONS'
12493       include 'COMMON.GEO'
12494       include 'COMMON.VAR'
12495       include 'COMMON.LOCAL'
12496       include 'COMMON.CHAIN'
12497       include 'COMMON.DERIV'
12498       include 'COMMON.NAMES'
12499       include 'COMMON.INTERACT'
12500       include 'COMMON.IOUNITS'
12501       include 'COMMON.CALC'
12502       include 'COMMON.CONTROL'
12503       include 'COMMON.SPLITELE'
12504       include 'COMMON.SBRIDGE'
12505       double precision tub_r,vectube(3),enetube(maxres*2)
12506       Etube=0.0d0
12507       do i=1,2*nres
12508         enetube(i)=0.0d0
12509       enddo
12510 C first we calculate the distance from tube center
12511 C first sugare-phosphate group for NARES this would be peptide group
12512 C for UNRES
12513       do i=1,nres
12514 C lets ommit dummy atoms for now
12515        if ((itype(i).eq.ntyp1).or.(itype(i+1).eq.ntyp1)) cycle
12516 C now calculate distance from center of tube and direction vectors
12517       vectube(1)=mod((c(1,i)+c(1,i+1))/2.0d0,boxxsize)
12518           if (vectube(1).lt.0) vectube(1)=vectube(1)+boxxsize
12519       vectube(2)=mod((c(2,i)+c(2,i+1))/2.0d0,boxxsize)
12520           if (vectube(2).lt.0) vectube(2)=vectube(2)+boxxsize
12521       vectube(1)=vectube(1)-tubecenter(1)
12522       vectube(2)=vectube(2)-tubecenter(2)
12523
12524 C      print *,"x",(c(1,i)+c(1,i+1))/2.0d0,tubecenter(1)
12525 C      print *,"y",(c(2,i)+c(2,i+1))/2.0d0,tubecenter(2)
12526
12527 C as the tube is infinity we do not calculate the Z-vector use of Z
12528 C as chosen axis
12529       vectube(3)=0.0d0
12530 C now calculte the distance
12531        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
12532 C now normalize vector
12533       vectube(1)=vectube(1)/tub_r
12534       vectube(2)=vectube(2)/tub_r
12535 C calculte rdiffrence between r and r0
12536       rdiff=tub_r-tubeR0
12537 C and its 6 power
12538       rdiff6=rdiff**6.0d0
12539 C for vectorization reasons we will sumup at the end to avoid depenence of previous
12540        enetube(i)=pep_aa_tube/rdiff6**2.0d0-pep_bb_tube/rdiff6
12541 C       write(iout,*) "TU13",i,rdiff6,enetube(i)
12542 C       print *,rdiff,rdiff6,pep_aa_tube
12543 C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
12544 C now we calculate gradient
12545        fac=(-12.0d0*pep_aa_tube/rdiff6+
12546      &       6.0d0*pep_bb_tube)/rdiff6/rdiff
12547 C       write(iout,'(a5,i4,f12.1,3f12.5)') "TU13",i,rdiff6,enetube(i),
12548 C     &rdiff,fac
12549
12550 C now direction of gg_tube vector
12551         do j=1,3
12552         gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac/2.0d0
12553         gg_tube(j,i)=gg_tube(j,i)+vectube(j)*fac/2.0d0
12554         enddo
12555         enddo
12556 C basically thats all code now we split for side-chains (REMEMBER to sum up at the END)
12557         do i=1,nres
12558 C Lets not jump over memory as we use many times iti
12559          iti=itype(i)
12560 C lets ommit dummy atoms for now
12561          if ((iti.eq.ntyp1)
12562 C in UNRES uncomment the line below as GLY has no side-chain...
12563      &      .or.(iti.eq.10)
12564      &   ) cycle
12565           vectube(1)=c(1,i+nres)
12566           vectube(1)=mod(vectube(1),boxxsize)
12567           if (vectube(1).lt.0) vectube(1)=vectube(1)+boxxsize
12568           vectube(2)=c(2,i+nres)
12569           vectube(2)=mod(vectube(2),boxxsize)
12570           if (vectube(2).lt.0) vectube(2)=vectube(2)+boxxsize
12571
12572       vectube(1)=vectube(1)-tubecenter(1)
12573       vectube(2)=vectube(2)-tubecenter(2)
12574 C THIS FRAGMENT MAKES TUBE FINITE
12575         positi=(mod(c(3,i+nres),boxzsize))
12576         if (positi.le.0) positi=positi+boxzsize
12577 C       print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop
12578 c for each residue check if it is in lipid or lipid water border area
12579 C       respos=mod(c(3,i+nres),boxzsize)
12580        print *,positi,bordtubebot,buftubebot,bordtubetop
12581        if ((positi.gt.bordtubebot)
12582      & .and.(positi.lt.bordtubetop)) then
12583 C the energy transfer exist
12584         if (positi.lt.buftubebot) then
12585          fracinbuf=1.0d0-
12586      &     ((positi-bordtubebot)/tubebufthick)
12587 C lipbufthick is thickenes of lipid buffore
12588          sstube=sscalelip(fracinbuf)
12589          ssgradtube=-sscagradlip(fracinbuf)/tubebufthick
12590          print *,ssgradtube, sstube,tubetranene(itype(i))
12591          enetube(i+nres)=enetube(i+nres)+sstube*tubetranene(itype(i))
12592          gg_tube_SC(3,i)=gg_tube_SC(3,i)
12593      &+ssgradtube*tubetranene(itype(i))
12594          gg_tube(3,i-1)= gg_tube(3,i-1)
12595      &+ssgradtube*tubetranene(itype(i))
12596 C         print *,"doing sccale for lower part"
12597         elseif (positi.gt.buftubetop) then
12598          fracinbuf=1.0d0-
12599      &((bordtubetop-positi)/tubebufthick)
12600          sstube=sscalelip(fracinbuf)
12601          ssgradtube=sscagradlip(fracinbuf)/tubebufthick
12602          enetube(i+nres)=enetube(i+nres)+sstube*tubetranene(itype(i))
12603 C         gg_tube_SC(3,i)=gg_tube_SC(3,i)
12604 C     &+ssgradtube*tubetranene(itype(i))
12605 C         gg_tube(3,i-1)= gg_tube(3,i-1)
12606 C     &+ssgradtube*tubetranene(itype(i))
12607 C          print *, "doing sscalefor top part",sslip,fracinbuf
12608         else
12609          sstube=1.0d0
12610          ssgradtube=0.0d0
12611          enetube(i+nres)=enetube(i+nres)+sstube*tubetranene(itype(i))
12612 C         print *,"I am in true lipid"
12613         endif
12614         else
12615 C          sstube=0.0d0
12616 C          ssgradtube=0.0d0
12617         cycle
12618         endif ! if in lipid or buffor
12619 CEND OF FINITE FRAGMENT
12620 C as the tube is infinity we do not calculate the Z-vector use of Z
12621 C as chosen axis
12622       vectube(3)=0.0d0
12623 C now calculte the distance
12624        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
12625 C now normalize vector
12626       vectube(1)=vectube(1)/tub_r
12627       vectube(2)=vectube(2)/tub_r
12628 C calculte rdiffrence between r and r0
12629       rdiff=tub_r-tubeR0
12630 C and its 6 power
12631       rdiff6=rdiff**6.0d0
12632 C for vectorization reasons we will sumup at the end to avoid depenence of previous
12633        sc_aa_tube=sc_aa_tube_par(iti)
12634        sc_bb_tube=sc_bb_tube_par(iti)
12635        enetube(i+nres)=(sc_aa_tube/rdiff6**2.0d0-sc_bb_tube/rdiff6)
12636      &                 *sstube+enetube(i+nres)
12637 C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
12638 C now we calculate gradient
12639        fac=(-12.0d0*sc_aa_tube/rdiff6**2.0d0/rdiff+
12640      &       6.0d0*sc_bb_tube/rdiff6/rdiff)*sstube
12641 C now direction of gg_tube vector
12642          do j=1,3
12643           gg_tube_SC(j,i)=gg_tube_SC(j,i)+vectube(j)*fac
12644           gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac
12645          enddo
12646          gg_tube_SC(3,i)=gg_tube_SC(3,i)
12647      &+ssgradtube*enetube(i+nres)/sstube
12648          gg_tube(3,i-1)= gg_tube(3,i-1)
12649      &+ssgradtube*enetube(i+nres)/sstube
12650
12651         enddo
12652         do i=1,2*nres
12653           Etube=Etube+enetube(i)
12654         enddo
12655 C        print *,"ETUBE", etube
12656         return
12657         end
12658 C TO DO 1) add to total energy
12659 C       2) add to gradient summation
12660 C       3) add reading parameters (AND of course oppening of PARAM file)
12661 C       4) add reading the center of tube
12662 C       5) add COMMONs
12663 C       6) add to zerograd
12664 c----------------------------------------------------------------------------
12665       subroutine e_saxs(Esaxs_constr)
12666       implicit none
12667       include 'DIMENSIONS'
12668 #ifdef MPI
12669       include "mpif.h"
12670       include "COMMON.SETUP"
12671       integer IERR
12672 #endif
12673       include 'COMMON.SBRIDGE'
12674       include 'COMMON.CHAIN'
12675       include 'COMMON.GEO'
12676       include 'COMMON.DERIV'
12677       include 'COMMON.LOCAL'
12678       include 'COMMON.INTERACT'
12679       include 'COMMON.VAR'
12680       include 'COMMON.IOUNITS'
12681 c      include 'COMMON.MD'
12682 #ifdef LANG0
12683 #ifdef FIVEDIAG
12684       include 'COMMON.LANGEVIN.lang0.5diag'
12685 #else
12686       include 'COMMON.LANGEVIN.lang0'
12687 #endif
12688 #else
12689       include 'COMMON.LANGEVIN'
12690 #endif
12691       include 'COMMON.CONTROL'
12692       include 'COMMON.SAXS'
12693       include 'COMMON.NAMES'
12694       include 'COMMON.TIME1'
12695       include 'COMMON.FFIELD'
12696 c
12697       double precision Esaxs_constr
12698       integer i,iint,j,k,l
12699       double precision PgradC(maxSAXS,3,maxres),
12700      &  PgradX(maxSAXS,3,maxres),Pcalc(maxSAXS)
12701 #ifdef MPI
12702       double precision PgradC_(maxSAXS,3,maxres),
12703      &  PgradX_(maxSAXS,3,maxres),Pcalc_(maxSAXS)
12704 #endif
12705       double precision dk,dijCACA,dijCASC,dijSCCA,dijSCSC,
12706      & sigma2CACA,sigma2CASC,sigma2SCCA,sigma2SCSC,expCACA,expCASC,
12707      & expSCCA,expSCSC,CASCgrad,SCCAgrad,SCSCgrad,aux,auxC,auxC1,
12708      & auxX,auxX1,CACAgrad,Cnorm,sigmaCACA,threesig
12709       double precision sss2,ssgrad2,rrr,sscalgrad2,sscale2
12710       double precision dist,mygauss,mygaussder
12711       external dist
12712       integer llicz,lllicz
12713       double precision time01
12714 c  SAXS restraint penalty function
12715 #ifdef DEBUG
12716       write(iout,*) "------- SAXS penalty function start -------"
12717       write (iout,*) "nsaxs",nsaxs
12718       write (iout,*) "Esaxs: iatsc_s",iatsc_s," iatsc_e",iatsc_e
12719       write (iout,*) "Psaxs"
12720       do i=1,nsaxs
12721         write (iout,'(i5,e15.5)') i, Psaxs(i)
12722       enddo
12723 #endif
12724 #ifdef TIMING
12725       time01=MPI_Wtime()
12726 #endif
12727       Esaxs_constr = 0.0d0
12728       do k=1,nsaxs
12729         Pcalc(k)=0.0d0
12730         do j=1,nres
12731           do l=1,3
12732             PgradC(k,l,j)=0.0d0
12733             PgradX(k,l,j)=0.0d0
12734           enddo
12735         enddo
12736       enddo
12737 c      lllicz=0
12738       do i=iatsc_s,iatsc_e
12739        if (itype(i).eq.ntyp1) cycle
12740        do iint=1,nint_gr(i)
12741          do j=istart(i,iint),iend(i,iint)
12742            if (itype(j).eq.ntyp1) cycle
12743 #ifdef ALLSAXS
12744            dijCACA=dist(i,j)
12745            dijCASC=dist(i,j+nres)
12746            dijSCCA=dist(i+nres,j)
12747            dijSCSC=dist(i+nres,j+nres)
12748            sigma2CACA=2.0d0/(pstok**2)
12749            sigma2CASC=4.0d0/(pstok**2+restok(itype(j))**2)
12750            sigma2SCCA=4.0d0/(pstok**2+restok(itype(i))**2)
12751            sigma2SCSC=4.0d0/(restok(itype(j))**2+restok(itype(i))**2)
12752            do k=1,nsaxs
12753              dk = distsaxs(k)
12754              expCACA = dexp(-0.5d0*sigma2CACA*(dijCACA-dk)**2)
12755              if (itype(j).ne.10) then
12756              expCASC = dexp(-0.5d0*sigma2CASC*(dijCASC-dk)**2)
12757              else
12758              endif
12759              expCASC = 0.0d0
12760              if (itype(i).ne.10) then
12761              expSCCA = dexp(-0.5d0*sigma2SCCA*(dijSCCA-dk)**2)
12762              else
12763              expSCCA = 0.0d0
12764              endif
12765              if (itype(i).ne.10 .and. itype(j).ne.10) then
12766              expSCSC = dexp(-0.5d0*sigma2SCSC*(dijSCSC-dk)**2)
12767              else
12768              expSCSC = 0.0d0
12769              endif
12770              Pcalc(k) = Pcalc(k)+expCACA+expCASC+expSCCA+expSCSC
12771 #ifdef DEBUG
12772              write(iout,*) "i j k Pcalc",i,j,Pcalc(k)
12773 #endif
12774              CACAgrad = sigma2CACA*(dijCACA-dk)*expCACA
12775              CASCgrad = sigma2CASC*(dijCASC-dk)*expCASC
12776              SCCAgrad = sigma2SCCA*(dijSCCA-dk)*expSCCA
12777              SCSCgrad = sigma2SCSC*(dijSCSC-dk)*expSCSC
12778              do l=1,3
12779 c CA CA
12780                aux = CACAgrad*(C(l,j)-C(l,i))/dijCACA
12781                PgradC(k,l,i) = PgradC(k,l,i)-aux
12782                PgradC(k,l,j) = PgradC(k,l,j)+aux
12783 c CA SC
12784                if (itype(j).ne.10) then
12785                aux = CASCgrad*(C(l,j+nres)-C(l,i))/dijCASC
12786                PgradC(k,l,i) = PgradC(k,l,i)-aux
12787                PgradC(k,l,j) = PgradC(k,l,j)+aux
12788                PgradX(k,l,j) = PgradX(k,l,j)+aux
12789                endif
12790 c SC CA
12791                if (itype(i).ne.10) then
12792                aux = SCCAgrad*(C(l,j)-C(l,i+nres))/dijSCCA
12793                PgradX(k,l,i) = PgradX(k,l,i)-aux
12794                PgradC(k,l,i) = PgradC(k,l,i)-aux
12795                PgradC(k,l,j) = PgradC(k,l,j)+aux
12796                endif
12797 c SC SC
12798                if (itype(i).ne.10 .and. itype(j).ne.10) then
12799                aux = SCSCgrad*(C(l,j+nres)-C(l,i+nres))/dijSCSC
12800                PgradC(k,l,i) = PgradC(k,l,i)-aux
12801                PgradC(k,l,j) = PgradC(k,l,j)+aux
12802                PgradX(k,l,i) = PgradX(k,l,i)-aux
12803                PgradX(k,l,j) = PgradX(k,l,j)+aux
12804                endif
12805              enddo ! l
12806            enddo ! k
12807 #else
12808            dijCACA=dist(i,j)
12809            sigma2CACA=scal_rad**2*0.25d0/
12810      &        (restok(itype(j))**2+restok(itype(i))**2)
12811 c           write (iout,*) "scal_rad",scal_rad," restok",restok(itype(j))
12812 c     &       ,restok(itype(i)),"sigma",1.0d0/dsqrt(sigma2CACA)
12813 #ifdef MYGAUSS
12814            sigmaCACA=dsqrt(sigma2CACA)
12815            threesig=3.0d0/sigmaCACA
12816 c           llicz=0
12817            do k=1,nsaxs
12818              dk = distsaxs(k)
12819              if (dabs(dijCACA-dk).ge.threesig) cycle
12820 c             llicz=llicz+1
12821 c             lllicz=lllicz+1
12822              aux = sigmaCACA*(dijCACA-dk)
12823              expCACA = mygauss(aux)
12824 c             if (expcaca.eq.0.0d0) cycle
12825              Pcalc(k) = Pcalc(k)+expCACA
12826              CACAgrad = -sigmaCACA*mygaussder(aux)
12827 c             write (iout,*) "i,j,k,aux",i,j,k,CACAgrad
12828              do l=1,3
12829                aux = CACAgrad*(C(l,j)-C(l,i))/dijCACA
12830                PgradC(k,l,i) = PgradC(k,l,i)-aux
12831                PgradC(k,l,j) = PgradC(k,l,j)+aux
12832              enddo ! l
12833            enddo ! k
12834 c           write (iout,*) "i",i," j",j," llicz",llicz
12835 #else
12836            IF (saxs_cutoff.eq.0) THEN
12837            do k=1,nsaxs
12838              dk = distsaxs(k)
12839              expCACA = dexp(-0.5d0*sigma2CACA*(dijCACA-dk)**2)
12840              Pcalc(k) = Pcalc(k)+expCACA
12841              CACAgrad = sigma2CACA*(dijCACA-dk)*expCACA
12842              do l=1,3
12843                aux = CACAgrad*(C(l,j)-C(l,i))/dijCACA
12844                PgradC(k,l,i) = PgradC(k,l,i)-aux
12845                PgradC(k,l,j) = PgradC(k,l,j)+aux
12846              enddo ! l
12847            enddo ! k
12848            ELSE
12849            rrr = saxs_cutoff*2.0d0/dsqrt(sigma2CACA)
12850            do k=1,nsaxs
12851              dk = distsaxs(k)
12852 c             write (2,*) "ijk",i,j,k
12853              sss2 = sscale2(dijCACA,rrr,dk,0.3d0)
12854              if (sss2.eq.0.0d0) cycle
12855              ssgrad2 = sscalgrad2(dijCACA,rrr,dk,0.3d0)
12856              if (energy_dec) write(iout,'(a4,3i5,8f10.4)')
12857      &          'saxs',i,j,k,dijCACA,restok(itype(i)),restok(itype(j)),
12858      &          1.0d0/dsqrt(sigma2CACA),rrr,dk,
12859      &           sss2,ssgrad2
12860              expCACA = dexp(-0.5d0*sigma2CACA*(dijCACA-dk)**2)*sss2
12861              Pcalc(k) = Pcalc(k)+expCACA
12862 #ifdef DEBUG
12863              write(iout,*) "i j k Pcalc",i,j,Pcalc(k)
12864 #endif
12865              CACAgrad = -sigma2CACA*(dijCACA-dk)*expCACA+
12866      &             ssgrad2*expCACA/sss2
12867              do l=1,3
12868 c CA CA
12869                aux = CACAgrad*(C(l,j)-C(l,i))/dijCACA
12870                PgradC(k,l,i) = PgradC(k,l,i)+aux
12871                PgradC(k,l,j) = PgradC(k,l,j)-aux
12872              enddo ! l
12873            enddo ! k
12874            ENDIF
12875 #endif
12876 #endif
12877          enddo ! j
12878        enddo ! iint
12879       enddo ! i
12880 c#ifdef TIMING
12881 c      time_SAXS=time_SAXS+MPI_Wtime()-time01
12882 c#endif
12883 c      write (iout,*) "lllicz",lllicz
12884 c#ifdef TIMING
12885 c      time01=MPI_Wtime()
12886 c#endif
12887 #ifdef MPI
12888       if (nfgtasks.gt.1) then
12889        call MPI_AllReduce(Pcalc(1),Pcalc_(1),nsaxs,MPI_DOUBLE_PRECISION,
12890      &    MPI_SUM,FG_COMM,IERR)
12891 c        if (fg_rank.eq.king) then
12892           do k=1,nsaxs
12893             Pcalc(k) = Pcalc_(k)
12894           enddo
12895 c        endif
12896 c        call MPI_AllReduce(PgradC(k,1,1),PgradC_(k,1,1),3*maxsaxs*nres,
12897 c     &    MPI_DOUBLE_PRECISION,MPI_SUM,FG_COMM,IERR)
12898 c        if (fg_rank.eq.king) then
12899 c          do i=1,nres
12900 c            do l=1,3
12901 c              do k=1,nsaxs
12902 c                PgradC(k,l,i) = PgradC_(k,l,i)
12903 c              enddo
12904 c            enddo
12905 c          enddo
12906 c        endif
12907 #ifdef ALLSAXS
12908 c        call MPI_AllReduce(PgradX(k,1,1),PgradX_(k,1,1),3*maxsaxs*nres,
12909 c     &    MPI_DOUBLE_PRECISION,MPI_SUM,FG_COMM,IERR)
12910 c        if (fg_rank.eq.king) then
12911 c          do i=1,nres
12912 c            do l=1,3
12913 c              do k=1,nsaxs
12914 c                PgradX(k,l,i) = PgradX_(k,l,i)
12915 c              enddo
12916 c            enddo
12917 c          enddo
12918 c        endif
12919 #endif
12920       endif
12921 #endif
12922       Cnorm = 0.0d0
12923       do k=1,nsaxs
12924         Cnorm = Cnorm + Pcalc(k)
12925       enddo
12926 #ifdef MPI
12927       if (fg_rank.eq.king) then
12928 #endif
12929       Esaxs_constr = dlog(Cnorm)-wsaxs0
12930       do k=1,nsaxs
12931         if (Pcalc(k).gt.0.0d0)
12932      &  Esaxs_constr = Esaxs_constr - Psaxs(k)*dlog(Pcalc(k))
12933 #ifdef DEBUG
12934         write (iout,*) "k",k," Esaxs_constr",Esaxs_constr
12935 #endif
12936       enddo
12937 #ifdef DEBUG
12938       write (iout,*) "Cnorm",Cnorm," Esaxs_constr",Esaxs_constr
12939 #endif
12940 #ifdef MPI
12941       endif
12942 #endif
12943       gsaxsC=0.0d0
12944       gsaxsX=0.0d0
12945       do i=nnt,nct
12946         do l=1,3
12947           auxC=0.0d0
12948           auxC1=0.0d0
12949           auxX=0.0d0
12950           auxX1=0.d0
12951           do k=1,nsaxs
12952             if (Pcalc(k).gt.0)
12953      &      auxC  = auxC +Psaxs(k)*PgradC(k,l,i)/Pcalc(k)
12954             auxC1 = auxC1+PgradC(k,l,i)
12955 #ifdef ALLSAXS
12956             auxX  = auxX +Psaxs(k)*PgradX(k,l,i)/Pcalc(k)
12957             auxX1 = auxX1+PgradX(k,l,i)
12958 #endif
12959           enddo
12960           gsaxsC(l,i) = auxC - auxC1/Cnorm
12961 #ifdef ALLSAXS
12962           gsaxsX(l,i) = auxX - auxX1/Cnorm
12963 #endif
12964 c          write (iout,*) "l i",l,i," gradC",wsaxs*(auxC - auxC1/Cnorm),
12965 c     *     " gradX",wsaxs*(auxX - auxX1/Cnorm)
12966 c          write (iout,*) "l i",l,i," gradC",wsaxs*gsaxsC(l,i),
12967 c     *     " gradX",wsaxs*gsaxsX(l,i)
12968         enddo
12969       enddo
12970 #ifdef TIMING
12971       time_SAXS=time_SAXS+MPI_Wtime()-time01
12972 #endif
12973 #ifdef DEBUG
12974       write (iout,*) "gsaxsc"
12975       do i=nnt,nct
12976         write (iout,'(i5,3e15.5)') i,(gsaxsc(j,i),j=1,3)
12977       enddo
12978 #endif
12979 #ifdef MPI
12980 c      endif
12981 #endif
12982       return
12983       end
12984 c----------------------------------------------------------------------------
12985       subroutine e_saxsC(Esaxs_constr)
12986       implicit none
12987       include 'DIMENSIONS'
12988 #ifdef MPI
12989       include "mpif.h"
12990       include "COMMON.SETUP"
12991       integer IERR
12992 #endif
12993       include 'COMMON.SBRIDGE'
12994       include 'COMMON.CHAIN'
12995       include 'COMMON.GEO'
12996       include 'COMMON.DERIV'
12997       include 'COMMON.LOCAL'
12998       include 'COMMON.INTERACT'
12999       include 'COMMON.VAR'
13000       include 'COMMON.IOUNITS'
13001 c      include 'COMMON.MD'
13002 #ifdef LANG0
13003 #ifdef FIVEDIAG
13004       include 'COMMON.LANGEVIN.lang0.5diag'
13005 #else
13006       include 'COMMON.LANGEVIN.lang0'
13007 #endif
13008 #else
13009       include 'COMMON.LANGEVIN'
13010 #endif
13011       include 'COMMON.CONTROL'
13012       include 'COMMON.SAXS'
13013       include 'COMMON.NAMES'
13014       include 'COMMON.TIME1'
13015       include 'COMMON.FFIELD'
13016 c
13017       double precision Esaxs_constr
13018       integer i,iint,j,k,l
13019       double precision PgradC(3,maxres),PgradX(3,maxres),Pcalc,logPtot
13020 #ifdef MPI
13021       double precision gsaxsc_(3,maxres),gsaxsx_(3,maxres),logPtot_
13022 #endif
13023       double precision dk,dijCASPH,dijSCSPH,
13024      & sigma2CA,sigma2SC,expCASPH,expSCSPH,
13025      & CASPHgrad,SCSPHgrad,aux,auxC,auxC1,
13026      & auxX,auxX1,Cnorm
13027 c  SAXS restraint penalty function
13028 #ifdef DEBUG
13029       write(iout,*) "------- SAXS penalty function start -------"
13030       write (iout,*) "nsaxs",nsaxs
13031
13032       do i=nnt,nct
13033         print *,MyRank,"C",i,(C(j,i),j=1,3)
13034       enddo
13035       do i=nnt,nct
13036         print *,MyRank,"CSaxs",i,(Csaxs(j,i),j=1,3)
13037       enddo
13038 #endif
13039       Esaxs_constr = 0.0d0
13040       logPtot=0.0d0
13041       do j=isaxs_start,isaxs_end
13042         Pcalc=0.0d0
13043         do i=1,nres
13044           do l=1,3
13045             PgradC(l,i)=0.0d0
13046             PgradX(l,i)=0.0d0
13047           enddo
13048         enddo
13049         do i=nnt,nct
13050           if (itype(i).eq.ntyp1) cycle
13051           dijCASPH=0.0d0
13052           dijSCSPH=0.0d0
13053           do l=1,3
13054             dijCASPH=dijCASPH+(C(l,i)-Csaxs(l,j))**2
13055           enddo
13056           if (itype(i).ne.10) then
13057           do l=1,3
13058             dijSCSPH=dijSCSPH+(C(l,i+nres)-Csaxs(l,j))**2
13059           enddo
13060           endif
13061           sigma2CA=2.0d0/pstok**2
13062           sigma2SC=4.0d0/restok(itype(i))**2
13063           expCASPH = dexp(-0.5d0*sigma2CA*dijCASPH)
13064           expSCSPH = dexp(-0.5d0*sigma2SC*dijSCSPH)
13065           Pcalc = Pcalc+expCASPH+expSCSPH
13066 #ifdef DEBUG
13067           write(*,*) "processor i j Pcalc",
13068      &       MyRank,i,j,dijCASPH,dijSCSPH, Pcalc
13069 #endif
13070           CASPHgrad = sigma2CA*expCASPH
13071           SCSPHgrad = sigma2SC*expSCSPH
13072           do l=1,3
13073             aux = (C(l,i+nres)-Csaxs(l,j))*SCSPHgrad
13074             PgradX(l,i) = PgradX(l,i) + aux
13075             PgradC(l,i) = PgradC(l,i)+(C(l,i)-Csaxs(l,j))*CASPHgrad+aux
13076           enddo ! l
13077         enddo ! i
13078         do i=nnt,nct
13079           do l=1,3
13080             gsaxsc(l,i)=gsaxsc(l,i)+PgradC(l,i)/Pcalc
13081             gsaxsx(l,i)=gsaxsx(l,i)+PgradX(l,i)/Pcalc
13082           enddo
13083         enddo
13084         logPtot = logPtot - dlog(Pcalc)
13085 c        print *,"me",me,MyRank," j",j," logPcalc",-dlog(Pcalc),
13086 c     &    " logPtot",logPtot
13087       enddo ! j
13088 #ifdef MPI
13089       if (nfgtasks.gt.1) then
13090 c        write (iout,*) "logPtot before reduction",logPtot
13091         call MPI_Reduce(logPtot,logPtot_,1,MPI_DOUBLE_PRECISION,
13092      &    MPI_SUM,king,FG_COMM,IERR)
13093         logPtot = logPtot_
13094 c        write (iout,*) "logPtot after reduction",logPtot
13095         call MPI_Reduce(gsaxsC(1,1),gsaxsC_(1,1),3*nres,
13096      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
13097         if (fg_rank.eq.king) then
13098           do i=1,nres
13099             do l=1,3
13100               gsaxsC(l,i) = gsaxsC_(l,i)
13101             enddo
13102           enddo
13103         endif
13104         call MPI_Reduce(gsaxsX(1,1),gsaxsX_(1,1),3*nres,
13105      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
13106         if (fg_rank.eq.king) then
13107           do i=1,nres
13108             do l=1,3
13109               gsaxsX(l,i) = gsaxsX_(l,i)
13110             enddo
13111           enddo
13112         endif
13113       endif
13114 #endif
13115       Esaxs_constr = logPtot
13116       return
13117       end
13118 c----------------------------------------------------------------------------
13119       double precision function sscale2(r,r_cut,r0,rlamb)
13120       implicit none
13121       double precision r,gamm,r_cut,r0,rlamb,rr
13122       rr = dabs(r-r0)
13123 c      write (2,*) "r",r," r_cut",r_cut," r0",r0," rlamb",rlamb
13124 c      write (2,*) "rr",rr
13125       if(rr.lt.r_cut-rlamb) then
13126         sscale2=1.0d0
13127       else if(rr.le.r_cut.and.rr.ge.r_cut-rlamb) then
13128         gamm=(rr-(r_cut-rlamb))/rlamb
13129         sscale2=1.0d0+gamm*gamm*(2*gamm-3.0d0)
13130       else
13131         sscale2=0d0
13132       endif
13133       return
13134       end
13135 C-----------------------------------------------------------------------
13136       double precision function sscalgrad2(r,r_cut,r0,rlamb)
13137       implicit none
13138       double precision r,gamm,r_cut,r0,rlamb,rr
13139       rr = dabs(r-r0)
13140       if(rr.lt.r_cut-rlamb) then
13141         sscalgrad2=0.0d0
13142       else if(rr.le.r_cut.and.rr.ge.r_cut-rlamb) then
13143         gamm=(rr-(r_cut-rlamb))/rlamb
13144         if (r.ge.r0) then
13145           sscalgrad2=gamm*(6*gamm-6.0d0)/rlamb
13146         else
13147           sscalgrad2=-gamm*(6*gamm-6.0d0)/rlamb
13148         endif
13149       else
13150         sscalgrad2=0.0d0
13151       endif
13152       return
13153       end
13154 c------------------------------------------------------------------------
13155       double precision function boxshift(x,boxsize)
13156       implicit none
13157       double precision x,boxsize
13158       double precision xtemp
13159       xtemp=dmod(x,boxsize)
13160       if (dabs(xtemp-boxsize).lt.dabs(xtemp)) then
13161         boxshift=xtemp-boxsize
13162       else if (dabs(xtemp+boxsize).lt.dabs(xtemp)) then
13163         boxshift=xtemp+boxsize
13164       else
13165         boxshift=xtemp
13166       endif
13167       return
13168       end
13169 c--------------------------------------------------------------------------
13170       subroutine closest_img(xi,yi,zi,xj,yj,zj)
13171       include 'DIMENSIONS'
13172       include 'COMMON.CHAIN'
13173       integer xshift,yshift,zshift,subchap
13174       double precision dist_init,xj_safe,yj_safe,zj_safe,
13175      & xj_temp,yj_temp,zj_temp,dist_temp
13176       xj_safe=xj
13177       yj_safe=yj
13178       zj_safe=zj
13179       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
13180       subchap=0
13181       do xshift=-1,1
13182         do yshift=-1,1
13183           do zshift=-1,1
13184             xj=xj_safe+xshift*boxxsize
13185             yj=yj_safe+yshift*boxysize
13186             zj=zj_safe+zshift*boxzsize
13187             dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
13188             if(dist_temp.lt.dist_init) then
13189               dist_init=dist_temp
13190               xj_temp=xj
13191               yj_temp=yj
13192               zj_temp=zj
13193               subchap=1
13194             endif
13195           enddo
13196         enddo
13197       enddo
13198       if (subchap.eq.1) then
13199         xj=xj_temp-xi
13200         yj=yj_temp-yi
13201         zj=zj_temp-zi
13202       else
13203         xj=xj_safe-xi
13204         yj=yj_safe-yi
13205         zj=zj_safe-zi
13206       endif
13207       return
13208       end
13209 c--------------------------------------------------------------------------
13210       subroutine to_box(xi,yi,zi)
13211       implicit none
13212       include 'DIMENSIONS'
13213       include 'COMMON.CHAIN'
13214       double precision xi,yi,zi
13215       xi=dmod(xi,boxxsize)
13216       if (xi.lt.0.0d0) xi=xi+boxxsize
13217       yi=dmod(yi,boxysize)
13218       if (yi.lt.0.0d0) yi=yi+boxysize
13219       zi=dmod(zi,boxzsize)
13220       if (zi.lt.0.0d0) zi=zi+boxzsize
13221       return
13222       end
13223 c--------------------------------------------------------------------------
13224       subroutine lipid_layer(xi,yi,zi,sslipi,ssgradlipi)
13225       implicit none
13226       include 'DIMENSIONS'
13227       include 'COMMON.CHAIN'
13228       double precision xi,yi,zi,sslipi,ssgradlipi
13229       double precision fracinbuf
13230       double precision sscalelip,sscagradlip
13231
13232       if ((zi.gt.bordlipbot).and.(zi.lt.bordliptop)) then
13233 C the energy transfer exist
13234         if (zi.lt.buflipbot) then
13235 C what fraction I am in
13236           fracinbuf=1.0d0-((zi-bordlipbot)/lipbufthick)
13237 C lipbufthick is thickenes of lipid buffore
13238           sslipi=sscalelip(fracinbuf)
13239           ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
13240         elseif (zi.gt.bufliptop) then
13241           fracinbuf=1.0d0-((bordliptop-zi)/lipbufthick)
13242           sslipi=sscalelip(fracinbuf)
13243           ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
13244         else
13245           sslipi=1.0d0
13246           ssgradlipi=0.0
13247         endif
13248       else
13249         sslipi=0.0d0
13250         ssgradlipi=0.0
13251       endif
13252       return
13253       end