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          do kk=1,constr_homology
7698           if(l_homo(kk,ii)) then
7699             min_odl=distancek(kk)
7700             exit
7701           endif
7702          enddo
7703          do kk=1,constr_homology
7704           if(l_homo(kk,ii) .and. distancek(kk).lt.min_odl)
7705      &              min_odl=distancek(kk)
7706          enddo
7707
7708 c        write (iout,* )"min_odl",min_odl
7709 #ifdef DEBUG
7710          write (iout,*) "ij dij",i,j,dij
7711          write (iout,*) "distance",(distance(k),k=1,constr_homology)
7712          write (iout,*) "distancek",(distancek(k),k=1,constr_homology)
7713          write (iout,* )"min_odl",min_odl
7714 #endif
7715 #ifdef OLDRESTR
7716          odleg2=0.0d0
7717 #else
7718          if (waga_dist.ge.0.0d0) then
7719            odleg2=nexl
7720          else
7721            odleg2=0.0d0
7722          endif
7723 #endif
7724          do k=1,constr_homology
7725 c Nie wiem po co to liczycie jeszcze raz!
7726 c            odleg3=-waga_dist(iset)*((distance(i,j,k)**2)/
7727 c     &              (2*(sigma_odl(i,j,k))**2))
7728            if(.not.l_homo(k,ii)) cycle
7729            if (waga_dist.ge.0.0d0) then
7730 c
7731 c          For Gaussian-type Urestr
7732 c
7733             godl(k)=dexp(-distancek(k)+min_odl)
7734             odleg2=odleg2+godl(k)
7735 c
7736 c          For Lorentzian-type Urestr
7737 c
7738            else
7739             odleg2=odleg2+distancek(k)
7740            endif
7741
7742 ccc       write(iout,779) i,j,k, "odleg2=",odleg2, "odleg3=", odleg3,
7743 ccc     & "dEXP(odleg3)=", dEXP(odleg3),"distance(i,j,k)^2=",
7744 ccc     & distance(i,j,k)**2, "dist(i+1,j+1)=", dist(i+1,j+1),
7745 ccc     & "sigma_odl(i,j,k)=", sigma_odl(i,j,k)
7746
7747          enddo
7748 c        write (iout,*) "godl",(godl(k),k=1,constr_homology) ! exponents
7749 c        write (iout,*) "ii i j",ii,i,j," odleg2",odleg2 ! sum of exps
7750 #ifdef DEBUG
7751          write (iout,*) "godl",(godl(k),k=1,constr_homology) ! exponents
7752          write (iout,*) "ii i j",ii,i,j," odleg2",odleg2 ! sum of exps
7753 #endif
7754            if (waga_dist.ge.0.0d0) then
7755 c
7756 c          For Gaussian-type Urestr
7757 c
7758               odleg=odleg-dLOG(odleg2/constr_homology)+min_odl
7759 c
7760 c          For Lorentzian-type Urestr
7761 c
7762            else
7763               odleg=odleg+odleg2/constr_homology
7764            endif
7765 c
7766 c        write (iout,*) "odleg",odleg ! sum of -ln-s
7767 c Gradient
7768 c
7769 c          For Gaussian-type Urestr
7770 c
7771          if (waga_dist.ge.0.0d0) sum_godl=odleg2
7772          sum_sgodl=0.0d0
7773          do k=1,constr_homology
7774 c            godl=dexp(((-(distance(i,j,k)**2)/(2*(sigma_odl(i,j,k))**2))
7775 c     &           *waga_dist)+min_odl
7776 c          sgodl=-godl(k)*distance(k)*sigma_odl(k,ii)*waga_dist
7777 c
7778          if(.not.l_homo(k,ii)) cycle
7779          if (waga_dist.ge.0.0d0) then
7780 c          For Gaussian-type Urestr
7781 c
7782            sgodl=-godl(k)*distance(k)*sigma_odl(k,ii) ! waga_dist rmvd
7783 c
7784 c          For Lorentzian-type Urestr
7785 c
7786          else
7787            sgodl=-2*sigma_odlir(k,ii)*(distance(k)/(distance(k)**2+
7788      &           sigma_odlir(k,ii)**2)**2)
7789          endif
7790            sum_sgodl=sum_sgodl+sgodl
7791
7792 c            sgodl2=sgodl2+sgodl
7793 c      write(iout,*) i, j, k, distance(i,j,k), "W GRADIENCIE1"
7794 c      write(iout,*) "constr_homology=",constr_homology
7795 c      write(iout,*) i, j, k, "TEST K"
7796          enddo
7797          if (waga_dist.ge.0.0d0) then
7798 c
7799 c          For Gaussian-type Urestr
7800 c
7801             grad_odl3=waga_homology(iset)*waga_dist
7802      &                *sum_sgodl/(sum_godl*dij)
7803 c
7804 c          For Lorentzian-type Urestr
7805 c
7806          else
7807 c Original grad expr modified by analogy w Gaussian-type Urestr grad
7808 c           grad_odl3=-waga_homology(iset)*waga_dist*sum_sgodl
7809             grad_odl3=-waga_homology(iset)*waga_dist*
7810      &                sum_sgodl/(constr_homology*dij)
7811          endif
7812 c
7813 c        grad_odl3=sum_sgodl/(sum_godl*dij)
7814
7815
7816 c      write(iout,*) i, j, k, distance(i,j,k), "W GRADIENCIE2"
7817 c      write(iout,*) (distance(i,j,k)**2), (2*(sigma_odl(i,j,k))**2),
7818 c     &              (-(distance(i,j,k)**2)/(2*(sigma_odl(i,j,k))**2))
7819
7820 ccc      write(iout,*) godl, sgodl, grad_odl3
7821
7822 c          grad_odl=grad_odl+grad_odl3
7823
7824          do jik=1,3
7825             ggodl=grad_odl3*(c(jik,i)-c(jik,j))
7826 ccc      write(iout,*) c(jik,i+1), c(jik,j+1), (c(jik,i+1)-c(jik,j+1))
7827 ccc      write(iout,746) "GRAD_ODL_1", i, j, jik, ggodl,
7828 ccc     &              ghpbc(jik,i+1), ghpbc(jik,j+1)
7829             ghpbc(jik,i)=ghpbc(jik,i)+ggodl
7830             ghpbc(jik,j)=ghpbc(jik,j)-ggodl
7831 ccc      write(iout,746) "GRAD_ODL_2", i, j, jik, ggodl,
7832 ccc     &              ghpbc(jik,i+1), ghpbc(jik,j+1)
7833 c         if (i.eq.25.and.j.eq.27) then
7834 c         write(iout,*) "jik",jik,"i",i,"j",j
7835 c         write(iout,*) "sum_sgodl",sum_sgodl,"sgodl",sgodl
7836 c         write(iout,*) "grad_odl3",grad_odl3
7837 c         write(iout,*) "c(",jik,i,")",c(jik,i),"c(",jik,j,")",c(jik,j)
7838 c         write(iout,*) "ggodl",ggodl
7839 c         write(iout,*) "ghpbc(",jik,i,")",
7840 c     &                 ghpbc(jik,i),"ghpbc(",jik,j,")",
7841 c     &                 ghpbc(jik,j)
7842 c         endif
7843          enddo
7844 ccc       write(iout,778)"TEST: odleg2=", odleg2, "DLOG(odleg2)=",
7845 ccc     & dLOG(odleg2),"-odleg=", -odleg
7846
7847       enddo ! ii-loop for dist
7848 #ifdef DEBUG
7849       write(iout,*) "------- dist restrs end -------"
7850 c     if (waga_angle.eq.1.0d0 .or. waga_theta.eq.1.0d0 .or.
7851 c    &     waga_d.eq.1.0d0) call sum_gradient
7852 #endif
7853 c Pseudo-energy and gradient from dihedral-angle restraints from
7854 c homology templates
7855 c      write (iout,*) "End of distance loop"
7856 c      call flush(iout)
7857       kat=0.0d0
7858 c      write (iout,*) idihconstr_start_homo,idihconstr_end_homo
7859 #ifdef DEBUG
7860       write(iout,*) "------- dih restrs start -------"
7861       do i=idihconstr_start_homo,idihconstr_end_homo
7862         write (iout,*) "gloc_init(",i,icg,")",gloc(i,icg)
7863       enddo
7864 #endif
7865       do i=idihconstr_start_homo,idihconstr_end_homo
7866         kat2=0.0d0
7867 c        betai=beta(i,i+1,i+2,i+3)
7868         betai = phi(i)
7869 c       write (iout,*) "betai =",betai
7870         do k=1,constr_homology
7871           dih_diff(k)=pinorm(dih(k,i)-betai)
7872 cd          write (iout,'(a8,2i4,2f15.8)') "dih_diff",i,k,dih_diff(k)
7873 cd     &                  ,sigma_dih(k,i)
7874 c          if (dih_diff(i,k).gt.3.14159) dih_diff(i,k)=
7875 c     &                                   -(6.28318-dih_diff(i,k))
7876 c          if (dih_diff(i,k).lt.-3.14159) dih_diff(i,k)=
7877 c     &                                   6.28318+dih_diff(i,k)
7878 #ifdef OLD_DIHED
7879           kat3=-0.5d0*dih_diff(k)**2*sigma_dih(k,i) ! waga_angle rmvd from Gaussian argument
7880 #else
7881           kat3=(dcos(dih_diff(k))-1)*sigma_dih(k,i) ! waga_angle rmvd from Gaussian argument
7882 #endif
7883 c         kat3=-0.5d0*waga_angle*dih_diff(k)**2*sigma_dih(k,i)
7884           gdih(k)=dexp(kat3)
7885           kat2=kat2+gdih(k)
7886 c          write(iout,*) "kat2=", kat2, "exp(kat3)=", exp(kat3)
7887 c          write(*,*)""
7888         enddo
7889 c       write (iout,*) "gdih",(gdih(k),k=1,constr_homology) ! exps
7890 c       write (iout,*) "i",i," betai",betai," kat2",kat2 ! sum of exps
7891 #ifdef DEBUG
7892         write (iout,*) "i",i," betai",betai," kat2",kat2
7893         write (iout,*) "gdih",(gdih(k),k=1,constr_homology)
7894 #endif
7895         if (kat2.le.1.0d-14) cycle
7896         kat=kat-dLOG(kat2/constr_homology)
7897 c       write (iout,*) "kat",kat ! sum of -ln-s
7898
7899 ccc       write(iout,778)"TEST: kat2=", kat2, "DLOG(kat2)=",
7900 ccc     & dLOG(kat2), "-kat=", -kat
7901
7902 c ----------------------------------------------------------------------
7903 c Gradient
7904 c ----------------------------------------------------------------------
7905
7906         sum_gdih=kat2
7907         sum_sgdih=0.0d0
7908         do k=1,constr_homology
7909 #ifdef OLD_DIHED
7910           sgdih=-gdih(k)*dih_diff(k)*sigma_dih(k,i)  ! waga_angle rmvd
7911 #else
7912           sgdih=-gdih(k)*dsin(dih_diff(k))*sigma_dih(k,i)  ! waga_angle rmvd
7913 #endif
7914 c         sgdih=-gdih(k)*dih_diff(k)*sigma_dih(k,i)*waga_angle
7915           sum_sgdih=sum_sgdih+sgdih
7916         enddo
7917 c       grad_dih3=sum_sgdih/sum_gdih
7918         grad_dih3=waga_homology(iset)*waga_angle*sum_sgdih/sum_gdih
7919
7920 c      write(iout,*)i,k,gdih,sgdih,beta(i+1,i+2,i+3,i+4),grad_dih3
7921 ccc      write(iout,747) "GRAD_KAT_1", i, nphi, icg, grad_dih3,
7922 ccc     & gloc(nphi+i-3,icg)
7923         gloc(i-3,icg)=gloc(i-3,icg)+grad_dih3
7924 c        if (i.eq.25) then
7925 c        write(iout,*) "i",i,"icg",icg,"gloc(",i,icg,")",gloc(i,icg)
7926 c        endif
7927 ccc      write(iout,747) "GRAD_KAT_2", i, nphi, icg, grad_dih3,
7928 ccc     & gloc(nphi+i-3,icg)
7929
7930       enddo ! i-loop for dih
7931 #ifdef DEBUG
7932       write(iout,*) "------- dih restrs end -------"
7933 #endif
7934
7935 c Pseudo-energy and gradient for theta angle restraints from
7936 c homology templates
7937 c FP 01/15 - inserted from econstr_local_test.F, loop structure
7938 c adapted
7939
7940 c
7941 c     For constr_homology reference structures (FP)
7942 c
7943 c     Uconst_back_tot=0.0d0
7944       Eval=0.0d0
7945       Erot=0.0d0
7946 c     Econstr_back legacy
7947       do i=1,nres
7948 c     do i=ithet_start,ithet_end
7949        dutheta(i)=0.0d0
7950 c     enddo
7951 c     do i=loc_start,loc_end
7952         do j=1,3
7953           duscdiff(j,i)=0.0d0
7954           duscdiffx(j,i)=0.0d0
7955         enddo
7956       enddo
7957 c
7958 c     do iref=1,nref
7959 c     write (iout,*) "ithet_start =",ithet_start,"ithet_end =",ithet_end
7960 c     write (iout,*) "waga_theta",waga_theta
7961       if (waga_theta.gt.0.0d0) then
7962 #ifdef DEBUG
7963       write (iout,*) "usampl",usampl
7964       write(iout,*) "------- theta restrs start -------"
7965 c     do i=ithet_start,ithet_end
7966 c       write (iout,*) "gloc_init(",nphi+i,icg,")",gloc(nphi+i,icg)
7967 c     enddo
7968 #endif
7969 c     write (iout,*) "maxres",maxres,"nres",nres
7970
7971       do i=ithet_start,ithet_end
7972 c
7973 c     do i=1,nfrag_back
7974 c       ii = ifrag_back(2,i,iset)-ifrag_back(1,i,iset)
7975 c
7976 c Deviation of theta angles wrt constr_homology ref structures
7977 c
7978         utheta_i=0.0d0 ! argument of Gaussian for single k
7979         gutheta_i=0.0d0 ! Sum of Gaussians over constr_homology ref structures
7980 c       do j=ifrag_back(1,i,iset)+2,ifrag_back(2,i,iset) ! original loop
7981 c       over residues in a fragment
7982 c       write (iout,*) "theta(",i,")=",theta(i)
7983         do k=1,constr_homology
7984 c
7985 c         dtheta_i=theta(j)-thetaref(j,iref)
7986 c         dtheta_i=thetaref(k,i)-theta(i) ! original form without indexing
7987           theta_diff(k)=thetatpl(k,i)-theta(i)
7988 cd          write (iout,'(a8,2i4,2f15.8)') "theta_diff",i,k,theta_diff(k)
7989 cd     &                  ,sigma_theta(k,i)
7990
7991 c
7992           utheta_i=-0.5d0*theta_diff(k)**2*sigma_theta(k,i) ! waga_theta rmvd from Gaussian argument
7993 c         utheta_i=-0.5d0*waga_theta*theta_diff(k)**2*sigma_theta(k,i) ! waga_theta?
7994           gtheta(k)=dexp(utheta_i) ! + min_utheta_i?
7995           gutheta_i=gutheta_i+gtheta(k)  ! Sum of Gaussians (pk)
7996 c         Gradient for single Gaussian restraint in subr Econstr_back
7997 c         dutheta(j-2)=dutheta(j-2)+wfrag_back(1,i,iset)*dtheta_i/(ii-1)
7998 c
7999         enddo
8000 c       write (iout,*) "gtheta",(gtheta(k),k=1,constr_homology) ! exps
8001 c       write (iout,*) "i",i," gutheta_i",gutheta_i ! sum of exps
8002
8003 c
8004 c         Gradient for multiple Gaussian restraint
8005         sum_gtheta=gutheta_i
8006         sum_sgtheta=0.0d0
8007         do k=1,constr_homology
8008 c        New generalized expr for multiple Gaussian from Econstr_back
8009          sgtheta=-gtheta(k)*theta_diff(k)*sigma_theta(k,i) ! waga_theta rmvd
8010 c
8011 c        sgtheta=-gtheta(k)*theta_diff(k)*sigma_theta(k,i)*waga_theta ! right functional form?
8012           sum_sgtheta=sum_sgtheta+sgtheta ! cum variable
8013         enddo
8014 c       Final value of gradient using same var as in Econstr_back
8015         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)
8016      &      +sum_sgtheta/sum_gtheta*waga_theta
8017      &               *waga_homology(iset)
8018 c        dutheta(i-2)=sum_sgtheta/sum_gtheta*waga_theta
8019 c     &               *waga_homology(iset)
8020 c       dutheta(i)=sum_sgtheta/sum_gtheta
8021 c
8022 c       Uconst_back=Uconst_back+waga_theta*utheta(i) ! waga_theta added as weight
8023         Eval=Eval-dLOG(gutheta_i/constr_homology)
8024 c       write (iout,*) "utheta(",i,")=",utheta(i) ! -ln of sum of exps
8025 c       write (iout,*) "Uconst_back",Uconst_back ! sum of -ln-s
8026 c       Uconst_back=Uconst_back+utheta(i)
8027       enddo ! (i-loop for theta)
8028 #ifdef DEBUG
8029       write(iout,*) "------- theta restrs end -------"
8030 #endif
8031       endif
8032 c
8033 c Deviation of local SC geometry
8034 c
8035 c Separation of two i-loops (instructed by AL - 11/3/2014)
8036 c
8037 c     write (iout,*) "loc_start =",loc_start,"loc_end =",loc_end
8038 c     write (iout,*) "waga_d",waga_d
8039
8040 #ifdef DEBUG
8041       write(iout,*) "------- SC restrs start -------"
8042       write (iout,*) "Initial duscdiff,duscdiffx"
8043       do i=loc_start,loc_end
8044         write (iout,*) i,(duscdiff(jik,i),jik=1,3),
8045      &                 (duscdiffx(jik,i),jik=1,3)
8046       enddo
8047 #endif
8048       do i=loc_start,loc_end
8049         usc_diff_i=0.0d0 ! argument of Gaussian for single k
8050         guscdiff(i)=0.0d0 ! Sum of Gaussians over constr_homology ref structures
8051 c       do j=ifrag_back(1,i,iset)+1,ifrag_back(2,i,iset)-1 ! Econstr_back legacy
8052 c       write(iout,*) "xxtab, yytab, zztab"
8053 c       write(iout,'(i5,3f8.2)') i,xxtab(i),yytab(i),zztab(i)
8054         do k=1,constr_homology
8055 c
8056           dxx=-xxtpl(k,i)+xxtab(i) ! Diff b/w x component of ith SC vector in model and kth ref str?
8057 c                                    Original sign inverted for calc of gradients (s. Econstr_back)
8058           dyy=-yytpl(k,i)+yytab(i) ! ibid y
8059           dzz=-zztpl(k,i)+zztab(i) ! ibid z
8060 c         write(iout,*) "dxx, dyy, dzz"
8061 cd          write(iout,'(2i5,4f8.2)') k,i,dxx,dyy,dzz,sigma_d(k,i)
8062 c
8063           usc_diff_i=-0.5d0*(dxx**2+dyy**2+dzz**2)*sigma_d(k,i)  ! waga_d rmvd from Gaussian argument
8064 c         usc_diff(i)=-0.5d0*waga_d*(dxx**2+dyy**2+dzz**2)*sigma_d(k,i) ! waga_d?
8065 c         uscdiffk(k)=usc_diff(i)
8066           guscdiff2(k)=dexp(usc_diff_i) ! without min_scdiff
8067 c          write(iout,*) "i",i," k",k," sigma_d",sigma_d(k,i),
8068 c     &       " guscdiff2",guscdiff2(k)
8069           guscdiff(i)=guscdiff(i)+guscdiff2(k)  !Sum of Gaussians (pk)
8070 c          write (iout,'(i5,6f10.5)') j,xxtab(j),yytab(j),zztab(j),
8071 c     &      xxref(j),yyref(j),zzref(j)
8072         enddo
8073 c
8074 c       Gradient
8075 c
8076 c       Generalized expression for multiple Gaussian acc to that for a single
8077 c       Gaussian in Econstr_back as instructed by AL (FP - 03/11/2014)
8078 c
8079 c       Original implementation
8080 c       sum_guscdiff=guscdiff(i)
8081 c
8082 c       sum_sguscdiff=0.0d0
8083 c       do k=1,constr_homology
8084 c          sguscdiff=-guscdiff2(k)*dscdiff(k)*sigma_d(k,i)*waga_d !waga_d?
8085 c          sguscdiff=-guscdiff3(k)*dscdiff(k)*sigma_d(k,i)*waga_d ! w min_uscdiff
8086 c          sum_sguscdiff=sum_sguscdiff+sguscdiff
8087 c       enddo
8088 c
8089 c       Implementation of new expressions for gradient (Jan. 2015)
8090 c
8091 c       grad_uscdiff=sum_sguscdiff/(sum_guscdiff*dtab) !?
8092         do k=1,constr_homology
8093 c
8094 c       New calculation of dxx, dyy, and dzz corrected by AL (07/11), was missing and wrong
8095 c       before. Now the drivatives should be correct
8096 c
8097           dxx=-xxtpl(k,i)+xxtab(i) ! Diff b/w x component of ith SC vector in model and kth ref str?
8098 c                                  Original sign inverted for calc of gradients (s. Econstr_back)
8099           dyy=-yytpl(k,i)+yytab(i) ! ibid y
8100           dzz=-zztpl(k,i)+zztab(i) ! ibid z
8101 c
8102 c         New implementation
8103 c
8104           sum_guscdiff=guscdiff2(k)*!(dsqrt(dxx*dxx+dyy*dyy+dzz*dzz))* -> wrong!
8105      &                 sigma_d(k,i) ! for the grad wrt r'
8106 c         sum_sguscdiff=sum_sguscdiff+sum_guscdiff
8107 c
8108 c
8109 c        New implementation
8110          sum_guscdiff = waga_homology(iset)*waga_d*sum_guscdiff
8111          do jik=1,3
8112             duscdiff(jik,i-1)=duscdiff(jik,i-1)+
8113      &      sum_guscdiff*(dXX_C1tab(jik,i)*dxx+
8114      &      dYY_C1tab(jik,i)*dyy+dZZ_C1tab(jik,i)*dzz)/guscdiff(i)
8115             duscdiff(jik,i)=duscdiff(jik,i)+
8116      &      sum_guscdiff*(dXX_Ctab(jik,i)*dxx+
8117      &      dYY_Ctab(jik,i)*dyy+dZZ_Ctab(jik,i)*dzz)/guscdiff(i)
8118             duscdiffx(jik,i)=duscdiffx(jik,i)+
8119      &      sum_guscdiff*(dXX_XYZtab(jik,i)*dxx+
8120      &      dYY_XYZtab(jik,i)*dyy+dZZ_XYZtab(jik,i)*dzz)/guscdiff(i)
8121 c
8122 #ifdef DEBUG
8123              write(iout,*) "jik",jik,"i",i
8124              write(iout,*) "dxx, dyy, dzz"
8125              write(iout,'(2i5,3f8.2)') k,i,dxx,dyy,dzz
8126              write(iout,*) "guscdiff2(",k,")",guscdiff2(k)
8127 c            write(iout,*) "sum_sguscdiff",sum_sguscdiff
8128 cc           write(iout,*) "dXX_Ctab(",jik,i,")",dXX_Ctab(jik,i)
8129 c            write(iout,*) "dYY_Ctab(",jik,i,")",dYY_Ctab(jik,i)
8130 c            write(iout,*) "dZZ_Ctab(",jik,i,")",dZZ_Ctab(jik,i)
8131 c            write(iout,*) "dXX_C1tab(",jik,i,")",dXX_C1tab(jik,i)
8132 c            write(iout,*) "dYY_C1tab(",jik,i,")",dYY_C1tab(jik,i)
8133 c            write(iout,*) "dZZ_C1tab(",jik,i,")",dZZ_C1tab(jik,i)
8134 c            write(iout,*) "dXX_XYZtab(",jik,i,")",dXX_XYZtab(jik,i)
8135 c            write(iout,*) "dYY_XYZtab(",jik,i,")",dYY_XYZtab(jik,i)
8136 c            write(iout,*) "dZZ_XYZtab(",jik,i,")",dZZ_XYZtab(jik,i)
8137 c            write(iout,*) "duscdiff(",jik,i-1,")",duscdiff(jik,i-1)
8138 c            write(iout,*) "duscdiff(",jik,i,")",duscdiff(jik,i)
8139 c            write(iout,*) "duscdiffx(",jik,i,")",duscdiffx(jik,i)
8140 c            endif
8141 #endif
8142          enddo
8143         enddo
8144 c
8145 c       uscdiff(i)=-dLOG(guscdiff(i)/(ii-1))      ! Weighting by (ii-1) required?
8146 c        usc_diff(i)=-dLOG(guscdiff(i)/constr_homology) ! + min_uscdiff ?
8147 c
8148 c        write (iout,*) i," uscdiff",uscdiff(i)
8149 c
8150 c Put together deviations from local geometry
8151
8152 c       Uconst_back=Uconst_back+wfrag_back(1,i,iset)*utheta(i)+
8153 c      &            wfrag_back(3,i,iset)*uscdiff(i)
8154         Erot=Erot-dLOG(guscdiff(i)/constr_homology)
8155 c       write (iout,*) "usc_diff(",i,")=",usc_diff(i) ! -ln of sum of exps
8156 c       write (iout,*) "Uconst_back",Uconst_back ! cum sum of -ln-s
8157 c       Uconst_back=Uconst_back+usc_diff(i)
8158 c
8159 c     Gradient of multiple Gaussian restraint (FP - 04/11/2014 - right?)
8160 c
8161 c     New implment: multiplied by sum_sguscdiff
8162 c
8163
8164       enddo ! (i-loop for dscdiff)
8165
8166 c      endif
8167
8168 #ifdef DEBUG
8169       write(iout,*) "------- SC restrs end -------"
8170         write (iout,*) "------ After SC loop in e_modeller ------"
8171         do i=loc_start,loc_end
8172          write (iout,*) "i",i," gradc",(gradc(j,i,icg),j=1,3)
8173          write (iout,*) "i",i," gradx",(gradx(j,i,icg),j=1,3)
8174         enddo
8175       if (waga_theta.eq.1.0d0) then
8176       write (iout,*) "in e_modeller after SC restr end: dutheta"
8177       do i=ithet_start,ithet_end
8178         write (iout,*) i,dutheta(i)
8179       enddo
8180       endif
8181       if (waga_d.eq.1.0d0) then
8182       write (iout,*) "e_modeller after SC loop: duscdiff/x"
8183       do i=1,nres
8184         write (iout,*) i,(duscdiff(j,i),j=1,3)
8185         write (iout,*) i,(duscdiffx(j,i),j=1,3)
8186       enddo
8187       endif
8188 #endif
8189
8190 c Total energy from homology restraints
8191 #ifdef DEBUG
8192       write (iout,*) "odleg",odleg," kat",kat
8193 #endif
8194 c
8195 c Addition of energy of theta angle and SC local geom over constr_homologs ref strs
8196 c
8197 c     ehomology_constr=odleg+kat
8198 c
8199 c     For Lorentzian-type Urestr
8200 c
8201
8202       if (waga_dist.ge.0.0d0) then
8203 c
8204 c          For Gaussian-type Urestr
8205 c
8206         ehomology_constr=(waga_dist*odleg+waga_angle*kat+
8207      &              waga_theta*Eval+waga_d*Erot)*waga_homology(iset)
8208 c     write (iout,*) "ehomology_constr=",ehomology_constr
8209       else
8210 c
8211 c          For Lorentzian-type Urestr
8212 c
8213         ehomology_constr=(-waga_dist*odleg+waga_angle*kat+
8214      &              waga_theta*Eval+waga_d*Erot)*waga_homology(iset)
8215 c     write (iout,*) "ehomology_constr=",ehomology_constr
8216       endif
8217 #ifdef DEBUG
8218       write (iout,*) "odleg",waga_dist,odleg," kat",waga_angle,kat,
8219      & "Eval",waga_theta,eval,
8220      &   "Erot",waga_d,Erot
8221       write (iout,*) "ehomology_constr",ehomology_constr
8222 #endif
8223       return
8224 c
8225 c FP 01/15 end
8226 c
8227   748 format(a8,f12.3,a6,f12.3,a7,f12.3)
8228   747 format(a12,i4,i4,i4,f8.3,f8.3)
8229   746 format(a12,i4,i4,i4,f8.3,f8.3,f8.3)
8230   778 format(a7,1X,f10.3,1X,a4,1X,f10.3,1X,a5,1X,f10.3)
8231   779 format(i3,1X,i3,1X,i2,1X,a7,1X,f7.3,1X,a7,1X,f7.3,1X,a13,1X,
8232      &       f7.3,1X,a17,1X,f9.3,1X,a10,1X,f8.3,1X,a10,1X,f8.3)
8233       end
8234 c----------------------------------------------------------------------------
8235 C The rigorous attempt to derive energy function
8236       subroutine ebend_kcc(etheta)
8237
8238       implicit real*8 (a-h,o-z)
8239       include 'DIMENSIONS'
8240       include 'COMMON.VAR'
8241       include 'COMMON.GEO'
8242       include 'COMMON.LOCAL'
8243       include 'COMMON.TORSION'
8244       include 'COMMON.INTERACT'
8245       include 'COMMON.DERIV'
8246       include 'COMMON.CHAIN'
8247       include 'COMMON.NAMES'
8248       include 'COMMON.IOUNITS'
8249       include 'COMMON.FFIELD'
8250       include 'COMMON.TORCNSTR'
8251       include 'COMMON.CONTROL'
8252       logical lprn
8253       double precision thybt1(maxang_kcc)
8254 C Set lprn=.true. for debugging
8255       lprn=energy_dec
8256 c     lprn=.true.
8257 C      print *,"wchodze kcc"
8258       if (lprn) write (iout,*) "ebend_kcc tor_mode",tor_mode
8259       etheta=0.0D0
8260       do i=ithet_start,ithet_end
8261 c        print *,i,itype(i-1),itype(i),itype(i-2)
8262         if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
8263      &  .or.itype(i).eq.ntyp1) cycle
8264         iti=iabs(itortyp(itype(i-1)))
8265         sinthet=dsin(theta(i))
8266         costhet=dcos(theta(i))
8267         do j=1,nbend_kcc_Tb(iti)
8268           thybt1(j)=v1bend_chyb(j,iti)
8269         enddo
8270         sumth1thyb=v1bend_chyb(0,iti)+
8271      &    tschebyshev(1,nbend_kcc_Tb(iti),thybt1(1),costhet)
8272         if (lprn) write (iout,*) i-1,itype(i-1),iti,theta(i)*rad2deg,
8273      &    sumth1thyb
8274         ihelp=nbend_kcc_Tb(iti)-1
8275         gradthybt1=gradtschebyshev(0,ihelp,thybt1(1),costhet)
8276         etheta=etheta+sumth1thyb
8277 C        print *,sumth1thyb,gradthybt1,sinthet*(-0.5d0)
8278         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)-wang*gradthybt1*sinthet
8279       enddo
8280       return
8281       end
8282 c-------------------------------------------------------------------------------------
8283       subroutine etheta_constr(ethetacnstr)
8284
8285       implicit real*8 (a-h,o-z)
8286       include 'DIMENSIONS'
8287       include 'COMMON.VAR'
8288       include 'COMMON.GEO'
8289       include 'COMMON.LOCAL'
8290       include 'COMMON.TORSION'
8291       include 'COMMON.INTERACT'
8292       include 'COMMON.DERIV'
8293       include 'COMMON.CHAIN'
8294       include 'COMMON.NAMES'
8295       include 'COMMON.IOUNITS'
8296       include 'COMMON.FFIELD'
8297       include 'COMMON.TORCNSTR'
8298       include 'COMMON.CONTROL'
8299       ethetacnstr=0.0d0
8300 C      print *,ithetaconstr_start,ithetaconstr_end,"TU"
8301       do i=ithetaconstr_start,ithetaconstr_end
8302         itheta=itheta_constr(i)
8303         thetiii=theta(itheta)
8304         difi=pinorm(thetiii-theta_constr0(i))
8305         if (difi.gt.theta_drange(i)) then
8306           difi=difi-theta_drange(i)
8307           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
8308           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
8309      &    +for_thet_constr(i)*difi**3
8310         else if (difi.lt.-drange(i)) then
8311           difi=difi+drange(i)
8312           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
8313           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
8314      &    +for_thet_constr(i)*difi**3
8315         else
8316           difi=0.0
8317         endif
8318        if (energy_dec) then
8319         write (iout,'(a6,2i5,4f8.3,2e14.5)') "ethetc",
8320      &    i,itheta,rad2deg*thetiii,
8321      &    rad2deg*theta_constr0(i),  rad2deg*theta_drange(i),
8322      &    rad2deg*difi,0.25d0*for_thet_constr(i)*difi**4,
8323      &    gloc(itheta+nphi-2,icg)
8324         endif
8325       enddo
8326       return
8327       end
8328 c------------------------------------------------------------------------------
8329       subroutine eback_sc_corr(esccor)
8330 c 7/21/2007 Correlations between the backbone-local and side-chain-local
8331 c        conformational states; temporarily implemented as differences
8332 c        between UNRES torsional potentials (dependent on three types of
8333 c        residues) and the torsional potentials dependent on all 20 types
8334 c        of residues computed from AM1  energy surfaces of terminally-blocked
8335 c        amino-acid residues.
8336       implicit real*8 (a-h,o-z)
8337       include 'DIMENSIONS'
8338       include 'COMMON.VAR'
8339       include 'COMMON.GEO'
8340       include 'COMMON.LOCAL'
8341       include 'COMMON.TORSION'
8342       include 'COMMON.SCCOR'
8343       include 'COMMON.INTERACT'
8344       include 'COMMON.DERIV'
8345       include 'COMMON.CHAIN'
8346       include 'COMMON.NAMES'
8347       include 'COMMON.IOUNITS'
8348       include 'COMMON.FFIELD'
8349       include 'COMMON.CONTROL'
8350       logical lprn
8351 C Set lprn=.true. for debugging
8352       lprn=.false.
8353 c      lprn=.true.
8354 c      write (iout,*) "EBACK_SC_COR",itau_start,itau_end
8355       esccor=0.0D0
8356       do i=itau_start,itau_end
8357         if ((itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)) cycle
8358         esccor_ii=0.0D0
8359         isccori=isccortyp(itype(i-2))
8360         isccori1=isccortyp(itype(i-1))
8361 c      write (iout,*) "EBACK_SC_COR",i,nterm_sccor(isccori,isccori1)
8362         phii=phi(i)
8363         do intertyp=1,3 !intertyp
8364 cc Added 09 May 2012 (Adasko)
8365 cc  Intertyp means interaction type of backbone mainchain correlation:
8366 c   1 = SC...Ca...Ca...Ca
8367 c   2 = Ca...Ca...Ca...SC
8368 c   3 = SC...Ca...Ca...SCi
8369         gloci=0.0D0
8370         if (((intertyp.eq.3).and.((itype(i-2).eq.10).or.
8371      &      (itype(i-1).eq.10).or.(itype(i-2).eq.ntyp1).or.
8372      &      (itype(i-1).eq.ntyp1)))
8373      &    .or. ((intertyp.eq.1).and.((itype(i-2).eq.10)
8374      &     .or.(itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)
8375      &     .or.(itype(i).eq.ntyp1)))
8376      &    .or.((intertyp.eq.2).and.((itype(i-1).eq.10).or.
8377      &      (itype(i-1).eq.ntyp1).or.(itype(i-2).eq.ntyp1).or.
8378      &      (itype(i-3).eq.ntyp1)))) cycle
8379         if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1).eq.ntyp1)) cycle
8380         if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres).eq.ntyp1))
8381      & cycle
8382        do j=1,nterm_sccor(isccori,isccori1)
8383           v1ij=v1sccor(j,intertyp,isccori,isccori1)
8384           v2ij=v2sccor(j,intertyp,isccori,isccori1)
8385           cosphi=dcos(j*tauangle(intertyp,i))
8386           sinphi=dsin(j*tauangle(intertyp,i))
8387           esccor=esccor+v1ij*cosphi+v2ij*sinphi
8388           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
8389         enddo
8390 c      write (iout,*) "EBACK_SC_COR",i,v1ij*cosphi+v2ij*sinphi,intertyp
8391         gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci
8392         if (lprn)
8393      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
8394      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,isccori,isccori1,
8395      &  (v1sccor(j,intertyp,isccori,isccori1),j=1,6)
8396      & ,(v2sccor(j,intertyp,isccori,isccori1),j=1,6)
8397         gsccor_loc(i-3)=gsccor_loc(i-3)+gloci
8398        enddo !intertyp
8399       enddo
8400
8401       return
8402       end
8403 #ifdef FOURBODY
8404 c----------------------------------------------------------------------------
8405       subroutine multibody(ecorr)
8406 C This subroutine calculates multi-body contributions to energy following
8407 C the idea of Skolnick et al. If side chains I and J make a contact and
8408 C at the same time side chains I+1 and J+1 make a contact, an extra
8409 C contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
8410       implicit real*8 (a-h,o-z)
8411       include 'DIMENSIONS'
8412       include 'COMMON.IOUNITS'
8413       include 'COMMON.DERIV'
8414       include 'COMMON.INTERACT'
8415       include 'COMMON.CONTACTS'
8416       include 'COMMON.CONTMAT'
8417       include 'COMMON.CORRMAT'
8418       double precision gx(3),gx1(3)
8419       logical lprn
8420
8421 C Set lprn=.true. for debugging
8422       lprn=.false.
8423
8424       if (lprn) then
8425         write (iout,'(a)') 'Contact function values:'
8426         do i=nnt,nct-2
8427           write (iout,'(i2,20(1x,i2,f10.5))')
8428      &        i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
8429         enddo
8430       endif
8431       ecorr=0.0D0
8432       do i=nnt,nct
8433         do j=1,3
8434           gradcorr(j,i)=0.0D0
8435           gradxorr(j,i)=0.0D0
8436         enddo
8437       enddo
8438       do i=nnt,nct-2
8439
8440         DO ISHIFT = 3,4
8441
8442         i1=i+ishift
8443         num_conti=num_cont(i)
8444         num_conti1=num_cont(i1)
8445         do jj=1,num_conti
8446           j=jcont(jj,i)
8447           do kk=1,num_conti1
8448             j1=jcont(kk,i1)
8449             if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
8450 cd          write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
8451 cd   &                   ' ishift=',ishift
8452 C Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
8453 C The system gains extra energy.
8454               ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
8455             endif   ! j1==j+-ishift
8456           enddo     ! kk
8457         enddo       ! jj
8458
8459         ENDDO ! ISHIFT
8460
8461       enddo         ! i
8462       return
8463       end
8464 c------------------------------------------------------------------------------
8465       double precision function esccorr(i,j,k,l,jj,kk)
8466       implicit real*8 (a-h,o-z)
8467       include 'DIMENSIONS'
8468       include 'COMMON.IOUNITS'
8469       include 'COMMON.DERIV'
8470       include 'COMMON.INTERACT'
8471       include 'COMMON.CONTACTS'
8472       include 'COMMON.CONTMAT'
8473       include 'COMMON.CORRMAT'
8474       include 'COMMON.SHIELD'
8475       double precision gx(3),gx1(3)
8476       logical lprn
8477       lprn=.false.
8478       eij=facont(jj,i)
8479       ekl=facont(kk,k)
8480 cd    write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
8481 C Calculate the multi-body contribution to energy.
8482 C Calculate multi-body contributions to the gradient.
8483 cd    write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
8484 cd   & k,l,(gacont(m,kk,k),m=1,3)
8485       do m=1,3
8486         gx(m) =ekl*gacont(m,jj,i)
8487         gx1(m)=eij*gacont(m,kk,k)
8488         gradxorr(m,i)=gradxorr(m,i)-gx(m)
8489         gradxorr(m,j)=gradxorr(m,j)+gx(m)
8490         gradxorr(m,k)=gradxorr(m,k)-gx1(m)
8491         gradxorr(m,l)=gradxorr(m,l)+gx1(m)
8492       enddo
8493       do m=i,j-1
8494         do ll=1,3
8495           gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
8496         enddo
8497       enddo
8498       do m=k,l-1
8499         do ll=1,3
8500           gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
8501         enddo
8502       enddo
8503       esccorr=-eij*ekl
8504       return
8505       end
8506 c------------------------------------------------------------------------------
8507       subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
8508 C This subroutine calculates multi-body contributions to hydrogen-bonding
8509       implicit real*8 (a-h,o-z)
8510       include 'DIMENSIONS'
8511       include 'COMMON.IOUNITS'
8512 #ifdef MPI
8513       include "mpif.h"
8514       parameter (max_cont=maxconts)
8515       parameter (max_dim=26)
8516       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
8517       double precision zapas(max_dim,maxconts,max_fg_procs),
8518      &  zapas_recv(max_dim,maxconts,max_fg_procs)
8519       common /przechowalnia/ zapas
8520       integer status(MPI_STATUS_SIZE),req(maxconts*2),
8521      &  status_array(MPI_STATUS_SIZE,maxconts*2)
8522 #endif
8523       include 'COMMON.SETUP'
8524       include 'COMMON.FFIELD'
8525       include 'COMMON.DERIV'
8526       include 'COMMON.INTERACT'
8527       include 'COMMON.CONTACTS'
8528       include 'COMMON.CONTMAT'
8529       include 'COMMON.CORRMAT'
8530       include 'COMMON.CONTROL'
8531       include 'COMMON.LOCAL'
8532       double precision gx(3),gx1(3),time00
8533       logical lprn,ldone
8534
8535 C Set lprn=.true. for debugging
8536       lprn=.false.
8537 #ifdef MPI
8538       n_corr=0
8539       n_corr1=0
8540       if (nfgtasks.le.1) goto 30
8541       if (lprn) then
8542         write (iout,'(a)') 'Contact function values before RECEIVE:'
8543         do i=nnt,nct-2
8544           write (iout,'(2i3,50(1x,i2,f5.2))')
8545      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
8546      &    j=1,num_cont_hb(i))
8547         enddo
8548         call flush(iout)
8549       endif
8550       do i=1,ntask_cont_from
8551         ncont_recv(i)=0
8552       enddo
8553       do i=1,ntask_cont_to
8554         ncont_sent(i)=0
8555       enddo
8556 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
8557 c     & ntask_cont_to
8558 C Make the list of contacts to send to send to other procesors
8559 c      write (iout,*) "limits",max0(iturn4_end-1,iatel_s),iturn3_end
8560 c      call flush(iout)
8561       do i=iturn3_start,iturn3_end
8562 c        write (iout,*) "make contact list turn3",i," num_cont",
8563 c     &    num_cont_hb(i)
8564         call add_hb_contact(i,i+2,iturn3_sent_local(1,i))
8565       enddo
8566       do i=iturn4_start,iturn4_end
8567 c        write (iout,*) "make contact list turn4",i," num_cont",
8568 c     &   num_cont_hb(i)
8569         call add_hb_contact(i,i+3,iturn4_sent_local(1,i))
8570       enddo
8571       do ii=1,nat_sent
8572         i=iat_sent(ii)
8573 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
8574 c     &    num_cont_hb(i)
8575         do j=1,num_cont_hb(i)
8576         do k=1,4
8577           jjc=jcont_hb(j,i)
8578           iproc=iint_sent_local(k,jjc,ii)
8579 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
8580           if (iproc.gt.0) then
8581             ncont_sent(iproc)=ncont_sent(iproc)+1
8582             nn=ncont_sent(iproc)
8583             zapas(1,nn,iproc)=i
8584             zapas(2,nn,iproc)=jjc
8585             zapas(3,nn,iproc)=facont_hb(j,i)
8586             zapas(4,nn,iproc)=ees0p(j,i)
8587             zapas(5,nn,iproc)=ees0m(j,i)
8588             zapas(6,nn,iproc)=gacont_hbr(1,j,i)
8589             zapas(7,nn,iproc)=gacont_hbr(2,j,i)
8590             zapas(8,nn,iproc)=gacont_hbr(3,j,i)
8591             zapas(9,nn,iproc)=gacontm_hb1(1,j,i)
8592             zapas(10,nn,iproc)=gacontm_hb1(2,j,i)
8593             zapas(11,nn,iproc)=gacontm_hb1(3,j,i)
8594             zapas(12,nn,iproc)=gacontp_hb1(1,j,i)
8595             zapas(13,nn,iproc)=gacontp_hb1(2,j,i)
8596             zapas(14,nn,iproc)=gacontp_hb1(3,j,i)
8597             zapas(15,nn,iproc)=gacontm_hb2(1,j,i)
8598             zapas(16,nn,iproc)=gacontm_hb2(2,j,i)
8599             zapas(17,nn,iproc)=gacontm_hb2(3,j,i)
8600             zapas(18,nn,iproc)=gacontp_hb2(1,j,i)
8601             zapas(19,nn,iproc)=gacontp_hb2(2,j,i)
8602             zapas(20,nn,iproc)=gacontp_hb2(3,j,i)
8603             zapas(21,nn,iproc)=gacontm_hb3(1,j,i)
8604             zapas(22,nn,iproc)=gacontm_hb3(2,j,i)
8605             zapas(23,nn,iproc)=gacontm_hb3(3,j,i)
8606             zapas(24,nn,iproc)=gacontp_hb3(1,j,i)
8607             zapas(25,nn,iproc)=gacontp_hb3(2,j,i)
8608             zapas(26,nn,iproc)=gacontp_hb3(3,j,i)
8609           endif
8610         enddo
8611         enddo
8612       enddo
8613       if (lprn) then
8614       write (iout,*)
8615      &  "Numbers of contacts to be sent to other processors",
8616      &  (ncont_sent(i),i=1,ntask_cont_to)
8617       write (iout,*) "Contacts sent"
8618       do ii=1,ntask_cont_to
8619         nn=ncont_sent(ii)
8620         iproc=itask_cont_to(ii)
8621         write (iout,*) nn," contacts to processor",iproc,
8622      &   " of CONT_TO_COMM group"
8623         do i=1,nn
8624           write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
8625         enddo
8626       enddo
8627       call flush(iout)
8628       endif
8629       CorrelType=477
8630       CorrelID=fg_rank+1
8631       CorrelType1=478
8632       CorrelID1=nfgtasks+fg_rank+1
8633       ireq=0
8634 C Receive the numbers of needed contacts from other processors
8635       do ii=1,ntask_cont_from
8636         iproc=itask_cont_from(ii)
8637         ireq=ireq+1
8638         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
8639      &    FG_COMM,req(ireq),IERR)
8640       enddo
8641 c      write (iout,*) "IRECV ended"
8642 c      call flush(iout)
8643 C Send the number of contacts needed by other processors
8644       do ii=1,ntask_cont_to
8645         iproc=itask_cont_to(ii)
8646         ireq=ireq+1
8647         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
8648      &    FG_COMM,req(ireq),IERR)
8649       enddo
8650 c      write (iout,*) "ISEND ended"
8651 c      write (iout,*) "number of requests (nn)",ireq
8652 c      call flush(iout)
8653       if (ireq.gt.0)
8654      &  call MPI_Waitall(ireq,req,status_array,ierr)
8655 c      write (iout,*)
8656 c     &  "Numbers of contacts to be received from other processors",
8657 c     &  (ncont_recv(i),i=1,ntask_cont_from)
8658 c      call flush(iout)
8659 C Receive contacts
8660       ireq=0
8661       do ii=1,ntask_cont_from
8662         iproc=itask_cont_from(ii)
8663         nn=ncont_recv(ii)
8664 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
8665 c     &   " of CONT_TO_COMM group"
8666 c        call flush(iout)
8667         if (nn.gt.0) then
8668           ireq=ireq+1
8669           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
8670      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
8671 c          write (iout,*) "ireq,req",ireq,req(ireq)
8672         endif
8673       enddo
8674 C Send the contacts to processors that need them
8675       do ii=1,ntask_cont_to
8676         iproc=itask_cont_to(ii)
8677         nn=ncont_sent(ii)
8678 c        write (iout,*) nn," contacts to processor",iproc,
8679 c     &   " of CONT_TO_COMM group"
8680         if (nn.gt.0) then
8681           ireq=ireq+1
8682           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
8683      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
8684 c          write (iout,*) "ireq,req",ireq,req(ireq)
8685 c          do i=1,nn
8686 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
8687 c          enddo
8688         endif
8689       enddo
8690 c      write (iout,*) "number of requests (contacts)",ireq
8691 c      write (iout,*) "req",(req(i),i=1,4)
8692 c      call flush(iout)
8693       if (ireq.gt.0)
8694      & call MPI_Waitall(ireq,req,status_array,ierr)
8695       do iii=1,ntask_cont_from
8696         iproc=itask_cont_from(iii)
8697         nn=ncont_recv(iii)
8698         if (lprn) then
8699         write (iout,*) "Received",nn," contacts from processor",iproc,
8700      &   " of CONT_FROM_COMM group"
8701         call flush(iout)
8702         do i=1,nn
8703           write(iout,'(2f5.0,4f10.5)')(zapas_recv(j,i,iii),j=1,5)
8704         enddo
8705         call flush(iout)
8706         endif
8707         do i=1,nn
8708           ii=zapas_recv(1,i,iii)
8709 c Flag the received contacts to prevent double-counting
8710           jj=-zapas_recv(2,i,iii)
8711 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
8712 c          call flush(iout)
8713           nnn=num_cont_hb(ii)+1
8714           num_cont_hb(ii)=nnn
8715           jcont_hb(nnn,ii)=jj
8716           facont_hb(nnn,ii)=zapas_recv(3,i,iii)
8717           ees0p(nnn,ii)=zapas_recv(4,i,iii)
8718           ees0m(nnn,ii)=zapas_recv(5,i,iii)
8719           gacont_hbr(1,nnn,ii)=zapas_recv(6,i,iii)
8720           gacont_hbr(2,nnn,ii)=zapas_recv(7,i,iii)
8721           gacont_hbr(3,nnn,ii)=zapas_recv(8,i,iii)
8722           gacontm_hb1(1,nnn,ii)=zapas_recv(9,i,iii)
8723           gacontm_hb1(2,nnn,ii)=zapas_recv(10,i,iii)
8724           gacontm_hb1(3,nnn,ii)=zapas_recv(11,i,iii)
8725           gacontp_hb1(1,nnn,ii)=zapas_recv(12,i,iii)
8726           gacontp_hb1(2,nnn,ii)=zapas_recv(13,i,iii)
8727           gacontp_hb1(3,nnn,ii)=zapas_recv(14,i,iii)
8728           gacontm_hb2(1,nnn,ii)=zapas_recv(15,i,iii)
8729           gacontm_hb2(2,nnn,ii)=zapas_recv(16,i,iii)
8730           gacontm_hb2(3,nnn,ii)=zapas_recv(17,i,iii)
8731           gacontp_hb2(1,nnn,ii)=zapas_recv(18,i,iii)
8732           gacontp_hb2(2,nnn,ii)=zapas_recv(19,i,iii)
8733           gacontp_hb2(3,nnn,ii)=zapas_recv(20,i,iii)
8734           gacontm_hb3(1,nnn,ii)=zapas_recv(21,i,iii)
8735           gacontm_hb3(2,nnn,ii)=zapas_recv(22,i,iii)
8736           gacontm_hb3(3,nnn,ii)=zapas_recv(23,i,iii)
8737           gacontp_hb3(1,nnn,ii)=zapas_recv(24,i,iii)
8738           gacontp_hb3(2,nnn,ii)=zapas_recv(25,i,iii)
8739           gacontp_hb3(3,nnn,ii)=zapas_recv(26,i,iii)
8740         enddo
8741       enddo
8742       if (lprn) then
8743         write (iout,'(a)') 'Contact function values after receive:'
8744         do i=nnt,nct-2
8745           write (iout,'(2i3,50(1x,i3,f5.2))')
8746      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
8747      &    j=1,num_cont_hb(i))
8748         enddo
8749         call flush(iout)
8750       endif
8751    30 continue
8752 #endif
8753       if (lprn) then
8754         write (iout,'(a)') 'Contact function values:'
8755         do i=nnt,nct-2
8756           write (iout,'(2i3,50(1x,i3,f5.2))')
8757      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
8758      &    j=1,num_cont_hb(i))
8759         enddo
8760         call flush(iout)
8761       endif
8762       ecorr=0.0D0
8763 C Remove the loop below after debugging !!!
8764       do i=nnt,nct
8765         do j=1,3
8766           gradcorr(j,i)=0.0D0
8767           gradxorr(j,i)=0.0D0
8768         enddo
8769       enddo
8770 C Calculate the local-electrostatic correlation terms
8771       do i=min0(iatel_s,iturn4_start),max0(iatel_e,iturn3_end)
8772         i1=i+1
8773         num_conti=num_cont_hb(i)
8774         num_conti1=num_cont_hb(i+1)
8775         do jj=1,num_conti
8776           j=jcont_hb(jj,i)
8777           jp=iabs(j)
8778           do kk=1,num_conti1
8779             j1=jcont_hb(kk,i1)
8780             jp1=iabs(j1)
8781 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
8782 c     &         ' jj=',jj,' kk=',kk
8783 c            call flush(iout)
8784             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
8785      &          .or. j.lt.0 .and. j1.gt.0) .and.
8786      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
8787 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
8788 C The system gains extra energy.
8789               ecorr=ecorr+ehbcorr(i,jp,i+1,jp1,jj,kk,0.72D0,0.32D0)
8790               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
8791      &            'ecorrh',i,j,ehbcorr(i,j,i+1,j1,jj,kk,0.72D0,0.32D0)
8792               n_corr=n_corr+1
8793             else if (j1.eq.j) then
8794 C Contacts I-J and I-(J+1) occur simultaneously.
8795 C The system loses extra energy.
8796 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
8797             endif
8798           enddo ! kk
8799           do kk=1,num_conti
8800             j1=jcont_hb(kk,i)
8801 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
8802 c    &         ' jj=',jj,' kk=',kk
8803             if (j1.eq.j+1) then
8804 C Contacts I-J and (I+1)-J occur simultaneously.
8805 C The system loses extra energy.
8806 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
8807             endif ! j1==j+1
8808           enddo ! kk
8809         enddo ! jj
8810       enddo ! i
8811       return
8812       end
8813 c------------------------------------------------------------------------------
8814       subroutine add_hb_contact(ii,jj,itask)
8815       implicit real*8 (a-h,o-z)
8816       include "DIMENSIONS"
8817       include "COMMON.IOUNITS"
8818       integer max_cont
8819       integer max_dim
8820       parameter (max_cont=maxconts)
8821       parameter (max_dim=26)
8822       include "COMMON.CONTACTS"
8823       include 'COMMON.CONTMAT'
8824       include 'COMMON.CORRMAT'
8825       double precision zapas(max_dim,maxconts,max_fg_procs),
8826      &  zapas_recv(max_dim,maxconts,max_fg_procs)
8827       common /przechowalnia/ zapas
8828       integer i,j,ii,jj,iproc,itask(4),nn
8829 c      write (iout,*) "itask",itask
8830       do i=1,2
8831         iproc=itask(i)
8832         if (iproc.gt.0) then
8833           do j=1,num_cont_hb(ii)
8834             jjc=jcont_hb(j,ii)
8835 c            write (iout,*) "i",ii," j",jj," jjc",jjc
8836             if (jjc.eq.jj) then
8837               ncont_sent(iproc)=ncont_sent(iproc)+1
8838               nn=ncont_sent(iproc)
8839               zapas(1,nn,iproc)=ii
8840               zapas(2,nn,iproc)=jjc
8841               zapas(3,nn,iproc)=facont_hb(j,ii)
8842               zapas(4,nn,iproc)=ees0p(j,ii)
8843               zapas(5,nn,iproc)=ees0m(j,ii)
8844               zapas(6,nn,iproc)=gacont_hbr(1,j,ii)
8845               zapas(7,nn,iproc)=gacont_hbr(2,j,ii)
8846               zapas(8,nn,iproc)=gacont_hbr(3,j,ii)
8847               zapas(9,nn,iproc)=gacontm_hb1(1,j,ii)
8848               zapas(10,nn,iproc)=gacontm_hb1(2,j,ii)
8849               zapas(11,nn,iproc)=gacontm_hb1(3,j,ii)
8850               zapas(12,nn,iproc)=gacontp_hb1(1,j,ii)
8851               zapas(13,nn,iproc)=gacontp_hb1(2,j,ii)
8852               zapas(14,nn,iproc)=gacontp_hb1(3,j,ii)
8853               zapas(15,nn,iproc)=gacontm_hb2(1,j,ii)
8854               zapas(16,nn,iproc)=gacontm_hb2(2,j,ii)
8855               zapas(17,nn,iproc)=gacontm_hb2(3,j,ii)
8856               zapas(18,nn,iproc)=gacontp_hb2(1,j,ii)
8857               zapas(19,nn,iproc)=gacontp_hb2(2,j,ii)
8858               zapas(20,nn,iproc)=gacontp_hb2(3,j,ii)
8859               zapas(21,nn,iproc)=gacontm_hb3(1,j,ii)
8860               zapas(22,nn,iproc)=gacontm_hb3(2,j,ii)
8861               zapas(23,nn,iproc)=gacontm_hb3(3,j,ii)
8862               zapas(24,nn,iproc)=gacontp_hb3(1,j,ii)
8863               zapas(25,nn,iproc)=gacontp_hb3(2,j,ii)
8864               zapas(26,nn,iproc)=gacontp_hb3(3,j,ii)
8865               exit
8866             endif
8867           enddo
8868         endif
8869       enddo
8870       return
8871       end
8872 c------------------------------------------------------------------------------
8873       subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,
8874      &  n_corr1)
8875 C This subroutine calculates multi-body contributions to hydrogen-bonding
8876       implicit real*8 (a-h,o-z)
8877       include 'DIMENSIONS'
8878       include 'COMMON.IOUNITS'
8879 #ifdef MPI
8880       include "mpif.h"
8881       parameter (max_cont=maxconts)
8882       parameter (max_dim=70)
8883       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
8884       double precision zapas(max_dim,maxconts,max_fg_procs),
8885      &  zapas_recv(max_dim,maxconts,max_fg_procs)
8886       common /przechowalnia/ zapas
8887       integer status(MPI_STATUS_SIZE),req(maxconts*2),
8888      &  status_array(MPI_STATUS_SIZE,maxconts*2)
8889 #endif
8890       include 'COMMON.SETUP'
8891       include 'COMMON.FFIELD'
8892       include 'COMMON.DERIV'
8893       include 'COMMON.LOCAL'
8894       include 'COMMON.INTERACT'
8895       include 'COMMON.CONTACTS'
8896       include 'COMMON.CONTMAT'
8897       include 'COMMON.CORRMAT'
8898       include 'COMMON.CHAIN'
8899       include 'COMMON.CONTROL'
8900       include 'COMMON.SHIELD'
8901       double precision gx(3),gx1(3)
8902       integer num_cont_hb_old(maxres)
8903       logical lprn,ldone
8904       double precision eello4,eello5,eelo6,eello_turn6
8905       external eello4,eello5,eello6,eello_turn6
8906 C Set lprn=.true. for debugging
8907       lprn=.false.
8908       eturn6=0.0d0
8909 #ifdef MPI
8910       do i=1,nres
8911         num_cont_hb_old(i)=num_cont_hb(i)
8912       enddo
8913       n_corr=0
8914       n_corr1=0
8915       if (nfgtasks.le.1) goto 30
8916       if (lprn) then
8917         write (iout,'(a)') 'Contact function values before RECEIVE:'
8918         do i=nnt,nct-2
8919           write (iout,'(2i3,50(1x,i2,f5.2))')
8920      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
8921      &    j=1,num_cont_hb(i))
8922         enddo
8923       endif
8924       do i=1,ntask_cont_from
8925         ncont_recv(i)=0
8926       enddo
8927       do i=1,ntask_cont_to
8928         ncont_sent(i)=0
8929       enddo
8930 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
8931 c     & ntask_cont_to
8932 C Make the list of contacts to send to send to other procesors
8933       do i=iturn3_start,iturn3_end
8934 c        write (iout,*) "make contact list turn3",i," num_cont",
8935 c     &    num_cont_hb(i)
8936         call add_hb_contact_eello(i,i+2,iturn3_sent_local(1,i))
8937       enddo
8938       do i=iturn4_start,iturn4_end
8939 c        write (iout,*) "make contact list turn4",i," num_cont",
8940 c     &   num_cont_hb(i)
8941         call add_hb_contact_eello(i,i+3,iturn4_sent_local(1,i))
8942       enddo
8943       do ii=1,nat_sent
8944         i=iat_sent(ii)
8945 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
8946 c     &    num_cont_hb(i)
8947         do j=1,num_cont_hb(i)
8948         do k=1,4
8949           jjc=jcont_hb(j,i)
8950           iproc=iint_sent_local(k,jjc,ii)
8951 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
8952           if (iproc.ne.0) then
8953             ncont_sent(iproc)=ncont_sent(iproc)+1
8954             nn=ncont_sent(iproc)
8955             zapas(1,nn,iproc)=i
8956             zapas(2,nn,iproc)=jjc
8957             zapas(3,nn,iproc)=d_cont(j,i)
8958             ind=3
8959             do kk=1,3
8960               ind=ind+1
8961               zapas(ind,nn,iproc)=grij_hb_cont(kk,j,i)
8962             enddo
8963             do kk=1,2
8964               do ll=1,2
8965                 ind=ind+1
8966                 zapas(ind,nn,iproc)=a_chuj(ll,kk,j,i)
8967               enddo
8968             enddo
8969             do jj=1,5
8970               do kk=1,3
8971                 do ll=1,2
8972                   do mm=1,2
8973                     ind=ind+1
8974                     zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,i)
8975                   enddo
8976                 enddo
8977               enddo
8978             enddo
8979           endif
8980         enddo
8981         enddo
8982       enddo
8983       if (lprn) then
8984       write (iout,*)
8985      &  "Numbers of contacts to be sent to other processors",
8986      &  (ncont_sent(i),i=1,ntask_cont_to)
8987       write (iout,*) "Contacts sent"
8988       do ii=1,ntask_cont_to
8989         nn=ncont_sent(ii)
8990         iproc=itask_cont_to(ii)
8991         write (iout,*) nn," contacts to processor",iproc,
8992      &   " of CONT_TO_COMM group"
8993         do i=1,nn
8994           write(iout,'(2f5.0,10f10.5)')(zapas(j,i,ii),j=1,10)
8995         enddo
8996       enddo
8997       call flush(iout)
8998       endif
8999       CorrelType=477
9000       CorrelID=fg_rank+1
9001       CorrelType1=478
9002       CorrelID1=nfgtasks+fg_rank+1
9003       ireq=0
9004 C Receive the numbers of needed contacts from other processors
9005       do ii=1,ntask_cont_from
9006         iproc=itask_cont_from(ii)
9007         ireq=ireq+1
9008         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
9009      &    FG_COMM,req(ireq),IERR)
9010       enddo
9011 c      write (iout,*) "IRECV ended"
9012 c      call flush(iout)
9013 C Send the number of contacts needed by other processors
9014       do ii=1,ntask_cont_to
9015         iproc=itask_cont_to(ii)
9016         ireq=ireq+1
9017         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
9018      &    FG_COMM,req(ireq),IERR)
9019       enddo
9020 c      write (iout,*) "ISEND ended"
9021 c      write (iout,*) "number of requests (nn)",ireq
9022 c      call flush(iout)
9023       if (ireq.gt.0)
9024      &  call MPI_Waitall(ireq,req,status_array,ierr)
9025 c      write (iout,*)
9026 c     &  "Numbers of contacts to be received from other processors",
9027 c     &  (ncont_recv(i),i=1,ntask_cont_from)
9028 c      call flush(iout)
9029 C Receive contacts
9030       ireq=0
9031       do ii=1,ntask_cont_from
9032         iproc=itask_cont_from(ii)
9033         nn=ncont_recv(ii)
9034 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
9035 c     &   " of CONT_TO_COMM group"
9036 c        call flush(iout)
9037         if (nn.gt.0) then
9038           ireq=ireq+1
9039           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
9040      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
9041 c          write (iout,*) "ireq,req",ireq,req(ireq)
9042         endif
9043       enddo
9044 C Send the contacts to processors that need them
9045       do ii=1,ntask_cont_to
9046         iproc=itask_cont_to(ii)
9047         nn=ncont_sent(ii)
9048 c        write (iout,*) nn," contacts to processor",iproc,
9049 c     &   " of CONT_TO_COMM group"
9050         if (nn.gt.0) then
9051           ireq=ireq+1
9052           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
9053      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
9054 c          write (iout,*) "ireq,req",ireq,req(ireq)
9055 c          do i=1,nn
9056 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
9057 c          enddo
9058         endif
9059       enddo
9060 c      write (iout,*) "number of requests (contacts)",ireq
9061 c      write (iout,*) "req",(req(i),i=1,4)
9062 c      call flush(iout)
9063       if (ireq.gt.0)
9064      & call MPI_Waitall(ireq,req,status_array,ierr)
9065       do iii=1,ntask_cont_from
9066         iproc=itask_cont_from(iii)
9067         nn=ncont_recv(iii)
9068         if (lprn) then
9069         write (iout,*) "Received",nn," contacts from processor",iproc,
9070      &   " of CONT_FROM_COMM group"
9071         call flush(iout)
9072         do i=1,nn
9073           write(iout,'(2f5.0,10f10.5)')(zapas_recv(j,i,iii),j=1,10)
9074         enddo
9075         call flush(iout)
9076         endif
9077         do i=1,nn
9078           ii=zapas_recv(1,i,iii)
9079 c Flag the received contacts to prevent double-counting
9080           jj=-zapas_recv(2,i,iii)
9081 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
9082 c          call flush(iout)
9083           nnn=num_cont_hb(ii)+1
9084           num_cont_hb(ii)=nnn
9085           jcont_hb(nnn,ii)=jj
9086           d_cont(nnn,ii)=zapas_recv(3,i,iii)
9087           ind=3
9088           do kk=1,3
9089             ind=ind+1
9090             grij_hb_cont(kk,nnn,ii)=zapas_recv(ind,i,iii)
9091           enddo
9092           do kk=1,2
9093             do ll=1,2
9094               ind=ind+1
9095               a_chuj(ll,kk,nnn,ii)=zapas_recv(ind,i,iii)
9096             enddo
9097           enddo
9098           do jj=1,5
9099             do kk=1,3
9100               do ll=1,2
9101                 do mm=1,2
9102                   ind=ind+1
9103                   a_chuj_der(mm,ll,kk,jj,nnn,ii)=zapas_recv(ind,i,iii)
9104                 enddo
9105               enddo
9106             enddo
9107           enddo
9108         enddo
9109       enddo
9110       if (lprn) then
9111         write (iout,'(a)') 'Contact function values after receive:'
9112         do i=nnt,nct-2
9113           write (iout,'(2i3,50(1x,i3,5f6.3))')
9114      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
9115      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
9116         enddo
9117         call flush(iout)
9118       endif
9119    30 continue
9120 #endif
9121       if (lprn) then
9122         write (iout,'(a)') 'Contact function values:'
9123         do i=nnt,nct-2
9124           write (iout,'(2i3,50(1x,i2,5f6.3))')
9125      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
9126      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
9127         enddo
9128       endif
9129       ecorr=0.0D0
9130       ecorr5=0.0d0
9131       ecorr6=0.0d0
9132 C Remove the loop below after debugging !!!
9133       do i=nnt,nct
9134         do j=1,3
9135           gradcorr(j,i)=0.0D0
9136           gradxorr(j,i)=0.0D0
9137         enddo
9138       enddo
9139 C Calculate the dipole-dipole interaction energies
9140       if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
9141       do i=iatel_s,iatel_e+1
9142         num_conti=num_cont_hb(i)
9143         do jj=1,num_conti
9144           j=jcont_hb(jj,i)
9145 #ifdef MOMENT
9146           call dipole(i,j,jj)
9147 #endif
9148         enddo
9149       enddo
9150       endif
9151 C Calculate the local-electrostatic correlation terms
9152 c                write (iout,*) "gradcorr5 in eello5 before loop"
9153 c                do iii=1,nres
9154 c                  write (iout,'(i5,3f10.5)')
9155 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
9156 c                enddo
9157       do i=min0(iatel_s,iturn4_start),max0(iatel_e+1,iturn3_end+1)
9158 c        write (iout,*) "corr loop i",i
9159         i1=i+1
9160         num_conti=num_cont_hb(i)
9161         num_conti1=num_cont_hb(i+1)
9162         do jj=1,num_conti
9163           j=jcont_hb(jj,i)
9164           jp=iabs(j)
9165           do kk=1,num_conti1
9166             j1=jcont_hb(kk,i1)
9167             jp1=iabs(j1)
9168 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
9169 c     &         ' jj=',jj,' kk=',kk
9170 c            if (j1.eq.j+1 .or. j1.eq.j-1) then
9171             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
9172      &          .or. j.lt.0 .and. j1.gt.0) .and.
9173      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
9174 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
9175 C The system gains extra energy.
9176               n_corr=n_corr+1
9177               sqd1=dsqrt(d_cont(jj,i))
9178               sqd2=dsqrt(d_cont(kk,i1))
9179               sred_geom = sqd1*sqd2
9180               IF (sred_geom.lt.cutoff_corr) THEN
9181                 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,
9182      &            ekont,fprimcont)
9183 cd               write (iout,*) 'i=',i,' j=',jp,' i1=',i1,' j1=',jp1,
9184 cd     &         ' jj=',jj,' kk=',kk
9185                 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
9186                 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
9187                 do l=1,3
9188                   g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
9189                   g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
9190                 enddo
9191                 n_corr1=n_corr1+1
9192 cd               write (iout,*) 'sred_geom=',sred_geom,
9193 cd     &          ' ekont=',ekont,' fprim=',fprimcont,
9194 cd     &          ' fac_prim1',fac_prim1,' fac_prim2',fac_prim2
9195 cd               write (iout,*) "g_contij",g_contij
9196 cd               write (iout,*) "grij_hb_cont i",grij_hb_cont(:,jj,i)
9197 cd               write (iout,*) "grij_hb_cont i1",grij_hb_cont(:,jj,i1)
9198                 call calc_eello(i,jp,i+1,jp1,jj,kk)
9199                 if (wcorr4.gt.0.0d0)
9200      &            ecorr=ecorr+eello4(i,jp,i+1,jp1,jj,kk)
9201 CC     &            *fac_shield(i)**2*fac_shield(j)**2
9202                   if (energy_dec.and.wcorr4.gt.0.0d0)
9203      1                 write (iout,'(a6,4i5,0pf7.3)')
9204      2                'ecorr4',i,j,i+1,j1,eello4(i,jp,i+1,jp1,jj,kk)
9205 c                write (iout,*) "gradcorr5 before eello5"
9206 c                do iii=1,nres
9207 c                  write (iout,'(i5,3f10.5)')
9208 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
9209 c                enddo
9210                 if (wcorr5.gt.0.0d0)
9211      &            ecorr5=ecorr5+eello5(i,jp,i+1,jp1,jj,kk)
9212 c                write (iout,*) "gradcorr5 after eello5"
9213 c                do iii=1,nres
9214 c                  write (iout,'(i5,3f10.5)')
9215 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
9216 c                enddo
9217                   if (energy_dec.and.wcorr5.gt.0.0d0)
9218      1                 write (iout,'(a6,4i5,0pf7.3)')
9219      2                'ecorr5',i,j,i+1,j1,eello5(i,jp,i+1,jp1,jj,kk)
9220 cd                write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
9221 cd                write(2,*)'ijkl',i,jp,i+1,jp1
9222                 if (wcorr6.gt.0.0d0 .and. (jp.ne.i+4 .or. jp1.ne.i+3
9223      &               .or. wturn6.eq.0.0d0))then
9224 cd                  write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
9225                   ecorr6=ecorr6+eello6(i,jp,i+1,jp1,jj,kk)
9226                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
9227      1                'ecorr6',i,j,i+1,j1,eello6(i,jp,i+1,jp1,jj,kk)
9228 cd                write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
9229 cd     &            'ecorr6=',ecorr6
9230 cd                write (iout,'(4e15.5)') sred_geom,
9231 cd     &          dabs(eello4(i,jp,i+1,jp1,jj,kk)),
9232 cd     &          dabs(eello5(i,jp,i+1,jp1,jj,kk)),
9233 cd     &          dabs(eello6(i,jp,i+1,jp1,jj,kk))
9234                 else if (wturn6.gt.0.0d0
9235      &            .and. (jp.eq.i+4 .and. jp1.eq.i+3)) then
9236 cd                  write (iout,*) '******eturn6: i,j,i+1,j1',i,jip,i+1,jp1
9237                   eturn6=eturn6+eello_turn6(i,jj,kk)
9238                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
9239      1                 'eturn6',i,j,i+1,j1,eello_turn6(i,jj,kk)
9240 cd                  write (2,*) 'multibody_eello:eturn6',eturn6
9241                 endif
9242               ENDIF
9243 1111          continue
9244             endif
9245           enddo ! kk
9246         enddo ! jj
9247       enddo ! i
9248       do i=1,nres
9249         num_cont_hb(i)=num_cont_hb_old(i)
9250       enddo
9251 c                write (iout,*) "gradcorr5 in eello5"
9252 c                do iii=1,nres
9253 c                  write (iout,'(i5,3f10.5)')
9254 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
9255 c                enddo
9256       return
9257       end
9258 c------------------------------------------------------------------------------
9259       subroutine add_hb_contact_eello(ii,jj,itask)
9260       implicit real*8 (a-h,o-z)
9261       include "DIMENSIONS"
9262       include "COMMON.IOUNITS"
9263       integer max_cont
9264       integer max_dim
9265       parameter (max_cont=maxconts)
9266       parameter (max_dim=70)
9267       include "COMMON.CONTACTS"
9268       include 'COMMON.CONTMAT'
9269       include 'COMMON.CORRMAT'
9270       double precision zapas(max_dim,maxconts,max_fg_procs),
9271      &  zapas_recv(max_dim,maxconts,max_fg_procs)
9272       common /przechowalnia/ zapas
9273       integer i,j,ii,jj,iproc,itask(4),nn
9274 c      write (iout,*) "itask",itask
9275       do i=1,2
9276         iproc=itask(i)
9277         if (iproc.gt.0) then
9278           do j=1,num_cont_hb(ii)
9279             jjc=jcont_hb(j,ii)
9280 c            write (iout,*) "send turns i",ii," j",jj," jjc",jjc
9281             if (jjc.eq.jj) then
9282               ncont_sent(iproc)=ncont_sent(iproc)+1
9283               nn=ncont_sent(iproc)
9284               zapas(1,nn,iproc)=ii
9285               zapas(2,nn,iproc)=jjc
9286               zapas(3,nn,iproc)=d_cont(j,ii)
9287               ind=3
9288               do kk=1,3
9289                 ind=ind+1
9290                 zapas(ind,nn,iproc)=grij_hb_cont(kk,j,ii)
9291               enddo
9292               do kk=1,2
9293                 do ll=1,2
9294                   ind=ind+1
9295                   zapas(ind,nn,iproc)=a_chuj(ll,kk,j,ii)
9296                 enddo
9297               enddo
9298               do jj=1,5
9299                 do kk=1,3
9300                   do ll=1,2
9301                     do mm=1,2
9302                       ind=ind+1
9303                       zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,ii)
9304                     enddo
9305                   enddo
9306                 enddo
9307               enddo
9308               exit
9309             endif
9310           enddo
9311         endif
9312       enddo
9313       return
9314       end
9315 c------------------------------------------------------------------------------
9316       double precision function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
9317       implicit real*8 (a-h,o-z)
9318       include 'DIMENSIONS'
9319       include 'COMMON.IOUNITS'
9320       include 'COMMON.DERIV'
9321       include 'COMMON.INTERACT'
9322       include 'COMMON.CONTACTS'
9323       include 'COMMON.CONTMAT'
9324       include 'COMMON.CORRMAT'
9325       include 'COMMON.SHIELD'
9326       include 'COMMON.CONTROL'
9327       double precision gx(3),gx1(3)
9328       logical lprn
9329       lprn=.false.
9330 C      print *,"wchodze",fac_shield(i),shield_mode
9331       eij=facont_hb(jj,i)
9332       ekl=facont_hb(kk,k)
9333       ees0pij=ees0p(jj,i)
9334       ees0pkl=ees0p(kk,k)
9335       ees0mij=ees0m(jj,i)
9336       ees0mkl=ees0m(kk,k)
9337       ekont=eij*ekl
9338       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
9339 C*
9340 C     & fac_shield(i)**2*fac_shield(j)**2
9341 cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
9342 C Following 4 lines for diagnostics.
9343 cd    ees0pkl=0.0D0
9344 cd    ees0pij=1.0D0
9345 cd    ees0mkl=0.0D0
9346 cd    ees0mij=1.0D0
9347 c      write (iout,'(2(a,2i3,a,f10.5,a,2f10.5),a,f10.5,a,$)')
9348 c     & 'Contacts ',i,j,
9349 c     & ' eij',eij,' eesij',ees0pij,ees0mij,' and ',k,l
9350 c     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' energy=',ekont*ees,
9351 c     & 'gradcorr_long'
9352 C Calculate the multi-body contribution to energy.
9353 C      ecorr=ecorr+ekont*ees
9354 C Calculate multi-body contributions to the gradient.
9355       coeffpees0pij=coeffp*ees0pij
9356       coeffmees0mij=coeffm*ees0mij
9357       coeffpees0pkl=coeffp*ees0pkl
9358       coeffmees0mkl=coeffm*ees0mkl
9359       do ll=1,3
9360 cgrad        ghalfi=ees*ekl*gacont_hbr(ll,jj,i)
9361         gradcorr(ll,i)=gradcorr(ll,i)!+0.5d0*ghalfi
9362      &  -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+
9363      &  coeffmees0mkl*gacontm_hb1(ll,jj,i))
9364         gradcorr(ll,j)=gradcorr(ll,j)!+0.5d0*ghalfi
9365      &  -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+
9366      &  coeffmees0mkl*gacontm_hb2(ll,jj,i))
9367 cgrad        ghalfk=ees*eij*gacont_hbr(ll,kk,k)
9368         gradcorr(ll,k)=gradcorr(ll,k)!+0.5d0*ghalfk
9369      &  -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+
9370      &  coeffmees0mij*gacontm_hb1(ll,kk,k))
9371         gradcorr(ll,l)=gradcorr(ll,l)!+0.5d0*ghalfk
9372      &  -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+
9373      &  coeffmees0mij*gacontm_hb2(ll,kk,k))
9374         gradlongij=ees*ekl*gacont_hbr(ll,jj,i)-
9375      &     ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+
9376      &     coeffmees0mkl*gacontm_hb3(ll,jj,i))
9377         gradcorr_long(ll,j)=gradcorr_long(ll,j)+gradlongij
9378         gradcorr_long(ll,i)=gradcorr_long(ll,i)-gradlongij
9379         gradlongkl=ees*eij*gacont_hbr(ll,kk,k)-
9380      &     ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+
9381      &     coeffmees0mij*gacontm_hb3(ll,kk,k))
9382         gradcorr_long(ll,l)=gradcorr_long(ll,l)+gradlongkl
9383         gradcorr_long(ll,k)=gradcorr_long(ll,k)-gradlongkl
9384 c        write (iout,'(2f10.5,2x,$)') gradlongij,gradlongkl
9385       enddo
9386 c      write (iout,*)
9387 cgrad      do m=i+1,j-1
9388 cgrad        do ll=1,3
9389 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
9390 cgrad     &     ees*ekl*gacont_hbr(ll,jj,i)-
9391 cgrad     &     ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
9392 cgrad     &     coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
9393 cgrad        enddo
9394 cgrad      enddo
9395 cgrad      do m=k+1,l-1
9396 cgrad        do ll=1,3
9397 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
9398 cgrad     &     ees*eij*gacont_hbr(ll,kk,k)-
9399 cgrad     &     ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
9400 cgrad     &     coeffm*ees0mij*gacontm_hb3(ll,kk,k))
9401 cgrad        enddo
9402 cgrad      enddo
9403 c      write (iout,*) "ehbcorr",ekont*ees
9404 C      print *,ekont,ees,i,k
9405       ehbcorr=ekont*ees
9406 C now gradient over shielding
9407 C      return
9408       if (shield_mode.gt.0) then
9409        j=ees0plist(jj,i)
9410        l=ees0plist(kk,k)
9411 C        print *,i,j,fac_shield(i),fac_shield(j),
9412 C     &fac_shield(k),fac_shield(l)
9413         if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
9414      &      (fac_shield(k).gt.0).and.(fac_shield(l).gt.0)) then
9415           do ilist=1,ishield_list(i)
9416            iresshield=shield_list(ilist,i)
9417            do m=1,3
9418            rlocshield=grad_shield_side(m,ilist,i)*ehbcorr/fac_shield(i)
9419 C     &      *2.0
9420            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
9421      &              rlocshield
9422      & +grad_shield_loc(m,ilist,i)*ehbcorr/fac_shield(i)
9423             gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
9424      &+rlocshield
9425            enddo
9426           enddo
9427           do ilist=1,ishield_list(j)
9428            iresshield=shield_list(ilist,j)
9429            do m=1,3
9430            rlocshield=grad_shield_side(m,ilist,j)*ehbcorr/fac_shield(j)
9431 C     &     *2.0
9432            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
9433      &              rlocshield
9434      & +grad_shield_loc(m,ilist,j)*ehbcorr/fac_shield(j)
9435            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
9436      &     +rlocshield
9437            enddo
9438           enddo
9439
9440           do ilist=1,ishield_list(k)
9441            iresshield=shield_list(ilist,k)
9442            do m=1,3
9443            rlocshield=grad_shield_side(m,ilist,k)*ehbcorr/fac_shield(k)
9444 C     &     *2.0
9445            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
9446      &              rlocshield
9447      & +grad_shield_loc(m,ilist,k)*ehbcorr/fac_shield(k)
9448            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
9449      &     +rlocshield
9450            enddo
9451           enddo
9452           do ilist=1,ishield_list(l)
9453            iresshield=shield_list(ilist,l)
9454            do m=1,3
9455            rlocshield=grad_shield_side(m,ilist,l)*ehbcorr/fac_shield(l)
9456 C     &     *2.0
9457            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
9458      &              rlocshield
9459      & +grad_shield_loc(m,ilist,l)*ehbcorr/fac_shield(l)
9460            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
9461      &     +rlocshield
9462            enddo
9463           enddo
9464 C          print *,gshieldx(m,iresshield)
9465           do m=1,3
9466             gshieldc_ec(m,i)=gshieldc_ec(m,i)+
9467      &              grad_shield(m,i)*ehbcorr/fac_shield(i)
9468             gshieldc_ec(m,j)=gshieldc_ec(m,j)+
9469      &              grad_shield(m,j)*ehbcorr/fac_shield(j)
9470             gshieldc_ec(m,i-1)=gshieldc_ec(m,i-1)+
9471      &              grad_shield(m,i)*ehbcorr/fac_shield(i)
9472             gshieldc_ec(m,j-1)=gshieldc_ec(m,j-1)+
9473      &              grad_shield(m,j)*ehbcorr/fac_shield(j)
9474
9475             gshieldc_ec(m,k)=gshieldc_ec(m,k)+
9476      &              grad_shield(m,k)*ehbcorr/fac_shield(k)
9477             gshieldc_ec(m,l)=gshieldc_ec(m,l)+
9478      &              grad_shield(m,l)*ehbcorr/fac_shield(l)
9479             gshieldc_ec(m,k-1)=gshieldc_ec(m,k-1)+
9480      &              grad_shield(m,k)*ehbcorr/fac_shield(k)
9481             gshieldc_ec(m,l-1)=gshieldc_ec(m,l-1)+
9482      &              grad_shield(m,l)*ehbcorr/fac_shield(l)
9483
9484            enddo
9485       endif
9486       endif
9487       return
9488       end
9489 #ifdef MOMENT
9490 C---------------------------------------------------------------------------
9491       subroutine dipole(i,j,jj)
9492       implicit real*8 (a-h,o-z)
9493       include 'DIMENSIONS'
9494       include 'COMMON.IOUNITS'
9495       include 'COMMON.CHAIN'
9496       include 'COMMON.FFIELD'
9497       include 'COMMON.DERIV'
9498       include 'COMMON.INTERACT'
9499       include 'COMMON.CONTACTS'
9500       include 'COMMON.CONTMAT'
9501       include 'COMMON.CORRMAT'
9502       include 'COMMON.TORSION'
9503       include 'COMMON.VAR'
9504       include 'COMMON.GEO'
9505       dimension dipi(2,2),dipj(2,2),dipderi(2),dipderj(2),auxvec(2),
9506      &  auxmat(2,2)
9507       iti1 = itortyp(itype(i+1))
9508       if (j.lt.nres-1) then
9509         itj1 = itype2loc(itype(j+1))
9510       else
9511         itj1=nloctyp
9512       endif
9513       do iii=1,2
9514         dipi(iii,1)=Ub2(iii,i)
9515         dipderi(iii)=Ub2der(iii,i)
9516         dipi(iii,2)=b1(iii,i+1)
9517         dipj(iii,1)=Ub2(iii,j)
9518         dipderj(iii)=Ub2der(iii,j)
9519         dipj(iii,2)=b1(iii,j+1)
9520       enddo
9521       kkk=0
9522       do iii=1,2
9523         call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
9524         do jjj=1,2
9525           kkk=kkk+1
9526           dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
9527         enddo
9528       enddo
9529       do kkk=1,5
9530         do lll=1,3
9531           mmm=0
9532           do iii=1,2
9533             call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),
9534      &        auxvec(1))
9535             do jjj=1,2
9536               mmm=mmm+1
9537               dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
9538             enddo
9539           enddo
9540         enddo
9541       enddo
9542       call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
9543       call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
9544       do iii=1,2
9545         dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
9546       enddo
9547       call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
9548       do iii=1,2
9549         dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
9550       enddo
9551       return
9552       end
9553 #endif
9554 C---------------------------------------------------------------------------
9555       subroutine calc_eello(i,j,k,l,jj,kk)
9556 C
9557 C This subroutine computes matrices and vectors needed to calculate
9558 C the fourth-, fifth-, and sixth-order local-electrostatic terms.
9559 C
9560       implicit real*8 (a-h,o-z)
9561       include 'DIMENSIONS'
9562       include 'COMMON.IOUNITS'
9563       include 'COMMON.CHAIN'
9564       include 'COMMON.DERIV'
9565       include 'COMMON.INTERACT'
9566       include 'COMMON.CONTACTS'
9567       include 'COMMON.CONTMAT'
9568       include 'COMMON.CORRMAT'
9569       include 'COMMON.TORSION'
9570       include 'COMMON.VAR'
9571       include 'COMMON.GEO'
9572       include 'COMMON.FFIELD'
9573       double precision aa1(2,2),aa2(2,2),aa1t(2,2),aa2t(2,2),
9574      &  aa1tder(2,2,3,5),aa2tder(2,2,3,5),auxmat(2,2)
9575       logical lprn
9576       common /kutas/ lprn
9577 cd      write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
9578 cd     & ' jj=',jj,' kk=',kk
9579 cd      if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
9580 cd      write (iout,*) "a_chujij",((a_chuj(iii,jjj,jj,i),iii=1,2),jjj=1,2)
9581 cd      write (iout,*) "a_chujkl",((a_chuj(iii,jjj,kk,k),iii=1,2),jjj=1,2)
9582       do iii=1,2
9583         do jjj=1,2
9584           aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
9585           aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
9586         enddo
9587       enddo
9588       call transpose2(aa1(1,1),aa1t(1,1))
9589       call transpose2(aa2(1,1),aa2t(1,1))
9590       do kkk=1,5
9591         do lll=1,3
9592           call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),
9593      &      aa1tder(1,1,lll,kkk))
9594           call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),
9595      &      aa2tder(1,1,lll,kkk))
9596         enddo
9597       enddo
9598       if (l.eq.j+1) then
9599 C parallel orientation of the two CA-CA-CA frames.
9600         if (i.gt.1) then
9601           iti=itype2loc(itype(i))
9602         else
9603           iti=nloctyp
9604         endif
9605         itk1=itype2loc(itype(k+1))
9606         itj=itype2loc(itype(j))
9607         if (l.lt.nres-1) then
9608           itl1=itype2loc(itype(l+1))
9609         else
9610           itl1=nloctyp
9611         endif
9612 C A1 kernel(j+1) A2T
9613 cd        do iii=1,2
9614 cd          write (iout,'(3f10.5,5x,3f10.5)')
9615 cd     &     (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
9616 cd        enddo
9617         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9618      &   aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),
9619      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
9620 C Following matrices are needed only for 6-th order cumulants
9621         IF (wcorr6.gt.0.0d0) THEN
9622         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9623      &   aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),
9624      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
9625         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9626      &   aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),
9627      &   Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
9628      &   ADtEAderx(1,1,1,1,1,1))
9629         lprn=.false.
9630         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9631      &   aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),
9632      &   DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
9633      &   ADtEA1derx(1,1,1,1,1,1))
9634         ENDIF
9635 C End 6-th order cumulants
9636 cd        lprn=.false.
9637 cd        if (lprn) then
9638 cd        write (2,*) 'In calc_eello6'
9639 cd        do iii=1,2
9640 cd          write (2,*) 'iii=',iii
9641 cd          do kkk=1,5
9642 cd            write (2,*) 'kkk=',kkk
9643 cd            do jjj=1,2
9644 cd              write (2,'(3(2f10.5),5x)')
9645 cd     &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
9646 cd            enddo
9647 cd          enddo
9648 cd        enddo
9649 cd        endif
9650         call transpose2(EUgder(1,1,k),auxmat(1,1))
9651         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
9652         call transpose2(EUg(1,1,k),auxmat(1,1))
9653         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
9654         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
9655 C AL 4/16/16: Derivatives of the quantitied related to matrices C, D, and E
9656 c    in theta; to be sriten later.
9657 c#ifdef NEWCORR
9658 c        call transpose2(gtEE(1,1,k),auxmat(1,1))
9659 c        call matmat2(auxmat(1,1),AEA(1,1,1),EAEAdert(1,1,1,1))
9660 c        call transpose2(EUg(1,1,k),auxmat(1,1))
9661 c        call matmat2(auxmat(1,1),AEAdert(1,1,1),EAEAdert(1,1,2,1))
9662 c#endif
9663         do iii=1,2
9664           do kkk=1,5
9665             do lll=1,3
9666               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
9667      &          EAEAderx(1,1,lll,kkk,iii,1))
9668             enddo
9669           enddo
9670         enddo
9671 C A1T kernel(i+1) A2
9672         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
9673      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),
9674      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
9675 C Following matrices are needed only for 6-th order cumulants
9676         IF (wcorr6.gt.0.0d0) THEN
9677         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
9678      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),
9679      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
9680         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
9681      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),
9682      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
9683      &   ADtEAderx(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.,DtUg2EUg(1,1,k),
9686      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
9687      &   ADtEA1derx(1,1,1,1,1,2))
9688         ENDIF
9689 C End 6-th order cumulants
9690         call transpose2(EUgder(1,1,l),auxmat(1,1))
9691         call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
9692         call transpose2(EUg(1,1,l),auxmat(1,1))
9693         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
9694         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
9695         do iii=1,2
9696           do kkk=1,5
9697             do lll=1,3
9698               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
9699      &          EAEAderx(1,1,lll,kkk,iii,2))
9700             enddo
9701           enddo
9702         enddo
9703 C AEAb1 and AEAb2
9704 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
9705 C They are needed only when the fifth- or the sixth-order cumulants are
9706 C indluded.
9707         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
9708         call transpose2(AEA(1,1,1),auxmat(1,1))
9709         call matvec2(auxmat(1,1),b1(1,i),AEAb1(1,1,1))
9710         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
9711         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
9712         call transpose2(AEAderg(1,1,1),auxmat(1,1))
9713         call matvec2(auxmat(1,1),b1(1,i),AEAb1derg(1,1,1))
9714         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
9715         call matvec2(AEA(1,1,1),b1(1,k+1),AEAb1(1,2,1))
9716         call matvec2(AEAderg(1,1,1),b1(1,k+1),AEAb1derg(1,2,1))
9717         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
9718         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
9719         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
9720         call transpose2(AEA(1,1,2),auxmat(1,1))
9721         call matvec2(auxmat(1,1),b1(1,j),AEAb1(1,1,2))
9722         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
9723         call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
9724         call transpose2(AEAderg(1,1,2),auxmat(1,1))
9725         call matvec2(auxmat(1,1),b1(1,j),AEAb1derg(1,1,2))
9726         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
9727         call matvec2(AEA(1,1,2),b1(1,l+1),AEAb1(1,2,2))
9728         call matvec2(AEAderg(1,1,2),b1(1,l+1),AEAb1derg(1,2,2))
9729         call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
9730         call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
9731         call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
9732 C Calculate the Cartesian derivatives of the vectors.
9733         do iii=1,2
9734           do kkk=1,5
9735             do lll=1,3
9736               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
9737               call matvec2(auxmat(1,1),b1(1,i),
9738      &          AEAb1derx(1,lll,kkk,iii,1,1))
9739               call matvec2(auxmat(1,1),Ub2(1,i),
9740      &          AEAb2derx(1,lll,kkk,iii,1,1))
9741               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
9742      &          AEAb1derx(1,lll,kkk,iii,2,1))
9743               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
9744      &          AEAb2derx(1,lll,kkk,iii,2,1))
9745               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
9746               call matvec2(auxmat(1,1),b1(1,j),
9747      &          AEAb1derx(1,lll,kkk,iii,1,2))
9748               call matvec2(auxmat(1,1),Ub2(1,j),
9749      &          AEAb2derx(1,lll,kkk,iii,1,2))
9750               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,l+1),
9751      &          AEAb1derx(1,lll,kkk,iii,2,2))
9752               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),
9753      &          AEAb2derx(1,lll,kkk,iii,2,2))
9754             enddo
9755           enddo
9756         enddo
9757         ENDIF
9758 C End vectors
9759       else
9760 C Antiparallel orientation of the two CA-CA-CA frames.
9761         if (i.gt.1) then
9762           iti=itype2loc(itype(i))
9763         else
9764           iti=nloctyp
9765         endif
9766         itk1=itype2loc(itype(k+1))
9767         itl=itype2loc(itype(l))
9768         itj=itype2loc(itype(j))
9769         if (j.lt.nres-1) then
9770           itj1=itype2loc(itype(j+1))
9771         else
9772           itj1=nloctyp
9773         endif
9774 C A2 kernel(j-1)T A1T
9775         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9776      &   aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),
9777      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
9778 C Following matrices are needed only for 6-th order cumulants
9779         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
9780      &     j.eq.i+4 .and. l.eq.i+3)) THEN
9781         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9782      &   aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),
9783      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
9784         call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9785      &   aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),
9786      &   Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
9787      &   ADtEAderx(1,1,1,1,1,1))
9788         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9789      &   aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),
9790      &   DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
9791      &   ADtEA1derx(1,1,1,1,1,1))
9792         ENDIF
9793 C End 6-th order cumulants
9794         call transpose2(EUgder(1,1,k),auxmat(1,1))
9795         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
9796         call transpose2(EUg(1,1,k),auxmat(1,1))
9797         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
9798         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
9799         do iii=1,2
9800           do kkk=1,5
9801             do lll=1,3
9802               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
9803      &          EAEAderx(1,1,lll,kkk,iii,1))
9804             enddo
9805           enddo
9806         enddo
9807 C A2T kernel(i+1)T A1
9808         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
9809      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),
9810      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
9811 C Following matrices are needed only for 6-th order cumulants
9812         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
9813      &     j.eq.i+4 .and. l.eq.i+3)) THEN
9814         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
9815      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),
9816      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
9817         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
9818      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),
9819      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
9820      &   ADtEAderx(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.,DtUg2EUg(1,1,k),
9823      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
9824      &   ADtEA1derx(1,1,1,1,1,2))
9825         ENDIF
9826 C End 6-th order cumulants
9827         call transpose2(EUgder(1,1,j),auxmat(1,1))
9828         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
9829         call transpose2(EUg(1,1,j),auxmat(1,1))
9830         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
9831         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
9832         do iii=1,2
9833           do kkk=1,5
9834             do lll=1,3
9835               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
9836      &          EAEAderx(1,1,lll,kkk,iii,2))
9837             enddo
9838           enddo
9839         enddo
9840 C AEAb1 and AEAb2
9841 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
9842 C They are needed only when the fifth- or the sixth-order cumulants are
9843 C indluded.
9844         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or.
9845      &    (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
9846         call transpose2(AEA(1,1,1),auxmat(1,1))
9847         call matvec2(auxmat(1,1),b1(1,i),AEAb1(1,1,1))
9848         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
9849         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
9850         call transpose2(AEAderg(1,1,1),auxmat(1,1))
9851         call matvec2(auxmat(1,1),b1(1,i),AEAb1derg(1,1,1))
9852         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
9853         call matvec2(AEA(1,1,1),b1(1,k+1),AEAb1(1,2,1))
9854         call matvec2(AEAderg(1,1,1),b1(1,k+1),AEAb1derg(1,2,1))
9855         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
9856         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
9857         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
9858         call transpose2(AEA(1,1,2),auxmat(1,1))
9859         call matvec2(auxmat(1,1),b1(1,j+1),AEAb1(1,1,2))
9860         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
9861         call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
9862         call transpose2(AEAderg(1,1,2),auxmat(1,1))
9863         call matvec2(auxmat(1,1),b1(1,l),AEAb1(1,1,2))
9864         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
9865         call matvec2(AEA(1,1,2),b1(1,j+1),AEAb1(1,2,2))
9866         call matvec2(AEAderg(1,1,2),b1(1,j+1),AEAb1derg(1,2,2))
9867         call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
9868         call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
9869         call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
9870 C Calculate the Cartesian derivatives of the vectors.
9871         do iii=1,2
9872           do kkk=1,5
9873             do lll=1,3
9874               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
9875               call matvec2(auxmat(1,1),b1(1,i),
9876      &          AEAb1derx(1,lll,kkk,iii,1,1))
9877               call matvec2(auxmat(1,1),Ub2(1,i),
9878      &          AEAb2derx(1,lll,kkk,iii,1,1))
9879               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
9880      &          AEAb1derx(1,lll,kkk,iii,2,1))
9881               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
9882      &          AEAb2derx(1,lll,kkk,iii,2,1))
9883               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
9884               call matvec2(auxmat(1,1),b1(1,l),
9885      &          AEAb1derx(1,lll,kkk,iii,1,2))
9886               call matvec2(auxmat(1,1),Ub2(1,l),
9887      &          AEAb2derx(1,lll,kkk,iii,1,2))
9888               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,j+1),
9889      &          AEAb1derx(1,lll,kkk,iii,2,2))
9890               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),
9891      &          AEAb2derx(1,lll,kkk,iii,2,2))
9892             enddo
9893           enddo
9894         enddo
9895         ENDIF
9896 C End vectors
9897       endif
9898       return
9899       end
9900 C---------------------------------------------------------------------------
9901       subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,
9902      &  KK,KKderg,AKA,AKAderg,AKAderx)
9903       implicit none
9904       integer nderg
9905       logical transp
9906       double precision aa1(2,2),aa2t(2,2),aa1derx(2,2,3,5),
9907      &  aa2tderx(2,2,3,5),KK(2,2),KKderg(2,2,nderg),AKA(2,2),
9908      &  AKAderg(2,2,nderg),AKAderx(2,2,3,5,2)
9909       integer iii,kkk,lll
9910       integer jjj,mmm
9911       logical lprn
9912       common /kutas/ lprn
9913       call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
9914       do iii=1,nderg
9915         call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,
9916      &    AKAderg(1,1,iii))
9917       enddo
9918 cd      if (lprn) write (2,*) 'In kernel'
9919       do kkk=1,5
9920 cd        if (lprn) write (2,*) 'kkk=',kkk
9921         do lll=1,3
9922           call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),
9923      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
9924 cd          if (lprn) then
9925 cd            write (2,*) 'lll=',lll
9926 cd            write (2,*) 'iii=1'
9927 cd            do jjj=1,2
9928 cd              write (2,'(3(2f10.5),5x)')
9929 cd     &        (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
9930 cd            enddo
9931 cd          endif
9932           call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),
9933      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
9934 cd          if (lprn) then
9935 cd            write (2,*) 'lll=',lll
9936 cd            write (2,*) 'iii=2'
9937 cd            do jjj=1,2
9938 cd              write (2,'(3(2f10.5),5x)')
9939 cd     &        (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
9940 cd            enddo
9941 cd          endif
9942         enddo
9943       enddo
9944       return
9945       end
9946 C---------------------------------------------------------------------------
9947       double precision function eello4(i,j,k,l,jj,kk)
9948       implicit real*8 (a-h,o-z)
9949       include 'DIMENSIONS'
9950       include 'COMMON.IOUNITS'
9951       include 'COMMON.CHAIN'
9952       include 'COMMON.DERIV'
9953       include 'COMMON.INTERACT'
9954       include 'COMMON.CONTACTS'
9955       include 'COMMON.CONTMAT'
9956       include 'COMMON.CORRMAT'
9957       include 'COMMON.TORSION'
9958       include 'COMMON.VAR'
9959       include 'COMMON.GEO'
9960       double precision pizda(2,2),ggg1(3),ggg2(3)
9961 cd      if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
9962 cd        eello4=0.0d0
9963 cd        return
9964 cd      endif
9965 cd      print *,'eello4:',i,j,k,l,jj,kk
9966 cd      write (2,*) 'i',i,' j',j,' k',k,' l',l
9967 cd      call checkint4(i,j,k,l,jj,kk,eel4_num)
9968 cold      eij=facont_hb(jj,i)
9969 cold      ekl=facont_hb(kk,k)
9970 cold      ekont=eij*ekl
9971       eel4=-EAEA(1,1,1)-EAEA(2,2,1)
9972 cd      eel41=-EAEA(1,1,2)-EAEA(2,2,2)
9973       gcorr_loc(k-1)=gcorr_loc(k-1)
9974      &   -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
9975       if (l.eq.j+1) then
9976         gcorr_loc(l-1)=gcorr_loc(l-1)
9977      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
9978 C Al 4/16/16: Derivatives in theta, to be added later.
9979 c#ifdef NEWCORR
9980 c        gcorr_loc(nphi+l-1)=gcorr_loc(nphi+l-1)
9981 c     &     -ekont*(EAEAdert(1,1,2,1)+EAEAdert(2,2,2,1))
9982 c#endif
9983       else
9984         gcorr_loc(j-1)=gcorr_loc(j-1)
9985      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
9986 c#ifdef NEWCORR
9987 c        gcorr_loc(nphi+j-1)=gcorr_loc(nphi+j-1)
9988 c     &     -ekont*(EAEAdert(1,1,2,1)+EAEAdert(2,2,2,1))
9989 c#endif
9990       endif
9991       do iii=1,2
9992         do kkk=1,5
9993           do lll=1,3
9994             derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1)
9995      &                        -EAEAderx(2,2,lll,kkk,iii,1)
9996 cd            derx(lll,kkk,iii)=0.0d0
9997           enddo
9998         enddo
9999       enddo
10000 cd      gcorr_loc(l-1)=0.0d0
10001 cd      gcorr_loc(j-1)=0.0d0
10002 cd      gcorr_loc(k-1)=0.0d0
10003 cd      eel4=1.0d0
10004 cd      write (iout,*)'Contacts have occurred for peptide groups',
10005 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l,
10006 cd     &  ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
10007       if (j.lt.nres-1) then
10008         j1=j+1
10009         j2=j-1
10010       else
10011         j1=j-1
10012         j2=j-2
10013       endif
10014       if (l.lt.nres-1) then
10015         l1=l+1
10016         l2=l-1
10017       else
10018         l1=l-1
10019         l2=l-2
10020       endif
10021       do ll=1,3
10022 cgrad        ggg1(ll)=eel4*g_contij(ll,1)
10023 cgrad        ggg2(ll)=eel4*g_contij(ll,2)
10024         glongij=eel4*g_contij(ll,1)+ekont*derx(ll,1,1)
10025         glongkl=eel4*g_contij(ll,2)+ekont*derx(ll,1,2)
10026 cgrad        ghalf=0.5d0*ggg1(ll)
10027         gradcorr(ll,i)=gradcorr(ll,i)+ekont*derx(ll,2,1)
10028         gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
10029         gradcorr(ll,j)=gradcorr(ll,j)+ekont*derx(ll,4,1)
10030         gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
10031         gradcorr_long(ll,j)=gradcorr_long(ll,j)+glongij
10032         gradcorr_long(ll,i)=gradcorr_long(ll,i)-glongij
10033 cgrad        ghalf=0.5d0*ggg2(ll)
10034         gradcorr(ll,k)=gradcorr(ll,k)+ekont*derx(ll,2,2)
10035         gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
10036         gradcorr(ll,l)=gradcorr(ll,l)+ekont*derx(ll,4,2)
10037         gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
10038         gradcorr_long(ll,l)=gradcorr_long(ll,l)+glongkl
10039         gradcorr_long(ll,k)=gradcorr_long(ll,k)-glongkl
10040       enddo
10041 cgrad      do m=i+1,j-1
10042 cgrad        do ll=1,3
10043 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
10044 cgrad        enddo
10045 cgrad      enddo
10046 cgrad      do m=k+1,l-1
10047 cgrad        do ll=1,3
10048 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
10049 cgrad        enddo
10050 cgrad      enddo
10051 cgrad      do m=i+2,j2
10052 cgrad        do ll=1,3
10053 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
10054 cgrad        enddo
10055 cgrad      enddo
10056 cgrad      do m=k+2,l2
10057 cgrad        do ll=1,3
10058 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
10059 cgrad        enddo
10060 cgrad      enddo
10061 cd      do iii=1,nres-3
10062 cd        write (2,*) iii,gcorr_loc(iii)
10063 cd      enddo
10064       eello4=ekont*eel4
10065 cd      write (2,*) 'ekont',ekont
10066 cd      write (iout,*) 'eello4',ekont*eel4
10067       return
10068       end
10069 C---------------------------------------------------------------------------
10070       double precision function eello5(i,j,k,l,jj,kk)
10071       implicit real*8 (a-h,o-z)
10072       include 'DIMENSIONS'
10073       include 'COMMON.IOUNITS'
10074       include 'COMMON.CHAIN'
10075       include 'COMMON.DERIV'
10076       include 'COMMON.INTERACT'
10077       include 'COMMON.CONTACTS'
10078       include 'COMMON.CONTMAT'
10079       include 'COMMON.CORRMAT'
10080       include 'COMMON.TORSION'
10081       include 'COMMON.VAR'
10082       include 'COMMON.GEO'
10083       double precision pizda(2,2),auxmat(2,2),auxmat1(2,2),vv(2)
10084       double precision ggg1(3),ggg2(3)
10085 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10086 C                                                                              C
10087 C                            Parallel chains                                   C
10088 C                                                                              C
10089 C          o             o                   o             o                   C
10090 C         /l\           / \             \   / \           / \   /              C
10091 C        /   \         /   \             \ /   \         /   \ /               C
10092 C       j| o |l1       | o |              o| o |         | o |o                C
10093 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
10094 C      \i/   \         /   \ /             /   \         /   \                 C
10095 C       o    k1             o                                                  C
10096 C         (I)          (II)                (III)          (IV)                 C
10097 C                                                                              C
10098 C      eello5_1        eello5_2            eello5_3       eello5_4             C
10099 C                                                                              C
10100 C                            Antiparallel chains                               C
10101 C                                                                              C
10102 C          o             o                   o             o                   C
10103 C         /j\           / \             \   / \           / \   /              C
10104 C        /   \         /   \             \ /   \         /   \ /               C
10105 C      j1| o |l        | o |              o| o |         | o |o                C
10106 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
10107 C      \i/   \         /   \ /             /   \         /   \                 C
10108 C       o     k1            o                                                  C
10109 C         (I)          (II)                (III)          (IV)                 C
10110 C                                                                              C
10111 C      eello5_1        eello5_2            eello5_3       eello5_4             C
10112 C                                                                              C
10113 C o denotes a local interaction, vertical lines an electrostatic interaction.  C
10114 C                                                                              C
10115 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10116 cd      if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
10117 cd        eello5=0.0d0
10118 cd        return
10119 cd      endif
10120 cd      write (iout,*)
10121 cd     &   'EELLO5: Contacts have occurred for peptide groups',i,j,
10122 cd     &   ' and',k,l
10123       itk=itype2loc(itype(k))
10124       itl=itype2loc(itype(l))
10125       itj=itype2loc(itype(j))
10126       eello5_1=0.0d0
10127       eello5_2=0.0d0
10128       eello5_3=0.0d0
10129       eello5_4=0.0d0
10130 cd      call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
10131 cd     &   eel5_3_num,eel5_4_num)
10132       do iii=1,2
10133         do kkk=1,5
10134           do lll=1,3
10135             derx(lll,kkk,iii)=0.0d0
10136           enddo
10137         enddo
10138       enddo
10139 cd      eij=facont_hb(jj,i)
10140 cd      ekl=facont_hb(kk,k)
10141 cd      ekont=eij*ekl
10142 cd      write (iout,*)'Contacts have occurred for peptide groups',
10143 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l
10144 cd      goto 1111
10145 C Contribution from the graph I.
10146 cd      write (2,*) 'AEA  ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
10147 cd      write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
10148       call transpose2(EUg(1,1,k),auxmat(1,1))
10149       call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
10150       vv(1)=pizda(1,1)-pizda(2,2)
10151       vv(2)=pizda(1,2)+pizda(2,1)
10152       eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k))
10153      & +0.5d0*scalar2(vv(1),Dtobr2(1,i))
10154 C Explicit gradient in virtual-dihedral angles.
10155       if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1)
10156      & +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k))
10157      & +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
10158       call transpose2(EUgder(1,1,k),auxmat1(1,1))
10159       call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
10160       vv(1)=pizda(1,1)-pizda(2,2)
10161       vv(2)=pizda(1,2)+pizda(2,1)
10162       g_corr5_loc(k-1)=g_corr5_loc(k-1)
10163      & +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k))
10164      & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
10165       call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
10166       vv(1)=pizda(1,1)-pizda(2,2)
10167       vv(2)=pizda(1,2)+pizda(2,1)
10168       if (l.eq.j+1) then
10169         if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1)
10170      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
10171      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
10172       else
10173         if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1)
10174      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
10175      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
10176       endif
10177 C Cartesian gradient
10178       do iii=1,2
10179         do kkk=1,5
10180           do lll=1,3
10181             call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),
10182      &        pizda(1,1))
10183             vv(1)=pizda(1,1)-pizda(2,2)
10184             vv(2)=pizda(1,2)+pizda(2,1)
10185             derx(lll,kkk,iii)=derx(lll,kkk,iii)
10186      &       +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k))
10187      &       +0.5d0*scalar2(vv(1),Dtobr2(1,i))
10188           enddo
10189         enddo
10190       enddo
10191 c      goto 1112
10192 c1111  continue
10193 C Contribution from graph II
10194       call transpose2(EE(1,1,k),auxmat(1,1))
10195       call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
10196       vv(1)=pizda(1,1)+pizda(2,2)
10197       vv(2)=pizda(2,1)-pizda(1,2)
10198       eello5_2=scalar2(AEAb1(1,2,1),b1(1,k))
10199      & -0.5d0*scalar2(vv(1),Ctobr(1,k))
10200 C Explicit gradient in virtual-dihedral angles.
10201       g_corr5_loc(k-1)=g_corr5_loc(k-1)
10202      & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
10203       call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
10204       vv(1)=pizda(1,1)+pizda(2,2)
10205       vv(2)=pizda(2,1)-pizda(1,2)
10206       if (l.eq.j+1) then
10207         g_corr5_loc(l-1)=g_corr5_loc(l-1)
10208      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,k))
10209      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
10210       else
10211         g_corr5_loc(j-1)=g_corr5_loc(j-1)
10212      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,k))
10213      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
10214       endif
10215 C Cartesian gradient
10216       do iii=1,2
10217         do kkk=1,5
10218           do lll=1,3
10219             call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
10220      &        pizda(1,1))
10221             vv(1)=pizda(1,1)+pizda(2,2)
10222             vv(2)=pizda(2,1)-pizda(1,2)
10223             derx(lll,kkk,iii)=derx(lll,kkk,iii)
10224      &       +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,k))
10225      &       -0.5d0*scalar2(vv(1),Ctobr(1,k))
10226           enddo
10227         enddo
10228       enddo
10229 cd      goto 1112
10230 cd1111  continue
10231       if (l.eq.j+1) then
10232 cd        goto 1110
10233 C Parallel orientation
10234 C Contribution from graph III
10235         call transpose2(EUg(1,1,l),auxmat(1,1))
10236         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
10237         vv(1)=pizda(1,1)-pizda(2,2)
10238         vv(2)=pizda(1,2)+pizda(2,1)
10239         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l))
10240      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j))
10241 C Explicit gradient in virtual-dihedral angles.
10242         g_corr5_loc(j-1)=g_corr5_loc(j-1)
10243      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l))
10244      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
10245         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
10246         vv(1)=pizda(1,1)-pizda(2,2)
10247         vv(2)=pizda(1,2)+pizda(2,1)
10248         g_corr5_loc(k-1)=g_corr5_loc(k-1)
10249      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l))
10250      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
10251         call transpose2(EUgder(1,1,l),auxmat1(1,1))
10252         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
10253         vv(1)=pizda(1,1)-pizda(2,2)
10254         vv(2)=pizda(1,2)+pizda(2,1)
10255         g_corr5_loc(l-1)=g_corr5_loc(l-1)
10256      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l))
10257      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
10258 C Cartesian gradient
10259         do iii=1,2
10260           do kkk=1,5
10261             do lll=1,3
10262               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
10263      &          pizda(1,1))
10264               vv(1)=pizda(1,1)-pizda(2,2)
10265               vv(2)=pizda(1,2)+pizda(2,1)
10266               derx(lll,kkk,iii)=derx(lll,kkk,iii)
10267      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l))
10268      &         +0.5d0*scalar2(vv(1),Dtobr2(1,j))
10269             enddo
10270           enddo
10271         enddo
10272 cd        goto 1112
10273 C Contribution from graph IV
10274 cd1110    continue
10275         call transpose2(EE(1,1,l),auxmat(1,1))
10276         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
10277         vv(1)=pizda(1,1)+pizda(2,2)
10278         vv(2)=pizda(2,1)-pizda(1,2)
10279         eello5_4=scalar2(AEAb1(1,2,2),b1(1,l))
10280      &   -0.5d0*scalar2(vv(1),Ctobr(1,l))
10281 C Explicit gradient in virtual-dihedral angles.
10282         g_corr5_loc(l-1)=g_corr5_loc(l-1)
10283      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
10284         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
10285         vv(1)=pizda(1,1)+pizda(2,2)
10286         vv(2)=pizda(2,1)-pizda(1,2)
10287         g_corr5_loc(k-1)=g_corr5_loc(k-1)
10288      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,l))
10289      &   -0.5d0*scalar2(vv(1),Ctobr(1,l)))
10290 C Cartesian gradient
10291         do iii=1,2
10292           do kkk=1,5
10293             do lll=1,3
10294               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
10295      &          pizda(1,1))
10296               vv(1)=pizda(1,1)+pizda(2,2)
10297               vv(2)=pizda(2,1)-pizda(1,2)
10298               derx(lll,kkk,iii)=derx(lll,kkk,iii)
10299      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,l))
10300      &         -0.5d0*scalar2(vv(1),Ctobr(1,l))
10301             enddo
10302           enddo
10303         enddo
10304       else
10305 C Antiparallel orientation
10306 C Contribution from graph III
10307 c        goto 1110
10308         call transpose2(EUg(1,1,j),auxmat(1,1))
10309         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
10310         vv(1)=pizda(1,1)-pizda(2,2)
10311         vv(2)=pizda(1,2)+pizda(2,1)
10312         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j))
10313      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l))
10314 C Explicit gradient in virtual-dihedral angles.
10315         g_corr5_loc(l-1)=g_corr5_loc(l-1)
10316      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j))
10317      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
10318         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
10319         vv(1)=pizda(1,1)-pizda(2,2)
10320         vv(2)=pizda(1,2)+pizda(2,1)
10321         g_corr5_loc(k-1)=g_corr5_loc(k-1)
10322      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j))
10323      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
10324         call transpose2(EUgder(1,1,j),auxmat1(1,1))
10325         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
10326         vv(1)=pizda(1,1)-pizda(2,2)
10327         vv(2)=pizda(1,2)+pizda(2,1)
10328         g_corr5_loc(j-1)=g_corr5_loc(j-1)
10329      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j))
10330      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
10331 C Cartesian gradient
10332         do iii=1,2
10333           do kkk=1,5
10334             do lll=1,3
10335               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
10336      &          pizda(1,1))
10337               vv(1)=pizda(1,1)-pizda(2,2)
10338               vv(2)=pizda(1,2)+pizda(2,1)
10339               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
10340      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j))
10341      &         +0.5d0*scalar2(vv(1),Dtobr2(1,l))
10342             enddo
10343           enddo
10344         enddo
10345 cd        goto 1112
10346 C Contribution from graph IV
10347 1110    continue
10348         call transpose2(EE(1,1,j),auxmat(1,1))
10349         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
10350         vv(1)=pizda(1,1)+pizda(2,2)
10351         vv(2)=pizda(2,1)-pizda(1,2)
10352         eello5_4=scalar2(AEAb1(1,2,2),b1(1,j))
10353      &   -0.5d0*scalar2(vv(1),Ctobr(1,j))
10354 C Explicit gradient in virtual-dihedral angles.
10355         g_corr5_loc(j-1)=g_corr5_loc(j-1)
10356      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
10357         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
10358         vv(1)=pizda(1,1)+pizda(2,2)
10359         vv(2)=pizda(2,1)-pizda(1,2)
10360         g_corr5_loc(k-1)=g_corr5_loc(k-1)
10361      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,j))
10362      &   -0.5d0*scalar2(vv(1),Ctobr(1,j)))
10363 C Cartesian gradient
10364         do iii=1,2
10365           do kkk=1,5
10366             do lll=1,3
10367               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
10368      &          pizda(1,1))
10369               vv(1)=pizda(1,1)+pizda(2,2)
10370               vv(2)=pizda(2,1)-pizda(1,2)
10371               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
10372      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,j))
10373      &         -0.5d0*scalar2(vv(1),Ctobr(1,j))
10374             enddo
10375           enddo
10376         enddo
10377       endif
10378 1112  continue
10379       eel5=eello5_1+eello5_2+eello5_3+eello5_4
10380 cd      if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
10381 cd        write (2,*) 'ijkl',i,j,k,l
10382 cd        write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
10383 cd     &     ' eello5_3',eello5_3,' eello5_4',eello5_4
10384 cd      endif
10385 cd      write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
10386 cd      write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
10387 cd      write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
10388 cd      write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
10389       if (j.lt.nres-1) then
10390         j1=j+1
10391         j2=j-1
10392       else
10393         j1=j-1
10394         j2=j-2
10395       endif
10396       if (l.lt.nres-1) then
10397         l1=l+1
10398         l2=l-1
10399       else
10400         l1=l-1
10401         l2=l-2
10402       endif
10403 cd      eij=1.0d0
10404 cd      ekl=1.0d0
10405 cd      ekont=1.0d0
10406 cd      write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
10407 C 2/11/08 AL Gradients over DC's connecting interacting sites will be
10408 C        summed up outside the subrouine as for the other subroutines
10409 C        handling long-range interactions. The old code is commented out
10410 C        with "cgrad" to keep track of changes.
10411       do ll=1,3
10412 cgrad        ggg1(ll)=eel5*g_contij(ll,1)
10413 cgrad        ggg2(ll)=eel5*g_contij(ll,2)
10414         gradcorr5ij=eel5*g_contij(ll,1)+ekont*derx(ll,1,1)
10415         gradcorr5kl=eel5*g_contij(ll,2)+ekont*derx(ll,1,2)
10416 c        write (iout,'(a,3i3,a,5f8.3,2i3,a,5f8.3,a,f8.3)')
10417 c     &   "ecorr5",ll,i,j," derx",derx(ll,2,1),derx(ll,3,1),derx(ll,4,1),
10418 c     &   derx(ll,5,1),k,l," derx",derx(ll,2,2),derx(ll,3,2),
10419 c     &   derx(ll,4,2),derx(ll,5,2)," ekont",ekont
10420 c        write (iout,'(a,3i3,a,3f8.3,2i3,a,3f8.3)')
10421 c     &   "ecorr5",ll,i,j," gradcorr5",g_contij(ll,1),derx(ll,1,1),
10422 c     &   gradcorr5ij,
10423 c     &   k,l," gradcorr5",g_contij(ll,2),derx(ll,1,2),gradcorr5kl
10424 cold        ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
10425 cgrad        ghalf=0.5d0*ggg1(ll)
10426 cd        ghalf=0.0d0
10427         gradcorr5(ll,i)=gradcorr5(ll,i)+ekont*derx(ll,2,1)
10428         gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
10429         gradcorr5(ll,j)=gradcorr5(ll,j)+ekont*derx(ll,4,1)
10430         gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
10431         gradcorr5_long(ll,j)=gradcorr5_long(ll,j)+gradcorr5ij
10432         gradcorr5_long(ll,i)=gradcorr5_long(ll,i)-gradcorr5ij
10433 cold        ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
10434 cgrad        ghalf=0.5d0*ggg2(ll)
10435 cd        ghalf=0.0d0
10436         gradcorr5(ll,k)=gradcorr5(ll,k)+ekont*derx(ll,2,2)
10437         gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
10438         gradcorr5(ll,l)=gradcorr5(ll,l)+ekont*derx(ll,4,2)
10439         gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
10440         gradcorr5_long(ll,l)=gradcorr5_long(ll,l)+gradcorr5kl
10441         gradcorr5_long(ll,k)=gradcorr5_long(ll,k)-gradcorr5kl
10442       enddo
10443 cd      goto 1112
10444 cgrad      do m=i+1,j-1
10445 cgrad        do ll=1,3
10446 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
10447 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
10448 cgrad        enddo
10449 cgrad      enddo
10450 cgrad      do m=k+1,l-1
10451 cgrad        do ll=1,3
10452 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
10453 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
10454 cgrad        enddo
10455 cgrad      enddo
10456 c1112  continue
10457 cgrad      do m=i+2,j2
10458 cgrad        do ll=1,3
10459 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
10460 cgrad        enddo
10461 cgrad      enddo
10462 cgrad      do m=k+2,l2
10463 cgrad        do ll=1,3
10464 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
10465 cgrad        enddo
10466 cgrad      enddo
10467 cd      do iii=1,nres-3
10468 cd        write (2,*) iii,g_corr5_loc(iii)
10469 cd      enddo
10470       eello5=ekont*eel5
10471 cd      write (2,*) 'ekont',ekont
10472 cd      write (iout,*) 'eello5',ekont*eel5
10473       return
10474       end
10475 c--------------------------------------------------------------------------
10476       double precision function eello6(i,j,k,l,jj,kk)
10477       implicit real*8 (a-h,o-z)
10478       include 'DIMENSIONS'
10479       include 'COMMON.IOUNITS'
10480       include 'COMMON.CHAIN'
10481       include 'COMMON.DERIV'
10482       include 'COMMON.INTERACT'
10483       include 'COMMON.CONTACTS'
10484       include 'COMMON.CONTMAT'
10485       include 'COMMON.CORRMAT'
10486       include 'COMMON.TORSION'
10487       include 'COMMON.VAR'
10488       include 'COMMON.GEO'
10489       include 'COMMON.FFIELD'
10490       double precision ggg1(3),ggg2(3)
10491 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
10492 cd        eello6=0.0d0
10493 cd        return
10494 cd      endif
10495 cd      write (iout,*)
10496 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
10497 cd     &   ' and',k,l
10498       eello6_1=0.0d0
10499       eello6_2=0.0d0
10500       eello6_3=0.0d0
10501       eello6_4=0.0d0
10502       eello6_5=0.0d0
10503       eello6_6=0.0d0
10504 cd      call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
10505 cd     &   eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
10506       do iii=1,2
10507         do kkk=1,5
10508           do lll=1,3
10509             derx(lll,kkk,iii)=0.0d0
10510           enddo
10511         enddo
10512       enddo
10513 cd      eij=facont_hb(jj,i)
10514 cd      ekl=facont_hb(kk,k)
10515 cd      ekont=eij*ekl
10516 cd      eij=1.0d0
10517 cd      ekl=1.0d0
10518 cd      ekont=1.0d0
10519       if (l.eq.j+1) then
10520         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
10521         eello6_2=eello6_graph1(j,i,l,k,2,.false.)
10522         eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
10523         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
10524         eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
10525         eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
10526       else
10527         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
10528         eello6_2=eello6_graph1(l,k,j,i,2,.true.)
10529         eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
10530         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
10531         if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
10532           eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
10533         else
10534           eello6_5=0.0d0
10535         endif
10536         eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
10537       endif
10538 C If turn contributions are considered, they will be handled separately.
10539       eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
10540 cd      write(iout,*) 'eello6_1',eello6_1!,' eel6_1_num',16*eel6_1_num
10541 cd      write(iout,*) 'eello6_2',eello6_2!,' eel6_2_num',16*eel6_2_num
10542 cd      write(iout,*) 'eello6_3',eello6_3!,' eel6_3_num',16*eel6_3_num
10543 cd      write(iout,*) 'eello6_4',eello6_4!,' eel6_4_num',16*eel6_4_num
10544 cd      write(iout,*) 'eello6_5',eello6_5!,' eel6_5_num',16*eel6_5_num
10545 cd      write(iout,*) 'eello6_6',eello6_6!,' eel6_6_num',16*eel6_6_num
10546 cd      goto 1112
10547       if (j.lt.nres-1) then
10548         j1=j+1
10549         j2=j-1
10550       else
10551         j1=j-1
10552         j2=j-2
10553       endif
10554       if (l.lt.nres-1) then
10555         l1=l+1
10556         l2=l-1
10557       else
10558         l1=l-1
10559         l2=l-2
10560       endif
10561       do ll=1,3
10562 cgrad        ggg1(ll)=eel6*g_contij(ll,1)
10563 cgrad        ggg2(ll)=eel6*g_contij(ll,2)
10564 cold        ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
10565 cgrad        ghalf=0.5d0*ggg1(ll)
10566 cd        ghalf=0.0d0
10567         gradcorr6ij=eel6*g_contij(ll,1)+ekont*derx(ll,1,1)
10568         gradcorr6kl=eel6*g_contij(ll,2)+ekont*derx(ll,1,2)
10569         gradcorr6(ll,i)=gradcorr6(ll,i)+ekont*derx(ll,2,1)
10570         gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
10571         gradcorr6(ll,j)=gradcorr6(ll,j)+ekont*derx(ll,4,1)
10572         gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
10573         gradcorr6_long(ll,j)=gradcorr6_long(ll,j)+gradcorr6ij
10574         gradcorr6_long(ll,i)=gradcorr6_long(ll,i)-gradcorr6ij
10575 cgrad        ghalf=0.5d0*ggg2(ll)
10576 cold        ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
10577 cd        ghalf=0.0d0
10578         gradcorr6(ll,k)=gradcorr6(ll,k)+ekont*derx(ll,2,2)
10579         gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
10580         gradcorr6(ll,l)=gradcorr6(ll,l)+ekont*derx(ll,4,2)
10581         gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
10582         gradcorr6_long(ll,l)=gradcorr6_long(ll,l)+gradcorr6kl
10583         gradcorr6_long(ll,k)=gradcorr6_long(ll,k)-gradcorr6kl
10584       enddo
10585 cd      goto 1112
10586 cgrad      do m=i+1,j-1
10587 cgrad        do ll=1,3
10588 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
10589 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
10590 cgrad        enddo
10591 cgrad      enddo
10592 cgrad      do m=k+1,l-1
10593 cgrad        do ll=1,3
10594 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
10595 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
10596 cgrad        enddo
10597 cgrad      enddo
10598 cgrad1112  continue
10599 cgrad      do m=i+2,j2
10600 cgrad        do ll=1,3
10601 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
10602 cgrad        enddo
10603 cgrad      enddo
10604 cgrad      do m=k+2,l2
10605 cgrad        do ll=1,3
10606 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
10607 cgrad        enddo
10608 cgrad      enddo
10609 cd      do iii=1,nres-3
10610 cd        write (2,*) iii,g_corr6_loc(iii)
10611 cd      enddo
10612       eello6=ekont*eel6
10613 cd      write (2,*) 'ekont',ekont
10614 cd      write (iout,*) 'eello6',ekont*eel6
10615       return
10616       end
10617 c--------------------------------------------------------------------------
10618       double precision function eello6_graph1(i,j,k,l,imat,swap)
10619       implicit real*8 (a-h,o-z)
10620       include 'DIMENSIONS'
10621       include 'COMMON.IOUNITS'
10622       include 'COMMON.CHAIN'
10623       include 'COMMON.DERIV'
10624       include 'COMMON.INTERACT'
10625       include 'COMMON.CONTACTS'
10626       include 'COMMON.CONTMAT'
10627       include 'COMMON.CORRMAT'
10628       include 'COMMON.TORSION'
10629       include 'COMMON.VAR'
10630       include 'COMMON.GEO'
10631       double precision vv(2),vv1(2),pizda(2,2),auxmat(2,2),pizda1(2,2)
10632       logical swap
10633       logical lprn
10634       common /kutas/ lprn
10635 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10636 C                                                                              C
10637 C      Parallel       Antiparallel                                             C
10638 C                                                                              C
10639 C          o             o                                                     C
10640 C         /l\           /j\                                                    C
10641 C        /   \         /   \                                                   C
10642 C       /| o |         | o |\                                                  C
10643 C     \ j|/k\|  /   \  |/k\|l /                                                C
10644 C      \ /   \ /     \ /   \ /                                                 C
10645 C       o     o       o     o                                                  C
10646 C       i             i                                                        C
10647 C                                                                              C
10648 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10649       itk=itype2loc(itype(k))
10650       s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
10651       s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
10652       s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
10653       call transpose2(EUgC(1,1,k),auxmat(1,1))
10654       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
10655       vv1(1)=pizda1(1,1)-pizda1(2,2)
10656       vv1(2)=pizda1(1,2)+pizda1(2,1)
10657       s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
10658       vv(1)=AEAb1(1,2,imat)*b1(1,k)-AEAb1(2,2,imat)*b1(2,k)
10659       vv(2)=AEAb1(1,2,imat)*b1(2,k)+AEAb1(2,2,imat)*b1(1,k)
10660       s5=scalar2(vv(1),Dtobr2(1,i))
10661 cd      write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
10662       eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
10663       if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1)
10664      & -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i))
10665      & -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k))
10666      & +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k))
10667      & +0.5d0*scalar2(vv1(1),Dtobr2der(1,i))
10668      & +scalar2(vv(1),Dtobr2der(1,i)))
10669       call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
10670       vv1(1)=pizda1(1,1)-pizda1(2,2)
10671       vv1(2)=pizda1(1,2)+pizda1(2,1)
10672       vv(1)=AEAb1derg(1,2,imat)*b1(1,k)-AEAb1derg(2,2,imat)*b1(2,k)
10673       vv(2)=AEAb1derg(1,2,imat)*b1(2,k)+AEAb1derg(2,2,imat)*b1(1,k)
10674       if (l.eq.j+1) then
10675         g_corr6_loc(l-1)=g_corr6_loc(l-1)
10676      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
10677      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
10678      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
10679      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
10680       else
10681         g_corr6_loc(j-1)=g_corr6_loc(j-1)
10682      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
10683      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
10684      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
10685      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
10686       endif
10687       call transpose2(EUgCder(1,1,k),auxmat(1,1))
10688       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
10689       vv1(1)=pizda1(1,1)-pizda1(2,2)
10690       vv1(2)=pizda1(1,2)+pizda1(2,1)
10691       if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1)
10692      & +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k))
10693      & +scalar2(AEAb2(1,1,imat),CUgb2der(1,k))
10694      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
10695       do iii=1,2
10696         if (swap) then
10697           ind=3-iii
10698         else
10699           ind=iii
10700         endif
10701         do kkk=1,5
10702           do lll=1,3
10703             s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
10704             s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
10705             s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
10706             call transpose2(EUgC(1,1,k),auxmat(1,1))
10707             call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
10708      &        pizda1(1,1))
10709             vv1(1)=pizda1(1,1)-pizda1(2,2)
10710             vv1(2)=pizda1(1,2)+pizda1(2,1)
10711             s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
10712             vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,k)
10713      &       -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,k)
10714             vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,k)
10715      &       +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,k)
10716             s5=scalar2(vv(1),Dtobr2(1,i))
10717             derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
10718           enddo
10719         enddo
10720       enddo
10721       return
10722       end
10723 c----------------------------------------------------------------------------
10724       double precision function eello6_graph2(i,j,k,l,jj,kk,swap)
10725       implicit real*8 (a-h,o-z)
10726       include 'DIMENSIONS'
10727       include 'COMMON.IOUNITS'
10728       include 'COMMON.CHAIN'
10729       include 'COMMON.DERIV'
10730       include 'COMMON.INTERACT'
10731       include 'COMMON.CONTACTS'
10732       include 'COMMON.CONTMAT'
10733       include 'COMMON.CORRMAT'
10734       include 'COMMON.TORSION'
10735       include 'COMMON.VAR'
10736       include 'COMMON.GEO'
10737       logical swap
10738       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
10739      & auxvec1(2),auxvec2(2),auxmat1(2,2)
10740       logical lprn
10741       common /kutas/ lprn
10742 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10743 C                                                                              C
10744 C      Parallel       Antiparallel                                             C
10745 C                                                                              C
10746 C          o             o                                                     C
10747 C     \   /l\           /j\   /                                                C
10748 C      \ /   \         /   \ /                                                 C
10749 C       o| o |         | o |o                                                  C
10750 C     \ j|/k\|      \  |/k\|l                                                  C
10751 C      \ /   \       \ /   \                                                   C
10752 C       o             o                                                        C
10753 C       i             i                                                        C
10754 C                                                                              C
10755 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10756 cd      write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
10757 C AL 7/4/01 s1 would occur in the sixth-order moment,
10758 C           but not in a cluster cumulant
10759 #ifdef MOMENT
10760       s1=dip(1,jj,i)*dip(1,kk,k)
10761 #endif
10762       call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
10763       s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
10764       call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
10765       s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
10766       call transpose2(EUg(1,1,k),auxmat(1,1))
10767       call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
10768       vv(1)=pizda(1,1)-pizda(2,2)
10769       vv(2)=pizda(1,2)+pizda(2,1)
10770       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
10771 cd      write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
10772 #ifdef MOMENT
10773       eello6_graph2=-(s1+s2+s3+s4)
10774 #else
10775       eello6_graph2=-(s2+s3+s4)
10776 #endif
10777 c      eello6_graph2=-s3
10778 C Derivatives in gamma(i-1)
10779       if (i.gt.1) then
10780 #ifdef MOMENT
10781         s1=dipderg(1,jj,i)*dip(1,kk,k)
10782 #endif
10783         s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
10784         call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
10785         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
10786         s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
10787 #ifdef MOMENT
10788         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
10789 #else
10790         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
10791 #endif
10792 c        g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
10793       endif
10794 C Derivatives in gamma(k-1)
10795 #ifdef MOMENT
10796       s1=dip(1,jj,i)*dipderg(1,kk,k)
10797 #endif
10798       call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
10799       s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
10800       call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
10801       s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
10802       call transpose2(EUgder(1,1,k),auxmat1(1,1))
10803       call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
10804       vv(1)=pizda(1,1)-pizda(2,2)
10805       vv(2)=pizda(1,2)+pizda(2,1)
10806       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
10807 #ifdef MOMENT
10808       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
10809 #else
10810       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
10811 #endif
10812 c      g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
10813 C Derivatives in gamma(j-1) or gamma(l-1)
10814       if (j.gt.1) then
10815 #ifdef MOMENT
10816         s1=dipderg(3,jj,i)*dip(1,kk,k)
10817 #endif
10818         call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
10819         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
10820         s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
10821         call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
10822         vv(1)=pizda(1,1)-pizda(2,2)
10823         vv(2)=pizda(1,2)+pizda(2,1)
10824         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
10825 #ifdef MOMENT
10826         if (swap) then
10827           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
10828         else
10829           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
10830         endif
10831 #endif
10832         g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
10833 c        g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
10834       endif
10835 C Derivatives in gamma(l-1) or gamma(j-1)
10836       if (l.gt.1) then
10837 #ifdef MOMENT
10838         s1=dip(1,jj,i)*dipderg(3,kk,k)
10839 #endif
10840         call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
10841         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
10842         call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
10843         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
10844         call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
10845         vv(1)=pizda(1,1)-pizda(2,2)
10846         vv(2)=pizda(1,2)+pizda(2,1)
10847         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
10848 #ifdef MOMENT
10849         if (swap) then
10850           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
10851         else
10852           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
10853         endif
10854 #endif
10855         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
10856 c        g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
10857       endif
10858 C Cartesian derivatives.
10859       if (lprn) then
10860         write (2,*) 'In eello6_graph2'
10861         do iii=1,2
10862           write (2,*) 'iii=',iii
10863           do kkk=1,5
10864             write (2,*) 'kkk=',kkk
10865             do jjj=1,2
10866               write (2,'(3(2f10.5),5x)')
10867      &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
10868             enddo
10869           enddo
10870         enddo
10871       endif
10872       do iii=1,2
10873         do kkk=1,5
10874           do lll=1,3
10875 #ifdef MOMENT
10876             if (iii.eq.1) then
10877               s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
10878             else
10879               s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
10880             endif
10881 #endif
10882             call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),
10883      &        auxvec(1))
10884             s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
10885             call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),
10886      &        auxvec(1))
10887             s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
10888             call transpose2(EUg(1,1,k),auxmat(1,1))
10889             call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),
10890      &        pizda(1,1))
10891             vv(1)=pizda(1,1)-pizda(2,2)
10892             vv(2)=pizda(1,2)+pizda(2,1)
10893             s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
10894 cd            write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
10895 #ifdef MOMENT
10896             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
10897 #else
10898             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
10899 #endif
10900             if (swap) then
10901               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
10902             else
10903               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
10904             endif
10905           enddo
10906         enddo
10907       enddo
10908       return
10909       end
10910 c----------------------------------------------------------------------------
10911       double precision function eello6_graph3(i,j,k,l,jj,kk,swap)
10912       implicit real*8 (a-h,o-z)
10913       include 'DIMENSIONS'
10914       include 'COMMON.IOUNITS'
10915       include 'COMMON.CHAIN'
10916       include 'COMMON.DERIV'
10917       include 'COMMON.INTERACT'
10918       include 'COMMON.CONTACTS'
10919       include 'COMMON.CONTMAT'
10920       include 'COMMON.CORRMAT'
10921       include 'COMMON.TORSION'
10922       include 'COMMON.VAR'
10923       include 'COMMON.GEO'
10924       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2)
10925       logical swap
10926 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10927 C                                                                              C
10928 C      Parallel       Antiparallel                                             C
10929 C                                                                              C
10930 C          o             o                                                     C
10931 C         /l\   /   \   /j\                                                    C
10932 C        /   \ /     \ /   \                                                   C
10933 C       /| o |o       o| o |\                                                  C
10934 C       j|/k\|  /      |/k\|l /                                                C
10935 C        /   \ /       /   \ /                                                 C
10936 C       /     o       /     o                                                  C
10937 C       i             i                                                        C
10938 C                                                                              C
10939 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10940 C
10941 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
10942 C           energy moment and not to the cluster cumulant.
10943       iti=itortyp(itype(i))
10944       if (j.lt.nres-1) then
10945         itj1=itype2loc(itype(j+1))
10946       else
10947         itj1=nloctyp
10948       endif
10949       itk=itype2loc(itype(k))
10950       itk1=itype2loc(itype(k+1))
10951       if (l.lt.nres-1) then
10952         itl1=itype2loc(itype(l+1))
10953       else
10954         itl1=nloctyp
10955       endif
10956 #ifdef MOMENT
10957       s1=dip(4,jj,i)*dip(4,kk,k)
10958 #endif
10959       call matvec2(AECA(1,1,1),b1(1,k+1),auxvec(1))
10960       s2=0.5d0*scalar2(b1(1,k),auxvec(1))
10961       call matvec2(AECA(1,1,2),b1(1,l+1),auxvec(1))
10962       s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
10963       call transpose2(EE(1,1,k),auxmat(1,1))
10964       call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
10965       vv(1)=pizda(1,1)+pizda(2,2)
10966       vv(2)=pizda(2,1)-pizda(1,2)
10967       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
10968 cd      write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4,
10969 cd     & "sum",-(s2+s3+s4)
10970 #ifdef MOMENT
10971       eello6_graph3=-(s1+s2+s3+s4)
10972 #else
10973       eello6_graph3=-(s2+s3+s4)
10974 #endif
10975 c      eello6_graph3=-s4
10976 C Derivatives in gamma(k-1)
10977       call matvec2(AECAderg(1,1,2),b1(1,l+1),auxvec(1))
10978       s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
10979       s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
10980       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
10981 C Derivatives in gamma(l-1)
10982       call matvec2(AECAderg(1,1,1),b1(1,k+1),auxvec(1))
10983       s2=0.5d0*scalar2(b1(1,k),auxvec(1))
10984       call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
10985       vv(1)=pizda(1,1)+pizda(2,2)
10986       vv(2)=pizda(2,1)-pizda(1,2)
10987       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
10988       g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
10989 C Cartesian derivatives.
10990       do iii=1,2
10991         do kkk=1,5
10992           do lll=1,3
10993 #ifdef MOMENT
10994             if (iii.eq.1) then
10995               s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
10996             else
10997               s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
10998             endif
10999 #endif
11000             call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
11001      &        auxvec(1))
11002             s2=0.5d0*scalar2(b1(1,k),auxvec(1))
11003             call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,l+1),
11004      &        auxvec(1))
11005             s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
11006             call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),
11007      &        pizda(1,1))
11008             vv(1)=pizda(1,1)+pizda(2,2)
11009             vv(2)=pizda(2,1)-pizda(1,2)
11010             s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
11011 #ifdef MOMENT
11012             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
11013 #else
11014             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
11015 #endif
11016             if (swap) then
11017               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
11018             else
11019               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
11020             endif
11021 c            derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
11022           enddo
11023         enddo
11024       enddo
11025       return
11026       end
11027 c----------------------------------------------------------------------------
11028       double precision function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
11029       implicit real*8 (a-h,o-z)
11030       include 'DIMENSIONS'
11031       include 'COMMON.IOUNITS'
11032       include 'COMMON.CHAIN'
11033       include 'COMMON.DERIV'
11034       include 'COMMON.INTERACT'
11035       include 'COMMON.CONTACTS'
11036       include 'COMMON.CONTMAT'
11037       include 'COMMON.CORRMAT'
11038       include 'COMMON.TORSION'
11039       include 'COMMON.VAR'
11040       include 'COMMON.GEO'
11041       include 'COMMON.FFIELD'
11042       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
11043      & auxvec1(2),auxmat1(2,2)
11044       logical swap
11045 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
11046 C                                                                              C
11047 C      Parallel       Antiparallel                                             C
11048 C                                                                              C
11049 C          o             o                                                     C
11050 C         /l\   /   \   /j\                                                    C
11051 C        /   \ /     \ /   \                                                   C
11052 C       /| o |o       o| o |\                                                  C
11053 C     \ j|/k\|      \  |/k\|l                                                  C
11054 C      \ /   \       \ /   \                                                   C
11055 C       o     \       o     \                                                  C
11056 C       i             i                                                        C
11057 C                                                                              C
11058 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
11059 C
11060 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
11061 C           energy moment and not to the cluster cumulant.
11062 cd      write (2,*) 'eello_graph4: wturn6',wturn6
11063       iti=itype2loc(itype(i))
11064       itj=itype2loc(itype(j))
11065       if (j.lt.nres-1) then
11066         itj1=itype2loc(itype(j+1))
11067       else
11068         itj1=nloctyp
11069       endif
11070       itk=itype2loc(itype(k))
11071       if (k.lt.nres-1) then
11072         itk1=itype2loc(itype(k+1))
11073       else
11074         itk1=nloctyp
11075       endif
11076       itl=itype2loc(itype(l))
11077       if (l.lt.nres-1) then
11078         itl1=itype2loc(itype(l+1))
11079       else
11080         itl1=nloctyp
11081       endif
11082 cd      write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
11083 cd      write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
11084 cd     & ' itl',itl,' itl1',itl1
11085 #ifdef MOMENT
11086       if (imat.eq.1) then
11087         s1=dip(3,jj,i)*dip(3,kk,k)
11088       else
11089         s1=dip(2,jj,j)*dip(2,kk,l)
11090       endif
11091 #endif
11092       call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
11093       s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
11094       if (j.eq.l+1) then
11095         call matvec2(ADtEA1(1,1,3-imat),b1(1,j+1),auxvec1(1))
11096         s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
11097       else
11098         call matvec2(ADtEA1(1,1,3-imat),b1(1,l+1),auxvec1(1))
11099         s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
11100       endif
11101       call transpose2(EUg(1,1,k),auxmat(1,1))
11102       call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
11103       vv(1)=pizda(1,1)-pizda(2,2)
11104       vv(2)=pizda(2,1)+pizda(1,2)
11105       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
11106 cd      write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
11107 #ifdef MOMENT
11108       eello6_graph4=-(s1+s2+s3+s4)
11109 #else
11110       eello6_graph4=-(s2+s3+s4)
11111 #endif
11112 C Derivatives in gamma(i-1)
11113       if (i.gt.1) then
11114 #ifdef MOMENT
11115         if (imat.eq.1) then
11116           s1=dipderg(2,jj,i)*dip(3,kk,k)
11117         else
11118           s1=dipderg(4,jj,j)*dip(2,kk,l)
11119         endif
11120 #endif
11121         s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
11122         if (j.eq.l+1) then
11123           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,j+1),auxvec1(1))
11124           s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
11125         else
11126           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,l+1),auxvec1(1))
11127           s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
11128         endif
11129         s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
11130         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
11131 cd          write (2,*) 'turn6 derivatives'
11132 #ifdef MOMENT
11133           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
11134 #else
11135           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
11136 #endif
11137         else
11138 #ifdef MOMENT
11139           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
11140 #else
11141           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
11142 #endif
11143         endif
11144       endif
11145 C Derivatives in gamma(k-1)
11146 #ifdef MOMENT
11147       if (imat.eq.1) then
11148         s1=dip(3,jj,i)*dipderg(2,kk,k)
11149       else
11150         s1=dip(2,jj,j)*dipderg(4,kk,l)
11151       endif
11152 #endif
11153       call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
11154       s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
11155       if (j.eq.l+1) then
11156         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,j+1),auxvec1(1))
11157         s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
11158       else
11159         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,l+1),auxvec1(1))
11160         s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
11161       endif
11162       call transpose2(EUgder(1,1,k),auxmat1(1,1))
11163       call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
11164       vv(1)=pizda(1,1)-pizda(2,2)
11165       vv(2)=pizda(2,1)+pizda(1,2)
11166       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
11167       if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
11168 #ifdef MOMENT
11169         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
11170 #else
11171         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
11172 #endif
11173       else
11174 #ifdef MOMENT
11175         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
11176 #else
11177         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
11178 #endif
11179       endif
11180 C Derivatives in gamma(j-1) or gamma(l-1)
11181       if (l.eq.j+1 .and. l.gt.1) then
11182         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
11183         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
11184         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
11185         vv(1)=pizda(1,1)-pizda(2,2)
11186         vv(2)=pizda(2,1)+pizda(1,2)
11187         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
11188         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
11189       else if (j.gt.1) then
11190         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
11191         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
11192         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
11193         vv(1)=pizda(1,1)-pizda(2,2)
11194         vv(2)=pizda(2,1)+pizda(1,2)
11195         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
11196         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
11197           gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
11198         else
11199           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
11200         endif
11201       endif
11202 C Cartesian derivatives.
11203       do iii=1,2
11204         do kkk=1,5
11205           do lll=1,3
11206 #ifdef MOMENT
11207             if (iii.eq.1) then
11208               if (imat.eq.1) then
11209                 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
11210               else
11211                 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
11212               endif
11213             else
11214               if (imat.eq.1) then
11215                 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
11216               else
11217                 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
11218               endif
11219             endif
11220 #endif
11221             call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),
11222      &        auxvec(1))
11223             s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
11224             if (j.eq.l+1) then
11225               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
11226      &          b1(1,j+1),auxvec(1))
11227               s3=-0.5d0*scalar2(b1(1,j),auxvec(1))
11228             else
11229               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
11230      &          b1(1,l+1),auxvec(1))
11231               s3=-0.5d0*scalar2(b1(1,l),auxvec(1))
11232             endif
11233             call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
11234      &        pizda(1,1))
11235             vv(1)=pizda(1,1)-pizda(2,2)
11236             vv(2)=pizda(2,1)+pizda(1,2)
11237             s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
11238             if (swap) then
11239               if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
11240 #ifdef MOMENT
11241                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
11242      &             -(s1+s2+s4)
11243 #else
11244                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
11245      &             -(s2+s4)
11246 #endif
11247                 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
11248               else
11249 #ifdef MOMENT
11250                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
11251 #else
11252                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
11253 #endif
11254                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
11255               endif
11256             else
11257 #ifdef MOMENT
11258               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
11259 #else
11260               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
11261 #endif
11262               if (l.eq.j+1) then
11263                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
11264               else
11265                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
11266               endif
11267             endif
11268           enddo
11269         enddo
11270       enddo
11271       return
11272       end
11273 c----------------------------------------------------------------------------
11274       double precision function eello_turn6(i,jj,kk)
11275       implicit real*8 (a-h,o-z)
11276       include 'DIMENSIONS'
11277       include 'COMMON.IOUNITS'
11278       include 'COMMON.CHAIN'
11279       include 'COMMON.DERIV'
11280       include 'COMMON.INTERACT'
11281       include 'COMMON.CONTACTS'
11282       include 'COMMON.CONTMAT'
11283       include 'COMMON.CORRMAT'
11284       include 'COMMON.TORSION'
11285       include 'COMMON.VAR'
11286       include 'COMMON.GEO'
11287       double precision vtemp1(2),vtemp2(2),vtemp3(2),vtemp4(2),
11288      &  atemp(2,2),auxmat(2,2),achuj_temp(2,2),gtemp(2,2),gvec(2),
11289      &  ggg1(3),ggg2(3)
11290       double precision vtemp1d(2),vtemp2d(2),vtemp3d(2),vtemp4d(2),
11291      &  atempd(2,2),auxmatd(2,2),achuj_tempd(2,2),gtempd(2,2),gvecd(2)
11292 C 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
11293 C           the respective energy moment and not to the cluster cumulant.
11294       s1=0.0d0
11295       s8=0.0d0
11296       s13=0.0d0
11297 c
11298       eello_turn6=0.0d0
11299       j=i+4
11300       k=i+1
11301       l=i+3
11302       iti=itype2loc(itype(i))
11303       itk=itype2loc(itype(k))
11304       itk1=itype2loc(itype(k+1))
11305       itl=itype2loc(itype(l))
11306       itj=itype2loc(itype(j))
11307 cd      write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
11308 cd      write (2,*) 'i',i,' k',k,' j',j,' l',l
11309 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
11310 cd        eello6=0.0d0
11311 cd        return
11312 cd      endif
11313 cd      write (iout,*)
11314 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
11315 cd     &   ' and',k,l
11316 cd      call checkint_turn6(i,jj,kk,eel_turn6_num)
11317       do iii=1,2
11318         do kkk=1,5
11319           do lll=1,3
11320             derx_turn(lll,kkk,iii)=0.0d0
11321           enddo
11322         enddo
11323       enddo
11324 cd      eij=1.0d0
11325 cd      ekl=1.0d0
11326 cd      ekont=1.0d0
11327       eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
11328 cd      eello6_5=0.0d0
11329 cd      write (2,*) 'eello6_5',eello6_5
11330 #ifdef MOMENT
11331       call transpose2(AEA(1,1,1),auxmat(1,1))
11332       call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
11333       ss1=scalar2(Ub2(1,i+2),b1(1,l))
11334       s1 = (auxmat(1,1)+auxmat(2,2))*ss1
11335 #endif
11336       call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1(1))
11337       call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
11338       s2 = scalar2(b1(1,k),vtemp1(1))
11339 #ifdef MOMENT
11340       call transpose2(AEA(1,1,2),atemp(1,1))
11341       call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
11342       call matvec2(Ug2(1,1,i+2),dd(1,1,k+1),vtemp2(1))
11343       s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,l),vtemp2(1))
11344 #endif
11345       call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
11346       call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
11347       s12 = scalar2(Ub2(1,i+2),vtemp3(1))
11348 #ifdef MOMENT
11349       call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
11350       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
11351       call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
11352       call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
11353       ss13 = scalar2(b1(1,k),vtemp4(1))
11354       s13 = (gtemp(1,1)+gtemp(2,2))*ss13
11355 #endif
11356 c      write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
11357 c      s1=0.0d0
11358 c      s2=0.0d0
11359 c      s8=0.0d0
11360 c      s12=0.0d0
11361 c      s13=0.0d0
11362       eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
11363 C Derivatives in gamma(i+2)
11364       s1d =0.0d0
11365       s8d =0.0d0
11366 #ifdef MOMENT
11367       call transpose2(AEA(1,1,1),auxmatd(1,1))
11368       call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
11369       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
11370       call transpose2(AEAderg(1,1,2),atempd(1,1))
11371       call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
11372       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,l),vtemp2(1))
11373 #endif
11374       call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
11375       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
11376       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
11377 c      s1d=0.0d0
11378 c      s2d=0.0d0
11379 c      s8d=0.0d0
11380 c      s12d=0.0d0
11381 c      s13d=0.0d0
11382       gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
11383 C Derivatives in gamma(i+3)
11384 #ifdef MOMENT
11385       call transpose2(AEA(1,1,1),auxmatd(1,1))
11386       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
11387       ss1d=scalar2(Ub2der(1,i+2),b1(1,l))
11388       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
11389 #endif
11390       call matvec2(EUgder(1,1,i+2),b1(1,l),vtemp1d(1))
11391       call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
11392       s2d = scalar2(b1(1,k),vtemp1d(1))
11393 #ifdef MOMENT
11394       call matvec2(Ug2der(1,1,i+2),dd(1,1,k+1),vtemp2d(1))
11395       s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,l),vtemp2d(1))
11396 #endif
11397       s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
11398 #ifdef MOMENT
11399       call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
11400       call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
11401       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
11402 #endif
11403 c      s1d=0.0d0
11404 c      s2d=0.0d0
11405 c      s8d=0.0d0
11406 c      s12d=0.0d0
11407 c      s13d=0.0d0
11408 #ifdef MOMENT
11409       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
11410      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
11411 #else
11412       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
11413      &               -0.5d0*ekont*(s2d+s12d)
11414 #endif
11415 C Derivatives in gamma(i+4)
11416       call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
11417       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
11418       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
11419 #ifdef MOMENT
11420       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
11421       call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
11422       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
11423 #endif
11424 c      s1d=0.0d0
11425 c      s2d=0.0d0
11426 c      s8d=0.0d0
11427 C      s12d=0.0d0
11428 c      s13d=0.0d0
11429 #ifdef MOMENT
11430       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
11431 #else
11432       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
11433 #endif
11434 C Derivatives in gamma(i+5)
11435 #ifdef MOMENT
11436       call transpose2(AEAderg(1,1,1),auxmatd(1,1))
11437       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
11438       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
11439 #endif
11440       call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1d(1))
11441       call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
11442       s2d = scalar2(b1(1,k),vtemp1d(1))
11443 #ifdef MOMENT
11444       call transpose2(AEA(1,1,2),atempd(1,1))
11445       call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
11446       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,l),vtemp2(1))
11447 #endif
11448       call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
11449       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
11450 #ifdef MOMENT
11451       call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
11452       ss13d = scalar2(b1(1,k),vtemp4d(1))
11453       s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
11454 #endif
11455 c      s1d=0.0d0
11456 c      s2d=0.0d0
11457 c      s8d=0.0d0
11458 c      s12d=0.0d0
11459 c      s13d=0.0d0
11460 #ifdef MOMENT
11461       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
11462      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
11463 #else
11464       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
11465      &               -0.5d0*ekont*(s2d+s12d)
11466 #endif
11467 C Cartesian derivatives
11468       do iii=1,2
11469         do kkk=1,5
11470           do lll=1,3
11471 #ifdef MOMENT
11472             call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
11473             call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
11474             s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
11475 #endif
11476             call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1(1))
11477             call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),
11478      &          vtemp1d(1))
11479             s2d = scalar2(b1(1,k),vtemp1d(1))
11480 #ifdef MOMENT
11481             call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
11482             call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
11483             s8d = -(atempd(1,1)+atempd(2,2))*
11484      &           scalar2(cc(1,1,l),vtemp2(1))
11485 #endif
11486             call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),
11487      &           auxmatd(1,1))
11488             call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
11489             s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
11490 c      s1d=0.0d0
11491 c      s2d=0.0d0
11492 c      s8d=0.0d0
11493 c      s12d=0.0d0
11494 c      s13d=0.0d0
11495 #ifdef MOMENT
11496             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
11497      &        - 0.5d0*(s1d+s2d)
11498 #else
11499             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
11500      &        - 0.5d0*s2d
11501 #endif
11502 #ifdef MOMENT
11503             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
11504      &        - 0.5d0*(s8d+s12d)
11505 #else
11506             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
11507      &        - 0.5d0*s12d
11508 #endif
11509           enddo
11510         enddo
11511       enddo
11512 #ifdef MOMENT
11513       do kkk=1,5
11514         do lll=1,3
11515           call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),
11516      &      achuj_tempd(1,1))
11517           call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
11518           call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
11519           s13d=(gtempd(1,1)+gtempd(2,2))*ss13
11520           derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
11521           call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),
11522      &      vtemp4d(1))
11523           ss13d = scalar2(b1(1,k),vtemp4d(1))
11524           s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
11525           derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
11526         enddo
11527       enddo
11528 #endif
11529 cd      write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
11530 cd     &  16*eel_turn6_num
11531 cd      goto 1112
11532       if (j.lt.nres-1) then
11533         j1=j+1
11534         j2=j-1
11535       else
11536         j1=j-1
11537         j2=j-2
11538       endif
11539       if (l.lt.nres-1) then
11540         l1=l+1
11541         l2=l-1
11542       else
11543         l1=l-1
11544         l2=l-2
11545       endif
11546       do ll=1,3
11547 cgrad        ggg1(ll)=eel_turn6*g_contij(ll,1)
11548 cgrad        ggg2(ll)=eel_turn6*g_contij(ll,2)
11549 cgrad        ghalf=0.5d0*ggg1(ll)
11550 cd        ghalf=0.0d0
11551         gturn6ij=eel_turn6*g_contij(ll,1)+ekont*derx_turn(ll,1,1)
11552         gturn6kl=eel_turn6*g_contij(ll,2)+ekont*derx_turn(ll,1,2)
11553         gcorr6_turn(ll,i)=gcorr6_turn(ll,i)!+ghalf
11554      &    +ekont*derx_turn(ll,2,1)
11555         gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
11556         gcorr6_turn(ll,j)=gcorr6_turn(ll,j)!+ghalf
11557      &    +ekont*derx_turn(ll,4,1)
11558         gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
11559         gcorr6_turn_long(ll,j)=gcorr6_turn_long(ll,j)+gturn6ij
11560         gcorr6_turn_long(ll,i)=gcorr6_turn_long(ll,i)-gturn6ij
11561 cgrad        ghalf=0.5d0*ggg2(ll)
11562 cd        ghalf=0.0d0
11563         gcorr6_turn(ll,k)=gcorr6_turn(ll,k)!+ghalf
11564      &    +ekont*derx_turn(ll,2,2)
11565         gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
11566         gcorr6_turn(ll,l)=gcorr6_turn(ll,l)!+ghalf
11567      &    +ekont*derx_turn(ll,4,2)
11568         gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
11569         gcorr6_turn_long(ll,l)=gcorr6_turn_long(ll,l)+gturn6kl
11570         gcorr6_turn_long(ll,k)=gcorr6_turn_long(ll,k)-gturn6kl
11571       enddo
11572 cd      goto 1112
11573 cgrad      do m=i+1,j-1
11574 cgrad        do ll=1,3
11575 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
11576 cgrad        enddo
11577 cgrad      enddo
11578 cgrad      do m=k+1,l-1
11579 cgrad        do ll=1,3
11580 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
11581 cgrad        enddo
11582 cgrad      enddo
11583 cgrad1112  continue
11584 cgrad      do m=i+2,j2
11585 cgrad        do ll=1,3
11586 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
11587 cgrad        enddo
11588 cgrad      enddo
11589 cgrad      do m=k+2,l2
11590 cgrad        do ll=1,3
11591 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
11592 cgrad        enddo
11593 cgrad      enddo
11594 cd      do iii=1,nres-3
11595 cd        write (2,*) iii,g_corr6_loc(iii)
11596 cd      enddo
11597       eello_turn6=ekont*eel_turn6
11598 cd      write (2,*) 'ekont',ekont
11599 cd      write (2,*) 'eel_turn6',ekont*eel_turn6
11600       return
11601       end
11602 C-----------------------------------------------------------------------------
11603 #endif
11604       double precision function scalar(u,v)
11605 !DIR$ INLINEALWAYS scalar
11606 #ifndef OSF
11607 cDEC$ ATTRIBUTES FORCEINLINE::scalar
11608 #endif
11609       implicit none
11610       double precision u(3),v(3)
11611 cd      double precision sc
11612 cd      integer i
11613 cd      sc=0.0d0
11614 cd      do i=1,3
11615 cd        sc=sc+u(i)*v(i)
11616 cd      enddo
11617 cd      scalar=sc
11618
11619       scalar=u(1)*v(1)+u(2)*v(2)+u(3)*v(3)
11620       return
11621       end
11622 crc-------------------------------------------------
11623       SUBROUTINE MATVEC2(A1,V1,V2)
11624 !DIR$ INLINEALWAYS MATVEC2
11625 #ifndef OSF
11626 cDEC$ ATTRIBUTES FORCEINLINE::MATVEC2
11627 #endif
11628       implicit real*8 (a-h,o-z)
11629       include 'DIMENSIONS'
11630       DIMENSION A1(2,2),V1(2),V2(2)
11631 c      DO 1 I=1,2
11632 c        VI=0.0
11633 c        DO 3 K=1,2
11634 c    3     VI=VI+A1(I,K)*V1(K)
11635 c        Vaux(I)=VI
11636 c    1 CONTINUE
11637
11638       vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
11639       vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
11640
11641       v2(1)=vaux1
11642       v2(2)=vaux2
11643       END
11644 C---------------------------------------
11645       SUBROUTINE MATMAT2(A1,A2,A3)
11646 #ifndef OSF
11647 cDEC$ ATTRIBUTES FORCEINLINE::MATMAT2
11648 #endif
11649       implicit real*8 (a-h,o-z)
11650       include 'DIMENSIONS'
11651       DIMENSION A1(2,2),A2(2,2),A3(2,2)
11652 c      DIMENSION AI3(2,2)
11653 c        DO  J=1,2
11654 c          A3IJ=0.0
11655 c          DO K=1,2
11656 c           A3IJ=A3IJ+A1(I,K)*A2(K,J)
11657 c          enddo
11658 c          A3(I,J)=A3IJ
11659 c       enddo
11660 c      enddo
11661
11662       ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
11663       ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
11664       ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
11665       ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
11666
11667       A3(1,1)=AI3_11
11668       A3(2,1)=AI3_21
11669       A3(1,2)=AI3_12
11670       A3(2,2)=AI3_22
11671       END
11672
11673 c-------------------------------------------------------------------------
11674       double precision function scalar2(u,v)
11675 !DIR$ INLINEALWAYS scalar2
11676       implicit none
11677       double precision u(2),v(2)
11678       double precision sc
11679       integer i
11680       scalar2=u(1)*v(1)+u(2)*v(2)
11681       return
11682       end
11683
11684 C-----------------------------------------------------------------------------
11685
11686       subroutine transpose2(a,at)
11687 !DIR$ INLINEALWAYS transpose2
11688 #ifndef OSF
11689 cDEC$ ATTRIBUTES FORCEINLINE::transpose2
11690 #endif
11691       implicit none
11692       double precision a(2,2),at(2,2)
11693       at(1,1)=a(1,1)
11694       at(1,2)=a(2,1)
11695       at(2,1)=a(1,2)
11696       at(2,2)=a(2,2)
11697       return
11698       end
11699 c--------------------------------------------------------------------------
11700       subroutine transpose(n,a,at)
11701       implicit none
11702       integer n,i,j
11703       double precision a(n,n),at(n,n)
11704       do i=1,n
11705         do j=1,n
11706           at(j,i)=a(i,j)
11707         enddo
11708       enddo
11709       return
11710       end
11711 C---------------------------------------------------------------------------
11712       subroutine prodmat3(a1,a2,kk,transp,prod)
11713 !DIR$ INLINEALWAYS prodmat3
11714 #ifndef OSF
11715 cDEC$ ATTRIBUTES FORCEINLINE::prodmat3
11716 #endif
11717       implicit none
11718       integer i,j
11719       double precision a1(2,2),a2(2,2),a2t(2,2),kk(2,2),prod(2,2)
11720       logical transp
11721 crc      double precision auxmat(2,2),prod_(2,2)
11722
11723       if (transp) then
11724 crc        call transpose2(kk(1,1),auxmat(1,1))
11725 crc        call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
11726 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
11727
11728            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1)
11729      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
11730            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2)
11731      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
11732            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1)
11733      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
11734            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2)
11735      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
11736
11737       else
11738 crc        call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
11739 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
11740
11741            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1)
11742      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
11743            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2)
11744      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
11745            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1)
11746      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
11747            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2)
11748      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
11749
11750       endif
11751 c      call transpose2(a2(1,1),a2t(1,1))
11752
11753 crc      print *,transp
11754 crc      print *,((prod_(i,j),i=1,2),j=1,2)
11755 crc      print *,((prod(i,j),i=1,2),j=1,2)
11756
11757       return
11758       end
11759 CCC----------------------------------------------
11760       subroutine Eliptransfer(eliptran)
11761       implicit real*8 (a-h,o-z)
11762       include 'DIMENSIONS'
11763       include 'COMMON.GEO'
11764       include 'COMMON.VAR'
11765       include 'COMMON.LOCAL'
11766       include 'COMMON.CHAIN'
11767       include 'COMMON.DERIV'
11768       include 'COMMON.NAMES'
11769       include 'COMMON.INTERACT'
11770       include 'COMMON.IOUNITS'
11771       include 'COMMON.CALC'
11772       include 'COMMON.CONTROL'
11773       include 'COMMON.SPLITELE'
11774       include 'COMMON.SBRIDGE'
11775 C this is done by Adasko
11776 C      print *,"wchodze"
11777 C structure of box:
11778 C      water
11779 C--bordliptop-- buffore starts
11780 C--bufliptop--- here true lipid starts
11781 C      lipid
11782 C--buflipbot--- lipid ends buffore starts
11783 C--bordlipbot--buffore ends
11784       eliptran=0.0
11785       do i=ilip_start,ilip_end
11786 C       do i=1,1
11787         if (itype(i).eq.ntyp1) cycle
11788
11789         positi=(mod(((c(3,i)+c(3,i+1))/2.0d0),boxzsize))
11790         if (positi.le.0.0) positi=positi+boxzsize
11791 C        print *,i
11792 C first for peptide groups
11793 c for each residue check if it is in lipid or lipid water border area
11794        if ((positi.gt.bordlipbot)
11795      &.and.(positi.lt.bordliptop)) then
11796 C the energy transfer exist
11797         if (positi.lt.buflipbot) then
11798 C what fraction I am in
11799          fracinbuf=1.0d0-
11800      &        ((positi-bordlipbot)/lipbufthick)
11801 C lipbufthick is thickenes of lipid buffore
11802          sslip=sscalelip(fracinbuf)
11803          ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
11804          eliptran=eliptran+sslip*pepliptran
11805          gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
11806          gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
11807 C         gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
11808
11809 C        print *,"doing sccale for lower part"
11810 C         print *,i,sslip,fracinbuf,ssgradlip
11811         elseif (positi.gt.bufliptop) then
11812          fracinbuf=1.0d0-((bordliptop-positi)/lipbufthick)
11813          sslip=sscalelip(fracinbuf)
11814          ssgradlip=sscagradlip(fracinbuf)/lipbufthick
11815          eliptran=eliptran+sslip*pepliptran
11816          gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
11817          gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
11818 C         gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
11819 C          print *, "doing sscalefor top part"
11820 C         print *,i,sslip,fracinbuf,ssgradlip
11821         else
11822          eliptran=eliptran+pepliptran
11823 C         print *,"I am in true lipid"
11824         endif
11825 C       else
11826 C       eliptran=elpitran+0.0 ! I am in water
11827        endif
11828        enddo
11829 C       print *, "nic nie bylo w lipidzie?"
11830 C now multiply all by the peptide group transfer factor
11831 C       eliptran=eliptran*pepliptran
11832 C now the same for side chains
11833 CV       do i=1,1
11834        do i=ilip_start,ilip_end
11835         if (itype(i).eq.ntyp1) cycle
11836         positi=(mod(c(3,i+nres),boxzsize))
11837         if (positi.le.0) positi=positi+boxzsize
11838 C       print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop
11839 c for each residue check if it is in lipid or lipid water border area
11840 C       respos=mod(c(3,i+nres),boxzsize)
11841 C       print *,positi,bordlipbot,buflipbot
11842        if ((positi.gt.bordlipbot)
11843      & .and.(positi.lt.bordliptop)) then
11844 C the energy transfer exist
11845         if (positi.lt.buflipbot) then
11846          fracinbuf=1.0d0-
11847      &     ((positi-bordlipbot)/lipbufthick)
11848 C lipbufthick is thickenes of lipid buffore
11849          sslip=sscalelip(fracinbuf)
11850          ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
11851          eliptran=eliptran+sslip*liptranene(itype(i))
11852          gliptranx(3,i)=gliptranx(3,i)
11853      &+ssgradlip*liptranene(itype(i))
11854          gliptranc(3,i-1)= gliptranc(3,i-1)
11855      &+ssgradlip*liptranene(itype(i))
11856 C         print *,"doing sccale for lower part"
11857         elseif (positi.gt.bufliptop) then
11858          fracinbuf=1.0d0-
11859      &((bordliptop-positi)/lipbufthick)
11860          sslip=sscalelip(fracinbuf)
11861          ssgradlip=sscagradlip(fracinbuf)/lipbufthick
11862          eliptran=eliptran+sslip*liptranene(itype(i))
11863          gliptranx(3,i)=gliptranx(3,i)
11864      &+ssgradlip*liptranene(itype(i))
11865          gliptranc(3,i-1)= gliptranc(3,i-1)
11866      &+ssgradlip*liptranene(itype(i))
11867 C          print *, "doing sscalefor top part",sslip,fracinbuf
11868         else
11869          eliptran=eliptran+liptranene(itype(i))
11870 C         print *,"I am in true lipid"
11871         endif
11872         endif ! if in lipid or buffor
11873 C       else
11874 C       eliptran=elpitran+0.0 ! I am in water
11875        enddo
11876        return
11877        end
11878 C---------------------------------------------------------
11879 C AFM soubroutine for constant force
11880        subroutine AFMforce(Eafmforce)
11881        implicit real*8 (a-h,o-z)
11882       include 'DIMENSIONS'
11883       include 'COMMON.GEO'
11884       include 'COMMON.VAR'
11885       include 'COMMON.LOCAL'
11886       include 'COMMON.CHAIN'
11887       include 'COMMON.DERIV'
11888       include 'COMMON.NAMES'
11889       include 'COMMON.INTERACT'
11890       include 'COMMON.IOUNITS'
11891       include 'COMMON.CALC'
11892       include 'COMMON.CONTROL'
11893       include 'COMMON.SPLITELE'
11894       include 'COMMON.SBRIDGE'
11895       real*8 diffafm(3)
11896       dist=0.0d0
11897       Eafmforce=0.0d0
11898       do i=1,3
11899       diffafm(i)=c(i,afmend)-c(i,afmbeg)
11900       dist=dist+diffafm(i)**2
11901       enddo
11902       dist=dsqrt(dist)
11903       Eafmforce=-forceAFMconst*(dist-distafminit)
11904       do i=1,3
11905       gradafm(i,afmend-1)=-forceAFMconst*diffafm(i)/dist
11906       gradafm(i,afmbeg-1)=forceAFMconst*diffafm(i)/dist
11907       enddo
11908 C      print *,'AFM',Eafmforce
11909       return
11910       end
11911 C---------------------------------------------------------
11912 C AFM subroutine with pseudoconstant velocity
11913        subroutine AFMvel(Eafmforce)
11914        implicit real*8 (a-h,o-z)
11915       include 'DIMENSIONS'
11916       include 'COMMON.GEO'
11917       include 'COMMON.VAR'
11918       include 'COMMON.LOCAL'
11919       include 'COMMON.CHAIN'
11920       include 'COMMON.DERIV'
11921       include 'COMMON.NAMES'
11922       include 'COMMON.INTERACT'
11923       include 'COMMON.IOUNITS'
11924       include 'COMMON.CALC'
11925       include 'COMMON.CONTROL'
11926       include 'COMMON.SPLITELE'
11927       include 'COMMON.SBRIDGE'
11928       real*8 diffafm(3)
11929 C Only for check grad COMMENT if not used for checkgrad
11930 C      totT=3.0d0
11931 C--------------------------------------------------------
11932 C      print *,"wchodze"
11933       dist=0.0d0
11934       Eafmforce=0.0d0
11935       do i=1,3
11936       diffafm(i)=c(i,afmend)-c(i,afmbeg)
11937       dist=dist+diffafm(i)**2
11938       enddo
11939       dist=dsqrt(dist)
11940       Eafmforce=0.5d0*forceAFMconst
11941      & *(distafminit+totTafm*velAFMconst-dist)**2
11942 C      Eafmforce=-forceAFMconst*(dist-distafminit)
11943       do i=1,3
11944       gradafm(i,afmend-1)=-forceAFMconst*
11945      &(distafminit+totTafm*velAFMconst-dist)
11946      &*diffafm(i)/dist
11947       gradafm(i,afmbeg-1)=forceAFMconst*
11948      &(distafminit+totTafm*velAFMconst-dist)
11949      &*diffafm(i)/dist
11950       enddo
11951 C      print *,'AFM',Eafmforce,totTafm*velAFMconst,dist
11952       return
11953       end
11954 C-----------------------------------------------------------
11955 C first for shielding is setting of function of side-chains
11956        subroutine set_shield_fac
11957       implicit real*8 (a-h,o-z)
11958       include 'DIMENSIONS'
11959       include 'COMMON.CHAIN'
11960       include 'COMMON.DERIV'
11961       include 'COMMON.IOUNITS'
11962       include 'COMMON.SHIELD'
11963       include 'COMMON.INTERACT'
11964 C this is the squar root 77 devided by 81 the epislion in lipid (in protein)
11965       double precision div77_81/0.974996043d0/,
11966      &div4_81/0.2222222222d0/,sh_frac_dist_grad(3)
11967
11968 C the vector between center of side_chain and peptide group
11969        double precision pep_side(3),long,side_calf(3),
11970      &pept_group(3),costhet_grad(3),cosphi_grad_long(3),
11971      &cosphi_grad_loc(3),pep_side_norm(3),side_calf_norm(3)
11972 C the line belowe needs to be changed for FGPROC>1
11973       do i=1,nres-1
11974       if ((itype(i).eq.ntyp1).and.itype(i+1).eq.ntyp1) cycle
11975       ishield_list(i)=0
11976 Cif there two consequtive dummy atoms there is no peptide group between them
11977 C the line below has to be changed for FGPROC>1
11978       VolumeTotal=0.0
11979       do k=1,nres
11980        if ((itype(k).eq.ntyp1).or.(itype(k).eq.10)) cycle
11981        dist_pep_side=0.0
11982        dist_side_calf=0.0
11983        do j=1,3
11984 C first lets set vector conecting the ithe side-chain with kth side-chain
11985       pep_side(j)=c(j,k+nres)-(c(j,i)+c(j,i+1))/2.0d0
11986 C      pep_side(j)=2.0d0
11987 C and vector conecting the side-chain with its proper calfa
11988       side_calf(j)=c(j,k+nres)-c(j,k)
11989 C      side_calf(j)=2.0d0
11990       pept_group(j)=c(j,i)-c(j,i+1)
11991 C lets have their lenght
11992       dist_pep_side=pep_side(j)**2+dist_pep_side
11993       dist_side_calf=dist_side_calf+side_calf(j)**2
11994       dist_pept_group=dist_pept_group+pept_group(j)**2
11995       enddo
11996        dist_pep_side=dsqrt(dist_pep_side)
11997        dist_pept_group=dsqrt(dist_pept_group)
11998        dist_side_calf=dsqrt(dist_side_calf)
11999       do j=1,3
12000         pep_side_norm(j)=pep_side(j)/dist_pep_side
12001         side_calf_norm(j)=dist_side_calf
12002       enddo
12003 C now sscale fraction
12004        sh_frac_dist=-(dist_pep_side-rpp(1,1)-buff_shield)/buff_shield
12005 C       print *,buff_shield,"buff"
12006 C now sscale
12007         if (sh_frac_dist.le.0.0) cycle
12008 C If we reach here it means that this side chain reaches the shielding sphere
12009 C Lets add him to the list for gradient
12010         ishield_list(i)=ishield_list(i)+1
12011 C ishield_list is a list of non 0 side-chain that contribute to factor gradient
12012 C this list is essential otherwise problem would be O3
12013         shield_list(ishield_list(i),i)=k
12014 C Lets have the sscale value
12015         if (sh_frac_dist.gt.1.0) then
12016          scale_fac_dist=1.0d0
12017          do j=1,3
12018          sh_frac_dist_grad(j)=0.0d0
12019          enddo
12020         else
12021          scale_fac_dist=-sh_frac_dist*sh_frac_dist
12022      &                   *(2.0*sh_frac_dist-3.0d0)
12023          fac_help_scale=6.0*(sh_frac_dist-sh_frac_dist**2)
12024      &                  /dist_pep_side/buff_shield*0.5
12025 C remember for the final gradient multiply sh_frac_dist_grad(j)
12026 C for side_chain by factor -2 !
12027          do j=1,3
12028          sh_frac_dist_grad(j)=fac_help_scale*pep_side(j)
12029 C         print *,"jestem",scale_fac_dist,fac_help_scale,
12030 C     &                    sh_frac_dist_grad(j)
12031          enddo
12032         endif
12033 C        if ((i.eq.3).and.(k.eq.2)) then
12034 C        print *,i,sh_frac_dist,dist_pep,fac_help_scale,scale_fac_dist
12035 C     & ,"TU"
12036 C        endif
12037
12038 C this is what is now we have the distance scaling now volume...
12039       short=short_r_sidechain(itype(k))
12040       long=long_r_sidechain(itype(k))
12041       costhet=1.0d0/dsqrt(1.0+short**2/dist_pep_side**2)
12042 C now costhet_grad
12043 C       costhet=0.0d0
12044        costhet_fac=costhet**3*short**2*(-0.5)/dist_pep_side**4
12045 C       costhet_fac=0.0d0
12046        do j=1,3
12047          costhet_grad(j)=costhet_fac*pep_side(j)
12048        enddo
12049 C remember for the final gradient multiply costhet_grad(j)
12050 C for side_chain by factor -2 !
12051 C fac alfa is angle between CB_k,CA_k, CA_i,CA_i+1
12052 C pep_side0pept_group is vector multiplication
12053       pep_side0pept_group=0.0
12054       do j=1,3
12055       pep_side0pept_group=pep_side0pept_group+pep_side(j)*side_calf(j)
12056       enddo
12057       cosalfa=(pep_side0pept_group/
12058      & (dist_pep_side*dist_side_calf))
12059       fac_alfa_sin=1.0-cosalfa**2
12060       fac_alfa_sin=dsqrt(fac_alfa_sin)
12061       rkprim=fac_alfa_sin*(long-short)+short
12062 C now costhet_grad
12063        cosphi=1.0d0/dsqrt(1.0+rkprim**2/dist_pep_side**2)
12064        cosphi_fac=cosphi**3*rkprim**2*(-0.5)/dist_pep_side**4
12065
12066        do j=1,3
12067          cosphi_grad_long(j)=cosphi_fac*pep_side(j)
12068      &+cosphi**3*0.5/dist_pep_side**2*(-rkprim)
12069      &*(long-short)/fac_alfa_sin*cosalfa/
12070      &((dist_pep_side*dist_side_calf))*
12071      &((side_calf(j))-cosalfa*
12072      &((pep_side(j)/dist_pep_side)*dist_side_calf))
12073
12074         cosphi_grad_loc(j)=cosphi**3*0.5/dist_pep_side**2*(-rkprim)
12075      &*(long-short)/fac_alfa_sin*cosalfa
12076      &/((dist_pep_side*dist_side_calf))*
12077      &(pep_side(j)-
12078      &cosalfa*side_calf(j)/dist_side_calf*dist_pep_side)
12079        enddo
12080
12081       VofOverlap=VSolvSphere/2.0d0*(1.0-costhet)*(1.0-cosphi)
12082      &                    /VSolvSphere_div
12083      &                    *wshield
12084 C now the gradient...
12085 C grad_shield is gradient of Calfa for peptide groups
12086 C      write(iout,*) "shield_compon",i,k,VSolvSphere,scale_fac_dist,
12087 C     &               costhet,cosphi
12088 C       write(iout,*) "cosphi_compon",i,k,pep_side0pept_group,
12089 C     & dist_pep_side,dist_side_calf,c(1,k+nres),c(1,k),itype(k)
12090       do j=1,3
12091       grad_shield(j,i)=grad_shield(j,i)
12092 C gradient po skalowaniu
12093      &                +(sh_frac_dist_grad(j)
12094 C  gradient po costhet
12095      &-scale_fac_dist*costhet_grad(j)/(1.0-costhet)
12096      &-scale_fac_dist*(cosphi_grad_long(j))
12097      &/(1.0-cosphi) )*div77_81
12098      &*VofOverlap
12099 C grad_shield_side is Cbeta sidechain gradient
12100       grad_shield_side(j,ishield_list(i),i)=
12101      &        (sh_frac_dist_grad(j)*(-2.0d0)
12102      &       +scale_fac_dist*costhet_grad(j)*2.0d0/(1.0-costhet)
12103      &       +scale_fac_dist*(cosphi_grad_long(j))
12104      &        *2.0d0/(1.0-cosphi))
12105      &        *div77_81*VofOverlap
12106
12107        grad_shield_loc(j,ishield_list(i),i)=
12108      &   scale_fac_dist*cosphi_grad_loc(j)
12109      &        *2.0d0/(1.0-cosphi)
12110      &        *div77_81*VofOverlap
12111       enddo
12112       VolumeTotal=VolumeTotal+VofOverlap*scale_fac_dist
12113       enddo
12114       fac_shield(i)=VolumeTotal*div77_81+div4_81
12115 c      write(2,*) "TOTAL VOLUME",i,VolumeTotal,fac_shield(i)
12116       enddo
12117       return
12118       end
12119 C--------------------------------------------------------------------------
12120       double precision function tschebyshev(m,n,x,y)
12121       implicit none
12122       include "DIMENSIONS"
12123       integer i,m,n
12124       double precision x(n),y,yy(0:maxvar),aux
12125 c Tschebyshev polynomial. Note that the first term is omitted
12126 c m=0: the constant term is included
12127 c m=1: the constant term is not included
12128       yy(0)=1.0d0
12129       yy(1)=y
12130       do i=2,n
12131         yy(i)=2*yy(1)*yy(i-1)-yy(i-2)
12132       enddo
12133       aux=0.0d0
12134       do i=m,n
12135         aux=aux+x(i)*yy(i)
12136       enddo
12137       tschebyshev=aux
12138       return
12139       end
12140 C--------------------------------------------------------------------------
12141       double precision function gradtschebyshev(m,n,x,y)
12142       implicit none
12143       include "DIMENSIONS"
12144       integer i,m,n
12145       double precision x(n+1),y,yy(0:maxvar),aux
12146 c Tschebyshev polynomial. Note that the first term is omitted
12147 c m=0: the constant term is included
12148 c m=1: the constant term is not included
12149       yy(0)=1.0d0
12150       yy(1)=2.0d0*y
12151       do i=2,n
12152         yy(i)=2*y*yy(i-1)-yy(i-2)
12153       enddo
12154       aux=0.0d0
12155       do i=m,n
12156         aux=aux+x(i+1)*yy(i)*(i+1)
12157 C        print *, x(i+1),yy(i),i
12158       enddo
12159       gradtschebyshev=aux
12160       return
12161       end
12162 C------------------------------------------------------------------------
12163 C first for shielding is setting of function of side-chains
12164        subroutine set_shield_fac2
12165       implicit real*8 (a-h,o-z)
12166       include 'DIMENSIONS'
12167       include 'COMMON.CHAIN'
12168       include 'COMMON.DERIV'
12169       include 'COMMON.IOUNITS'
12170       include 'COMMON.SHIELD'
12171       include 'COMMON.INTERACT'
12172 C this is the squar root 77 devided by 81 the epislion in lipid (in protein)
12173       double precision div77_81/0.974996043d0/,
12174      &div4_81/0.2222222222d0/,sh_frac_dist_grad(3)
12175
12176 C the vector between center of side_chain and peptide group
12177        double precision pep_side(3),long,side_calf(3),
12178      &pept_group(3),costhet_grad(3),cosphi_grad_long(3),
12179      &cosphi_grad_loc(3),pep_side_norm(3),side_calf_norm(3)
12180 C the line belowe needs to be changed for FGPROC>1
12181       do i=1,nres-1
12182       if ((itype(i).eq.ntyp1).and.itype(i+1).eq.ntyp1) cycle
12183       ishield_list(i)=0
12184 Cif there two consequtive dummy atoms there is no peptide group between them
12185 C the line below has to be changed for FGPROC>1
12186       VolumeTotal=0.0
12187       do k=1,nres
12188        if ((itype(k).eq.ntyp1).or.(itype(k).eq.10)) cycle
12189        dist_pep_side=0.0
12190        dist_side_calf=0.0
12191        do j=1,3
12192 C first lets set vector conecting the ithe side-chain with kth side-chain
12193       pep_side(j)=c(j,k+nres)-(c(j,i)+c(j,i+1))/2.0d0
12194 C      pep_side(j)=2.0d0
12195 C and vector conecting the side-chain with its proper calfa
12196       side_calf(j)=c(j,k+nres)-c(j,k)
12197 C      side_calf(j)=2.0d0
12198       pept_group(j)=c(j,i)-c(j,i+1)
12199 C lets have their lenght
12200       dist_pep_side=pep_side(j)**2+dist_pep_side
12201       dist_side_calf=dist_side_calf+side_calf(j)**2
12202       dist_pept_group=dist_pept_group+pept_group(j)**2
12203       enddo
12204        dist_pep_side=dsqrt(dist_pep_side)
12205        dist_pept_group=dsqrt(dist_pept_group)
12206        dist_side_calf=dsqrt(dist_side_calf)
12207       do j=1,3
12208         pep_side_norm(j)=pep_side(j)/dist_pep_side
12209         side_calf_norm(j)=dist_side_calf
12210       enddo
12211 C now sscale fraction
12212        sh_frac_dist=-(dist_pep_side-rpp(1,1)-buff_shield)/buff_shield
12213 C       print *,buff_shield,"buff"
12214 C now sscale
12215         if (sh_frac_dist.le.0.0) cycle
12216 C If we reach here it means that this side chain reaches the shielding sphere
12217 C Lets add him to the list for gradient
12218         ishield_list(i)=ishield_list(i)+1
12219 C ishield_list is a list of non 0 side-chain that contribute to factor gradient
12220 C this list is essential otherwise problem would be O3
12221         shield_list(ishield_list(i),i)=k
12222 C Lets have the sscale value
12223         if (sh_frac_dist.gt.1.0) then
12224          scale_fac_dist=1.0d0
12225          do j=1,3
12226          sh_frac_dist_grad(j)=0.0d0
12227          enddo
12228         else
12229          scale_fac_dist=-sh_frac_dist*sh_frac_dist
12230      &                   *(2.0d0*sh_frac_dist-3.0d0)
12231          fac_help_scale=6.0d0*(sh_frac_dist-sh_frac_dist**2)
12232      &                  /dist_pep_side/buff_shield*0.5d0
12233 C remember for the final gradient multiply sh_frac_dist_grad(j)
12234 C for side_chain by factor -2 !
12235          do j=1,3
12236          sh_frac_dist_grad(j)=fac_help_scale*pep_side(j)
12237 C         sh_frac_dist_grad(j)=0.0d0
12238 C         scale_fac_dist=1.0d0
12239 C         print *,"jestem",scale_fac_dist,fac_help_scale,
12240 C     &                    sh_frac_dist_grad(j)
12241          enddo
12242         endif
12243 C this is what is now we have the distance scaling now volume...
12244       short=short_r_sidechain(itype(k))
12245       long=long_r_sidechain(itype(k))
12246       costhet=1.0d0/dsqrt(1.0d0+short**2/dist_pep_side**2)
12247       sinthet=short/dist_pep_side*costhet
12248 C now costhet_grad
12249 C       costhet=0.6d0
12250 C       sinthet=0.8
12251        costhet_fac=costhet**3*short**2*(-0.5d0)/dist_pep_side**4
12252 C       sinthet_fac=costhet**2*0.5d0*(short**3/dist_pep_side**4*costhet
12253 C     &             -short/dist_pep_side**2/costhet)
12254 C       costhet_fac=0.0d0
12255        do j=1,3
12256          costhet_grad(j)=costhet_fac*pep_side(j)
12257        enddo
12258 C remember for the final gradient multiply costhet_grad(j)
12259 C for side_chain by factor -2 !
12260 C fac alfa is angle between CB_k,CA_k, CA_i,CA_i+1
12261 C pep_side0pept_group is vector multiplication
12262       pep_side0pept_group=0.0d0
12263       do j=1,3
12264       pep_side0pept_group=pep_side0pept_group+pep_side(j)*side_calf(j)
12265       enddo
12266       cosalfa=(pep_side0pept_group/
12267      & (dist_pep_side*dist_side_calf))
12268       fac_alfa_sin=1.0d0-cosalfa**2
12269       fac_alfa_sin=dsqrt(fac_alfa_sin)
12270       rkprim=fac_alfa_sin*(long-short)+short
12271 C      rkprim=short
12272
12273 C now costhet_grad
12274        cosphi=1.0d0/dsqrt(1.0d0+rkprim**2/dist_pep_side**2)
12275 C       cosphi=0.6
12276        cosphi_fac=cosphi**3*rkprim**2*(-0.5d0)/dist_pep_side**4
12277        sinphi=rkprim/dist_pep_side/dsqrt(1.0d0+rkprim**2/
12278      &      dist_pep_side**2)
12279 C       sinphi=0.8
12280        do j=1,3
12281          cosphi_grad_long(j)=cosphi_fac*pep_side(j)
12282      &+cosphi**3*0.5d0/dist_pep_side**2*(-rkprim)
12283      &*(long-short)/fac_alfa_sin*cosalfa/
12284      &((dist_pep_side*dist_side_calf))*
12285      &((side_calf(j))-cosalfa*
12286      &((pep_side(j)/dist_pep_side)*dist_side_calf))
12287 C       cosphi_grad_long(j)=0.0d0
12288         cosphi_grad_loc(j)=cosphi**3*0.5d0/dist_pep_side**2*(-rkprim)
12289      &*(long-short)/fac_alfa_sin*cosalfa
12290      &/((dist_pep_side*dist_side_calf))*
12291      &(pep_side(j)-
12292      &cosalfa*side_calf(j)/dist_side_calf*dist_pep_side)
12293 C       cosphi_grad_loc(j)=0.0d0
12294        enddo
12295 C      print *,sinphi,sinthet
12296 c      write (iout,*) "VSolvSphere",VSolvSphere," VSolvSphere_div",
12297 c     &  VSolvSphere_div," sinphi",sinphi," sinthet",sinthet
12298       VofOverlap=VSolvSphere/2.0d0*(1.0d0-dsqrt(1.0d0-sinphi*sinthet))
12299      &                    /VSolvSphere_div
12300 C     &                    *wshield
12301 C now the gradient...
12302       do j=1,3
12303       grad_shield(j,i)=grad_shield(j,i)
12304 C gradient po skalowaniu
12305      &                +(sh_frac_dist_grad(j)*VofOverlap
12306 C  gradient po costhet
12307      &       +scale_fac_dist*VSolvSphere/VSolvSphere_div/4.0d0*
12308      &(1.0d0/(-dsqrt(1.0d0-sinphi*sinthet))*(
12309      &       sinphi/sinthet*costhet*costhet_grad(j)
12310      &      +sinthet/sinphi*cosphi*cosphi_grad_long(j)))
12311      & )*wshield
12312 C grad_shield_side is Cbeta sidechain gradient
12313       grad_shield_side(j,ishield_list(i),i)=
12314      &        (sh_frac_dist_grad(j)*(-2.0d0)
12315      &        *VofOverlap
12316      &       -scale_fac_dist*VSolvSphere/VSolvSphere_div/2.0d0*
12317      &(1.0d0/(-dsqrt(1.0d0-sinphi*sinthet))*(
12318      &       sinphi/sinthet*costhet*costhet_grad(j)
12319      &      +sinthet/sinphi*cosphi*cosphi_grad_long(j)))
12320      &       )*wshield
12321
12322        grad_shield_loc(j,ishield_list(i),i)=
12323      &       scale_fac_dist*VSolvSphere/VSolvSphere_div/2.0d0*
12324      &(1.0d0/(dsqrt(1.0d0-sinphi*sinthet))*(
12325      &       sinthet/sinphi*cosphi*cosphi_grad_loc(j)
12326      &        ))
12327      &        *wshield
12328       enddo
12329 c      write (iout,*) "VofOverlap",VofOverlap," scale_fac_dist",
12330 c     & scale_fac_dist
12331       VolumeTotal=VolumeTotal+VofOverlap*scale_fac_dist
12332       enddo
12333       fac_shield(i)=VolumeTotal*wshield+(1.0d0-wshield)
12334 c      write(2,*) "TOTAL VOLUME",i,VolumeTotal,fac_shield(i),
12335 c     &  " wshield",wshield
12336 c      write(2,*) "TU",rpp(1,1),short,long,buff_shield
12337       enddo
12338       return
12339       end
12340 C-----------------------------------------------------------------------
12341 C-----------------------------------------------------------
12342 C This subroutine is to mimic the histone like structure but as well can be
12343 C utilizet to nanostructures (infinit) small modification has to be used to
12344 C make it finite (z gradient at the ends has to be changes as well as the x,y
12345 C gradient has to be modified at the ends
12346 C The energy function is Kihara potential
12347 C E=4esp*((sigma/(r-r0))^12 - (sigma/(r-r0))^6)
12348 C 4eps is depth of well sigma is r_minimum r is distance from center of tube
12349 C and r0 is the excluded size of nanotube (can be set to 0 if we want just a
12350 C simple Kihara potential
12351       subroutine calctube(Etube)
12352        implicit real*8 (a-h,o-z)
12353       include 'DIMENSIONS'
12354       include 'COMMON.GEO'
12355       include 'COMMON.VAR'
12356       include 'COMMON.LOCAL'
12357       include 'COMMON.CHAIN'
12358       include 'COMMON.DERIV'
12359       include 'COMMON.NAMES'
12360       include 'COMMON.INTERACT'
12361       include 'COMMON.IOUNITS'
12362       include 'COMMON.CALC'
12363       include 'COMMON.CONTROL'
12364       include 'COMMON.SPLITELE'
12365       include 'COMMON.SBRIDGE'
12366       double precision tub_r,vectube(3),enetube(maxres*2)
12367       Etube=0.0d0
12368       do i=1,2*nres
12369         enetube(i)=0.0d0
12370       enddo
12371 C first we calculate the distance from tube center
12372 C first sugare-phosphate group for NARES this would be peptide group
12373 C for UNRES
12374       do i=1,nres
12375 C lets ommit dummy atoms for now
12376        if ((itype(i).eq.ntyp1).or.(itype(i+1).eq.ntyp1)) cycle
12377 C now calculate distance from center of tube and direction vectors
12378       vectube(1)=mod((c(1,i)+c(1,i+1))/2.0d0,boxxsize)
12379           if (vectube(1).lt.0) vectube(1)=vectube(1)+boxxsize
12380       vectube(2)=mod((c(2,i)+c(2,i+1))/2.0d0,boxxsize)
12381           if (vectube(2).lt.0) vectube(2)=vectube(2)+boxxsize
12382       vectube(1)=vectube(1)-tubecenter(1)
12383       vectube(2)=vectube(2)-tubecenter(2)
12384
12385 C      print *,"x",(c(1,i)+c(1,i+1))/2.0d0,tubecenter(1)
12386 C      print *,"y",(c(2,i)+c(2,i+1))/2.0d0,tubecenter(2)
12387
12388 C as the tube is infinity we do not calculate the Z-vector use of Z
12389 C as chosen axis
12390       vectube(3)=0.0d0
12391 C now calculte the distance
12392        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
12393 C now normalize vector
12394       vectube(1)=vectube(1)/tub_r
12395       vectube(2)=vectube(2)/tub_r
12396 C calculte rdiffrence between r and r0
12397       rdiff=tub_r-tubeR0
12398 C and its 6 power
12399       rdiff6=rdiff**6.0d0
12400 C for vectorization reasons we will sumup at the end to avoid depenence of previous
12401        enetube(i)=pep_aa_tube/rdiff6**2.0d0-pep_bb_tube/rdiff6
12402 C       write(iout,*) "TU13",i,rdiff6,enetube(i)
12403 C       print *,rdiff,rdiff6,pep_aa_tube
12404 C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
12405 C now we calculate gradient
12406        fac=(-12.0d0*pep_aa_tube/rdiff6+
12407      &       6.0d0*pep_bb_tube)/rdiff6/rdiff
12408 C       write(iout,'(a5,i4,f12.1,3f12.5)') "TU13",i,rdiff6,enetube(i),
12409 C     &rdiff,fac
12410
12411 C now direction of gg_tube vector
12412         do j=1,3
12413         gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac/2.0d0
12414         gg_tube(j,i)=gg_tube(j,i)+vectube(j)*fac/2.0d0
12415         enddo
12416         enddo
12417 C basically thats all code now we split for side-chains (REMEMBER to sum up at the END)
12418         do i=1,nres
12419 C Lets not jump over memory as we use many times iti
12420          iti=itype(i)
12421 C lets ommit dummy atoms for now
12422          if ((iti.eq.ntyp1)
12423 C in UNRES uncomment the line below as GLY has no side-chain...
12424 C      .or.(iti.eq.10)
12425      &   ) cycle
12426           vectube(1)=c(1,i+nres)
12427           vectube(1)=mod(vectube(1),boxxsize)
12428           if (vectube(1).lt.0) vectube(1)=vectube(1)+boxxsize
12429           vectube(2)=c(2,i+nres)
12430           vectube(2)=mod(vectube(2),boxxsize)
12431           if (vectube(2).lt.0) vectube(2)=vectube(2)+boxxsize
12432
12433       vectube(1)=vectube(1)-tubecenter(1)
12434       vectube(2)=vectube(2)-tubecenter(2)
12435
12436 C as the tube is infinity we do not calculate the Z-vector use of Z
12437 C as chosen axis
12438       vectube(3)=0.0d0
12439 C now calculte the distance
12440        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
12441 C now normalize vector
12442       vectube(1)=vectube(1)/tub_r
12443       vectube(2)=vectube(2)/tub_r
12444 C calculte rdiffrence between r and r0
12445       rdiff=tub_r-tubeR0
12446 C and its 6 power
12447       rdiff6=rdiff**6.0d0
12448 C for vectorization reasons we will sumup at the end to avoid depenence of previous
12449        sc_aa_tube=sc_aa_tube_par(iti)
12450        sc_bb_tube=sc_bb_tube_par(iti)
12451        enetube(i+nres)=sc_aa_tube/rdiff6**2.0d0-sc_bb_tube/rdiff6
12452 C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
12453 C now we calculate gradient
12454        fac=-12.0d0*sc_aa_tube/rdiff6**2.0d0/rdiff+
12455      &       6.0d0*sc_bb_tube/rdiff6/rdiff
12456 C now direction of gg_tube vector
12457          do j=1,3
12458           gg_tube_SC(j,i)=gg_tube_SC(j,i)+vectube(j)*fac
12459           gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac
12460          enddo
12461         enddo
12462         do i=1,2*nres
12463           Etube=Etube+enetube(i)
12464         enddo
12465 C        print *,"ETUBE", etube
12466         return
12467         end
12468 C TO DO 1) add to total energy
12469 C       2) add to gradient summation
12470 C       3) add reading parameters (AND of course oppening of PARAM file)
12471 C       4) add reading the center of tube
12472 C       5) add COMMONs
12473 C       6) add to zerograd
12474
12475 C-----------------------------------------------------------------------
12476 C-----------------------------------------------------------
12477 C This subroutine is to mimic the histone like structure but as well can be
12478 C utilizet to nanostructures (infinit) small modification has to be used to
12479 C make it finite (z gradient at the ends has to be changes as well as the x,y
12480 C gradient has to be modified at the ends
12481 C The energy function is Kihara potential
12482 C E=4esp*((sigma/(r-r0))^12 - (sigma/(r-r0))^6)
12483 C 4eps is depth of well sigma is r_minimum r is distance from center of tube
12484 C and r0 is the excluded size of nanotube (can be set to 0 if we want just a
12485 C simple Kihara potential
12486       subroutine calctube2(Etube)
12487        implicit real*8 (a-h,o-z)
12488       include 'DIMENSIONS'
12489       include 'COMMON.GEO'
12490       include 'COMMON.VAR'
12491       include 'COMMON.LOCAL'
12492       include 'COMMON.CHAIN'
12493       include 'COMMON.DERIV'
12494       include 'COMMON.NAMES'
12495       include 'COMMON.INTERACT'
12496       include 'COMMON.IOUNITS'
12497       include 'COMMON.CALC'
12498       include 'COMMON.CONTROL'
12499       include 'COMMON.SPLITELE'
12500       include 'COMMON.SBRIDGE'
12501       double precision tub_r,vectube(3),enetube(maxres*2)
12502       Etube=0.0d0
12503       do i=1,2*nres
12504         enetube(i)=0.0d0
12505       enddo
12506 C first we calculate the distance from tube center
12507 C first sugare-phosphate group for NARES this would be peptide group
12508 C for UNRES
12509       do i=1,nres
12510 C lets ommit dummy atoms for now
12511        if ((itype(i).eq.ntyp1).or.(itype(i+1).eq.ntyp1)) cycle
12512 C now calculate distance from center of tube and direction vectors
12513       vectube(1)=mod((c(1,i)+c(1,i+1))/2.0d0,boxxsize)
12514           if (vectube(1).lt.0) vectube(1)=vectube(1)+boxxsize
12515       vectube(2)=mod((c(2,i)+c(2,i+1))/2.0d0,boxxsize)
12516           if (vectube(2).lt.0) vectube(2)=vectube(2)+boxxsize
12517       vectube(1)=vectube(1)-tubecenter(1)
12518       vectube(2)=vectube(2)-tubecenter(2)
12519
12520 C      print *,"x",(c(1,i)+c(1,i+1))/2.0d0,tubecenter(1)
12521 C      print *,"y",(c(2,i)+c(2,i+1))/2.0d0,tubecenter(2)
12522
12523 C as the tube is infinity we do not calculate the Z-vector use of Z
12524 C as chosen axis
12525       vectube(3)=0.0d0
12526 C now calculte the distance
12527        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
12528 C now normalize vector
12529       vectube(1)=vectube(1)/tub_r
12530       vectube(2)=vectube(2)/tub_r
12531 C calculte rdiffrence between r and r0
12532       rdiff=tub_r-tubeR0
12533 C and its 6 power
12534       rdiff6=rdiff**6.0d0
12535 C for vectorization reasons we will sumup at the end to avoid depenence of previous
12536        enetube(i)=pep_aa_tube/rdiff6**2.0d0-pep_bb_tube/rdiff6
12537 C       write(iout,*) "TU13",i,rdiff6,enetube(i)
12538 C       print *,rdiff,rdiff6,pep_aa_tube
12539 C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
12540 C now we calculate gradient
12541        fac=(-12.0d0*pep_aa_tube/rdiff6+
12542      &       6.0d0*pep_bb_tube)/rdiff6/rdiff
12543 C       write(iout,'(a5,i4,f12.1,3f12.5)') "TU13",i,rdiff6,enetube(i),
12544 C     &rdiff,fac
12545
12546 C now direction of gg_tube vector
12547         do j=1,3
12548         gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac/2.0d0
12549         gg_tube(j,i)=gg_tube(j,i)+vectube(j)*fac/2.0d0
12550         enddo
12551         enddo
12552 C basically thats all code now we split for side-chains (REMEMBER to sum up at the END)
12553         do i=1,nres
12554 C Lets not jump over memory as we use many times iti
12555          iti=itype(i)
12556 C lets ommit dummy atoms for now
12557          if ((iti.eq.ntyp1)
12558 C in UNRES uncomment the line below as GLY has no side-chain...
12559      &      .or.(iti.eq.10)
12560      &   ) cycle
12561           vectube(1)=c(1,i+nres)
12562           vectube(1)=mod(vectube(1),boxxsize)
12563           if (vectube(1).lt.0) vectube(1)=vectube(1)+boxxsize
12564           vectube(2)=c(2,i+nres)
12565           vectube(2)=mod(vectube(2),boxxsize)
12566           if (vectube(2).lt.0) vectube(2)=vectube(2)+boxxsize
12567
12568       vectube(1)=vectube(1)-tubecenter(1)
12569       vectube(2)=vectube(2)-tubecenter(2)
12570 C THIS FRAGMENT MAKES TUBE FINITE
12571         positi=(mod(c(3,i+nres),boxzsize))
12572         if (positi.le.0) positi=positi+boxzsize
12573 C       print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop
12574 c for each residue check if it is in lipid or lipid water border area
12575 C       respos=mod(c(3,i+nres),boxzsize)
12576        print *,positi,bordtubebot,buftubebot,bordtubetop
12577        if ((positi.gt.bordtubebot)
12578      & .and.(positi.lt.bordtubetop)) then
12579 C the energy transfer exist
12580         if (positi.lt.buftubebot) then
12581          fracinbuf=1.0d0-
12582      &     ((positi-bordtubebot)/tubebufthick)
12583 C lipbufthick is thickenes of lipid buffore
12584          sstube=sscalelip(fracinbuf)
12585          ssgradtube=-sscagradlip(fracinbuf)/tubebufthick
12586          print *,ssgradtube, sstube,tubetranene(itype(i))
12587          enetube(i+nres)=enetube(i+nres)+sstube*tubetranene(itype(i))
12588          gg_tube_SC(3,i)=gg_tube_SC(3,i)
12589      &+ssgradtube*tubetranene(itype(i))
12590          gg_tube(3,i-1)= gg_tube(3,i-1)
12591      &+ssgradtube*tubetranene(itype(i))
12592 C         print *,"doing sccale for lower part"
12593         elseif (positi.gt.buftubetop) then
12594          fracinbuf=1.0d0-
12595      &((bordtubetop-positi)/tubebufthick)
12596          sstube=sscalelip(fracinbuf)
12597          ssgradtube=sscagradlip(fracinbuf)/tubebufthick
12598          enetube(i+nres)=enetube(i+nres)+sstube*tubetranene(itype(i))
12599 C         gg_tube_SC(3,i)=gg_tube_SC(3,i)
12600 C     &+ssgradtube*tubetranene(itype(i))
12601 C         gg_tube(3,i-1)= gg_tube(3,i-1)
12602 C     &+ssgradtube*tubetranene(itype(i))
12603 C          print *, "doing sscalefor top part",sslip,fracinbuf
12604         else
12605          sstube=1.0d0
12606          ssgradtube=0.0d0
12607          enetube(i+nres)=enetube(i+nres)+sstube*tubetranene(itype(i))
12608 C         print *,"I am in true lipid"
12609         endif
12610         else
12611 C          sstube=0.0d0
12612 C          ssgradtube=0.0d0
12613         cycle
12614         endif ! if in lipid or buffor
12615 CEND OF FINITE FRAGMENT
12616 C as the tube is infinity we do not calculate the Z-vector use of Z
12617 C as chosen axis
12618       vectube(3)=0.0d0
12619 C now calculte the distance
12620        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
12621 C now normalize vector
12622       vectube(1)=vectube(1)/tub_r
12623       vectube(2)=vectube(2)/tub_r
12624 C calculte rdiffrence between r and r0
12625       rdiff=tub_r-tubeR0
12626 C and its 6 power
12627       rdiff6=rdiff**6.0d0
12628 C for vectorization reasons we will sumup at the end to avoid depenence of previous
12629        sc_aa_tube=sc_aa_tube_par(iti)
12630        sc_bb_tube=sc_bb_tube_par(iti)
12631        enetube(i+nres)=(sc_aa_tube/rdiff6**2.0d0-sc_bb_tube/rdiff6)
12632      &                 *sstube+enetube(i+nres)
12633 C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
12634 C now we calculate gradient
12635        fac=(-12.0d0*sc_aa_tube/rdiff6**2.0d0/rdiff+
12636      &       6.0d0*sc_bb_tube/rdiff6/rdiff)*sstube
12637 C now direction of gg_tube vector
12638          do j=1,3
12639           gg_tube_SC(j,i)=gg_tube_SC(j,i)+vectube(j)*fac
12640           gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac
12641          enddo
12642          gg_tube_SC(3,i)=gg_tube_SC(3,i)
12643      &+ssgradtube*enetube(i+nres)/sstube
12644          gg_tube(3,i-1)= gg_tube(3,i-1)
12645      &+ssgradtube*enetube(i+nres)/sstube
12646
12647         enddo
12648         do i=1,2*nres
12649           Etube=Etube+enetube(i)
12650         enddo
12651 C        print *,"ETUBE", etube
12652         return
12653         end
12654 C TO DO 1) add to total energy
12655 C       2) add to gradient summation
12656 C       3) add reading parameters (AND of course oppening of PARAM file)
12657 C       4) add reading the center of tube
12658 C       5) add COMMONs
12659 C       6) add to zerograd
12660 c----------------------------------------------------------------------------
12661       subroutine e_saxs(Esaxs_constr)
12662       implicit none
12663       include 'DIMENSIONS'
12664 #ifdef MPI
12665       include "mpif.h"
12666       include "COMMON.SETUP"
12667       integer IERR
12668 #endif
12669       include 'COMMON.SBRIDGE'
12670       include 'COMMON.CHAIN'
12671       include 'COMMON.GEO'
12672       include 'COMMON.DERIV'
12673       include 'COMMON.LOCAL'
12674       include 'COMMON.INTERACT'
12675       include 'COMMON.VAR'
12676       include 'COMMON.IOUNITS'
12677 c      include 'COMMON.MD'
12678 #ifdef LANG0
12679 #ifdef FIVEDIAG
12680       include 'COMMON.LANGEVIN.lang0.5diag'
12681 #else
12682       include 'COMMON.LANGEVIN.lang0'
12683 #endif
12684 #else
12685       include 'COMMON.LANGEVIN'
12686 #endif
12687       include 'COMMON.CONTROL'
12688       include 'COMMON.SAXS'
12689       include 'COMMON.NAMES'
12690       include 'COMMON.TIME1'
12691       include 'COMMON.FFIELD'
12692 c
12693       double precision Esaxs_constr
12694       integer i,iint,j,k,l
12695       double precision PgradC(maxSAXS,3,maxres),
12696      &  PgradX(maxSAXS,3,maxres),Pcalc(maxSAXS)
12697 #ifdef MPI
12698       double precision PgradC_(maxSAXS,3,maxres),
12699      &  PgradX_(maxSAXS,3,maxres),Pcalc_(maxSAXS)
12700 #endif
12701       double precision dk,dijCACA,dijCASC,dijSCCA,dijSCSC,
12702      & sigma2CACA,sigma2CASC,sigma2SCCA,sigma2SCSC,expCACA,expCASC,
12703      & expSCCA,expSCSC,CASCgrad,SCCAgrad,SCSCgrad,aux,auxC,auxC1,
12704      & auxX,auxX1,CACAgrad,Cnorm,sigmaCACA,threesig
12705       double precision sss2,ssgrad2,rrr,sscalgrad2,sscale2
12706       double precision dist,mygauss,mygaussder
12707       external dist
12708       integer llicz,lllicz
12709       double precision time01
12710 c  SAXS restraint penalty function
12711 #ifdef DEBUG
12712       write(iout,*) "------- SAXS penalty function start -------"
12713       write (iout,*) "nsaxs",nsaxs
12714       write (iout,*) "Esaxs: iatsc_s",iatsc_s," iatsc_e",iatsc_e
12715       write (iout,*) "Psaxs"
12716       do i=1,nsaxs
12717         write (iout,'(i5,e15.5)') i, Psaxs(i)
12718       enddo
12719 #endif
12720 #ifdef TIMING
12721       time01=MPI_Wtime()
12722 #endif
12723       Esaxs_constr = 0.0d0
12724       do k=1,nsaxs
12725         Pcalc(k)=0.0d0
12726         do j=1,nres
12727           do l=1,3
12728             PgradC(k,l,j)=0.0d0
12729             PgradX(k,l,j)=0.0d0
12730           enddo
12731         enddo
12732       enddo
12733 c      lllicz=0
12734       do i=iatsc_s,iatsc_e
12735        if (itype(i).eq.ntyp1) cycle
12736        do iint=1,nint_gr(i)
12737          do j=istart(i,iint),iend(i,iint)
12738            if (itype(j).eq.ntyp1) cycle
12739 #ifdef ALLSAXS
12740            dijCACA=dist(i,j)
12741            dijCASC=dist(i,j+nres)
12742            dijSCCA=dist(i+nres,j)
12743            dijSCSC=dist(i+nres,j+nres)
12744            sigma2CACA=2.0d0/(pstok**2)
12745            sigma2CASC=4.0d0/(pstok**2+restok(itype(j))**2)
12746            sigma2SCCA=4.0d0/(pstok**2+restok(itype(i))**2)
12747            sigma2SCSC=4.0d0/(restok(itype(j))**2+restok(itype(i))**2)
12748            do k=1,nsaxs
12749              dk = distsaxs(k)
12750              expCACA = dexp(-0.5d0*sigma2CACA*(dijCACA-dk)**2)
12751              if (itype(j).ne.10) then
12752              expCASC = dexp(-0.5d0*sigma2CASC*(dijCASC-dk)**2)
12753              else
12754              endif
12755              expCASC = 0.0d0
12756              if (itype(i).ne.10) then
12757              expSCCA = dexp(-0.5d0*sigma2SCCA*(dijSCCA-dk)**2)
12758              else
12759              expSCCA = 0.0d0
12760              endif
12761              if (itype(i).ne.10 .and. itype(j).ne.10) then
12762              expSCSC = dexp(-0.5d0*sigma2SCSC*(dijSCSC-dk)**2)
12763              else
12764              expSCSC = 0.0d0
12765              endif
12766              Pcalc(k) = Pcalc(k)+expCACA+expCASC+expSCCA+expSCSC
12767 #ifdef DEBUG
12768              write(iout,*) "i j k Pcalc",i,j,Pcalc(k)
12769 #endif
12770              CACAgrad = sigma2CACA*(dijCACA-dk)*expCACA
12771              CASCgrad = sigma2CASC*(dijCASC-dk)*expCASC
12772              SCCAgrad = sigma2SCCA*(dijSCCA-dk)*expSCCA
12773              SCSCgrad = sigma2SCSC*(dijSCSC-dk)*expSCSC
12774              do l=1,3
12775 c CA CA
12776                aux = CACAgrad*(C(l,j)-C(l,i))/dijCACA
12777                PgradC(k,l,i) = PgradC(k,l,i)-aux
12778                PgradC(k,l,j) = PgradC(k,l,j)+aux
12779 c CA SC
12780                if (itype(j).ne.10) then
12781                aux = CASCgrad*(C(l,j+nres)-C(l,i))/dijCASC
12782                PgradC(k,l,i) = PgradC(k,l,i)-aux
12783                PgradC(k,l,j) = PgradC(k,l,j)+aux
12784                PgradX(k,l,j) = PgradX(k,l,j)+aux
12785                endif
12786 c SC CA
12787                if (itype(i).ne.10) then
12788                aux = SCCAgrad*(C(l,j)-C(l,i+nres))/dijSCCA
12789                PgradX(k,l,i) = PgradX(k,l,i)-aux
12790                PgradC(k,l,i) = PgradC(k,l,i)-aux
12791                PgradC(k,l,j) = PgradC(k,l,j)+aux
12792                endif
12793 c SC SC
12794                if (itype(i).ne.10 .and. itype(j).ne.10) then
12795                aux = SCSCgrad*(C(l,j+nres)-C(l,i+nres))/dijSCSC
12796                PgradC(k,l,i) = PgradC(k,l,i)-aux
12797                PgradC(k,l,j) = PgradC(k,l,j)+aux
12798                PgradX(k,l,i) = PgradX(k,l,i)-aux
12799                PgradX(k,l,j) = PgradX(k,l,j)+aux
12800                endif
12801              enddo ! l
12802            enddo ! k
12803 #else
12804            dijCACA=dist(i,j)
12805            sigma2CACA=scal_rad**2*0.25d0/
12806      &        (restok(itype(j))**2+restok(itype(i))**2)
12807 c           write (iout,*) "scal_rad",scal_rad," restok",restok(itype(j))
12808 c     &       ,restok(itype(i)),"sigma",1.0d0/dsqrt(sigma2CACA)
12809 #ifdef MYGAUSS
12810            sigmaCACA=dsqrt(sigma2CACA)
12811            threesig=3.0d0/sigmaCACA
12812 c           llicz=0
12813            do k=1,nsaxs
12814              dk = distsaxs(k)
12815              if (dabs(dijCACA-dk).ge.threesig) cycle
12816 c             llicz=llicz+1
12817 c             lllicz=lllicz+1
12818              aux = sigmaCACA*(dijCACA-dk)
12819              expCACA = mygauss(aux)
12820 c             if (expcaca.eq.0.0d0) cycle
12821              Pcalc(k) = Pcalc(k)+expCACA
12822              CACAgrad = -sigmaCACA*mygaussder(aux)
12823 c             write (iout,*) "i,j,k,aux",i,j,k,CACAgrad
12824              do l=1,3
12825                aux = CACAgrad*(C(l,j)-C(l,i))/dijCACA
12826                PgradC(k,l,i) = PgradC(k,l,i)-aux
12827                PgradC(k,l,j) = PgradC(k,l,j)+aux
12828              enddo ! l
12829            enddo ! k
12830 c           write (iout,*) "i",i," j",j," llicz",llicz
12831 #else
12832            IF (saxs_cutoff.eq.0) THEN
12833            do k=1,nsaxs
12834              dk = distsaxs(k)
12835              expCACA = dexp(-0.5d0*sigma2CACA*(dijCACA-dk)**2)
12836              Pcalc(k) = Pcalc(k)+expCACA
12837              CACAgrad = sigma2CACA*(dijCACA-dk)*expCACA
12838              do l=1,3
12839                aux = CACAgrad*(C(l,j)-C(l,i))/dijCACA
12840                PgradC(k,l,i) = PgradC(k,l,i)-aux
12841                PgradC(k,l,j) = PgradC(k,l,j)+aux
12842              enddo ! l
12843            enddo ! k
12844            ELSE
12845            rrr = saxs_cutoff*2.0d0/dsqrt(sigma2CACA)
12846            do k=1,nsaxs
12847              dk = distsaxs(k)
12848 c             write (2,*) "ijk",i,j,k
12849              sss2 = sscale2(dijCACA,rrr,dk,0.3d0)
12850              if (sss2.eq.0.0d0) cycle
12851              ssgrad2 = sscalgrad2(dijCACA,rrr,dk,0.3d0)
12852              if (energy_dec) write(iout,'(a4,3i5,8f10.4)')
12853      &          'saxs',i,j,k,dijCACA,restok(itype(i)),restok(itype(j)),
12854      &          1.0d0/dsqrt(sigma2CACA),rrr,dk,
12855      &           sss2,ssgrad2
12856              expCACA = dexp(-0.5d0*sigma2CACA*(dijCACA-dk)**2)*sss2
12857              Pcalc(k) = Pcalc(k)+expCACA
12858 #ifdef DEBUG
12859              write(iout,*) "i j k Pcalc",i,j,Pcalc(k)
12860 #endif
12861              CACAgrad = -sigma2CACA*(dijCACA-dk)*expCACA+
12862      &             ssgrad2*expCACA/sss2
12863              do l=1,3
12864 c CA CA
12865                aux = CACAgrad*(C(l,j)-C(l,i))/dijCACA
12866                PgradC(k,l,i) = PgradC(k,l,i)+aux
12867                PgradC(k,l,j) = PgradC(k,l,j)-aux
12868              enddo ! l
12869            enddo ! k
12870            ENDIF
12871 #endif
12872 #endif
12873          enddo ! j
12874        enddo ! iint
12875       enddo ! i
12876 c#ifdef TIMING
12877 c      time_SAXS=time_SAXS+MPI_Wtime()-time01
12878 c#endif
12879 c      write (iout,*) "lllicz",lllicz
12880 c#ifdef TIMING
12881 c      time01=MPI_Wtime()
12882 c#endif
12883 #ifdef MPI
12884       if (nfgtasks.gt.1) then
12885        call MPI_AllReduce(Pcalc(1),Pcalc_(1),nsaxs,MPI_DOUBLE_PRECISION,
12886      &    MPI_SUM,FG_COMM,IERR)
12887 c        if (fg_rank.eq.king) then
12888           do k=1,nsaxs
12889             Pcalc(k) = Pcalc_(k)
12890           enddo
12891 c        endif
12892 c        call MPI_AllReduce(PgradC(k,1,1),PgradC_(k,1,1),3*maxsaxs*nres,
12893 c     &    MPI_DOUBLE_PRECISION,MPI_SUM,FG_COMM,IERR)
12894 c        if (fg_rank.eq.king) then
12895 c          do i=1,nres
12896 c            do l=1,3
12897 c              do k=1,nsaxs
12898 c                PgradC(k,l,i) = PgradC_(k,l,i)
12899 c              enddo
12900 c            enddo
12901 c          enddo
12902 c        endif
12903 #ifdef ALLSAXS
12904 c        call MPI_AllReduce(PgradX(k,1,1),PgradX_(k,1,1),3*maxsaxs*nres,
12905 c     &    MPI_DOUBLE_PRECISION,MPI_SUM,FG_COMM,IERR)
12906 c        if (fg_rank.eq.king) then
12907 c          do i=1,nres
12908 c            do l=1,3
12909 c              do k=1,nsaxs
12910 c                PgradX(k,l,i) = PgradX_(k,l,i)
12911 c              enddo
12912 c            enddo
12913 c          enddo
12914 c        endif
12915 #endif
12916       endif
12917 #endif
12918       Cnorm = 0.0d0
12919       do k=1,nsaxs
12920         Cnorm = Cnorm + Pcalc(k)
12921       enddo
12922 #ifdef MPI
12923       if (fg_rank.eq.king) then
12924 #endif
12925       Esaxs_constr = dlog(Cnorm)-wsaxs0
12926       do k=1,nsaxs
12927         if (Pcalc(k).gt.0.0d0)
12928      &  Esaxs_constr = Esaxs_constr - Psaxs(k)*dlog(Pcalc(k))
12929 #ifdef DEBUG
12930         write (iout,*) "k",k," Esaxs_constr",Esaxs_constr
12931 #endif
12932       enddo
12933 #ifdef DEBUG
12934       write (iout,*) "Cnorm",Cnorm," Esaxs_constr",Esaxs_constr
12935 #endif
12936 #ifdef MPI
12937       endif
12938 #endif
12939       gsaxsC=0.0d0
12940       gsaxsX=0.0d0
12941       do i=nnt,nct
12942         do l=1,3
12943           auxC=0.0d0
12944           auxC1=0.0d0
12945           auxX=0.0d0
12946           auxX1=0.d0
12947           do k=1,nsaxs
12948             if (Pcalc(k).gt.0)
12949      &      auxC  = auxC +Psaxs(k)*PgradC(k,l,i)/Pcalc(k)
12950             auxC1 = auxC1+PgradC(k,l,i)
12951 #ifdef ALLSAXS
12952             auxX  = auxX +Psaxs(k)*PgradX(k,l,i)/Pcalc(k)
12953             auxX1 = auxX1+PgradX(k,l,i)
12954 #endif
12955           enddo
12956           gsaxsC(l,i) = auxC - auxC1/Cnorm
12957 #ifdef ALLSAXS
12958           gsaxsX(l,i) = auxX - auxX1/Cnorm
12959 #endif
12960 c          write (iout,*) "l i",l,i," gradC",wsaxs*(auxC - auxC1/Cnorm),
12961 c     *     " gradX",wsaxs*(auxX - auxX1/Cnorm)
12962 c          write (iout,*) "l i",l,i," gradC",wsaxs*gsaxsC(l,i),
12963 c     *     " gradX",wsaxs*gsaxsX(l,i)
12964         enddo
12965       enddo
12966 #ifdef TIMING
12967       time_SAXS=time_SAXS+MPI_Wtime()-time01
12968 #endif
12969 #ifdef DEBUG
12970       write (iout,*) "gsaxsc"
12971       do i=nnt,nct
12972         write (iout,'(i5,3e15.5)') i,(gsaxsc(j,i),j=1,3)
12973       enddo
12974 #endif
12975 #ifdef MPI
12976 c      endif
12977 #endif
12978       return
12979       end
12980 c----------------------------------------------------------------------------
12981       subroutine e_saxsC(Esaxs_constr)
12982       implicit none
12983       include 'DIMENSIONS'
12984 #ifdef MPI
12985       include "mpif.h"
12986       include "COMMON.SETUP"
12987       integer IERR
12988 #endif
12989       include 'COMMON.SBRIDGE'
12990       include 'COMMON.CHAIN'
12991       include 'COMMON.GEO'
12992       include 'COMMON.DERIV'
12993       include 'COMMON.LOCAL'
12994       include 'COMMON.INTERACT'
12995       include 'COMMON.VAR'
12996       include 'COMMON.IOUNITS'
12997 c      include 'COMMON.MD'
12998 #ifdef LANG0
12999 #ifdef FIVEDIAG
13000       include 'COMMON.LANGEVIN.lang0.5diag'
13001 #else
13002       include 'COMMON.LANGEVIN.lang0'
13003 #endif
13004 #else
13005       include 'COMMON.LANGEVIN'
13006 #endif
13007       include 'COMMON.CONTROL'
13008       include 'COMMON.SAXS'
13009       include 'COMMON.NAMES'
13010       include 'COMMON.TIME1'
13011       include 'COMMON.FFIELD'
13012 c
13013       double precision Esaxs_constr
13014       integer i,iint,j,k,l
13015       double precision PgradC(3,maxres),PgradX(3,maxres),Pcalc,logPtot
13016 #ifdef MPI
13017       double precision gsaxsc_(3,maxres),gsaxsx_(3,maxres),logPtot_
13018 #endif
13019       double precision dk,dijCASPH,dijSCSPH,
13020      & sigma2CA,sigma2SC,expCASPH,expSCSPH,
13021      & CASPHgrad,SCSPHgrad,aux,auxC,auxC1,
13022      & auxX,auxX1,Cnorm
13023 c  SAXS restraint penalty function
13024 #ifdef DEBUG
13025       write(iout,*) "------- SAXS penalty function start -------"
13026       write (iout,*) "nsaxs",nsaxs
13027
13028       do i=nnt,nct
13029         print *,MyRank,"C",i,(C(j,i),j=1,3)
13030       enddo
13031       do i=nnt,nct
13032         print *,MyRank,"CSaxs",i,(Csaxs(j,i),j=1,3)
13033       enddo
13034 #endif
13035       Esaxs_constr = 0.0d0
13036       logPtot=0.0d0
13037       do j=isaxs_start,isaxs_end
13038         Pcalc=0.0d0
13039         do i=1,nres
13040           do l=1,3
13041             PgradC(l,i)=0.0d0
13042             PgradX(l,i)=0.0d0
13043           enddo
13044         enddo
13045         do i=nnt,nct
13046           if (itype(i).eq.ntyp1) cycle
13047           dijCASPH=0.0d0
13048           dijSCSPH=0.0d0
13049           do l=1,3
13050             dijCASPH=dijCASPH+(C(l,i)-Csaxs(l,j))**2
13051           enddo
13052           if (itype(i).ne.10) then
13053           do l=1,3
13054             dijSCSPH=dijSCSPH+(C(l,i+nres)-Csaxs(l,j))**2
13055           enddo
13056           endif
13057           sigma2CA=2.0d0/pstok**2
13058           sigma2SC=4.0d0/restok(itype(i))**2
13059           expCASPH = dexp(-0.5d0*sigma2CA*dijCASPH)
13060           expSCSPH = dexp(-0.5d0*sigma2SC*dijSCSPH)
13061           Pcalc = Pcalc+expCASPH+expSCSPH
13062 #ifdef DEBUG
13063           write(*,*) "processor i j Pcalc",
13064      &       MyRank,i,j,dijCASPH,dijSCSPH, Pcalc
13065 #endif
13066           CASPHgrad = sigma2CA*expCASPH
13067           SCSPHgrad = sigma2SC*expSCSPH
13068           do l=1,3
13069             aux = (C(l,i+nres)-Csaxs(l,j))*SCSPHgrad
13070             PgradX(l,i) = PgradX(l,i) + aux
13071             PgradC(l,i) = PgradC(l,i)+(C(l,i)-Csaxs(l,j))*CASPHgrad+aux
13072           enddo ! l
13073         enddo ! i
13074         do i=nnt,nct
13075           do l=1,3
13076             gsaxsc(l,i)=gsaxsc(l,i)+PgradC(l,i)/Pcalc
13077             gsaxsx(l,i)=gsaxsx(l,i)+PgradX(l,i)/Pcalc
13078           enddo
13079         enddo
13080         logPtot = logPtot - dlog(Pcalc)
13081 c        print *,"me",me,MyRank," j",j," logPcalc",-dlog(Pcalc),
13082 c     &    " logPtot",logPtot
13083       enddo ! j
13084 #ifdef MPI
13085       if (nfgtasks.gt.1) then
13086 c        write (iout,*) "logPtot before reduction",logPtot
13087         call MPI_Reduce(logPtot,logPtot_,1,MPI_DOUBLE_PRECISION,
13088      &    MPI_SUM,king,FG_COMM,IERR)
13089         logPtot = logPtot_
13090 c        write (iout,*) "logPtot after reduction",logPtot
13091         call MPI_Reduce(gsaxsC(1,1),gsaxsC_(1,1),3*nres,
13092      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
13093         if (fg_rank.eq.king) then
13094           do i=1,nres
13095             do l=1,3
13096               gsaxsC(l,i) = gsaxsC_(l,i)
13097             enddo
13098           enddo
13099         endif
13100         call MPI_Reduce(gsaxsX(1,1),gsaxsX_(1,1),3*nres,
13101      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
13102         if (fg_rank.eq.king) then
13103           do i=1,nres
13104             do l=1,3
13105               gsaxsX(l,i) = gsaxsX_(l,i)
13106             enddo
13107           enddo
13108         endif
13109       endif
13110 #endif
13111       Esaxs_constr = logPtot
13112       return
13113       end
13114 c----------------------------------------------------------------------------
13115       double precision function sscale2(r,r_cut,r0,rlamb)
13116       implicit none
13117       double precision r,gamm,r_cut,r0,rlamb,rr
13118       rr = dabs(r-r0)
13119 c      write (2,*) "r",r," r_cut",r_cut," r0",r0," rlamb",rlamb
13120 c      write (2,*) "rr",rr
13121       if(rr.lt.r_cut-rlamb) then
13122         sscale2=1.0d0
13123       else if(rr.le.r_cut.and.rr.ge.r_cut-rlamb) then
13124         gamm=(rr-(r_cut-rlamb))/rlamb
13125         sscale2=1.0d0+gamm*gamm*(2*gamm-3.0d0)
13126       else
13127         sscale2=0d0
13128       endif
13129       return
13130       end
13131 C-----------------------------------------------------------------------
13132       double precision function sscalgrad2(r,r_cut,r0,rlamb)
13133       implicit none
13134       double precision r,gamm,r_cut,r0,rlamb,rr
13135       rr = dabs(r-r0)
13136       if(rr.lt.r_cut-rlamb) then
13137         sscalgrad2=0.0d0
13138       else if(rr.le.r_cut.and.rr.ge.r_cut-rlamb) then
13139         gamm=(rr-(r_cut-rlamb))/rlamb
13140         if (r.ge.r0) then
13141           sscalgrad2=gamm*(6*gamm-6.0d0)/rlamb
13142         else
13143           sscalgrad2=-gamm*(6*gamm-6.0d0)/rlamb
13144         endif
13145       else
13146         sscalgrad2=0.0d0
13147       endif
13148       return
13149       end
13150 c------------------------------------------------------------------------
13151       double precision function boxshift(x,boxsize)
13152       implicit none
13153       double precision x,boxsize
13154       double precision xtemp
13155       xtemp=dmod(x,boxsize)
13156       if (dabs(xtemp-boxsize).lt.dabs(xtemp)) then
13157         boxshift=xtemp-boxsize
13158       else if (dabs(xtemp+boxsize).lt.dabs(xtemp)) then
13159         boxshift=xtemp+boxsize
13160       else
13161         boxshift=xtemp
13162       endif
13163       return
13164       end
13165 c--------------------------------------------------------------------------
13166       subroutine closest_img(xi,yi,zi,xj,yj,zj)
13167       include 'DIMENSIONS'
13168       include 'COMMON.CHAIN'
13169       integer xshift,yshift,zshift,subchap
13170       double precision dist_init,xj_safe,yj_safe,zj_safe,
13171      & xj_temp,yj_temp,zj_temp,dist_temp
13172       xj_safe=xj
13173       yj_safe=yj
13174       zj_safe=zj
13175       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
13176       subchap=0
13177       do xshift=-1,1
13178         do yshift=-1,1
13179           do zshift=-1,1
13180             xj=xj_safe+xshift*boxxsize
13181             yj=yj_safe+yshift*boxysize
13182             zj=zj_safe+zshift*boxzsize
13183             dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
13184             if(dist_temp.lt.dist_init) then
13185               dist_init=dist_temp
13186               xj_temp=xj
13187               yj_temp=yj
13188               zj_temp=zj
13189               subchap=1
13190             endif
13191           enddo
13192         enddo
13193       enddo
13194       if (subchap.eq.1) then
13195         xj=xj_temp-xi
13196         yj=yj_temp-yi
13197         zj=zj_temp-zi
13198       else
13199         xj=xj_safe-xi
13200         yj=yj_safe-yi
13201         zj=zj_safe-zi
13202       endif
13203       return
13204       end
13205 c--------------------------------------------------------------------------
13206       subroutine to_box(xi,yi,zi)
13207       implicit none
13208       include 'DIMENSIONS'
13209       include 'COMMON.CHAIN'
13210       double precision xi,yi,zi
13211       xi=dmod(xi,boxxsize)
13212       if (xi.lt.0.0d0) xi=xi+boxxsize
13213       yi=dmod(yi,boxysize)
13214       if (yi.lt.0.0d0) yi=yi+boxysize
13215       zi=dmod(zi,boxzsize)
13216       if (zi.lt.0.0d0) zi=zi+boxzsize
13217       return
13218       end
13219 c--------------------------------------------------------------------------
13220       subroutine lipid_layer(xi,yi,zi,sslipi,ssgradlipi)
13221       implicit none
13222       include 'DIMENSIONS'
13223       include 'COMMON.CHAIN'
13224       double precision xi,yi,zi,sslipi,ssgradlipi
13225       double precision fracinbuf
13226       double precision sscalelip,sscagradlip
13227
13228       if ((zi.gt.bordlipbot).and.(zi.lt.bordliptop)) then
13229 C the energy transfer exist
13230         if (zi.lt.buflipbot) then
13231 C what fraction I am in
13232           fracinbuf=1.0d0-((zi-bordlipbot)/lipbufthick)
13233 C lipbufthick is thickenes of lipid buffore
13234           sslipi=sscalelip(fracinbuf)
13235           ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
13236         elseif (zi.gt.bufliptop) then
13237           fracinbuf=1.0d0-((bordliptop-zi)/lipbufthick)
13238           sslipi=sscalelip(fracinbuf)
13239           ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
13240         else
13241           sslipi=1.0d0
13242           ssgradlipi=0.0
13243         endif
13244       else
13245         sslipi=0.0d0
13246         ssgradlipi=0.0
13247       endif
13248       return
13249       end