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 for diagnostics; uncomment
2057 c            rij_shift=1.2*sig0ij
2058 C I hate to put IF's in the loops, but here don't have another choice!!!!
2059               if (rij_shift.le.0.0D0) then
2060                 evdw=1.0D20
2061 cd              write (iout,'(2(a3,i3,2x),17(0pf7.3))')
2062 cd     &        restyp(itypi),i,restyp(itypj),j,
2063 cd     &        rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq)
2064                 return
2065               endif
2066               sigder=-sig*sigsq
2067 c---------------------------------------------------------------
2068               rij_shift=1.0D0/rij_shift
2069               fac=rij_shift**expon
2070 C here to start with
2071 C            if (c(i,3).gt.
2072               faclip=fac
2073               e1=fac*fac*aa
2074               e2=fac*bb
2075               evdwij=eps1*eps2rt*eps3rt*(e1+e2)
2076               eps2der=evdwij*eps3rt
2077               eps3der=evdwij*eps2rt
2078 C       write(63,'(2i3,2e10.3,2f10.5)') i,j,aa,bb, evdwij,
2079 C     &((sslipi+sslipj)/2.0d0+
2080 C     &(2.0d0-sslipi-sslipj)/2.0d0)
2081 c            write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt,
2082 c     &        " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2
2083               evdwij=evdwij*eps2rt*eps3rt
2084               evdw=evdw+evdwij*sss
2085               if (lprn) then
2086                 sigm=dabs(aa/bb)**(1.0D0/6.0D0)
2087                 epsi=bb**2/aa
2088                 write (iout,'(2(a3,i3,2x),17(0pf7.3))')
2089      &           restyp(itypi),i,restyp(itypj),j,
2090      &           epsi,sigm,chi1,chi2,chip1,chip2,
2091      &           eps1,eps2rt**2,eps3rt**2,sig,sig0ij,
2092      &           om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
2093      &           evdwij
2094               endif
2095
2096               if (energy_dec) write (iout,'(a,2i5,3f10.5)')
2097      &                    'r sss evdw',i,j,1.0d0/rij,sss,evdwij
2098
2099 C Calculate gradient components.
2100               e1=e1*eps1*eps2rt**2*eps3rt**2
2101               fac=-expon*(e1+evdwij)*rij_shift
2102               sigder=fac*sigder
2103               fac=rij*fac
2104 c            print '(2i4,6f8.4)',i,j,sss,sssgrad*
2105 c     &      evdwij,fac,sigma(itypi,itypj),expon
2106               fac=fac+evdwij*sssgrad/sss*rij
2107 c            fac=0.0d0
2108 C Calculate the radial part of the gradient
2109               gg_lipi(3)=eps1*(eps2rt*eps2rt)
2110      &          *(eps3rt*eps3rt)*sss/2.0d0*(faclip*faclip*
2111      &           (aa_lip(itypi,itypj)-aa_aq(itypi,itypj))
2112      &          +faclip*(bb_lip(itypi,itypj)-bb_aq(itypi,itypj)))
2113               gg_lipj(3)=ssgradlipj*gg_lipi(3)
2114               gg_lipi(3)=gg_lipi(3)*ssgradlipi
2115 C            gg_lipi(3)=0.0d0
2116 C            gg_lipj(3)=0.0d0
2117               gg(1)=xj*fac
2118               gg(2)=yj*fac
2119               gg(3)=zj*fac
2120 C Calculate angular part of the gradient.
2121 c            call sc_grad_scale(sss)
2122               call sc_grad
2123             ENDIF    ! dyn_ss
2124 c          enddo      ! j
2125 c        enddo        ! iint
2126       enddo          ! i
2127 C      enddo          ! zshift
2128 C      enddo          ! yshift
2129 C      enddo          ! xshift
2130 c      write (iout,*) "Number of loop steps in EGB:",ind
2131 cccc      energy_dec=.false.
2132       return
2133       end
2134 C-----------------------------------------------------------------------------
2135       subroutine egbv(evdw)
2136 C
2137 C This subroutine calculates the interaction energy of nonbonded side chains
2138 C assuming the Gay-Berne-Vorobjev potential of interaction.
2139 C
2140       implicit none
2141       include 'DIMENSIONS'
2142       include 'COMMON.GEO'
2143       include 'COMMON.VAR'
2144       include 'COMMON.LOCAL'
2145       include 'COMMON.CHAIN'
2146       include 'COMMON.DERIV'
2147       include 'COMMON.NAMES'
2148       include 'COMMON.INTERACT'
2149       include 'COMMON.IOUNITS'
2150       include 'COMMON.CALC'
2151       include 'COMMON.SPLITELE'
2152       double precision boxshift
2153       integer icall
2154       common /srutu/ icall
2155       logical lprn
2156       double precision evdw
2157       integer itypi,itypj,itypi1,iint,ind,ikont
2158       double precision eps0ij,epsi,sigm,fac,e1,e2,rrij,r0ij,
2159      & xi,yi,zi,fac_augm,e_augm
2160       double precision fracinbuf,sslipi,evdwij_przed_tri,sig0ij,
2161      & sslipj,ssgradlipj,ssgradlipi,sig,rij_shift,faclip,sssgrad1
2162       double precision dist,sscale,sscagrad,sscagradlip,sscalelip
2163       evdw=0.0D0
2164 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
2165       evdw=0.0D0
2166       lprn=.false.
2167 c     if (icall.eq.0) lprn=.true.
2168       ind=0
2169 c      do i=iatsc_s,iatsc_e
2170       do ikont=g_listscsc_start,g_listscsc_end
2171         i=newcontlisti(ikont)
2172         j=newcontlistj(ikont)
2173         itypi=iabs(itype(i))
2174         if (itypi.eq.ntyp1) cycle
2175         itypi1=iabs(itype(i+1))
2176         xi=c(1,nres+i)
2177         yi=c(2,nres+i)
2178         zi=c(3,nres+i)
2179         call to_box(xi,yi,zi)
2180 C define scaling factor for lipids
2181
2182 C        if (positi.le.0) positi=positi+boxzsize
2183 C        print *,i
2184 C first for peptide groups
2185 c for each residue check if it is in lipid or lipid water border area
2186         call lipid_layer(xi,yi,zi,sslipi,ssgradlipi)
2187         dxi=dc_norm(1,nres+i)
2188         dyi=dc_norm(2,nres+i)
2189         dzi=dc_norm(3,nres+i)
2190 c        dsci_inv=dsc_inv(itypi)
2191         dsci_inv=vbld_inv(i+nres)
2192 C
2193 C Calculate SC interaction energy.
2194 C
2195 c        do iint=1,nint_gr(i)
2196 c          do j=istart(i,iint),iend(i,iint)
2197             ind=ind+1
2198             itypj=iabs(itype(j))
2199             if (itypj.eq.ntyp1) cycle
2200 c            dscj_inv=dsc_inv(itypj)
2201             dscj_inv=vbld_inv(j+nres)
2202             sig0ij=sigma(itypi,itypj)
2203             r0ij=r0(itypi,itypj)
2204             chi1=chi(itypi,itypj)
2205             chi2=chi(itypj,itypi)
2206             chi12=chi1*chi2
2207             chip1=chip(itypi)
2208             chip2=chip(itypj)
2209             chip12=chip1*chip2
2210             alf1=alp(itypi)
2211             alf2=alp(itypj)
2212             alf12=0.5D0*(alf1+alf2)
2213 C For diagnostics only!!!
2214 c           chi1=0.0D0
2215 c           chi2=0.0D0
2216 c           chi12=0.0D0
2217 c           chip1=0.0D0
2218 c           chip2=0.0D0
2219 c           chip12=0.0D0
2220 c           alf1=0.0D0
2221 c           alf2=0.0D0
2222 c           alf12=0.0D0
2223            xj=c(1,nres+j)
2224            yj=c(2,nres+j)
2225            zj=c(3,nres+j)
2226            call to_box(xj,yj,zj)
2227            call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
2228            aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
2229      &       +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
2230            bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
2231      &       +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
2232 C      if (aa.ne.aa_aq(itypi,itypj)) write(63,'2e10.5')
2233 C     &(aa-aa_aq(itypi,itypj)),(bb-bb_aq(itypi,itypj))
2234 C      write(iout,*) "tu,", i,j,aa,bb,aa_lip(itypi,itypj),sslipi,sslipj
2235            xj=boxshift(xj-xi,boxxsize)
2236            yj=boxshift(yj-yi,boxysize)
2237            zj=boxshift(zj-zi,boxzsize)
2238            dxj=dc_norm(1,nres+j)
2239            dyj=dc_norm(2,nres+j)
2240            dzj=dc_norm(3,nres+j)
2241            rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
2242            rij=dsqrt(rrij)
2243            sss=sscale(1.0d0/rij,r_cut_int)
2244            if (sss.eq.0.0d0) cycle
2245            sssgrad=sscagrad(1.0d0/rij,r_cut_int)
2246 C Calculate angle-dependent terms of energy and contributions to their
2247 C derivatives.
2248            call sc_angular
2249            sigsq=1.0D0/sigsq
2250            sig=sig0ij*dsqrt(sigsq)
2251            rij_shift=1.0D0/rij-sig+r0ij
2252 C I hate to put IF's in the loops, but here don't have another choice!!!!
2253            if (rij_shift.le.0.0D0) then
2254              evdw=1.0D20
2255              return
2256            endif
2257            sigder=-sig*sigsq
2258 c---------------------------------------------------------------
2259            rij_shift=1.0D0/rij_shift
2260            fac=rij_shift**expon
2261            e1=fac*fac*aa
2262            e2=fac*bb
2263            evdwij=eps1*eps2rt*eps3rt*(e1+e2)
2264            eps2der=evdwij*eps3rt
2265            eps3der=evdwij*eps2rt
2266            fac_augm=rrij**expon
2267            e_augm=augm(itypi,itypj)*fac_augm
2268            evdwij=evdwij*eps2rt*eps3rt
2269            evdw=evdw+evdwij+e_augm
2270            if (lprn) then
2271              sigm=dabs(aa/bb)**(1.0D0/6.0D0)
2272              epsi=bb**2/aa
2273              write (iout,'(2(a3,i3,2x),17(0pf7.3))')
2274      &        restyp(itypi),i,restyp(itypj),j,
2275      &        epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),
2276      &        chi1,chi2,chip1,chip2,
2277      &        eps1,eps2rt**2,eps3rt**2,
2278      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
2279      &        evdwij+e_augm
2280            endif
2281 C Calculate gradient components.
2282            e1=e1*eps1*eps2rt**2*eps3rt**2
2283            fac=-expon*(e1+evdwij)*rij_shift
2284            sigder=fac*sigder
2285            fac=rij*fac-2*expon*rrij*e_augm
2286            fac=fac+(evdwij+e_augm)*sssgrad/sss*rij
2287 C Calculate the radial part of the gradient
2288            gg(1)=xj*fac
2289            gg(2)=yj*fac
2290            gg(3)=zj*fac
2291 C Calculate angular part of the gradient.
2292 c            call sc_grad_scale(sss)
2293            call sc_grad
2294 c          enddo      ! j
2295 c        enddo        ! iint
2296       enddo          ! i
2297       end
2298 C-----------------------------------------------------------------------------
2299       subroutine sc_angular
2300 C Calculate eps1,eps2,eps3,sigma, and parts of their derivatives in om1,om2,
2301 C om12. Called by ebp, egb, and egbv.
2302       implicit none
2303       include 'COMMON.CALC'
2304       include 'COMMON.IOUNITS'
2305       erij(1)=xj*rij
2306       erij(2)=yj*rij
2307       erij(3)=zj*rij
2308       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
2309       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
2310       om12=dxi*dxj+dyi*dyj+dzi*dzj
2311       chiom12=chi12*om12
2312 C Calculate eps1(om12) and its derivative in om12
2313       faceps1=1.0D0-om12*chiom12
2314       faceps1_inv=1.0D0/faceps1
2315       eps1=dsqrt(faceps1_inv)
2316 C Following variable is eps1*deps1/dom12
2317       eps1_om12=faceps1_inv*chiom12
2318 c diagnostics only
2319 c      faceps1_inv=om12
2320 c      eps1=om12
2321 c      eps1_om12=1.0d0
2322 c      write (iout,*) "om12",om12," eps1",eps1
2323 C Calculate sigma(om1,om2,om12) and the derivatives of sigma**2 in om1,om2,
2324 C and om12.
2325       om1om2=om1*om2
2326       chiom1=chi1*om1
2327       chiom2=chi2*om2
2328       facsig=om1*chiom1+om2*chiom2-2.0D0*om1om2*chiom12
2329       sigsq=1.0D0-facsig*faceps1_inv
2330       sigsq_om1=(chiom1-chiom12*om2)*faceps1_inv
2331       sigsq_om2=(chiom2-chiom12*om1)*faceps1_inv
2332       sigsq_om12=-chi12*(om1om2*faceps1-om12*facsig)*faceps1_inv**2
2333 c diagnostics only
2334 c      sigsq=1.0d0
2335 c      sigsq_om1=0.0d0
2336 c      sigsq_om2=0.0d0
2337 c      sigsq_om12=0.0d0
2338 c      write (iout,*) "chiom1",chiom1," chiom2",chiom2," chiom12",chiom12
2339 c      write (iout,*) "faceps1",faceps1," faceps1_inv",faceps1_inv,
2340 c     &    " eps1",eps1
2341 C Calculate eps2 and its derivatives in om1, om2, and om12.
2342       chipom1=chip1*om1
2343       chipom2=chip2*om2
2344       chipom12=chip12*om12
2345       facp=1.0D0-om12*chipom12
2346       facp_inv=1.0D0/facp
2347       facp1=om1*chipom1+om2*chipom2-2.0D0*om1om2*chipom12
2348 c      write (iout,*) "chipom1",chipom1," chipom2",chipom2,
2349 c     &  " chipom12",chipom12," facp",facp," facp_inv",facp_inv
2350 C Following variable is the square root of eps2
2351       eps2rt=1.0D0-facp1*facp_inv
2352 C Following three variables are the derivatives of the square root of eps
2353 C in om1, om2, and om12.
2354       eps2rt_om1=-4.0D0*(chipom1-chipom12*om2)*facp_inv
2355       eps2rt_om2=-4.0D0*(chipom2-chipom12*om1)*facp_inv
2356       eps2rt_om12=4.0D0*chip12*(om1om2*facp-om12*facp1)*facp_inv**2
2357 C Evaluate the "asymmetric" factor in the VDW constant, eps3
2358       eps3rt=1.0D0-alf1*om1+alf2*om2-alf12*om12
2359 c      write (iout,*) "eps2rt",eps2rt," eps3rt",eps3rt
2360 c      write (iout,*) "eps2rt_om1",eps2rt_om1," eps2rt_om2",eps2rt_om2,
2361 c     &  " eps2rt_om12",eps2rt_om12
2362 C Calculate whole angle-dependent part of epsilon and contributions
2363 C to its derivatives
2364       return
2365       end
2366 C----------------------------------------------------------------------------
2367       subroutine sc_grad
2368       implicit real*8 (a-h,o-z)
2369       include 'DIMENSIONS'
2370       include 'COMMON.CHAIN'
2371       include 'COMMON.DERIV'
2372       include 'COMMON.CALC'
2373       include 'COMMON.IOUNITS'
2374       double precision dcosom1(3),dcosom2(3)
2375 cc      print *,'sss=',sss
2376       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
2377       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
2378       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12
2379      &     -2.0D0*alf12*eps3der+sigder*sigsq_om12
2380 c diagnostics only
2381 c      eom1=0.0d0
2382 c      eom2=0.0d0
2383 c      eom12=evdwij*eps1_om12
2384 c end diagnostics
2385 c      write (iout,*) "eps2der",eps2der," eps3der",eps3der,
2386 c     &  " sigder",sigder
2387 c      write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12
2388 c      write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12
2389       do k=1,3
2390         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
2391         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
2392       enddo
2393       do k=1,3
2394         gg(k)=(gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k))*sss
2395       enddo
2396 c      write (iout,*) "gg",(gg(k),k=1,3)
2397       do k=1,3
2398         gvdwx(k,i)=gvdwx(k,i)-gg(k)+gg_lipi(k)
2399      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
2400      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv*sss
2401         gvdwx(k,j)=gvdwx(k,j)+gg(k)+gg_lipj(k)
2402      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
2403      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv*sss
2404 c        write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
2405 c     &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
2406 c        write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
2407 c     &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
2408       enddo
2409 C
2410 C Calculate the components of the gradient in DC and X
2411 C
2412 cgrad      do k=i,j-1
2413 cgrad        do l=1,3
2414 cgrad          gvdwc(l,k)=gvdwc(l,k)+gg(l)
2415 cgrad        enddo
2416 cgrad      enddo
2417       do l=1,3
2418         gvdwc(l,i)=gvdwc(l,i)-gg(l)+gg_lipi(l)
2419         gvdwc(l,j)=gvdwc(l,j)+gg(l)+gg_lipj(l)
2420       enddo
2421       return
2422       end
2423 C-----------------------------------------------------------------------
2424       subroutine e_softsphere(evdw)
2425 C
2426 C This subroutine calculates the interaction energy of nonbonded side chains
2427 C assuming the LJ potential of interaction.
2428 C
2429       implicit real*8 (a-h,o-z)
2430       include 'DIMENSIONS'
2431       parameter (accur=1.0d-10)
2432       include 'COMMON.GEO'
2433       include 'COMMON.VAR'
2434       include 'COMMON.LOCAL'
2435       include 'COMMON.CHAIN'
2436       include 'COMMON.DERIV'
2437       include 'COMMON.INTERACT'
2438       include 'COMMON.TORSION'
2439       include 'COMMON.SBRIDGE'
2440       include 'COMMON.NAMES'
2441       include 'COMMON.IOUNITS'
2442 c      include 'COMMON.CONTACTS'
2443       dimension gg(3)
2444       double precision boxshift
2445 cd    print *,'Entering Esoft_sphere nnt=',nnt,' nct=',nct
2446       evdw=0.0D0
2447 c      do i=iatsc_s,iatsc_e
2448       do ikont=g_listscsc_start,g_listscsc_end
2449         i=newcontlisti(ikont)
2450         j=newcontlistj(ikont)
2451         itypi=iabs(itype(i))
2452         if (itypi.eq.ntyp1) cycle
2453         itypi1=iabs(itype(i+1))
2454         xi=c(1,nres+i)
2455         yi=c(2,nres+i)
2456         zi=c(3,nres+i)
2457         call to_box(xi,yi,zi)
2458 C
2459 C Calculate SC interaction energy.
2460 C
2461 c        do iint=1,nint_gr(i)
2462 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
2463 cd   &                  'iend=',iend(i,iint)
2464 c          do j=istart(i,iint),iend(i,iint)
2465             itypj=iabs(itype(j))
2466             if (itypj.eq.ntyp1) cycle
2467             xj=boxshift(c(1,nres+j)-xi,boxxsize)
2468             yj=boxshift(c(2,nres+j)-yi,boxysize)
2469             zj=boxshift(c(3,nres+j)-zi,boxzsize)
2470             rij=xj*xj+yj*yj+zj*zj
2471 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
2472             r0ij=r0(itypi,itypj)
2473             r0ijsq=r0ij*r0ij
2474 c            print *,i,j,r0ij,dsqrt(rij)
2475             if (rij.lt.r0ijsq) then
2476               evdwij=0.25d0*(rij-r0ijsq)**2
2477               fac=rij-r0ijsq
2478             else
2479               evdwij=0.0d0
2480               fac=0.0d0
2481             endif
2482             evdw=evdw+evdwij
2483 C
2484 C Calculate the components of the gradient in DC and X
2485 C
2486             gg(1)=xj*fac
2487             gg(2)=yj*fac
2488             gg(3)=zj*fac
2489             do k=1,3
2490               gvdwx(k,i)=gvdwx(k,i)-gg(k)
2491               gvdwx(k,j)=gvdwx(k,j)+gg(k)
2492               gvdwc(k,i)=gvdwc(k,i)-gg(k)
2493               gvdwc(k,j)=gvdwc(k,j)+gg(k)
2494             enddo
2495 cgrad            do k=i,j-1
2496 cgrad              do l=1,3
2497 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
2498 cgrad              enddo
2499 cgrad            enddo
2500 c          enddo ! j
2501 c        enddo ! iint
2502       enddo ! i
2503       return
2504       end
2505 C--------------------------------------------------------------------------
2506       subroutine eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,
2507      &              eello_turn4)
2508 C
2509 C Soft-sphere potential of p-p interaction
2510 C
2511       implicit real*8 (a-h,o-z)
2512       include 'DIMENSIONS'
2513       include 'COMMON.CONTROL'
2514       include 'COMMON.IOUNITS'
2515       include 'COMMON.GEO'
2516       include 'COMMON.VAR'
2517       include 'COMMON.LOCAL'
2518       include 'COMMON.CHAIN'
2519       include 'COMMON.DERIV'
2520       include 'COMMON.INTERACT'
2521 c      include 'COMMON.CONTACTS'
2522       include 'COMMON.TORSION'
2523       include 'COMMON.VECTORS'
2524       include 'COMMON.FFIELD'
2525       dimension ggg(3)
2526       double precision boxshift
2527 C      write(iout,*) 'In EELEC_soft_sphere'
2528       ees=0.0D0
2529       evdw1=0.0D0
2530       eel_loc=0.0d0
2531       eello_turn3=0.0d0
2532       eello_turn4=0.0d0
2533       ind=0
2534       do i=iatel_s,iatel_e
2535         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
2536         dxi=dc(1,i)
2537         dyi=dc(2,i)
2538         dzi=dc(3,i)
2539         xmedi=c(1,i)+0.5d0*dxi
2540         ymedi=c(2,i)+0.5d0*dyi
2541         zmedi=c(3,i)+0.5d0*dzi
2542         call to_box(xmedi,ymedi,zmedi)
2543         num_conti=0
2544 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
2545         do j=ielstart(i),ielend(i)
2546           if (itype(j).eq.ntyp1 .or. itype(j+1).eq.ntyp1) cycle
2547           ind=ind+1
2548           iteli=itel(i)
2549           itelj=itel(j)
2550           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
2551           r0ij=rpp(iteli,itelj)
2552           r0ijsq=r0ij*r0ij
2553           dxj=dc(1,j)
2554           dyj=dc(2,j)
2555           dzj=dc(3,j)
2556           xj=c(1,j)+0.5D0*dxj
2557           yj=c(2,j)+0.5D0*dyj
2558           zj=c(3,j)+0.5D0*dzj
2559           call to_box(xj,yj,zj)
2560           xj=boxshift(xj-xmedi,boxxsize)
2561           yj=boxshift(yj-ymedi,boxysize)
2562           zj=boxshift(zj-zmedi,boxzsize)
2563           rij=xj*xj+yj*yj+zj*zj
2564             sss=sscale(sqrt(rij),r_cut_int)
2565             sssgrad=sscagrad(sqrt(rij),r_cut_int)
2566           if (rij.lt.r0ijsq) then
2567             evdw1ij=0.25d0*(rij-r0ijsq)**2
2568             fac=rij-r0ijsq
2569           else
2570             evdw1ij=0.0d0
2571             fac=0.0d0
2572           endif
2573           evdw1=evdw1+evdw1ij*sss
2574 C
2575 C Calculate contributions to the Cartesian gradient.
2576 C
2577           ggg(1)=fac*xj*sssgrad
2578           ggg(2)=fac*yj*sssgrad
2579           ggg(3)=fac*zj*sssgrad
2580           do k=1,3
2581             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
2582             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
2583           enddo
2584 *
2585 * Loop over residues i+1 thru j-1.
2586 *
2587 cgrad          do k=i+1,j-1
2588 cgrad            do l=1,3
2589 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
2590 cgrad            enddo
2591 cgrad          enddo
2592         enddo ! j
2593       enddo   ! i
2594 cgrad      do i=nnt,nct-1
2595 cgrad        do k=1,3
2596 cgrad          gelc(k,i)=gelc(k,i)+0.5d0*gelc(k,i)
2597 cgrad        enddo
2598 cgrad        do j=i+1,nct-1
2599 cgrad          do k=1,3
2600 cgrad            gelc(k,i)=gelc(k,i)+gelc(k,j)
2601 cgrad          enddo
2602 cgrad        enddo
2603 cgrad      enddo
2604       return
2605       end
2606 c------------------------------------------------------------------------------
2607       subroutine vec_and_deriv
2608       implicit real*8 (a-h,o-z)
2609       include 'DIMENSIONS'
2610 #ifdef MPI
2611       include 'mpif.h'
2612 #endif
2613       include 'COMMON.IOUNITS'
2614       include 'COMMON.GEO'
2615       include 'COMMON.VAR'
2616       include 'COMMON.LOCAL'
2617       include 'COMMON.CHAIN'
2618       include 'COMMON.VECTORS'
2619       include 'COMMON.SETUP'
2620       include 'COMMON.TIME1'
2621       dimension uyder(3,3,2),uzder(3,3,2),vbld_inv_temp(2)
2622 C Compute the local reference systems. For reference system (i), the
2623 C X-axis points from CA(i) to CA(i+1), the Y axis is in the
2624 C CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
2625 #ifdef PARVEC
2626       do i=ivec_start,ivec_end
2627 #else
2628       do i=1,nres-1
2629 #endif
2630           if (i.eq.nres-1) then
2631 C Case of the last full residue
2632 C Compute the Z-axis
2633             call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
2634             costh=dcos(pi-theta(nres))
2635             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2636             do k=1,3
2637               uz(k,i)=fac*uz(k,i)
2638             enddo
2639 C Compute the derivatives of uz
2640             uzder(1,1,1)= 0.0d0
2641             uzder(2,1,1)=-dc_norm(3,i-1)
2642             uzder(3,1,1)= dc_norm(2,i-1)
2643             uzder(1,2,1)= dc_norm(3,i-1)
2644             uzder(2,2,1)= 0.0d0
2645             uzder(3,2,1)=-dc_norm(1,i-1)
2646             uzder(1,3,1)=-dc_norm(2,i-1)
2647             uzder(2,3,1)= dc_norm(1,i-1)
2648             uzder(3,3,1)= 0.0d0
2649             uzder(1,1,2)= 0.0d0
2650             uzder(2,1,2)= dc_norm(3,i)
2651             uzder(3,1,2)=-dc_norm(2,i)
2652             uzder(1,2,2)=-dc_norm(3,i)
2653             uzder(2,2,2)= 0.0d0
2654             uzder(3,2,2)= dc_norm(1,i)
2655             uzder(1,3,2)= dc_norm(2,i)
2656             uzder(2,3,2)=-dc_norm(1,i)
2657             uzder(3,3,2)= 0.0d0
2658 C Compute the Y-axis
2659             facy=fac
2660             do k=1,3
2661               uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
2662             enddo
2663 C Compute the derivatives of uy
2664             do j=1,3
2665               do k=1,3
2666                 uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i)
2667      &                        -dc_norm(k,i)*dc_norm(j,i-1)
2668                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2669               enddo
2670               uyder(j,j,1)=uyder(j,j,1)-costh
2671               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2672             enddo
2673             do j=1,2
2674               do k=1,3
2675                 do l=1,3
2676                   uygrad(l,k,j,i)=uyder(l,k,j)
2677                   uzgrad(l,k,j,i)=uzder(l,k,j)
2678                 enddo
2679               enddo
2680             enddo
2681             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2682             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2683             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2684             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2685           else
2686 C Other residues
2687 C Compute the Z-axis
2688             call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
2689             costh=dcos(pi-theta(i+2))
2690             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2691             do k=1,3
2692               uz(k,i)=fac*uz(k,i)
2693             enddo
2694 C Compute the derivatives of uz
2695             uzder(1,1,1)= 0.0d0
2696             uzder(2,1,1)=-dc_norm(3,i+1)
2697             uzder(3,1,1)= dc_norm(2,i+1)
2698             uzder(1,2,1)= dc_norm(3,i+1)
2699             uzder(2,2,1)= 0.0d0
2700             uzder(3,2,1)=-dc_norm(1,i+1)
2701             uzder(1,3,1)=-dc_norm(2,i+1)
2702             uzder(2,3,1)= dc_norm(1,i+1)
2703             uzder(3,3,1)= 0.0d0
2704             uzder(1,1,2)= 0.0d0
2705             uzder(2,1,2)= dc_norm(3,i)
2706             uzder(3,1,2)=-dc_norm(2,i)
2707             uzder(1,2,2)=-dc_norm(3,i)
2708             uzder(2,2,2)= 0.0d0
2709             uzder(3,2,2)= dc_norm(1,i)
2710             uzder(1,3,2)= dc_norm(2,i)
2711             uzder(2,3,2)=-dc_norm(1,i)
2712             uzder(3,3,2)= 0.0d0
2713 C Compute the Y-axis
2714             facy=fac
2715             do k=1,3
2716               uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
2717             enddo
2718 C Compute the derivatives of uy
2719             do j=1,3
2720               do k=1,3
2721                 uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i)
2722      &                        -dc_norm(k,i)*dc_norm(j,i+1)
2723                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2724               enddo
2725               uyder(j,j,1)=uyder(j,j,1)-costh
2726               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2727             enddo
2728             do j=1,2
2729               do k=1,3
2730                 do l=1,3
2731                   uygrad(l,k,j,i)=uyder(l,k,j)
2732                   uzgrad(l,k,j,i)=uzder(l,k,j)
2733                 enddo
2734               enddo
2735             enddo
2736             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2737             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2738             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2739             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2740           endif
2741       enddo
2742       do i=1,nres-1
2743         vbld_inv_temp(1)=vbld_inv(i+1)
2744         if (i.lt.nres-1) then
2745           vbld_inv_temp(2)=vbld_inv(i+2)
2746           else
2747           vbld_inv_temp(2)=vbld_inv(i)
2748           endif
2749         do j=1,2
2750           do k=1,3
2751             do l=1,3
2752               uygrad(l,k,j,i)=vbld_inv_temp(j)*uygrad(l,k,j,i)
2753               uzgrad(l,k,j,i)=vbld_inv_temp(j)*uzgrad(l,k,j,i)
2754             enddo
2755           enddo
2756         enddo
2757       enddo
2758 #if defined(PARVEC) && defined(MPI)
2759       if (nfgtasks1.gt.1) then
2760         time00=MPI_Wtime()
2761 c        print *,"Processor",fg_rank1,kolor1," ivec_start",ivec_start,
2762 c     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks1-1),
2763 c     &   " ivec_count",(ivec_count(i),i=0,nfgtasks1-1)
2764         call MPI_Allgatherv(uy(1,ivec_start),ivec_count(fg_rank1),
2765      &   MPI_UYZ,uy(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
2766      &   FG_COMM1,IERR)
2767         call MPI_Allgatherv(uz(1,ivec_start),ivec_count(fg_rank1),
2768      &   MPI_UYZ,uz(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
2769      &   FG_COMM1,IERR)
2770         call MPI_Allgatherv(uygrad(1,1,1,ivec_start),
2771      &   ivec_count(fg_rank1),MPI_UYZGRAD,uygrad(1,1,1,1),ivec_count(0),
2772      &   ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2773         call MPI_Allgatherv(uzgrad(1,1,1,ivec_start),
2774      &   ivec_count(fg_rank1),MPI_UYZGRAD,uzgrad(1,1,1,1),ivec_count(0),
2775      &   ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2776         time_gather=time_gather+MPI_Wtime()-time00
2777       endif
2778 #endif
2779 #ifdef DEBUG
2780       if (fg_rank.eq.0) then
2781         write (iout,*) "Arrays UY and UZ"
2782         do i=1,nres-1
2783           write (iout,'(i5,3f10.5,5x,3f10.5)') i,(uy(k,i),k=1,3),
2784      &     (uz(k,i),k=1,3)
2785         enddo
2786       endif
2787 #endif
2788       return
2789       end
2790 C--------------------------------------------------------------------------
2791       subroutine set_matrices
2792       implicit real*8 (a-h,o-z)
2793       include 'DIMENSIONS'
2794 #ifdef MPI
2795       include "mpif.h"
2796       include "COMMON.SETUP"
2797       integer IERR
2798       integer status(MPI_STATUS_SIZE)
2799 #endif
2800       include 'COMMON.IOUNITS'
2801       include 'COMMON.GEO'
2802       include 'COMMON.VAR'
2803       include 'COMMON.LOCAL'
2804       include 'COMMON.CHAIN'
2805       include 'COMMON.DERIV'
2806       include 'COMMON.INTERACT'
2807       include 'COMMON.CORRMAT'
2808       include 'COMMON.TORSION'
2809       include 'COMMON.VECTORS'
2810       include 'COMMON.FFIELD'
2811       double precision auxvec(2),auxmat(2,2)
2812 C
2813 C Compute the virtual-bond-torsional-angle dependent quantities needed
2814 C to calculate the el-loc multibody terms of various order.
2815 C
2816 c      write(iout,*) 'nphi=',nphi,nres
2817 c      write(iout,*) "itype2loc",itype2loc
2818 #ifdef PARMAT
2819       do i=ivec_start+2,ivec_end+2
2820 #else
2821       do i=3,nres+1
2822 #endif
2823         ii=ireschain(i-2)
2824 c        write (iout,*) "i",i,i-2," ii",ii
2825         if (ii.eq.0) cycle
2826         innt=chain_border(1,ii)
2827         inct=chain_border(2,ii)
2828 c        write (iout,*) "i",i,i-2," ii",ii," innt",innt," inct",inct
2829 c        if (i.gt. nnt+2 .and. i.lt.nct+2) then
2830         if (i.gt. innt+2 .and. i.lt.inct+2) then
2831           iti = itype2loc(itype(i-2))
2832         else
2833           iti=nloctyp
2834         endif
2835 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2836         if (i.gt. innt+1 .and. i.lt.inct+1) then
2837           iti1 = itype2loc(itype(i-1))
2838         else
2839           iti1=nloctyp
2840         endif
2841 c        write(iout,*),"i",i,i-2," iti",itype(i-2),iti,
2842 c     &  " iti1",itype(i-1),iti1
2843 #ifdef NEWCORR
2844         cost1=dcos(theta(i-1))
2845         sint1=dsin(theta(i-1))
2846         sint1sq=sint1*sint1
2847         sint1cub=sint1sq*sint1
2848         sint1cost1=2*sint1*cost1
2849 c        write (iout,*) "bnew1",i,iti
2850 c        write (iout,*) (bnew1(k,1,iti),k=1,3)
2851 c        write (iout,*) (bnew1(k,2,iti),k=1,3)
2852 c        write (iout,*) "bnew2",i,iti
2853 c        write (iout,*) (bnew2(k,1,iti),k=1,3)
2854 c        write (iout,*) (bnew2(k,2,iti),k=1,3)
2855         do k=1,2
2856           b1k=bnew1(1,k,iti)+(bnew1(2,k,iti)+bnew1(3,k,iti)*cost1)*cost1
2857           b1(k,i-2)=sint1*b1k
2858           gtb1(k,i-2)=cost1*b1k-sint1sq*
2859      &              (bnew1(2,k,iti)+2*bnew1(3,k,iti)*cost1)
2860           b2k=bnew2(1,k,iti)+(bnew2(2,k,iti)+bnew2(3,k,iti)*cost1)*cost1
2861           b2(k,i-2)=sint1*b2k
2862           gtb2(k,i-2)=cost1*b2k-sint1sq*
2863      &              (bnew2(2,k,iti)+2*bnew2(3,k,iti)*cost1)
2864         enddo
2865         do k=1,2
2866           aux=ccnew(1,k,iti)+(ccnew(2,k,iti)+ccnew(3,k,iti)*cost1)*cost1
2867           cc(1,k,i-2)=sint1sq*aux
2868           gtcc(1,k,i-2)=sint1cost1*aux-sint1cub*
2869      &              (ccnew(2,k,iti)+2*ccnew(3,k,iti)*cost1)
2870           aux=ddnew(1,k,iti)+(ddnew(2,k,iti)+ddnew(3,k,iti)*cost1)*cost1
2871           dd(1,k,i-2)=sint1sq*aux
2872           gtdd(1,k,i-2)=sint1cost1*aux-sint1cub*
2873      &              (ddnew(2,k,iti)+2*ddnew(3,k,iti)*cost1)
2874         enddo
2875         cc(2,1,i-2)=cc(1,2,i-2)
2876         cc(2,2,i-2)=-cc(1,1,i-2)
2877         gtcc(2,1,i-2)=gtcc(1,2,i-2)
2878         gtcc(2,2,i-2)=-gtcc(1,1,i-2)
2879         dd(2,1,i-2)=dd(1,2,i-2)
2880         dd(2,2,i-2)=-dd(1,1,i-2)
2881         gtdd(2,1,i-2)=gtdd(1,2,i-2)
2882         gtdd(2,2,i-2)=-gtdd(1,1,i-2)
2883         do k=1,2
2884           do l=1,2
2885             aux=eenew(1,l,k,iti)+eenew(2,l,k,iti)*cost1
2886             EE(l,k,i-2)=sint1sq*aux
2887             gtEE(l,k,i-2)=sint1cost1*aux-sint1cub*eenew(2,l,k,iti)
2888           enddo
2889         enddo
2890         EE(1,1,i-2)=EE(1,1,i-2)+e0new(1,iti)*cost1
2891         EE(1,2,i-2)=EE(1,2,i-2)+e0new(2,iti)+e0new(3,iti)*cost1
2892         EE(2,1,i-2)=EE(2,1,i-2)+e0new(2,iti)*cost1+e0new(3,iti)
2893         EE(2,2,i-2)=EE(2,2,i-2)-e0new(1,iti)
2894         gtEE(1,1,i-2)=gtEE(1,1,i-2)-e0new(1,iti)*sint1
2895         gtEE(1,2,i-2)=gtEE(1,2,i-2)-e0new(3,iti)*sint1
2896         gtEE(2,1,i-2)=gtEE(2,1,i-2)-e0new(2,iti)*sint1
2897 c        b1tilde(1,i-2)=b1(1,i-2)
2898 c        b1tilde(2,i-2)=-b1(2,i-2)
2899 c        b2tilde(1,i-2)=b2(1,i-2)
2900 c        b2tilde(2,i-2)=-b2(2,i-2)
2901 #ifdef DEBUG
2902         write (iout,*) 'i=',i-2,gtb1(2,i-2),gtb1(1,i-2)
2903         write(iout,*)  'b1=',(b1(k,i-2),k=1,2)
2904         write(iout,*)  'b2=',(b2(k,i-2),k=1,2)
2905         write (iout,*) 'theta=', theta(i-1)
2906 #endif
2907 #else
2908         if (i.gt. innt+2 .and. i.lt.inct+2) then
2909 c        if (i.gt. nnt+2 .and. i.lt.nct+2) then
2910           iti = itype2loc(itype(i-2))
2911         else
2912           iti=nloctyp
2913         endif
2914 c        write (iout,*) "i",i-1," itype",itype(i-2)," iti",iti
2915 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2916         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2917           iti1 = itype2loc(itype(i-1))
2918         else
2919           iti1=nloctyp
2920         endif
2921         b1(1,i-2)=b(3,iti)
2922         b1(2,i-2)=b(5,iti)
2923         b2(1,i-2)=b(2,iti)
2924         b2(2,i-2)=b(4,iti)
2925         do k=1,2
2926           do l=1,2
2927            CC(k,l,i-2)=ccold(k,l,iti)
2928            DD(k,l,i-2)=ddold(k,l,iti)
2929            EE(k,l,i-2)=eeold(k,l,iti)
2930            gtEE(k,l,i-2)=0.0d0
2931           enddo
2932         enddo
2933 #endif
2934         b1tilde(1,i-2)= b1(1,i-2)
2935         b1tilde(2,i-2)=-b1(2,i-2)
2936         b2tilde(1,i-2)= b2(1,i-2)
2937         b2tilde(2,i-2)=-b2(2,i-2)
2938 c
2939         Ctilde(1,1,i-2)= CC(1,1,i-2)
2940         Ctilde(1,2,i-2)= CC(1,2,i-2)
2941         Ctilde(2,1,i-2)=-CC(2,1,i-2)
2942         Ctilde(2,2,i-2)=-CC(2,2,i-2)
2943 c
2944         Dtilde(1,1,i-2)= DD(1,1,i-2)
2945         Dtilde(1,2,i-2)= DD(1,2,i-2)
2946         Dtilde(2,1,i-2)=-DD(2,1,i-2)
2947         Dtilde(2,2,i-2)=-DD(2,2,i-2)
2948 #ifdef DEBUG
2949         write(iout,*) "i",i," iti",iti
2950         write(iout,*)  'b1=',(b1(k,i-2),k=1,2)
2951         write(iout,*)  'b2=',(b2(k,i-2),k=1,2)
2952 #endif
2953       enddo
2954       mu=0.0d0
2955 #ifdef PARMAT
2956       do i=ivec_start+2,ivec_end+2
2957 #else
2958       do i=3,nres+1
2959 #endif
2960 c        if (itype(i-1).eq.ntyp1 .and. itype(i).eq.ntyp1) cycle
2961         if (i .lt. nres+1 .and. itype(i-1).lt.ntyp1) then
2962           sin1=dsin(phi(i))
2963           cos1=dcos(phi(i))
2964           sintab(i-2)=sin1
2965           costab(i-2)=cos1
2966           obrot(1,i-2)=cos1
2967           obrot(2,i-2)=sin1
2968           sin2=dsin(2*phi(i))
2969           cos2=dcos(2*phi(i))
2970           sintab2(i-2)=sin2
2971           costab2(i-2)=cos2
2972           obrot2(1,i-2)=cos2
2973           obrot2(2,i-2)=sin2
2974           Ug(1,1,i-2)=-cos1
2975           Ug(1,2,i-2)=-sin1
2976           Ug(2,1,i-2)=-sin1
2977           Ug(2,2,i-2)= cos1
2978           Ug2(1,1,i-2)=-cos2
2979           Ug2(1,2,i-2)=-sin2
2980           Ug2(2,1,i-2)=-sin2
2981           Ug2(2,2,i-2)= cos2
2982         else
2983           costab(i-2)=1.0d0
2984           sintab(i-2)=0.0d0
2985           obrot(1,i-2)=1.0d0
2986           obrot(2,i-2)=0.0d0
2987           obrot2(1,i-2)=0.0d0
2988           obrot2(2,i-2)=0.0d0
2989           Ug(1,1,i-2)=1.0d0
2990           Ug(1,2,i-2)=0.0d0
2991           Ug(2,1,i-2)=0.0d0
2992           Ug(2,2,i-2)=1.0d0
2993           Ug2(1,1,i-2)=0.0d0
2994           Ug2(1,2,i-2)=0.0d0
2995           Ug2(2,1,i-2)=0.0d0
2996           Ug2(2,2,i-2)=0.0d0
2997         endif
2998         if (i .gt. 3) then
2999           obrot_der(1,i-2)=-sin1
3000           obrot_der(2,i-2)= cos1
3001           Ugder(1,1,i-2)= sin1
3002           Ugder(1,2,i-2)=-cos1
3003           Ugder(2,1,i-2)=-cos1
3004           Ugder(2,2,i-2)=-sin1
3005           dwacos2=cos2+cos2
3006           dwasin2=sin2+sin2
3007           obrot2_der(1,i-2)=-dwasin2
3008           obrot2_der(2,i-2)= dwacos2
3009           Ug2der(1,1,i-2)= dwasin2
3010           Ug2der(1,2,i-2)=-dwacos2
3011           Ug2der(2,1,i-2)=-dwacos2
3012           Ug2der(2,2,i-2)=-dwasin2
3013         else
3014           obrot_der(1,i-2)=0.0d0
3015           obrot_der(2,i-2)=0.0d0
3016           Ugder(1,1,i-2)=0.0d0
3017           Ugder(1,2,i-2)=0.0d0
3018           Ugder(2,1,i-2)=0.0d0
3019           Ugder(2,2,i-2)=0.0d0
3020           obrot2_der(1,i-2)=0.0d0
3021           obrot2_der(2,i-2)=0.0d0
3022           Ug2der(1,1,i-2)=0.0d0
3023           Ug2der(1,2,i-2)=0.0d0
3024           Ug2der(2,1,i-2)=0.0d0
3025           Ug2der(2,2,i-2)=0.0d0
3026         endif
3027 c        if (i.gt. iatel_s+2 .and. i.lt.iatel_e+5) then
3028 c        if (i.gt. nnt+2 .and. i.lt.nct+2) then
3029         if (i.gt.nnt+2 .and.i.lt.nct+2) then
3030           iti = itype2loc(itype(i-2))
3031         else
3032           iti=nloctyp
3033         endif
3034 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
3035         if (i.gt. nnt+1 .and. i.lt.nct+1) then
3036           iti1 = itype2loc(itype(i-1))
3037         else
3038           iti1=nloctyp
3039         endif
3040 cd        write (iout,*) '*******i',i,' iti1',iti
3041 cd        write (iout,*) 'b1',b1(:,iti)
3042 cd        write (iout,*) 'b2',b2(:,iti)
3043 cd        write (iout,*) 'Ug',Ug(:,:,i-2)
3044 c        if (i .gt. iatel_s+2) then
3045         if (i .gt. nnt+2) then
3046           call matvec2(Ug(1,1,i-2),b2(1,i-2),Ub2(1,i-2))
3047 #ifdef NEWCORR
3048           call matvec2(Ug(1,1,i-2),gtb2(1,i-2),gUb2(1,i-2))
3049 c          write (iout,*) Ug(1,1,i-2),gtb2(1,i-2),gUb2(1,i-2),"chuj"
3050 #endif
3051 c          write(iout,*) "co jest kurwa", iti, EE(1,1,i),EE(2,1,i),
3052 c     &    EE(1,2,iti),EE(2,2,i)
3053           call matmat2(EE(1,1,i-2),Ug(1,1,i-2),EUg(1,1,i-2))
3054           call matmat2(gtEE(1,1,i-2),Ug(1,1,i-2),gtEUg(1,1,i-2))
3055 c          write(iout,*) "Macierz EUG",
3056 c     &    eug(1,1,i-2),eug(1,2,i-2),eug(2,1,i-2),
3057 c     &    eug(2,2,i-2)
3058 #ifdef FOURBODY
3059           if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
3060      &    then
3061           call matmat2(CC(1,1,i-2),Ug(1,1,i-2),CUg(1,1,i-2))
3062           call matmat2(DD(1,1,i-2),Ug(1,1,i-2),DUg(1,1,i-2))
3063           call matmat2(Dtilde(1,1,i-2),Ug2(1,1,i-2),DtUg2(1,1,i-2))
3064           call matvec2(Ctilde(1,1,i-1),obrot(1,i-2),Ctobr(1,i-2))
3065           call matvec2(Dtilde(1,1,i-2),obrot2(1,i-2),Dtobr2(1,i-2))
3066           endif
3067 #endif
3068         else
3069           do k=1,2
3070             Ub2(k,i-2)=0.0d0
3071             Ctobr(k,i-2)=0.0d0
3072             Dtobr2(k,i-2)=0.0d0
3073             do l=1,2
3074               EUg(l,k,i-2)=0.0d0
3075               CUg(l,k,i-2)=0.0d0
3076               DUg(l,k,i-2)=0.0d0
3077               DtUg2(l,k,i-2)=0.0d0
3078             enddo
3079           enddo
3080         endif
3081         call matvec2(Ugder(1,1,i-2),b2(1,i-2),Ub2der(1,i-2))
3082         call matmat2(EE(1,1,i-2),Ugder(1,1,i-2),EUgder(1,1,i-2))
3083         do k=1,2
3084           muder(k,i-2)=Ub2der(k,i-2)
3085         enddo
3086 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
3087         if (i.gt. nnt+1 .and. i.lt.nct+1) then
3088           if (itype(i-1).le.ntyp) then
3089             iti1 = itype2loc(itype(i-1))
3090           else
3091             iti1=nloctyp
3092           endif
3093         else
3094           iti1=nloctyp
3095         endif
3096         do k=1,2
3097           mu(k,i-2)=Ub2(k,i-2)+b1(k,i-1)
3098 c          mu(k,i-2)=b1(k,i-1)
3099 c          mu(k,i-2)=Ub2(k,i-2)
3100         enddo
3101 #ifdef MUOUT
3102         write (iout,'(2hmu,i3,3f8.1,12f10.5)') i-2,rad2deg*theta(i-1),
3103      &     rad2deg*theta(i),rad2deg*phi(i),mu(1,i-2),mu(2,i-2),
3104      &       -b2(1,i-2),b2(2,i-2),b1(1,i-2),b1(2,i-2),
3105      &       dsqrt(b2(1,i-1)**2+b2(2,i-1)**2)
3106      &      +dsqrt(b1(1,i-1)**2+b1(2,i-1)**2),
3107      &      ((ee(l,k,i-2),l=1,2),k=1,2)
3108 #endif
3109 cd        write (iout,*) 'mu1',mu1(:,i-2)
3110 cd        write (iout,*) 'mu2',mu2(:,i-2)
3111 cd        write (iout,*) 'mu',i-2,mu(:,i-2)
3112 #ifdef FOURBODY
3113         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
3114      &  then
3115         call matmat2(CC(1,1,i-1),Ugder(1,1,i-2),CUgder(1,1,i-2))
3116         call matmat2(DD(1,1,i-2),Ugder(1,1,i-2),DUgder(1,1,i-2))
3117         call matmat2(Dtilde(1,1,i-2),Ug2der(1,1,i-2),DtUg2der(1,1,i-2))
3118         call matvec2(Ctilde(1,1,i-1),obrot_der(1,i-2),Ctobrder(1,i-2))
3119         call matvec2(Dtilde(1,1,i-2),obrot2_der(1,i-2),Dtobr2der(1,i-2))
3120 C Vectors and matrices dependent on a single virtual-bond dihedral.
3121         call matvec2(DD(1,1,i-2),b1tilde(1,i-1),auxvec(1))
3122         call matvec2(Ug2(1,1,i-2),auxvec(1),Ug2Db1t(1,i-2))
3123         call matvec2(Ug2der(1,1,i-2),auxvec(1),Ug2Db1tder(1,i-2))
3124         call matvec2(CC(1,1,i-1),Ub2(1,i-2),CUgb2(1,i-2))
3125         call matvec2(CC(1,1,i-1),Ub2der(1,i-2),CUgb2der(1,i-2))
3126         call matmat2(EUg(1,1,i-2),CC(1,1,i-1),EUgC(1,1,i-2))
3127         call matmat2(EUgder(1,1,i-2),CC(1,1,i-1),EUgCder(1,1,i-2))
3128         call matmat2(EUg(1,1,i-2),DD(1,1,i-1),EUgD(1,1,i-2))
3129         call matmat2(EUgder(1,1,i-2),DD(1,1,i-1),EUgDder(1,1,i-2))
3130         endif
3131 #endif
3132       enddo
3133 #ifdef FOURBODY
3134 C Matrices dependent on two consecutive virtual-bond dihedrals.
3135 C The order of matrices is from left to right.
3136       if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
3137      &then
3138 c      do i=max0(ivec_start,2),ivec_end
3139       do i=2,nres-1
3140         call matmat2(DtUg2(1,1,i-1),EUg(1,1,i),DtUg2EUg(1,1,i))
3141         call matmat2(DtUg2der(1,1,i-1),EUg(1,1,i),DtUg2EUgder(1,1,1,i))
3142         call matmat2(DtUg2(1,1,i-1),EUgder(1,1,i),DtUg2EUgder(1,1,2,i))
3143         call transpose2(DtUg2(1,1,i-1),auxmat(1,1))
3144         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUg(1,1,i))
3145         call matmat2(auxmat(1,1),EUgder(1,1,i),Ug2DtEUgder(1,1,2,i))
3146         call transpose2(DtUg2der(1,1,i-1),auxmat(1,1))
3147         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUgder(1,1,1,i))
3148       enddo
3149       endif
3150 #endif
3151 #if defined(MPI) && defined(PARMAT)
3152 #ifdef DEBUG
3153 c      if (fg_rank.eq.0) then
3154         write (iout,*) "Arrays UG and UGDER before GATHER"
3155         do i=1,nres-1
3156           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3157      &     ((ug(l,k,i),l=1,2),k=1,2),
3158      &     ((ugder(l,k,i),l=1,2),k=1,2)
3159         enddo
3160         write (iout,*) "Arrays UG2 and UG2DER"
3161         do i=1,nres-1
3162           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3163      &     ((ug2(l,k,i),l=1,2),k=1,2),
3164      &     ((ug2der(l,k,i),l=1,2),k=1,2)
3165         enddo
3166         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
3167         do i=1,nres-1
3168           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3169      &     (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
3170      &     (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
3171         enddo
3172         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
3173         do i=1,nres-1
3174           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3175      &     costab(i),sintab(i),costab2(i),sintab2(i)
3176         enddo
3177         write (iout,*) "Array MUDER"
3178         do i=1,nres-1
3179           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
3180         enddo
3181 c      endif
3182 #endif
3183       if (nfgtasks.gt.1) then
3184         time00=MPI_Wtime()
3185 c        write(iout,*)"Processor",fg_rank,kolor," ivec_start",ivec_start,
3186 c     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks-1),
3187 c     &   " ivec_count",(ivec_count(i),i=0,nfgtasks-1)
3188 #ifdef MATGATHER
3189         call MPI_Allgatherv(Ub2(1,ivec_start),ivec_count(fg_rank1),
3190      &   MPI_MU,Ub2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3191      &   FG_COMM1,IERR)
3192         call MPI_Allgatherv(Ub2der(1,ivec_start),ivec_count(fg_rank1),
3193      &   MPI_MU,Ub2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3194      &   FG_COMM1,IERR)
3195         call MPI_Allgatherv(mu(1,ivec_start),ivec_count(fg_rank1),
3196      &   MPI_MU,mu(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3197      &   FG_COMM1,IERR)
3198         call MPI_Allgatherv(muder(1,ivec_start),ivec_count(fg_rank1),
3199      &   MPI_MU,muder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3200      &   FG_COMM1,IERR)
3201         call MPI_Allgatherv(Eug(1,1,ivec_start),ivec_count(fg_rank1),
3202      &   MPI_MAT1,Eug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3203      &   FG_COMM1,IERR)
3204         call MPI_Allgatherv(Eugder(1,1,ivec_start),ivec_count(fg_rank1),
3205      &   MPI_MAT1,Eugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3206      &   FG_COMM1,IERR)
3207         call MPI_Allgatherv(costab(ivec_start),ivec_count(fg_rank1),
3208      &   MPI_DOUBLE_PRECISION,costab(1),ivec_count(0),ivec_displ(0),
3209      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3210         call MPI_Allgatherv(sintab(ivec_start),ivec_count(fg_rank1),
3211      &   MPI_DOUBLE_PRECISION,sintab(1),ivec_count(0),ivec_displ(0),
3212      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3213         call MPI_Allgatherv(costab2(ivec_start),ivec_count(fg_rank1),
3214      &   MPI_DOUBLE_PRECISION,costab2(1),ivec_count(0),ivec_displ(0),
3215      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3216         call MPI_Allgatherv(sintab2(ivec_start),ivec_count(fg_rank1),
3217      &   MPI_DOUBLE_PRECISION,sintab2(1),ivec_count(0),ivec_displ(0),
3218      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3219 #ifdef FOURBODY
3220         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
3221      &  then
3222         call MPI_Allgatherv(Ctobr(1,ivec_start),ivec_count(fg_rank1),
3223      &   MPI_MU,Ctobr(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3224      &   FG_COMM1,IERR)
3225         call MPI_Allgatherv(Ctobrder(1,ivec_start),ivec_count(fg_rank1),
3226      &   MPI_MU,Ctobrder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3227      &   FG_COMM1,IERR)
3228         call MPI_Allgatherv(Dtobr2(1,ivec_start),ivec_count(fg_rank1),
3229      &   MPI_MU,Dtobr2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3230      &   FG_COMM1,IERR)
3231        call MPI_Allgatherv(Dtobr2der(1,ivec_start),ivec_count(fg_rank1),
3232      &   MPI_MU,Dtobr2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3233      &   FG_COMM1,IERR)
3234         call MPI_Allgatherv(Ug2Db1t(1,ivec_start),ivec_count(fg_rank1),
3235      &   MPI_MU,Ug2Db1t(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3236      &   FG_COMM1,IERR)
3237         call MPI_Allgatherv(Ug2Db1tder(1,ivec_start),
3238      &   ivec_count(fg_rank1),
3239      &   MPI_MU,Ug2Db1tder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3240      &   FG_COMM1,IERR)
3241         call MPI_Allgatherv(CUgb2(1,ivec_start),ivec_count(fg_rank1),
3242      &   MPI_MU,CUgb2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3243      &   FG_COMM1,IERR)
3244         call MPI_Allgatherv(CUgb2der(1,ivec_start),ivec_count(fg_rank1),
3245      &   MPI_MU,CUgb2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3246      &   FG_COMM1,IERR)
3247         call MPI_Allgatherv(Cug(1,1,ivec_start),ivec_count(fg_rank1),
3248      &   MPI_MAT1,Cug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3249      &   FG_COMM1,IERR)
3250         call MPI_Allgatherv(Cugder(1,1,ivec_start),ivec_count(fg_rank1),
3251      &   MPI_MAT1,Cugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3252      &   FG_COMM1,IERR)
3253         call MPI_Allgatherv(Dug(1,1,ivec_start),ivec_count(fg_rank1),
3254      &   MPI_MAT1,Dug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3255      &   FG_COMM1,IERR)
3256         call MPI_Allgatherv(Dugder(1,1,ivec_start),ivec_count(fg_rank1),
3257      &   MPI_MAT1,Dugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3258      &   FG_COMM1,IERR)
3259         call MPI_Allgatherv(Dtug2(1,1,ivec_start),ivec_count(fg_rank1),
3260      &   MPI_MAT1,Dtug2(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3261      &   FG_COMM1,IERR)
3262         call MPI_Allgatherv(Dtug2der(1,1,ivec_start),
3263      &   ivec_count(fg_rank1),
3264      &   MPI_MAT1,Dtug2der(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3265      &   FG_COMM1,IERR)
3266         call MPI_Allgatherv(EugC(1,1,ivec_start),ivec_count(fg_rank1),
3267      &   MPI_MAT1,EugC(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3268      &   FG_COMM1,IERR)
3269        call MPI_Allgatherv(EugCder(1,1,ivec_start),ivec_count(fg_rank1),
3270      &   MPI_MAT1,EugCder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3271      &   FG_COMM1,IERR)
3272         call MPI_Allgatherv(EugD(1,1,ivec_start),ivec_count(fg_rank1),
3273      &   MPI_MAT1,EugD(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3274      &   FG_COMM1,IERR)
3275        call MPI_Allgatherv(EugDder(1,1,ivec_start),ivec_count(fg_rank1),
3276      &   MPI_MAT1,EugDder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3277      &   FG_COMM1,IERR)
3278         call MPI_Allgatherv(DtUg2EUg(1,1,ivec_start),
3279      &   ivec_count(fg_rank1),
3280      &   MPI_MAT1,DtUg2EUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3281      &   FG_COMM1,IERR)
3282         call MPI_Allgatherv(Ug2DtEUg(1,1,ivec_start),
3283      &   ivec_count(fg_rank1),
3284      &   MPI_MAT1,Ug2DtEUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3285      &   FG_COMM1,IERR)
3286         call MPI_Allgatherv(DtUg2EUgder(1,1,1,ivec_start),
3287      &   ivec_count(fg_rank1),
3288      &   MPI_MAT2,DtUg2EUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
3289      &   MPI_MAT2,FG_COMM1,IERR)
3290         call MPI_Allgatherv(Ug2DtEUgder(1,1,1,ivec_start),
3291      &   ivec_count(fg_rank1),
3292      &   MPI_MAT2,Ug2DtEUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
3293      &   MPI_MAT2,FG_COMM1,IERR)
3294         endif
3295 #endif
3296 #else
3297 c Passes matrix info through the ring
3298       isend=fg_rank1
3299       irecv=fg_rank1-1
3300       if (irecv.lt.0) irecv=nfgtasks1-1
3301       iprev=irecv
3302       inext=fg_rank1+1
3303       if (inext.ge.nfgtasks1) inext=0
3304       do i=1,nfgtasks1-1
3305 c        write (iout,*) "isend",isend," irecv",irecv
3306 c        call flush(iout)
3307         lensend=lentyp(isend)
3308         lenrecv=lentyp(irecv)
3309 c        write (iout,*) "lensend",lensend," lenrecv",lenrecv
3310 c        call MPI_SENDRECV(ug(1,1,ivec_displ(isend)+1),1,
3311 c     &   MPI_ROTAT1(lensend),inext,2200+isend,
3312 c     &   ug(1,1,ivec_displ(irecv)+1),1,MPI_ROTAT1(lenrecv),
3313 c     &   iprev,2200+irecv,FG_COMM,status,IERR)
3314 c        write (iout,*) "Gather ROTAT1"
3315 c        call flush(iout)
3316 c        call MPI_SENDRECV(obrot(1,ivec_displ(isend)+1),1,
3317 c     &   MPI_ROTAT2(lensend),inext,3300+isend,
3318 c     &   obrot(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
3319 c     &   iprev,3300+irecv,FG_COMM,status,IERR)
3320 c        write (iout,*) "Gather ROTAT2"
3321 c        call flush(iout)
3322         call MPI_SENDRECV(costab(ivec_displ(isend)+1),1,
3323      &   MPI_ROTAT_OLD(lensend),inext,4400+isend,
3324      &   costab(ivec_displ(irecv)+1),1,MPI_ROTAT_OLD(lenrecv),
3325      &   iprev,4400+irecv,FG_COMM,status,IERR)
3326 c        write (iout,*) "Gather ROTAT_OLD"
3327 c        call flush(iout)
3328         call MPI_SENDRECV(mu(1,ivec_displ(isend)+1),1,
3329      &   MPI_PRECOMP11(lensend),inext,5500+isend,
3330      &   mu(1,ivec_displ(irecv)+1),1,MPI_PRECOMP11(lenrecv),
3331      &   iprev,5500+irecv,FG_COMM,status,IERR)
3332 c        write (iout,*) "Gather PRECOMP11"
3333 c        call flush(iout)
3334         call MPI_SENDRECV(Eug(1,1,ivec_displ(isend)+1),1,
3335      &   MPI_PRECOMP12(lensend),inext,6600+isend,
3336      &   Eug(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP12(lenrecv),
3337      &   iprev,6600+irecv,FG_COMM,status,IERR)
3338 c        write (iout,*) "Gather PRECOMP12"
3339 c        call flush(iout)
3340 #ifdef FOURBODY
3341         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
3342      &  then
3343         call MPI_SENDRECV(ug2db1t(1,ivec_displ(isend)+1),1,
3344      &   MPI_ROTAT2(lensend),inext,7700+isend,
3345      &   ug2db1t(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
3346      &   iprev,7700+irecv,FG_COMM,status,IERR)
3347 c        write (iout,*) "Gather PRECOMP21"
3348 c        call flush(iout)
3349         call MPI_SENDRECV(EUgC(1,1,ivec_displ(isend)+1),1,
3350      &   MPI_PRECOMP22(lensend),inext,8800+isend,
3351      &   EUgC(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP22(lenrecv),
3352      &   iprev,8800+irecv,FG_COMM,status,IERR)
3353 c        write (iout,*) "Gather PRECOMP22"
3354 c        call flush(iout)
3355         call MPI_SENDRECV(Ug2DtEUgder(1,1,1,ivec_displ(isend)+1),1,
3356      &   MPI_PRECOMP23(lensend),inext,9900+isend,
3357      &   Ug2DtEUgder(1,1,1,ivec_displ(irecv)+1),1,
3358      &   MPI_PRECOMP23(lenrecv),
3359      &   iprev,9900+irecv,FG_COMM,status,IERR)
3360 #endif
3361 c        write (iout,*) "Gather PRECOMP23"
3362 c        call flush(iout)
3363         endif
3364         isend=irecv
3365         irecv=irecv-1
3366         if (irecv.lt.0) irecv=nfgtasks1-1
3367       enddo
3368 #endif
3369         time_gather=time_gather+MPI_Wtime()-time00
3370       endif
3371 #ifdef DEBUG
3372 c      if (fg_rank.eq.0) then
3373         write (iout,*) "Arrays UG and UGDER"
3374         do i=1,nres-1
3375           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3376      &     ((ug(l,k,i),l=1,2),k=1,2),
3377      &     ((ugder(l,k,i),l=1,2),k=1,2)
3378         enddo
3379         write (iout,*) "Arrays UG2 and UG2DER"
3380         do i=1,nres-1
3381           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3382      &     ((ug2(l,k,i),l=1,2),k=1,2),
3383      &     ((ug2der(l,k,i),l=1,2),k=1,2)
3384         enddo
3385         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
3386         do i=1,nres-1
3387           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3388      &     (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
3389      &     (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
3390         enddo
3391         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
3392         do i=1,nres-1
3393           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3394      &     costab(i),sintab(i),costab2(i),sintab2(i)
3395         enddo
3396         write (iout,*) "Array MUDER"
3397         do i=1,nres-1
3398           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
3399         enddo
3400 c      endif
3401 #endif
3402 #endif
3403 cd      do i=1,nres
3404 cd        iti = itype2loc(itype(i))
3405 cd        write (iout,*) i
3406 cd        do j=1,2
3407 cd        write (iout,'(2f10.5,5x,2f10.5,5x,2f10.5)')
3408 cd     &  (EE(j,k,i),k=1,2),(Ug(j,k,i),k=1,2),(EUg(j,k,i),k=1,2)
3409 cd        enddo
3410 cd      enddo
3411       return
3412       end
3413 C-----------------------------------------------------------------------------
3414       subroutine eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
3415 C
3416 C This subroutine calculates the average interaction energy and its gradient
3417 C in the virtual-bond vectors between non-adjacent peptide groups, based on
3418 C the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
3419 C The potential depends both on the distance of peptide-group centers and on
3420 C the orientation of the CA-CA virtual bonds.
3421 C
3422       implicit real*8 (a-h,o-z)
3423 #ifdef MPI
3424       include 'mpif.h'
3425 #endif
3426       include 'DIMENSIONS'
3427       include 'COMMON.CONTROL'
3428       include 'COMMON.SETUP'
3429       include 'COMMON.IOUNITS'
3430       include 'COMMON.GEO'
3431       include 'COMMON.VAR'
3432       include 'COMMON.LOCAL'
3433       include 'COMMON.CHAIN'
3434       include 'COMMON.DERIV'
3435       include 'COMMON.INTERACT'
3436 #ifdef FOURBODY
3437       include 'COMMON.CONTACTS'
3438       include 'COMMON.CONTMAT'
3439 #endif
3440       include 'COMMON.CORRMAT'
3441       include 'COMMON.TORSION'
3442       include 'COMMON.VECTORS'
3443       include 'COMMON.FFIELD'
3444       include 'COMMON.TIME1'
3445       include 'COMMON.SPLITELE'
3446       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
3447      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
3448       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
3449      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4),gmuij(4)
3450       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3451      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3452      &    num_conti,j1,j2
3453 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
3454 #ifdef MOMENT
3455       double precision scal_el /1.0d0/
3456 #else
3457       double precision scal_el /0.5d0/
3458 #endif
3459 C 12/13/98
3460 C 13-go grudnia roku pamietnego...
3461       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
3462      &                   0.0d0,1.0d0,0.0d0,
3463      &                   0.0d0,0.0d0,1.0d0/
3464 cd      write(iout,*) 'In EELEC'
3465 cd      do i=1,nloctyp
3466 cd        write(iout,*) 'Type',i
3467 cd        write(iout,*) 'B1',B1(:,i)
3468 cd        write(iout,*) 'B2',B2(:,i)
3469 cd        write(iout,*) 'CC',CC(:,:,i)
3470 cd        write(iout,*) 'DD',DD(:,:,i)
3471 cd        write(iout,*) 'EE',EE(:,:,i)
3472 cd      enddo
3473 cd      call check_vecgrad
3474 cd      stop
3475       if (icheckgrad.eq.1) then
3476         do i=1,nres-1
3477           fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
3478           do k=1,3
3479             dc_norm(k,i)=dc(k,i)*fac
3480           enddo
3481 c          write (iout,*) 'i',i,' fac',fac
3482         enddo
3483       endif
3484       if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
3485      &    .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or.
3486      &    wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
3487 c        call vec_and_deriv
3488 #ifdef TIMING
3489         time01=MPI_Wtime()
3490 #endif
3491         call set_matrices
3492 #ifdef TIMING
3493         time_mat=time_mat+MPI_Wtime()-time01
3494 #endif
3495       endif
3496 cd      do i=1,nres-1
3497 cd        write (iout,*) 'i=',i
3498 cd        do k=1,3
3499 cd        write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
3500 cd        enddo
3501 cd        do k=1,3
3502 cd          write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
3503 cd     &     uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
3504 cd        enddo
3505 cd      enddo
3506       t_eelecij=0.0d0
3507       ees=0.0D0
3508       evdw1=0.0D0
3509       eel_loc=0.0d0
3510       eello_turn3=0.0d0
3511       eello_turn4=0.0d0
3512       ind=0
3513 #ifdef FOURBODY
3514       do i=1,nres
3515         num_cont_hb(i)=0
3516       enddo
3517 #endif
3518 cd      print '(a)','Enter EELEC'
3519 cd      write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
3520       do i=1,nres
3521         gel_loc_loc(i)=0.0d0
3522         gcorr_loc(i)=0.0d0
3523       enddo
3524 c
3525 c
3526 c 9/27/08 AL Split the interaction loop to ensure load balancing of turn terms
3527 C
3528 C Loop over i,i+2 and i,i+3 pairs of the peptide groups
3529 C
3530 C 14/01/2014 TURN3,TUNR4 does no go under periodic boundry condition
3531       do i=iturn3_start,iturn3_end
3532 c        if (i.le.1) cycle
3533 C        write(iout,*) "tu jest i",i
3534         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
3535 C changes suggested by Ana to avoid out of bounds
3536 C Adam: Unnecessary: handled by iturn3_end and iturn3_start
3537 c     & .or.((i+4).gt.nres)
3538 c     & .or.((i-1).le.0)
3539 C end of changes by Ana
3540      &  .or. itype(i+2).eq.ntyp1
3541      &  .or. itype(i+3).eq.ntyp1) cycle
3542 C Adam: Instructions below will switch off existing interactions
3543 c        if(i.gt.1)then
3544 c          if(itype(i-1).eq.ntyp1)cycle
3545 c        end if
3546 c        if(i.LT.nres-3)then
3547 c          if (itype(i+4).eq.ntyp1) cycle
3548 c        end if
3549         dxi=dc(1,i)
3550         dyi=dc(2,i)
3551         dzi=dc(3,i)
3552         dx_normi=dc_norm(1,i)
3553         dy_normi=dc_norm(2,i)
3554         dz_normi=dc_norm(3,i)
3555         xmedi=c(1,i)+0.5d0*dxi
3556         ymedi=c(2,i)+0.5d0*dyi
3557         zmedi=c(3,i)+0.5d0*dzi
3558         call to_box(xmedi,ymedi,zmedi)
3559         num_conti=0
3560         call eelecij(i,i+2,ees,evdw1,eel_loc)
3561         if (wturn3.gt.0.0d0) call eturn3(i,eello_turn3)
3562 #ifdef FOURBODY
3563         num_cont_hb(i)=num_conti
3564 #endif
3565       enddo
3566       do i=iturn4_start,iturn4_end
3567         if (i.lt.1) cycle
3568         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
3569 C changes suggested by Ana to avoid out of bounds
3570 c     & .or.((i+5).gt.nres)
3571 c     & .or.((i-1).le.0)
3572 C end of changes suggested by Ana
3573      &    .or. itype(i+3).eq.ntyp1
3574      &    .or. itype(i+4).eq.ntyp1
3575 c     &    .or. itype(i+5).eq.ntyp1
3576 c     &    .or. itype(i).eq.ntyp1
3577 c     &    .or. itype(i-1).eq.ntyp1
3578      &                             ) cycle
3579         dxi=dc(1,i)
3580         dyi=dc(2,i)
3581         dzi=dc(3,i)
3582         dx_normi=dc_norm(1,i)
3583         dy_normi=dc_norm(2,i)
3584         dz_normi=dc_norm(3,i)
3585         xmedi=c(1,i)+0.5d0*dxi
3586         ymedi=c(2,i)+0.5d0*dyi
3587         zmedi=c(3,i)+0.5d0*dzi
3588 C Return atom into box, boxxsize is size of box in x dimension
3589 c  194   continue
3590 c        if (xmedi.gt.((0.5d0)*boxxsize)) xmedi=xmedi-boxxsize
3591 c        if (xmedi.lt.((-0.5d0)*boxxsize)) xmedi=xmedi+boxxsize
3592 C Condition for being inside the proper box
3593 c        if ((xmedi.gt.((0.5d0)*boxxsize)).or.
3594 c     &       (xmedi.lt.((-0.5d0)*boxxsize))) then
3595 c        go to 194
3596 c        endif
3597 c  195   continue
3598 c        if (ymedi.gt.((0.5d0)*boxysize)) ymedi=ymedi-boxysize
3599 c        if (ymedi.lt.((-0.5d0)*boxysize)) ymedi=ymedi+boxysize
3600 C Condition for being inside the proper box
3601 c        if ((ymedi.gt.((0.5d0)*boxysize)).or.
3602 c     &       (ymedi.lt.((-0.5d0)*boxysize))) then
3603 c        go to 195
3604 c        endif
3605 c  196   continue
3606 c        if (zmedi.gt.((0.5d0)*boxzsize)) zmedi=zmedi-boxzsize
3607 c        if (zmedi.lt.((-0.5d0)*boxzsize)) zmedi=zmedi+boxzsize
3608 C Condition for being inside the proper box
3609 c        if ((zmedi.gt.((0.5d0)*boxzsize)).or.
3610 c     &       (zmedi.lt.((-0.5d0)*boxzsize))) then
3611 c        go to 196
3612 c        endif
3613         call to_box(xmedi,ymedi,zmedi)
3614 #ifdef FOURBODY
3615         num_conti=num_cont_hb(i)
3616 #endif
3617 c        write(iout,*) "JESTEM W PETLI"
3618         call eelecij(i,i+3,ees,evdw1,eel_loc)
3619         if (wturn4.gt.0.0d0 .and. itype(i+2).ne.ntyp1)
3620      &   call eturn4(i,eello_turn4)
3621 #ifdef FOURBODY
3622         num_cont_hb(i)=num_conti
3623 #endif
3624       enddo   ! i
3625 C Loop over all neighbouring boxes
3626 C      do xshift=-1,1
3627 C      do yshift=-1,1
3628 C      do zshift=-1,1
3629 c
3630 c Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
3631 c
3632 CTU KURWA
3633 c      do i=iatel_s,iatel_e
3634       do ikont=g_listpp_start,g_listpp_end
3635         i=newcontlistppi(ikont)
3636         j=newcontlistppj(ikont)
3637 C        do i=75,75
3638 c        if (i.le.1) cycle
3639         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
3640 C changes suggested by Ana to avoid out of bounds
3641 c     & .or.((i+2).gt.nres)
3642 c     & .or.((i-1).le.0)
3643 C end of changes by Ana
3644 c     &  .or. itype(i+2).eq.ntyp1
3645 c     &  .or. itype(i-1).eq.ntyp1
3646      &                ) cycle
3647         dxi=dc(1,i)
3648         dyi=dc(2,i)
3649         dzi=dc(3,i)
3650         dx_normi=dc_norm(1,i)
3651         dy_normi=dc_norm(2,i)
3652         dz_normi=dc_norm(3,i)
3653         xmedi=c(1,i)+0.5d0*dxi
3654         ymedi=c(2,i)+0.5d0*dyi
3655         zmedi=c(3,i)+0.5d0*dzi
3656         call to_box(xmedi,ymedi,zmedi)
3657 C          xmedi=xmedi+xshift*boxxsize
3658 C          ymedi=ymedi+yshift*boxysize
3659 C          zmedi=zmedi+zshift*boxzsize
3660
3661 C Return tom into box, boxxsize is size of box in x dimension
3662 c  164   continue
3663 c        if (xmedi.gt.((xshift+0.5d0)*boxxsize)) xmedi=xmedi-boxxsize
3664 c        if (xmedi.lt.((xshift-0.5d0)*boxxsize)) xmedi=xmedi+boxxsize
3665 C Condition for being inside the proper box
3666 c        if ((xmedi.gt.((xshift+0.5d0)*boxxsize)).or.
3667 c     &       (xmedi.lt.((xshift-0.5d0)*boxxsize))) then
3668 c        go to 164
3669 c        endif
3670 c  165   continue
3671 c        if (ymedi.gt.((yshift+0.5d0)*boxysize)) ymedi=ymedi-boxysize
3672 c        if (ymedi.lt.((yshift-0.5d0)*boxysize)) ymedi=ymedi+boxysize
3673 C Condition for being inside the proper box
3674 c        if ((ymedi.gt.((yshift+0.5d0)*boxysize)).or.
3675 c     &       (ymedi.lt.((yshift-0.5d0)*boxysize))) then
3676 c        go to 165
3677 c        endif
3678 c  166   continue
3679 c        if (zmedi.gt.((zshift+0.5d0)*boxzsize)) zmedi=zmedi-boxzsize
3680 c        if (zmedi.lt.((zshift-0.5d0)*boxzsize)) zmedi=zmedi+boxzsize
3681 cC Condition for being inside the proper box
3682 c        if ((zmedi.gt.((zshift+0.5d0)*boxzsize)).or.
3683 c     &       (zmedi.lt.((zshift-0.5d0)*boxzsize))) then
3684 c        go to 166
3685 c        endif
3686
3687 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
3688 #ifdef FOURBODY
3689         num_conti=num_cont_hb(i)
3690 #endif
3691 C I TU KURWA
3692 c        do j=ielstart(i),ielend(i)
3693 C          do j=16,17
3694 C          write (iout,*) i,j
3695 C         if (j.le.1) cycle
3696         if (itype(j).eq.ntyp1.or. itype(j+1).eq.ntyp1
3697 C changes suggested by Ana to avoid out of bounds
3698 c     & .or.((j+2).gt.nres)
3699 c     & .or.((j-1).le.0)
3700 C end of changes by Ana
3701 c     & .or.itype(j+2).eq.ntyp1
3702 c     & .or.itype(j-1).eq.ntyp1
3703      &) cycle
3704         call eelecij(i,j,ees,evdw1,eel_loc)
3705 c        enddo ! j
3706 #ifdef FOURBODY
3707         num_cont_hb(i)=num_conti
3708 #endif
3709       enddo   ! i
3710 C     enddo   ! zshift
3711 C      enddo   ! yshift
3712 C      enddo   ! xshift
3713
3714 c      write (iout,*) "Number of loop steps in EELEC:",ind
3715 cd      do i=1,nres
3716 cd        write (iout,'(i3,3f10.5,5x,3f10.5)')
3717 cd     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
3718 cd      enddo
3719 c 12/7/99 Adam eello_turn3 will be considered as a separate energy term
3720 ccc      eel_loc=eel_loc+eello_turn3
3721 cd      print *,"Processor",fg_rank," t_eelecij",t_eelecij
3722       return
3723       end
3724 C-------------------------------------------------------------------------------
3725       subroutine eelecij(i,j,ees,evdw1,eel_loc)
3726       implicit none
3727       include 'DIMENSIONS'
3728 #ifdef MPI
3729       include "mpif.h"
3730 #endif
3731       include 'COMMON.CONTROL'
3732       include 'COMMON.IOUNITS'
3733       include 'COMMON.GEO'
3734       include 'COMMON.VAR'
3735       include 'COMMON.LOCAL'
3736       include 'COMMON.CHAIN'
3737       include 'COMMON.DERIV'
3738       include 'COMMON.INTERACT'
3739 #ifdef FOURBODY
3740       include 'COMMON.CONTACTS'
3741       include 'COMMON.CONTMAT'
3742 #endif
3743       include 'COMMON.CORRMAT'
3744       include 'COMMON.TORSION'
3745       include 'COMMON.VECTORS'
3746       include 'COMMON.FFIELD'
3747       include 'COMMON.TIME1'
3748       include 'COMMON.SPLITELE'
3749       include 'COMMON.SHIELD'
3750       double precision ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
3751      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
3752       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
3753      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4),gmuij1(4),gmuji1(4),
3754      &    gmuij2(4),gmuji2(4)
3755       double precision dxi,dyi,dzi
3756       double precision dx_normi,dy_normi,dz_normi,aux
3757       integer j1,j2,lll,num_conti
3758       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3759      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3760      &    num_conti,j1,j2
3761       integer k,i,j,iteli,itelj,kkk,l,kkll,m,isubchap,ilist,iresshield
3762       double precision ael6i,rrmij,rmij,r0ij,fcont,fprimcont,ees0tmp
3763       double precision ees,evdw1,eel_loc,aaa,bbb,ael3i
3764       double precision dxj,dyj,dzj,dx_normj,dy_normj,dz_normj,xj,yj,zj,
3765      &  rij,r3ij,r6ij,cosa,cosb,cosg,fac,ev1,ev2,fac3,fac4,
3766      &  evdwij,el1,el2,eesij,ees0ij,facvdw,facel,fac1,ecosa,
3767      &  ecosb,ecosg,ury,urz,vry,vrz,facr,a22der,a23der,a32der,
3768      &  a33der,eel_loc_ij,cosa4,wij,cosbg1,cosbg2,ees0pij,
3769      &  ees0pij1,ees0mij,ees0mij1,fac3p,ees0mijp,ees0pijp,
3770      &  ecosa1,ecosb1,ecosg1,ecosa2,ecosb2,ecosg2,ecosap,ecosbp,
3771      &  ecosgp,ecosam,ecosbm,ecosgm,ghalf,rlocshield
3772       double precision a22,a23,a32,a33,geel_loc_ij,geel_loc_ji
3773       double precision xmedi,ymedi,zmedi
3774       double precision sscale,sscagrad,scalar
3775       double precision boxshift
3776 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
3777 #ifdef MOMENT
3778       double precision scal_el /1.0d0/
3779 #else
3780       double precision scal_el /0.5d0/
3781 #endif
3782 C 12/13/98
3783 C 13-go grudnia roku pamietnego...
3784       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
3785      &                   0.0d0,1.0d0,0.0d0,
3786      &                   0.0d0,0.0d0,1.0d0/
3787 c          time00=MPI_Wtime()
3788 cd      write (iout,*) "eelecij",i,j
3789 c          ind=ind+1
3790           iteli=itel(i)
3791           itelj=itel(j)
3792           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
3793           aaa=app(iteli,itelj)
3794           bbb=bpp(iteli,itelj)
3795           ael6i=ael6(iteli,itelj)
3796           ael3i=ael3(iteli,itelj)
3797           dxj=dc(1,j)
3798           dyj=dc(2,j)
3799           dzj=dc(3,j)
3800           dx_normj=dc_norm(1,j)
3801           dy_normj=dc_norm(2,j)
3802           dz_normj=dc_norm(3,j)
3803 C          xj=c(1,j)+0.5D0*dxj-xmedi
3804 C          yj=c(2,j)+0.5D0*dyj-ymedi
3805 C          zj=c(3,j)+0.5D0*dzj-zmedi
3806           xj=c(1,j)+0.5D0*dxj
3807           yj=c(2,j)+0.5D0*dyj
3808           zj=c(3,j)+0.5D0*dzj
3809           call to_box(xj,yj,zj)
3810           xj=boxshift(xj-xmedi,boxxsize)
3811           yj=boxshift(yj-ymedi,boxysize)
3812           zj=boxshift(zj-zmedi,boxzsize)
3813 C        if ((i+3).lt.j) then !this condition keeps for turn3 and turn4 not subject to PBC
3814 c  174   continue
3815           rij=xj*xj+yj*yj+zj*zj
3816
3817           sss=sscale(dsqrt(rij),r_cut_int)
3818           if (sss.eq.0.0d0) return
3819           sssgrad=sscagrad(dsqrt(rij),r_cut_int)
3820 c            if (sss.gt.0.0d0) then
3821           rrmij=1.0D0/rij
3822           rij=dsqrt(rij)
3823           rmij=1.0D0/rij
3824           r3ij=rrmij*rmij
3825           r6ij=r3ij*r3ij
3826           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
3827           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
3828           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
3829           fac=cosa-3.0D0*cosb*cosg
3830           ev1=aaa*r6ij*r6ij
3831 c 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
3832           if (j.eq.i+2) ev1=scal_el*ev1
3833           ev2=bbb*r6ij
3834           fac3=ael6i*r6ij
3835           fac4=ael3i*r3ij
3836           evdwij=(ev1+ev2)
3837           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
3838           el2=fac4*fac
3839 C MARYSIA
3840 C          eesij=(el1+el2)
3841 C 12/26/95 - for the evaluation of multi-body H-bonding interactions
3842           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
3843           if (shield_mode.gt.0) then
3844 C          fac_shield(i)=0.4
3845 C          fac_shield(j)=0.6
3846           el1=el1*fac_shield(i)**2*fac_shield(j)**2
3847           el2=el2*fac_shield(i)**2*fac_shield(j)**2
3848           eesij=(el1+el2)
3849           ees=ees+eesij
3850           else
3851           fac_shield(i)=1.0
3852           fac_shield(j)=1.0
3853           eesij=(el1+el2)
3854           ees=ees+eesij*sss
3855           endif
3856           evdw1=evdw1+evdwij*sss
3857 cd          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
3858 cd     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
3859 cd     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
3860 cd     &      xmedi,ymedi,zmedi,xj,yj,zj
3861
3862           if (energy_dec) then
3863             write (iout,'(a6,2i5,0pf7.3,2i5,e11.3,3f10.5)')
3864      &        'evdw1',i,j,evdwij,iteli,itelj,aaa,evdw1,sss,rij
3865             write (iout,'(a6,2i5,0pf7.3,2f8.3)') 'ees',i,j,eesij,
3866      &        fac_shield(i),fac_shield(j)
3867           endif
3868
3869 C
3870 C Calculate contributions to the Cartesian gradient.
3871 C
3872 #ifdef SPLITELE
3873           facvdw=-6*rrmij*(ev1+evdwij)*sss
3874           facel=-3*rrmij*(el1+eesij)
3875           fac1=fac
3876           erij(1)=xj*rmij
3877           erij(2)=yj*rmij
3878           erij(3)=zj*rmij
3879
3880 *
3881 * Radial derivatives. First process both termini of the fragment (i,j)
3882 *
3883           aux=facel*sss+rmij*sssgrad*eesij
3884           ggg(1)=aux*xj
3885           ggg(2)=aux*yj
3886           ggg(3)=aux*zj
3887           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
3888      &  (shield_mode.gt.0)) then
3889 C          print *,i,j
3890           do ilist=1,ishield_list(i)
3891            iresshield=shield_list(ilist,i)
3892            do k=1,3
3893            rlocshield=grad_shield_side(k,ilist,i)*eesij/fac_shield(i)
3894      &      *2.0
3895            gshieldx(k,iresshield)=gshieldx(k,iresshield)+
3896      &              rlocshield
3897      & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)*2.0
3898             gshieldc(k,iresshield-1)=gshieldc(k,iresshield-1)+rlocshield
3899 C           gshieldc_loc(k,iresshield)=gshieldc_loc(k,iresshield)
3900 C     & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)
3901 C             if (iresshield.gt.i) then
3902 C               do ishi=i+1,iresshield-1
3903 C                gshieldc(k,ishi)=gshieldc(k,ishi)+rlocshield
3904 C     & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)
3905 C
3906 C              enddo
3907 C             else
3908 C               do ishi=iresshield,i
3909 C                gshieldc(k,ishi)=gshieldc(k,ishi)-rlocshield
3910 C     & -grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)
3911 C
3912 C               enddo
3913 C              endif
3914            enddo
3915           enddo
3916           do ilist=1,ishield_list(j)
3917            iresshield=shield_list(ilist,j)
3918            do k=1,3
3919            rlocshield=grad_shield_side(k,ilist,j)*eesij/fac_shield(j)
3920      &     *2.0*sss
3921            gshieldx(k,iresshield)=gshieldx(k,iresshield)+
3922      &              rlocshield
3923      & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)*2.0*sss
3924            gshieldc(k,iresshield-1)=gshieldc(k,iresshield-1)+rlocshield
3925
3926 C     & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
3927 C           gshieldc_loc(k,iresshield)=gshieldc_loc(k,iresshield)
3928 C     & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
3929 C             if (iresshield.gt.j) then
3930 C               do ishi=j+1,iresshield-1
3931 C                gshieldc(k,ishi)=gshieldc(k,ishi)+rlocshield
3932 C     & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
3933 C
3934 C               enddo
3935 C            else
3936 C               do ishi=iresshield,j
3937 C                gshieldc(k,ishi)=gshieldc(k,ishi)-rlocshield
3938 C     & -grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
3939 C               enddo
3940 C              endif
3941            enddo
3942           enddo
3943
3944           do k=1,3
3945             gshieldc(k,i)=gshieldc(k,i)+
3946      &              grad_shield(k,i)*eesij/fac_shield(i)*2.0*sss
3947             gshieldc(k,j)=gshieldc(k,j)+
3948      &              grad_shield(k,j)*eesij/fac_shield(j)*2.0*sss
3949             gshieldc(k,i-1)=gshieldc(k,i-1)+
3950      &              grad_shield(k,i)*eesij/fac_shield(i)*2.0*sss
3951             gshieldc(k,j-1)=gshieldc(k,j-1)+
3952      &              grad_shield(k,j)*eesij/fac_shield(j)*2.0*sss
3953
3954            enddo
3955            endif
3956 c          do k=1,3
3957 c            ghalf=0.5D0*ggg(k)
3958 c            gelc(k,i)=gelc(k,i)+ghalf
3959 c            gelc(k,j)=gelc(k,j)+ghalf
3960 c          enddo
3961 c 9/28/08 AL Gradient compotents will be summed only at the end
3962 C           print *,"before", gelc_long(1,i), gelc_long(1,j)
3963           do k=1,3
3964             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
3965 C     &                    +grad_shield(k,j)*eesij/fac_shield(j)
3966             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
3967 C     &                    +grad_shield(k,i)*eesij/fac_shield(i)
3968 C            gelc_long(k,i-1)=gelc_long(k,i-1)
3969 C     &                    +grad_shield(k,i)*eesij/fac_shield(i)
3970 C            gelc_long(k,j-1)=gelc_long(k,j-1)
3971 C     &                    +grad_shield(k,j)*eesij/fac_shield(j)
3972           enddo
3973 C           print *,"bafter", gelc_long(1,i), gelc_long(1,j)
3974
3975 *
3976 * Loop over residues i+1 thru j-1.
3977 *
3978 cgrad          do k=i+1,j-1
3979 cgrad            do l=1,3
3980 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3981 cgrad            enddo
3982 cgrad          enddo
3983           facvdw=facvdw+sssgrad*rmij*evdwij
3984           ggg(1)=facvdw*xj
3985           ggg(2)=facvdw*yj
3986           ggg(3)=facvdw*zj
3987 c          do k=1,3
3988 c            ghalf=0.5D0*ggg(k)
3989 c            gvdwpp(k,i)=gvdwpp(k,i)+ghalf
3990 c            gvdwpp(k,j)=gvdwpp(k,j)+ghalf
3991 c          enddo
3992 c 9/28/08 AL Gradient compotents will be summed only at the end
3993           do k=1,3
3994             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
3995             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
3996           enddo
3997 *
3998 * Loop over residues i+1 thru j-1.
3999 *
4000 cgrad          do k=i+1,j-1
4001 cgrad            do l=1,3
4002 cgrad              gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
4003 cgrad            enddo
4004 cgrad          enddo
4005 #else
4006 C MARYSIA
4007           facvdw=(ev1+evdwij)
4008           facel=(el1+eesij)
4009           fac1=fac
4010           fac=-3*rrmij*(facvdw+facvdw+facel)*sss
4011      &       +(evdwij+eesij)*sssgrad*rrmij
4012           erij(1)=xj*rmij
4013           erij(2)=yj*rmij
4014           erij(3)=zj*rmij
4015 *
4016 * Radial derivatives. First process both termini of the fragment (i,j)
4017 *
4018           ggg(1)=fac*xj
4019 C+eesij*grad_shield(1,i)+eesij*grad_shield(1,j)
4020           ggg(2)=fac*yj
4021 C+eesij*grad_shield(2,i)+eesij*grad_shield(2,j)
4022           ggg(3)=fac*zj
4023 C+eesij*grad_shield(3,i)+eesij*grad_shield(3,j)
4024 c          do k=1,3
4025 c            ghalf=0.5D0*ggg(k)
4026 c            gelc(k,i)=gelc(k,i)+ghalf
4027 c            gelc(k,j)=gelc(k,j)+ghalf
4028 c          enddo
4029 c 9/28/08 AL Gradient compotents will be summed only at the end
4030           do k=1,3
4031             gelc_long(k,j)=gelc(k,j)+ggg(k)
4032             gelc_long(k,i)=gelc(k,i)-ggg(k)
4033           enddo
4034 *
4035 * Loop over residues i+1 thru j-1.
4036 *
4037 cgrad          do k=i+1,j-1
4038 cgrad            do l=1,3
4039 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
4040 cgrad            enddo
4041 cgrad          enddo
4042 c 9/28/08 AL Gradient compotents will be summed only at the end
4043           ggg(1)=facvdw*xj+sssgrad*rmij*evdwij*xj
4044           ggg(2)=facvdw*yj+sssgrad*rmij*evdwij*yj
4045           ggg(3)=facvdw*zj+sssgrad*rmij*evdwij*zj
4046           do k=1,3
4047             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
4048             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
4049           enddo
4050 #endif
4051 *
4052 * Angular part
4053 *
4054           ecosa=2.0D0*fac3*fac1+fac4
4055           fac4=-3.0D0*fac4
4056           fac3=-6.0D0*fac3
4057           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
4058           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
4059           do k=1,3
4060             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
4061             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
4062           enddo
4063 cd        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
4064 cd   &          (dcosg(k),k=1,3)
4065           do k=1,3
4066             ggg(k)=(ecosb*dcosb(k)+ecosg*dcosg(k))*
4067      &      fac_shield(i)**2*fac_shield(j)**2*sss
4068           enddo
4069 c          do k=1,3
4070 c            ghalf=0.5D0*ggg(k)
4071 c            gelc(k,i)=gelc(k,i)+ghalf
4072 c     &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
4073 c     &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
4074 c            gelc(k,j)=gelc(k,j)+ghalf
4075 c     &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
4076 c     &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
4077 c          enddo
4078 cgrad          do k=i+1,j-1
4079 cgrad            do l=1,3
4080 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
4081 cgrad            enddo
4082 cgrad          enddo
4083 C                     print *,"before22", gelc_long(1,i), gelc_long(1,j)
4084           do k=1,3
4085             gelc(k,i)=gelc(k,i)
4086      &           +((ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
4087      &           + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1))*sss
4088      &           *fac_shield(i)**2*fac_shield(j)**2
4089             gelc(k,j)=gelc(k,j)
4090      &           +((ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
4091      &           + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1))*sss
4092      &           *fac_shield(i)**2*fac_shield(j)**2
4093             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
4094             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
4095           enddo
4096 C           print *,"before33", gelc_long(1,i), gelc_long(1,j)
4097
4098 C MARYSIA
4099 c          endif !sscale
4100           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
4101      &        .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0
4102      &        .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
4103 C
4104 C 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
4105 C   energy of a peptide unit is assumed in the form of a second-order
4106 C   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
4107 C   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
4108 C   are computed for EVERY pair of non-contiguous peptide groups.
4109 C
4110
4111           if (j.lt.nres-1) then
4112             j1=j+1
4113             j2=j-1
4114           else
4115             j1=j-1
4116             j2=j-2
4117           endif
4118           kkk=0
4119           lll=0
4120           do k=1,2
4121             do l=1,2
4122               kkk=kkk+1
4123               muij(kkk)=mu(k,i)*mu(l,j)
4124 c              write(iout,*) 'mumu=', mu(k,i),mu(l,j),i,j,k,l
4125 #ifdef NEWCORR
4126              gmuij1(kkk)=gtb1(k,i+1)*mu(l,j)
4127 c             write(iout,*) 'k=',k,i,gtb1(k,i+1),gtb1(k,i+1)*mu(l,j)
4128              gmuij2(kkk)=gUb2(k,i)*mu(l,j)
4129              gmuji1(kkk)=mu(k,i)*gtb1(l,j+1)
4130 c             write(iout,*) 'l=',l,j,gtb1(l,j+1),gtb1(l,j+1)*mu(k,i)
4131              gmuji2(kkk)=mu(k,i)*gUb2(l,j)
4132 #endif
4133             enddo
4134           enddo
4135 #ifdef DEBUG
4136           write (iout,*) 'EELEC: i',i,' j',j
4137           write (iout,*) 'j',j,' j1',j1,' j2',j2
4138           write(iout,*) 'muij',muij
4139 #endif
4140           ury=scalar(uy(1,i),erij)
4141           urz=scalar(uz(1,i),erij)
4142           vry=scalar(uy(1,j),erij)
4143           vrz=scalar(uz(1,j),erij)
4144           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
4145           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
4146           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
4147           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
4148           fac=dsqrt(-ael6i)*r3ij
4149 #ifdef DEBUG
4150           write (iout,*) "ury",ury," urz",urz," vry",vry," vrz",vrz
4151           write (iout,*) "uyvy",scalar(uy(1,i),uy(1,j)),
4152      &      "uyvz",scalar(uy(1,i),uz(1,j)),
4153      &      "uzvy",scalar(uz(1,i),uy(1,j)),
4154      &      "uzvz",scalar(uz(1,i),uz(1,j))
4155           write (iout,*) "a22",a22," a23",a23," a32",a32," a33",a33
4156           write (iout,*) "fac",fac
4157 #endif
4158           a22=a22*fac
4159           a23=a23*fac
4160           a32=a32*fac
4161           a33=a33*fac
4162 #ifdef DEBUG
4163           write (iout,*) "a22",a22," a23",a23," a32",a32," a33",a33
4164 #endif
4165 #undef DEBUG
4166 cd          write (iout,'(4i5,4f10.5)')
4167 cd     &     i,itortyp(itype(i)),j,itortyp(itype(j)),a22,a23,a32,a33
4168 cd          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
4169 cd          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') uy(:,i),uz(:,i),
4170 cd     &      uy(:,j),uz(:,j)
4171 cd          write (iout,'(4f10.5)')
4172 cd     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
4173 cd     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
4174 cd          write (iout,'(4f10.5)') ury,urz,vry,vrz
4175 cd           write (iout,'(9f10.5/)')
4176 cd     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
4177 C Derivatives of the elements of A in virtual-bond vectors
4178           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
4179           do k=1,3
4180             uryg(k,1)=scalar(erder(1,k),uy(1,i))
4181             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
4182             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
4183             urzg(k,1)=scalar(erder(1,k),uz(1,i))
4184             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
4185             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
4186             vryg(k,1)=scalar(erder(1,k),uy(1,j))
4187             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
4188             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
4189             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
4190             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
4191             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
4192           enddo
4193 C Compute radial contributions to the gradient
4194           facr=-3.0d0*rrmij
4195           a22der=a22*facr
4196           a23der=a23*facr
4197           a32der=a32*facr
4198           a33der=a33*facr
4199           agg(1,1)=a22der*xj
4200           agg(2,1)=a22der*yj
4201           agg(3,1)=a22der*zj
4202           agg(1,2)=a23der*xj
4203           agg(2,2)=a23der*yj
4204           agg(3,2)=a23der*zj
4205           agg(1,3)=a32der*xj
4206           agg(2,3)=a32der*yj
4207           agg(3,3)=a32der*zj
4208           agg(1,4)=a33der*xj
4209           agg(2,4)=a33der*yj
4210           agg(3,4)=a33der*zj
4211 C Add the contributions coming from er
4212           fac3=-3.0d0*fac
4213           do k=1,3
4214             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
4215             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
4216             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
4217             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
4218           enddo
4219           do k=1,3
4220 C Derivatives in DC(i)
4221 cgrad            ghalf1=0.5d0*agg(k,1)
4222 cgrad            ghalf2=0.5d0*agg(k,2)
4223 cgrad            ghalf3=0.5d0*agg(k,3)
4224 cgrad            ghalf4=0.5d0*agg(k,4)
4225             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j))
4226      &      -3.0d0*uryg(k,2)*vry)!+ghalf1
4227             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j))
4228      &      -3.0d0*uryg(k,2)*vrz)!+ghalf2
4229             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j))
4230      &      -3.0d0*urzg(k,2)*vry)!+ghalf3
4231             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j))
4232      &      -3.0d0*urzg(k,2)*vrz)!+ghalf4
4233 C Derivatives in DC(i+1)
4234             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j))
4235      &      -3.0d0*uryg(k,3)*vry)!+agg(k,1)
4236             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j))
4237      &      -3.0d0*uryg(k,3)*vrz)!+agg(k,2)
4238             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j))
4239      &      -3.0d0*urzg(k,3)*vry)!+agg(k,3)
4240             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j))
4241      &      -3.0d0*urzg(k,3)*vrz)!+agg(k,4)
4242 C Derivatives in DC(j)
4243             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i))
4244      &      -3.0d0*vryg(k,2)*ury)!+ghalf1
4245             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i))
4246      &      -3.0d0*vrzg(k,2)*ury)!+ghalf2
4247             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i))
4248      &      -3.0d0*vryg(k,2)*urz)!+ghalf3
4249             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i))
4250      &      -3.0d0*vrzg(k,2)*urz)!+ghalf4
4251 C Derivatives in DC(j+1) or DC(nres-1)
4252             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i))
4253      &      -3.0d0*vryg(k,3)*ury)
4254             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i))
4255      &      -3.0d0*vrzg(k,3)*ury)
4256             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i))
4257      &      -3.0d0*vryg(k,3)*urz)
4258             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i))
4259      &      -3.0d0*vrzg(k,3)*urz)
4260 cgrad            if (j.eq.nres-1 .and. i.lt.j-2) then
4261 cgrad              do l=1,4
4262 cgrad                aggj1(k,l)=aggj1(k,l)+agg(k,l)
4263 cgrad              enddo
4264 cgrad            endif
4265           enddo
4266           acipa(1,1)=a22
4267           acipa(1,2)=a23
4268           acipa(2,1)=a32
4269           acipa(2,2)=a33
4270           a22=-a22
4271           a23=-a23
4272           do l=1,2
4273             do k=1,3
4274               agg(k,l)=-agg(k,l)
4275               aggi(k,l)=-aggi(k,l)
4276               aggi1(k,l)=-aggi1(k,l)
4277               aggj(k,l)=-aggj(k,l)
4278               aggj1(k,l)=-aggj1(k,l)
4279             enddo
4280           enddo
4281           if (j.lt.nres-1) then
4282             a22=-a22
4283             a32=-a32
4284             do l=1,3,2
4285               do k=1,3
4286                 agg(k,l)=-agg(k,l)
4287                 aggi(k,l)=-aggi(k,l)
4288                 aggi1(k,l)=-aggi1(k,l)
4289                 aggj(k,l)=-aggj(k,l)
4290                 aggj1(k,l)=-aggj1(k,l)
4291               enddo
4292             enddo
4293           else
4294             a22=-a22
4295             a23=-a23
4296             a32=-a32
4297             a33=-a33
4298             do l=1,4
4299               do k=1,3
4300                 agg(k,l)=-agg(k,l)
4301                 aggi(k,l)=-aggi(k,l)
4302                 aggi1(k,l)=-aggi1(k,l)
4303                 aggj(k,l)=-aggj(k,l)
4304                 aggj1(k,l)=-aggj1(k,l)
4305               enddo
4306             enddo
4307           endif
4308           ENDIF ! WCORR
4309           IF (wel_loc.gt.0.0d0) THEN
4310 C Contribution to the local-electrostatic energy coming from the i-j pair
4311           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3)
4312      &     +a33*muij(4)
4313 #ifdef DEBUG
4314           write (iout,*) "muij",muij," a22",a22," a23",a23," a32",a32,
4315      &     " a33",a33
4316           write (iout,*) "ij",i,j," eel_loc_ij",eel_loc_ij,
4317      &     " wel_loc",wel_loc
4318 #endif
4319           if (shield_mode.eq.0) then
4320            fac_shield(i)=1.0
4321            fac_shield(j)=1.0
4322 C          else
4323 C           fac_shield(i)=0.4
4324 C           fac_shield(j)=0.6
4325           endif
4326           eel_loc_ij=eel_loc_ij
4327      &    *fac_shield(i)*fac_shield(j)*sss
4328 c          if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
4329 c     &            'eelloc',i,j,eel_loc_ij
4330 C Now derivative over eel_loc
4331           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
4332      &  (shield_mode.gt.0)) then
4333 C          print *,i,j
4334
4335           do ilist=1,ishield_list(i)
4336            iresshield=shield_list(ilist,i)
4337            do k=1,3
4338            rlocshield=grad_shield_side(k,ilist,i)*eel_loc_ij
4339      &                                          /fac_shield(i)
4340 C     &      *2.0
4341            gshieldx_ll(k,iresshield)=gshieldx_ll(k,iresshield)+
4342      &              rlocshield
4343      & +grad_shield_loc(k,ilist,i)*eel_loc_ij/fac_shield(i)
4344             gshieldc_ll(k,iresshield-1)=gshieldc_ll(k,iresshield-1)
4345      &      +rlocshield
4346            enddo
4347           enddo
4348           do ilist=1,ishield_list(j)
4349            iresshield=shield_list(ilist,j)
4350            do k=1,3
4351            rlocshield=grad_shield_side(k,ilist,j)*eel_loc_ij
4352      &                                       /fac_shield(j)
4353 C     &     *2.0
4354            gshieldx_ll(k,iresshield)=gshieldx_ll(k,iresshield)+
4355      &              rlocshield
4356      & +grad_shield_loc(k,ilist,j)*eel_loc_ij/fac_shield(j)
4357            gshieldc_ll(k,iresshield-1)=gshieldc_ll(k,iresshield-1)
4358      &             +rlocshield
4359
4360            enddo
4361           enddo
4362
4363           do k=1,3
4364             gshieldc_ll(k,i)=gshieldc_ll(k,i)+
4365      &              grad_shield(k,i)*eel_loc_ij/fac_shield(i)
4366             gshieldc_ll(k,j)=gshieldc_ll(k,j)+
4367      &              grad_shield(k,j)*eel_loc_ij/fac_shield(j)
4368             gshieldc_ll(k,i-1)=gshieldc_ll(k,i-1)+
4369      &              grad_shield(k,i)*eel_loc_ij/fac_shield(i)
4370             gshieldc_ll(k,j-1)=gshieldc_ll(k,j-1)+
4371      &              grad_shield(k,j)*eel_loc_ij/fac_shield(j)
4372            enddo
4373            endif
4374
4375
4376 c          write (iout,*) 'i',i,' j',j,itype(i),itype(j),
4377 c     &                     ' eel_loc_ij',eel_loc_ij
4378 C          write(iout,*) 'muije=',i,j,muij(1),muij(2),muij(3),muij(4)
4379 C Calculate patrial derivative for theta angle
4380 #ifdef NEWCORR
4381          geel_loc_ij=(a22*gmuij1(1)
4382      &     +a23*gmuij1(2)
4383      &     +a32*gmuij1(3)
4384      &     +a33*gmuij1(4))
4385      &    *fac_shield(i)*fac_shield(j)*sss
4386 c         write(iout,*) "derivative over thatai"
4387 c         write(iout,*) a22*gmuij1(1), a23*gmuij1(2) ,a32*gmuij1(3),
4388 c     &   a33*gmuij1(4)
4389          gloc(nphi+i,icg)=gloc(nphi+i,icg)+
4390      &      geel_loc_ij*wel_loc
4391 c         write(iout,*) "derivative over thatai-1"
4392 c         write(iout,*) a22*gmuij2(1), a23*gmuij2(2) ,a32*gmuij2(3),
4393 c     &   a33*gmuij2(4)
4394          geel_loc_ij=
4395      &     a22*gmuij2(1)
4396      &     +a23*gmuij2(2)
4397      &     +a32*gmuij2(3)
4398      &     +a33*gmuij2(4)
4399          gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
4400      &      geel_loc_ij*wel_loc
4401      &    *fac_shield(i)*fac_shield(j)*sss
4402
4403 c  Derivative over j residue
4404          geel_loc_ji=a22*gmuji1(1)
4405      &     +a23*gmuji1(2)
4406      &     +a32*gmuji1(3)
4407      &     +a33*gmuji1(4)
4408 c         write(iout,*) "derivative over thataj"
4409 c         write(iout,*) a22*gmuji1(1), a23*gmuji1(2) ,a32*gmuji1(3),
4410 c     &   a33*gmuji1(4)
4411
4412         gloc(nphi+j,icg)=gloc(nphi+j,icg)+
4413      &      geel_loc_ji*wel_loc
4414      &    *fac_shield(i)*fac_shield(j)*sss
4415
4416          geel_loc_ji=
4417      &     +a22*gmuji2(1)
4418      &     +a23*gmuji2(2)
4419      &     +a32*gmuji2(3)
4420      &     +a33*gmuji2(4)
4421 c         write(iout,*) "derivative over thataj-1"
4422 c         write(iout,*) a22*gmuji2(1), a23*gmuji2(2) ,a32*gmuji2(3),
4423 c     &   a33*gmuji2(4)
4424          gloc(nphi+j-1,icg)=gloc(nphi+j-1,icg)+
4425      &      geel_loc_ji*wel_loc
4426      &    *fac_shield(i)*fac_shield(j)*sss
4427 #endif
4428 cd          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
4429
4430           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
4431      &            'eelloc',i,j,eel_loc_ij
4432 c           if (eel_loc_ij.ne.0)
4433 c     &      write (iout,'(a4,2i4,8f9.5)')'chuj',
4434 c     &     i,j,a22,muij(1),a23,muij(2),a32,muij(3),a33,muij(4)
4435
4436           eel_loc=eel_loc+eel_loc_ij
4437 C Partial derivatives in virtual-bond dihedral angles gamma
4438           if (i.gt.1)
4439      &    gel_loc_loc(i-1)=gel_loc_loc(i-1)+
4440      &            (a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j)
4441      &           +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j))
4442      &    *fac_shield(i)*fac_shield(j)*sss
4443
4444           gel_loc_loc(j-1)=gel_loc_loc(j-1)+
4445      &           (a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j)
4446      &           +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j))
4447      &    *fac_shield(i)*fac_shield(j)*sss
4448 C Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
4449           aux=eel_loc_ij/sss*sssgrad*rmij
4450           ggg(1)=aux*xj
4451           ggg(2)=aux*yj
4452           ggg(3)=aux*zj
4453           do l=1,3
4454             ggg(l)=ggg(l)+(agg(l,1)*muij(1)+
4455      &          agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4))
4456      &    *fac_shield(i)*fac_shield(j)*sss
4457             gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l)
4458             gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l)
4459 cgrad            ghalf=0.5d0*ggg(l)
4460 cgrad            gel_loc(l,i)=gel_loc(l,i)+ghalf
4461 cgrad            gel_loc(l,j)=gel_loc(l,j)+ghalf
4462           enddo
4463 cgrad          do k=i+1,j2
4464 cgrad            do l=1,3
4465 cgrad              gel_loc(l,k)=gel_loc(l,k)+ggg(l)
4466 cgrad            enddo
4467 cgrad          enddo
4468 C Remaining derivatives of eello
4469           do l=1,3
4470             gel_loc(l,i)=gel_loc(l,i)+(aggi(l,1)*muij(1)+
4471      &        aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4))
4472      &    *fac_shield(i)*fac_shield(j)*sss
4473
4474             gel_loc(l,i+1)=gel_loc(l,i+1)+(aggi1(l,1)*muij(1)+
4475      &     aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4))
4476      &    *fac_shield(i)*fac_shield(j)*sss
4477
4478             gel_loc(l,j)=gel_loc(l,j)+(aggj(l,1)*muij(1)+
4479      &       aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4))
4480      &    *fac_shield(i)*fac_shield(j)*sss
4481
4482             gel_loc(l,j1)=gel_loc(l,j1)+(aggj1(l,1)*muij(1)+
4483      &     aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4))
4484      &    *fac_shield(i)*fac_shield(j)*sss
4485
4486           enddo
4487           ENDIF
4488 C Change 12/26/95 to calculate four-body contributions to H-bonding energy
4489 c          if (j.gt.i+1 .and. num_conti.le.maxconts) then
4490 #ifdef FOURBODY
4491           if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0
4492      &       .and. num_conti.le.maxconts) then
4493 c            write (iout,*) i,j," entered corr"
4494 C
4495 C Calculate the contact function. The ith column of the array JCONT will
4496 C contain the numbers of atoms that make contacts with the atom I (of numbers
4497 C greater than I). The arrays FACONT and GACONT will contain the values of
4498 C the contact function and its derivative.
4499 c           r0ij=1.02D0*rpp(iteli,itelj)
4500 c           r0ij=1.11D0*rpp(iteli,itelj)
4501             r0ij=2.20D0*rpp(iteli,itelj)
4502 c           r0ij=1.55D0*rpp(iteli,itelj)
4503             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
4504             if (fcont.gt.0.0D0) then
4505               num_conti=num_conti+1
4506               if (num_conti.gt.maxconts) then
4507                 write (iout,*) 'WARNING - max. # of contacts exceeded;',
4508      &                         ' will skip next contacts for this conf.'
4509               else
4510                 jcont_hb(num_conti,i)=j
4511 cd                write (iout,*) "i",i," j",j," num_conti",num_conti,
4512 cd     &           " jcont_hb",jcont_hb(num_conti,i)
4513                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.
4514      &          wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
4515 C 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
4516 C  terms.
4517                 d_cont(num_conti,i)=rij
4518 cd                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
4519 C     --- Electrostatic-interaction matrix ---
4520                 a_chuj(1,1,num_conti,i)=a22
4521                 a_chuj(1,2,num_conti,i)=a23
4522                 a_chuj(2,1,num_conti,i)=a32
4523                 a_chuj(2,2,num_conti,i)=a33
4524 C     --- Gradient of rij
4525                 do kkk=1,3
4526                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
4527                 enddo
4528                 kkll=0
4529                 do k=1,2
4530                   do l=1,2
4531                     kkll=kkll+1
4532                     do m=1,3
4533                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
4534                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
4535                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
4536                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
4537                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
4538                     enddo
4539                   enddo
4540                 enddo
4541                 ENDIF
4542                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
4543 C Calculate contact energies
4544                 cosa4=4.0D0*cosa
4545                 wij=cosa-3.0D0*cosb*cosg
4546                 cosbg1=cosb+cosg
4547                 cosbg2=cosb-cosg
4548 c               fac3=dsqrt(-ael6i)/r0ij**3
4549                 fac3=dsqrt(-ael6i)*r3ij
4550 c                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
4551                 ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
4552                 if (ees0tmp.gt.0) then
4553                   ees0pij=dsqrt(ees0tmp)
4554                 else
4555                   ees0pij=0
4556                 endif
4557 c                ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
4558                 ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
4559                 if (ees0tmp.gt.0) then
4560                   ees0mij=dsqrt(ees0tmp)
4561                 else
4562                   ees0mij=0
4563                 endif
4564 c               ees0mij=0.0D0
4565                 if (shield_mode.eq.0) then
4566                 fac_shield(i)=1.0d0
4567                 fac_shield(j)=1.0d0
4568                 else
4569                 ees0plist(num_conti,i)=j
4570 C                fac_shield(i)=0.4d0
4571 C                fac_shield(j)=0.6d0
4572                 endif
4573                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij)
4574      &          *fac_shield(i)*fac_shield(j)*sss
4575                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij)
4576      &          *fac_shield(i)*fac_shield(j)*sss
4577 C Diagnostics. Comment out or remove after debugging!
4578 c               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
4579 c               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
4580 c               ees0m(num_conti,i)=0.0D0
4581 C End diagnostics.
4582 c               write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
4583 c    & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
4584 C Angular derivatives of the contact function
4585                 ees0pij1=fac3/ees0pij
4586                 ees0mij1=fac3/ees0mij
4587                 fac3p=-3.0D0*fac3*rrmij
4588                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
4589                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
4590 c               ees0mij1=0.0D0
4591                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
4592                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
4593                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
4594                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
4595                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
4596                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
4597                 ecosap=ecosa1+ecosa2
4598                 ecosbp=ecosb1+ecosb2
4599                 ecosgp=ecosg1+ecosg2
4600                 ecosam=ecosa1-ecosa2
4601                 ecosbm=ecosb1-ecosb2
4602                 ecosgm=ecosg1-ecosg2
4603 C Diagnostics
4604 c               ecosap=ecosa1
4605 c               ecosbp=ecosb1
4606 c               ecosgp=ecosg1
4607 c               ecosam=0.0D0
4608 c               ecosbm=0.0D0
4609 c               ecosgm=0.0D0
4610 C End diagnostics
4611                 facont_hb(num_conti,i)=fcont
4612                 fprimcont=fprimcont/rij
4613 cd              facont_hb(num_conti,i)=1.0D0
4614 C Following line is for diagnostics.
4615 cd              fprimcont=0.0D0
4616                 do k=1,3
4617                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
4618                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
4619                 enddo
4620                 do k=1,3
4621                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
4622                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
4623                 enddo
4624                 gggp(1)=gggp(1)+ees0pijp*xj
4625      &          +ees0p(num_conti,i)/sss*rmij*xj*sssgrad
4626                 gggp(2)=gggp(2)+ees0pijp*yj
4627      &          +ees0p(num_conti,i)/sss*rmij*yj*sssgrad
4628                 gggp(3)=gggp(3)+ees0pijp*zj
4629      &          +ees0p(num_conti,i)/sss*rmij*zj*sssgrad
4630                 gggm(1)=gggm(1)+ees0mijp*xj
4631      &          +ees0m(num_conti,i)/sss*rmij*xj*sssgrad
4632                 gggm(2)=gggm(2)+ees0mijp*yj
4633      &          +ees0m(num_conti,i)/sss*rmij*yj*sssgrad
4634                 gggm(3)=gggm(3)+ees0mijp*zj
4635      &          +ees0m(num_conti,i)/sss*rmij*zj*sssgrad
4636 C Derivatives due to the contact function
4637                 gacont_hbr(1,num_conti,i)=fprimcont*xj
4638                 gacont_hbr(2,num_conti,i)=fprimcont*yj
4639                 gacont_hbr(3,num_conti,i)=fprimcont*zj
4640                 do k=1,3
4641 c
4642 c 10/24/08 cgrad and ! comments indicate the parts of the code removed
4643 c          following the change of gradient-summation algorithm.
4644 c
4645 cgrad                  ghalfp=0.5D0*gggp(k)
4646 cgrad                  ghalfm=0.5D0*gggm(k)
4647                   gacontp_hb1(k,num_conti,i)=!ghalfp
4648      &              +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i))
4649      &              + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
4650      &          *fac_shield(i)*fac_shield(j)*sss
4651
4652                   gacontp_hb2(k,num_conti,i)=!ghalfp
4653      &              +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j))
4654      &              + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
4655      &          *fac_shield(i)*fac_shield(j)*sss
4656
4657                   gacontp_hb3(k,num_conti,i)=gggp(k)
4658      &          *fac_shield(i)*fac_shield(j)*sss
4659
4660                   gacontm_hb1(k,num_conti,i)=!ghalfm
4661      &              +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i))
4662      &              + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
4663      &          *fac_shield(i)*fac_shield(j)*sss
4664
4665                   gacontm_hb2(k,num_conti,i)=!ghalfm
4666      &              +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j))
4667      &              + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
4668      &          *fac_shield(i)*fac_shield(j)*sss
4669
4670                   gacontm_hb3(k,num_conti,i)=gggm(k)
4671      &          *fac_shield(i)*fac_shield(j)*sss
4672
4673                 enddo
4674 C Diagnostics. Comment out or remove after debugging!
4675 cdiag           do k=1,3
4676 cdiag             gacontp_hb1(k,num_conti,i)=0.0D0
4677 cdiag             gacontp_hb2(k,num_conti,i)=0.0D0
4678 cdiag             gacontp_hb3(k,num_conti,i)=0.0D0
4679 cdiag             gacontm_hb1(k,num_conti,i)=0.0D0
4680 cdiag             gacontm_hb2(k,num_conti,i)=0.0D0
4681 cdiag             gacontm_hb3(k,num_conti,i)=0.0D0
4682 cdiag           enddo
4683               ENDIF ! wcorr
4684               endif  ! num_conti.le.maxconts
4685             endif  ! fcont.gt.0
4686           endif    ! j.gt.i+1
4687 #endif
4688           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
4689             do k=1,4
4690               do l=1,3
4691                 ghalf=0.5d0*agg(l,k)
4692                 aggi(l,k)=aggi(l,k)+ghalf
4693                 aggi1(l,k)=aggi1(l,k)+agg(l,k)
4694                 aggj(l,k)=aggj(l,k)+ghalf
4695               enddo
4696             enddo
4697             if (j.eq.nres-1 .and. i.lt.j-2) then
4698               do k=1,4
4699                 do l=1,3
4700                   aggj1(l,k)=aggj1(l,k)+agg(l,k)
4701                 enddo
4702               enddo
4703             endif
4704           endif
4705 c          t_eelecij=t_eelecij+MPI_Wtime()-time00
4706       return
4707       end
4708 C-----------------------------------------------------------------------------
4709       subroutine eturn3(i,eello_turn3)
4710 C Third- and fourth-order contributions from turns
4711       implicit real*8 (a-h,o-z)
4712       include 'DIMENSIONS'
4713       include 'COMMON.IOUNITS'
4714       include 'COMMON.GEO'
4715       include 'COMMON.VAR'
4716       include 'COMMON.LOCAL'
4717       include 'COMMON.CHAIN'
4718       include 'COMMON.DERIV'
4719       include 'COMMON.INTERACT'
4720       include 'COMMON.CORRMAT'
4721       include 'COMMON.TORSION'
4722       include 'COMMON.VECTORS'
4723       include 'COMMON.FFIELD'
4724       include 'COMMON.CONTROL'
4725       include 'COMMON.SHIELD'
4726       dimension ggg(3)
4727       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
4728      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
4729      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2),gpizda1(2,2),
4730      &  gpizda2(2,2),auxgmat1(2,2),auxgmatt1(2,2),
4731      &  auxgmat2(2,2),auxgmatt2(2,2)
4732       double precision agg(3,4),aggi(3,4),aggi1(3,4),
4733      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
4734       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
4735      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
4736      &    num_conti,j1,j2
4737       j=i+2
4738 c      write (iout,*) "eturn3",i,j,j1,j2
4739       a_temp(1,1)=a22
4740       a_temp(1,2)=a23
4741       a_temp(2,1)=a32
4742       a_temp(2,2)=a33
4743 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4744 C
4745 C               Third-order contributions
4746 C
4747 C                 (i+2)o----(i+3)
4748 C                      | |
4749 C                      | |
4750 C                 (i+1)o----i
4751 C
4752 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4753 cd        call checkint_turn3(i,a_temp,eello_turn3_num)
4754         call matmat2(EUg(1,1,i+1),EUg(1,1,i+2),auxmat(1,1))
4755 c auxalary matices for theta gradient
4756 c auxalary matrix for i+1 and constant i+2
4757         call matmat2(gtEUg(1,1,i+1),EUg(1,1,i+2),auxgmat1(1,1))
4758 c auxalary matrix for i+2 and constant i+1
4759         call matmat2(EUg(1,1,i+1),gtEUg(1,1,i+2),auxgmat2(1,1))
4760         call transpose2(auxmat(1,1),auxmat1(1,1))
4761         call transpose2(auxgmat1(1,1),auxgmatt1(1,1))
4762         call transpose2(auxgmat2(1,1),auxgmatt2(1,1))
4763         call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4764         call matmat2(a_temp(1,1),auxgmatt1(1,1),gpizda1(1,1))
4765         call matmat2(a_temp(1,1),auxgmatt2(1,1),gpizda2(1,1))
4766         if (shield_mode.eq.0) then
4767         fac_shield(i)=1.0
4768         fac_shield(j)=1.0
4769 C        else
4770 C        fac_shield(i)=0.4
4771 C        fac_shield(j)=0.6
4772         endif
4773         eello_turn3=eello_turn3+0.5d0*(pizda(1,1)+pizda(2,2))
4774      &  *fac_shield(i)*fac_shield(j)
4775         eello_t3=0.5d0*(pizda(1,1)+pizda(2,2))
4776      &  *fac_shield(i)*fac_shield(j)
4777         if (energy_dec) write (iout,'(6heturn3,2i5,0pf7.3)') i,i+2,
4778      &    eello_t3
4779 C#ifdef NEWCORR
4780 C Derivatives in theta
4781         gloc(nphi+i,icg)=gloc(nphi+i,icg)
4782      &  +0.5d0*(gpizda1(1,1)+gpizda1(2,2))*wturn3
4783      &   *fac_shield(i)*fac_shield(j)
4784         gloc(nphi+i+1,icg)=gloc(nphi+i+1,icg)
4785      &  +0.5d0*(gpizda2(1,1)+gpizda2(2,2))*wturn3
4786      &   *fac_shield(i)*fac_shield(j)
4787 C#endif
4788
4789 C Derivatives in shield mode
4790           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
4791      &  (shield_mode.gt.0)) then
4792 C          print *,i,j
4793
4794           do ilist=1,ishield_list(i)
4795            iresshield=shield_list(ilist,i)
4796            do k=1,3
4797            rlocshield=grad_shield_side(k,ilist,i)*eello_t3/fac_shield(i)
4798 C     &      *2.0
4799            gshieldx_t3(k,iresshield)=gshieldx_t3(k,iresshield)+
4800      &              rlocshield
4801      & +grad_shield_loc(k,ilist,i)*eello_t3/fac_shield(i)
4802             gshieldc_t3(k,iresshield-1)=gshieldc_t3(k,iresshield-1)
4803      &      +rlocshield
4804            enddo
4805           enddo
4806           do ilist=1,ishield_list(j)
4807            iresshield=shield_list(ilist,j)
4808            do k=1,3
4809            rlocshield=grad_shield_side(k,ilist,j)*eello_t3/fac_shield(j)
4810 C     &     *2.0
4811            gshieldx_t3(k,iresshield)=gshieldx_t3(k,iresshield)+
4812      &              rlocshield
4813      & +grad_shield_loc(k,ilist,j)*eello_t3/fac_shield(j)
4814            gshieldc_t3(k,iresshield-1)=gshieldc_t3(k,iresshield-1)
4815      &             +rlocshield
4816
4817            enddo
4818           enddo
4819
4820           do k=1,3
4821             gshieldc_t3(k,i)=gshieldc_t3(k,i)+
4822      &              grad_shield(k,i)*eello_t3/fac_shield(i)
4823             gshieldc_t3(k,j)=gshieldc_t3(k,j)+
4824      &              grad_shield(k,j)*eello_t3/fac_shield(j)
4825             gshieldc_t3(k,i-1)=gshieldc_t3(k,i-1)+
4826      &              grad_shield(k,i)*eello_t3/fac_shield(i)
4827             gshieldc_t3(k,j-1)=gshieldc_t3(k,j-1)+
4828      &              grad_shield(k,j)*eello_t3/fac_shield(j)
4829            enddo
4830            endif
4831
4832 C        if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
4833 cd        write (2,*) 'i,',i,' j',j,'eello_turn3',
4834 cd     &    0.5d0*(pizda(1,1)+pizda(2,2)),
4835 cd     &    ' eello_turn3_num',4*eello_turn3_num
4836 C Derivatives in gamma(i)
4837         call matmat2(EUgder(1,1,i+1),EUg(1,1,i+2),auxmat2(1,1))
4838         call transpose2(auxmat2(1,1),auxmat3(1,1))
4839         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
4840         gel_loc_turn3(i)=gel_loc_turn3(i)+0.5d0*(pizda(1,1)+pizda(2,2))
4841      &   *fac_shield(i)*fac_shield(j)
4842 C Derivatives in gamma(i+1)
4843         call matmat2(EUg(1,1,i+1),EUgder(1,1,i+2),auxmat2(1,1))
4844         call transpose2(auxmat2(1,1),auxmat3(1,1))
4845         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
4846         gel_loc_turn3(i+1)=gel_loc_turn3(i+1)
4847      &    +0.5d0*(pizda(1,1)+pizda(2,2))
4848      &   *fac_shield(i)*fac_shield(j)
4849 C Cartesian derivatives
4850         do l=1,3
4851 c            ghalf1=0.5d0*agg(l,1)
4852 c            ghalf2=0.5d0*agg(l,2)
4853 c            ghalf3=0.5d0*agg(l,3)
4854 c            ghalf4=0.5d0*agg(l,4)
4855           a_temp(1,1)=aggi(l,1)!+ghalf1
4856           a_temp(1,2)=aggi(l,2)!+ghalf2
4857           a_temp(2,1)=aggi(l,3)!+ghalf3
4858           a_temp(2,2)=aggi(l,4)!+ghalf4
4859           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4860           gcorr3_turn(l,i)=gcorr3_turn(l,i)
4861      &      +0.5d0*(pizda(1,1)+pizda(2,2))
4862      &   *fac_shield(i)*fac_shield(j)
4863
4864           a_temp(1,1)=aggi1(l,1)!+agg(l,1)
4865           a_temp(1,2)=aggi1(l,2)!+agg(l,2)
4866           a_temp(2,1)=aggi1(l,3)!+agg(l,3)
4867           a_temp(2,2)=aggi1(l,4)!+agg(l,4)
4868           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4869           gcorr3_turn(l,i+1)=gcorr3_turn(l,i+1)
4870      &      +0.5d0*(pizda(1,1)+pizda(2,2))
4871      &   *fac_shield(i)*fac_shield(j)
4872           a_temp(1,1)=aggj(l,1)!+ghalf1
4873           a_temp(1,2)=aggj(l,2)!+ghalf2
4874           a_temp(2,1)=aggj(l,3)!+ghalf3
4875           a_temp(2,2)=aggj(l,4)!+ghalf4
4876           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4877           gcorr3_turn(l,j)=gcorr3_turn(l,j)
4878      &      +0.5d0*(pizda(1,1)+pizda(2,2))
4879      &   *fac_shield(i)*fac_shield(j)
4880           a_temp(1,1)=aggj1(l,1)
4881           a_temp(1,2)=aggj1(l,2)
4882           a_temp(2,1)=aggj1(l,3)
4883           a_temp(2,2)=aggj1(l,4)
4884           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4885           gcorr3_turn(l,j1)=gcorr3_turn(l,j1)
4886      &      +0.5d0*(pizda(1,1)+pizda(2,2))
4887      &   *fac_shield(i)*fac_shield(j)
4888         enddo
4889       return
4890       end
4891 C-------------------------------------------------------------------------------
4892       subroutine eturn4(i,eello_turn4)
4893 C Third- and fourth-order contributions from turns
4894       implicit real*8 (a-h,o-z)
4895       include 'DIMENSIONS'
4896       include 'COMMON.IOUNITS'
4897       include 'COMMON.GEO'
4898       include 'COMMON.VAR'
4899       include 'COMMON.LOCAL'
4900       include 'COMMON.CHAIN'
4901       include 'COMMON.DERIV'
4902       include 'COMMON.INTERACT'
4903       include 'COMMON.CORRMAT'
4904       include 'COMMON.TORSION'
4905       include 'COMMON.VECTORS'
4906       include 'COMMON.FFIELD'
4907       include 'COMMON.CONTROL'
4908       include 'COMMON.SHIELD'
4909       dimension ggg(3)
4910       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
4911      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
4912      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2),auxgvec(2),
4913      &  auxgEvec1(2),auxgEvec2(2),auxgEvec3(2),
4914      &  gte1t(2,2),gte2t(2,2),gte3t(2,2),
4915      &  gte1a(2,2),gtae3(2,2),gtae3e2(2,2), ae3gte2(2,2),
4916      &  gtEpizda1(2,2),gtEpizda2(2,2),gtEpizda3(2,2)
4917       double precision agg(3,4),aggi(3,4),aggi1(3,4),
4918      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
4919       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
4920      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
4921      &    num_conti,j1,j2
4922       j=i+3
4923 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4924 C
4925 C               Fourth-order contributions
4926 C
4927 C                 (i+3)o----(i+4)
4928 C                     /  |
4929 C               (i+2)o   |
4930 C                     \  |
4931 C                 (i+1)o----i
4932 C
4933 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4934 cd        call checkint_turn4(i,a_temp,eello_turn4_num)
4935 c        write (iout,*) "eturn4 i",i," j",j," j1",j1," j2",j2
4936 c        write(iout,*)"WCHODZE W PROGRAM"
4937         a_temp(1,1)=a22
4938         a_temp(1,2)=a23
4939         a_temp(2,1)=a32
4940         a_temp(2,2)=a33
4941         iti1=itype2loc(itype(i+1))
4942         iti2=itype2loc(itype(i+2))
4943         iti3=itype2loc(itype(i+3))
4944 c        write(iout,*) "iti1",iti1," iti2",iti2," iti3",iti3
4945         call transpose2(EUg(1,1,i+1),e1t(1,1))
4946         call transpose2(Eug(1,1,i+2),e2t(1,1))
4947         call transpose2(Eug(1,1,i+3),e3t(1,1))
4948 C Ematrix derivative in theta
4949         call transpose2(gtEUg(1,1,i+1),gte1t(1,1))
4950         call transpose2(gtEug(1,1,i+2),gte2t(1,1))
4951         call transpose2(gtEug(1,1,i+3),gte3t(1,1))
4952         call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4953 c       eta1 in derivative theta
4954         call matmat2(gte1t(1,1),a_temp(1,1),gte1a(1,1))
4955         call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4956 c       auxgvec is derivative of Ub2 so i+3 theta
4957         call matvec2(e1a(1,1),gUb2(1,i+3),auxgvec(1))
4958 c       auxalary matrix of E i+1
4959         call matvec2(gte1a(1,1),Ub2(1,i+3),auxgEvec1(1))
4960 c        s1=0.0
4961 c        gs1=0.0
4962         s1=scalar2(b1(1,i+2),auxvec(1))
4963 c derivative of theta i+2 with constant i+3
4964         gs23=scalar2(gtb1(1,i+2),auxvec(1))
4965 c derivative of theta i+2 with constant i+2
4966         gs32=scalar2(b1(1,i+2),auxgvec(1))
4967 c derivative of E matix in theta of i+1
4968         gsE13=scalar2(b1(1,i+2),auxgEvec1(1))
4969
4970         call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4971 c       ea31 in derivative theta
4972         call matmat2(a_temp(1,1),gte3t(1,1),gtae3(1,1))
4973         call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4974 c auxilary matrix auxgvec of Ub2 with constant E matirx
4975         call matvec2(ae3(1,1),gUb2(1,i+2),auxgvec(1))
4976 c auxilary matrix auxgEvec1 of E matix with Ub2 constant
4977         call matvec2(gtae3(1,1),Ub2(1,i+2),auxgEvec3(1))
4978
4979 c        s2=0.0
4980 c        gs2=0.0
4981         s2=scalar2(b1(1,i+1),auxvec(1))
4982 c derivative of theta i+1 with constant i+3
4983         gs13=scalar2(gtb1(1,i+1),auxvec(1))
4984 c derivative of theta i+2 with constant i+1
4985         gs21=scalar2(b1(1,i+1),auxgvec(1))
4986 c derivative of theta i+3 with constant i+1
4987         gsE31=scalar2(b1(1,i+1),auxgEvec3(1))
4988 c        write(iout,*) gs1,gs2,'i=',i,auxgvec(1),gUb2(1,i+2),gtb1(1,i+2),
4989 c     &  gtb1(1,i+1)
4990         call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4991 c two derivatives over diffetent matrices
4992 c gtae3e2 is derivative over i+3
4993         call matmat2(gtae3(1,1),e2t(1,1),gtae3e2(1,1))
4994 c ae3gte2 is derivative over i+2
4995         call matmat2(ae3(1,1),gte2t(1,1),ae3gte2(1,1))
4996         call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4997 c three possible derivative over theta E matices
4998 c i+1
4999         call matmat2(ae3e2(1,1),gte1t(1,1),gtEpizda1(1,1))
5000 c i+2
5001         call matmat2(ae3gte2(1,1),e1t(1,1),gtEpizda2(1,1))
5002 c i+3
5003         call matmat2(gtae3e2(1,1),e1t(1,1),gtEpizda3(1,1))
5004         s3=0.5d0*(pizda(1,1)+pizda(2,2))
5005
5006         gsEE1=0.5d0*(gtEpizda1(1,1)+gtEpizda1(2,2))
5007         gsEE2=0.5d0*(gtEpizda2(1,1)+gtEpizda2(2,2))
5008         gsEE3=0.5d0*(gtEpizda3(1,1)+gtEpizda3(2,2))
5009         if (shield_mode.eq.0) then
5010         fac_shield(i)=1.0
5011         fac_shield(j)=1.0
5012 C        else
5013 C        fac_shield(i)=0.6
5014 C        fac_shield(j)=0.4
5015         endif
5016         eello_turn4=eello_turn4-(s1+s2+s3)
5017      &  *fac_shield(i)*fac_shield(j)
5018         eello_t4=-(s1+s2+s3)
5019      &  *fac_shield(i)*fac_shield(j)
5020 c             write(iout,*)'chujOWO', auxvec(1),b1(1,iti2)
5021         if (energy_dec) write (iout,'(a6,2i5,0pf7.3,3f7.3)')
5022      &      'eturn4',i,j,-(s1+s2+s3),s1,s2,s3
5023 C Now derivative over shield:
5024           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
5025      &  (shield_mode.gt.0)) then
5026 C          print *,i,j
5027
5028           do ilist=1,ishield_list(i)
5029            iresshield=shield_list(ilist,i)
5030            do k=1,3
5031            rlocshield=grad_shield_side(k,ilist,i)*eello_t4/fac_shield(i)
5032 C     &      *2.0
5033            gshieldx_t4(k,iresshield)=gshieldx_t4(k,iresshield)+
5034      &              rlocshield
5035      & +grad_shield_loc(k,ilist,i)*eello_t4/fac_shield(i)
5036             gshieldc_t4(k,iresshield-1)=gshieldc_t4(k,iresshield-1)
5037      &      +rlocshield
5038            enddo
5039           enddo
5040           do ilist=1,ishield_list(j)
5041            iresshield=shield_list(ilist,j)
5042            do k=1,3
5043            rlocshield=grad_shield_side(k,ilist,j)*eello_t4/fac_shield(j)
5044 C     &     *2.0
5045            gshieldx_t4(k,iresshield)=gshieldx_t4(k,iresshield)+
5046      &              rlocshield
5047      & +grad_shield_loc(k,ilist,j)*eello_t4/fac_shield(j)
5048            gshieldc_t4(k,iresshield-1)=gshieldc_t4(k,iresshield-1)
5049      &             +rlocshield
5050
5051            enddo
5052           enddo
5053
5054           do k=1,3
5055             gshieldc_t4(k,i)=gshieldc_t4(k,i)+
5056      &              grad_shield(k,i)*eello_t4/fac_shield(i)
5057             gshieldc_t4(k,j)=gshieldc_t4(k,j)+
5058      &              grad_shield(k,j)*eello_t4/fac_shield(j)
5059             gshieldc_t4(k,i-1)=gshieldc_t4(k,i-1)+
5060      &              grad_shield(k,i)*eello_t4/fac_shield(i)
5061             gshieldc_t4(k,j-1)=gshieldc_t4(k,j-1)+
5062      &              grad_shield(k,j)*eello_t4/fac_shield(j)
5063            enddo
5064            endif
5065
5066
5067
5068
5069
5070
5071 cd        write (2,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
5072 cd     &    ' eello_turn4_num',8*eello_turn4_num
5073 #ifdef NEWCORR
5074         gloc(nphi+i,icg)=gloc(nphi+i,icg)
5075      &                  -(gs13+gsE13+gsEE1)*wturn4
5076      &  *fac_shield(i)*fac_shield(j)
5077         gloc(nphi+i+1,icg)= gloc(nphi+i+1,icg)
5078      &                    -(gs23+gs21+gsEE2)*wturn4
5079      &  *fac_shield(i)*fac_shield(j)
5080
5081         gloc(nphi+i+2,icg)= gloc(nphi+i+2,icg)
5082      &                    -(gs32+gsE31+gsEE3)*wturn4
5083      &  *fac_shield(i)*fac_shield(j)
5084
5085 c         gloc(nphi+i+1,icg)=gloc(nphi+i+1,icg)-
5086 c     &   gs2
5087 #endif
5088         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
5089      &      'eturn4',i,j,-(s1+s2+s3)
5090 c        write (iout,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
5091 c     &    ' eello_turn4_num',8*eello_turn4_num
5092 C Derivatives in gamma(i)
5093         call transpose2(EUgder(1,1,i+1),e1tder(1,1))
5094         call matmat2(e1tder(1,1),a_temp(1,1),auxmat(1,1))
5095         call matvec2(auxmat(1,1),Ub2(1,i+3),auxvec(1))
5096         s1=scalar2(b1(1,i+2),auxvec(1))
5097         call matmat2(ae3e2(1,1),e1tder(1,1),pizda(1,1))
5098         s3=0.5d0*(pizda(1,1)+pizda(2,2))
5099         gel_loc_turn4(i)=gel_loc_turn4(i)-(s1+s3)
5100      &  *fac_shield(i)*fac_shield(j)
5101 C Derivatives in gamma(i+1)
5102         call transpose2(EUgder(1,1,i+2),e2tder(1,1))
5103         call matvec2(ae3(1,1),Ub2der(1,i+2),auxvec(1))
5104         s2=scalar2(b1(1,i+1),auxvec(1))
5105         call matmat2(ae3(1,1),e2tder(1,1),auxmat(1,1))
5106         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
5107         s3=0.5d0*(pizda(1,1)+pizda(2,2))
5108         gel_loc_turn4(i+1)=gel_loc_turn4(i+1)-(s2+s3)
5109      &  *fac_shield(i)*fac_shield(j)
5110 C Derivatives in gamma(i+2)
5111         call transpose2(EUgder(1,1,i+3),e3tder(1,1))
5112         call matvec2(e1a(1,1),Ub2der(1,i+3),auxvec(1))
5113         s1=scalar2(b1(1,i+2),auxvec(1))
5114         call matmat2(a_temp(1,1),e3tder(1,1),auxmat(1,1))
5115         call matvec2(auxmat(1,1),Ub2(1,i+2),auxvec(1))
5116         s2=scalar2(b1(1,i+1),auxvec(1))
5117         call matmat2(auxmat(1,1),e2t(1,1),auxmat3(1,1))
5118         call matmat2(auxmat3(1,1),e1t(1,1),pizda(1,1))
5119         s3=0.5d0*(pizda(1,1)+pizda(2,2))
5120         gel_loc_turn4(i+2)=gel_loc_turn4(i+2)-(s1+s2+s3)
5121      &  *fac_shield(i)*fac_shield(j)
5122 C Cartesian derivatives
5123 C Derivatives of this turn contributions in DC(i+2)
5124         if (j.lt.nres-1) then
5125           do l=1,3
5126             a_temp(1,1)=agg(l,1)
5127             a_temp(1,2)=agg(l,2)
5128             a_temp(2,1)=agg(l,3)
5129             a_temp(2,2)=agg(l,4)
5130             call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5131             call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5132             s1=scalar2(b1(1,i+2),auxvec(1))
5133             call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5134             call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5135             s2=scalar2(b1(1,i+1),auxvec(1))
5136             call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5137             call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5138             s3=0.5d0*(pizda(1,1)+pizda(2,2))
5139             ggg(l)=-(s1+s2+s3)
5140             gcorr4_turn(l,i+2)=gcorr4_turn(l,i+2)-(s1+s2+s3)
5141      &  *fac_shield(i)*fac_shield(j)
5142           enddo
5143         endif
5144 C Remaining derivatives of this turn contribution
5145         do l=1,3
5146           a_temp(1,1)=aggi(l,1)
5147           a_temp(1,2)=aggi(l,2)
5148           a_temp(2,1)=aggi(l,3)
5149           a_temp(2,2)=aggi(l,4)
5150           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5151           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5152           s1=scalar2(b1(1,i+2),auxvec(1))
5153           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5154           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5155           s2=scalar2(b1(1,i+1),auxvec(1))
5156           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5157           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5158           s3=0.5d0*(pizda(1,1)+pizda(2,2))
5159           gcorr4_turn(l,i)=gcorr4_turn(l,i)-(s1+s2+s3)
5160      &  *fac_shield(i)*fac_shield(j)
5161           a_temp(1,1)=aggi1(l,1)
5162           a_temp(1,2)=aggi1(l,2)
5163           a_temp(2,1)=aggi1(l,3)
5164           a_temp(2,2)=aggi1(l,4)
5165           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5166           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5167           s1=scalar2(b1(1,i+2),auxvec(1))
5168           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5169           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5170           s2=scalar2(b1(1,i+1),auxvec(1))
5171           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5172           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5173           s3=0.5d0*(pizda(1,1)+pizda(2,2))
5174           gcorr4_turn(l,i+1)=gcorr4_turn(l,i+1)-(s1+s2+s3)
5175      &  *fac_shield(i)*fac_shield(j)
5176           a_temp(1,1)=aggj(l,1)
5177           a_temp(1,2)=aggj(l,2)
5178           a_temp(2,1)=aggj(l,3)
5179           a_temp(2,2)=aggj(l,4)
5180           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5181           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5182           s1=scalar2(b1(1,i+2),auxvec(1))
5183           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5184           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5185           s2=scalar2(b1(1,i+1),auxvec(1))
5186           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5187           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5188           s3=0.5d0*(pizda(1,1)+pizda(2,2))
5189           gcorr4_turn(l,j)=gcorr4_turn(l,j)-(s1+s2+s3)
5190      &  *fac_shield(i)*fac_shield(j)
5191           a_temp(1,1)=aggj1(l,1)
5192           a_temp(1,2)=aggj1(l,2)
5193           a_temp(2,1)=aggj1(l,3)
5194           a_temp(2,2)=aggj1(l,4)
5195           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5196           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5197           s1=scalar2(b1(1,i+2),auxvec(1))
5198           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5199           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5200           s2=scalar2(b1(1,i+1),auxvec(1))
5201           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5202           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5203           s3=0.5d0*(pizda(1,1)+pizda(2,2))
5204 c          write (iout,*) "s1",s1," s2",s2," s3",s3," s1+s2+s3",s1+s2+s3
5205           gcorr4_turn(l,j1)=gcorr4_turn(l,j1)-(s1+s2+s3)
5206      &  *fac_shield(i)*fac_shield(j)
5207         enddo
5208       return
5209       end
5210 C-----------------------------------------------------------------------------
5211       subroutine vecpr(u,v,w)
5212       implicit real*8(a-h,o-z)
5213       dimension u(3),v(3),w(3)
5214       w(1)=u(2)*v(3)-u(3)*v(2)
5215       w(2)=-u(1)*v(3)+u(3)*v(1)
5216       w(3)=u(1)*v(2)-u(2)*v(1)
5217       return
5218       end
5219 C-----------------------------------------------------------------------------
5220       subroutine unormderiv(u,ugrad,unorm,ungrad)
5221 C This subroutine computes the derivatives of a normalized vector u, given
5222 C the derivatives computed without normalization conditions, ugrad. Returns
5223 C ungrad.
5224       implicit none
5225       double precision u(3),ugrad(3,3),unorm,ungrad(3,3)
5226       double precision vec(3)
5227       double precision scalar
5228       integer i,j
5229 c      write (2,*) 'ugrad',ugrad
5230 c      write (2,*) 'u',u
5231       do i=1,3
5232         vec(i)=scalar(ugrad(1,i),u(1))
5233       enddo
5234 c      write (2,*) 'vec',vec
5235       do i=1,3
5236         do j=1,3
5237           ungrad(j,i)=(ugrad(j,i)-u(j)*vec(i))*unorm
5238         enddo
5239       enddo
5240 c      write (2,*) 'ungrad',ungrad
5241       return
5242       end
5243 C-----------------------------------------------------------------------------
5244       subroutine escp_soft_sphere(evdw2,evdw2_14)
5245 C
5246 C This subroutine calculates the excluded-volume interaction energy between
5247 C peptide-group centers and side chains and its gradient in virtual-bond and
5248 C side-chain vectors.
5249 C
5250       implicit real*8 (a-h,o-z)
5251       include 'DIMENSIONS'
5252       include 'COMMON.GEO'
5253       include 'COMMON.VAR'
5254       include 'COMMON.LOCAL'
5255       include 'COMMON.CHAIN'
5256       include 'COMMON.DERIV'
5257       include 'COMMON.INTERACT'
5258       include 'COMMON.FFIELD'
5259       include 'COMMON.IOUNITS'
5260       include 'COMMON.CONTROL'
5261       dimension ggg(3)
5262       double precision boxshift
5263       evdw2=0.0D0
5264       evdw2_14=0.0d0
5265       r0_scp=4.5d0
5266 cd    print '(a)','Enter ESCP'
5267 cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
5268 C      do xshift=-1,1
5269 C      do yshift=-1,1
5270 C      do zshift=-1,1
5271 c      do i=iatscp_s,iatscp_e
5272       do ikont=g_listscp_start,g_listscp_end
5273         i=newcontlistscpi(ikont)
5274         j=newcontlistscpj(ikont)
5275         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
5276         iteli=itel(i)
5277         xi=0.5D0*(c(1,i)+c(1,i+1))
5278         yi=0.5D0*(c(2,i)+c(2,i+1))
5279         zi=0.5D0*(c(3,i)+c(3,i+1))
5280 C Return atom into box, boxxsize is size of box in x dimension
5281 c  134   continue
5282 c        if (xi.gt.((xshift+0.5d0)*boxxsize)) xi=xi-boxxsize
5283 c        if (xi.lt.((xshift-0.5d0)*boxxsize)) xi=xi+boxxsize
5284 C Condition for being inside the proper box
5285 c        if ((xi.gt.((xshift+0.5d0)*boxxsize)).or.
5286 c     &       (xi.lt.((xshift-0.5d0)*boxxsize))) then
5287 c        go to 134
5288 c        endif
5289 c  135   continue
5290 c        if (yi.gt.((yshift+0.5d0)*boxysize)) yi=yi-boxysize
5291 c        if (yi.lt.((yshift-0.5d0)*boxysize)) yi=yi+boxysize
5292 C Condition for being inside the proper box
5293 c        if ((yi.gt.((yshift+0.5d0)*boxysize)).or.
5294 c     &       (yi.lt.((yshift-0.5d0)*boxysize))) then
5295 c        go to 135
5296 c c       endif
5297 c  136   continue
5298 c        if (zi.gt.((zshift+0.5d0)*boxzsize)) zi=zi-boxzsize
5299 c        if (zi.lt.((zshift-0.5d0)*boxzsize)) zi=zi+boxzsize
5300 cC Condition for being inside the proper box
5301 c        if ((zi.gt.((zshift+0.5d0)*boxzsize)).or.
5302 c     &       (zi.lt.((zshift-0.5d0)*boxzsize))) then
5303 c        go to 136
5304 c        endif
5305           call to_box(xi,yi,zi)
5306 C          xi=xi+xshift*boxxsize
5307 C          yi=yi+yshift*boxysize
5308 C          zi=zi+zshift*boxzsize
5309 c        do iint=1,nscp_gr(i)
5310
5311 c        do j=iscpstart(i,iint),iscpend(i,iint)
5312           if (itype(j).eq.ntyp1) cycle
5313           itypj=iabs(itype(j))
5314 C Uncomment following three lines for SC-p interactions
5315 c         xj=c(1,nres+j)-xi
5316 c         yj=c(2,nres+j)-yi
5317 c         zj=c(3,nres+j)-zi
5318 C Uncomment following three lines for Ca-p interactions
5319           xj=c(1,j)
5320           yj=c(2,j)
5321           zj=c(3,j)
5322           call to_box(xj,yj,zj)
5323           xj=boxshift(xj-xi,boxxsize)
5324           yj=boxshift(yj-yi,boxysize)
5325           zj=boxshift(zj-zi,boxzsize)
5326 C          xj=xj-xi
5327 C          yj=yj-yi
5328 C          zj=zj-zi
5329           rij=xj*xj+yj*yj+zj*zj
5330
5331           r0ij=r0_scp
5332           r0ijsq=r0ij*r0ij
5333           if (rij.lt.r0ijsq) then
5334             evdwij=0.25d0*(rij-r0ijsq)**2
5335             fac=rij-r0ijsq
5336           else
5337             evdwij=0.0d0
5338             fac=0.0d0
5339           endif
5340           evdw2=evdw2+evdwij
5341 C
5342 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
5343 C
5344           ggg(1)=xj*fac
5345           ggg(2)=yj*fac
5346           ggg(3)=zj*fac
5347           do k=1,3
5348             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
5349             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
5350           enddo
5351 c        enddo
5352
5353 c        enddo ! iint
5354       enddo ! i
5355 C      enddo !zshift
5356 C      enddo !yshift
5357 C      enddo !xshift
5358       return
5359       end
5360 C-----------------------------------------------------------------------------
5361       subroutine escp(evdw2,evdw2_14)
5362 C
5363 C This subroutine calculates the excluded-volume interaction energy between
5364 C peptide-group centers and side chains and its gradient in virtual-bond and
5365 C side-chain vectors.
5366 C
5367       implicit none
5368       include 'DIMENSIONS'
5369       include 'COMMON.GEO'
5370       include 'COMMON.VAR'
5371       include 'COMMON.LOCAL'
5372       include 'COMMON.CHAIN'
5373       include 'COMMON.DERIV'
5374       include 'COMMON.INTERACT'
5375       include 'COMMON.FFIELD'
5376       include 'COMMON.IOUNITS'
5377       include 'COMMON.CONTROL'
5378       include 'COMMON.SPLITELE'
5379       double precision ggg(3)
5380       integer i,iint,j,k,iteli,itypj,subchap,ikont
5381       double precision xi,yi,zi,xj,yj,zj,rrij,sss1,sssgrad1,
5382      & fac,e1,e2,rij
5383       double precision evdw2,evdw2_14,evdwij
5384       double precision sscale,sscagrad
5385       double precision boxshift
5386       evdw2=0.0D0
5387       evdw2_14=0.0d0
5388 c        print *,boxxsize,boxysize,boxzsize,'wymiary pudla'
5389 cd    print '(a)','Enter ESCP'
5390 cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
5391 C      do xshift=-1,1
5392 C      do yshift=-1,1
5393 C      do zshift=-1,1
5394       if (energy_dec) write (iout,*) "escp:",r_cut_int,rlamb
5395 c      do i=iatscp_s,iatscp_e
5396       do ikont=g_listscp_start,g_listscp_end
5397         i=newcontlistscpi(ikont)
5398         j=newcontlistscpj(ikont)
5399         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
5400         iteli=itel(i)
5401         xi=0.5D0*(c(1,i)+c(1,i+1))
5402         yi=0.5D0*(c(2,i)+c(2,i+1))
5403         zi=0.5D0*(c(3,i)+c(3,i+1))
5404         call to_box(xi,yi,zi)
5405 c        do iint=1,nscp_gr(i)
5406
5407 c        do j=iscpstart(i,iint),iscpend(i,iint)
5408           itypj=iabs(itype(j))
5409           if (itypj.eq.ntyp1) cycle
5410 C Uncomment following three lines for SC-p interactions
5411 c         xj=c(1,nres+j)-xi
5412 c         yj=c(2,nres+j)-yi
5413 c         zj=c(3,nres+j)-zi
5414 C Uncomment following three lines for Ca-p interactions
5415           xj=c(1,j)
5416           yj=c(2,j)
5417           zj=c(3,j)
5418           call to_box(xj,yj,zj)
5419           xj=boxshift(xj-xi,boxxsize)
5420           yj=boxshift(yj-yi,boxysize)
5421           zj=boxshift(zj-zi,boxzsize)
5422 c          print *,xj,yj,zj,'polozenie j'
5423           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
5424 c          print *,rrij
5425           sss=sscale(1.0d0/(dsqrt(rrij)),r_cut_int)
5426 c          print *,r_cut,1.0d0/dsqrt(rrij),sss,'tu patrz'
5427 c          if (sss.eq.0) print *,'czasem jest OK'
5428           if (sss.le.0.0d0) cycle
5429           sssgrad=sscagrad(1.0d0/(dsqrt(rrij)),r_cut_int)
5430           fac=rrij**expon2
5431           e1=fac*fac*aad(itypj,iteli)
5432           e2=fac*bad(itypj,iteli)
5433           if (iabs(j-i) .le. 2) then
5434             e1=scal14*e1
5435             e2=scal14*e2
5436             evdw2_14=evdw2_14+(e1+e2)*sss
5437           endif
5438           evdwij=e1+e2
5439           evdw2=evdw2+evdwij*sss
5440           if (energy_dec) write (iout,'(a6,2i5,3f7.3,2i3,3e11.3)')
5441      &        'evdw2',i,j,1.0d0/dsqrt(rrij),sss,
5442      &       evdwij,iteli,itypj,fac,aad(itypj,iteli),
5443      &       bad(itypj,iteli)
5444 C
5445 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
5446 C
5447           fac=-(evdwij+e1)*rrij*sss
5448           fac=fac+(evdwij)*sssgrad*dsqrt(rrij)/expon
5449           ggg(1)=xj*fac
5450           ggg(2)=yj*fac
5451           ggg(3)=zj*fac
5452 cgrad          if (j.lt.i) then
5453 cd          write (iout,*) 'j<i'
5454 C Uncomment following three lines for SC-p interactions
5455 c           do k=1,3
5456 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
5457 c           enddo
5458 cgrad          else
5459 cd          write (iout,*) 'j>i'
5460 cgrad            do k=1,3
5461 cgrad              ggg(k)=-ggg(k)
5462 C Uncomment following line for SC-p interactions
5463 ccgrad             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
5464 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
5465 cgrad            enddo
5466 cgrad          endif
5467 cgrad          do k=1,3
5468 cgrad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
5469 cgrad          enddo
5470 cgrad          kstart=min0(i+1,j)
5471 cgrad          kend=max0(i-1,j-1)
5472 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
5473 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
5474 cgrad          do k=kstart,kend
5475 cgrad            do l=1,3
5476 cgrad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
5477 cgrad            enddo
5478 cgrad          enddo
5479           do k=1,3
5480             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
5481             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
5482           enddo
5483 c        endif !endif for sscale cutoff
5484 c        enddo ! j
5485
5486 c        enddo ! iint
5487       enddo ! i
5488 c      enddo !zshift
5489 c      enddo !yshift
5490 c      enddo !xshift
5491       do i=1,nct
5492         do j=1,3
5493           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
5494           gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
5495           gradx_scp(j,i)=expon*gradx_scp(j,i)
5496         enddo
5497       enddo
5498 C******************************************************************************
5499 C
5500 C                              N O T E !!!
5501 C
5502 C To save time the factor EXPON has been extracted from ALL components
5503 C of GVDWC and GRADX. Remember to multiply them by this factor before further
5504 C use!
5505 C
5506 C******************************************************************************
5507       return
5508       end
5509 C--------------------------------------------------------------------------
5510       subroutine edis(ehpb)
5511 C
5512 C Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors.
5513 C
5514       implicit real*8 (a-h,o-z)
5515       include 'DIMENSIONS'
5516       include 'COMMON.SBRIDGE'
5517       include 'COMMON.CHAIN'
5518       include 'COMMON.DERIV'
5519       include 'COMMON.VAR'
5520       include 'COMMON.INTERACT'
5521       include 'COMMON.IOUNITS'
5522       include 'COMMON.CONTROL'
5523       dimension ggg(3),ggg_peak(3,1000)
5524       ehpb=0.0D0
5525       do i=1,3
5526        ggg(i)=0.0d0
5527       enddo
5528 c 8/21/18 AL: added explicit restraints on reference coords
5529 c      write (iout,*) "restr_on_coord",restr_on_coord
5530       if (restr_on_coord) then
5531
5532       do i=nnt,nct
5533         ecoor=0.0d0
5534         if (itype(i).eq.ntyp1) cycle
5535         do j=1,3
5536           ecoor=ecoor+(c(j,i)-cref(j,i))**2
5537           ghpbc(j,i)=ghpbc(j,i)+bfac(i)*(c(j,i)-cref(j,i))
5538         enddo
5539         if (itype(i).ne.10) then
5540           do j=1,3
5541             ecoor=ecoor+(c(j,i+nres)-cref(j,i+nres))**2
5542             ghpbx(j,i)=ghpbx(j,i)+bfac(i)*(c(j,i+nres)-cref(j,i+nres))
5543           enddo
5544         endif
5545         if (energy_dec) write (iout,*)
5546      &     "i",i," bfac",bfac(i)," ecoor",ecoor
5547         ehpb=ehpb+0.5d0*bfac(i)*ecoor
5548       enddo
5549
5550       endif
5551 C      write (iout,*) ,"link_end",link_end,constr_dist
5552 cd      write(iout,*)'edis: nhpb=',nhpb,' fbr=',fbr
5553 c      write(iout,*)'link_start=',link_start,' link_end=',link_end,
5554 c     &  " constr_dist",constr_dist," link_start_peak",link_start_peak,
5555 c     &  " link_end_peak",link_end_peak
5556       if (link_end.eq.0.and.link_end_peak.eq.0) return
5557       do i=link_start_peak,link_end_peak
5558         ehpb_peak=0.0d0
5559 c        print *,"i",i," link_end_peak",link_end_peak," ipeak",
5560 c     &   ipeak(1,i),ipeak(2,i)
5561         do ip=ipeak(1,i),ipeak(2,i)
5562           ii=ihpb_peak(ip)
5563           jj=jhpb_peak(ip)
5564           dd=dist(ii,jj)
5565           iip=ip-ipeak(1,i)+1
5566 C iii and jjj point to the residues for which the distance is assigned.
5567 c          if (ii.gt.nres) then
5568 c            iii=ii-nres
5569 c            jjj=jj-nres
5570 c          else
5571 c            iii=ii
5572 c            jjj=jj
5573 c          endif
5574           if (ii.gt.nres) then
5575             iii=ii-nres
5576           else
5577             iii=ii
5578           endif
5579           if (jj.gt.nres) then
5580             jjj=jj-nres
5581           else
5582             jjj=jj
5583           endif
5584           aux=rlornmr1(dd,dhpb_peak(ip),dhpb1_peak(ip),forcon_peak(ip))
5585           aux=dexp(-scal_peak*aux)
5586           ehpb_peak=ehpb_peak+aux
5587           fac=rlornmr1prim(dd,dhpb_peak(ip),dhpb1_peak(ip),
5588      &      forcon_peak(ip))*aux/dd
5589           do j=1,3
5590             ggg_peak(j,iip)=fac*(c(j,jj)-c(j,ii))
5591           enddo
5592           if (energy_dec) write (iout,'(a6,3i5,6f10.3,i5)')
5593      &      "edisL",i,ii,jj,dd,dhpb_peak(ip),dhpb1_peak(ip),
5594      &      forcon_peak(ip),fordepth_peak(ip),ehpb_peak
5595         enddo
5596 c        write (iout,*) "ehpb_peak",ehpb_peak," scal_peak",scal_peak
5597         ehpb=ehpb-fordepth_peak(ipeak(1,i))*dlog(ehpb_peak)/scal_peak
5598         do ip=ipeak(1,i),ipeak(2,i)
5599           iip=ip-ipeak(1,i)+1
5600           do j=1,3
5601             ggg(j)=ggg_peak(j,iip)/ehpb_peak
5602           enddo
5603           ii=ihpb_peak(ip)
5604           jj=jhpb_peak(ip)
5605 C iii and jjj point to the residues for which the distance is assigned.
5606 c          if (ii.gt.nres) then
5607 c            iii=ii-nres
5608 c            jjj=jj-nres
5609 c          else
5610 c            iii=ii
5611 c            jjj=jj
5612 c          endif
5613           if (ii.gt.nres) then
5614             iii=ii-nres
5615           else
5616             iii=ii
5617           endif
5618           if (jj.gt.nres) then
5619             jjj=jj-nres
5620           else
5621             jjj=jj
5622           endif
5623           if (iii.lt.ii) then
5624             do j=1,3
5625               ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
5626             enddo
5627           endif
5628           if (jjj.lt.jj) then
5629             do j=1,3
5630               ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
5631             enddo
5632           endif
5633           do k=1,3
5634             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
5635             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
5636           enddo
5637         enddo
5638       enddo
5639       do i=link_start,link_end
5640 C If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a
5641 C CA-CA distance used in regularization of structure.
5642         ii=ihpb(i)
5643         jj=jhpb(i)
5644 C iii and jjj point to the residues for which the distance is assigned.
5645         if (ii.gt.nres) then
5646           iii=ii-nres
5647         else
5648           iii=ii
5649         endif
5650         if (jj.gt.nres) then
5651           jjj=jj-nres
5652         else
5653           jjj=jj
5654         endif
5655 c        write (iout,*) "i",i," ii",ii," iii",iii," jj",jj," jjj",jjj,
5656 c     &    dhpb(i),dhpb1(i),forcon(i)
5657 C 24/11/03 AL: SS bridges handled separately because of introducing a specific
5658 C    distance and angle dependent SS bond potential.
5659 C        if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and.
5660 C     & iabs(itype(jjj)).eq.1) then
5661 cmc        if (ii.gt.nres .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then
5662 C 18/07/06 MC: Use the convention that the first nss pairs are SS bonds
5663         if (.not.dyn_ss .and. i.le.nss) then
5664 C 15/02/13 CC dynamic SSbond - additional check
5665           if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and.
5666      &        iabs(itype(jjj)).eq.1) then
5667            call ssbond_ene(iii,jjj,eij)
5668            ehpb=ehpb+2*eij
5669          endif
5670 cd          write (iout,*) "eij",eij
5671 cd   &   ' waga=',waga,' fac=',fac
5672 !        else if (ii.gt.nres .and. jj.gt.nres) then
5673         else
5674 C Calculate the distance between the two points and its difference from the
5675 C target distance.
5676           dd=dist(ii,jj)
5677           if (irestr_type(i).eq.11) then
5678             ehpb=ehpb+fordepth(i)!**4.0d0
5679      &           *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i))
5680             fac=fordepth(i)!**4.0d0
5681      &           *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd
5682             if (energy_dec) write (iout,'(a6,2i5,6f10.3,i5)')
5683      &        "edisL",ii,jj,dd,dhpb(i),dhpb1(i),forcon(i),fordepth(i),
5684      &        ehpb,irestr_type(i)
5685           else if (irestr_type(i).eq.10) then
5686 c AL 6//19/2018 cross-link restraints
5687             xdis = 0.5d0*(dd/forcon(i))**2
5688             expdis = dexp(-xdis)
5689 c            aux=(dhpb(i)+dhpb1(i)*xdis)*expdis+fordepth(i)
5690             aux=(dhpb(i)+dhpb1(i)*xdis*xdis)*expdis+fordepth(i)
5691 c            write (iout,*)"HERE: xdis",xdis," expdis",expdis," aux",aux,
5692 c     &          " wboltzd",wboltzd
5693             ehpb=ehpb-wboltzd*xlscore(i)*dlog(aux)
5694 c            fac=-wboltzd*(dhpb1(i)*(1.0d0-xdis)-dhpb(i))
5695             fac=-wboltzd*xlscore(i)*(dhpb1(i)*(2.0d0-xdis)*xdis-dhpb(i))
5696      &           *expdis/(aux*forcon(i)**2)
5697             if (energy_dec) write(iout,'(a6,2i5,6f10.3,i5)')
5698      &        "edisX",ii,jj,dd,dhpb(i),dhpb1(i),forcon(i),fordepth(i),
5699      &        -wboltzd*xlscore(i)*dlog(aux),irestr_type(i)
5700           else if (irestr_type(i).eq.2) then
5701 c Quartic restraints
5702             ehpb=ehpb+forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
5703             if (energy_dec) write(iout,'(a6,2i5,5f10.3,i5)')
5704      &      "edisQ",ii,jj,dd,dhpb(i),dhpb1(i),forcon(i),
5705      &      forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i)),irestr_type(i)
5706             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
5707           else
5708 c Quadratic restraints
5709             rdis=dd-dhpb(i)
5710 C Get the force constant corresponding to this distance.
5711             waga=forcon(i)
5712 C Calculate the contribution to energy.
5713             ehpb=ehpb+0.5d0*waga*rdis*rdis
5714             if (energy_dec) write(iout,'(a6,2i5,5f10.3,i5)')
5715      &      "edisS",ii,jj,dd,dhpb(i),dhpb1(i),forcon(i),
5716      &       0.5d0*waga*rdis*rdis,irestr_type(i)
5717 C
5718 C Evaluate gradient.
5719 C
5720             fac=waga*rdis/dd
5721           endif
5722 c Calculate Cartesian gradient
5723           do j=1,3
5724             ggg(j)=fac*(c(j,jj)-c(j,ii))
5725           enddo
5726 cd      print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
5727 C If this is a SC-SC distance, we need to calculate the contributions to the
5728 C Cartesian gradient in the SC vectors (ghpbx).
5729           if (iii.lt.ii) then
5730             do j=1,3
5731               ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
5732             enddo
5733           endif
5734           if (jjj.lt.jj) then
5735             do j=1,3
5736               ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
5737             enddo
5738           endif
5739           do k=1,3
5740             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
5741             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
5742           enddo
5743         endif
5744       enddo
5745       return
5746       end
5747 C--------------------------------------------------------------------------
5748       subroutine ssbond_ene(i,j,eij)
5749 C
5750 C Calculate the distance and angle dependent SS-bond potential energy
5751 C using a free-energy function derived based on RHF/6-31G** ab initio
5752 C calculations of diethyl disulfide.
5753 C
5754 C A. Liwo and U. Kozlowska, 11/24/03
5755 C
5756       implicit real*8 (a-h,o-z)
5757       include 'DIMENSIONS'
5758       include 'COMMON.SBRIDGE'
5759       include 'COMMON.CHAIN'
5760       include 'COMMON.DERIV'
5761       include 'COMMON.LOCAL'
5762       include 'COMMON.INTERACT'
5763       include 'COMMON.VAR'
5764       include 'COMMON.IOUNITS'
5765       double precision erij(3),dcosom1(3),dcosom2(3),gg(3)
5766       itypi=iabs(itype(i))
5767       xi=c(1,nres+i)
5768       yi=c(2,nres+i)
5769       zi=c(3,nres+i)
5770       dxi=dc_norm(1,nres+i)
5771       dyi=dc_norm(2,nres+i)
5772       dzi=dc_norm(3,nres+i)
5773 c      dsci_inv=dsc_inv(itypi)
5774       dsci_inv=vbld_inv(nres+i)
5775       itypj=iabs(itype(j))
5776 c      dscj_inv=dsc_inv(itypj)
5777       dscj_inv=vbld_inv(nres+j)
5778       xj=c(1,nres+j)-xi
5779       yj=c(2,nres+j)-yi
5780       zj=c(3,nres+j)-zi
5781       dxj=dc_norm(1,nres+j)
5782       dyj=dc_norm(2,nres+j)
5783       dzj=dc_norm(3,nres+j)
5784       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
5785       rij=dsqrt(rrij)
5786       erij(1)=xj*rij
5787       erij(2)=yj*rij
5788       erij(3)=zj*rij
5789       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
5790       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
5791       om12=dxi*dxj+dyi*dyj+dzi*dzj
5792       do k=1,3
5793         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
5794         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
5795       enddo
5796       rij=1.0d0/rij
5797       deltad=rij-d0cm
5798       deltat1=1.0d0-om1
5799       deltat2=1.0d0+om2
5800       deltat12=om2-om1+2.0d0
5801       cosphi=om12-om1*om2
5802       eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2)
5803      &  +akct*deltad*deltat12
5804      &  +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi+ebr
5805 c      write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth,
5806 c     &  " akct",akct," deltad",deltad," deltat",deltat1,deltat2,
5807 c     &  " deltat12",deltat12," eij",eij
5808       ed=2*akcm*deltad+akct*deltat12
5809       pom1=akct*deltad
5810       pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
5811       eom1=-2*akth*deltat1-pom1-om2*pom2
5812       eom2= 2*akth*deltat2+pom1-om1*pom2
5813       eom12=pom2
5814       do k=1,3
5815         ggk=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
5816         ghpbx(k,i)=ghpbx(k,i)-ggk
5817      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
5818      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
5819         ghpbx(k,j)=ghpbx(k,j)+ggk
5820      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
5821      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
5822         ghpbc(k,i)=ghpbc(k,i)-ggk
5823         ghpbc(k,j)=ghpbc(k,j)+ggk
5824       enddo
5825 C
5826 C Calculate the components of the gradient in DC and X
5827 C
5828 cgrad      do k=i,j-1
5829 cgrad        do l=1,3
5830 cgrad          ghpbc(l,k)=ghpbc(l,k)+gg(l)
5831 cgrad        enddo
5832 cgrad      enddo
5833       return
5834       end
5835 C--------------------------------------------------------------------------
5836       subroutine ebond(estr)
5837 c
5838 c Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
5839 c
5840       implicit real*8 (a-h,o-z)
5841       include 'DIMENSIONS'
5842       include 'COMMON.LOCAL'
5843       include 'COMMON.GEO'
5844       include 'COMMON.INTERACT'
5845       include 'COMMON.DERIV'
5846       include 'COMMON.VAR'
5847       include 'COMMON.CHAIN'
5848       include 'COMMON.IOUNITS'
5849       include 'COMMON.NAMES'
5850       include 'COMMON.FFIELD'
5851       include 'COMMON.CONTROL'
5852       include 'COMMON.SETUP'
5853       double precision u(3),ud(3)
5854       estr=0.0d0
5855       estr1=0.0d0
5856       do i=ibondp_start,ibondp_end
5857 c  3/4/2020 Adam: removed dummy bond graient if Calpha and SC coords are
5858 c      used
5859 #ifdef FIVEDIAG
5860         if (itype(i-1).eq.ntyp1 .or. itype(i).eq.ntyp1) cycle
5861         diff = vbld(i)-vbldp0
5862 #else
5863         if (itype(i-1).eq.ntyp1 .and. itype(i).eq.ntyp1) cycle
5864 c          estr1=estr1+gnmr1(vbld(i),-1.0d0,distchainmax)
5865 c          do j=1,3
5866 c          gradb(j,i-1)=gnmr1prim(vbld(i),-1.0d0,distchainmax)
5867 c     &      *dc(j,i-1)/vbld(i)
5868 c          enddo
5869 c          if (energy_dec) write(iout,*)
5870 c     &       "estr1",i,gnmr1(vbld(i),-1.0d0,distchainmax)
5871 c        else
5872 C       Checking if it involves dummy (NH3+ or COO-) group
5873         if (itype(i-1).eq.ntyp1 .or. itype(i).eq.ntyp1) then
5874 C YES   vbldpDUM is the equlibrium length of spring for Dummy atom
5875           diff = vbld(i)-vbldpDUM
5876           if (energy_dec) write(iout,*) "dum_bond",i,diff
5877         else
5878 C NO    vbldp0 is the equlibrium length of spring for peptide group
5879           diff = vbld(i)-vbldp0
5880         endif
5881 #endif
5882         if (energy_dec) write (iout,'(a7,i5,4f7.3)')
5883      &     "estr bb",i,vbld(i),vbldp0,diff,AKP*diff*diff
5884         estr=estr+diff*diff
5885         do j=1,3
5886           gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)
5887         enddo
5888 c        write (iout,'(i5,3f10.5)') i,(gradb(j,i-1),j=1,3)
5889 c        endif
5890       enddo
5891
5892       estr=0.5d0*AKP*estr+estr1
5893 c
5894 c 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included
5895 c
5896       do i=ibond_start,ibond_end
5897         iti=iabs(itype(i))
5898         if (iti.ne.10 .and. iti.ne.ntyp1) then
5899           nbi=nbondterm(iti)
5900           if (nbi.eq.1) then
5901             diff=vbld(i+nres)-vbldsc0(1,iti)
5902             if (energy_dec)  write (iout,*)
5903      &      "estr sc",i,iti,vbld(i+nres),vbldsc0(1,iti),diff,
5904      &      AKSC(1,iti),AKSC(1,iti)*diff*diff
5905             estr=estr+0.5d0*AKSC(1,iti)*diff*diff
5906             do j=1,3
5907               gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
5908             enddo
5909           else
5910             do j=1,nbi
5911               diff=vbld(i+nres)-vbldsc0(j,iti)
5912               ud(j)=aksc(j,iti)*diff
5913               u(j)=abond0(j,iti)+0.5d0*ud(j)*diff
5914             enddo
5915             uprod=u(1)
5916             do j=2,nbi
5917               uprod=uprod*u(j)
5918             enddo
5919             usum=0.0d0
5920             usumsqder=0.0d0
5921             do j=1,nbi
5922               uprod1=1.0d0
5923               uprod2=1.0d0
5924               do k=1,nbi
5925                 if (k.ne.j) then
5926                   uprod1=uprod1*u(k)
5927                   uprod2=uprod2*u(k)*u(k)
5928                 endif
5929               enddo
5930               usum=usum+uprod1
5931               usumsqder=usumsqder+ud(j)*uprod2
5932             enddo
5933             estr=estr+uprod/usum
5934             do j=1,3
5935              gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
5936             enddo
5937           endif
5938         endif
5939       enddo
5940       return
5941       end
5942 #ifdef CRYST_THETA
5943 C--------------------------------------------------------------------------
5944       subroutine ebend(etheta)
5945 C
5946 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
5947 C angles gamma and its derivatives in consecutive thetas and gammas.
5948 C
5949       implicit real*8 (a-h,o-z)
5950       include 'DIMENSIONS'
5951       include 'COMMON.LOCAL'
5952       include 'COMMON.GEO'
5953       include 'COMMON.INTERACT'
5954       include 'COMMON.DERIV'
5955       include 'COMMON.VAR'
5956       include 'COMMON.CHAIN'
5957       include 'COMMON.IOUNITS'
5958       include 'COMMON.NAMES'
5959       include 'COMMON.FFIELD'
5960       include 'COMMON.CONTROL'
5961       include 'COMMON.TORCNSTR'
5962       common /calcthet/ term1,term2,termm,diffak,ratak,
5963      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
5964      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
5965       double precision y(2),z(2)
5966       delta=0.02d0*pi
5967 c      time11=dexp(-2*time)
5968 c      time12=1.0d0
5969       etheta=0.0D0
5970 c     write (*,'(a,i2)') 'EBEND ICG=',icg
5971       do i=ithet_start,ithet_end
5972         if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
5973      &  .or.itype(i).eq.ntyp1) cycle
5974 C Zero the energy function and its derivative at 0 or pi.
5975         call splinthet(theta(i),0.5d0*delta,ss,ssd)
5976         it=itype(i-1)
5977         ichir1=isign(1,itype(i-2))
5978         ichir2=isign(1,itype(i))
5979          if (itype(i-2).eq.10) ichir1=isign(1,itype(i-1))
5980          if (itype(i).eq.10) ichir2=isign(1,itype(i-1))
5981          if (itype(i-1).eq.10) then
5982           itype1=isign(10,itype(i-2))
5983           ichir11=isign(1,itype(i-2))
5984           ichir12=isign(1,itype(i-2))
5985           itype2=isign(10,itype(i))
5986           ichir21=isign(1,itype(i))
5987           ichir22=isign(1,itype(i))
5988          endif
5989
5990         if (i.gt.3 .and. itype(i-3).ne.ntyp1) then
5991 #ifdef OSF
5992           phii=phi(i)
5993           if (phii.ne.phii) phii=150.0
5994 #else
5995           phii=phi(i)
5996 #endif
5997           y(1)=dcos(phii)
5998           y(2)=dsin(phii)
5999         else
6000           y(1)=0.0D0
6001           y(2)=0.0D0
6002         endif
6003         if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
6004 #ifdef OSF
6005           phii1=phi(i+1)
6006           if (phii1.ne.phii1) phii1=150.0
6007           phii1=pinorm(phii1)
6008           z(1)=cos(phii1)
6009 #else
6010           phii1=phi(i+1)
6011 #endif
6012           z(1)=dcos(phii1)
6013           z(2)=dsin(phii1)
6014         else
6015           z(1)=0.0D0
6016           z(2)=0.0D0
6017         endif
6018 C Calculate the "mean" value of theta from the part of the distribution
6019 C dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2).
6020 C In following comments this theta will be referred to as t_c.
6021         thet_pred_mean=0.0d0
6022         do k=1,2
6023             athetk=athet(k,it,ichir1,ichir2)
6024             bthetk=bthet(k,it,ichir1,ichir2)
6025           if (it.eq.10) then
6026              athetk=athet(k,itype1,ichir11,ichir12)
6027              bthetk=bthet(k,itype2,ichir21,ichir22)
6028           endif
6029          thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k)
6030 c         write(iout,*) 'chuj tu', y(k),z(k)
6031         enddo
6032         dthett=thet_pred_mean*ssd
6033         thet_pred_mean=thet_pred_mean*ss+a0thet(it)
6034 C Derivatives of the "mean" values in gamma1 and gamma2.
6035         dthetg1=(-athet(1,it,ichir1,ichir2)*y(2)
6036      &+athet(2,it,ichir1,ichir2)*y(1))*ss
6037          dthetg2=(-bthet(1,it,ichir1,ichir2)*z(2)
6038      &          +bthet(2,it,ichir1,ichir2)*z(1))*ss
6039          if (it.eq.10) then
6040       dthetg1=(-athet(1,itype1,ichir11,ichir12)*y(2)
6041      &+athet(2,itype1,ichir11,ichir12)*y(1))*ss
6042         dthetg2=(-bthet(1,itype2,ichir21,ichir22)*z(2)
6043      &         +bthet(2,itype2,ichir21,ichir22)*z(1))*ss
6044          endif
6045         if (theta(i).gt.pi-delta) then
6046           call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,
6047      &         E_tc0)
6048           call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0)
6049           call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
6050           call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,
6051      &        E_theta)
6052           call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,
6053      &        E_tc)
6054         else if (theta(i).lt.delta) then
6055           call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0)
6056           call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
6057           call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,
6058      &        E_theta)
6059           call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0)
6060           call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,
6061      &        E_tc)
6062         else
6063           call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,
6064      &        E_theta,E_tc)
6065         endif
6066         etheta=etheta+ethetai
6067         if (energy_dec) write (iout,'(a6,i5,0pf7.3,f7.3,i5)')
6068      &      'ebend',i,ethetai,theta(i),itype(i)
6069         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1
6070         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2
6071         gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)+gloc(nphi+i-2,icg)
6072       enddo
6073
6074 C Ufff.... We've done all this!!!
6075       return
6076       end
6077 C---------------------------------------------------------------------------
6078       subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,
6079      &     E_tc)
6080       implicit real*8 (a-h,o-z)
6081       include 'DIMENSIONS'
6082       include 'COMMON.LOCAL'
6083       include 'COMMON.IOUNITS'
6084       common /calcthet/ term1,term2,termm,diffak,ratak,
6085      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
6086      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
6087 C Calculate the contributions to both Gaussian lobes.
6088 C 6/6/97 - Deform the Gaussians using the factor of 1/(1+time)
6089 C The "polynomial part" of the "standard deviation" of this part of
6090 C the distributioni.
6091 ccc        write (iout,*) thetai,thet_pred_mean
6092         sig=polthet(3,it)
6093         do j=2,0,-1
6094           sig=sig*thet_pred_mean+polthet(j,it)
6095         enddo
6096 C Derivative of the "interior part" of the "standard deviation of the"
6097 C gamma-dependent Gaussian lobe in t_c.
6098         sigtc=3*polthet(3,it)
6099         do j=2,1,-1
6100           sigtc=sigtc*thet_pred_mean+j*polthet(j,it)
6101         enddo
6102         sigtc=sig*sigtc
6103 C Set the parameters of both Gaussian lobes of the distribution.
6104 C "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc)
6105         fac=sig*sig+sigc0(it)
6106         sigcsq=fac+fac
6107         sigc=1.0D0/sigcsq
6108 C Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c
6109         sigsqtc=-4.0D0*sigcsq*sigtc
6110 c       print *,i,sig,sigtc,sigsqtc
6111 C Following variable (sigtc) is d[sigma(t_c)]/dt_c
6112         sigtc=-sigtc/(fac*fac)
6113 C Following variable is sigma(t_c)**(-2)
6114         sigcsq=sigcsq*sigcsq
6115         sig0i=sig0(it)
6116         sig0inv=1.0D0/sig0i**2
6117         delthec=thetai-thet_pred_mean
6118         delthe0=thetai-theta0i
6119         term1=-0.5D0*sigcsq*delthec*delthec
6120         term2=-0.5D0*sig0inv*delthe0*delthe0
6121 C        write (iout,*)'term1',term1,term2,sigcsq,delthec,sig0inv,delthe0
6122 C Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and
6123 C NaNs in taking the logarithm. We extract the largest exponent which is added
6124 C to the energy (this being the log of the distribution) at the end of energy
6125 C term evaluation for this virtual-bond angle.
6126         if (term1.gt.term2) then
6127           termm=term1
6128           term2=dexp(term2-termm)
6129           term1=1.0d0
6130         else
6131           termm=term2
6132           term1=dexp(term1-termm)
6133           term2=1.0d0
6134         endif
6135 C The ratio between the gamma-independent and gamma-dependent lobes of
6136 C the distribution is a Gaussian function of thet_pred_mean too.
6137         diffak=gthet(2,it)-thet_pred_mean
6138         ratak=diffak/gthet(3,it)**2
6139         ak=dexp(gthet(1,it)-0.5D0*diffak*ratak)
6140 C Let's differentiate it in thet_pred_mean NOW.
6141         aktc=ak*ratak
6142 C Now put together the distribution terms to make complete distribution.
6143         termexp=term1+ak*term2
6144         termpre=sigc+ak*sig0i
6145 C Contribution of the bending energy from this theta is just the -log of
6146 C the sum of the contributions from the two lobes and the pre-exponential
6147 C factor. Simple enough, isn't it?
6148         ethetai=(-dlog(termexp)-termm+dlog(termpre))
6149 C       write (iout,*) 'termexp',termexp,termm,termpre,i
6150 C NOW the derivatives!!!
6151 C 6/6/97 Take into account the deformation.
6152         E_theta=(delthec*sigcsq*term1
6153      &       +ak*delthe0*sig0inv*term2)/termexp
6154         E_tc=((sigtc+aktc*sig0i)/termpre
6155      &      -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+
6156      &       aktc*term2)/termexp)
6157       return
6158       end
6159 c-----------------------------------------------------------------------------
6160       subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)
6161       implicit real*8 (a-h,o-z)
6162       include 'DIMENSIONS'
6163       include 'COMMON.LOCAL'
6164       include 'COMMON.IOUNITS'
6165       common /calcthet/ term1,term2,termm,diffak,ratak,
6166      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
6167      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
6168       delthec=thetai-thet_pred_mean
6169       delthe0=thetai-theta0i
6170 C "Thank you" to MAPLE (probably spared one day of hand-differentiation).
6171       t3 = thetai-thet_pred_mean
6172       t6 = t3**2
6173       t9 = term1
6174       t12 = t3*sigcsq
6175       t14 = t12+t6*sigsqtc
6176       t16 = 1.0d0
6177       t21 = thetai-theta0i
6178       t23 = t21**2
6179       t26 = term2
6180       t27 = t21*t26
6181       t32 = termexp
6182       t40 = t32**2
6183       E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9
6184      & -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40
6185      & *(-t12*t9-ak*sig0inv*t27)
6186       return
6187       end
6188 #else
6189 C--------------------------------------------------------------------------
6190       subroutine ebend(etheta)
6191 C
6192 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
6193 C angles gamma and its derivatives in consecutive thetas and gammas.
6194 C ab initio-derived potentials from
6195 c Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203
6196 C
6197       implicit real*8 (a-h,o-z)
6198       include 'DIMENSIONS'
6199       include 'COMMON.LOCAL'
6200       include 'COMMON.GEO'
6201       include 'COMMON.INTERACT'
6202       include 'COMMON.DERIV'
6203       include 'COMMON.VAR'
6204       include 'COMMON.CHAIN'
6205       include 'COMMON.IOUNITS'
6206       include 'COMMON.NAMES'
6207       include 'COMMON.FFIELD'
6208       include 'COMMON.CONTROL'
6209       include 'COMMON.TORCNSTR'
6210       double precision coskt(mmaxtheterm),sinkt(mmaxtheterm),
6211      & cosph1(maxsingle),sinph1(maxsingle),cosph2(maxsingle),
6212      & sinph2(maxsingle),cosph1ph2(maxdouble,maxdouble),
6213      & sinph1ph2(maxdouble,maxdouble)
6214       logical lprn /.false./, lprn1 /.false./
6215       etheta=0.0D0
6216       do i=ithet_start,ithet_end
6217 c        print *,i,itype(i-1),itype(i),itype(i-2)
6218         if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
6219      &  .or.itype(i).eq.ntyp1) cycle
6220 C        print *,i,theta(i)
6221         if (iabs(itype(i+1)).eq.20) iblock=2
6222         if (iabs(itype(i+1)).ne.20) iblock=1
6223         dethetai=0.0d0
6224         dephii=0.0d0
6225         dephii1=0.0d0
6226         theti2=0.5d0*theta(i)
6227         ityp2=ithetyp((itype(i-1)))
6228         do k=1,nntheterm
6229           coskt(k)=dcos(k*theti2)
6230           sinkt(k)=dsin(k*theti2)
6231         enddo
6232 C        print *,ethetai
6233         if (i.gt.3 .and. itype(i-3).ne.ntyp1) then
6234 #ifdef OSF
6235           phii=phi(i)
6236           if (phii.ne.phii) phii=150.0
6237 #else
6238           phii=phi(i)
6239 #endif
6240           ityp1=ithetyp((itype(i-2)))
6241 C propagation of chirality for glycine type
6242           do k=1,nsingle
6243             cosph1(k)=dcos(k*phii)
6244             sinph1(k)=dsin(k*phii)
6245           enddo
6246         else
6247           phii=0.0d0
6248           do k=1,nsingle
6249           ityp1=ithetyp((itype(i-2)))
6250             cosph1(k)=0.0d0
6251             sinph1(k)=0.0d0
6252           enddo
6253         endif
6254         if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
6255 #ifdef OSF
6256           phii1=phi(i+1)
6257           if (phii1.ne.phii1) phii1=150.0
6258           phii1=pinorm(phii1)
6259 #else
6260           phii1=phi(i+1)
6261 #endif
6262           ityp3=ithetyp((itype(i)))
6263           do k=1,nsingle
6264             cosph2(k)=dcos(k*phii1)
6265             sinph2(k)=dsin(k*phii1)
6266           enddo
6267         else
6268           phii1=0.0d0
6269           ityp3=ithetyp((itype(i)))
6270           do k=1,nsingle
6271             cosph2(k)=0.0d0
6272             sinph2(k)=0.0d0
6273           enddo
6274         endif
6275         ethetai=aa0thet(ityp1,ityp2,ityp3,iblock)
6276         do k=1,ndouble
6277           do l=1,k-1
6278             ccl=cosph1(l)*cosph2(k-l)
6279             ssl=sinph1(l)*sinph2(k-l)
6280             scl=sinph1(l)*cosph2(k-l)
6281             csl=cosph1(l)*sinph2(k-l)
6282             cosph1ph2(l,k)=ccl-ssl
6283             cosph1ph2(k,l)=ccl+ssl
6284             sinph1ph2(l,k)=scl+csl
6285             sinph1ph2(k,l)=scl-csl
6286           enddo
6287         enddo
6288         if (lprn) then
6289         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,
6290      &    " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
6291         write (iout,*) "coskt and sinkt"
6292         do k=1,nntheterm
6293           write (iout,*) k,coskt(k),sinkt(k)
6294         enddo
6295         endif
6296         do k=1,ntheterm
6297           ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3,iblock)*sinkt(k)
6298           dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3,iblock)
6299      &      *coskt(k)
6300           if (lprn)
6301      &    write (iout,*) "k",k,"
6302      &     aathet",aathet(k,ityp1,ityp2,ityp3,iblock),
6303      &     " ethetai",ethetai
6304         enddo
6305         if (lprn) then
6306         write (iout,*) "cosph and sinph"
6307         do k=1,nsingle
6308           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
6309         enddo
6310         write (iout,*) "cosph1ph2 and sinph2ph2"
6311         do k=2,ndouble
6312           do l=1,k-1
6313             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),
6314      &         sinph1ph2(l,k),sinph1ph2(k,l)
6315           enddo
6316         enddo
6317         write(iout,*) "ethetai",ethetai
6318         endif
6319 C       print *,ethetai
6320         do m=1,ntheterm2
6321           do k=1,nsingle
6322             aux=bbthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)
6323      &         +ccthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k)
6324      &         +ddthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)
6325      &         +eethet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k)
6326             ethetai=ethetai+sinkt(m)*aux
6327             dethetai=dethetai+0.5d0*m*aux*coskt(m)
6328             dephii=dephii+k*sinkt(m)*(
6329      &          ccthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)-
6330      &          bbthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k))
6331             dephii1=dephii1+k*sinkt(m)*(
6332      &          eethet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)-
6333      &          ddthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k))
6334             if (lprn)
6335      &      write (iout,*) "m",m," k",k," bbthet",
6336      &         bbthet(k,m,ityp1,ityp2,ityp3,iblock)," ccthet",
6337      &         ccthet(k,m,ityp1,ityp2,ityp3,iblock)," ddthet",
6338      &         ddthet(k,m,ityp1,ityp2,ityp3,iblock)," eethet",
6339      &         eethet(k,m,ityp1,ityp2,ityp3,iblock)," ethetai",ethetai
6340 C        print *,"tu",cosph1(k),sinph1(k),cosph2(k),sinph2(k)
6341           enddo
6342         enddo
6343 C        print *,"cosph1", (cosph1(k), k=1,nsingle)
6344 C        print *,"cosph2", (cosph2(k), k=1,nsingle)
6345 C        print *,"sinph1", (sinph1(k), k=1,nsingle)
6346 C        print *,"sinph2", (sinph2(k), k=1,nsingle)
6347         if (lprn)
6348      &  write(iout,*) "ethetai",ethetai
6349 C        print *,"tu",cosph1(k),sinph1(k),cosph2(k),sinph2(k)
6350         do m=1,ntheterm3
6351           do k=2,ndouble
6352             do l=1,k-1
6353               aux=ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
6354      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l)+
6355      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
6356      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)
6357               ethetai=ethetai+sinkt(m)*aux
6358               dethetai=dethetai+0.5d0*m*coskt(m)*aux
6359               dephii=dephii+l*sinkt(m)*(
6360      &           -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)-
6361      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
6362      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
6363      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
6364               dephii1=dephii1+(k-l)*sinkt(m)*(
6365      &           -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
6366      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
6367      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)-
6368      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
6369               if (lprn) then
6370               write (iout,*) "m",m," k",k," l",l," ffthet",
6371      &            ffthet(l,k,m,ityp1,ityp2,ityp3,iblock),
6372      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)," ggthet",
6373      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock),
6374      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock),
6375      &            " ethetai",ethetai
6376               write (iout,*) cosph1ph2(l,k)*sinkt(m),
6377      &            cosph1ph2(k,l)*sinkt(m),
6378      &            sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
6379               endif
6380             enddo
6381           enddo
6382         enddo
6383 10      continue
6384 c        lprn1=.true.
6385 C        print *,ethetai
6386         if (lprn1)
6387      &    write (iout,'(i2,3f8.1,9h ethetai ,f10.5)')
6388      &   i,theta(i)*rad2deg,phii*rad2deg,
6389      &   phii1*rad2deg,ethetai
6390 c        lprn1=.false.
6391         etheta=etheta+ethetai
6392         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
6393         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
6394         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)+wang*dethetai
6395       enddo
6396
6397       return
6398       end
6399 #endif
6400 #ifdef CRYST_SC
6401 c-----------------------------------------------------------------------------
6402       subroutine esc(escloc)
6403 C Calculate the local energy of a side chain and its derivatives in the
6404 C corresponding virtual-bond valence angles THETA and the spherical angles
6405 C ALPHA and OMEGA.
6406       implicit real*8 (a-h,o-z)
6407       include 'DIMENSIONS'
6408       include 'COMMON.GEO'
6409       include 'COMMON.LOCAL'
6410       include 'COMMON.VAR'
6411       include 'COMMON.INTERACT'
6412       include 'COMMON.DERIV'
6413       include 'COMMON.CHAIN'
6414       include 'COMMON.IOUNITS'
6415       include 'COMMON.NAMES'
6416       include 'COMMON.FFIELD'
6417       include 'COMMON.CONTROL'
6418       double precision x(3),dersc(3),xemp(3),dersc0(3),dersc1(3),
6419      &     ddersc0(3),ddummy(3),xtemp(3),temp(3)
6420       common /sccalc/ time11,time12,time112,theti,it,nlobit
6421       delta=0.02d0*pi
6422       escloc=0.0D0
6423 c     write (iout,'(a)') 'ESC'
6424       do i=loc_start,loc_end
6425         it=itype(i)
6426         if (it.eq.ntyp1) cycle
6427         if (it.eq.10) goto 1
6428         nlobit=nlob(iabs(it))
6429 c       print *,'i=',i,' it=',it,' nlobit=',nlobit
6430 c       write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
6431         theti=theta(i+1)-pipol
6432         x(1)=dtan(theti)
6433         x(2)=alph(i)
6434         x(3)=omeg(i)
6435
6436         if (x(2).gt.pi-delta) then
6437           xtemp(1)=x(1)
6438           xtemp(2)=pi-delta
6439           xtemp(3)=x(3)
6440           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
6441           xtemp(2)=pi
6442           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
6443           call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),
6444      &        escloci,dersc(2))
6445           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
6446      &        ddersc0(1),dersc(1))
6447           call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),
6448      &        ddersc0(3),dersc(3))
6449           xtemp(2)=pi-delta
6450           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
6451           xtemp(2)=pi
6452           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
6453           call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,
6454      &            dersc0(2),esclocbi,dersc02)
6455           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
6456      &            dersc12,dersc01)
6457           call splinthet(x(2),0.5d0*delta,ss,ssd)
6458           dersc0(1)=dersc01
6459           dersc0(2)=dersc02
6460           dersc0(3)=0.0d0
6461           do k=1,3
6462             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
6463           enddo
6464           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
6465 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
6466 c    &             esclocbi,ss,ssd
6467           escloci=ss*escloci+(1.0d0-ss)*esclocbi
6468 c         escloci=esclocbi
6469 c         write (iout,*) escloci
6470         else if (x(2).lt.delta) then
6471           xtemp(1)=x(1)
6472           xtemp(2)=delta
6473           xtemp(3)=x(3)
6474           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
6475           xtemp(2)=0.0d0
6476           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
6477           call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),
6478      &        escloci,dersc(2))
6479           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
6480      &        ddersc0(1),dersc(1))
6481           call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),
6482      &        ddersc0(3),dersc(3))
6483           xtemp(2)=delta
6484           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
6485           xtemp(2)=0.0d0
6486           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
6487           call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,
6488      &            dersc0(2),esclocbi,dersc02)
6489           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
6490      &            dersc12,dersc01)
6491           dersc0(1)=dersc01
6492           dersc0(2)=dersc02
6493           dersc0(3)=0.0d0
6494           call splinthet(x(2),0.5d0*delta,ss,ssd)
6495           do k=1,3
6496             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
6497           enddo
6498           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
6499 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
6500 c    &             esclocbi,ss,ssd
6501           escloci=ss*escloci+(1.0d0-ss)*esclocbi
6502 c         write (iout,*) escloci
6503         else
6504           call enesc(x,escloci,dersc,ddummy,.false.)
6505         endif
6506
6507         escloc=escloc+escloci
6508         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
6509      &     'escloc',i,escloci
6510 c       write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
6511
6512         gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
6513      &   wscloc*dersc(1)
6514         gloc(ialph(i,1),icg)=wscloc*dersc(2)
6515         gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
6516     1   continue
6517       enddo
6518       return
6519       end
6520 C---------------------------------------------------------------------------
6521       subroutine enesc(x,escloci,dersc,ddersc,mixed)
6522       implicit real*8 (a-h,o-z)
6523       include 'DIMENSIONS'
6524       include 'COMMON.GEO'
6525       include 'COMMON.LOCAL'
6526       include 'COMMON.IOUNITS'
6527       common /sccalc/ time11,time12,time112,theti,it,nlobit
6528       double precision x(3),z(3),Ax(3,maxlob,-1:1),dersc(3),ddersc(3)
6529       double precision contr(maxlob,-1:1)
6530       logical mixed
6531 c       write (iout,*) 'it=',it,' nlobit=',nlobit
6532         escloc_i=0.0D0
6533         do j=1,3
6534           dersc(j)=0.0D0
6535           if (mixed) ddersc(j)=0.0d0
6536         enddo
6537         x3=x(3)
6538
6539 C Because of periodicity of the dependence of the SC energy in omega we have
6540 C to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
6541 C To avoid underflows, first compute & store the exponents.
6542
6543         do iii=-1,1
6544
6545           x(3)=x3+iii*dwapi
6546
6547           do j=1,nlobit
6548             do k=1,3
6549               z(k)=x(k)-censc(k,j,it)
6550             enddo
6551             do k=1,3
6552               Axk=0.0D0
6553               do l=1,3
6554                 Axk=Axk+gaussc(l,k,j,it)*z(l)
6555               enddo
6556               Ax(k,j,iii)=Axk
6557             enddo
6558             expfac=0.0D0
6559             do k=1,3
6560               expfac=expfac+Ax(k,j,iii)*z(k)
6561             enddo
6562             contr(j,iii)=expfac
6563           enddo ! j
6564
6565         enddo ! iii
6566
6567         x(3)=x3
6568 C As in the case of ebend, we want to avoid underflows in exponentiation and
6569 C subsequent NaNs and INFs in energy calculation.
6570 C Find the largest exponent
6571         emin=contr(1,-1)
6572         do iii=-1,1
6573           do j=1,nlobit
6574             if (emin.gt.contr(j,iii)) emin=contr(j,iii)
6575           enddo
6576         enddo
6577         emin=0.5D0*emin
6578 cd      print *,'it=',it,' emin=',emin
6579
6580 C Compute the contribution to SC energy and derivatives
6581         do iii=-1,1
6582
6583           do j=1,nlobit
6584 #ifdef OSF
6585             adexp=bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin
6586             if(adexp.ne.adexp) adexp=1.0
6587             expfac=dexp(adexp)
6588 #else
6589             expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin)
6590 #endif
6591 cd          print *,'j=',j,' expfac=',expfac
6592             escloc_i=escloc_i+expfac
6593             do k=1,3
6594               dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
6595             enddo
6596             if (mixed) then
6597               do k=1,3,2
6598                 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii)
6599      &            +gaussc(k,2,j,it))*expfac
6600               enddo
6601             endif
6602           enddo
6603
6604         enddo ! iii
6605
6606         dersc(1)=dersc(1)/cos(theti)**2
6607         ddersc(1)=ddersc(1)/cos(theti)**2
6608         ddersc(3)=ddersc(3)
6609
6610         escloci=-(dlog(escloc_i)-emin)
6611         do j=1,3
6612           dersc(j)=dersc(j)/escloc_i
6613         enddo
6614         if (mixed) then
6615           do j=1,3,2
6616             ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
6617           enddo
6618         endif
6619       return
6620       end
6621 C------------------------------------------------------------------------------
6622       subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
6623       implicit real*8 (a-h,o-z)
6624       include 'DIMENSIONS'
6625       include 'COMMON.GEO'
6626       include 'COMMON.LOCAL'
6627       include 'COMMON.IOUNITS'
6628       common /sccalc/ time11,time12,time112,theti,it,nlobit
6629       double precision x(3),z(3),Ax(3,maxlob),dersc(3)
6630       double precision contr(maxlob)
6631       logical mixed
6632
6633       escloc_i=0.0D0
6634
6635       do j=1,3
6636         dersc(j)=0.0D0
6637       enddo
6638
6639       do j=1,nlobit
6640         do k=1,2
6641           z(k)=x(k)-censc(k,j,it)
6642         enddo
6643         z(3)=dwapi
6644         do k=1,3
6645           Axk=0.0D0
6646           do l=1,3
6647             Axk=Axk+gaussc(l,k,j,it)*z(l)
6648           enddo
6649           Ax(k,j)=Axk
6650         enddo
6651         expfac=0.0D0
6652         do k=1,3
6653           expfac=expfac+Ax(k,j)*z(k)
6654         enddo
6655         contr(j)=expfac
6656       enddo ! j
6657
6658 C As in the case of ebend, we want to avoid underflows in exponentiation and
6659 C subsequent NaNs and INFs in energy calculation.
6660 C Find the largest exponent
6661       emin=contr(1)
6662       do j=1,nlobit
6663         if (emin.gt.contr(j)) emin=contr(j)
6664       enddo
6665       emin=0.5D0*emin
6666
6667 C Compute the contribution to SC energy and derivatives
6668
6669       dersc12=0.0d0
6670       do j=1,nlobit
6671         expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j)+emin)
6672         escloc_i=escloc_i+expfac
6673         do k=1,2
6674           dersc(k)=dersc(k)+Ax(k,j)*expfac
6675         enddo
6676         if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j)
6677      &            +gaussc(1,2,j,it))*expfac
6678         dersc(3)=0.0d0
6679       enddo
6680
6681       dersc(1)=dersc(1)/cos(theti)**2
6682       dersc12=dersc12/cos(theti)**2
6683       escloci=-(dlog(escloc_i)-emin)
6684       do j=1,2
6685         dersc(j)=dersc(j)/escloc_i
6686       enddo
6687       if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
6688       return
6689       end
6690 #else
6691 c----------------------------------------------------------------------------------
6692       subroutine esc(escloc)
6693 C Calculate the local energy of a side chain and its derivatives in the
6694 C corresponding virtual-bond valence angles THETA and the spherical angles
6695 C ALPHA and OMEGA derived from AM1 all-atom calculations.
6696 C added by Urszula Kozlowska. 07/11/2007
6697 C
6698       implicit real*8 (a-h,o-z)
6699       include 'DIMENSIONS'
6700       include 'COMMON.GEO'
6701       include 'COMMON.LOCAL'
6702       include 'COMMON.VAR'
6703       include 'COMMON.SCROT'
6704       include 'COMMON.INTERACT'
6705       include 'COMMON.DERIV'
6706       include 'COMMON.CHAIN'
6707       include 'COMMON.IOUNITS'
6708       include 'COMMON.NAMES'
6709       include 'COMMON.FFIELD'
6710       include 'COMMON.CONTROL'
6711       include 'COMMON.VECTORS'
6712       double precision x_prime(3),y_prime(3),z_prime(3)
6713      &    , sumene,dsc_i,dp2_i,x(65),
6714      &     xx,yy,zz,sumene1,sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6,
6715      &    de_dxx,de_dyy,de_dzz,de_dt
6716       double precision s1_t,s1_6_t,s2_t,s2_6_t
6717       double precision
6718      & dXX_Ci1(3),dYY_Ci1(3),dZZ_Ci1(3),dXX_Ci(3),
6719      & dYY_Ci(3),dZZ_Ci(3),dXX_XYZ(3),dYY_XYZ(3),dZZ_XYZ(3),
6720      & dt_dCi(3),dt_dCi1(3)
6721       common /sccalc/ time11,time12,time112,theti,it,nlobit
6722       delta=0.02d0*pi
6723       escloc=0.0D0
6724       do i=loc_start,loc_end
6725         if (itype(i).eq.ntyp1) cycle
6726         costtab(i+1) =dcos(theta(i+1))
6727         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
6728         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
6729         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
6730         cosfac2=0.5d0/(1.0d0+costtab(i+1))
6731         cosfac=dsqrt(cosfac2)
6732         sinfac2=0.5d0/(1.0d0-costtab(i+1))
6733         sinfac=dsqrt(sinfac2)
6734         it=iabs(itype(i))
6735         if (it.eq.10) goto 1
6736 c
6737 C  Compute the axes of tghe local cartesian coordinates system; store in
6738 c   x_prime, y_prime and z_prime
6739 c
6740         do j=1,3
6741           x_prime(j) = 0.00
6742           y_prime(j) = 0.00
6743           z_prime(j) = 0.00
6744         enddo
6745 C        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
6746 C     &   dc_norm(3,i+nres)
6747         do j = 1,3
6748           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
6749           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
6750         enddo
6751         do j = 1,3
6752           z_prime(j) = -uz(j,i-1)*dsign(1.0d0,dfloat(itype(i)))
6753         enddo
6754 c       write (2,*) "i",i
6755 c       write (2,*) "x_prime",(x_prime(j),j=1,3)
6756 c       write (2,*) "y_prime",(y_prime(j),j=1,3)
6757 c       write (2,*) "z_prime",(z_prime(j),j=1,3)
6758 c       write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
6759 c      & " xy",scalar(x_prime(1),y_prime(1)),
6760 c      & " xz",scalar(x_prime(1),z_prime(1)),
6761 c      & " yy",scalar(y_prime(1),y_prime(1)),
6762 c      & " yz",scalar(y_prime(1),z_prime(1)),
6763 c      & " zz",scalar(z_prime(1),z_prime(1))
6764 c
6765 C Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
6766 C to local coordinate system. Store in xx, yy, zz.
6767 c
6768         xx=0.0d0
6769         yy=0.0d0
6770         zz=0.0d0
6771         do j = 1,3
6772           xx = xx + x_prime(j)*dc_norm(j,i+nres)
6773           yy = yy + y_prime(j)*dc_norm(j,i+nres)
6774           zz = zz + z_prime(j)*dc_norm(j,i+nres)
6775         enddo
6776
6777         xxtab(i)=xx
6778         yytab(i)=yy
6779         zztab(i)=zz
6780 C
6781 C Compute the energy of the ith side cbain
6782 C
6783 c        write (2,*) "xx",xx," yy",yy," zz",zz
6784         it=iabs(itype(i))
6785         do j = 1,65
6786           x(j) = sc_parmin(j,it)
6787         enddo
6788 #ifdef CHECK_COORD
6789 Cc diagnostics - remove later
6790         xx1 = dcos(alph(2))
6791         yy1 = dsin(alph(2))*dcos(omeg(2))
6792         zz1 = -dsign(1.0,dfloat(itype(i)))*dsin(alph(2))*dsin(omeg(2))
6793         write(2,'(3f8.1,3f9.3,1x,3f9.3)')
6794      &    alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,
6795      &    xx1,yy1,zz1
6796 C,"  --- ", xx_w,yy_w,zz_w
6797 c end diagnostics
6798 #endif
6799         sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
6800      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
6801      &   + x(10)*yy*zz
6802         sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
6803      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
6804      & + x(20)*yy*zz
6805         sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
6806      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
6807      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
6808      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
6809      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
6810      &  +x(40)*xx*yy*zz
6811         sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
6812      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
6813      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
6814      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
6815      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
6816      &  +x(60)*xx*yy*zz
6817         dsc_i   = 0.743d0+x(61)
6818         dp2_i   = 1.9d0+x(62)
6819         dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
6820      &          *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
6821         dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
6822      &          *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
6823         s1=(1+x(63))/(0.1d0 + dscp1)
6824         s1_6=(1+x(64))/(0.1d0 + dscp1**6)
6825         s2=(1+x(65))/(0.1d0 + dscp2)
6826         s2_6=(1+x(65))/(0.1d0 + dscp2**6)
6827         sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6)
6828      & + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
6829 c        write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
6830 c     &   sumene4,
6831 c     &   dscp1,dscp2,sumene
6832 c        sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6833         escloc = escloc + sumene
6834         if (energy_dec) write (2,*) "i",i," itype",itype(i)," it",it,
6835      &   " escloc",sumene,escloc,it,itype(i)
6836 c     & ,zz,xx,yy
6837 c#define DEBUG
6838 #ifdef DEBUG
6839 C
6840 C This section to check the numerical derivatives of the energy of ith side
6841 C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
6842 C #define DEBUG in the code to turn it on.
6843 C
6844         write (2,*) "sumene               =",sumene
6845         aincr=1.0d-7
6846         xxsave=xx
6847         xx=xx+aincr
6848         write (2,*) xx,yy,zz
6849         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6850         de_dxx_num=(sumenep-sumene)/aincr
6851         xx=xxsave
6852         write (2,*) "xx+ sumene from enesc=",sumenep
6853         yysave=yy
6854         yy=yy+aincr
6855         write (2,*) xx,yy,zz
6856         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6857         de_dyy_num=(sumenep-sumene)/aincr
6858         yy=yysave
6859         write (2,*) "yy+ sumene from enesc=",sumenep
6860         zzsave=zz
6861         zz=zz+aincr
6862         write (2,*) xx,yy,zz
6863         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6864         de_dzz_num=(sumenep-sumene)/aincr
6865         zz=zzsave
6866         write (2,*) "zz+ sumene from enesc=",sumenep
6867         costsave=cost2tab(i+1)
6868         sintsave=sint2tab(i+1)
6869         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
6870         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
6871         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6872         de_dt_num=(sumenep-sumene)/aincr
6873         write (2,*) " t+ sumene from enesc=",sumenep
6874         cost2tab(i+1)=costsave
6875         sint2tab(i+1)=sintsave
6876 C End of diagnostics section.
6877 #endif
6878 C
6879 C Compute the gradient of esc
6880 C
6881 c        zz=zz*dsign(1.0,dfloat(itype(i)))
6882         pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
6883         pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
6884         pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
6885         pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
6886         pom_dx=dsc_i*dp2_i*cost2tab(i+1)
6887         pom_dy=dsc_i*dp2_i*sint2tab(i+1)
6888         pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
6889         pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
6890         pom1=(sumene3*sint2tab(i+1)+sumene1)
6891      &     *(pom_s1/dscp1+pom_s16*dscp1**4)
6892         pom2=(sumene4*cost2tab(i+1)+sumene2)
6893      &     *(pom_s2/dscp2+pom_s26*dscp2**4)
6894         sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
6895         sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2
6896      &  +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2)
6897      &  +x(40)*yy*zz
6898         sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
6899         sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2
6900      &  +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2)
6901      &  +x(60)*yy*zz
6902         de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6)
6903      &        +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6)
6904      &        +(pom1+pom2)*pom_dx
6905 #ifdef DEBUG
6906         write(2,*), "de_dxx = ", de_dxx,de_dxx_num,itype(i)
6907 #endif
6908 C
6909         sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
6910         sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2
6911      &  +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2)
6912      &  +x(40)*xx*zz
6913         sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
6914         sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz
6915      &  +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz
6916      &  +x(59)*zz**2 +x(60)*xx*zz
6917         de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6)
6918      &        +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6)
6919      &        +(pom1-pom2)*pom_dy
6920 #ifdef DEBUG
6921         write(2,*), "de_dyy = ", de_dyy,de_dyy_num,itype(i)
6922 #endif
6923 C
6924         de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy
6925      &  +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx
6926      &  +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6)
6927      &  +(x(4) + 2*x(7)*zz+  x(8)*xx + x(10)*yy)*(s1+s1_6)
6928      &  +(x(44)+2*x(47)*zz +x(48)*xx   +x(50)*yy  +3*x(53)*zz**2
6929      &  +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy
6930      &  +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6)
6931      &  + ( x(14) + 2*x(17)*zz+  x(18)*xx + x(20)*yy)*(s2+s2_6)
6932 #ifdef DEBUG
6933         write(2,*), "de_dzz = ", de_dzz,de_dzz_num,itype(i)
6934 #endif
6935 C
6936         de_dt =  0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6)
6937      &  -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6)
6938      &  +pom1*pom_dt1+pom2*pom_dt2
6939 #ifdef DEBUG
6940         write(2,*), "de_dt = ", de_dt,de_dt_num,itype(i)
6941 #endif
6942 c#undef DEBUG
6943 c
6944 C
6945        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
6946        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
6947        cosfac2xx=cosfac2*xx
6948        sinfac2yy=sinfac2*yy
6949        do k = 1,3
6950          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))*
6951      &      vbld_inv(i+1)
6952          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))*
6953      &      vbld_inv(i)
6954          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
6955          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
6956 c         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
6957 c     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
6958 c         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
6959 c     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
6960          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
6961          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
6962          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
6963          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
6964          dZZ_Ci1(k)=0.0d0
6965          dZZ_Ci(k)=0.0d0
6966          do j=1,3
6967            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)
6968      &     *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
6969            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)
6970      &     *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
6971          enddo
6972
6973          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
6974          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
6975          dZZ_XYZ(k)=vbld_inv(i+nres)*
6976      &   (z_prime(k)-zz*dC_norm(k,i+nres))
6977 c
6978          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
6979          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
6980        enddo
6981
6982        do k=1,3
6983          dXX_Ctab(k,i)=dXX_Ci(k)
6984          dXX_C1tab(k,i)=dXX_Ci1(k)
6985          dYY_Ctab(k,i)=dYY_Ci(k)
6986          dYY_C1tab(k,i)=dYY_Ci1(k)
6987          dZZ_Ctab(k,i)=dZZ_Ci(k)
6988          dZZ_C1tab(k,i)=dZZ_Ci1(k)
6989          dXX_XYZtab(k,i)=dXX_XYZ(k)
6990          dYY_XYZtab(k,i)=dYY_XYZ(k)
6991          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
6992        enddo
6993
6994        do k = 1,3
6995 c         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
6996 c     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
6997 c         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
6998 c     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
6999 c         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
7000 c     &    dt_dci(k)
7001 c         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
7002 c     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
7003          gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k)
7004      &    +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
7005          gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k)
7006      &    +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
7007          gsclocx(k,i)=                 de_dxx*dxx_XYZ(k)
7008      &    +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
7009        enddo
7010 c       write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
7011 c     &  (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
7012
7013 C to check gradient call subroutine check_grad
7014
7015     1 continue
7016       enddo
7017       return
7018       end
7019 c------------------------------------------------------------------------------
7020       double precision function enesc(x,xx,yy,zz,cost2,sint2)
7021       implicit none
7022       double precision x(65),xx,yy,zz,cost2,sint2,sumene1,sumene2,
7023      & sumene3,sumene4,sumene,dsc_i,dp2_i,dscp1,dscp2,s1,s1_6,s2,s2_6
7024       sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
7025      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
7026      &   + x(10)*yy*zz
7027       sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
7028      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
7029      & + x(20)*yy*zz
7030       sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
7031      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
7032      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
7033      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
7034      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
7035      &  +x(40)*xx*yy*zz
7036       sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
7037      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
7038      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
7039      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
7040      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
7041      &  +x(60)*xx*yy*zz
7042       dsc_i   = 0.743d0+x(61)
7043       dp2_i   = 1.9d0+x(62)
7044       dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
7045      &          *(xx*cost2+yy*sint2))
7046       dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
7047      &          *(xx*cost2-yy*sint2))
7048       s1=(1+x(63))/(0.1d0 + dscp1)
7049       s1_6=(1+x(64))/(0.1d0 + dscp1**6)
7050       s2=(1+x(65))/(0.1d0 + dscp2)
7051       s2_6=(1+x(65))/(0.1d0 + dscp2**6)
7052       sumene = ( sumene3*sint2 + sumene1)*(s1+s1_6)
7053      & + (sumene4*cost2 +sumene2)*(s2+s2_6)
7054       enesc=sumene
7055       return
7056       end
7057 #endif
7058 c------------------------------------------------------------------------------
7059       subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
7060 C
7061 C This procedure calculates two-body contact function g(rij) and its derivative:
7062 C
7063 C           eps0ij                                     !       x < -1
7064 C g(rij) =  esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5)  ! -1 =< x =< 1
7065 C            0                                         !       x > 1
7066 C
7067 C where x=(rij-r0ij)/delta
7068 C
7069 C rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
7070 C
7071       implicit none
7072       double precision rij,r0ij,eps0ij,fcont,fprimcont
7073       double precision x,x2,x4,delta
7074 c     delta=0.02D0*r0ij
7075 c      delta=0.2D0*r0ij
7076       x=(rij-r0ij)/delta
7077       if (x.lt.-1.0D0) then
7078         fcont=eps0ij
7079         fprimcont=0.0D0
7080       else if (x.le.1.0D0) then
7081         x2=x*x
7082         x4=x2*x2
7083         fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
7084         fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
7085       else
7086         fcont=0.0D0
7087         fprimcont=0.0D0
7088       endif
7089       return
7090       end
7091 c------------------------------------------------------------------------------
7092       subroutine splinthet(theti,delta,ss,ssder)
7093       implicit real*8 (a-h,o-z)
7094       include 'DIMENSIONS'
7095       include 'COMMON.VAR'
7096       include 'COMMON.GEO'
7097       thetup=pi-delta
7098       thetlow=delta
7099       if (theti.gt.pipol) then
7100         call gcont(theti,thetup,1.0d0,delta,ss,ssder)
7101       else
7102         call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
7103         ssder=-ssder
7104       endif
7105       return
7106       end
7107 c------------------------------------------------------------------------------
7108       subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
7109       implicit none
7110       double precision x,x0,delta,f0,f1,fprim0,f,fprim
7111       double precision ksi,ksi2,ksi3,a1,a2,a3
7112       a1=fprim0*delta/(f1-f0)
7113       a2=3.0d0-2.0d0*a1
7114       a3=a1-2.0d0
7115       ksi=(x-x0)/delta
7116       ksi2=ksi*ksi
7117       ksi3=ksi2*ksi
7118       f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
7119       fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
7120       return
7121       end
7122 c------------------------------------------------------------------------------
7123       subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
7124       implicit none
7125       double precision x,x0,delta,f0x,f1x,fprim0x,fx
7126       double precision ksi,ksi2,ksi3,a1,a2,a3
7127       ksi=(x-x0)/delta
7128       ksi2=ksi*ksi
7129       ksi3=ksi2*ksi
7130       a1=fprim0x*delta
7131       a2=3*(f1x-f0x)-2*fprim0x*delta
7132       a3=fprim0x*delta-2*(f1x-f0x)
7133       fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
7134       return
7135       end
7136 C-----------------------------------------------------------------------------
7137 #ifdef CRYST_TOR
7138 C-----------------------------------------------------------------------------
7139       subroutine etor(etors)
7140       implicit real*8 (a-h,o-z)
7141       include 'DIMENSIONS'
7142       include 'COMMON.VAR'
7143       include 'COMMON.GEO'
7144       include 'COMMON.LOCAL'
7145       include 'COMMON.TORSION'
7146       include 'COMMON.INTERACT'
7147       include 'COMMON.DERIV'
7148       include 'COMMON.CHAIN'
7149       include 'COMMON.NAMES'
7150       include 'COMMON.IOUNITS'
7151       include 'COMMON.FFIELD'
7152       include 'COMMON.TORCNSTR'
7153       include 'COMMON.CONTROL'
7154       logical lprn
7155 C Set lprn=.true. for debugging
7156       lprn=.false.
7157 c      lprn=.true.
7158       etors=0.0D0
7159       do i=iphi_start,iphi_end
7160       etors_ii=0.0D0
7161         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
7162      &      .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
7163         itori=itortyp(itype(i-2))
7164         itori1=itortyp(itype(i-1))
7165         phii=phi(i)
7166         gloci=0.0D0
7167 C Proline-Proline pair is a special case...
7168         if (itori.eq.3 .and. itori1.eq.3) then
7169           if (phii.gt.-dwapi3) then
7170             cosphi=dcos(3*phii)
7171             fac=1.0D0/(1.0D0-cosphi)
7172             etorsi=v1(1,3,3)*fac
7173             etorsi=etorsi+etorsi
7174             etors=etors+etorsi-v1(1,3,3)
7175             if (energy_dec) etors_ii=etors_ii+etorsi-v1(1,3,3)
7176             gloci=gloci-3*fac*etorsi*dsin(3*phii)
7177           endif
7178           do j=1,3
7179             v1ij=v1(j+1,itori,itori1)
7180             v2ij=v2(j+1,itori,itori1)
7181             cosphi=dcos(j*phii)
7182             sinphi=dsin(j*phii)
7183             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7184             if (energy_dec) etors_ii=etors_ii+
7185      &                              v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7186             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7187           enddo
7188         else
7189           do j=1,nterm_old
7190             v1ij=v1(j,itori,itori1)
7191             v2ij=v2(j,itori,itori1)
7192             cosphi=dcos(j*phii)
7193             sinphi=dsin(j*phii)
7194             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7195             if (energy_dec) etors_ii=etors_ii+
7196      &                  v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7197             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7198           enddo
7199         endif
7200         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
7201              'etor',i,etors_ii
7202         if (lprn)
7203      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
7204      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
7205      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
7206         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
7207 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
7208       enddo
7209       return
7210       end
7211 c------------------------------------------------------------------------------
7212       subroutine etor_d(etors_d)
7213       etors_d=0.0d0
7214       return
7215       end
7216 c----------------------------------------------------------------------------
7217 c LICZENIE WIEZOW Z ROWNANIA ENERGII MODELLERA
7218       subroutine e_modeller(ehomology_constr)
7219       ehomology_constr=0.0d0
7220       write (iout,*) "!!!!!UWAGA, JESTEM W DZIWNEJ PETLI, TEST!!!!!"
7221       return
7222       end
7223 C !!!!!!!! NIE CZYTANE !!!!!!!!!!!
7224
7225 c------------------------------------------------------------------------------
7226       subroutine etor_d(etors_d)
7227       etors_d=0.0d0
7228       return
7229       end
7230 c----------------------------------------------------------------------------
7231 #else
7232       subroutine etor(etors)
7233       implicit real*8 (a-h,o-z)
7234       include 'DIMENSIONS'
7235       include 'COMMON.VAR'
7236       include 'COMMON.GEO'
7237       include 'COMMON.LOCAL'
7238       include 'COMMON.TORSION'
7239       include 'COMMON.INTERACT'
7240       include 'COMMON.DERIV'
7241       include 'COMMON.CHAIN'
7242       include 'COMMON.NAMES'
7243       include 'COMMON.IOUNITS'
7244       include 'COMMON.FFIELD'
7245       include 'COMMON.TORCNSTR'
7246       include 'COMMON.CONTROL'
7247       logical lprn
7248 C Set lprn=.true. for debugging
7249       lprn=.false.
7250 c     lprn=.true.
7251       etors=0.0D0
7252       do i=iphi_start,iphi_end
7253 C ANY TWO ARE DUMMY ATOMS in row CYCLE
7254 c        if (((itype(i-3).eq.ntyp1).and.(itype(i-2).eq.ntyp1)).or.
7255 c     &      ((itype(i-2).eq.ntyp1).and.(itype(i-1).eq.ntyp1))  .or.
7256 c     &      ((itype(i-1).eq.ntyp1).and.(itype(i).eq.ntyp1))) cycle
7257         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
7258      &      .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
7259 C In current verion the ALL DUMMY ATOM POTENTIALS ARE OFF
7260 C For introducing the NH3+ and COO- group please check the etor_d for reference
7261 C and guidance
7262         etors_ii=0.0D0
7263          if (iabs(itype(i)).eq.20) then
7264          iblock=2
7265          else
7266          iblock=1
7267          endif
7268         itori=itortyp(itype(i-2))
7269         itori1=itortyp(itype(i-1))
7270         phii=phi(i)
7271         gloci=0.0D0
7272 C Regular cosine and sine terms
7273         do j=1,nterm(itori,itori1,iblock)
7274           v1ij=v1(j,itori,itori1,iblock)
7275           v2ij=v2(j,itori,itori1,iblock)
7276           cosphi=dcos(j*phii)
7277           sinphi=dsin(j*phii)
7278           etors=etors+v1ij*cosphi+v2ij*sinphi
7279           if (energy_dec) etors_ii=etors_ii+
7280      &                v1ij*cosphi+v2ij*sinphi
7281           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7282         enddo
7283 C Lorentz terms
7284 C                         v1
7285 C  E = SUM ----------------------------------- - v1
7286 C          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
7287 C
7288         cosphi=dcos(0.5d0*phii)
7289         sinphi=dsin(0.5d0*phii)
7290         do j=1,nlor(itori,itori1,iblock)
7291           vl1ij=vlor1(j,itori,itori1)
7292           vl2ij=vlor2(j,itori,itori1)
7293           vl3ij=vlor3(j,itori,itori1)
7294           pom=vl2ij*cosphi+vl3ij*sinphi
7295           pom1=1.0d0/(pom*pom+1.0d0)
7296           etors=etors+vl1ij*pom1
7297           if (energy_dec) etors_ii=etors_ii+
7298      &                vl1ij*pom1
7299           pom=-pom*pom1*pom1
7300           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
7301         enddo
7302 C Subtract the constant term
7303         etors=etors-v0(itori,itori1,iblock)
7304           if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
7305      &         'etor',i,etors_ii-v0(itori,itori1,iblock)
7306         if (lprn)
7307      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
7308      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
7309      &  (v1(j,itori,itori1,iblock),j=1,6),
7310      &  (v2(j,itori,itori1,iblock),j=1,6)
7311         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
7312 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
7313       enddo
7314       return
7315       end
7316 c----------------------------------------------------------------------------
7317       subroutine etor_d(etors_d)
7318 C 6/23/01 Compute double torsional energy
7319       implicit real*8 (a-h,o-z)
7320       include 'DIMENSIONS'
7321       include 'COMMON.VAR'
7322       include 'COMMON.GEO'
7323       include 'COMMON.LOCAL'
7324       include 'COMMON.TORSION'
7325       include 'COMMON.INTERACT'
7326       include 'COMMON.DERIV'
7327       include 'COMMON.CHAIN'
7328       include 'COMMON.NAMES'
7329       include 'COMMON.IOUNITS'
7330       include 'COMMON.FFIELD'
7331       include 'COMMON.TORCNSTR'
7332       logical lprn
7333 C Set lprn=.true. for debugging
7334       lprn=.false.
7335 c     lprn=.true.
7336       etors_d=0.0D0
7337 c      write(iout,*) "a tu??"
7338       do i=iphid_start,iphid_end
7339 C ANY TWO ARE DUMMY ATOMS in row CYCLE
7340 C        if (((itype(i-3).eq.ntyp1).and.(itype(i-2).eq.ntyp1)).or.
7341 C     &      ((itype(i-2).eq.ntyp1).and.(itype(i-1).eq.ntyp1)).or.
7342 C     &      ((itype(i-1).eq.ntyp1).and.(itype(i).eq.ntyp1))  .or.
7343 C     &      ((itype(i).eq.ntyp1).and.(itype(i+1).eq.ntyp1))) cycle
7344          if ((itype(i-2).eq.ntyp1).or.itype(i-3).eq.ntyp1.or.
7345      &  (itype(i-1).eq.ntyp1).or.(itype(i).eq.ntyp1).or.
7346      &  (itype(i+1).eq.ntyp1)) cycle
7347 C In current verion the ALL DUMMY ATOM POTENTIALS ARE OFF
7348         itori=itortyp(itype(i-2))
7349         itori1=itortyp(itype(i-1))
7350         itori2=itortyp(itype(i))
7351         phii=phi(i)
7352         phii1=phi(i+1)
7353         gloci1=0.0D0
7354         gloci2=0.0D0
7355         iblock=1
7356         if (iabs(itype(i+1)).eq.20) iblock=2
7357 C Iblock=2 Proline type
7358 C ADASKO: WHEN PARAMETERS FOR THIS TYPE OF BLOCKING GROUP IS READY UNCOMMENT
7359 C CHECK WEATHER THERE IS NECCESITY FOR iblock=3 for COO-
7360 C        if (itype(i+1).eq.ntyp1) iblock=3
7361 C The problem of NH3+ group can be resolved by adding new parameters please note if there
7362 C IS or IS NOT need for this
7363 C IF Yes uncomment below and add to parmread.F appropriate changes and to v1cij and so on
7364 C        is (itype(i-3).eq.ntyp1) ntblock=2
7365 C        ntblock is N-terminal blocking group
7366
7367 C Regular cosine and sine terms
7368         do j=1,ntermd_1(itori,itori1,itori2,iblock)
7369 C Example of changes for NH3+ blocking group
7370 C       do j=1,ntermd_1(itori,itori1,itori2,iblock,ntblock)
7371 C          v1cij=v1c(1,j,itori,itori1,itori2,iblock,ntblock)
7372           v1cij=v1c(1,j,itori,itori1,itori2,iblock)
7373           v1sij=v1s(1,j,itori,itori1,itori2,iblock)
7374           v2cij=v1c(2,j,itori,itori1,itori2,iblock)
7375           v2sij=v1s(2,j,itori,itori1,itori2,iblock)
7376           cosphi1=dcos(j*phii)
7377           sinphi1=dsin(j*phii)
7378           cosphi2=dcos(j*phii1)
7379           sinphi2=dsin(j*phii1)
7380           etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+
7381      &     v2cij*cosphi2+v2sij*sinphi2
7382           gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
7383           gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
7384         enddo
7385         do k=2,ntermd_2(itori,itori1,itori2,iblock)
7386           do l=1,k-1
7387             v1cdij = v2c(k,l,itori,itori1,itori2,iblock)
7388             v2cdij = v2c(l,k,itori,itori1,itori2,iblock)
7389             v1sdij = v2s(k,l,itori,itori1,itori2,iblock)
7390             v2sdij = v2s(l,k,itori,itori1,itori2,iblock)
7391             cosphi1p2=dcos(l*phii+(k-l)*phii1)
7392             cosphi1m2=dcos(l*phii-(k-l)*phii1)
7393             sinphi1p2=dsin(l*phii+(k-l)*phii1)
7394             sinphi1m2=dsin(l*phii-(k-l)*phii1)
7395             etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+
7396      &        v1sdij*sinphi1p2+v2sdij*sinphi1m2
7397             gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2
7398      &        -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
7399             gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2
7400      &        -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
7401           enddo
7402         enddo
7403         gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*gloci1
7404         gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*gloci2
7405       enddo
7406       return
7407       end
7408 #endif
7409 C----------------------------------------------------------------------------------
7410 C The rigorous attempt to derive energy function
7411       subroutine etor_kcc(etors)
7412       implicit real*8 (a-h,o-z)
7413       include 'DIMENSIONS'
7414       include 'COMMON.VAR'
7415       include 'COMMON.GEO'
7416       include 'COMMON.LOCAL'
7417       include 'COMMON.TORSION'
7418       include 'COMMON.INTERACT'
7419       include 'COMMON.DERIV'
7420       include 'COMMON.CHAIN'
7421       include 'COMMON.NAMES'
7422       include 'COMMON.IOUNITS'
7423       include 'COMMON.FFIELD'
7424       include 'COMMON.TORCNSTR'
7425       include 'COMMON.CONTROL'
7426       double precision c1(0:maxval_kcc),c2(0:maxval_kcc)
7427       logical lprn
7428 c      double precision thybt1(maxtermkcc),thybt2(maxtermkcc)
7429 C Set lprn=.true. for debugging
7430       lprn=energy_dec
7431 c     lprn=.true.
7432 C      print *,"wchodze kcc"
7433       if (lprn) write (iout,*) "etor_kcc tor_mode",tor_mode
7434       etors=0.0D0
7435       do i=iphi_start,iphi_end
7436 C ANY TWO ARE DUMMY ATOMS in row CYCLE
7437 c        if (((itype(i-3).eq.ntyp1).and.(itype(i-2).eq.ntyp1)).or.
7438 c     &      ((itype(i-2).eq.ntyp1).and.(itype(i-1).eq.ntyp1))  .or.
7439 c     &      ((itype(i-1).eq.ntyp1).and.(itype(i).eq.ntyp1))) cycle
7440         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
7441      &      .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
7442         itori=itortyp(itype(i-2))
7443         itori1=itortyp(itype(i-1))
7444         phii=phi(i)
7445         glocig=0.0D0
7446         glocit1=0.0d0
7447         glocit2=0.0d0
7448 C to avoid multiple devision by 2
7449 c        theti22=0.5d0*theta(i)
7450 C theta 12 is the theta_1 /2
7451 C theta 22 is theta_2 /2
7452 c        theti12=0.5d0*theta(i-1)
7453 C and appropriate sinus function
7454         sinthet1=dsin(theta(i-1))
7455         sinthet2=dsin(theta(i))
7456         costhet1=dcos(theta(i-1))
7457         costhet2=dcos(theta(i))
7458 C to speed up lets store its mutliplication
7459         sint1t2=sinthet2*sinthet1
7460         sint1t2n=1.0d0
7461 C \sum_{i=1}^n (sin(theta_1) * sin(theta_2))^n * (c_n* cos(n*gamma)
7462 C +d_n*sin(n*gamma)) *
7463 C \sum_{i=1}^m (1+a_m*Tb_m(cos(theta_1 /2))+b_m*Tb_m(cos(theta_2 /2)))
7464 C we have two sum 1) Non-Chebyshev which is with n and gamma
7465         nval=nterm_kcc_Tb(itori,itori1)
7466         c1(0)=0.0d0
7467         c2(0)=0.0d0
7468         c1(1)=1.0d0
7469         c2(1)=1.0d0
7470         do j=2,nval
7471           c1(j)=c1(j-1)*costhet1
7472           c2(j)=c2(j-1)*costhet2
7473         enddo
7474         etori=0.0d0
7475         do j=1,nterm_kcc(itori,itori1)
7476           cosphi=dcos(j*phii)
7477           sinphi=dsin(j*phii)
7478           sint1t2n1=sint1t2n
7479           sint1t2n=sint1t2n*sint1t2
7480           sumvalc=0.0d0
7481           gradvalct1=0.0d0
7482           gradvalct2=0.0d0
7483           do k=1,nval
7484             do l=1,nval
7485               sumvalc=sumvalc+v1_kcc(l,k,j,itori1,itori)*c1(k)*c2(l)
7486               gradvalct1=gradvalct1+
7487      &           (k-1)*v1_kcc(l,k,j,itori1,itori)*c1(k-1)*c2(l)
7488               gradvalct2=gradvalct2+
7489      &           (l-1)*v1_kcc(l,k,j,itori1,itori)*c1(k)*c2(l-1)
7490             enddo
7491           enddo
7492           gradvalct1=-gradvalct1*sinthet1
7493           gradvalct2=-gradvalct2*sinthet2
7494           sumvals=0.0d0
7495           gradvalst1=0.0d0
7496           gradvalst2=0.0d0
7497           do k=1,nval
7498             do l=1,nval
7499               sumvals=sumvals+v2_kcc(l,k,j,itori1,itori)*c1(k)*c2(l)
7500               gradvalst1=gradvalst1+
7501      &           (k-1)*v2_kcc(l,k,j,itori1,itori)*c1(k-1)*c2(l)
7502               gradvalst2=gradvalst2+
7503      &           (l-1)*v2_kcc(l,k,j,itori1,itori)*c1(k)*c2(l-1)
7504             enddo
7505           enddo
7506           gradvalst1=-gradvalst1*sinthet1
7507           gradvalst2=-gradvalst2*sinthet2
7508           if (lprn) write (iout,*)j,"sumvalc",sumvalc," sumvals",sumvals
7509           etori=etori+sint1t2n*(sumvalc*cosphi+sumvals*sinphi)
7510 C glocig is the gradient local i site in gamma
7511           glocig=glocig+j*sint1t2n*(sumvals*cosphi-sumvalc*sinphi)
7512 C now gradient over theta_1
7513           glocit1=glocit1+sint1t2n*(gradvalct1*cosphi+gradvalst1*sinphi)
7514      &   +j*sint1t2n1*costhet1*sinthet2*(sumvalc*cosphi+sumvals*sinphi)
7515           glocit2=glocit2+sint1t2n*(gradvalct2*cosphi+gradvalst2*sinphi)
7516      &   +j*sint1t2n1*sinthet1*costhet2*(sumvalc*cosphi+sumvals*sinphi)
7517         enddo ! j
7518         etors=etors+etori
7519 C derivative over gamma
7520         gloc(i-3,icg)=gloc(i-3,icg)+wtor*glocig
7521 C derivative over theta1
7522         gloc(nphi+i-3,icg)=gloc(nphi+i-3,icg)+wtor*glocit1
7523 C now derivative over theta2
7524         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)+wtor*glocit2
7525         if (lprn) then
7526           write (iout,*) i-2,i-1,itype(i-2),itype(i-1),itori,itori1,
7527      &       theta(i-1)*rad2deg,theta(i)*rad2deg,phii*rad2deg,etori
7528           write (iout,*) "c1",(c1(k),k=0,nval),
7529      &    " c2",(c2(k),k=0,nval)
7530         endif
7531       enddo
7532       return
7533       end
7534 c---------------------------------------------------------------------------------------------
7535       subroutine etor_constr(edihcnstr)
7536       implicit real*8 (a-h,o-z)
7537       include 'DIMENSIONS'
7538       include 'COMMON.VAR'
7539       include 'COMMON.GEO'
7540       include 'COMMON.LOCAL'
7541       include 'COMMON.TORSION'
7542       include 'COMMON.INTERACT'
7543       include 'COMMON.DERIV'
7544       include 'COMMON.CHAIN'
7545       include 'COMMON.NAMES'
7546       include 'COMMON.IOUNITS'
7547       include 'COMMON.FFIELD'
7548       include 'COMMON.TORCNSTR'
7549       include 'COMMON.BOUNDS'
7550       include 'COMMON.CONTROL'
7551 ! 6/20/98 - dihedral angle constraints
7552       edihcnstr=0.0d0
7553 c      do i=1,ndih_constr
7554       if (raw_psipred) then
7555         do i=idihconstr_start,idihconstr_end
7556           itori=idih_constr(i)
7557           phii=phi(itori)
7558           gaudih_i=vpsipred(1,i)
7559           gauder_i=0.0d0
7560           do j=1,2
7561             s = sdihed(j,i)
7562             cos_i=(1.0d0-dcos(phii-phibound(j,i)))/s**2
7563             dexpcos_i=dexp(-cos_i*cos_i)
7564             gaudih_i=gaudih_i+vpsipred(j+1,i)*dexpcos_i
7565             gauder_i=gauder_i-2*vpsipred(j+1,i)*dsin(phii-phibound(j,i))
7566      &            *cos_i*dexpcos_i/s**2
7567           enddo
7568           edihcnstr=edihcnstr-wdihc*dlog(gaudih_i)
7569           gloc(itori-3,icg)=gloc(itori-3,icg)-wdihc*gauder_i/gaudih_i
7570           if (energy_dec)
7571      &     write (iout,'(2i5,f8.3,f8.5,2(f8.5,2f8.3),f10.5)')
7572      &     i,itori,phii*rad2deg,vpsipred(1,i),vpsipred(2,i),
7573      &     phibound(1,i)*rad2deg,sdihed(1,i)*rad2deg,vpsipred(3,i),
7574      &     phibound(2,i)*rad2deg,sdihed(2,i)*rad2deg,
7575      &     -wdihc*dlog(gaudih_i)
7576         enddo
7577       else
7578
7579       do i=idihconstr_start,idihconstr_end
7580         itori=idih_constr(i)
7581         phii=phi(itori)
7582         difi=pinorm(phii-phi0(i))
7583         if (difi.gt.drange(i)) then
7584           difi=difi-drange(i)
7585           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
7586           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
7587         else if (difi.lt.-drange(i)) then
7588           difi=difi+drange(i)
7589           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
7590           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
7591         else
7592           difi=0.0
7593         endif
7594       enddo
7595
7596       endif
7597
7598       return
7599       end
7600 c----------------------------------------------------------------------------
7601 c MODELLER restraint function
7602       subroutine e_modeller(ehomology_constr)
7603       implicit none
7604       include 'DIMENSIONS'
7605
7606       double precision ehomology_constr
7607       integer nnn,i,ii,j,k,ijk,jik,ki,kk,nexl,irec,l
7608       integer katy, odleglosci, test7
7609       real*8 odleg, odleg2, odleg3, kat, kat2, kat3, gdih(max_template)
7610       real*8 Eval,Erot
7611       real*8 distance(max_template),distancek(max_template),
7612      &    min_odl,godl(max_template),dih_diff(max_template)
7613
7614 c
7615 c     FP - 30/10/2014 Temporary specifications for homology restraints
7616 c
7617       double precision utheta_i,gutheta_i,sum_gtheta,sum_sgtheta,
7618      &                 sgtheta
7619       double precision, dimension (maxres) :: guscdiff,usc_diff
7620       double precision, dimension (max_template) ::
7621      &           gtheta,dscdiff,uscdiffk,guscdiff2,guscdiff3,
7622      &           theta_diff
7623       double precision sum_godl,sgodl,grad_odl3,ggodl,sum_gdih,
7624      & sum_guscdiff,sum_sgdih,sgdih,grad_dih3,usc_diff_i,dxx,dyy,dzz,
7625      & betai,sum_sgodl,dij
7626       double precision dist,pinorm
7627 c
7628       include 'COMMON.SBRIDGE'
7629       include 'COMMON.CHAIN'
7630       include 'COMMON.GEO'
7631       include 'COMMON.DERIV'
7632       include 'COMMON.LOCAL'
7633       include 'COMMON.INTERACT'
7634       include 'COMMON.VAR'
7635       include 'COMMON.IOUNITS'
7636 c      include 'COMMON.MD'
7637       include 'COMMON.CONTROL'
7638       include 'COMMON.HOMOLOGY'
7639       include 'COMMON.QRESTR'
7640 c
7641 c     From subroutine Econstr_back
7642 c
7643       include 'COMMON.NAMES'
7644       include 'COMMON.TIME1'
7645 c
7646
7647
7648       do i=1,max_template
7649         distancek(i)=9999999.9
7650       enddo
7651
7652
7653       odleg=0.0d0
7654
7655 c Pseudo-energy and gradient from homology restraints (MODELLER-like
7656 c function)
7657 C AL 5/2/14 - Introduce list of restraints
7658 c     write(iout,*) "waga_theta",waga_theta,"waga_d",waga_d
7659 #ifdef DEBUG
7660       write(iout,*) "------- dist restrs start -------"
7661 #endif
7662       do ii = link_start_homo,link_end_homo
7663          i = ires_homo(ii)
7664          j = jres_homo(ii)
7665          dij=dist(i,j)
7666 c        write (iout,*) "dij(",i,j,") =",dij
7667          nexl=0
7668          do k=1,constr_homology
7669 c           write(iout,*) ii,k,i,j,l_homo(k,ii),dij,odl(k,ii)
7670            if(.not.l_homo(k,ii)) then
7671              nexl=nexl+1
7672              cycle
7673            endif
7674            distance(k)=odl(k,ii)-dij
7675 c          write (iout,*) "distance(",k,") =",distance(k)
7676 c
7677 c          For Gaussian-type Urestr
7678 c
7679            distancek(k)=0.5d0*distance(k)**2*sigma_odl(k,ii) ! waga_dist rmvd from Gaussian argument
7680 c          write (iout,*) "sigma_odl(",k,ii,") =",sigma_odl(k,ii)
7681 c          write (iout,*) "distancek(",k,") =",distancek(k)
7682 c          distancek(k)=0.5d0*waga_dist*distance(k)**2*sigma_odl(k,ii)
7683 c
7684 c          For Lorentzian-type Urestr
7685 c
7686            if (waga_dist.lt.0.0d0) then
7687               sigma_odlir(k,ii)=dsqrt(1/sigma_odl(k,ii))
7688               distancek(k)=distance(k)**2/(sigma_odlir(k,ii)*
7689      &                     (distance(k)**2+sigma_odlir(k,ii)**2))
7690            endif
7691          enddo
7692
7693 c         min_odl=minval(distancek)
7694          do kk=1,constr_homology
7695           if(l_homo(kk,ii)) then
7696             min_odl=distancek(kk)
7697             exit
7698           endif
7699          enddo
7700          do kk=1,constr_homology
7701           if(l_homo(kk,ii) .and. distancek(kk).lt.min_odl)
7702      &              min_odl=distancek(kk)
7703          enddo
7704
7705 c        write (iout,* )"min_odl",min_odl
7706 #ifdef DEBUG
7707          write (iout,*) "ij dij",i,j,dij
7708          write (iout,*) "distance",(distance(k),k=1,constr_homology)
7709          write (iout,*) "distancek",(distancek(k),k=1,constr_homology)
7710          write (iout,* )"min_odl",min_odl
7711 #endif
7712 #ifdef OLDRESTR
7713          odleg2=0.0d0
7714 #else
7715          if (waga_dist.ge.0.0d0) then
7716            odleg2=nexl
7717          else
7718            odleg2=0.0d0
7719          endif
7720 #endif
7721          do k=1,constr_homology
7722 c Nie wiem po co to liczycie jeszcze raz!
7723 c            odleg3=-waga_dist(iset)*((distance(i,j,k)**2)/
7724 c     &              (2*(sigma_odl(i,j,k))**2))
7725            if(.not.l_homo(k,ii)) cycle
7726            if (waga_dist.ge.0.0d0) then
7727 c
7728 c          For Gaussian-type Urestr
7729 c
7730             godl(k)=dexp(-distancek(k)+min_odl)
7731             odleg2=odleg2+godl(k)
7732 c
7733 c          For Lorentzian-type Urestr
7734 c
7735            else
7736             odleg2=odleg2+distancek(k)
7737            endif
7738
7739 ccc       write(iout,779) i,j,k, "odleg2=",odleg2, "odleg3=", odleg3,
7740 ccc     & "dEXP(odleg3)=", dEXP(odleg3),"distance(i,j,k)^2=",
7741 ccc     & distance(i,j,k)**2, "dist(i+1,j+1)=", dist(i+1,j+1),
7742 ccc     & "sigma_odl(i,j,k)=", sigma_odl(i,j,k)
7743
7744          enddo
7745 c        write (iout,*) "godl",(godl(k),k=1,constr_homology) ! exponents
7746 c        write (iout,*) "ii i j",ii,i,j," odleg2",odleg2 ! sum of exps
7747 #ifdef DEBUG
7748          write (iout,*) "godl",(godl(k),k=1,constr_homology) ! exponents
7749          write (iout,*) "ii i j",ii,i,j," odleg2",odleg2 ! sum of exps
7750 #endif
7751            if (waga_dist.ge.0.0d0) then
7752 c
7753 c          For Gaussian-type Urestr
7754 c
7755               odleg=odleg-dLOG(odleg2/constr_homology)+min_odl
7756 c
7757 c          For Lorentzian-type Urestr
7758 c
7759            else
7760               odleg=odleg+odleg2/constr_homology
7761            endif
7762 c
7763 c        write (iout,*) "odleg",odleg ! sum of -ln-s
7764 c Gradient
7765 c
7766 c          For Gaussian-type Urestr
7767 c
7768          if (waga_dist.ge.0.0d0) sum_godl=odleg2
7769          sum_sgodl=0.0d0
7770          do k=1,constr_homology
7771 c            godl=dexp(((-(distance(i,j,k)**2)/(2*(sigma_odl(i,j,k))**2))
7772 c     &           *waga_dist)+min_odl
7773 c          sgodl=-godl(k)*distance(k)*sigma_odl(k,ii)*waga_dist
7774 c
7775          if(.not.l_homo(k,ii)) cycle
7776          if (waga_dist.ge.0.0d0) then
7777 c          For Gaussian-type Urestr
7778 c
7779            sgodl=-godl(k)*distance(k)*sigma_odl(k,ii) ! waga_dist rmvd
7780 c
7781 c          For Lorentzian-type Urestr
7782 c
7783          else
7784            sgodl=-2*sigma_odlir(k,ii)*(distance(k)/(distance(k)**2+
7785      &           sigma_odlir(k,ii)**2)**2)
7786          endif
7787            sum_sgodl=sum_sgodl+sgodl
7788
7789 c            sgodl2=sgodl2+sgodl
7790 c      write(iout,*) i, j, k, distance(i,j,k), "W GRADIENCIE1"
7791 c      write(iout,*) "constr_homology=",constr_homology
7792 c      write(iout,*) i, j, k, "TEST K"
7793          enddo
7794          if (waga_dist.ge.0.0d0) then
7795 c
7796 c          For Gaussian-type Urestr
7797 c
7798             grad_odl3=waga_homology(iset)*waga_dist
7799      &                *sum_sgodl/(sum_godl*dij)
7800 c
7801 c          For Lorentzian-type Urestr
7802 c
7803          else
7804 c Original grad expr modified by analogy w Gaussian-type Urestr grad
7805 c           grad_odl3=-waga_homology(iset)*waga_dist*sum_sgodl
7806             grad_odl3=-waga_homology(iset)*waga_dist*
7807      &                sum_sgodl/(constr_homology*dij)
7808          endif
7809 c
7810 c        grad_odl3=sum_sgodl/(sum_godl*dij)
7811
7812
7813 c      write(iout,*) i, j, k, distance(i,j,k), "W GRADIENCIE2"
7814 c      write(iout,*) (distance(i,j,k)**2), (2*(sigma_odl(i,j,k))**2),
7815 c     &              (-(distance(i,j,k)**2)/(2*(sigma_odl(i,j,k))**2))
7816
7817 ccc      write(iout,*) godl, sgodl, grad_odl3
7818
7819 c          grad_odl=grad_odl+grad_odl3
7820
7821          do jik=1,3
7822             ggodl=grad_odl3*(c(jik,i)-c(jik,j))
7823 ccc      write(iout,*) c(jik,i+1), c(jik,j+1), (c(jik,i+1)-c(jik,j+1))
7824 ccc      write(iout,746) "GRAD_ODL_1", i, j, jik, ggodl,
7825 ccc     &              ghpbc(jik,i+1), ghpbc(jik,j+1)
7826             ghpbc(jik,i)=ghpbc(jik,i)+ggodl
7827             ghpbc(jik,j)=ghpbc(jik,j)-ggodl
7828 ccc      write(iout,746) "GRAD_ODL_2", i, j, jik, ggodl,
7829 ccc     &              ghpbc(jik,i+1), ghpbc(jik,j+1)
7830 c         if (i.eq.25.and.j.eq.27) then
7831 c         write(iout,*) "jik",jik,"i",i,"j",j
7832 c         write(iout,*) "sum_sgodl",sum_sgodl,"sgodl",sgodl
7833 c         write(iout,*) "grad_odl3",grad_odl3
7834 c         write(iout,*) "c(",jik,i,")",c(jik,i),"c(",jik,j,")",c(jik,j)
7835 c         write(iout,*) "ggodl",ggodl
7836 c         write(iout,*) "ghpbc(",jik,i,")",
7837 c     &                 ghpbc(jik,i),"ghpbc(",jik,j,")",
7838 c     &                 ghpbc(jik,j)
7839 c         endif
7840          enddo
7841 ccc       write(iout,778)"TEST: odleg2=", odleg2, "DLOG(odleg2)=",
7842 ccc     & dLOG(odleg2),"-odleg=", -odleg
7843
7844       enddo ! ii-loop for dist
7845 #ifdef DEBUG
7846       write(iout,*) "------- dist restrs end -------"
7847 c     if (waga_angle.eq.1.0d0 .or. waga_theta.eq.1.0d0 .or.
7848 c    &     waga_d.eq.1.0d0) call sum_gradient
7849 #endif
7850 c Pseudo-energy and gradient from dihedral-angle restraints from
7851 c homology templates
7852 c      write (iout,*) "End of distance loop"
7853 c      call flush(iout)
7854       kat=0.0d0
7855 c      write (iout,*) idihconstr_start_homo,idihconstr_end_homo
7856 #ifdef DEBUG
7857       write(iout,*) "------- dih restrs start -------"
7858       do i=idihconstr_start_homo,idihconstr_end_homo
7859         write (iout,*) "gloc_init(",i,icg,")",gloc(i,icg)
7860       enddo
7861 #endif
7862       do i=idihconstr_start_homo,idihconstr_end_homo
7863         kat2=0.0d0
7864 c        betai=beta(i,i+1,i+2,i+3)
7865         betai = phi(i)
7866 c       write (iout,*) "betai =",betai
7867         do k=1,constr_homology
7868           dih_diff(k)=pinorm(dih(k,i)-betai)
7869 cd          write (iout,'(a8,2i4,2f15.8)') "dih_diff",i,k,dih_diff(k)
7870 cd     &                  ,sigma_dih(k,i)
7871 c          if (dih_diff(i,k).gt.3.14159) dih_diff(i,k)=
7872 c     &                                   -(6.28318-dih_diff(i,k))
7873 c          if (dih_diff(i,k).lt.-3.14159) dih_diff(i,k)=
7874 c     &                                   6.28318+dih_diff(i,k)
7875 #ifdef OLD_DIHED
7876           kat3=-0.5d0*dih_diff(k)**2*sigma_dih(k,i) ! waga_angle rmvd from Gaussian argument
7877 #else
7878           kat3=(dcos(dih_diff(k))-1)*sigma_dih(k,i) ! waga_angle rmvd from Gaussian argument
7879 #endif
7880 c         kat3=-0.5d0*waga_angle*dih_diff(k)**2*sigma_dih(k,i)
7881           gdih(k)=dexp(kat3)
7882           kat2=kat2+gdih(k)
7883 c          write(iout,*) "kat2=", kat2, "exp(kat3)=", exp(kat3)
7884 c          write(*,*)""
7885         enddo
7886 c       write (iout,*) "gdih",(gdih(k),k=1,constr_homology) ! exps
7887 c       write (iout,*) "i",i," betai",betai," kat2",kat2 ! sum of exps
7888 #ifdef DEBUG
7889         write (iout,*) "i",i," betai",betai," kat2",kat2
7890         write (iout,*) "gdih",(gdih(k),k=1,constr_homology)
7891 #endif
7892         if (kat2.le.1.0d-14) cycle
7893         kat=kat-dLOG(kat2/constr_homology)
7894 c       write (iout,*) "kat",kat ! sum of -ln-s
7895
7896 ccc       write(iout,778)"TEST: kat2=", kat2, "DLOG(kat2)=",
7897 ccc     & dLOG(kat2), "-kat=", -kat
7898
7899 c ----------------------------------------------------------------------
7900 c Gradient
7901 c ----------------------------------------------------------------------
7902
7903         sum_gdih=kat2
7904         sum_sgdih=0.0d0
7905         do k=1,constr_homology
7906 #ifdef OLD_DIHED
7907           sgdih=-gdih(k)*dih_diff(k)*sigma_dih(k,i)  ! waga_angle rmvd
7908 #else
7909           sgdih=-gdih(k)*dsin(dih_diff(k))*sigma_dih(k,i)  ! waga_angle rmvd
7910 #endif
7911 c         sgdih=-gdih(k)*dih_diff(k)*sigma_dih(k,i)*waga_angle
7912           sum_sgdih=sum_sgdih+sgdih
7913         enddo
7914 c       grad_dih3=sum_sgdih/sum_gdih
7915         grad_dih3=waga_homology(iset)*waga_angle*sum_sgdih/sum_gdih
7916
7917 c      write(iout,*)i,k,gdih,sgdih,beta(i+1,i+2,i+3,i+4),grad_dih3
7918 ccc      write(iout,747) "GRAD_KAT_1", i, nphi, icg, grad_dih3,
7919 ccc     & gloc(nphi+i-3,icg)
7920         gloc(i-3,icg)=gloc(i-3,icg)+grad_dih3
7921 c        if (i.eq.25) then
7922 c        write(iout,*) "i",i,"icg",icg,"gloc(",i,icg,")",gloc(i,icg)
7923 c        endif
7924 ccc      write(iout,747) "GRAD_KAT_2", i, nphi, icg, grad_dih3,
7925 ccc     & gloc(nphi+i-3,icg)
7926
7927       enddo ! i-loop for dih
7928 #ifdef DEBUG
7929       write(iout,*) "------- dih restrs end -------"
7930 #endif
7931
7932 c Pseudo-energy and gradient for theta angle restraints from
7933 c homology templates
7934 c FP 01/15 - inserted from econstr_local_test.F, loop structure
7935 c adapted
7936
7937 c
7938 c     For constr_homology reference structures (FP)
7939 c
7940 c     Uconst_back_tot=0.0d0
7941       Eval=0.0d0
7942       Erot=0.0d0
7943 c     Econstr_back legacy
7944       do i=1,nres
7945 c     do i=ithet_start,ithet_end
7946        dutheta(i)=0.0d0
7947 c     enddo
7948 c     do i=loc_start,loc_end
7949         do j=1,3
7950           duscdiff(j,i)=0.0d0
7951           duscdiffx(j,i)=0.0d0
7952         enddo
7953       enddo
7954 c
7955 c     do iref=1,nref
7956 c     write (iout,*) "ithet_start =",ithet_start,"ithet_end =",ithet_end
7957 c     write (iout,*) "waga_theta",waga_theta
7958       if (waga_theta.gt.0.0d0) then
7959 #ifdef DEBUG
7960       write (iout,*) "usampl",usampl
7961       write(iout,*) "------- theta restrs start -------"
7962 c     do i=ithet_start,ithet_end
7963 c       write (iout,*) "gloc_init(",nphi+i,icg,")",gloc(nphi+i,icg)
7964 c     enddo
7965 #endif
7966 c     write (iout,*) "maxres",maxres,"nres",nres
7967
7968       do i=ithet_start,ithet_end
7969 c
7970 c     do i=1,nfrag_back
7971 c       ii = ifrag_back(2,i,iset)-ifrag_back(1,i,iset)
7972 c
7973 c Deviation of theta angles wrt constr_homology ref structures
7974 c
7975         utheta_i=0.0d0 ! argument of Gaussian for single k
7976         gutheta_i=0.0d0 ! Sum of Gaussians over constr_homology ref structures
7977 c       do j=ifrag_back(1,i,iset)+2,ifrag_back(2,i,iset) ! original loop
7978 c       over residues in a fragment
7979 c       write (iout,*) "theta(",i,")=",theta(i)
7980         do k=1,constr_homology
7981 c
7982 c         dtheta_i=theta(j)-thetaref(j,iref)
7983 c         dtheta_i=thetaref(k,i)-theta(i) ! original form without indexing
7984           theta_diff(k)=thetatpl(k,i)-theta(i)
7985 cd          write (iout,'(a8,2i4,2f15.8)') "theta_diff",i,k,theta_diff(k)
7986 cd     &                  ,sigma_theta(k,i)
7987
7988 c
7989           utheta_i=-0.5d0*theta_diff(k)**2*sigma_theta(k,i) ! waga_theta rmvd from Gaussian argument
7990 c         utheta_i=-0.5d0*waga_theta*theta_diff(k)**2*sigma_theta(k,i) ! waga_theta?
7991           gtheta(k)=dexp(utheta_i) ! + min_utheta_i?
7992           gutheta_i=gutheta_i+gtheta(k)  ! Sum of Gaussians (pk)
7993 c         Gradient for single Gaussian restraint in subr Econstr_back
7994 c         dutheta(j-2)=dutheta(j-2)+wfrag_back(1,i,iset)*dtheta_i/(ii-1)
7995 c
7996         enddo
7997 c       write (iout,*) "gtheta",(gtheta(k),k=1,constr_homology) ! exps
7998 c       write (iout,*) "i",i," gutheta_i",gutheta_i ! sum of exps
7999
8000 c
8001 c         Gradient for multiple Gaussian restraint
8002         sum_gtheta=gutheta_i
8003         sum_sgtheta=0.0d0
8004         do k=1,constr_homology
8005 c        New generalized expr for multiple Gaussian from Econstr_back
8006          sgtheta=-gtheta(k)*theta_diff(k)*sigma_theta(k,i) ! waga_theta rmvd
8007 c
8008 c        sgtheta=-gtheta(k)*theta_diff(k)*sigma_theta(k,i)*waga_theta ! right functional form?
8009           sum_sgtheta=sum_sgtheta+sgtheta ! cum variable
8010         enddo
8011 c       Final value of gradient using same var as in Econstr_back
8012         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)
8013      &      +sum_sgtheta/sum_gtheta*waga_theta
8014      &               *waga_homology(iset)
8015 c        dutheta(i-2)=sum_sgtheta/sum_gtheta*waga_theta
8016 c     &               *waga_homology(iset)
8017 c       dutheta(i)=sum_sgtheta/sum_gtheta
8018 c
8019 c       Uconst_back=Uconst_back+waga_theta*utheta(i) ! waga_theta added as weight
8020         Eval=Eval-dLOG(gutheta_i/constr_homology)
8021 c       write (iout,*) "utheta(",i,")=",utheta(i) ! -ln of sum of exps
8022 c       write (iout,*) "Uconst_back",Uconst_back ! sum of -ln-s
8023 c       Uconst_back=Uconst_back+utheta(i)
8024       enddo ! (i-loop for theta)
8025 #ifdef DEBUG
8026       write(iout,*) "------- theta restrs end -------"
8027 #endif
8028       endif
8029 c
8030 c Deviation of local SC geometry
8031 c
8032 c Separation of two i-loops (instructed by AL - 11/3/2014)
8033 c
8034 c     write (iout,*) "loc_start =",loc_start,"loc_end =",loc_end
8035 c     write (iout,*) "waga_d",waga_d
8036
8037 #ifdef DEBUG
8038       write(iout,*) "------- SC restrs start -------"
8039       write (iout,*) "Initial duscdiff,duscdiffx"
8040       do i=loc_start,loc_end
8041         write (iout,*) i,(duscdiff(jik,i),jik=1,3),
8042      &                 (duscdiffx(jik,i),jik=1,3)
8043       enddo
8044 #endif
8045       do i=loc_start,loc_end
8046         usc_diff_i=0.0d0 ! argument of Gaussian for single k
8047         guscdiff(i)=0.0d0 ! Sum of Gaussians over constr_homology ref structures
8048 c       do j=ifrag_back(1,i,iset)+1,ifrag_back(2,i,iset)-1 ! Econstr_back legacy
8049 c       write(iout,*) "xxtab, yytab, zztab"
8050 c       write(iout,'(i5,3f8.2)') i,xxtab(i),yytab(i),zztab(i)
8051         do k=1,constr_homology
8052 c
8053           dxx=-xxtpl(k,i)+xxtab(i) ! Diff b/w x component of ith SC vector in model and kth ref str?
8054 c                                    Original sign inverted for calc of gradients (s. Econstr_back)
8055           dyy=-yytpl(k,i)+yytab(i) ! ibid y
8056           dzz=-zztpl(k,i)+zztab(i) ! ibid z
8057 c         write(iout,*) "dxx, dyy, dzz"
8058 cd          write(iout,'(2i5,4f8.2)') k,i,dxx,dyy,dzz,sigma_d(k,i)
8059 c
8060           usc_diff_i=-0.5d0*(dxx**2+dyy**2+dzz**2)*sigma_d(k,i)  ! waga_d rmvd from Gaussian argument
8061 c         usc_diff(i)=-0.5d0*waga_d*(dxx**2+dyy**2+dzz**2)*sigma_d(k,i) ! waga_d?
8062 c         uscdiffk(k)=usc_diff(i)
8063           guscdiff2(k)=dexp(usc_diff_i) ! without min_scdiff
8064 c          write(iout,*) "i",i," k",k," sigma_d",sigma_d(k,i),
8065 c     &       " guscdiff2",guscdiff2(k)
8066           guscdiff(i)=guscdiff(i)+guscdiff2(k)  !Sum of Gaussians (pk)
8067 c          write (iout,'(i5,6f10.5)') j,xxtab(j),yytab(j),zztab(j),
8068 c     &      xxref(j),yyref(j),zzref(j)
8069         enddo
8070 c
8071 c       Gradient
8072 c
8073 c       Generalized expression for multiple Gaussian acc to that for a single
8074 c       Gaussian in Econstr_back as instructed by AL (FP - 03/11/2014)
8075 c
8076 c       Original implementation
8077 c       sum_guscdiff=guscdiff(i)
8078 c
8079 c       sum_sguscdiff=0.0d0
8080 c       do k=1,constr_homology
8081 c          sguscdiff=-guscdiff2(k)*dscdiff(k)*sigma_d(k,i)*waga_d !waga_d?
8082 c          sguscdiff=-guscdiff3(k)*dscdiff(k)*sigma_d(k,i)*waga_d ! w min_uscdiff
8083 c          sum_sguscdiff=sum_sguscdiff+sguscdiff
8084 c       enddo
8085 c
8086 c       Implementation of new expressions for gradient (Jan. 2015)
8087 c
8088 c       grad_uscdiff=sum_sguscdiff/(sum_guscdiff*dtab) !?
8089         do k=1,constr_homology
8090 c
8091 c       New calculation of dxx, dyy, and dzz corrected by AL (07/11), was missing and wrong
8092 c       before. Now the drivatives should be correct
8093 c
8094           dxx=-xxtpl(k,i)+xxtab(i) ! Diff b/w x component of ith SC vector in model and kth ref str?
8095 c                                  Original sign inverted for calc of gradients (s. Econstr_back)
8096           dyy=-yytpl(k,i)+yytab(i) ! ibid y
8097           dzz=-zztpl(k,i)+zztab(i) ! ibid z
8098 c
8099 c         New implementation
8100 c
8101           sum_guscdiff=guscdiff2(k)*!(dsqrt(dxx*dxx+dyy*dyy+dzz*dzz))* -> wrong!
8102      &                 sigma_d(k,i) ! for the grad wrt r'
8103 c         sum_sguscdiff=sum_sguscdiff+sum_guscdiff
8104 c
8105 c
8106 c        New implementation
8107          sum_guscdiff = waga_homology(iset)*waga_d*sum_guscdiff
8108          do jik=1,3
8109             duscdiff(jik,i-1)=duscdiff(jik,i-1)+
8110      &      sum_guscdiff*(dXX_C1tab(jik,i)*dxx+
8111      &      dYY_C1tab(jik,i)*dyy+dZZ_C1tab(jik,i)*dzz)/guscdiff(i)
8112             duscdiff(jik,i)=duscdiff(jik,i)+
8113      &      sum_guscdiff*(dXX_Ctab(jik,i)*dxx+
8114      &      dYY_Ctab(jik,i)*dyy+dZZ_Ctab(jik,i)*dzz)/guscdiff(i)
8115             duscdiffx(jik,i)=duscdiffx(jik,i)+
8116      &      sum_guscdiff*(dXX_XYZtab(jik,i)*dxx+
8117      &      dYY_XYZtab(jik,i)*dyy+dZZ_XYZtab(jik,i)*dzz)/guscdiff(i)
8118 c
8119 #ifdef DEBUG
8120              write(iout,*) "jik",jik,"i",i
8121              write(iout,*) "dxx, dyy, dzz"
8122              write(iout,'(2i5,3f8.2)') k,i,dxx,dyy,dzz
8123              write(iout,*) "guscdiff2(",k,")",guscdiff2(k)
8124 c            write(iout,*) "sum_sguscdiff",sum_sguscdiff
8125 cc           write(iout,*) "dXX_Ctab(",jik,i,")",dXX_Ctab(jik,i)
8126 c            write(iout,*) "dYY_Ctab(",jik,i,")",dYY_Ctab(jik,i)
8127 c            write(iout,*) "dZZ_Ctab(",jik,i,")",dZZ_Ctab(jik,i)
8128 c            write(iout,*) "dXX_C1tab(",jik,i,")",dXX_C1tab(jik,i)
8129 c            write(iout,*) "dYY_C1tab(",jik,i,")",dYY_C1tab(jik,i)
8130 c            write(iout,*) "dZZ_C1tab(",jik,i,")",dZZ_C1tab(jik,i)
8131 c            write(iout,*) "dXX_XYZtab(",jik,i,")",dXX_XYZtab(jik,i)
8132 c            write(iout,*) "dYY_XYZtab(",jik,i,")",dYY_XYZtab(jik,i)
8133 c            write(iout,*) "dZZ_XYZtab(",jik,i,")",dZZ_XYZtab(jik,i)
8134 c            write(iout,*) "duscdiff(",jik,i-1,")",duscdiff(jik,i-1)
8135 c            write(iout,*) "duscdiff(",jik,i,")",duscdiff(jik,i)
8136 c            write(iout,*) "duscdiffx(",jik,i,")",duscdiffx(jik,i)
8137 c            endif
8138 #endif
8139          enddo
8140         enddo
8141 c
8142 c       uscdiff(i)=-dLOG(guscdiff(i)/(ii-1))      ! Weighting by (ii-1) required?
8143 c        usc_diff(i)=-dLOG(guscdiff(i)/constr_homology) ! + min_uscdiff ?
8144 c
8145 c        write (iout,*) i," uscdiff",uscdiff(i)
8146 c
8147 c Put together deviations from local geometry
8148
8149 c       Uconst_back=Uconst_back+wfrag_back(1,i,iset)*utheta(i)+
8150 c      &            wfrag_back(3,i,iset)*uscdiff(i)
8151         Erot=Erot-dLOG(guscdiff(i)/constr_homology)
8152 c       write (iout,*) "usc_diff(",i,")=",usc_diff(i) ! -ln of sum of exps
8153 c       write (iout,*) "Uconst_back",Uconst_back ! cum sum of -ln-s
8154 c       Uconst_back=Uconst_back+usc_diff(i)
8155 c
8156 c     Gradient of multiple Gaussian restraint (FP - 04/11/2014 - right?)
8157 c
8158 c     New implment: multiplied by sum_sguscdiff
8159 c
8160
8161       enddo ! (i-loop for dscdiff)
8162
8163 c      endif
8164
8165 #ifdef DEBUG
8166       write(iout,*) "------- SC restrs end -------"
8167         write (iout,*) "------ After SC loop in e_modeller ------"
8168         do i=loc_start,loc_end
8169          write (iout,*) "i",i," gradc",(gradc(j,i,icg),j=1,3)
8170          write (iout,*) "i",i," gradx",(gradx(j,i,icg),j=1,3)
8171         enddo
8172       if (waga_theta.eq.1.0d0) then
8173       write (iout,*) "in e_modeller after SC restr end: dutheta"
8174       do i=ithet_start,ithet_end
8175         write (iout,*) i,dutheta(i)
8176       enddo
8177       endif
8178       if (waga_d.eq.1.0d0) then
8179       write (iout,*) "e_modeller after SC loop: duscdiff/x"
8180       do i=1,nres
8181         write (iout,*) i,(duscdiff(j,i),j=1,3)
8182         write (iout,*) i,(duscdiffx(j,i),j=1,3)
8183       enddo
8184       endif
8185 #endif
8186
8187 c Total energy from homology restraints
8188 #ifdef DEBUG
8189       write (iout,*) "odleg",odleg," kat",kat
8190 #endif
8191 c
8192 c Addition of energy of theta angle and SC local geom over constr_homologs ref strs
8193 c
8194 c     ehomology_constr=odleg+kat
8195 c
8196 c     For Lorentzian-type Urestr
8197 c
8198
8199       if (waga_dist.ge.0.0d0) then
8200 c
8201 c          For Gaussian-type Urestr
8202 c
8203         ehomology_constr=(waga_dist*odleg+waga_angle*kat+
8204      &              waga_theta*Eval+waga_d*Erot)*waga_homology(iset)
8205 c     write (iout,*) "ehomology_constr=",ehomology_constr
8206       else
8207 c
8208 c          For Lorentzian-type Urestr
8209 c
8210         ehomology_constr=(-waga_dist*odleg+waga_angle*kat+
8211      &              waga_theta*Eval+waga_d*Erot)*waga_homology(iset)
8212 c     write (iout,*) "ehomology_constr=",ehomology_constr
8213       endif
8214 #ifdef DEBUG
8215       write (iout,*) "odleg",waga_dist,odleg," kat",waga_angle,kat,
8216      & "Eval",waga_theta,eval,
8217      &   "Erot",waga_d,Erot
8218       write (iout,*) "ehomology_constr",ehomology_constr
8219 #endif
8220       return
8221 c
8222 c FP 01/15 end
8223 c
8224   748 format(a8,f12.3,a6,f12.3,a7,f12.3)
8225   747 format(a12,i4,i4,i4,f8.3,f8.3)
8226   746 format(a12,i4,i4,i4,f8.3,f8.3,f8.3)
8227   778 format(a7,1X,f10.3,1X,a4,1X,f10.3,1X,a5,1X,f10.3)
8228   779 format(i3,1X,i3,1X,i2,1X,a7,1X,f7.3,1X,a7,1X,f7.3,1X,a13,1X,
8229      &       f7.3,1X,a17,1X,f9.3,1X,a10,1X,f8.3,1X,a10,1X,f8.3)
8230       end
8231 c----------------------------------------------------------------------------
8232 C The rigorous attempt to derive energy function
8233       subroutine ebend_kcc(etheta)
8234
8235       implicit real*8 (a-h,o-z)
8236       include 'DIMENSIONS'
8237       include 'COMMON.VAR'
8238       include 'COMMON.GEO'
8239       include 'COMMON.LOCAL'
8240       include 'COMMON.TORSION'
8241       include 'COMMON.INTERACT'
8242       include 'COMMON.DERIV'
8243       include 'COMMON.CHAIN'
8244       include 'COMMON.NAMES'
8245       include 'COMMON.IOUNITS'
8246       include 'COMMON.FFIELD'
8247       include 'COMMON.TORCNSTR'
8248       include 'COMMON.CONTROL'
8249       logical lprn
8250       double precision thybt1(maxang_kcc)
8251 C Set lprn=.true. for debugging
8252       lprn=energy_dec
8253 c     lprn=.true.
8254 C      print *,"wchodze kcc"
8255       if (lprn) write (iout,*) "ebend_kcc tor_mode",tor_mode
8256       etheta=0.0D0
8257       do i=ithet_start,ithet_end
8258 c        print *,i,itype(i-1),itype(i),itype(i-2)
8259         if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
8260      &  .or.itype(i).eq.ntyp1) cycle
8261         iti=iabs(itortyp(itype(i-1)))
8262         sinthet=dsin(theta(i))
8263         costhet=dcos(theta(i))
8264         do j=1,nbend_kcc_Tb(iti)
8265           thybt1(j)=v1bend_chyb(j,iti)
8266         enddo
8267         sumth1thyb=v1bend_chyb(0,iti)+
8268      &    tschebyshev(1,nbend_kcc_Tb(iti),thybt1(1),costhet)
8269         if (lprn) write (iout,*) i-1,itype(i-1),iti,theta(i)*rad2deg,
8270      &    sumth1thyb
8271         ihelp=nbend_kcc_Tb(iti)-1
8272         gradthybt1=gradtschebyshev(0,ihelp,thybt1(1),costhet)
8273         etheta=etheta+sumth1thyb
8274 C        print *,sumth1thyb,gradthybt1,sinthet*(-0.5d0)
8275         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)-wang*gradthybt1*sinthet
8276       enddo
8277       return
8278       end
8279 c-------------------------------------------------------------------------------------
8280       subroutine etheta_constr(ethetacnstr)
8281
8282       implicit real*8 (a-h,o-z)
8283       include 'DIMENSIONS'
8284       include 'COMMON.VAR'
8285       include 'COMMON.GEO'
8286       include 'COMMON.LOCAL'
8287       include 'COMMON.TORSION'
8288       include 'COMMON.INTERACT'
8289       include 'COMMON.DERIV'
8290       include 'COMMON.CHAIN'
8291       include 'COMMON.NAMES'
8292       include 'COMMON.IOUNITS'
8293       include 'COMMON.FFIELD'
8294       include 'COMMON.TORCNSTR'
8295       include 'COMMON.CONTROL'
8296       ethetacnstr=0.0d0
8297 C      print *,ithetaconstr_start,ithetaconstr_end,"TU"
8298       do i=ithetaconstr_start,ithetaconstr_end
8299         itheta=itheta_constr(i)
8300         thetiii=theta(itheta)
8301         difi=pinorm(thetiii-theta_constr0(i))
8302         if (difi.gt.theta_drange(i)) then
8303           difi=difi-theta_drange(i)
8304           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
8305           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
8306      &    +for_thet_constr(i)*difi**3
8307         else if (difi.lt.-drange(i)) then
8308           difi=difi+drange(i)
8309           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
8310           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
8311      &    +for_thet_constr(i)*difi**3
8312         else
8313           difi=0.0
8314         endif
8315        if (energy_dec) then
8316         write (iout,'(a6,2i5,4f8.3,2e14.5)') "ethetc",
8317      &    i,itheta,rad2deg*thetiii,
8318      &    rad2deg*theta_constr0(i),  rad2deg*theta_drange(i),
8319      &    rad2deg*difi,0.25d0*for_thet_constr(i)*difi**4,
8320      &    gloc(itheta+nphi-2,icg)
8321         endif
8322       enddo
8323       return
8324       end
8325 c------------------------------------------------------------------------------
8326       subroutine eback_sc_corr(esccor)
8327 c 7/21/2007 Correlations between the backbone-local and side-chain-local
8328 c        conformational states; temporarily implemented as differences
8329 c        between UNRES torsional potentials (dependent on three types of
8330 c        residues) and the torsional potentials dependent on all 20 types
8331 c        of residues computed from AM1  energy surfaces of terminally-blocked
8332 c        amino-acid residues.
8333       implicit real*8 (a-h,o-z)
8334       include 'DIMENSIONS'
8335       include 'COMMON.VAR'
8336       include 'COMMON.GEO'
8337       include 'COMMON.LOCAL'
8338       include 'COMMON.TORSION'
8339       include 'COMMON.SCCOR'
8340       include 'COMMON.INTERACT'
8341       include 'COMMON.DERIV'
8342       include 'COMMON.CHAIN'
8343       include 'COMMON.NAMES'
8344       include 'COMMON.IOUNITS'
8345       include 'COMMON.FFIELD'
8346       include 'COMMON.CONTROL'
8347       logical lprn
8348 C Set lprn=.true. for debugging
8349       lprn=.false.
8350 c      lprn=.true.
8351 c      write (iout,*) "EBACK_SC_COR",itau_start,itau_end
8352       esccor=0.0D0
8353       do i=itau_start,itau_end
8354         if ((itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)) cycle
8355         esccor_ii=0.0D0
8356         isccori=isccortyp(itype(i-2))
8357         isccori1=isccortyp(itype(i-1))
8358 c      write (iout,*) "EBACK_SC_COR",i,nterm_sccor(isccori,isccori1)
8359         phii=phi(i)
8360         do intertyp=1,3 !intertyp
8361 cc Added 09 May 2012 (Adasko)
8362 cc  Intertyp means interaction type of backbone mainchain correlation:
8363 c   1 = SC...Ca...Ca...Ca
8364 c   2 = Ca...Ca...Ca...SC
8365 c   3 = SC...Ca...Ca...SCi
8366         gloci=0.0D0
8367         if (((intertyp.eq.3).and.((itype(i-2).eq.10).or.
8368      &      (itype(i-1).eq.10).or.(itype(i-2).eq.ntyp1).or.
8369      &      (itype(i-1).eq.ntyp1)))
8370      &    .or. ((intertyp.eq.1).and.((itype(i-2).eq.10)
8371      &     .or.(itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)
8372      &     .or.(itype(i).eq.ntyp1)))
8373      &    .or.((intertyp.eq.2).and.((itype(i-1).eq.10).or.
8374      &      (itype(i-1).eq.ntyp1).or.(itype(i-2).eq.ntyp1).or.
8375      &      (itype(i-3).eq.ntyp1)))) cycle
8376         if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1).eq.ntyp1)) cycle
8377         if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres).eq.ntyp1))
8378      & cycle
8379        do j=1,nterm_sccor(isccori,isccori1)
8380           v1ij=v1sccor(j,intertyp,isccori,isccori1)
8381           v2ij=v2sccor(j,intertyp,isccori,isccori1)
8382           cosphi=dcos(j*tauangle(intertyp,i))
8383           sinphi=dsin(j*tauangle(intertyp,i))
8384           esccor=esccor+v1ij*cosphi+v2ij*sinphi
8385           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
8386         enddo
8387 c      write (iout,*) "EBACK_SC_COR",i,v1ij*cosphi+v2ij*sinphi,intertyp
8388         gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci
8389         if (lprn)
8390      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
8391      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,isccori,isccori1,
8392      &  (v1sccor(j,intertyp,isccori,isccori1),j=1,6)
8393      & ,(v2sccor(j,intertyp,isccori,isccori1),j=1,6)
8394         gsccor_loc(i-3)=gsccor_loc(i-3)+gloci
8395        enddo !intertyp
8396       enddo
8397
8398       return
8399       end
8400 #ifdef FOURBODY
8401 c----------------------------------------------------------------------------
8402       subroutine multibody(ecorr)
8403 C This subroutine calculates multi-body contributions to energy following
8404 C the idea of Skolnick et al. If side chains I and J make a contact and
8405 C at the same time side chains I+1 and J+1 make a contact, an extra
8406 C contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
8407       implicit real*8 (a-h,o-z)
8408       include 'DIMENSIONS'
8409       include 'COMMON.IOUNITS'
8410       include 'COMMON.DERIV'
8411       include 'COMMON.INTERACT'
8412       include 'COMMON.CONTACTS'
8413       include 'COMMON.CONTMAT'
8414       include 'COMMON.CORRMAT'
8415       double precision gx(3),gx1(3)
8416       logical lprn
8417
8418 C Set lprn=.true. for debugging
8419       lprn=.false.
8420
8421       if (lprn) then
8422         write (iout,'(a)') 'Contact function values:'
8423         do i=nnt,nct-2
8424           write (iout,'(i2,20(1x,i2,f10.5))')
8425      &        i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
8426         enddo
8427       endif
8428       ecorr=0.0D0
8429       do i=nnt,nct
8430         do j=1,3
8431           gradcorr(j,i)=0.0D0
8432           gradxorr(j,i)=0.0D0
8433         enddo
8434       enddo
8435       do i=nnt,nct-2
8436
8437         DO ISHIFT = 3,4
8438
8439         i1=i+ishift
8440         num_conti=num_cont(i)
8441         num_conti1=num_cont(i1)
8442         do jj=1,num_conti
8443           j=jcont(jj,i)
8444           do kk=1,num_conti1
8445             j1=jcont(kk,i1)
8446             if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
8447 cd          write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
8448 cd   &                   ' ishift=',ishift
8449 C Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
8450 C The system gains extra energy.
8451               ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
8452             endif   ! j1==j+-ishift
8453           enddo     ! kk
8454         enddo       ! jj
8455
8456         ENDDO ! ISHIFT
8457
8458       enddo         ! i
8459       return
8460       end
8461 c------------------------------------------------------------------------------
8462       double precision function esccorr(i,j,k,l,jj,kk)
8463       implicit real*8 (a-h,o-z)
8464       include 'DIMENSIONS'
8465       include 'COMMON.IOUNITS'
8466       include 'COMMON.DERIV'
8467       include 'COMMON.INTERACT'
8468       include 'COMMON.CONTACTS'
8469       include 'COMMON.CONTMAT'
8470       include 'COMMON.CORRMAT'
8471       include 'COMMON.SHIELD'
8472       double precision gx(3),gx1(3)
8473       logical lprn
8474       lprn=.false.
8475       eij=facont(jj,i)
8476       ekl=facont(kk,k)
8477 cd    write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
8478 C Calculate the multi-body contribution to energy.
8479 C Calculate multi-body contributions to the gradient.
8480 cd    write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
8481 cd   & k,l,(gacont(m,kk,k),m=1,3)
8482       do m=1,3
8483         gx(m) =ekl*gacont(m,jj,i)
8484         gx1(m)=eij*gacont(m,kk,k)
8485         gradxorr(m,i)=gradxorr(m,i)-gx(m)
8486         gradxorr(m,j)=gradxorr(m,j)+gx(m)
8487         gradxorr(m,k)=gradxorr(m,k)-gx1(m)
8488         gradxorr(m,l)=gradxorr(m,l)+gx1(m)
8489       enddo
8490       do m=i,j-1
8491         do ll=1,3
8492           gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
8493         enddo
8494       enddo
8495       do m=k,l-1
8496         do ll=1,3
8497           gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
8498         enddo
8499       enddo
8500       esccorr=-eij*ekl
8501       return
8502       end
8503 c------------------------------------------------------------------------------
8504       subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
8505 C This subroutine calculates multi-body contributions to hydrogen-bonding
8506       implicit real*8 (a-h,o-z)
8507       include 'DIMENSIONS'
8508       include 'COMMON.IOUNITS'
8509 #ifdef MPI
8510       include "mpif.h"
8511       parameter (max_cont=maxconts)
8512       parameter (max_dim=26)
8513       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
8514       double precision zapas(max_dim,maxconts,max_fg_procs),
8515      &  zapas_recv(max_dim,maxconts,max_fg_procs)
8516       common /przechowalnia/ zapas
8517       integer status(MPI_STATUS_SIZE),req(maxconts*2),
8518      &  status_array(MPI_STATUS_SIZE,maxconts*2)
8519 #endif
8520       include 'COMMON.SETUP'
8521       include 'COMMON.FFIELD'
8522       include 'COMMON.DERIV'
8523       include 'COMMON.INTERACT'
8524       include 'COMMON.CONTACTS'
8525       include 'COMMON.CONTMAT'
8526       include 'COMMON.CORRMAT'
8527       include 'COMMON.CONTROL'
8528       include 'COMMON.LOCAL'
8529       double precision gx(3),gx1(3),time00
8530       logical lprn,ldone
8531
8532 C Set lprn=.true. for debugging
8533       lprn=.false.
8534 #ifdef MPI
8535       n_corr=0
8536       n_corr1=0
8537       if (nfgtasks.le.1) goto 30
8538       if (lprn) then
8539         write (iout,'(a)') 'Contact function values before RECEIVE:'
8540         do i=nnt,nct-2
8541           write (iout,'(2i3,50(1x,i2,f5.2))')
8542      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
8543      &    j=1,num_cont_hb(i))
8544         enddo
8545         call flush(iout)
8546       endif
8547       do i=1,ntask_cont_from
8548         ncont_recv(i)=0
8549       enddo
8550       do i=1,ntask_cont_to
8551         ncont_sent(i)=0
8552       enddo
8553 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
8554 c     & ntask_cont_to
8555 C Make the list of contacts to send to send to other procesors
8556 c      write (iout,*) "limits",max0(iturn4_end-1,iatel_s),iturn3_end
8557 c      call flush(iout)
8558       do i=iturn3_start,iturn3_end
8559 c        write (iout,*) "make contact list turn3",i," num_cont",
8560 c     &    num_cont_hb(i)
8561         call add_hb_contact(i,i+2,iturn3_sent_local(1,i))
8562       enddo
8563       do i=iturn4_start,iturn4_end
8564 c        write (iout,*) "make contact list turn4",i," num_cont",
8565 c     &   num_cont_hb(i)
8566         call add_hb_contact(i,i+3,iturn4_sent_local(1,i))
8567       enddo
8568       do ii=1,nat_sent
8569         i=iat_sent(ii)
8570 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
8571 c     &    num_cont_hb(i)
8572         do j=1,num_cont_hb(i)
8573         do k=1,4
8574           jjc=jcont_hb(j,i)
8575           iproc=iint_sent_local(k,jjc,ii)
8576 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
8577           if (iproc.gt.0) then
8578             ncont_sent(iproc)=ncont_sent(iproc)+1
8579             nn=ncont_sent(iproc)
8580             zapas(1,nn,iproc)=i
8581             zapas(2,nn,iproc)=jjc
8582             zapas(3,nn,iproc)=facont_hb(j,i)
8583             zapas(4,nn,iproc)=ees0p(j,i)
8584             zapas(5,nn,iproc)=ees0m(j,i)
8585             zapas(6,nn,iproc)=gacont_hbr(1,j,i)
8586             zapas(7,nn,iproc)=gacont_hbr(2,j,i)
8587             zapas(8,nn,iproc)=gacont_hbr(3,j,i)
8588             zapas(9,nn,iproc)=gacontm_hb1(1,j,i)
8589             zapas(10,nn,iproc)=gacontm_hb1(2,j,i)
8590             zapas(11,nn,iproc)=gacontm_hb1(3,j,i)
8591             zapas(12,nn,iproc)=gacontp_hb1(1,j,i)
8592             zapas(13,nn,iproc)=gacontp_hb1(2,j,i)
8593             zapas(14,nn,iproc)=gacontp_hb1(3,j,i)
8594             zapas(15,nn,iproc)=gacontm_hb2(1,j,i)
8595             zapas(16,nn,iproc)=gacontm_hb2(2,j,i)
8596             zapas(17,nn,iproc)=gacontm_hb2(3,j,i)
8597             zapas(18,nn,iproc)=gacontp_hb2(1,j,i)
8598             zapas(19,nn,iproc)=gacontp_hb2(2,j,i)
8599             zapas(20,nn,iproc)=gacontp_hb2(3,j,i)
8600             zapas(21,nn,iproc)=gacontm_hb3(1,j,i)
8601             zapas(22,nn,iproc)=gacontm_hb3(2,j,i)
8602             zapas(23,nn,iproc)=gacontm_hb3(3,j,i)
8603             zapas(24,nn,iproc)=gacontp_hb3(1,j,i)
8604             zapas(25,nn,iproc)=gacontp_hb3(2,j,i)
8605             zapas(26,nn,iproc)=gacontp_hb3(3,j,i)
8606           endif
8607         enddo
8608         enddo
8609       enddo
8610       if (lprn) then
8611       write (iout,*)
8612      &  "Numbers of contacts to be sent to other processors",
8613      &  (ncont_sent(i),i=1,ntask_cont_to)
8614       write (iout,*) "Contacts sent"
8615       do ii=1,ntask_cont_to
8616         nn=ncont_sent(ii)
8617         iproc=itask_cont_to(ii)
8618         write (iout,*) nn," contacts to processor",iproc,
8619      &   " of CONT_TO_COMM group"
8620         do i=1,nn
8621           write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
8622         enddo
8623       enddo
8624       call flush(iout)
8625       endif
8626       CorrelType=477
8627       CorrelID=fg_rank+1
8628       CorrelType1=478
8629       CorrelID1=nfgtasks+fg_rank+1
8630       ireq=0
8631 C Receive the numbers of needed contacts from other processors
8632       do ii=1,ntask_cont_from
8633         iproc=itask_cont_from(ii)
8634         ireq=ireq+1
8635         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
8636      &    FG_COMM,req(ireq),IERR)
8637       enddo
8638 c      write (iout,*) "IRECV ended"
8639 c      call flush(iout)
8640 C Send the number of contacts needed by other processors
8641       do ii=1,ntask_cont_to
8642         iproc=itask_cont_to(ii)
8643         ireq=ireq+1
8644         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
8645      &    FG_COMM,req(ireq),IERR)
8646       enddo
8647 c      write (iout,*) "ISEND ended"
8648 c      write (iout,*) "number of requests (nn)",ireq
8649 c      call flush(iout)
8650       if (ireq.gt.0)
8651      &  call MPI_Waitall(ireq,req,status_array,ierr)
8652 c      write (iout,*)
8653 c     &  "Numbers of contacts to be received from other processors",
8654 c     &  (ncont_recv(i),i=1,ntask_cont_from)
8655 c      call flush(iout)
8656 C Receive contacts
8657       ireq=0
8658       do ii=1,ntask_cont_from
8659         iproc=itask_cont_from(ii)
8660         nn=ncont_recv(ii)
8661 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
8662 c     &   " of CONT_TO_COMM group"
8663 c        call flush(iout)
8664         if (nn.gt.0) then
8665           ireq=ireq+1
8666           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
8667      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
8668 c          write (iout,*) "ireq,req",ireq,req(ireq)
8669         endif
8670       enddo
8671 C Send the contacts to processors that need them
8672       do ii=1,ntask_cont_to
8673         iproc=itask_cont_to(ii)
8674         nn=ncont_sent(ii)
8675 c        write (iout,*) nn," contacts to processor",iproc,
8676 c     &   " of CONT_TO_COMM group"
8677         if (nn.gt.0) then
8678           ireq=ireq+1
8679           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
8680      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
8681 c          write (iout,*) "ireq,req",ireq,req(ireq)
8682 c          do i=1,nn
8683 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
8684 c          enddo
8685         endif
8686       enddo
8687 c      write (iout,*) "number of requests (contacts)",ireq
8688 c      write (iout,*) "req",(req(i),i=1,4)
8689 c      call flush(iout)
8690       if (ireq.gt.0)
8691      & call MPI_Waitall(ireq,req,status_array,ierr)
8692       do iii=1,ntask_cont_from
8693         iproc=itask_cont_from(iii)
8694         nn=ncont_recv(iii)
8695         if (lprn) then
8696         write (iout,*) "Received",nn," contacts from processor",iproc,
8697      &   " of CONT_FROM_COMM group"
8698         call flush(iout)
8699         do i=1,nn
8700           write(iout,'(2f5.0,4f10.5)')(zapas_recv(j,i,iii),j=1,5)
8701         enddo
8702         call flush(iout)
8703         endif
8704         do i=1,nn
8705           ii=zapas_recv(1,i,iii)
8706 c Flag the received contacts to prevent double-counting
8707           jj=-zapas_recv(2,i,iii)
8708 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
8709 c          call flush(iout)
8710           nnn=num_cont_hb(ii)+1
8711           num_cont_hb(ii)=nnn
8712           jcont_hb(nnn,ii)=jj
8713           facont_hb(nnn,ii)=zapas_recv(3,i,iii)
8714           ees0p(nnn,ii)=zapas_recv(4,i,iii)
8715           ees0m(nnn,ii)=zapas_recv(5,i,iii)
8716           gacont_hbr(1,nnn,ii)=zapas_recv(6,i,iii)
8717           gacont_hbr(2,nnn,ii)=zapas_recv(7,i,iii)
8718           gacont_hbr(3,nnn,ii)=zapas_recv(8,i,iii)
8719           gacontm_hb1(1,nnn,ii)=zapas_recv(9,i,iii)
8720           gacontm_hb1(2,nnn,ii)=zapas_recv(10,i,iii)
8721           gacontm_hb1(3,nnn,ii)=zapas_recv(11,i,iii)
8722           gacontp_hb1(1,nnn,ii)=zapas_recv(12,i,iii)
8723           gacontp_hb1(2,nnn,ii)=zapas_recv(13,i,iii)
8724           gacontp_hb1(3,nnn,ii)=zapas_recv(14,i,iii)
8725           gacontm_hb2(1,nnn,ii)=zapas_recv(15,i,iii)
8726           gacontm_hb2(2,nnn,ii)=zapas_recv(16,i,iii)
8727           gacontm_hb2(3,nnn,ii)=zapas_recv(17,i,iii)
8728           gacontp_hb2(1,nnn,ii)=zapas_recv(18,i,iii)
8729           gacontp_hb2(2,nnn,ii)=zapas_recv(19,i,iii)
8730           gacontp_hb2(3,nnn,ii)=zapas_recv(20,i,iii)
8731           gacontm_hb3(1,nnn,ii)=zapas_recv(21,i,iii)
8732           gacontm_hb3(2,nnn,ii)=zapas_recv(22,i,iii)
8733           gacontm_hb3(3,nnn,ii)=zapas_recv(23,i,iii)
8734           gacontp_hb3(1,nnn,ii)=zapas_recv(24,i,iii)
8735           gacontp_hb3(2,nnn,ii)=zapas_recv(25,i,iii)
8736           gacontp_hb3(3,nnn,ii)=zapas_recv(26,i,iii)
8737         enddo
8738       enddo
8739       if (lprn) then
8740         write (iout,'(a)') 'Contact function values after receive:'
8741         do i=nnt,nct-2
8742           write (iout,'(2i3,50(1x,i3,f5.2))')
8743      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
8744      &    j=1,num_cont_hb(i))
8745         enddo
8746         call flush(iout)
8747       endif
8748    30 continue
8749 #endif
8750       if (lprn) then
8751         write (iout,'(a)') 'Contact function values:'
8752         do i=nnt,nct-2
8753           write (iout,'(2i3,50(1x,i3,f5.2))')
8754      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
8755      &    j=1,num_cont_hb(i))
8756         enddo
8757         call flush(iout)
8758       endif
8759       ecorr=0.0D0
8760 C Remove the loop below after debugging !!!
8761       do i=nnt,nct
8762         do j=1,3
8763           gradcorr(j,i)=0.0D0
8764           gradxorr(j,i)=0.0D0
8765         enddo
8766       enddo
8767 C Calculate the local-electrostatic correlation terms
8768       do i=min0(iatel_s,iturn4_start),max0(iatel_e,iturn3_end)
8769         i1=i+1
8770         num_conti=num_cont_hb(i)
8771         num_conti1=num_cont_hb(i+1)
8772         do jj=1,num_conti
8773           j=jcont_hb(jj,i)
8774           jp=iabs(j)
8775           do kk=1,num_conti1
8776             j1=jcont_hb(kk,i1)
8777             jp1=iabs(j1)
8778 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
8779 c     &         ' jj=',jj,' kk=',kk
8780 c            call flush(iout)
8781             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
8782      &          .or. j.lt.0 .and. j1.gt.0) .and.
8783      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
8784 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
8785 C The system gains extra energy.
8786               ecorr=ecorr+ehbcorr(i,jp,i+1,jp1,jj,kk,0.72D0,0.32D0)
8787               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
8788      &            'ecorrh',i,j,ehbcorr(i,j,i+1,j1,jj,kk,0.72D0,0.32D0)
8789               n_corr=n_corr+1
8790             else if (j1.eq.j) then
8791 C Contacts I-J and I-(J+1) occur simultaneously.
8792 C The system loses extra energy.
8793 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
8794             endif
8795           enddo ! kk
8796           do kk=1,num_conti
8797             j1=jcont_hb(kk,i)
8798 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
8799 c    &         ' jj=',jj,' kk=',kk
8800             if (j1.eq.j+1) then
8801 C Contacts I-J and (I+1)-J occur simultaneously.
8802 C The system loses extra energy.
8803 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
8804             endif ! j1==j+1
8805           enddo ! kk
8806         enddo ! jj
8807       enddo ! i
8808       return
8809       end
8810 c------------------------------------------------------------------------------
8811       subroutine add_hb_contact(ii,jj,itask)
8812       implicit real*8 (a-h,o-z)
8813       include "DIMENSIONS"
8814       include "COMMON.IOUNITS"
8815       integer max_cont
8816       integer max_dim
8817       parameter (max_cont=maxconts)
8818       parameter (max_dim=26)
8819       include "COMMON.CONTACTS"
8820       include 'COMMON.CONTMAT'
8821       include 'COMMON.CORRMAT'
8822       double precision zapas(max_dim,maxconts,max_fg_procs),
8823      &  zapas_recv(max_dim,maxconts,max_fg_procs)
8824       common /przechowalnia/ zapas
8825       integer i,j,ii,jj,iproc,itask(4),nn
8826 c      write (iout,*) "itask",itask
8827       do i=1,2
8828         iproc=itask(i)
8829         if (iproc.gt.0) then
8830           do j=1,num_cont_hb(ii)
8831             jjc=jcont_hb(j,ii)
8832 c            write (iout,*) "i",ii," j",jj," jjc",jjc
8833             if (jjc.eq.jj) then
8834               ncont_sent(iproc)=ncont_sent(iproc)+1
8835               nn=ncont_sent(iproc)
8836               zapas(1,nn,iproc)=ii
8837               zapas(2,nn,iproc)=jjc
8838               zapas(3,nn,iproc)=facont_hb(j,ii)
8839               zapas(4,nn,iproc)=ees0p(j,ii)
8840               zapas(5,nn,iproc)=ees0m(j,ii)
8841               zapas(6,nn,iproc)=gacont_hbr(1,j,ii)
8842               zapas(7,nn,iproc)=gacont_hbr(2,j,ii)
8843               zapas(8,nn,iproc)=gacont_hbr(3,j,ii)
8844               zapas(9,nn,iproc)=gacontm_hb1(1,j,ii)
8845               zapas(10,nn,iproc)=gacontm_hb1(2,j,ii)
8846               zapas(11,nn,iproc)=gacontm_hb1(3,j,ii)
8847               zapas(12,nn,iproc)=gacontp_hb1(1,j,ii)
8848               zapas(13,nn,iproc)=gacontp_hb1(2,j,ii)
8849               zapas(14,nn,iproc)=gacontp_hb1(3,j,ii)
8850               zapas(15,nn,iproc)=gacontm_hb2(1,j,ii)
8851               zapas(16,nn,iproc)=gacontm_hb2(2,j,ii)
8852               zapas(17,nn,iproc)=gacontm_hb2(3,j,ii)
8853               zapas(18,nn,iproc)=gacontp_hb2(1,j,ii)
8854               zapas(19,nn,iproc)=gacontp_hb2(2,j,ii)
8855               zapas(20,nn,iproc)=gacontp_hb2(3,j,ii)
8856               zapas(21,nn,iproc)=gacontm_hb3(1,j,ii)
8857               zapas(22,nn,iproc)=gacontm_hb3(2,j,ii)
8858               zapas(23,nn,iproc)=gacontm_hb3(3,j,ii)
8859               zapas(24,nn,iproc)=gacontp_hb3(1,j,ii)
8860               zapas(25,nn,iproc)=gacontp_hb3(2,j,ii)
8861               zapas(26,nn,iproc)=gacontp_hb3(3,j,ii)
8862               exit
8863             endif
8864           enddo
8865         endif
8866       enddo
8867       return
8868       end
8869 c------------------------------------------------------------------------------
8870       subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,
8871      &  n_corr1)
8872 C This subroutine calculates multi-body contributions to hydrogen-bonding
8873       implicit real*8 (a-h,o-z)
8874       include 'DIMENSIONS'
8875       include 'COMMON.IOUNITS'
8876 #ifdef MPI
8877       include "mpif.h"
8878       parameter (max_cont=maxconts)
8879       parameter (max_dim=70)
8880       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
8881       double precision zapas(max_dim,maxconts,max_fg_procs),
8882      &  zapas_recv(max_dim,maxconts,max_fg_procs)
8883       common /przechowalnia/ zapas
8884       integer status(MPI_STATUS_SIZE),req(maxconts*2),
8885      &  status_array(MPI_STATUS_SIZE,maxconts*2)
8886 #endif
8887       include 'COMMON.SETUP'
8888       include 'COMMON.FFIELD'
8889       include 'COMMON.DERIV'
8890       include 'COMMON.LOCAL'
8891       include 'COMMON.INTERACT'
8892       include 'COMMON.CONTACTS'
8893       include 'COMMON.CONTMAT'
8894       include 'COMMON.CORRMAT'
8895       include 'COMMON.CHAIN'
8896       include 'COMMON.CONTROL'
8897       include 'COMMON.SHIELD'
8898       double precision gx(3),gx1(3)
8899       integer num_cont_hb_old(maxres)
8900       logical lprn,ldone
8901       double precision eello4,eello5,eelo6,eello_turn6
8902       external eello4,eello5,eello6,eello_turn6
8903 C Set lprn=.true. for debugging
8904       lprn=.false.
8905       eturn6=0.0d0
8906 #ifdef MPI
8907       do i=1,nres
8908         num_cont_hb_old(i)=num_cont_hb(i)
8909       enddo
8910       n_corr=0
8911       n_corr1=0
8912       if (nfgtasks.le.1) goto 30
8913       if (lprn) then
8914         write (iout,'(a)') 'Contact function values before RECEIVE:'
8915         do i=nnt,nct-2
8916           write (iout,'(2i3,50(1x,i2,f5.2))')
8917      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
8918      &    j=1,num_cont_hb(i))
8919         enddo
8920       endif
8921       do i=1,ntask_cont_from
8922         ncont_recv(i)=0
8923       enddo
8924       do i=1,ntask_cont_to
8925         ncont_sent(i)=0
8926       enddo
8927 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
8928 c     & ntask_cont_to
8929 C Make the list of contacts to send to send to other procesors
8930       do i=iturn3_start,iturn3_end
8931 c        write (iout,*) "make contact list turn3",i," num_cont",
8932 c     &    num_cont_hb(i)
8933         call add_hb_contact_eello(i,i+2,iturn3_sent_local(1,i))
8934       enddo
8935       do i=iturn4_start,iturn4_end
8936 c        write (iout,*) "make contact list turn4",i," num_cont",
8937 c     &   num_cont_hb(i)
8938         call add_hb_contact_eello(i,i+3,iturn4_sent_local(1,i))
8939       enddo
8940       do ii=1,nat_sent
8941         i=iat_sent(ii)
8942 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
8943 c     &    num_cont_hb(i)
8944         do j=1,num_cont_hb(i)
8945         do k=1,4
8946           jjc=jcont_hb(j,i)
8947           iproc=iint_sent_local(k,jjc,ii)
8948 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
8949           if (iproc.ne.0) then
8950             ncont_sent(iproc)=ncont_sent(iproc)+1
8951             nn=ncont_sent(iproc)
8952             zapas(1,nn,iproc)=i
8953             zapas(2,nn,iproc)=jjc
8954             zapas(3,nn,iproc)=d_cont(j,i)
8955             ind=3
8956             do kk=1,3
8957               ind=ind+1
8958               zapas(ind,nn,iproc)=grij_hb_cont(kk,j,i)
8959             enddo
8960             do kk=1,2
8961               do ll=1,2
8962                 ind=ind+1
8963                 zapas(ind,nn,iproc)=a_chuj(ll,kk,j,i)
8964               enddo
8965             enddo
8966             do jj=1,5
8967               do kk=1,3
8968                 do ll=1,2
8969                   do mm=1,2
8970                     ind=ind+1
8971                     zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,i)
8972                   enddo
8973                 enddo
8974               enddo
8975             enddo
8976           endif
8977         enddo
8978         enddo
8979       enddo
8980       if (lprn) then
8981       write (iout,*)
8982      &  "Numbers of contacts to be sent to other processors",
8983      &  (ncont_sent(i),i=1,ntask_cont_to)
8984       write (iout,*) "Contacts sent"
8985       do ii=1,ntask_cont_to
8986         nn=ncont_sent(ii)
8987         iproc=itask_cont_to(ii)
8988         write (iout,*) nn," contacts to processor",iproc,
8989      &   " of CONT_TO_COMM group"
8990         do i=1,nn
8991           write(iout,'(2f5.0,10f10.5)')(zapas(j,i,ii),j=1,10)
8992         enddo
8993       enddo
8994       call flush(iout)
8995       endif
8996       CorrelType=477
8997       CorrelID=fg_rank+1
8998       CorrelType1=478
8999       CorrelID1=nfgtasks+fg_rank+1
9000       ireq=0
9001 C Receive the numbers of needed contacts from other processors
9002       do ii=1,ntask_cont_from
9003         iproc=itask_cont_from(ii)
9004         ireq=ireq+1
9005         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
9006      &    FG_COMM,req(ireq),IERR)
9007       enddo
9008 c      write (iout,*) "IRECV ended"
9009 c      call flush(iout)
9010 C Send the number of contacts needed by other processors
9011       do ii=1,ntask_cont_to
9012         iproc=itask_cont_to(ii)
9013         ireq=ireq+1
9014         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
9015      &    FG_COMM,req(ireq),IERR)
9016       enddo
9017 c      write (iout,*) "ISEND ended"
9018 c      write (iout,*) "number of requests (nn)",ireq
9019 c      call flush(iout)
9020       if (ireq.gt.0)
9021      &  call MPI_Waitall(ireq,req,status_array,ierr)
9022 c      write (iout,*)
9023 c     &  "Numbers of contacts to be received from other processors",
9024 c     &  (ncont_recv(i),i=1,ntask_cont_from)
9025 c      call flush(iout)
9026 C Receive contacts
9027       ireq=0
9028       do ii=1,ntask_cont_from
9029         iproc=itask_cont_from(ii)
9030         nn=ncont_recv(ii)
9031 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
9032 c     &   " of CONT_TO_COMM group"
9033 c        call flush(iout)
9034         if (nn.gt.0) then
9035           ireq=ireq+1
9036           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
9037      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
9038 c          write (iout,*) "ireq,req",ireq,req(ireq)
9039         endif
9040       enddo
9041 C Send the contacts to processors that need them
9042       do ii=1,ntask_cont_to
9043         iproc=itask_cont_to(ii)
9044         nn=ncont_sent(ii)
9045 c        write (iout,*) nn," contacts to processor",iproc,
9046 c     &   " of CONT_TO_COMM group"
9047         if (nn.gt.0) then
9048           ireq=ireq+1
9049           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
9050      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
9051 c          write (iout,*) "ireq,req",ireq,req(ireq)
9052 c          do i=1,nn
9053 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
9054 c          enddo
9055         endif
9056       enddo
9057 c      write (iout,*) "number of requests (contacts)",ireq
9058 c      write (iout,*) "req",(req(i),i=1,4)
9059 c      call flush(iout)
9060       if (ireq.gt.0)
9061      & call MPI_Waitall(ireq,req,status_array,ierr)
9062       do iii=1,ntask_cont_from
9063         iproc=itask_cont_from(iii)
9064         nn=ncont_recv(iii)
9065         if (lprn) then
9066         write (iout,*) "Received",nn," contacts from processor",iproc,
9067      &   " of CONT_FROM_COMM group"
9068         call flush(iout)
9069         do i=1,nn
9070           write(iout,'(2f5.0,10f10.5)')(zapas_recv(j,i,iii),j=1,10)
9071         enddo
9072         call flush(iout)
9073         endif
9074         do i=1,nn
9075           ii=zapas_recv(1,i,iii)
9076 c Flag the received contacts to prevent double-counting
9077           jj=-zapas_recv(2,i,iii)
9078 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
9079 c          call flush(iout)
9080           nnn=num_cont_hb(ii)+1
9081           num_cont_hb(ii)=nnn
9082           jcont_hb(nnn,ii)=jj
9083           d_cont(nnn,ii)=zapas_recv(3,i,iii)
9084           ind=3
9085           do kk=1,3
9086             ind=ind+1
9087             grij_hb_cont(kk,nnn,ii)=zapas_recv(ind,i,iii)
9088           enddo
9089           do kk=1,2
9090             do ll=1,2
9091               ind=ind+1
9092               a_chuj(ll,kk,nnn,ii)=zapas_recv(ind,i,iii)
9093             enddo
9094           enddo
9095           do jj=1,5
9096             do kk=1,3
9097               do ll=1,2
9098                 do mm=1,2
9099                   ind=ind+1
9100                   a_chuj_der(mm,ll,kk,jj,nnn,ii)=zapas_recv(ind,i,iii)
9101                 enddo
9102               enddo
9103             enddo
9104           enddo
9105         enddo
9106       enddo
9107       if (lprn) then
9108         write (iout,'(a)') 'Contact function values after receive:'
9109         do i=nnt,nct-2
9110           write (iout,'(2i3,50(1x,i3,5f6.3))')
9111      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
9112      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
9113         enddo
9114         call flush(iout)
9115       endif
9116    30 continue
9117 #endif
9118       if (lprn) then
9119         write (iout,'(a)') 'Contact function values:'
9120         do i=nnt,nct-2
9121           write (iout,'(2i3,50(1x,i2,5f6.3))')
9122      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
9123      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
9124         enddo
9125       endif
9126       ecorr=0.0D0
9127       ecorr5=0.0d0
9128       ecorr6=0.0d0
9129 C Remove the loop below after debugging !!!
9130       do i=nnt,nct
9131         do j=1,3
9132           gradcorr(j,i)=0.0D0
9133           gradxorr(j,i)=0.0D0
9134         enddo
9135       enddo
9136 C Calculate the dipole-dipole interaction energies
9137       if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
9138       do i=iatel_s,iatel_e+1
9139         num_conti=num_cont_hb(i)
9140         do jj=1,num_conti
9141           j=jcont_hb(jj,i)
9142 #ifdef MOMENT
9143           call dipole(i,j,jj)
9144 #endif
9145         enddo
9146       enddo
9147       endif
9148 C Calculate the local-electrostatic correlation terms
9149 c                write (iout,*) "gradcorr5 in eello5 before loop"
9150 c                do iii=1,nres
9151 c                  write (iout,'(i5,3f10.5)')
9152 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
9153 c                enddo
9154       do i=min0(iatel_s,iturn4_start),max0(iatel_e+1,iturn3_end+1)
9155 c        write (iout,*) "corr loop i",i
9156         i1=i+1
9157         num_conti=num_cont_hb(i)
9158         num_conti1=num_cont_hb(i+1)
9159         do jj=1,num_conti
9160           j=jcont_hb(jj,i)
9161           jp=iabs(j)
9162           do kk=1,num_conti1
9163             j1=jcont_hb(kk,i1)
9164             jp1=iabs(j1)
9165 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
9166 c     &         ' jj=',jj,' kk=',kk
9167 c            if (j1.eq.j+1 .or. j1.eq.j-1) then
9168             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
9169      &          .or. j.lt.0 .and. j1.gt.0) .and.
9170      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
9171 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
9172 C The system gains extra energy.
9173               n_corr=n_corr+1
9174               sqd1=dsqrt(d_cont(jj,i))
9175               sqd2=dsqrt(d_cont(kk,i1))
9176               sred_geom = sqd1*sqd2
9177               IF (sred_geom.lt.cutoff_corr) THEN
9178                 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,
9179      &            ekont,fprimcont)
9180 cd               write (iout,*) 'i=',i,' j=',jp,' i1=',i1,' j1=',jp1,
9181 cd     &         ' jj=',jj,' kk=',kk
9182                 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
9183                 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
9184                 do l=1,3
9185                   g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
9186                   g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
9187                 enddo
9188                 n_corr1=n_corr1+1
9189 cd               write (iout,*) 'sred_geom=',sred_geom,
9190 cd     &          ' ekont=',ekont,' fprim=',fprimcont,
9191 cd     &          ' fac_prim1',fac_prim1,' fac_prim2',fac_prim2
9192 cd               write (iout,*) "g_contij",g_contij
9193 cd               write (iout,*) "grij_hb_cont i",grij_hb_cont(:,jj,i)
9194 cd               write (iout,*) "grij_hb_cont i1",grij_hb_cont(:,jj,i1)
9195                 call calc_eello(i,jp,i+1,jp1,jj,kk)
9196                 if (wcorr4.gt.0.0d0)
9197      &            ecorr=ecorr+eello4(i,jp,i+1,jp1,jj,kk)
9198 CC     &            *fac_shield(i)**2*fac_shield(j)**2
9199                   if (energy_dec.and.wcorr4.gt.0.0d0)
9200      1                 write (iout,'(a6,4i5,0pf7.3)')
9201      2                'ecorr4',i,j,i+1,j1,eello4(i,jp,i+1,jp1,jj,kk)
9202 c                write (iout,*) "gradcorr5 before eello5"
9203 c                do iii=1,nres
9204 c                  write (iout,'(i5,3f10.5)')
9205 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
9206 c                enddo
9207                 if (wcorr5.gt.0.0d0)
9208      &            ecorr5=ecorr5+eello5(i,jp,i+1,jp1,jj,kk)
9209 c                write (iout,*) "gradcorr5 after eello5"
9210 c                do iii=1,nres
9211 c                  write (iout,'(i5,3f10.5)')
9212 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
9213 c                enddo
9214                   if (energy_dec.and.wcorr5.gt.0.0d0)
9215      1                 write (iout,'(a6,4i5,0pf7.3)')
9216      2                'ecorr5',i,j,i+1,j1,eello5(i,jp,i+1,jp1,jj,kk)
9217 cd                write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
9218 cd                write(2,*)'ijkl',i,jp,i+1,jp1
9219                 if (wcorr6.gt.0.0d0 .and. (jp.ne.i+4 .or. jp1.ne.i+3
9220      &               .or. wturn6.eq.0.0d0))then
9221 cd                  write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
9222                   ecorr6=ecorr6+eello6(i,jp,i+1,jp1,jj,kk)
9223                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
9224      1                'ecorr6',i,j,i+1,j1,eello6(i,jp,i+1,jp1,jj,kk)
9225 cd                write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
9226 cd     &            'ecorr6=',ecorr6
9227 cd                write (iout,'(4e15.5)') sred_geom,
9228 cd     &          dabs(eello4(i,jp,i+1,jp1,jj,kk)),
9229 cd     &          dabs(eello5(i,jp,i+1,jp1,jj,kk)),
9230 cd     &          dabs(eello6(i,jp,i+1,jp1,jj,kk))
9231                 else if (wturn6.gt.0.0d0
9232      &            .and. (jp.eq.i+4 .and. jp1.eq.i+3)) then
9233 cd                  write (iout,*) '******eturn6: i,j,i+1,j1',i,jip,i+1,jp1
9234                   eturn6=eturn6+eello_turn6(i,jj,kk)
9235                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
9236      1                 'eturn6',i,j,i+1,j1,eello_turn6(i,jj,kk)
9237 cd                  write (2,*) 'multibody_eello:eturn6',eturn6
9238                 endif
9239               ENDIF
9240 1111          continue
9241             endif
9242           enddo ! kk
9243         enddo ! jj
9244       enddo ! i
9245       do i=1,nres
9246         num_cont_hb(i)=num_cont_hb_old(i)
9247       enddo
9248 c                write (iout,*) "gradcorr5 in eello5"
9249 c                do iii=1,nres
9250 c                  write (iout,'(i5,3f10.5)')
9251 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
9252 c                enddo
9253       return
9254       end
9255 c------------------------------------------------------------------------------
9256       subroutine add_hb_contact_eello(ii,jj,itask)
9257       implicit real*8 (a-h,o-z)
9258       include "DIMENSIONS"
9259       include "COMMON.IOUNITS"
9260       integer max_cont
9261       integer max_dim
9262       parameter (max_cont=maxconts)
9263       parameter (max_dim=70)
9264       include "COMMON.CONTACTS"
9265       include 'COMMON.CONTMAT'
9266       include 'COMMON.CORRMAT'
9267       double precision zapas(max_dim,maxconts,max_fg_procs),
9268      &  zapas_recv(max_dim,maxconts,max_fg_procs)
9269       common /przechowalnia/ zapas
9270       integer i,j,ii,jj,iproc,itask(4),nn
9271 c      write (iout,*) "itask",itask
9272       do i=1,2
9273         iproc=itask(i)
9274         if (iproc.gt.0) then
9275           do j=1,num_cont_hb(ii)
9276             jjc=jcont_hb(j,ii)
9277 c            write (iout,*) "send turns i",ii," j",jj," jjc",jjc
9278             if (jjc.eq.jj) then
9279               ncont_sent(iproc)=ncont_sent(iproc)+1
9280               nn=ncont_sent(iproc)
9281               zapas(1,nn,iproc)=ii
9282               zapas(2,nn,iproc)=jjc
9283               zapas(3,nn,iproc)=d_cont(j,ii)
9284               ind=3
9285               do kk=1,3
9286                 ind=ind+1
9287                 zapas(ind,nn,iproc)=grij_hb_cont(kk,j,ii)
9288               enddo
9289               do kk=1,2
9290                 do ll=1,2
9291                   ind=ind+1
9292                   zapas(ind,nn,iproc)=a_chuj(ll,kk,j,ii)
9293                 enddo
9294               enddo
9295               do jj=1,5
9296                 do kk=1,3
9297                   do ll=1,2
9298                     do mm=1,2
9299                       ind=ind+1
9300                       zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,ii)
9301                     enddo
9302                   enddo
9303                 enddo
9304               enddo
9305               exit
9306             endif
9307           enddo
9308         endif
9309       enddo
9310       return
9311       end
9312 c------------------------------------------------------------------------------
9313       double precision function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
9314       implicit real*8 (a-h,o-z)
9315       include 'DIMENSIONS'
9316       include 'COMMON.IOUNITS'
9317       include 'COMMON.DERIV'
9318       include 'COMMON.INTERACT'
9319       include 'COMMON.CONTACTS'
9320       include 'COMMON.CONTMAT'
9321       include 'COMMON.CORRMAT'
9322       include 'COMMON.SHIELD'
9323       include 'COMMON.CONTROL'
9324       double precision gx(3),gx1(3)
9325       logical lprn
9326       lprn=.false.
9327 C      print *,"wchodze",fac_shield(i),shield_mode
9328       eij=facont_hb(jj,i)
9329       ekl=facont_hb(kk,k)
9330       ees0pij=ees0p(jj,i)
9331       ees0pkl=ees0p(kk,k)
9332       ees0mij=ees0m(jj,i)
9333       ees0mkl=ees0m(kk,k)
9334       ekont=eij*ekl
9335       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
9336 C*
9337 C     & fac_shield(i)**2*fac_shield(j)**2
9338 cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
9339 C Following 4 lines for diagnostics.
9340 cd    ees0pkl=0.0D0
9341 cd    ees0pij=1.0D0
9342 cd    ees0mkl=0.0D0
9343 cd    ees0mij=1.0D0
9344 c      write (iout,'(2(a,2i3,a,f10.5,a,2f10.5),a,f10.5,a,$)')
9345 c     & 'Contacts ',i,j,
9346 c     & ' eij',eij,' eesij',ees0pij,ees0mij,' and ',k,l
9347 c     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' energy=',ekont*ees,
9348 c     & 'gradcorr_long'
9349 C Calculate the multi-body contribution to energy.
9350 C      ecorr=ecorr+ekont*ees
9351 C Calculate multi-body contributions to the gradient.
9352       coeffpees0pij=coeffp*ees0pij
9353       coeffmees0mij=coeffm*ees0mij
9354       coeffpees0pkl=coeffp*ees0pkl
9355       coeffmees0mkl=coeffm*ees0mkl
9356       do ll=1,3
9357 cgrad        ghalfi=ees*ekl*gacont_hbr(ll,jj,i)
9358         gradcorr(ll,i)=gradcorr(ll,i)!+0.5d0*ghalfi
9359      &  -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+
9360      &  coeffmees0mkl*gacontm_hb1(ll,jj,i))
9361         gradcorr(ll,j)=gradcorr(ll,j)!+0.5d0*ghalfi
9362      &  -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+
9363      &  coeffmees0mkl*gacontm_hb2(ll,jj,i))
9364 cgrad        ghalfk=ees*eij*gacont_hbr(ll,kk,k)
9365         gradcorr(ll,k)=gradcorr(ll,k)!+0.5d0*ghalfk
9366      &  -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+
9367      &  coeffmees0mij*gacontm_hb1(ll,kk,k))
9368         gradcorr(ll,l)=gradcorr(ll,l)!+0.5d0*ghalfk
9369      &  -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+
9370      &  coeffmees0mij*gacontm_hb2(ll,kk,k))
9371         gradlongij=ees*ekl*gacont_hbr(ll,jj,i)-
9372      &     ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+
9373      &     coeffmees0mkl*gacontm_hb3(ll,jj,i))
9374         gradcorr_long(ll,j)=gradcorr_long(ll,j)+gradlongij
9375         gradcorr_long(ll,i)=gradcorr_long(ll,i)-gradlongij
9376         gradlongkl=ees*eij*gacont_hbr(ll,kk,k)-
9377      &     ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+
9378      &     coeffmees0mij*gacontm_hb3(ll,kk,k))
9379         gradcorr_long(ll,l)=gradcorr_long(ll,l)+gradlongkl
9380         gradcorr_long(ll,k)=gradcorr_long(ll,k)-gradlongkl
9381 c        write (iout,'(2f10.5,2x,$)') gradlongij,gradlongkl
9382       enddo
9383 c      write (iout,*)
9384 cgrad      do m=i+1,j-1
9385 cgrad        do ll=1,3
9386 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
9387 cgrad     &     ees*ekl*gacont_hbr(ll,jj,i)-
9388 cgrad     &     ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
9389 cgrad     &     coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
9390 cgrad        enddo
9391 cgrad      enddo
9392 cgrad      do m=k+1,l-1
9393 cgrad        do ll=1,3
9394 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
9395 cgrad     &     ees*eij*gacont_hbr(ll,kk,k)-
9396 cgrad     &     ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
9397 cgrad     &     coeffm*ees0mij*gacontm_hb3(ll,kk,k))
9398 cgrad        enddo
9399 cgrad      enddo
9400 c      write (iout,*) "ehbcorr",ekont*ees
9401 C      print *,ekont,ees,i,k
9402       ehbcorr=ekont*ees
9403 C now gradient over shielding
9404 C      return
9405       if (shield_mode.gt.0) then
9406        j=ees0plist(jj,i)
9407        l=ees0plist(kk,k)
9408 C        print *,i,j,fac_shield(i),fac_shield(j),
9409 C     &fac_shield(k),fac_shield(l)
9410         if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
9411      &      (fac_shield(k).gt.0).and.(fac_shield(l).gt.0)) then
9412           do ilist=1,ishield_list(i)
9413            iresshield=shield_list(ilist,i)
9414            do m=1,3
9415            rlocshield=grad_shield_side(m,ilist,i)*ehbcorr/fac_shield(i)
9416 C     &      *2.0
9417            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
9418      &              rlocshield
9419      & +grad_shield_loc(m,ilist,i)*ehbcorr/fac_shield(i)
9420             gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
9421      &+rlocshield
9422            enddo
9423           enddo
9424           do ilist=1,ishield_list(j)
9425            iresshield=shield_list(ilist,j)
9426            do m=1,3
9427            rlocshield=grad_shield_side(m,ilist,j)*ehbcorr/fac_shield(j)
9428 C     &     *2.0
9429            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
9430      &              rlocshield
9431      & +grad_shield_loc(m,ilist,j)*ehbcorr/fac_shield(j)
9432            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
9433      &     +rlocshield
9434            enddo
9435           enddo
9436
9437           do ilist=1,ishield_list(k)
9438            iresshield=shield_list(ilist,k)
9439            do m=1,3
9440            rlocshield=grad_shield_side(m,ilist,k)*ehbcorr/fac_shield(k)
9441 C     &     *2.0
9442            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
9443      &              rlocshield
9444      & +grad_shield_loc(m,ilist,k)*ehbcorr/fac_shield(k)
9445            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
9446      &     +rlocshield
9447            enddo
9448           enddo
9449           do ilist=1,ishield_list(l)
9450            iresshield=shield_list(ilist,l)
9451            do m=1,3
9452            rlocshield=grad_shield_side(m,ilist,l)*ehbcorr/fac_shield(l)
9453 C     &     *2.0
9454            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
9455      &              rlocshield
9456      & +grad_shield_loc(m,ilist,l)*ehbcorr/fac_shield(l)
9457            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
9458      &     +rlocshield
9459            enddo
9460           enddo
9461 C          print *,gshieldx(m,iresshield)
9462           do m=1,3
9463             gshieldc_ec(m,i)=gshieldc_ec(m,i)+
9464      &              grad_shield(m,i)*ehbcorr/fac_shield(i)
9465             gshieldc_ec(m,j)=gshieldc_ec(m,j)+
9466      &              grad_shield(m,j)*ehbcorr/fac_shield(j)
9467             gshieldc_ec(m,i-1)=gshieldc_ec(m,i-1)+
9468      &              grad_shield(m,i)*ehbcorr/fac_shield(i)
9469             gshieldc_ec(m,j-1)=gshieldc_ec(m,j-1)+
9470      &              grad_shield(m,j)*ehbcorr/fac_shield(j)
9471
9472             gshieldc_ec(m,k)=gshieldc_ec(m,k)+
9473      &              grad_shield(m,k)*ehbcorr/fac_shield(k)
9474             gshieldc_ec(m,l)=gshieldc_ec(m,l)+
9475      &              grad_shield(m,l)*ehbcorr/fac_shield(l)
9476             gshieldc_ec(m,k-1)=gshieldc_ec(m,k-1)+
9477      &              grad_shield(m,k)*ehbcorr/fac_shield(k)
9478             gshieldc_ec(m,l-1)=gshieldc_ec(m,l-1)+
9479      &              grad_shield(m,l)*ehbcorr/fac_shield(l)
9480
9481            enddo
9482       endif
9483       endif
9484       return
9485       end
9486 #ifdef MOMENT
9487 C---------------------------------------------------------------------------
9488       subroutine dipole(i,j,jj)
9489       implicit real*8 (a-h,o-z)
9490       include 'DIMENSIONS'
9491       include 'COMMON.IOUNITS'
9492       include 'COMMON.CHAIN'
9493       include 'COMMON.FFIELD'
9494       include 'COMMON.DERIV'
9495       include 'COMMON.INTERACT'
9496       include 'COMMON.CONTACTS'
9497       include 'COMMON.CONTMAT'
9498       include 'COMMON.CORRMAT'
9499       include 'COMMON.TORSION'
9500       include 'COMMON.VAR'
9501       include 'COMMON.GEO'
9502       dimension dipi(2,2),dipj(2,2),dipderi(2),dipderj(2),auxvec(2),
9503      &  auxmat(2,2)
9504       iti1 = itortyp(itype(i+1))
9505       if (j.lt.nres-1) then
9506         itj1 = itype2loc(itype(j+1))
9507       else
9508         itj1=nloctyp
9509       endif
9510       do iii=1,2
9511         dipi(iii,1)=Ub2(iii,i)
9512         dipderi(iii)=Ub2der(iii,i)
9513         dipi(iii,2)=b1(iii,i+1)
9514         dipj(iii,1)=Ub2(iii,j)
9515         dipderj(iii)=Ub2der(iii,j)
9516         dipj(iii,2)=b1(iii,j+1)
9517       enddo
9518       kkk=0
9519       do iii=1,2
9520         call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
9521         do jjj=1,2
9522           kkk=kkk+1
9523           dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
9524         enddo
9525       enddo
9526       do kkk=1,5
9527         do lll=1,3
9528           mmm=0
9529           do iii=1,2
9530             call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),
9531      &        auxvec(1))
9532             do jjj=1,2
9533               mmm=mmm+1
9534               dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
9535             enddo
9536           enddo
9537         enddo
9538       enddo
9539       call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
9540       call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
9541       do iii=1,2
9542         dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
9543       enddo
9544       call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
9545       do iii=1,2
9546         dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
9547       enddo
9548       return
9549       end
9550 #endif
9551 C---------------------------------------------------------------------------
9552       subroutine calc_eello(i,j,k,l,jj,kk)
9553 C
9554 C This subroutine computes matrices and vectors needed to calculate
9555 C the fourth-, fifth-, and sixth-order local-electrostatic terms.
9556 C
9557       implicit real*8 (a-h,o-z)
9558       include 'DIMENSIONS'
9559       include 'COMMON.IOUNITS'
9560       include 'COMMON.CHAIN'
9561       include 'COMMON.DERIV'
9562       include 'COMMON.INTERACT'
9563       include 'COMMON.CONTACTS'
9564       include 'COMMON.CONTMAT'
9565       include 'COMMON.CORRMAT'
9566       include 'COMMON.TORSION'
9567       include 'COMMON.VAR'
9568       include 'COMMON.GEO'
9569       include 'COMMON.FFIELD'
9570       double precision aa1(2,2),aa2(2,2),aa1t(2,2),aa2t(2,2),
9571      &  aa1tder(2,2,3,5),aa2tder(2,2,3,5),auxmat(2,2)
9572       logical lprn
9573       common /kutas/ lprn
9574 cd      write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
9575 cd     & ' jj=',jj,' kk=',kk
9576 cd      if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
9577 cd      write (iout,*) "a_chujij",((a_chuj(iii,jjj,jj,i),iii=1,2),jjj=1,2)
9578 cd      write (iout,*) "a_chujkl",((a_chuj(iii,jjj,kk,k),iii=1,2),jjj=1,2)
9579       do iii=1,2
9580         do jjj=1,2
9581           aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
9582           aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
9583         enddo
9584       enddo
9585       call transpose2(aa1(1,1),aa1t(1,1))
9586       call transpose2(aa2(1,1),aa2t(1,1))
9587       do kkk=1,5
9588         do lll=1,3
9589           call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),
9590      &      aa1tder(1,1,lll,kkk))
9591           call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),
9592      &      aa2tder(1,1,lll,kkk))
9593         enddo
9594       enddo
9595       if (l.eq.j+1) then
9596 C parallel orientation of the two CA-CA-CA frames.
9597         if (i.gt.1) then
9598           iti=itype2loc(itype(i))
9599         else
9600           iti=nloctyp
9601         endif
9602         itk1=itype2loc(itype(k+1))
9603         itj=itype2loc(itype(j))
9604         if (l.lt.nres-1) then
9605           itl1=itype2loc(itype(l+1))
9606         else
9607           itl1=nloctyp
9608         endif
9609 C A1 kernel(j+1) A2T
9610 cd        do iii=1,2
9611 cd          write (iout,'(3f10.5,5x,3f10.5)')
9612 cd     &     (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
9613 cd        enddo
9614         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9615      &   aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),
9616      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
9617 C Following matrices are needed only for 6-th order cumulants
9618         IF (wcorr6.gt.0.0d0) THEN
9619         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9620      &   aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),
9621      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
9622         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9623      &   aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),
9624      &   Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
9625      &   ADtEAderx(1,1,1,1,1,1))
9626         lprn=.false.
9627         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9628      &   aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),
9629      &   DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
9630      &   ADtEA1derx(1,1,1,1,1,1))
9631         ENDIF
9632 C End 6-th order cumulants
9633 cd        lprn=.false.
9634 cd        if (lprn) then
9635 cd        write (2,*) 'In calc_eello6'
9636 cd        do iii=1,2
9637 cd          write (2,*) 'iii=',iii
9638 cd          do kkk=1,5
9639 cd            write (2,*) 'kkk=',kkk
9640 cd            do jjj=1,2
9641 cd              write (2,'(3(2f10.5),5x)')
9642 cd     &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
9643 cd            enddo
9644 cd          enddo
9645 cd        enddo
9646 cd        endif
9647         call transpose2(EUgder(1,1,k),auxmat(1,1))
9648         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
9649         call transpose2(EUg(1,1,k),auxmat(1,1))
9650         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
9651         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
9652 C AL 4/16/16: Derivatives of the quantitied related to matrices C, D, and E
9653 c    in theta; to be sriten later.
9654 c#ifdef NEWCORR
9655 c        call transpose2(gtEE(1,1,k),auxmat(1,1))
9656 c        call matmat2(auxmat(1,1),AEA(1,1,1),EAEAdert(1,1,1,1))
9657 c        call transpose2(EUg(1,1,k),auxmat(1,1))
9658 c        call matmat2(auxmat(1,1),AEAdert(1,1,1),EAEAdert(1,1,2,1))
9659 c#endif
9660         do iii=1,2
9661           do kkk=1,5
9662             do lll=1,3
9663               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
9664      &          EAEAderx(1,1,lll,kkk,iii,1))
9665             enddo
9666           enddo
9667         enddo
9668 C A1T kernel(i+1) A2
9669         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
9670      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),
9671      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
9672 C Following matrices are needed only for 6-th order cumulants
9673         IF (wcorr6.gt.0.0d0) THEN
9674         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
9675      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),
9676      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
9677         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
9678      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),
9679      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
9680      &   ADtEAderx(1,1,1,1,1,2))
9681         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
9682      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),
9683      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
9684      &   ADtEA1derx(1,1,1,1,1,2))
9685         ENDIF
9686 C End 6-th order cumulants
9687         call transpose2(EUgder(1,1,l),auxmat(1,1))
9688         call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
9689         call transpose2(EUg(1,1,l),auxmat(1,1))
9690         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
9691         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
9692         do iii=1,2
9693           do kkk=1,5
9694             do lll=1,3
9695               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
9696      &          EAEAderx(1,1,lll,kkk,iii,2))
9697             enddo
9698           enddo
9699         enddo
9700 C AEAb1 and AEAb2
9701 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
9702 C They are needed only when the fifth- or the sixth-order cumulants are
9703 C indluded.
9704         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
9705         call transpose2(AEA(1,1,1),auxmat(1,1))
9706         call matvec2(auxmat(1,1),b1(1,i),AEAb1(1,1,1))
9707         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
9708         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
9709         call transpose2(AEAderg(1,1,1),auxmat(1,1))
9710         call matvec2(auxmat(1,1),b1(1,i),AEAb1derg(1,1,1))
9711         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
9712         call matvec2(AEA(1,1,1),b1(1,k+1),AEAb1(1,2,1))
9713         call matvec2(AEAderg(1,1,1),b1(1,k+1),AEAb1derg(1,2,1))
9714         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
9715         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
9716         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
9717         call transpose2(AEA(1,1,2),auxmat(1,1))
9718         call matvec2(auxmat(1,1),b1(1,j),AEAb1(1,1,2))
9719         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
9720         call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
9721         call transpose2(AEAderg(1,1,2),auxmat(1,1))
9722         call matvec2(auxmat(1,1),b1(1,j),AEAb1derg(1,1,2))
9723         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
9724         call matvec2(AEA(1,1,2),b1(1,l+1),AEAb1(1,2,2))
9725         call matvec2(AEAderg(1,1,2),b1(1,l+1),AEAb1derg(1,2,2))
9726         call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
9727         call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
9728         call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
9729 C Calculate the Cartesian derivatives of the vectors.
9730         do iii=1,2
9731           do kkk=1,5
9732             do lll=1,3
9733               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
9734               call matvec2(auxmat(1,1),b1(1,i),
9735      &          AEAb1derx(1,lll,kkk,iii,1,1))
9736               call matvec2(auxmat(1,1),Ub2(1,i),
9737      &          AEAb2derx(1,lll,kkk,iii,1,1))
9738               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
9739      &          AEAb1derx(1,lll,kkk,iii,2,1))
9740               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
9741      &          AEAb2derx(1,lll,kkk,iii,2,1))
9742               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
9743               call matvec2(auxmat(1,1),b1(1,j),
9744      &          AEAb1derx(1,lll,kkk,iii,1,2))
9745               call matvec2(auxmat(1,1),Ub2(1,j),
9746      &          AEAb2derx(1,lll,kkk,iii,1,2))
9747               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,l+1),
9748      &          AEAb1derx(1,lll,kkk,iii,2,2))
9749               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),
9750      &          AEAb2derx(1,lll,kkk,iii,2,2))
9751             enddo
9752           enddo
9753         enddo
9754         ENDIF
9755 C End vectors
9756       else
9757 C Antiparallel orientation of the two CA-CA-CA frames.
9758         if (i.gt.1) then
9759           iti=itype2loc(itype(i))
9760         else
9761           iti=nloctyp
9762         endif
9763         itk1=itype2loc(itype(k+1))
9764         itl=itype2loc(itype(l))
9765         itj=itype2loc(itype(j))
9766         if (j.lt.nres-1) then
9767           itj1=itype2loc(itype(j+1))
9768         else
9769           itj1=nloctyp
9770         endif
9771 C A2 kernel(j-1)T A1T
9772         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9773      &   aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),
9774      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
9775 C Following matrices are needed only for 6-th order cumulants
9776         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
9777      &     j.eq.i+4 .and. l.eq.i+3)) THEN
9778         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9779      &   aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),
9780      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
9781         call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9782      &   aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),
9783      &   Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
9784      &   ADtEAderx(1,1,1,1,1,1))
9785         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9786      &   aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),
9787      &   DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
9788      &   ADtEA1derx(1,1,1,1,1,1))
9789         ENDIF
9790 C End 6-th order cumulants
9791         call transpose2(EUgder(1,1,k),auxmat(1,1))
9792         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
9793         call transpose2(EUg(1,1,k),auxmat(1,1))
9794         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
9795         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
9796         do iii=1,2
9797           do kkk=1,5
9798             do lll=1,3
9799               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
9800      &          EAEAderx(1,1,lll,kkk,iii,1))
9801             enddo
9802           enddo
9803         enddo
9804 C A2T kernel(i+1)T A1
9805         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
9806      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),
9807      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
9808 C Following matrices are needed only for 6-th order cumulants
9809         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
9810      &     j.eq.i+4 .and. l.eq.i+3)) THEN
9811         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
9812      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),
9813      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
9814         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
9815      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),
9816      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
9817      &   ADtEAderx(1,1,1,1,1,2))
9818         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
9819      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),
9820      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
9821      &   ADtEA1derx(1,1,1,1,1,2))
9822         ENDIF
9823 C End 6-th order cumulants
9824         call transpose2(EUgder(1,1,j),auxmat(1,1))
9825         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
9826         call transpose2(EUg(1,1,j),auxmat(1,1))
9827         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
9828         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
9829         do iii=1,2
9830           do kkk=1,5
9831             do lll=1,3
9832               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
9833      &          EAEAderx(1,1,lll,kkk,iii,2))
9834             enddo
9835           enddo
9836         enddo
9837 C AEAb1 and AEAb2
9838 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
9839 C They are needed only when the fifth- or the sixth-order cumulants are
9840 C indluded.
9841         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or.
9842      &    (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
9843         call transpose2(AEA(1,1,1),auxmat(1,1))
9844         call matvec2(auxmat(1,1),b1(1,i),AEAb1(1,1,1))
9845         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
9846         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
9847         call transpose2(AEAderg(1,1,1),auxmat(1,1))
9848         call matvec2(auxmat(1,1),b1(1,i),AEAb1derg(1,1,1))
9849         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
9850         call matvec2(AEA(1,1,1),b1(1,k+1),AEAb1(1,2,1))
9851         call matvec2(AEAderg(1,1,1),b1(1,k+1),AEAb1derg(1,2,1))
9852         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
9853         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
9854         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
9855         call transpose2(AEA(1,1,2),auxmat(1,1))
9856         call matvec2(auxmat(1,1),b1(1,j+1),AEAb1(1,1,2))
9857         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
9858         call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
9859         call transpose2(AEAderg(1,1,2),auxmat(1,1))
9860         call matvec2(auxmat(1,1),b1(1,l),AEAb1(1,1,2))
9861         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
9862         call matvec2(AEA(1,1,2),b1(1,j+1),AEAb1(1,2,2))
9863         call matvec2(AEAderg(1,1,2),b1(1,j+1),AEAb1derg(1,2,2))
9864         call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
9865         call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
9866         call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
9867 C Calculate the Cartesian derivatives of the vectors.
9868         do iii=1,2
9869           do kkk=1,5
9870             do lll=1,3
9871               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
9872               call matvec2(auxmat(1,1),b1(1,i),
9873      &          AEAb1derx(1,lll,kkk,iii,1,1))
9874               call matvec2(auxmat(1,1),Ub2(1,i),
9875      &          AEAb2derx(1,lll,kkk,iii,1,1))
9876               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
9877      &          AEAb1derx(1,lll,kkk,iii,2,1))
9878               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
9879      &          AEAb2derx(1,lll,kkk,iii,2,1))
9880               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
9881               call matvec2(auxmat(1,1),b1(1,l),
9882      &          AEAb1derx(1,lll,kkk,iii,1,2))
9883               call matvec2(auxmat(1,1),Ub2(1,l),
9884      &          AEAb2derx(1,lll,kkk,iii,1,2))
9885               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,j+1),
9886      &          AEAb1derx(1,lll,kkk,iii,2,2))
9887               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),
9888      &          AEAb2derx(1,lll,kkk,iii,2,2))
9889             enddo
9890           enddo
9891         enddo
9892         ENDIF
9893 C End vectors
9894       endif
9895       return
9896       end
9897 C---------------------------------------------------------------------------
9898       subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,
9899      &  KK,KKderg,AKA,AKAderg,AKAderx)
9900       implicit none
9901       integer nderg
9902       logical transp
9903       double precision aa1(2,2),aa2t(2,2),aa1derx(2,2,3,5),
9904      &  aa2tderx(2,2,3,5),KK(2,2),KKderg(2,2,nderg),AKA(2,2),
9905      &  AKAderg(2,2,nderg),AKAderx(2,2,3,5,2)
9906       integer iii,kkk,lll
9907       integer jjj,mmm
9908       logical lprn
9909       common /kutas/ lprn
9910       call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
9911       do iii=1,nderg
9912         call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,
9913      &    AKAderg(1,1,iii))
9914       enddo
9915 cd      if (lprn) write (2,*) 'In kernel'
9916       do kkk=1,5
9917 cd        if (lprn) write (2,*) 'kkk=',kkk
9918         do lll=1,3
9919           call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),
9920      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
9921 cd          if (lprn) then
9922 cd            write (2,*) 'lll=',lll
9923 cd            write (2,*) 'iii=1'
9924 cd            do jjj=1,2
9925 cd              write (2,'(3(2f10.5),5x)')
9926 cd     &        (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
9927 cd            enddo
9928 cd          endif
9929           call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),
9930      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
9931 cd          if (lprn) then
9932 cd            write (2,*) 'lll=',lll
9933 cd            write (2,*) 'iii=2'
9934 cd            do jjj=1,2
9935 cd              write (2,'(3(2f10.5),5x)')
9936 cd     &        (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
9937 cd            enddo
9938 cd          endif
9939         enddo
9940       enddo
9941       return
9942       end
9943 C---------------------------------------------------------------------------
9944       double precision function eello4(i,j,k,l,jj,kk)
9945       implicit real*8 (a-h,o-z)
9946       include 'DIMENSIONS'
9947       include 'COMMON.IOUNITS'
9948       include 'COMMON.CHAIN'
9949       include 'COMMON.DERIV'
9950       include 'COMMON.INTERACT'
9951       include 'COMMON.CONTACTS'
9952       include 'COMMON.CONTMAT'
9953       include 'COMMON.CORRMAT'
9954       include 'COMMON.TORSION'
9955       include 'COMMON.VAR'
9956       include 'COMMON.GEO'
9957       double precision pizda(2,2),ggg1(3),ggg2(3)
9958 cd      if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
9959 cd        eello4=0.0d0
9960 cd        return
9961 cd      endif
9962 cd      print *,'eello4:',i,j,k,l,jj,kk
9963 cd      write (2,*) 'i',i,' j',j,' k',k,' l',l
9964 cd      call checkint4(i,j,k,l,jj,kk,eel4_num)
9965 cold      eij=facont_hb(jj,i)
9966 cold      ekl=facont_hb(kk,k)
9967 cold      ekont=eij*ekl
9968       eel4=-EAEA(1,1,1)-EAEA(2,2,1)
9969 cd      eel41=-EAEA(1,1,2)-EAEA(2,2,2)
9970       gcorr_loc(k-1)=gcorr_loc(k-1)
9971      &   -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
9972       if (l.eq.j+1) then
9973         gcorr_loc(l-1)=gcorr_loc(l-1)
9974      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
9975 C Al 4/16/16: Derivatives in theta, to be added later.
9976 c#ifdef NEWCORR
9977 c        gcorr_loc(nphi+l-1)=gcorr_loc(nphi+l-1)
9978 c     &     -ekont*(EAEAdert(1,1,2,1)+EAEAdert(2,2,2,1))
9979 c#endif
9980       else
9981         gcorr_loc(j-1)=gcorr_loc(j-1)
9982      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
9983 c#ifdef NEWCORR
9984 c        gcorr_loc(nphi+j-1)=gcorr_loc(nphi+j-1)
9985 c     &     -ekont*(EAEAdert(1,1,2,1)+EAEAdert(2,2,2,1))
9986 c#endif
9987       endif
9988       do iii=1,2
9989         do kkk=1,5
9990           do lll=1,3
9991             derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1)
9992      &                        -EAEAderx(2,2,lll,kkk,iii,1)
9993 cd            derx(lll,kkk,iii)=0.0d0
9994           enddo
9995         enddo
9996       enddo
9997 cd      gcorr_loc(l-1)=0.0d0
9998 cd      gcorr_loc(j-1)=0.0d0
9999 cd      gcorr_loc(k-1)=0.0d0
10000 cd      eel4=1.0d0
10001 cd      write (iout,*)'Contacts have occurred for peptide groups',
10002 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l,
10003 cd     &  ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
10004       if (j.lt.nres-1) then
10005         j1=j+1
10006         j2=j-1
10007       else
10008         j1=j-1
10009         j2=j-2
10010       endif
10011       if (l.lt.nres-1) then
10012         l1=l+1
10013         l2=l-1
10014       else
10015         l1=l-1
10016         l2=l-2
10017       endif
10018       do ll=1,3
10019 cgrad        ggg1(ll)=eel4*g_contij(ll,1)
10020 cgrad        ggg2(ll)=eel4*g_contij(ll,2)
10021         glongij=eel4*g_contij(ll,1)+ekont*derx(ll,1,1)
10022         glongkl=eel4*g_contij(ll,2)+ekont*derx(ll,1,2)
10023 cgrad        ghalf=0.5d0*ggg1(ll)
10024         gradcorr(ll,i)=gradcorr(ll,i)+ekont*derx(ll,2,1)
10025         gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
10026         gradcorr(ll,j)=gradcorr(ll,j)+ekont*derx(ll,4,1)
10027         gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
10028         gradcorr_long(ll,j)=gradcorr_long(ll,j)+glongij
10029         gradcorr_long(ll,i)=gradcorr_long(ll,i)-glongij
10030 cgrad        ghalf=0.5d0*ggg2(ll)
10031         gradcorr(ll,k)=gradcorr(ll,k)+ekont*derx(ll,2,2)
10032         gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
10033         gradcorr(ll,l)=gradcorr(ll,l)+ekont*derx(ll,4,2)
10034         gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
10035         gradcorr_long(ll,l)=gradcorr_long(ll,l)+glongkl
10036         gradcorr_long(ll,k)=gradcorr_long(ll,k)-glongkl
10037       enddo
10038 cgrad      do m=i+1,j-1
10039 cgrad        do ll=1,3
10040 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
10041 cgrad        enddo
10042 cgrad      enddo
10043 cgrad      do m=k+1,l-1
10044 cgrad        do ll=1,3
10045 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
10046 cgrad        enddo
10047 cgrad      enddo
10048 cgrad      do m=i+2,j2
10049 cgrad        do ll=1,3
10050 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
10051 cgrad        enddo
10052 cgrad      enddo
10053 cgrad      do m=k+2,l2
10054 cgrad        do ll=1,3
10055 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
10056 cgrad        enddo
10057 cgrad      enddo
10058 cd      do iii=1,nres-3
10059 cd        write (2,*) iii,gcorr_loc(iii)
10060 cd      enddo
10061       eello4=ekont*eel4
10062 cd      write (2,*) 'ekont',ekont
10063 cd      write (iout,*) 'eello4',ekont*eel4
10064       return
10065       end
10066 C---------------------------------------------------------------------------
10067       double precision function eello5(i,j,k,l,jj,kk)
10068       implicit real*8 (a-h,o-z)
10069       include 'DIMENSIONS'
10070       include 'COMMON.IOUNITS'
10071       include 'COMMON.CHAIN'
10072       include 'COMMON.DERIV'
10073       include 'COMMON.INTERACT'
10074       include 'COMMON.CONTACTS'
10075       include 'COMMON.CONTMAT'
10076       include 'COMMON.CORRMAT'
10077       include 'COMMON.TORSION'
10078       include 'COMMON.VAR'
10079       include 'COMMON.GEO'
10080       double precision pizda(2,2),auxmat(2,2),auxmat1(2,2),vv(2)
10081       double precision ggg1(3),ggg2(3)
10082 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10083 C                                                                              C
10084 C                            Parallel chains                                   C
10085 C                                                                              C
10086 C          o             o                   o             o                   C
10087 C         /l\           / \             \   / \           / \   /              C
10088 C        /   \         /   \             \ /   \         /   \ /               C
10089 C       j| o |l1       | o |              o| o |         | o |o                C
10090 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
10091 C      \i/   \         /   \ /             /   \         /   \                 C
10092 C       o    k1             o                                                  C
10093 C         (I)          (II)                (III)          (IV)                 C
10094 C                                                                              C
10095 C      eello5_1        eello5_2            eello5_3       eello5_4             C
10096 C                                                                              C
10097 C                            Antiparallel chains                               C
10098 C                                                                              C
10099 C          o             o                   o             o                   C
10100 C         /j\           / \             \   / \           / \   /              C
10101 C        /   \         /   \             \ /   \         /   \ /               C
10102 C      j1| o |l        | o |              o| o |         | o |o                C
10103 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
10104 C      \i/   \         /   \ /             /   \         /   \                 C
10105 C       o     k1            o                                                  C
10106 C         (I)          (II)                (III)          (IV)                 C
10107 C                                                                              C
10108 C      eello5_1        eello5_2            eello5_3       eello5_4             C
10109 C                                                                              C
10110 C o denotes a local interaction, vertical lines an electrostatic interaction.  C
10111 C                                                                              C
10112 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10113 cd      if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
10114 cd        eello5=0.0d0
10115 cd        return
10116 cd      endif
10117 cd      write (iout,*)
10118 cd     &   'EELLO5: Contacts have occurred for peptide groups',i,j,
10119 cd     &   ' and',k,l
10120       itk=itype2loc(itype(k))
10121       itl=itype2loc(itype(l))
10122       itj=itype2loc(itype(j))
10123       eello5_1=0.0d0
10124       eello5_2=0.0d0
10125       eello5_3=0.0d0
10126       eello5_4=0.0d0
10127 cd      call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
10128 cd     &   eel5_3_num,eel5_4_num)
10129       do iii=1,2
10130         do kkk=1,5
10131           do lll=1,3
10132             derx(lll,kkk,iii)=0.0d0
10133           enddo
10134         enddo
10135       enddo
10136 cd      eij=facont_hb(jj,i)
10137 cd      ekl=facont_hb(kk,k)
10138 cd      ekont=eij*ekl
10139 cd      write (iout,*)'Contacts have occurred for peptide groups',
10140 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l
10141 cd      goto 1111
10142 C Contribution from the graph I.
10143 cd      write (2,*) 'AEA  ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
10144 cd      write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
10145       call transpose2(EUg(1,1,k),auxmat(1,1))
10146       call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
10147       vv(1)=pizda(1,1)-pizda(2,2)
10148       vv(2)=pizda(1,2)+pizda(2,1)
10149       eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k))
10150      & +0.5d0*scalar2(vv(1),Dtobr2(1,i))
10151 C Explicit gradient in virtual-dihedral angles.
10152       if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1)
10153      & +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k))
10154      & +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
10155       call transpose2(EUgder(1,1,k),auxmat1(1,1))
10156       call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
10157       vv(1)=pizda(1,1)-pizda(2,2)
10158       vv(2)=pizda(1,2)+pizda(2,1)
10159       g_corr5_loc(k-1)=g_corr5_loc(k-1)
10160      & +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k))
10161      & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
10162       call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
10163       vv(1)=pizda(1,1)-pizda(2,2)
10164       vv(2)=pizda(1,2)+pizda(2,1)
10165       if (l.eq.j+1) then
10166         if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1)
10167      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
10168      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
10169       else
10170         if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1)
10171      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
10172      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
10173       endif
10174 C Cartesian gradient
10175       do iii=1,2
10176         do kkk=1,5
10177           do lll=1,3
10178             call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),
10179      &        pizda(1,1))
10180             vv(1)=pizda(1,1)-pizda(2,2)
10181             vv(2)=pizda(1,2)+pizda(2,1)
10182             derx(lll,kkk,iii)=derx(lll,kkk,iii)
10183      &       +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k))
10184      &       +0.5d0*scalar2(vv(1),Dtobr2(1,i))
10185           enddo
10186         enddo
10187       enddo
10188 c      goto 1112
10189 c1111  continue
10190 C Contribution from graph II
10191       call transpose2(EE(1,1,k),auxmat(1,1))
10192       call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
10193       vv(1)=pizda(1,1)+pizda(2,2)
10194       vv(2)=pizda(2,1)-pizda(1,2)
10195       eello5_2=scalar2(AEAb1(1,2,1),b1(1,k))
10196      & -0.5d0*scalar2(vv(1),Ctobr(1,k))
10197 C Explicit gradient in virtual-dihedral angles.
10198       g_corr5_loc(k-1)=g_corr5_loc(k-1)
10199      & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
10200       call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
10201       vv(1)=pizda(1,1)+pizda(2,2)
10202       vv(2)=pizda(2,1)-pizda(1,2)
10203       if (l.eq.j+1) then
10204         g_corr5_loc(l-1)=g_corr5_loc(l-1)
10205      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,k))
10206      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
10207       else
10208         g_corr5_loc(j-1)=g_corr5_loc(j-1)
10209      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,k))
10210      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
10211       endif
10212 C Cartesian gradient
10213       do iii=1,2
10214         do kkk=1,5
10215           do lll=1,3
10216             call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
10217      &        pizda(1,1))
10218             vv(1)=pizda(1,1)+pizda(2,2)
10219             vv(2)=pizda(2,1)-pizda(1,2)
10220             derx(lll,kkk,iii)=derx(lll,kkk,iii)
10221      &       +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,k))
10222      &       -0.5d0*scalar2(vv(1),Ctobr(1,k))
10223           enddo
10224         enddo
10225       enddo
10226 cd      goto 1112
10227 cd1111  continue
10228       if (l.eq.j+1) then
10229 cd        goto 1110
10230 C Parallel orientation
10231 C Contribution from graph III
10232         call transpose2(EUg(1,1,l),auxmat(1,1))
10233         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
10234         vv(1)=pizda(1,1)-pizda(2,2)
10235         vv(2)=pizda(1,2)+pizda(2,1)
10236         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l))
10237      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j))
10238 C Explicit gradient in virtual-dihedral angles.
10239         g_corr5_loc(j-1)=g_corr5_loc(j-1)
10240      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l))
10241      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
10242         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
10243         vv(1)=pizda(1,1)-pizda(2,2)
10244         vv(2)=pizda(1,2)+pizda(2,1)
10245         g_corr5_loc(k-1)=g_corr5_loc(k-1)
10246      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l))
10247      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
10248         call transpose2(EUgder(1,1,l),auxmat1(1,1))
10249         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
10250         vv(1)=pizda(1,1)-pizda(2,2)
10251         vv(2)=pizda(1,2)+pizda(2,1)
10252         g_corr5_loc(l-1)=g_corr5_loc(l-1)
10253      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l))
10254      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
10255 C Cartesian gradient
10256         do iii=1,2
10257           do kkk=1,5
10258             do lll=1,3
10259               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
10260      &          pizda(1,1))
10261               vv(1)=pizda(1,1)-pizda(2,2)
10262               vv(2)=pizda(1,2)+pizda(2,1)
10263               derx(lll,kkk,iii)=derx(lll,kkk,iii)
10264      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l))
10265      &         +0.5d0*scalar2(vv(1),Dtobr2(1,j))
10266             enddo
10267           enddo
10268         enddo
10269 cd        goto 1112
10270 C Contribution from graph IV
10271 cd1110    continue
10272         call transpose2(EE(1,1,l),auxmat(1,1))
10273         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
10274         vv(1)=pizda(1,1)+pizda(2,2)
10275         vv(2)=pizda(2,1)-pizda(1,2)
10276         eello5_4=scalar2(AEAb1(1,2,2),b1(1,l))
10277      &   -0.5d0*scalar2(vv(1),Ctobr(1,l))
10278 C Explicit gradient in virtual-dihedral angles.
10279         g_corr5_loc(l-1)=g_corr5_loc(l-1)
10280      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
10281         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
10282         vv(1)=pizda(1,1)+pizda(2,2)
10283         vv(2)=pizda(2,1)-pizda(1,2)
10284         g_corr5_loc(k-1)=g_corr5_loc(k-1)
10285      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,l))
10286      &   -0.5d0*scalar2(vv(1),Ctobr(1,l)))
10287 C Cartesian gradient
10288         do iii=1,2
10289           do kkk=1,5
10290             do lll=1,3
10291               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
10292      &          pizda(1,1))
10293               vv(1)=pizda(1,1)+pizda(2,2)
10294               vv(2)=pizda(2,1)-pizda(1,2)
10295               derx(lll,kkk,iii)=derx(lll,kkk,iii)
10296      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,l))
10297      &         -0.5d0*scalar2(vv(1),Ctobr(1,l))
10298             enddo
10299           enddo
10300         enddo
10301       else
10302 C Antiparallel orientation
10303 C Contribution from graph III
10304 c        goto 1110
10305         call transpose2(EUg(1,1,j),auxmat(1,1))
10306         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
10307         vv(1)=pizda(1,1)-pizda(2,2)
10308         vv(2)=pizda(1,2)+pizda(2,1)
10309         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j))
10310      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l))
10311 C Explicit gradient in virtual-dihedral angles.
10312         g_corr5_loc(l-1)=g_corr5_loc(l-1)
10313      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j))
10314      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
10315         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
10316         vv(1)=pizda(1,1)-pizda(2,2)
10317         vv(2)=pizda(1,2)+pizda(2,1)
10318         g_corr5_loc(k-1)=g_corr5_loc(k-1)
10319      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j))
10320      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
10321         call transpose2(EUgder(1,1,j),auxmat1(1,1))
10322         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
10323         vv(1)=pizda(1,1)-pizda(2,2)
10324         vv(2)=pizda(1,2)+pizda(2,1)
10325         g_corr5_loc(j-1)=g_corr5_loc(j-1)
10326      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j))
10327      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
10328 C Cartesian gradient
10329         do iii=1,2
10330           do kkk=1,5
10331             do lll=1,3
10332               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
10333      &          pizda(1,1))
10334               vv(1)=pizda(1,1)-pizda(2,2)
10335               vv(2)=pizda(1,2)+pizda(2,1)
10336               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
10337      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j))
10338      &         +0.5d0*scalar2(vv(1),Dtobr2(1,l))
10339             enddo
10340           enddo
10341         enddo
10342 cd        goto 1112
10343 C Contribution from graph IV
10344 1110    continue
10345         call transpose2(EE(1,1,j),auxmat(1,1))
10346         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
10347         vv(1)=pizda(1,1)+pizda(2,2)
10348         vv(2)=pizda(2,1)-pizda(1,2)
10349         eello5_4=scalar2(AEAb1(1,2,2),b1(1,j))
10350      &   -0.5d0*scalar2(vv(1),Ctobr(1,j))
10351 C Explicit gradient in virtual-dihedral angles.
10352         g_corr5_loc(j-1)=g_corr5_loc(j-1)
10353      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
10354         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
10355         vv(1)=pizda(1,1)+pizda(2,2)
10356         vv(2)=pizda(2,1)-pizda(1,2)
10357         g_corr5_loc(k-1)=g_corr5_loc(k-1)
10358      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,j))
10359      &   -0.5d0*scalar2(vv(1),Ctobr(1,j)))
10360 C Cartesian gradient
10361         do iii=1,2
10362           do kkk=1,5
10363             do lll=1,3
10364               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
10365      &          pizda(1,1))
10366               vv(1)=pizda(1,1)+pizda(2,2)
10367               vv(2)=pizda(2,1)-pizda(1,2)
10368               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
10369      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,j))
10370      &         -0.5d0*scalar2(vv(1),Ctobr(1,j))
10371             enddo
10372           enddo
10373         enddo
10374       endif
10375 1112  continue
10376       eel5=eello5_1+eello5_2+eello5_3+eello5_4
10377 cd      if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
10378 cd        write (2,*) 'ijkl',i,j,k,l
10379 cd        write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
10380 cd     &     ' eello5_3',eello5_3,' eello5_4',eello5_4
10381 cd      endif
10382 cd      write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
10383 cd      write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
10384 cd      write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
10385 cd      write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
10386       if (j.lt.nres-1) then
10387         j1=j+1
10388         j2=j-1
10389       else
10390         j1=j-1
10391         j2=j-2
10392       endif
10393       if (l.lt.nres-1) then
10394         l1=l+1
10395         l2=l-1
10396       else
10397         l1=l-1
10398         l2=l-2
10399       endif
10400 cd      eij=1.0d0
10401 cd      ekl=1.0d0
10402 cd      ekont=1.0d0
10403 cd      write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
10404 C 2/11/08 AL Gradients over DC's connecting interacting sites will be
10405 C        summed up outside the subrouine as for the other subroutines
10406 C        handling long-range interactions. The old code is commented out
10407 C        with "cgrad" to keep track of changes.
10408       do ll=1,3
10409 cgrad        ggg1(ll)=eel5*g_contij(ll,1)
10410 cgrad        ggg2(ll)=eel5*g_contij(ll,2)
10411         gradcorr5ij=eel5*g_contij(ll,1)+ekont*derx(ll,1,1)
10412         gradcorr5kl=eel5*g_contij(ll,2)+ekont*derx(ll,1,2)
10413 c        write (iout,'(a,3i3,a,5f8.3,2i3,a,5f8.3,a,f8.3)')
10414 c     &   "ecorr5",ll,i,j," derx",derx(ll,2,1),derx(ll,3,1),derx(ll,4,1),
10415 c     &   derx(ll,5,1),k,l," derx",derx(ll,2,2),derx(ll,3,2),
10416 c     &   derx(ll,4,2),derx(ll,5,2)," ekont",ekont
10417 c        write (iout,'(a,3i3,a,3f8.3,2i3,a,3f8.3)')
10418 c     &   "ecorr5",ll,i,j," gradcorr5",g_contij(ll,1),derx(ll,1,1),
10419 c     &   gradcorr5ij,
10420 c     &   k,l," gradcorr5",g_contij(ll,2),derx(ll,1,2),gradcorr5kl
10421 cold        ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
10422 cgrad        ghalf=0.5d0*ggg1(ll)
10423 cd        ghalf=0.0d0
10424         gradcorr5(ll,i)=gradcorr5(ll,i)+ekont*derx(ll,2,1)
10425         gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
10426         gradcorr5(ll,j)=gradcorr5(ll,j)+ekont*derx(ll,4,1)
10427         gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
10428         gradcorr5_long(ll,j)=gradcorr5_long(ll,j)+gradcorr5ij
10429         gradcorr5_long(ll,i)=gradcorr5_long(ll,i)-gradcorr5ij
10430 cold        ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
10431 cgrad        ghalf=0.5d0*ggg2(ll)
10432 cd        ghalf=0.0d0
10433         gradcorr5(ll,k)=gradcorr5(ll,k)+ekont*derx(ll,2,2)
10434         gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
10435         gradcorr5(ll,l)=gradcorr5(ll,l)+ekont*derx(ll,4,2)
10436         gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
10437         gradcorr5_long(ll,l)=gradcorr5_long(ll,l)+gradcorr5kl
10438         gradcorr5_long(ll,k)=gradcorr5_long(ll,k)-gradcorr5kl
10439       enddo
10440 cd      goto 1112
10441 cgrad      do m=i+1,j-1
10442 cgrad        do ll=1,3
10443 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
10444 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
10445 cgrad        enddo
10446 cgrad      enddo
10447 cgrad      do m=k+1,l-1
10448 cgrad        do ll=1,3
10449 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
10450 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
10451 cgrad        enddo
10452 cgrad      enddo
10453 c1112  continue
10454 cgrad      do m=i+2,j2
10455 cgrad        do ll=1,3
10456 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
10457 cgrad        enddo
10458 cgrad      enddo
10459 cgrad      do m=k+2,l2
10460 cgrad        do ll=1,3
10461 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
10462 cgrad        enddo
10463 cgrad      enddo
10464 cd      do iii=1,nres-3
10465 cd        write (2,*) iii,g_corr5_loc(iii)
10466 cd      enddo
10467       eello5=ekont*eel5
10468 cd      write (2,*) 'ekont',ekont
10469 cd      write (iout,*) 'eello5',ekont*eel5
10470       return
10471       end
10472 c--------------------------------------------------------------------------
10473       double precision function eello6(i,j,k,l,jj,kk)
10474       implicit real*8 (a-h,o-z)
10475       include 'DIMENSIONS'
10476       include 'COMMON.IOUNITS'
10477       include 'COMMON.CHAIN'
10478       include 'COMMON.DERIV'
10479       include 'COMMON.INTERACT'
10480       include 'COMMON.CONTACTS'
10481       include 'COMMON.CONTMAT'
10482       include 'COMMON.CORRMAT'
10483       include 'COMMON.TORSION'
10484       include 'COMMON.VAR'
10485       include 'COMMON.GEO'
10486       include 'COMMON.FFIELD'
10487       double precision ggg1(3),ggg2(3)
10488 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
10489 cd        eello6=0.0d0
10490 cd        return
10491 cd      endif
10492 cd      write (iout,*)
10493 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
10494 cd     &   ' and',k,l
10495       eello6_1=0.0d0
10496       eello6_2=0.0d0
10497       eello6_3=0.0d0
10498       eello6_4=0.0d0
10499       eello6_5=0.0d0
10500       eello6_6=0.0d0
10501 cd      call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
10502 cd     &   eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
10503       do iii=1,2
10504         do kkk=1,5
10505           do lll=1,3
10506             derx(lll,kkk,iii)=0.0d0
10507           enddo
10508         enddo
10509       enddo
10510 cd      eij=facont_hb(jj,i)
10511 cd      ekl=facont_hb(kk,k)
10512 cd      ekont=eij*ekl
10513 cd      eij=1.0d0
10514 cd      ekl=1.0d0
10515 cd      ekont=1.0d0
10516       if (l.eq.j+1) then
10517         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
10518         eello6_2=eello6_graph1(j,i,l,k,2,.false.)
10519         eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
10520         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
10521         eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
10522         eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
10523       else
10524         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
10525         eello6_2=eello6_graph1(l,k,j,i,2,.true.)
10526         eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
10527         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
10528         if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
10529           eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
10530         else
10531           eello6_5=0.0d0
10532         endif
10533         eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
10534       endif
10535 C If turn contributions are considered, they will be handled separately.
10536       eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
10537 cd      write(iout,*) 'eello6_1',eello6_1!,' eel6_1_num',16*eel6_1_num
10538 cd      write(iout,*) 'eello6_2',eello6_2!,' eel6_2_num',16*eel6_2_num
10539 cd      write(iout,*) 'eello6_3',eello6_3!,' eel6_3_num',16*eel6_3_num
10540 cd      write(iout,*) 'eello6_4',eello6_4!,' eel6_4_num',16*eel6_4_num
10541 cd      write(iout,*) 'eello6_5',eello6_5!,' eel6_5_num',16*eel6_5_num
10542 cd      write(iout,*) 'eello6_6',eello6_6!,' eel6_6_num',16*eel6_6_num
10543 cd      goto 1112
10544       if (j.lt.nres-1) then
10545         j1=j+1
10546         j2=j-1
10547       else
10548         j1=j-1
10549         j2=j-2
10550       endif
10551       if (l.lt.nres-1) then
10552         l1=l+1
10553         l2=l-1
10554       else
10555         l1=l-1
10556         l2=l-2
10557       endif
10558       do ll=1,3
10559 cgrad        ggg1(ll)=eel6*g_contij(ll,1)
10560 cgrad        ggg2(ll)=eel6*g_contij(ll,2)
10561 cold        ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
10562 cgrad        ghalf=0.5d0*ggg1(ll)
10563 cd        ghalf=0.0d0
10564         gradcorr6ij=eel6*g_contij(ll,1)+ekont*derx(ll,1,1)
10565         gradcorr6kl=eel6*g_contij(ll,2)+ekont*derx(ll,1,2)
10566         gradcorr6(ll,i)=gradcorr6(ll,i)+ekont*derx(ll,2,1)
10567         gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
10568         gradcorr6(ll,j)=gradcorr6(ll,j)+ekont*derx(ll,4,1)
10569         gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
10570         gradcorr6_long(ll,j)=gradcorr6_long(ll,j)+gradcorr6ij
10571         gradcorr6_long(ll,i)=gradcorr6_long(ll,i)-gradcorr6ij
10572 cgrad        ghalf=0.5d0*ggg2(ll)
10573 cold        ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
10574 cd        ghalf=0.0d0
10575         gradcorr6(ll,k)=gradcorr6(ll,k)+ekont*derx(ll,2,2)
10576         gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
10577         gradcorr6(ll,l)=gradcorr6(ll,l)+ekont*derx(ll,4,2)
10578         gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
10579         gradcorr6_long(ll,l)=gradcorr6_long(ll,l)+gradcorr6kl
10580         gradcorr6_long(ll,k)=gradcorr6_long(ll,k)-gradcorr6kl
10581       enddo
10582 cd      goto 1112
10583 cgrad      do m=i+1,j-1
10584 cgrad        do ll=1,3
10585 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
10586 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
10587 cgrad        enddo
10588 cgrad      enddo
10589 cgrad      do m=k+1,l-1
10590 cgrad        do ll=1,3
10591 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
10592 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
10593 cgrad        enddo
10594 cgrad      enddo
10595 cgrad1112  continue
10596 cgrad      do m=i+2,j2
10597 cgrad        do ll=1,3
10598 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
10599 cgrad        enddo
10600 cgrad      enddo
10601 cgrad      do m=k+2,l2
10602 cgrad        do ll=1,3
10603 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
10604 cgrad        enddo
10605 cgrad      enddo
10606 cd      do iii=1,nres-3
10607 cd        write (2,*) iii,g_corr6_loc(iii)
10608 cd      enddo
10609       eello6=ekont*eel6
10610 cd      write (2,*) 'ekont',ekont
10611 cd      write (iout,*) 'eello6',ekont*eel6
10612       return
10613       end
10614 c--------------------------------------------------------------------------
10615       double precision function eello6_graph1(i,j,k,l,imat,swap)
10616       implicit real*8 (a-h,o-z)
10617       include 'DIMENSIONS'
10618       include 'COMMON.IOUNITS'
10619       include 'COMMON.CHAIN'
10620       include 'COMMON.DERIV'
10621       include 'COMMON.INTERACT'
10622       include 'COMMON.CONTACTS'
10623       include 'COMMON.CONTMAT'
10624       include 'COMMON.CORRMAT'
10625       include 'COMMON.TORSION'
10626       include 'COMMON.VAR'
10627       include 'COMMON.GEO'
10628       double precision vv(2),vv1(2),pizda(2,2),auxmat(2,2),pizda1(2,2)
10629       logical swap
10630       logical lprn
10631       common /kutas/ lprn
10632 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10633 C                                                                              C
10634 C      Parallel       Antiparallel                                             C
10635 C                                                                              C
10636 C          o             o                                                     C
10637 C         /l\           /j\                                                    C
10638 C        /   \         /   \                                                   C
10639 C       /| o |         | o |\                                                  C
10640 C     \ j|/k\|  /   \  |/k\|l /                                                C
10641 C      \ /   \ /     \ /   \ /                                                 C
10642 C       o     o       o     o                                                  C
10643 C       i             i                                                        C
10644 C                                                                              C
10645 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10646       itk=itype2loc(itype(k))
10647       s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
10648       s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
10649       s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
10650       call transpose2(EUgC(1,1,k),auxmat(1,1))
10651       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
10652       vv1(1)=pizda1(1,1)-pizda1(2,2)
10653       vv1(2)=pizda1(1,2)+pizda1(2,1)
10654       s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
10655       vv(1)=AEAb1(1,2,imat)*b1(1,k)-AEAb1(2,2,imat)*b1(2,k)
10656       vv(2)=AEAb1(1,2,imat)*b1(2,k)+AEAb1(2,2,imat)*b1(1,k)
10657       s5=scalar2(vv(1),Dtobr2(1,i))
10658 cd      write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
10659       eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
10660       if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1)
10661      & -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i))
10662      & -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k))
10663      & +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k))
10664      & +0.5d0*scalar2(vv1(1),Dtobr2der(1,i))
10665      & +scalar2(vv(1),Dtobr2der(1,i)))
10666       call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
10667       vv1(1)=pizda1(1,1)-pizda1(2,2)
10668       vv1(2)=pizda1(1,2)+pizda1(2,1)
10669       vv(1)=AEAb1derg(1,2,imat)*b1(1,k)-AEAb1derg(2,2,imat)*b1(2,k)
10670       vv(2)=AEAb1derg(1,2,imat)*b1(2,k)+AEAb1derg(2,2,imat)*b1(1,k)
10671       if (l.eq.j+1) then
10672         g_corr6_loc(l-1)=g_corr6_loc(l-1)
10673      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
10674      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
10675      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
10676      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
10677       else
10678         g_corr6_loc(j-1)=g_corr6_loc(j-1)
10679      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
10680      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
10681      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
10682      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
10683       endif
10684       call transpose2(EUgCder(1,1,k),auxmat(1,1))
10685       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
10686       vv1(1)=pizda1(1,1)-pizda1(2,2)
10687       vv1(2)=pizda1(1,2)+pizda1(2,1)
10688       if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1)
10689      & +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k))
10690      & +scalar2(AEAb2(1,1,imat),CUgb2der(1,k))
10691      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
10692       do iii=1,2
10693         if (swap) then
10694           ind=3-iii
10695         else
10696           ind=iii
10697         endif
10698         do kkk=1,5
10699           do lll=1,3
10700             s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
10701             s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
10702             s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
10703             call transpose2(EUgC(1,1,k),auxmat(1,1))
10704             call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
10705      &        pizda1(1,1))
10706             vv1(1)=pizda1(1,1)-pizda1(2,2)
10707             vv1(2)=pizda1(1,2)+pizda1(2,1)
10708             s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
10709             vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,k)
10710      &       -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,k)
10711             vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,k)
10712      &       +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,k)
10713             s5=scalar2(vv(1),Dtobr2(1,i))
10714             derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
10715           enddo
10716         enddo
10717       enddo
10718       return
10719       end
10720 c----------------------------------------------------------------------------
10721       double precision function eello6_graph2(i,j,k,l,jj,kk,swap)
10722       implicit real*8 (a-h,o-z)
10723       include 'DIMENSIONS'
10724       include 'COMMON.IOUNITS'
10725       include 'COMMON.CHAIN'
10726       include 'COMMON.DERIV'
10727       include 'COMMON.INTERACT'
10728       include 'COMMON.CONTACTS'
10729       include 'COMMON.CONTMAT'
10730       include 'COMMON.CORRMAT'
10731       include 'COMMON.TORSION'
10732       include 'COMMON.VAR'
10733       include 'COMMON.GEO'
10734       logical swap
10735       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
10736      & auxvec1(2),auxvec2(2),auxmat1(2,2)
10737       logical lprn
10738       common /kutas/ lprn
10739 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10740 C                                                                              C
10741 C      Parallel       Antiparallel                                             C
10742 C                                                                              C
10743 C          o             o                                                     C
10744 C     \   /l\           /j\   /                                                C
10745 C      \ /   \         /   \ /                                                 C
10746 C       o| o |         | o |o                                                  C
10747 C     \ j|/k\|      \  |/k\|l                                                  C
10748 C      \ /   \       \ /   \                                                   C
10749 C       o             o                                                        C
10750 C       i             i                                                        C
10751 C                                                                              C
10752 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10753 cd      write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
10754 C AL 7/4/01 s1 would occur in the sixth-order moment,
10755 C           but not in a cluster cumulant
10756 #ifdef MOMENT
10757       s1=dip(1,jj,i)*dip(1,kk,k)
10758 #endif
10759       call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
10760       s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
10761       call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
10762       s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
10763       call transpose2(EUg(1,1,k),auxmat(1,1))
10764       call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
10765       vv(1)=pizda(1,1)-pizda(2,2)
10766       vv(2)=pizda(1,2)+pizda(2,1)
10767       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
10768 cd      write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
10769 #ifdef MOMENT
10770       eello6_graph2=-(s1+s2+s3+s4)
10771 #else
10772       eello6_graph2=-(s2+s3+s4)
10773 #endif
10774 c      eello6_graph2=-s3
10775 C Derivatives in gamma(i-1)
10776       if (i.gt.1) then
10777 #ifdef MOMENT
10778         s1=dipderg(1,jj,i)*dip(1,kk,k)
10779 #endif
10780         s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
10781         call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
10782         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
10783         s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
10784 #ifdef MOMENT
10785         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
10786 #else
10787         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
10788 #endif
10789 c        g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
10790       endif
10791 C Derivatives in gamma(k-1)
10792 #ifdef MOMENT
10793       s1=dip(1,jj,i)*dipderg(1,kk,k)
10794 #endif
10795       call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
10796       s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
10797       call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
10798       s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
10799       call transpose2(EUgder(1,1,k),auxmat1(1,1))
10800       call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
10801       vv(1)=pizda(1,1)-pizda(2,2)
10802       vv(2)=pizda(1,2)+pizda(2,1)
10803       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
10804 #ifdef MOMENT
10805       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
10806 #else
10807       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
10808 #endif
10809 c      g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
10810 C Derivatives in gamma(j-1) or gamma(l-1)
10811       if (j.gt.1) then
10812 #ifdef MOMENT
10813         s1=dipderg(3,jj,i)*dip(1,kk,k)
10814 #endif
10815         call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
10816         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
10817         s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
10818         call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
10819         vv(1)=pizda(1,1)-pizda(2,2)
10820         vv(2)=pizda(1,2)+pizda(2,1)
10821         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
10822 #ifdef MOMENT
10823         if (swap) then
10824           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
10825         else
10826           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
10827         endif
10828 #endif
10829         g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
10830 c        g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
10831       endif
10832 C Derivatives in gamma(l-1) or gamma(j-1)
10833       if (l.gt.1) then
10834 #ifdef MOMENT
10835         s1=dip(1,jj,i)*dipderg(3,kk,k)
10836 #endif
10837         call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
10838         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
10839         call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
10840         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
10841         call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
10842         vv(1)=pizda(1,1)-pizda(2,2)
10843         vv(2)=pizda(1,2)+pizda(2,1)
10844         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
10845 #ifdef MOMENT
10846         if (swap) then
10847           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
10848         else
10849           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
10850         endif
10851 #endif
10852         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
10853 c        g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
10854       endif
10855 C Cartesian derivatives.
10856       if (lprn) then
10857         write (2,*) 'In eello6_graph2'
10858         do iii=1,2
10859           write (2,*) 'iii=',iii
10860           do kkk=1,5
10861             write (2,*) 'kkk=',kkk
10862             do jjj=1,2
10863               write (2,'(3(2f10.5),5x)')
10864      &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
10865             enddo
10866           enddo
10867         enddo
10868       endif
10869       do iii=1,2
10870         do kkk=1,5
10871           do lll=1,3
10872 #ifdef MOMENT
10873             if (iii.eq.1) then
10874               s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
10875             else
10876               s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
10877             endif
10878 #endif
10879             call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),
10880      &        auxvec(1))
10881             s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
10882             call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),
10883      &        auxvec(1))
10884             s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
10885             call transpose2(EUg(1,1,k),auxmat(1,1))
10886             call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),
10887      &        pizda(1,1))
10888             vv(1)=pizda(1,1)-pizda(2,2)
10889             vv(2)=pizda(1,2)+pizda(2,1)
10890             s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
10891 cd            write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
10892 #ifdef MOMENT
10893             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
10894 #else
10895             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
10896 #endif
10897             if (swap) then
10898               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
10899             else
10900               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
10901             endif
10902           enddo
10903         enddo
10904       enddo
10905       return
10906       end
10907 c----------------------------------------------------------------------------
10908       double precision function eello6_graph3(i,j,k,l,jj,kk,swap)
10909       implicit real*8 (a-h,o-z)
10910       include 'DIMENSIONS'
10911       include 'COMMON.IOUNITS'
10912       include 'COMMON.CHAIN'
10913       include 'COMMON.DERIV'
10914       include 'COMMON.INTERACT'
10915       include 'COMMON.CONTACTS'
10916       include 'COMMON.CONTMAT'
10917       include 'COMMON.CORRMAT'
10918       include 'COMMON.TORSION'
10919       include 'COMMON.VAR'
10920       include 'COMMON.GEO'
10921       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2)
10922       logical swap
10923 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10924 C                                                                              C
10925 C      Parallel       Antiparallel                                             C
10926 C                                                                              C
10927 C          o             o                                                     C
10928 C         /l\   /   \   /j\                                                    C
10929 C        /   \ /     \ /   \                                                   C
10930 C       /| o |o       o| o |\                                                  C
10931 C       j|/k\|  /      |/k\|l /                                                C
10932 C        /   \ /       /   \ /                                                 C
10933 C       /     o       /     o                                                  C
10934 C       i             i                                                        C
10935 C                                                                              C
10936 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10937 C
10938 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
10939 C           energy moment and not to the cluster cumulant.
10940       iti=itortyp(itype(i))
10941       if (j.lt.nres-1) then
10942         itj1=itype2loc(itype(j+1))
10943       else
10944         itj1=nloctyp
10945       endif
10946       itk=itype2loc(itype(k))
10947       itk1=itype2loc(itype(k+1))
10948       if (l.lt.nres-1) then
10949         itl1=itype2loc(itype(l+1))
10950       else
10951         itl1=nloctyp
10952       endif
10953 #ifdef MOMENT
10954       s1=dip(4,jj,i)*dip(4,kk,k)
10955 #endif
10956       call matvec2(AECA(1,1,1),b1(1,k+1),auxvec(1))
10957       s2=0.5d0*scalar2(b1(1,k),auxvec(1))
10958       call matvec2(AECA(1,1,2),b1(1,l+1),auxvec(1))
10959       s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
10960       call transpose2(EE(1,1,k),auxmat(1,1))
10961       call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
10962       vv(1)=pizda(1,1)+pizda(2,2)
10963       vv(2)=pizda(2,1)-pizda(1,2)
10964       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
10965 cd      write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4,
10966 cd     & "sum",-(s2+s3+s4)
10967 #ifdef MOMENT
10968       eello6_graph3=-(s1+s2+s3+s4)
10969 #else
10970       eello6_graph3=-(s2+s3+s4)
10971 #endif
10972 c      eello6_graph3=-s4
10973 C Derivatives in gamma(k-1)
10974       call matvec2(AECAderg(1,1,2),b1(1,l+1),auxvec(1))
10975       s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
10976       s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
10977       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
10978 C Derivatives in gamma(l-1)
10979       call matvec2(AECAderg(1,1,1),b1(1,k+1),auxvec(1))
10980       s2=0.5d0*scalar2(b1(1,k),auxvec(1))
10981       call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
10982       vv(1)=pizda(1,1)+pizda(2,2)
10983       vv(2)=pizda(2,1)-pizda(1,2)
10984       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
10985       g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
10986 C Cartesian derivatives.
10987       do iii=1,2
10988         do kkk=1,5
10989           do lll=1,3
10990 #ifdef MOMENT
10991             if (iii.eq.1) then
10992               s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
10993             else
10994               s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
10995             endif
10996 #endif
10997             call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
10998      &        auxvec(1))
10999             s2=0.5d0*scalar2(b1(1,k),auxvec(1))
11000             call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,l+1),
11001      &        auxvec(1))
11002             s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
11003             call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),
11004      &        pizda(1,1))
11005             vv(1)=pizda(1,1)+pizda(2,2)
11006             vv(2)=pizda(2,1)-pizda(1,2)
11007             s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
11008 #ifdef MOMENT
11009             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
11010 #else
11011             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
11012 #endif
11013             if (swap) then
11014               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
11015             else
11016               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
11017             endif
11018 c            derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
11019           enddo
11020         enddo
11021       enddo
11022       return
11023       end
11024 c----------------------------------------------------------------------------
11025       double precision function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
11026       implicit real*8 (a-h,o-z)
11027       include 'DIMENSIONS'
11028       include 'COMMON.IOUNITS'
11029       include 'COMMON.CHAIN'
11030       include 'COMMON.DERIV'
11031       include 'COMMON.INTERACT'
11032       include 'COMMON.CONTACTS'
11033       include 'COMMON.CONTMAT'
11034       include 'COMMON.CORRMAT'
11035       include 'COMMON.TORSION'
11036       include 'COMMON.VAR'
11037       include 'COMMON.GEO'
11038       include 'COMMON.FFIELD'
11039       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
11040      & auxvec1(2),auxmat1(2,2)
11041       logical swap
11042 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
11043 C                                                                              C
11044 C      Parallel       Antiparallel                                             C
11045 C                                                                              C
11046 C          o             o                                                     C
11047 C         /l\   /   \   /j\                                                    C
11048 C        /   \ /     \ /   \                                                   C
11049 C       /| o |o       o| o |\                                                  C
11050 C     \ j|/k\|      \  |/k\|l                                                  C
11051 C      \ /   \       \ /   \                                                   C
11052 C       o     \       o     \                                                  C
11053 C       i             i                                                        C
11054 C                                                                              C
11055 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
11056 C
11057 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
11058 C           energy moment and not to the cluster cumulant.
11059 cd      write (2,*) 'eello_graph4: wturn6',wturn6
11060       iti=itype2loc(itype(i))
11061       itj=itype2loc(itype(j))
11062       if (j.lt.nres-1) then
11063         itj1=itype2loc(itype(j+1))
11064       else
11065         itj1=nloctyp
11066       endif
11067       itk=itype2loc(itype(k))
11068       if (k.lt.nres-1) then
11069         itk1=itype2loc(itype(k+1))
11070       else
11071         itk1=nloctyp
11072       endif
11073       itl=itype2loc(itype(l))
11074       if (l.lt.nres-1) then
11075         itl1=itype2loc(itype(l+1))
11076       else
11077         itl1=nloctyp
11078       endif
11079 cd      write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
11080 cd      write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
11081 cd     & ' itl',itl,' itl1',itl1
11082 #ifdef MOMENT
11083       if (imat.eq.1) then
11084         s1=dip(3,jj,i)*dip(3,kk,k)
11085       else
11086         s1=dip(2,jj,j)*dip(2,kk,l)
11087       endif
11088 #endif
11089       call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
11090       s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
11091       if (j.eq.l+1) then
11092         call matvec2(ADtEA1(1,1,3-imat),b1(1,j+1),auxvec1(1))
11093         s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
11094       else
11095         call matvec2(ADtEA1(1,1,3-imat),b1(1,l+1),auxvec1(1))
11096         s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
11097       endif
11098       call transpose2(EUg(1,1,k),auxmat(1,1))
11099       call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
11100       vv(1)=pizda(1,1)-pizda(2,2)
11101       vv(2)=pizda(2,1)+pizda(1,2)
11102       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
11103 cd      write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
11104 #ifdef MOMENT
11105       eello6_graph4=-(s1+s2+s3+s4)
11106 #else
11107       eello6_graph4=-(s2+s3+s4)
11108 #endif
11109 C Derivatives in gamma(i-1)
11110       if (i.gt.1) then
11111 #ifdef MOMENT
11112         if (imat.eq.1) then
11113           s1=dipderg(2,jj,i)*dip(3,kk,k)
11114         else
11115           s1=dipderg(4,jj,j)*dip(2,kk,l)
11116         endif
11117 #endif
11118         s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
11119         if (j.eq.l+1) then
11120           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,j+1),auxvec1(1))
11121           s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
11122         else
11123           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,l+1),auxvec1(1))
11124           s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
11125         endif
11126         s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
11127         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
11128 cd          write (2,*) 'turn6 derivatives'
11129 #ifdef MOMENT
11130           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
11131 #else
11132           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
11133 #endif
11134         else
11135 #ifdef MOMENT
11136           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
11137 #else
11138           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
11139 #endif
11140         endif
11141       endif
11142 C Derivatives in gamma(k-1)
11143 #ifdef MOMENT
11144       if (imat.eq.1) then
11145         s1=dip(3,jj,i)*dipderg(2,kk,k)
11146       else
11147         s1=dip(2,jj,j)*dipderg(4,kk,l)
11148       endif
11149 #endif
11150       call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
11151       s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
11152       if (j.eq.l+1) then
11153         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,j+1),auxvec1(1))
11154         s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
11155       else
11156         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,l+1),auxvec1(1))
11157         s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
11158       endif
11159       call transpose2(EUgder(1,1,k),auxmat1(1,1))
11160       call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
11161       vv(1)=pizda(1,1)-pizda(2,2)
11162       vv(2)=pizda(2,1)+pizda(1,2)
11163       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
11164       if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
11165 #ifdef MOMENT
11166         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
11167 #else
11168         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
11169 #endif
11170       else
11171 #ifdef MOMENT
11172         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
11173 #else
11174         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
11175 #endif
11176       endif
11177 C Derivatives in gamma(j-1) or gamma(l-1)
11178       if (l.eq.j+1 .and. l.gt.1) then
11179         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
11180         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
11181         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
11182         vv(1)=pizda(1,1)-pizda(2,2)
11183         vv(2)=pizda(2,1)+pizda(1,2)
11184         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
11185         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
11186       else if (j.gt.1) then
11187         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
11188         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
11189         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
11190         vv(1)=pizda(1,1)-pizda(2,2)
11191         vv(2)=pizda(2,1)+pizda(1,2)
11192         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
11193         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
11194           gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
11195         else
11196           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
11197         endif
11198       endif
11199 C Cartesian derivatives.
11200       do iii=1,2
11201         do kkk=1,5
11202           do lll=1,3
11203 #ifdef MOMENT
11204             if (iii.eq.1) then
11205               if (imat.eq.1) then
11206                 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
11207               else
11208                 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
11209               endif
11210             else
11211               if (imat.eq.1) then
11212                 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
11213               else
11214                 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
11215               endif
11216             endif
11217 #endif
11218             call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),
11219      &        auxvec(1))
11220             s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
11221             if (j.eq.l+1) then
11222               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
11223      &          b1(1,j+1),auxvec(1))
11224               s3=-0.5d0*scalar2(b1(1,j),auxvec(1))
11225             else
11226               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
11227      &          b1(1,l+1),auxvec(1))
11228               s3=-0.5d0*scalar2(b1(1,l),auxvec(1))
11229             endif
11230             call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
11231      &        pizda(1,1))
11232             vv(1)=pizda(1,1)-pizda(2,2)
11233             vv(2)=pizda(2,1)+pizda(1,2)
11234             s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
11235             if (swap) then
11236               if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
11237 #ifdef MOMENT
11238                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
11239      &             -(s1+s2+s4)
11240 #else
11241                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
11242      &             -(s2+s4)
11243 #endif
11244                 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
11245               else
11246 #ifdef MOMENT
11247                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
11248 #else
11249                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
11250 #endif
11251                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
11252               endif
11253             else
11254 #ifdef MOMENT
11255               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
11256 #else
11257               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
11258 #endif
11259               if (l.eq.j+1) then
11260                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
11261               else
11262                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
11263               endif
11264             endif
11265           enddo
11266         enddo
11267       enddo
11268       return
11269       end
11270 c----------------------------------------------------------------------------
11271       double precision function eello_turn6(i,jj,kk)
11272       implicit real*8 (a-h,o-z)
11273       include 'DIMENSIONS'
11274       include 'COMMON.IOUNITS'
11275       include 'COMMON.CHAIN'
11276       include 'COMMON.DERIV'
11277       include 'COMMON.INTERACT'
11278       include 'COMMON.CONTACTS'
11279       include 'COMMON.CONTMAT'
11280       include 'COMMON.CORRMAT'
11281       include 'COMMON.TORSION'
11282       include 'COMMON.VAR'
11283       include 'COMMON.GEO'
11284       double precision vtemp1(2),vtemp2(2),vtemp3(2),vtemp4(2),
11285      &  atemp(2,2),auxmat(2,2),achuj_temp(2,2),gtemp(2,2),gvec(2),
11286      &  ggg1(3),ggg2(3)
11287       double precision vtemp1d(2),vtemp2d(2),vtemp3d(2),vtemp4d(2),
11288      &  atempd(2,2),auxmatd(2,2),achuj_tempd(2,2),gtempd(2,2),gvecd(2)
11289 C 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
11290 C           the respective energy moment and not to the cluster cumulant.
11291       s1=0.0d0
11292       s8=0.0d0
11293       s13=0.0d0
11294 c
11295       eello_turn6=0.0d0
11296       j=i+4
11297       k=i+1
11298       l=i+3
11299       iti=itype2loc(itype(i))
11300       itk=itype2loc(itype(k))
11301       itk1=itype2loc(itype(k+1))
11302       itl=itype2loc(itype(l))
11303       itj=itype2loc(itype(j))
11304 cd      write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
11305 cd      write (2,*) 'i',i,' k',k,' j',j,' l',l
11306 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
11307 cd        eello6=0.0d0
11308 cd        return
11309 cd      endif
11310 cd      write (iout,*)
11311 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
11312 cd     &   ' and',k,l
11313 cd      call checkint_turn6(i,jj,kk,eel_turn6_num)
11314       do iii=1,2
11315         do kkk=1,5
11316           do lll=1,3
11317             derx_turn(lll,kkk,iii)=0.0d0
11318           enddo
11319         enddo
11320       enddo
11321 cd      eij=1.0d0
11322 cd      ekl=1.0d0
11323 cd      ekont=1.0d0
11324       eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
11325 cd      eello6_5=0.0d0
11326 cd      write (2,*) 'eello6_5',eello6_5
11327 #ifdef MOMENT
11328       call transpose2(AEA(1,1,1),auxmat(1,1))
11329       call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
11330       ss1=scalar2(Ub2(1,i+2),b1(1,l))
11331       s1 = (auxmat(1,1)+auxmat(2,2))*ss1
11332 #endif
11333       call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1(1))
11334       call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
11335       s2 = scalar2(b1(1,k),vtemp1(1))
11336 #ifdef MOMENT
11337       call transpose2(AEA(1,1,2),atemp(1,1))
11338       call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
11339       call matvec2(Ug2(1,1,i+2),dd(1,1,k+1),vtemp2(1))
11340       s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,l),vtemp2(1))
11341 #endif
11342       call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
11343       call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
11344       s12 = scalar2(Ub2(1,i+2),vtemp3(1))
11345 #ifdef MOMENT
11346       call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
11347       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
11348       call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
11349       call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
11350       ss13 = scalar2(b1(1,k),vtemp4(1))
11351       s13 = (gtemp(1,1)+gtemp(2,2))*ss13
11352 #endif
11353 c      write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
11354 c      s1=0.0d0
11355 c      s2=0.0d0
11356 c      s8=0.0d0
11357 c      s12=0.0d0
11358 c      s13=0.0d0
11359       eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
11360 C Derivatives in gamma(i+2)
11361       s1d =0.0d0
11362       s8d =0.0d0
11363 #ifdef MOMENT
11364       call transpose2(AEA(1,1,1),auxmatd(1,1))
11365       call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
11366       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
11367       call transpose2(AEAderg(1,1,2),atempd(1,1))
11368       call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
11369       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,l),vtemp2(1))
11370 #endif
11371       call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
11372       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
11373       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
11374 c      s1d=0.0d0
11375 c      s2d=0.0d0
11376 c      s8d=0.0d0
11377 c      s12d=0.0d0
11378 c      s13d=0.0d0
11379       gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
11380 C Derivatives in gamma(i+3)
11381 #ifdef MOMENT
11382       call transpose2(AEA(1,1,1),auxmatd(1,1))
11383       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
11384       ss1d=scalar2(Ub2der(1,i+2),b1(1,l))
11385       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
11386 #endif
11387       call matvec2(EUgder(1,1,i+2),b1(1,l),vtemp1d(1))
11388       call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
11389       s2d = scalar2(b1(1,k),vtemp1d(1))
11390 #ifdef MOMENT
11391       call matvec2(Ug2der(1,1,i+2),dd(1,1,k+1),vtemp2d(1))
11392       s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,l),vtemp2d(1))
11393 #endif
11394       s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
11395 #ifdef MOMENT
11396       call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
11397       call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
11398       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
11399 #endif
11400 c      s1d=0.0d0
11401 c      s2d=0.0d0
11402 c      s8d=0.0d0
11403 c      s12d=0.0d0
11404 c      s13d=0.0d0
11405 #ifdef MOMENT
11406       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
11407      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
11408 #else
11409       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
11410      &               -0.5d0*ekont*(s2d+s12d)
11411 #endif
11412 C Derivatives in gamma(i+4)
11413       call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
11414       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
11415       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
11416 #ifdef MOMENT
11417       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
11418       call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
11419       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
11420 #endif
11421 c      s1d=0.0d0
11422 c      s2d=0.0d0
11423 c      s8d=0.0d0
11424 C      s12d=0.0d0
11425 c      s13d=0.0d0
11426 #ifdef MOMENT
11427       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
11428 #else
11429       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
11430 #endif
11431 C Derivatives in gamma(i+5)
11432 #ifdef MOMENT
11433       call transpose2(AEAderg(1,1,1),auxmatd(1,1))
11434       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
11435       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
11436 #endif
11437       call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1d(1))
11438       call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
11439       s2d = scalar2(b1(1,k),vtemp1d(1))
11440 #ifdef MOMENT
11441       call transpose2(AEA(1,1,2),atempd(1,1))
11442       call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
11443       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,l),vtemp2(1))
11444 #endif
11445       call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
11446       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
11447 #ifdef MOMENT
11448       call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
11449       ss13d = scalar2(b1(1,k),vtemp4d(1))
11450       s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
11451 #endif
11452 c      s1d=0.0d0
11453 c      s2d=0.0d0
11454 c      s8d=0.0d0
11455 c      s12d=0.0d0
11456 c      s13d=0.0d0
11457 #ifdef MOMENT
11458       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
11459      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
11460 #else
11461       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
11462      &               -0.5d0*ekont*(s2d+s12d)
11463 #endif
11464 C Cartesian derivatives
11465       do iii=1,2
11466         do kkk=1,5
11467           do lll=1,3
11468 #ifdef MOMENT
11469             call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
11470             call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
11471             s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
11472 #endif
11473             call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1(1))
11474             call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),
11475      &          vtemp1d(1))
11476             s2d = scalar2(b1(1,k),vtemp1d(1))
11477 #ifdef MOMENT
11478             call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
11479             call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
11480             s8d = -(atempd(1,1)+atempd(2,2))*
11481      &           scalar2(cc(1,1,l),vtemp2(1))
11482 #endif
11483             call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),
11484      &           auxmatd(1,1))
11485             call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
11486             s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
11487 c      s1d=0.0d0
11488 c      s2d=0.0d0
11489 c      s8d=0.0d0
11490 c      s12d=0.0d0
11491 c      s13d=0.0d0
11492 #ifdef MOMENT
11493             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
11494      &        - 0.5d0*(s1d+s2d)
11495 #else
11496             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
11497      &        - 0.5d0*s2d
11498 #endif
11499 #ifdef MOMENT
11500             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
11501      &        - 0.5d0*(s8d+s12d)
11502 #else
11503             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
11504      &        - 0.5d0*s12d
11505 #endif
11506           enddo
11507         enddo
11508       enddo
11509 #ifdef MOMENT
11510       do kkk=1,5
11511         do lll=1,3
11512           call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),
11513      &      achuj_tempd(1,1))
11514           call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
11515           call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
11516           s13d=(gtempd(1,1)+gtempd(2,2))*ss13
11517           derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
11518           call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),
11519      &      vtemp4d(1))
11520           ss13d = scalar2(b1(1,k),vtemp4d(1))
11521           s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
11522           derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
11523         enddo
11524       enddo
11525 #endif
11526 cd      write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
11527 cd     &  16*eel_turn6_num
11528 cd      goto 1112
11529       if (j.lt.nres-1) then
11530         j1=j+1
11531         j2=j-1
11532       else
11533         j1=j-1
11534         j2=j-2
11535       endif
11536       if (l.lt.nres-1) then
11537         l1=l+1
11538         l2=l-1
11539       else
11540         l1=l-1
11541         l2=l-2
11542       endif
11543       do ll=1,3
11544 cgrad        ggg1(ll)=eel_turn6*g_contij(ll,1)
11545 cgrad        ggg2(ll)=eel_turn6*g_contij(ll,2)
11546 cgrad        ghalf=0.5d0*ggg1(ll)
11547 cd        ghalf=0.0d0
11548         gturn6ij=eel_turn6*g_contij(ll,1)+ekont*derx_turn(ll,1,1)
11549         gturn6kl=eel_turn6*g_contij(ll,2)+ekont*derx_turn(ll,1,2)
11550         gcorr6_turn(ll,i)=gcorr6_turn(ll,i)!+ghalf
11551      &    +ekont*derx_turn(ll,2,1)
11552         gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
11553         gcorr6_turn(ll,j)=gcorr6_turn(ll,j)!+ghalf
11554      &    +ekont*derx_turn(ll,4,1)
11555         gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
11556         gcorr6_turn_long(ll,j)=gcorr6_turn_long(ll,j)+gturn6ij
11557         gcorr6_turn_long(ll,i)=gcorr6_turn_long(ll,i)-gturn6ij
11558 cgrad        ghalf=0.5d0*ggg2(ll)
11559 cd        ghalf=0.0d0
11560         gcorr6_turn(ll,k)=gcorr6_turn(ll,k)!+ghalf
11561      &    +ekont*derx_turn(ll,2,2)
11562         gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
11563         gcorr6_turn(ll,l)=gcorr6_turn(ll,l)!+ghalf
11564      &    +ekont*derx_turn(ll,4,2)
11565         gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
11566         gcorr6_turn_long(ll,l)=gcorr6_turn_long(ll,l)+gturn6kl
11567         gcorr6_turn_long(ll,k)=gcorr6_turn_long(ll,k)-gturn6kl
11568       enddo
11569 cd      goto 1112
11570 cgrad      do m=i+1,j-1
11571 cgrad        do ll=1,3
11572 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
11573 cgrad        enddo
11574 cgrad      enddo
11575 cgrad      do m=k+1,l-1
11576 cgrad        do ll=1,3
11577 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
11578 cgrad        enddo
11579 cgrad      enddo
11580 cgrad1112  continue
11581 cgrad      do m=i+2,j2
11582 cgrad        do ll=1,3
11583 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
11584 cgrad        enddo
11585 cgrad      enddo
11586 cgrad      do m=k+2,l2
11587 cgrad        do ll=1,3
11588 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
11589 cgrad        enddo
11590 cgrad      enddo
11591 cd      do iii=1,nres-3
11592 cd        write (2,*) iii,g_corr6_loc(iii)
11593 cd      enddo
11594       eello_turn6=ekont*eel_turn6
11595 cd      write (2,*) 'ekont',ekont
11596 cd      write (2,*) 'eel_turn6',ekont*eel_turn6
11597       return
11598       end
11599 C-----------------------------------------------------------------------------
11600 #endif
11601       double precision function scalar(u,v)
11602 !DIR$ INLINEALWAYS scalar
11603 #ifndef OSF
11604 cDEC$ ATTRIBUTES FORCEINLINE::scalar
11605 #endif
11606       implicit none
11607       double precision u(3),v(3)
11608 cd      double precision sc
11609 cd      integer i
11610 cd      sc=0.0d0
11611 cd      do i=1,3
11612 cd        sc=sc+u(i)*v(i)
11613 cd      enddo
11614 cd      scalar=sc
11615
11616       scalar=u(1)*v(1)+u(2)*v(2)+u(3)*v(3)
11617       return
11618       end
11619 crc-------------------------------------------------
11620       SUBROUTINE MATVEC2(A1,V1,V2)
11621 !DIR$ INLINEALWAYS MATVEC2
11622 #ifndef OSF
11623 cDEC$ ATTRIBUTES FORCEINLINE::MATVEC2
11624 #endif
11625       implicit real*8 (a-h,o-z)
11626       include 'DIMENSIONS'
11627       DIMENSION A1(2,2),V1(2),V2(2)
11628 c      DO 1 I=1,2
11629 c        VI=0.0
11630 c        DO 3 K=1,2
11631 c    3     VI=VI+A1(I,K)*V1(K)
11632 c        Vaux(I)=VI
11633 c    1 CONTINUE
11634
11635       vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
11636       vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
11637
11638       v2(1)=vaux1
11639       v2(2)=vaux2
11640       END
11641 C---------------------------------------
11642       SUBROUTINE MATMAT2(A1,A2,A3)
11643 #ifndef OSF
11644 cDEC$ ATTRIBUTES FORCEINLINE::MATMAT2
11645 #endif
11646       implicit real*8 (a-h,o-z)
11647       include 'DIMENSIONS'
11648       DIMENSION A1(2,2),A2(2,2),A3(2,2)
11649 c      DIMENSION AI3(2,2)
11650 c        DO  J=1,2
11651 c          A3IJ=0.0
11652 c          DO K=1,2
11653 c           A3IJ=A3IJ+A1(I,K)*A2(K,J)
11654 c          enddo
11655 c          A3(I,J)=A3IJ
11656 c       enddo
11657 c      enddo
11658
11659       ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
11660       ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
11661       ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
11662       ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
11663
11664       A3(1,1)=AI3_11
11665       A3(2,1)=AI3_21
11666       A3(1,2)=AI3_12
11667       A3(2,2)=AI3_22
11668       END
11669
11670 c-------------------------------------------------------------------------
11671       double precision function scalar2(u,v)
11672 !DIR$ INLINEALWAYS scalar2
11673       implicit none
11674       double precision u(2),v(2)
11675       double precision sc
11676       integer i
11677       scalar2=u(1)*v(1)+u(2)*v(2)
11678       return
11679       end
11680
11681 C-----------------------------------------------------------------------------
11682
11683       subroutine transpose2(a,at)
11684 !DIR$ INLINEALWAYS transpose2
11685 #ifndef OSF
11686 cDEC$ ATTRIBUTES FORCEINLINE::transpose2
11687 #endif
11688       implicit none
11689       double precision a(2,2),at(2,2)
11690       at(1,1)=a(1,1)
11691       at(1,2)=a(2,1)
11692       at(2,1)=a(1,2)
11693       at(2,2)=a(2,2)
11694       return
11695       end
11696 c--------------------------------------------------------------------------
11697       subroutine transpose(n,a,at)
11698       implicit none
11699       integer n,i,j
11700       double precision a(n,n),at(n,n)
11701       do i=1,n
11702         do j=1,n
11703           at(j,i)=a(i,j)
11704         enddo
11705       enddo
11706       return
11707       end
11708 C---------------------------------------------------------------------------
11709       subroutine prodmat3(a1,a2,kk,transp,prod)
11710 !DIR$ INLINEALWAYS prodmat3
11711 #ifndef OSF
11712 cDEC$ ATTRIBUTES FORCEINLINE::prodmat3
11713 #endif
11714       implicit none
11715       integer i,j
11716       double precision a1(2,2),a2(2,2),a2t(2,2),kk(2,2),prod(2,2)
11717       logical transp
11718 crc      double precision auxmat(2,2),prod_(2,2)
11719
11720       if (transp) then
11721 crc        call transpose2(kk(1,1),auxmat(1,1))
11722 crc        call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
11723 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
11724
11725            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1)
11726      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
11727            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2)
11728      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
11729            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1)
11730      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
11731            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2)
11732      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
11733
11734       else
11735 crc        call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
11736 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
11737
11738            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1)
11739      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
11740            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2)
11741      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
11742            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1)
11743      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
11744            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2)
11745      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
11746
11747       endif
11748 c      call transpose2(a2(1,1),a2t(1,1))
11749
11750 crc      print *,transp
11751 crc      print *,((prod_(i,j),i=1,2),j=1,2)
11752 crc      print *,((prod(i,j),i=1,2),j=1,2)
11753
11754       return
11755       end
11756 CCC----------------------------------------------
11757       subroutine Eliptransfer(eliptran)
11758       implicit real*8 (a-h,o-z)
11759       include 'DIMENSIONS'
11760       include 'COMMON.GEO'
11761       include 'COMMON.VAR'
11762       include 'COMMON.LOCAL'
11763       include 'COMMON.CHAIN'
11764       include 'COMMON.DERIV'
11765       include 'COMMON.NAMES'
11766       include 'COMMON.INTERACT'
11767       include 'COMMON.IOUNITS'
11768       include 'COMMON.CALC'
11769       include 'COMMON.CONTROL'
11770       include 'COMMON.SPLITELE'
11771       include 'COMMON.SBRIDGE'
11772 C this is done by Adasko
11773 C      print *,"wchodze"
11774 C structure of box:
11775 C      water
11776 C--bordliptop-- buffore starts
11777 C--bufliptop--- here true lipid starts
11778 C      lipid
11779 C--buflipbot--- lipid ends buffore starts
11780 C--bordlipbot--buffore ends
11781       eliptran=0.0
11782       do i=ilip_start,ilip_end
11783 C       do i=1,1
11784         if (itype(i).eq.ntyp1) cycle
11785
11786         positi=(mod(((c(3,i)+c(3,i+1))/2.0d0),boxzsize))
11787         if (positi.le.0.0) positi=positi+boxzsize
11788 C        print *,i
11789 C first for peptide groups
11790 c for each residue check if it is in lipid or lipid water border area
11791        if ((positi.gt.bordlipbot)
11792      &.and.(positi.lt.bordliptop)) then
11793 C the energy transfer exist
11794         if (positi.lt.buflipbot) then
11795 C what fraction I am in
11796          fracinbuf=1.0d0-
11797      &        ((positi-bordlipbot)/lipbufthick)
11798 C lipbufthick is thickenes of lipid buffore
11799          sslip=sscalelip(fracinbuf)
11800          ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
11801          eliptran=eliptran+sslip*pepliptran
11802          gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
11803          gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
11804 C         gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
11805
11806 C        print *,"doing sccale for lower part"
11807 C         print *,i,sslip,fracinbuf,ssgradlip
11808         elseif (positi.gt.bufliptop) then
11809          fracinbuf=1.0d0-((bordliptop-positi)/lipbufthick)
11810          sslip=sscalelip(fracinbuf)
11811          ssgradlip=sscagradlip(fracinbuf)/lipbufthick
11812          eliptran=eliptran+sslip*pepliptran
11813          gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
11814          gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
11815 C         gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
11816 C          print *, "doing sscalefor top part"
11817 C         print *,i,sslip,fracinbuf,ssgradlip
11818         else
11819          eliptran=eliptran+pepliptran
11820 C         print *,"I am in true lipid"
11821         endif
11822 C       else
11823 C       eliptran=elpitran+0.0 ! I am in water
11824        endif
11825        enddo
11826 C       print *, "nic nie bylo w lipidzie?"
11827 C now multiply all by the peptide group transfer factor
11828 C       eliptran=eliptran*pepliptran
11829 C now the same for side chains
11830 CV       do i=1,1
11831        do i=ilip_start,ilip_end
11832         if (itype(i).eq.ntyp1) cycle
11833         positi=(mod(c(3,i+nres),boxzsize))
11834         if (positi.le.0) positi=positi+boxzsize
11835 C       print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop
11836 c for each residue check if it is in lipid or lipid water border area
11837 C       respos=mod(c(3,i+nres),boxzsize)
11838 C       print *,positi,bordlipbot,buflipbot
11839        if ((positi.gt.bordlipbot)
11840      & .and.(positi.lt.bordliptop)) then
11841 C the energy transfer exist
11842         if (positi.lt.buflipbot) then
11843          fracinbuf=1.0d0-
11844      &     ((positi-bordlipbot)/lipbufthick)
11845 C lipbufthick is thickenes of lipid buffore
11846          sslip=sscalelip(fracinbuf)
11847          ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
11848          eliptran=eliptran+sslip*liptranene(itype(i))
11849          gliptranx(3,i)=gliptranx(3,i)
11850      &+ssgradlip*liptranene(itype(i))
11851          gliptranc(3,i-1)= gliptranc(3,i-1)
11852      &+ssgradlip*liptranene(itype(i))
11853 C         print *,"doing sccale for lower part"
11854         elseif (positi.gt.bufliptop) then
11855          fracinbuf=1.0d0-
11856      &((bordliptop-positi)/lipbufthick)
11857          sslip=sscalelip(fracinbuf)
11858          ssgradlip=sscagradlip(fracinbuf)/lipbufthick
11859          eliptran=eliptran+sslip*liptranene(itype(i))
11860          gliptranx(3,i)=gliptranx(3,i)
11861      &+ssgradlip*liptranene(itype(i))
11862          gliptranc(3,i-1)= gliptranc(3,i-1)
11863      &+ssgradlip*liptranene(itype(i))
11864 C          print *, "doing sscalefor top part",sslip,fracinbuf
11865         else
11866          eliptran=eliptran+liptranene(itype(i))
11867 C         print *,"I am in true lipid"
11868         endif
11869         endif ! if in lipid or buffor
11870 C       else
11871 C       eliptran=elpitran+0.0 ! I am in water
11872        enddo
11873        return
11874        end
11875 C---------------------------------------------------------
11876 C AFM soubroutine for constant force
11877        subroutine AFMforce(Eafmforce)
11878        implicit real*8 (a-h,o-z)
11879       include 'DIMENSIONS'
11880       include 'COMMON.GEO'
11881       include 'COMMON.VAR'
11882       include 'COMMON.LOCAL'
11883       include 'COMMON.CHAIN'
11884       include 'COMMON.DERIV'
11885       include 'COMMON.NAMES'
11886       include 'COMMON.INTERACT'
11887       include 'COMMON.IOUNITS'
11888       include 'COMMON.CALC'
11889       include 'COMMON.CONTROL'
11890       include 'COMMON.SPLITELE'
11891       include 'COMMON.SBRIDGE'
11892       real*8 diffafm(3)
11893       dist=0.0d0
11894       Eafmforce=0.0d0
11895       do i=1,3
11896       diffafm(i)=c(i,afmend)-c(i,afmbeg)
11897       dist=dist+diffafm(i)**2
11898       enddo
11899       dist=dsqrt(dist)
11900       Eafmforce=-forceAFMconst*(dist-distafminit)
11901       do i=1,3
11902       gradafm(i,afmend-1)=-forceAFMconst*diffafm(i)/dist
11903       gradafm(i,afmbeg-1)=forceAFMconst*diffafm(i)/dist
11904       enddo
11905 C      print *,'AFM',Eafmforce
11906       return
11907       end
11908 C---------------------------------------------------------
11909 C AFM subroutine with pseudoconstant velocity
11910        subroutine AFMvel(Eafmforce)
11911        implicit real*8 (a-h,o-z)
11912       include 'DIMENSIONS'
11913       include 'COMMON.GEO'
11914       include 'COMMON.VAR'
11915       include 'COMMON.LOCAL'
11916       include 'COMMON.CHAIN'
11917       include 'COMMON.DERIV'
11918       include 'COMMON.NAMES'
11919       include 'COMMON.INTERACT'
11920       include 'COMMON.IOUNITS'
11921       include 'COMMON.CALC'
11922       include 'COMMON.CONTROL'
11923       include 'COMMON.SPLITELE'
11924       include 'COMMON.SBRIDGE'
11925       real*8 diffafm(3)
11926 C Only for check grad COMMENT if not used for checkgrad
11927 C      totT=3.0d0
11928 C--------------------------------------------------------
11929 C      print *,"wchodze"
11930       dist=0.0d0
11931       Eafmforce=0.0d0
11932       do i=1,3
11933       diffafm(i)=c(i,afmend)-c(i,afmbeg)
11934       dist=dist+diffafm(i)**2
11935       enddo
11936       dist=dsqrt(dist)
11937       Eafmforce=0.5d0*forceAFMconst
11938      & *(distafminit+totTafm*velAFMconst-dist)**2
11939 C      Eafmforce=-forceAFMconst*(dist-distafminit)
11940       do i=1,3
11941       gradafm(i,afmend-1)=-forceAFMconst*
11942      &(distafminit+totTafm*velAFMconst-dist)
11943      &*diffafm(i)/dist
11944       gradafm(i,afmbeg-1)=forceAFMconst*
11945      &(distafminit+totTafm*velAFMconst-dist)
11946      &*diffafm(i)/dist
11947       enddo
11948 C      print *,'AFM',Eafmforce,totTafm*velAFMconst,dist
11949       return
11950       end
11951 C-----------------------------------------------------------
11952 C first for shielding is setting of function of side-chains
11953        subroutine set_shield_fac
11954       implicit real*8 (a-h,o-z)
11955       include 'DIMENSIONS'
11956       include 'COMMON.CHAIN'
11957       include 'COMMON.DERIV'
11958       include 'COMMON.IOUNITS'
11959       include 'COMMON.SHIELD'
11960       include 'COMMON.INTERACT'
11961 C this is the squar root 77 devided by 81 the epislion in lipid (in protein)
11962       double precision div77_81/0.974996043d0/,
11963      &div4_81/0.2222222222d0/,sh_frac_dist_grad(3)
11964
11965 C the vector between center of side_chain and peptide group
11966        double precision pep_side(3),long,side_calf(3),
11967      &pept_group(3),costhet_grad(3),cosphi_grad_long(3),
11968      &cosphi_grad_loc(3),pep_side_norm(3),side_calf_norm(3)
11969 C the line belowe needs to be changed for FGPROC>1
11970       do i=1,nres-1
11971       if ((itype(i).eq.ntyp1).and.itype(i+1).eq.ntyp1) cycle
11972       ishield_list(i)=0
11973 Cif there two consequtive dummy atoms there is no peptide group between them
11974 C the line below has to be changed for FGPROC>1
11975       VolumeTotal=0.0
11976       do k=1,nres
11977        if ((itype(k).eq.ntyp1).or.(itype(k).eq.10)) cycle
11978        dist_pep_side=0.0
11979        dist_side_calf=0.0
11980        do j=1,3
11981 C first lets set vector conecting the ithe side-chain with kth side-chain
11982       pep_side(j)=c(j,k+nres)-(c(j,i)+c(j,i+1))/2.0d0
11983 C      pep_side(j)=2.0d0
11984 C and vector conecting the side-chain with its proper calfa
11985       side_calf(j)=c(j,k+nres)-c(j,k)
11986 C      side_calf(j)=2.0d0
11987       pept_group(j)=c(j,i)-c(j,i+1)
11988 C lets have their lenght
11989       dist_pep_side=pep_side(j)**2+dist_pep_side
11990       dist_side_calf=dist_side_calf+side_calf(j)**2
11991       dist_pept_group=dist_pept_group+pept_group(j)**2
11992       enddo
11993        dist_pep_side=dsqrt(dist_pep_side)
11994        dist_pept_group=dsqrt(dist_pept_group)
11995        dist_side_calf=dsqrt(dist_side_calf)
11996       do j=1,3
11997         pep_side_norm(j)=pep_side(j)/dist_pep_side
11998         side_calf_norm(j)=dist_side_calf
11999       enddo
12000 C now sscale fraction
12001        sh_frac_dist=-(dist_pep_side-rpp(1,1)-buff_shield)/buff_shield
12002 C       print *,buff_shield,"buff"
12003 C now sscale
12004         if (sh_frac_dist.le.0.0) cycle
12005 C If we reach here it means that this side chain reaches the shielding sphere
12006 C Lets add him to the list for gradient
12007         ishield_list(i)=ishield_list(i)+1
12008 C ishield_list is a list of non 0 side-chain that contribute to factor gradient
12009 C this list is essential otherwise problem would be O3
12010         shield_list(ishield_list(i),i)=k
12011 C Lets have the sscale value
12012         if (sh_frac_dist.gt.1.0) then
12013          scale_fac_dist=1.0d0
12014          do j=1,3
12015          sh_frac_dist_grad(j)=0.0d0
12016          enddo
12017         else
12018          scale_fac_dist=-sh_frac_dist*sh_frac_dist
12019      &                   *(2.0*sh_frac_dist-3.0d0)
12020          fac_help_scale=6.0*(sh_frac_dist-sh_frac_dist**2)
12021      &                  /dist_pep_side/buff_shield*0.5
12022 C remember for the final gradient multiply sh_frac_dist_grad(j)
12023 C for side_chain by factor -2 !
12024          do j=1,3
12025          sh_frac_dist_grad(j)=fac_help_scale*pep_side(j)
12026 C         print *,"jestem",scale_fac_dist,fac_help_scale,
12027 C     &                    sh_frac_dist_grad(j)
12028          enddo
12029         endif
12030 C        if ((i.eq.3).and.(k.eq.2)) then
12031 C        print *,i,sh_frac_dist,dist_pep,fac_help_scale,scale_fac_dist
12032 C     & ,"TU"
12033 C        endif
12034
12035 C this is what is now we have the distance scaling now volume...
12036       short=short_r_sidechain(itype(k))
12037       long=long_r_sidechain(itype(k))
12038       costhet=1.0d0/dsqrt(1.0+short**2/dist_pep_side**2)
12039 C now costhet_grad
12040 C       costhet=0.0d0
12041        costhet_fac=costhet**3*short**2*(-0.5)/dist_pep_side**4
12042 C       costhet_fac=0.0d0
12043        do j=1,3
12044          costhet_grad(j)=costhet_fac*pep_side(j)
12045        enddo
12046 C remember for the final gradient multiply costhet_grad(j)
12047 C for side_chain by factor -2 !
12048 C fac alfa is angle between CB_k,CA_k, CA_i,CA_i+1
12049 C pep_side0pept_group is vector multiplication
12050       pep_side0pept_group=0.0
12051       do j=1,3
12052       pep_side0pept_group=pep_side0pept_group+pep_side(j)*side_calf(j)
12053       enddo
12054       cosalfa=(pep_side0pept_group/
12055      & (dist_pep_side*dist_side_calf))
12056       fac_alfa_sin=1.0-cosalfa**2
12057       fac_alfa_sin=dsqrt(fac_alfa_sin)
12058       rkprim=fac_alfa_sin*(long-short)+short
12059 C now costhet_grad
12060        cosphi=1.0d0/dsqrt(1.0+rkprim**2/dist_pep_side**2)
12061        cosphi_fac=cosphi**3*rkprim**2*(-0.5)/dist_pep_side**4
12062
12063        do j=1,3
12064          cosphi_grad_long(j)=cosphi_fac*pep_side(j)
12065      &+cosphi**3*0.5/dist_pep_side**2*(-rkprim)
12066      &*(long-short)/fac_alfa_sin*cosalfa/
12067      &((dist_pep_side*dist_side_calf))*
12068      &((side_calf(j))-cosalfa*
12069      &((pep_side(j)/dist_pep_side)*dist_side_calf))
12070
12071         cosphi_grad_loc(j)=cosphi**3*0.5/dist_pep_side**2*(-rkprim)
12072      &*(long-short)/fac_alfa_sin*cosalfa
12073      &/((dist_pep_side*dist_side_calf))*
12074      &(pep_side(j)-
12075      &cosalfa*side_calf(j)/dist_side_calf*dist_pep_side)
12076        enddo
12077
12078       VofOverlap=VSolvSphere/2.0d0*(1.0-costhet)*(1.0-cosphi)
12079      &                    /VSolvSphere_div
12080      &                    *wshield
12081 C now the gradient...
12082 C grad_shield is gradient of Calfa for peptide groups
12083 C      write(iout,*) "shield_compon",i,k,VSolvSphere,scale_fac_dist,
12084 C     &               costhet,cosphi
12085 C       write(iout,*) "cosphi_compon",i,k,pep_side0pept_group,
12086 C     & dist_pep_side,dist_side_calf,c(1,k+nres),c(1,k),itype(k)
12087       do j=1,3
12088       grad_shield(j,i)=grad_shield(j,i)
12089 C gradient po skalowaniu
12090      &                +(sh_frac_dist_grad(j)
12091 C  gradient po costhet
12092      &-scale_fac_dist*costhet_grad(j)/(1.0-costhet)
12093      &-scale_fac_dist*(cosphi_grad_long(j))
12094      &/(1.0-cosphi) )*div77_81
12095      &*VofOverlap
12096 C grad_shield_side is Cbeta sidechain gradient
12097       grad_shield_side(j,ishield_list(i),i)=
12098      &        (sh_frac_dist_grad(j)*(-2.0d0)
12099      &       +scale_fac_dist*costhet_grad(j)*2.0d0/(1.0-costhet)
12100      &       +scale_fac_dist*(cosphi_grad_long(j))
12101      &        *2.0d0/(1.0-cosphi))
12102      &        *div77_81*VofOverlap
12103
12104        grad_shield_loc(j,ishield_list(i),i)=
12105      &   scale_fac_dist*cosphi_grad_loc(j)
12106      &        *2.0d0/(1.0-cosphi)
12107      &        *div77_81*VofOverlap
12108       enddo
12109       VolumeTotal=VolumeTotal+VofOverlap*scale_fac_dist
12110       enddo
12111       fac_shield(i)=VolumeTotal*div77_81+div4_81
12112 c      write(2,*) "TOTAL VOLUME",i,VolumeTotal,fac_shield(i)
12113       enddo
12114       return
12115       end
12116 C--------------------------------------------------------------------------
12117       double precision function tschebyshev(m,n,x,y)
12118       implicit none
12119       include "DIMENSIONS"
12120       integer i,m,n
12121       double precision x(n),y,yy(0:maxvar),aux
12122 c Tschebyshev polynomial. Note that the first term is omitted
12123 c m=0: the constant term is included
12124 c m=1: the constant term is not included
12125       yy(0)=1.0d0
12126       yy(1)=y
12127       do i=2,n
12128         yy(i)=2*yy(1)*yy(i-1)-yy(i-2)
12129       enddo
12130       aux=0.0d0
12131       do i=m,n
12132         aux=aux+x(i)*yy(i)
12133       enddo
12134       tschebyshev=aux
12135       return
12136       end
12137 C--------------------------------------------------------------------------
12138       double precision function gradtschebyshev(m,n,x,y)
12139       implicit none
12140       include "DIMENSIONS"
12141       integer i,m,n
12142       double precision x(n+1),y,yy(0:maxvar),aux
12143 c Tschebyshev polynomial. Note that the first term is omitted
12144 c m=0: the constant term is included
12145 c m=1: the constant term is not included
12146       yy(0)=1.0d0
12147       yy(1)=2.0d0*y
12148       do i=2,n
12149         yy(i)=2*y*yy(i-1)-yy(i-2)
12150       enddo
12151       aux=0.0d0
12152       do i=m,n
12153         aux=aux+x(i+1)*yy(i)*(i+1)
12154 C        print *, x(i+1),yy(i),i
12155       enddo
12156       gradtschebyshev=aux
12157       return
12158       end
12159 C------------------------------------------------------------------------
12160 C first for shielding is setting of function of side-chains
12161        subroutine set_shield_fac2
12162       implicit real*8 (a-h,o-z)
12163       include 'DIMENSIONS'
12164       include 'COMMON.CHAIN'
12165       include 'COMMON.DERIV'
12166       include 'COMMON.IOUNITS'
12167       include 'COMMON.SHIELD'
12168       include 'COMMON.INTERACT'
12169 C this is the squar root 77 devided by 81 the epislion in lipid (in protein)
12170       double precision div77_81/0.974996043d0/,
12171      &div4_81/0.2222222222d0/,sh_frac_dist_grad(3)
12172
12173 C the vector between center of side_chain and peptide group
12174        double precision pep_side(3),long,side_calf(3),
12175      &pept_group(3),costhet_grad(3),cosphi_grad_long(3),
12176      &cosphi_grad_loc(3),pep_side_norm(3),side_calf_norm(3)
12177 C the line belowe needs to be changed for FGPROC>1
12178       do i=1,nres-1
12179       if ((itype(i).eq.ntyp1).and.itype(i+1).eq.ntyp1) cycle
12180       ishield_list(i)=0
12181 Cif there two consequtive dummy atoms there is no peptide group between them
12182 C the line below has to be changed for FGPROC>1
12183       VolumeTotal=0.0
12184       do k=1,nres
12185        if ((itype(k).eq.ntyp1).or.(itype(k).eq.10)) cycle
12186        dist_pep_side=0.0
12187        dist_side_calf=0.0
12188        do j=1,3
12189 C first lets set vector conecting the ithe side-chain with kth side-chain
12190       pep_side(j)=c(j,k+nres)-(c(j,i)+c(j,i+1))/2.0d0
12191 C      pep_side(j)=2.0d0
12192 C and vector conecting the side-chain with its proper calfa
12193       side_calf(j)=c(j,k+nres)-c(j,k)
12194 C      side_calf(j)=2.0d0
12195       pept_group(j)=c(j,i)-c(j,i+1)
12196 C lets have their lenght
12197       dist_pep_side=pep_side(j)**2+dist_pep_side
12198       dist_side_calf=dist_side_calf+side_calf(j)**2
12199       dist_pept_group=dist_pept_group+pept_group(j)**2
12200       enddo
12201        dist_pep_side=dsqrt(dist_pep_side)
12202        dist_pept_group=dsqrt(dist_pept_group)
12203        dist_side_calf=dsqrt(dist_side_calf)
12204       do j=1,3
12205         pep_side_norm(j)=pep_side(j)/dist_pep_side
12206         side_calf_norm(j)=dist_side_calf
12207       enddo
12208 C now sscale fraction
12209        sh_frac_dist=-(dist_pep_side-rpp(1,1)-buff_shield)/buff_shield
12210 C       print *,buff_shield,"buff"
12211 C now sscale
12212         if (sh_frac_dist.le.0.0) cycle
12213 C If we reach here it means that this side chain reaches the shielding sphere
12214 C Lets add him to the list for gradient
12215         ishield_list(i)=ishield_list(i)+1
12216 C ishield_list is a list of non 0 side-chain that contribute to factor gradient
12217 C this list is essential otherwise problem would be O3
12218         shield_list(ishield_list(i),i)=k
12219 C Lets have the sscale value
12220         if (sh_frac_dist.gt.1.0) then
12221          scale_fac_dist=1.0d0
12222          do j=1,3
12223          sh_frac_dist_grad(j)=0.0d0
12224          enddo
12225         else
12226          scale_fac_dist=-sh_frac_dist*sh_frac_dist
12227      &                   *(2.0d0*sh_frac_dist-3.0d0)
12228          fac_help_scale=6.0d0*(sh_frac_dist-sh_frac_dist**2)
12229      &                  /dist_pep_side/buff_shield*0.5d0
12230 C remember for the final gradient multiply sh_frac_dist_grad(j)
12231 C for side_chain by factor -2 !
12232          do j=1,3
12233          sh_frac_dist_grad(j)=fac_help_scale*pep_side(j)
12234 C         sh_frac_dist_grad(j)=0.0d0
12235 C         scale_fac_dist=1.0d0
12236 C         print *,"jestem",scale_fac_dist,fac_help_scale,
12237 C     &                    sh_frac_dist_grad(j)
12238          enddo
12239         endif
12240 C this is what is now we have the distance scaling now volume...
12241       short=short_r_sidechain(itype(k))
12242       long=long_r_sidechain(itype(k))
12243       costhet=1.0d0/dsqrt(1.0d0+short**2/dist_pep_side**2)
12244       sinthet=short/dist_pep_side*costhet
12245 C now costhet_grad
12246 C       costhet=0.6d0
12247 C       sinthet=0.8
12248        costhet_fac=costhet**3*short**2*(-0.5d0)/dist_pep_side**4
12249 C       sinthet_fac=costhet**2*0.5d0*(short**3/dist_pep_side**4*costhet
12250 C     &             -short/dist_pep_side**2/costhet)
12251 C       costhet_fac=0.0d0
12252        do j=1,3
12253          costhet_grad(j)=costhet_fac*pep_side(j)
12254        enddo
12255 C remember for the final gradient multiply costhet_grad(j)
12256 C for side_chain by factor -2 !
12257 C fac alfa is angle between CB_k,CA_k, CA_i,CA_i+1
12258 C pep_side0pept_group is vector multiplication
12259       pep_side0pept_group=0.0d0
12260       do j=1,3
12261       pep_side0pept_group=pep_side0pept_group+pep_side(j)*side_calf(j)
12262       enddo
12263       cosalfa=(pep_side0pept_group/
12264      & (dist_pep_side*dist_side_calf))
12265       fac_alfa_sin=1.0d0-cosalfa**2
12266       fac_alfa_sin=dsqrt(fac_alfa_sin)
12267       rkprim=fac_alfa_sin*(long-short)+short
12268 C      rkprim=short
12269
12270 C now costhet_grad
12271        cosphi=1.0d0/dsqrt(1.0d0+rkprim**2/dist_pep_side**2)
12272 C       cosphi=0.6
12273        cosphi_fac=cosphi**3*rkprim**2*(-0.5d0)/dist_pep_side**4
12274        sinphi=rkprim/dist_pep_side/dsqrt(1.0d0+rkprim**2/
12275      &      dist_pep_side**2)
12276 C       sinphi=0.8
12277        do j=1,3
12278          cosphi_grad_long(j)=cosphi_fac*pep_side(j)
12279      &+cosphi**3*0.5d0/dist_pep_side**2*(-rkprim)
12280      &*(long-short)/fac_alfa_sin*cosalfa/
12281      &((dist_pep_side*dist_side_calf))*
12282      &((side_calf(j))-cosalfa*
12283      &((pep_side(j)/dist_pep_side)*dist_side_calf))
12284 C       cosphi_grad_long(j)=0.0d0
12285         cosphi_grad_loc(j)=cosphi**3*0.5d0/dist_pep_side**2*(-rkprim)
12286      &*(long-short)/fac_alfa_sin*cosalfa
12287      &/((dist_pep_side*dist_side_calf))*
12288      &(pep_side(j)-
12289      &cosalfa*side_calf(j)/dist_side_calf*dist_pep_side)
12290 C       cosphi_grad_loc(j)=0.0d0
12291        enddo
12292 C      print *,sinphi,sinthet
12293 c      write (iout,*) "VSolvSphere",VSolvSphere," VSolvSphere_div",
12294 c     &  VSolvSphere_div," sinphi",sinphi," sinthet",sinthet
12295       VofOverlap=VSolvSphere/2.0d0*(1.0d0-dsqrt(1.0d0-sinphi*sinthet))
12296      &                    /VSolvSphere_div
12297 C     &                    *wshield
12298 C now the gradient...
12299       do j=1,3
12300       grad_shield(j,i)=grad_shield(j,i)
12301 C gradient po skalowaniu
12302      &                +(sh_frac_dist_grad(j)*VofOverlap
12303 C  gradient po costhet
12304      &       +scale_fac_dist*VSolvSphere/VSolvSphere_div/4.0d0*
12305      &(1.0d0/(-dsqrt(1.0d0-sinphi*sinthet))*(
12306      &       sinphi/sinthet*costhet*costhet_grad(j)
12307      &      +sinthet/sinphi*cosphi*cosphi_grad_long(j)))
12308      & )*wshield
12309 C grad_shield_side is Cbeta sidechain gradient
12310       grad_shield_side(j,ishield_list(i),i)=
12311      &        (sh_frac_dist_grad(j)*(-2.0d0)
12312      &        *VofOverlap
12313      &       -scale_fac_dist*VSolvSphere/VSolvSphere_div/2.0d0*
12314      &(1.0d0/(-dsqrt(1.0d0-sinphi*sinthet))*(
12315      &       sinphi/sinthet*costhet*costhet_grad(j)
12316      &      +sinthet/sinphi*cosphi*cosphi_grad_long(j)))
12317      &       )*wshield
12318
12319        grad_shield_loc(j,ishield_list(i),i)=
12320      &       scale_fac_dist*VSolvSphere/VSolvSphere_div/2.0d0*
12321      &(1.0d0/(dsqrt(1.0d0-sinphi*sinthet))*(
12322      &       sinthet/sinphi*cosphi*cosphi_grad_loc(j)
12323      &        ))
12324      &        *wshield
12325       enddo
12326 c      write (iout,*) "VofOverlap",VofOverlap," scale_fac_dist",
12327 c     & scale_fac_dist
12328       VolumeTotal=VolumeTotal+VofOverlap*scale_fac_dist
12329       enddo
12330       fac_shield(i)=VolumeTotal*wshield+(1.0d0-wshield)
12331 c      write(2,*) "TOTAL VOLUME",i,VolumeTotal,fac_shield(i),
12332 c     &  " wshield",wshield
12333 c      write(2,*) "TU",rpp(1,1),short,long,buff_shield
12334       enddo
12335       return
12336       end
12337 C-----------------------------------------------------------------------
12338 C-----------------------------------------------------------
12339 C This subroutine is to mimic the histone like structure but as well can be
12340 C utilizet to nanostructures (infinit) small modification has to be used to
12341 C make it finite (z gradient at the ends has to be changes as well as the x,y
12342 C gradient has to be modified at the ends
12343 C The energy function is Kihara potential
12344 C E=4esp*((sigma/(r-r0))^12 - (sigma/(r-r0))^6)
12345 C 4eps is depth of well sigma is r_minimum r is distance from center of tube
12346 C and r0 is the excluded size of nanotube (can be set to 0 if we want just a
12347 C simple Kihara potential
12348       subroutine calctube(Etube)
12349        implicit real*8 (a-h,o-z)
12350       include 'DIMENSIONS'
12351       include 'COMMON.GEO'
12352       include 'COMMON.VAR'
12353       include 'COMMON.LOCAL'
12354       include 'COMMON.CHAIN'
12355       include 'COMMON.DERIV'
12356       include 'COMMON.NAMES'
12357       include 'COMMON.INTERACT'
12358       include 'COMMON.IOUNITS'
12359       include 'COMMON.CALC'
12360       include 'COMMON.CONTROL'
12361       include 'COMMON.SPLITELE'
12362       include 'COMMON.SBRIDGE'
12363       double precision tub_r,vectube(3),enetube(maxres*2)
12364       Etube=0.0d0
12365       do i=1,2*nres
12366         enetube(i)=0.0d0
12367       enddo
12368 C first we calculate the distance from tube center
12369 C first sugare-phosphate group for NARES this would be peptide group
12370 C for UNRES
12371       do i=1,nres
12372 C lets ommit dummy atoms for now
12373        if ((itype(i).eq.ntyp1).or.(itype(i+1).eq.ntyp1)) cycle
12374 C now calculate distance from center of tube and direction vectors
12375       vectube(1)=mod((c(1,i)+c(1,i+1))/2.0d0,boxxsize)
12376           if (vectube(1).lt.0) vectube(1)=vectube(1)+boxxsize
12377       vectube(2)=mod((c(2,i)+c(2,i+1))/2.0d0,boxxsize)
12378           if (vectube(2).lt.0) vectube(2)=vectube(2)+boxxsize
12379       vectube(1)=vectube(1)-tubecenter(1)
12380       vectube(2)=vectube(2)-tubecenter(2)
12381
12382 C      print *,"x",(c(1,i)+c(1,i+1))/2.0d0,tubecenter(1)
12383 C      print *,"y",(c(2,i)+c(2,i+1))/2.0d0,tubecenter(2)
12384
12385 C as the tube is infinity we do not calculate the Z-vector use of Z
12386 C as chosen axis
12387       vectube(3)=0.0d0
12388 C now calculte the distance
12389        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
12390 C now normalize vector
12391       vectube(1)=vectube(1)/tub_r
12392       vectube(2)=vectube(2)/tub_r
12393 C calculte rdiffrence between r and r0
12394       rdiff=tub_r-tubeR0
12395 C and its 6 power
12396       rdiff6=rdiff**6.0d0
12397 C for vectorization reasons we will sumup at the end to avoid depenence of previous
12398        enetube(i)=pep_aa_tube/rdiff6**2.0d0-pep_bb_tube/rdiff6
12399 C       write(iout,*) "TU13",i,rdiff6,enetube(i)
12400 C       print *,rdiff,rdiff6,pep_aa_tube
12401 C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
12402 C now we calculate gradient
12403        fac=(-12.0d0*pep_aa_tube/rdiff6+
12404      &       6.0d0*pep_bb_tube)/rdiff6/rdiff
12405 C       write(iout,'(a5,i4,f12.1,3f12.5)') "TU13",i,rdiff6,enetube(i),
12406 C     &rdiff,fac
12407
12408 C now direction of gg_tube vector
12409         do j=1,3
12410         gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac/2.0d0
12411         gg_tube(j,i)=gg_tube(j,i)+vectube(j)*fac/2.0d0
12412         enddo
12413         enddo
12414 C basically thats all code now we split for side-chains (REMEMBER to sum up at the END)
12415         do i=1,nres
12416 C Lets not jump over memory as we use many times iti
12417          iti=itype(i)
12418 C lets ommit dummy atoms for now
12419          if ((iti.eq.ntyp1)
12420 C in UNRES uncomment the line below as GLY has no side-chain...
12421 C      .or.(iti.eq.10)
12422      &   ) cycle
12423           vectube(1)=c(1,i+nres)
12424           vectube(1)=mod(vectube(1),boxxsize)
12425           if (vectube(1).lt.0) vectube(1)=vectube(1)+boxxsize
12426           vectube(2)=c(2,i+nres)
12427           vectube(2)=mod(vectube(2),boxxsize)
12428           if (vectube(2).lt.0) vectube(2)=vectube(2)+boxxsize
12429
12430       vectube(1)=vectube(1)-tubecenter(1)
12431       vectube(2)=vectube(2)-tubecenter(2)
12432
12433 C as the tube is infinity we do not calculate the Z-vector use of Z
12434 C as chosen axis
12435       vectube(3)=0.0d0
12436 C now calculte the distance
12437        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
12438 C now normalize vector
12439       vectube(1)=vectube(1)/tub_r
12440       vectube(2)=vectube(2)/tub_r
12441 C calculte rdiffrence between r and r0
12442       rdiff=tub_r-tubeR0
12443 C and its 6 power
12444       rdiff6=rdiff**6.0d0
12445 C for vectorization reasons we will sumup at the end to avoid depenence of previous
12446        sc_aa_tube=sc_aa_tube_par(iti)
12447        sc_bb_tube=sc_bb_tube_par(iti)
12448        enetube(i+nres)=sc_aa_tube/rdiff6**2.0d0-sc_bb_tube/rdiff6
12449 C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
12450 C now we calculate gradient
12451        fac=-12.0d0*sc_aa_tube/rdiff6**2.0d0/rdiff+
12452      &       6.0d0*sc_bb_tube/rdiff6/rdiff
12453 C now direction of gg_tube vector
12454          do j=1,3
12455           gg_tube_SC(j,i)=gg_tube_SC(j,i)+vectube(j)*fac
12456           gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac
12457          enddo
12458         enddo
12459         do i=1,2*nres
12460           Etube=Etube+enetube(i)
12461         enddo
12462 C        print *,"ETUBE", etube
12463         return
12464         end
12465 C TO DO 1) add to total energy
12466 C       2) add to gradient summation
12467 C       3) add reading parameters (AND of course oppening of PARAM file)
12468 C       4) add reading the center of tube
12469 C       5) add COMMONs
12470 C       6) add to zerograd
12471
12472 C-----------------------------------------------------------------------
12473 C-----------------------------------------------------------
12474 C This subroutine is to mimic the histone like structure but as well can be
12475 C utilizet to nanostructures (infinit) small modification has to be used to
12476 C make it finite (z gradient at the ends has to be changes as well as the x,y
12477 C gradient has to be modified at the ends
12478 C The energy function is Kihara potential
12479 C E=4esp*((sigma/(r-r0))^12 - (sigma/(r-r0))^6)
12480 C 4eps is depth of well sigma is r_minimum r is distance from center of tube
12481 C and r0 is the excluded size of nanotube (can be set to 0 if we want just a
12482 C simple Kihara potential
12483       subroutine calctube2(Etube)
12484        implicit real*8 (a-h,o-z)
12485       include 'DIMENSIONS'
12486       include 'COMMON.GEO'
12487       include 'COMMON.VAR'
12488       include 'COMMON.LOCAL'
12489       include 'COMMON.CHAIN'
12490       include 'COMMON.DERIV'
12491       include 'COMMON.NAMES'
12492       include 'COMMON.INTERACT'
12493       include 'COMMON.IOUNITS'
12494       include 'COMMON.CALC'
12495       include 'COMMON.CONTROL'
12496       include 'COMMON.SPLITELE'
12497       include 'COMMON.SBRIDGE'
12498       double precision tub_r,vectube(3),enetube(maxres*2)
12499       Etube=0.0d0
12500       do i=1,2*nres
12501         enetube(i)=0.0d0
12502       enddo
12503 C first we calculate the distance from tube center
12504 C first sugare-phosphate group for NARES this would be peptide group
12505 C for UNRES
12506       do i=1,nres
12507 C lets ommit dummy atoms for now
12508        if ((itype(i).eq.ntyp1).or.(itype(i+1).eq.ntyp1)) cycle
12509 C now calculate distance from center of tube and direction vectors
12510       vectube(1)=mod((c(1,i)+c(1,i+1))/2.0d0,boxxsize)
12511           if (vectube(1).lt.0) vectube(1)=vectube(1)+boxxsize
12512       vectube(2)=mod((c(2,i)+c(2,i+1))/2.0d0,boxxsize)
12513           if (vectube(2).lt.0) vectube(2)=vectube(2)+boxxsize
12514       vectube(1)=vectube(1)-tubecenter(1)
12515       vectube(2)=vectube(2)-tubecenter(2)
12516
12517 C      print *,"x",(c(1,i)+c(1,i+1))/2.0d0,tubecenter(1)
12518 C      print *,"y",(c(2,i)+c(2,i+1))/2.0d0,tubecenter(2)
12519
12520 C as the tube is infinity we do not calculate the Z-vector use of Z
12521 C as chosen axis
12522       vectube(3)=0.0d0
12523 C now calculte the distance
12524        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
12525 C now normalize vector
12526       vectube(1)=vectube(1)/tub_r
12527       vectube(2)=vectube(2)/tub_r
12528 C calculte rdiffrence between r and r0
12529       rdiff=tub_r-tubeR0
12530 C and its 6 power
12531       rdiff6=rdiff**6.0d0
12532 C for vectorization reasons we will sumup at the end to avoid depenence of previous
12533        enetube(i)=pep_aa_tube/rdiff6**2.0d0-pep_bb_tube/rdiff6
12534 C       write(iout,*) "TU13",i,rdiff6,enetube(i)
12535 C       print *,rdiff,rdiff6,pep_aa_tube
12536 C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
12537 C now we calculate gradient
12538        fac=(-12.0d0*pep_aa_tube/rdiff6+
12539      &       6.0d0*pep_bb_tube)/rdiff6/rdiff
12540 C       write(iout,'(a5,i4,f12.1,3f12.5)') "TU13",i,rdiff6,enetube(i),
12541 C     &rdiff,fac
12542
12543 C now direction of gg_tube vector
12544         do j=1,3
12545         gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac/2.0d0
12546         gg_tube(j,i)=gg_tube(j,i)+vectube(j)*fac/2.0d0
12547         enddo
12548         enddo
12549 C basically thats all code now we split for side-chains (REMEMBER to sum up at the END)
12550         do i=1,nres
12551 C Lets not jump over memory as we use many times iti
12552          iti=itype(i)
12553 C lets ommit dummy atoms for now
12554          if ((iti.eq.ntyp1)
12555 C in UNRES uncomment the line below as GLY has no side-chain...
12556      &      .or.(iti.eq.10)
12557      &   ) cycle
12558           vectube(1)=c(1,i+nres)
12559           vectube(1)=mod(vectube(1),boxxsize)
12560           if (vectube(1).lt.0) vectube(1)=vectube(1)+boxxsize
12561           vectube(2)=c(2,i+nres)
12562           vectube(2)=mod(vectube(2),boxxsize)
12563           if (vectube(2).lt.0) vectube(2)=vectube(2)+boxxsize
12564
12565       vectube(1)=vectube(1)-tubecenter(1)
12566       vectube(2)=vectube(2)-tubecenter(2)
12567 C THIS FRAGMENT MAKES TUBE FINITE
12568         positi=(mod(c(3,i+nres),boxzsize))
12569         if (positi.le.0) positi=positi+boxzsize
12570 C       print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop
12571 c for each residue check if it is in lipid or lipid water border area
12572 C       respos=mod(c(3,i+nres),boxzsize)
12573        print *,positi,bordtubebot,buftubebot,bordtubetop
12574        if ((positi.gt.bordtubebot)
12575      & .and.(positi.lt.bordtubetop)) then
12576 C the energy transfer exist
12577         if (positi.lt.buftubebot) then
12578          fracinbuf=1.0d0-
12579      &     ((positi-bordtubebot)/tubebufthick)
12580 C lipbufthick is thickenes of lipid buffore
12581          sstube=sscalelip(fracinbuf)
12582          ssgradtube=-sscagradlip(fracinbuf)/tubebufthick
12583          print *,ssgradtube, sstube,tubetranene(itype(i))
12584          enetube(i+nres)=enetube(i+nres)+sstube*tubetranene(itype(i))
12585          gg_tube_SC(3,i)=gg_tube_SC(3,i)
12586      &+ssgradtube*tubetranene(itype(i))
12587          gg_tube(3,i-1)= gg_tube(3,i-1)
12588      &+ssgradtube*tubetranene(itype(i))
12589 C         print *,"doing sccale for lower part"
12590         elseif (positi.gt.buftubetop) then
12591          fracinbuf=1.0d0-
12592      &((bordtubetop-positi)/tubebufthick)
12593          sstube=sscalelip(fracinbuf)
12594          ssgradtube=sscagradlip(fracinbuf)/tubebufthick
12595          enetube(i+nres)=enetube(i+nres)+sstube*tubetranene(itype(i))
12596 C         gg_tube_SC(3,i)=gg_tube_SC(3,i)
12597 C     &+ssgradtube*tubetranene(itype(i))
12598 C         gg_tube(3,i-1)= gg_tube(3,i-1)
12599 C     &+ssgradtube*tubetranene(itype(i))
12600 C          print *, "doing sscalefor top part",sslip,fracinbuf
12601         else
12602          sstube=1.0d0
12603          ssgradtube=0.0d0
12604          enetube(i+nres)=enetube(i+nres)+sstube*tubetranene(itype(i))
12605 C         print *,"I am in true lipid"
12606         endif
12607         else
12608 C          sstube=0.0d0
12609 C          ssgradtube=0.0d0
12610         cycle
12611         endif ! if in lipid or buffor
12612 CEND OF FINITE FRAGMENT
12613 C as the tube is infinity we do not calculate the Z-vector use of Z
12614 C as chosen axis
12615       vectube(3)=0.0d0
12616 C now calculte the distance
12617        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
12618 C now normalize vector
12619       vectube(1)=vectube(1)/tub_r
12620       vectube(2)=vectube(2)/tub_r
12621 C calculte rdiffrence between r and r0
12622       rdiff=tub_r-tubeR0
12623 C and its 6 power
12624       rdiff6=rdiff**6.0d0
12625 C for vectorization reasons we will sumup at the end to avoid depenence of previous
12626        sc_aa_tube=sc_aa_tube_par(iti)
12627        sc_bb_tube=sc_bb_tube_par(iti)
12628        enetube(i+nres)=(sc_aa_tube/rdiff6**2.0d0-sc_bb_tube/rdiff6)
12629      &                 *sstube+enetube(i+nres)
12630 C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
12631 C now we calculate gradient
12632        fac=(-12.0d0*sc_aa_tube/rdiff6**2.0d0/rdiff+
12633      &       6.0d0*sc_bb_tube/rdiff6/rdiff)*sstube
12634 C now direction of gg_tube vector
12635          do j=1,3
12636           gg_tube_SC(j,i)=gg_tube_SC(j,i)+vectube(j)*fac
12637           gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac
12638          enddo
12639          gg_tube_SC(3,i)=gg_tube_SC(3,i)
12640      &+ssgradtube*enetube(i+nres)/sstube
12641          gg_tube(3,i-1)= gg_tube(3,i-1)
12642      &+ssgradtube*enetube(i+nres)/sstube
12643
12644         enddo
12645         do i=1,2*nres
12646           Etube=Etube+enetube(i)
12647         enddo
12648 C        print *,"ETUBE", etube
12649         return
12650         end
12651 C TO DO 1) add to total energy
12652 C       2) add to gradient summation
12653 C       3) add reading parameters (AND of course oppening of PARAM file)
12654 C       4) add reading the center of tube
12655 C       5) add COMMONs
12656 C       6) add to zerograd
12657 c----------------------------------------------------------------------------
12658       subroutine e_saxs(Esaxs_constr)
12659       implicit none
12660       include 'DIMENSIONS'
12661 #ifdef MPI
12662       include "mpif.h"
12663       include "COMMON.SETUP"
12664       integer IERR
12665 #endif
12666       include 'COMMON.SBRIDGE'
12667       include 'COMMON.CHAIN'
12668       include 'COMMON.GEO'
12669       include 'COMMON.DERIV'
12670       include 'COMMON.LOCAL'
12671       include 'COMMON.INTERACT'
12672       include 'COMMON.VAR'
12673       include 'COMMON.IOUNITS'
12674 c      include 'COMMON.MD'
12675 #ifdef LANG0
12676 #ifdef FIVEDIAG
12677       include 'COMMON.LANGEVIN.lang0.5diag'
12678 #else
12679       include 'COMMON.LANGEVIN.lang0'
12680 #endif
12681 #else
12682       include 'COMMON.LANGEVIN'
12683 #endif
12684       include 'COMMON.CONTROL'
12685       include 'COMMON.SAXS'
12686       include 'COMMON.NAMES'
12687       include 'COMMON.TIME1'
12688       include 'COMMON.FFIELD'
12689 c
12690       double precision Esaxs_constr
12691       integer i,iint,j,k,l
12692       double precision PgradC(maxSAXS,3,maxres),
12693      &  PgradX(maxSAXS,3,maxres),Pcalc(maxSAXS)
12694 #ifdef MPI
12695       double precision PgradC_(maxSAXS,3,maxres),
12696      &  PgradX_(maxSAXS,3,maxres),Pcalc_(maxSAXS)
12697 #endif
12698       double precision dk,dijCACA,dijCASC,dijSCCA,dijSCSC,
12699      & sigma2CACA,sigma2CASC,sigma2SCCA,sigma2SCSC,expCACA,expCASC,
12700      & expSCCA,expSCSC,CASCgrad,SCCAgrad,SCSCgrad,aux,auxC,auxC1,
12701      & auxX,auxX1,CACAgrad,Cnorm,sigmaCACA,threesig
12702       double precision sss2,ssgrad2,rrr,sscalgrad2,sscale2
12703       double precision dist,mygauss,mygaussder
12704       external dist
12705       integer llicz,lllicz
12706       double precision time01
12707 c  SAXS restraint penalty function
12708 #ifdef DEBUG
12709       write(iout,*) "------- SAXS penalty function start -------"
12710       write (iout,*) "nsaxs",nsaxs
12711       write (iout,*) "Esaxs: iatsc_s",iatsc_s," iatsc_e",iatsc_e
12712       write (iout,*) "Psaxs"
12713       do i=1,nsaxs
12714         write (iout,'(i5,e15.5)') i, Psaxs(i)
12715       enddo
12716 #endif
12717 #ifdef TIMING
12718       time01=MPI_Wtime()
12719 #endif
12720       Esaxs_constr = 0.0d0
12721       do k=1,nsaxs
12722         Pcalc(k)=0.0d0
12723         do j=1,nres
12724           do l=1,3
12725             PgradC(k,l,j)=0.0d0
12726             PgradX(k,l,j)=0.0d0
12727           enddo
12728         enddo
12729       enddo
12730 c      lllicz=0
12731       do i=iatsc_s,iatsc_e
12732        if (itype(i).eq.ntyp1) cycle
12733        do iint=1,nint_gr(i)
12734          do j=istart(i,iint),iend(i,iint)
12735            if (itype(j).eq.ntyp1) cycle
12736 #ifdef ALLSAXS
12737            dijCACA=dist(i,j)
12738            dijCASC=dist(i,j+nres)
12739            dijSCCA=dist(i+nres,j)
12740            dijSCSC=dist(i+nres,j+nres)
12741            sigma2CACA=2.0d0/(pstok**2)
12742            sigma2CASC=4.0d0/(pstok**2+restok(itype(j))**2)
12743            sigma2SCCA=4.0d0/(pstok**2+restok(itype(i))**2)
12744            sigma2SCSC=4.0d0/(restok(itype(j))**2+restok(itype(i))**2)
12745            do k=1,nsaxs
12746              dk = distsaxs(k)
12747              expCACA = dexp(-0.5d0*sigma2CACA*(dijCACA-dk)**2)
12748              if (itype(j).ne.10) then
12749              expCASC = dexp(-0.5d0*sigma2CASC*(dijCASC-dk)**2)
12750              else
12751              endif
12752              expCASC = 0.0d0
12753              if (itype(i).ne.10) then
12754              expSCCA = dexp(-0.5d0*sigma2SCCA*(dijSCCA-dk)**2)
12755              else
12756              expSCCA = 0.0d0
12757              endif
12758              if (itype(i).ne.10 .and. itype(j).ne.10) then
12759              expSCSC = dexp(-0.5d0*sigma2SCSC*(dijSCSC-dk)**2)
12760              else
12761              expSCSC = 0.0d0
12762              endif
12763              Pcalc(k) = Pcalc(k)+expCACA+expCASC+expSCCA+expSCSC
12764 #ifdef DEBUG
12765              write(iout,*) "i j k Pcalc",i,j,Pcalc(k)
12766 #endif
12767              CACAgrad = sigma2CACA*(dijCACA-dk)*expCACA
12768              CASCgrad = sigma2CASC*(dijCASC-dk)*expCASC
12769              SCCAgrad = sigma2SCCA*(dijSCCA-dk)*expSCCA
12770              SCSCgrad = sigma2SCSC*(dijSCSC-dk)*expSCSC
12771              do l=1,3
12772 c CA CA
12773                aux = CACAgrad*(C(l,j)-C(l,i))/dijCACA
12774                PgradC(k,l,i) = PgradC(k,l,i)-aux
12775                PgradC(k,l,j) = PgradC(k,l,j)+aux
12776 c CA SC
12777                if (itype(j).ne.10) then
12778                aux = CASCgrad*(C(l,j+nres)-C(l,i))/dijCASC
12779                PgradC(k,l,i) = PgradC(k,l,i)-aux
12780                PgradC(k,l,j) = PgradC(k,l,j)+aux
12781                PgradX(k,l,j) = PgradX(k,l,j)+aux
12782                endif
12783 c SC CA
12784                if (itype(i).ne.10) then
12785                aux = SCCAgrad*(C(l,j)-C(l,i+nres))/dijSCCA
12786                PgradX(k,l,i) = PgradX(k,l,i)-aux
12787                PgradC(k,l,i) = PgradC(k,l,i)-aux
12788                PgradC(k,l,j) = PgradC(k,l,j)+aux
12789                endif
12790 c SC SC
12791                if (itype(i).ne.10 .and. itype(j).ne.10) then
12792                aux = SCSCgrad*(C(l,j+nres)-C(l,i+nres))/dijSCSC
12793                PgradC(k,l,i) = PgradC(k,l,i)-aux
12794                PgradC(k,l,j) = PgradC(k,l,j)+aux
12795                PgradX(k,l,i) = PgradX(k,l,i)-aux
12796                PgradX(k,l,j) = PgradX(k,l,j)+aux
12797                endif
12798              enddo ! l
12799            enddo ! k
12800 #else
12801            dijCACA=dist(i,j)
12802            sigma2CACA=scal_rad**2*0.25d0/
12803      &        (restok(itype(j))**2+restok(itype(i))**2)
12804 c           write (iout,*) "scal_rad",scal_rad," restok",restok(itype(j))
12805 c     &       ,restok(itype(i)),"sigma",1.0d0/dsqrt(sigma2CACA)
12806 #ifdef MYGAUSS
12807            sigmaCACA=dsqrt(sigma2CACA)
12808            threesig=3.0d0/sigmaCACA
12809 c           llicz=0
12810            do k=1,nsaxs
12811              dk = distsaxs(k)
12812              if (dabs(dijCACA-dk).ge.threesig) cycle
12813 c             llicz=llicz+1
12814 c             lllicz=lllicz+1
12815              aux = sigmaCACA*(dijCACA-dk)
12816              expCACA = mygauss(aux)
12817 c             if (expcaca.eq.0.0d0) cycle
12818              Pcalc(k) = Pcalc(k)+expCACA
12819              CACAgrad = -sigmaCACA*mygaussder(aux)
12820 c             write (iout,*) "i,j,k,aux",i,j,k,CACAgrad
12821              do l=1,3
12822                aux = CACAgrad*(C(l,j)-C(l,i))/dijCACA
12823                PgradC(k,l,i) = PgradC(k,l,i)-aux
12824                PgradC(k,l,j) = PgradC(k,l,j)+aux
12825              enddo ! l
12826            enddo ! k
12827 c           write (iout,*) "i",i," j",j," llicz",llicz
12828 #else
12829            IF (saxs_cutoff.eq.0) THEN
12830            do k=1,nsaxs
12831              dk = distsaxs(k)
12832              expCACA = dexp(-0.5d0*sigma2CACA*(dijCACA-dk)**2)
12833              Pcalc(k) = Pcalc(k)+expCACA
12834              CACAgrad = sigma2CACA*(dijCACA-dk)*expCACA
12835              do l=1,3
12836                aux = CACAgrad*(C(l,j)-C(l,i))/dijCACA
12837                PgradC(k,l,i) = PgradC(k,l,i)-aux
12838                PgradC(k,l,j) = PgradC(k,l,j)+aux
12839              enddo ! l
12840            enddo ! k
12841            ELSE
12842            rrr = saxs_cutoff*2.0d0/dsqrt(sigma2CACA)
12843            do k=1,nsaxs
12844              dk = distsaxs(k)
12845 c             write (2,*) "ijk",i,j,k
12846              sss2 = sscale2(dijCACA,rrr,dk,0.3d0)
12847              if (sss2.eq.0.0d0) cycle
12848              ssgrad2 = sscalgrad2(dijCACA,rrr,dk,0.3d0)
12849              if (energy_dec) write(iout,'(a4,3i5,8f10.4)')
12850      &          'saxs',i,j,k,dijCACA,restok(itype(i)),restok(itype(j)),
12851      &          1.0d0/dsqrt(sigma2CACA),rrr,dk,
12852      &           sss2,ssgrad2
12853              expCACA = dexp(-0.5d0*sigma2CACA*(dijCACA-dk)**2)*sss2
12854              Pcalc(k) = Pcalc(k)+expCACA
12855 #ifdef DEBUG
12856              write(iout,*) "i j k Pcalc",i,j,Pcalc(k)
12857 #endif
12858              CACAgrad = -sigma2CACA*(dijCACA-dk)*expCACA+
12859      &             ssgrad2*expCACA/sss2
12860              do l=1,3
12861 c CA CA
12862                aux = CACAgrad*(C(l,j)-C(l,i))/dijCACA
12863                PgradC(k,l,i) = PgradC(k,l,i)+aux
12864                PgradC(k,l,j) = PgradC(k,l,j)-aux
12865              enddo ! l
12866            enddo ! k
12867            ENDIF
12868 #endif
12869 #endif
12870          enddo ! j
12871        enddo ! iint
12872       enddo ! i
12873 c#ifdef TIMING
12874 c      time_SAXS=time_SAXS+MPI_Wtime()-time01
12875 c#endif
12876 c      write (iout,*) "lllicz",lllicz
12877 c#ifdef TIMING
12878 c      time01=MPI_Wtime()
12879 c#endif
12880 #ifdef MPI
12881       if (nfgtasks.gt.1) then
12882        call MPI_AllReduce(Pcalc(1),Pcalc_(1),nsaxs,MPI_DOUBLE_PRECISION,
12883      &    MPI_SUM,FG_COMM,IERR)
12884 c        if (fg_rank.eq.king) then
12885           do k=1,nsaxs
12886             Pcalc(k) = Pcalc_(k)
12887           enddo
12888 c        endif
12889 c        call MPI_AllReduce(PgradC(k,1,1),PgradC_(k,1,1),3*maxsaxs*nres,
12890 c     &    MPI_DOUBLE_PRECISION,MPI_SUM,FG_COMM,IERR)
12891 c        if (fg_rank.eq.king) then
12892 c          do i=1,nres
12893 c            do l=1,3
12894 c              do k=1,nsaxs
12895 c                PgradC(k,l,i) = PgradC_(k,l,i)
12896 c              enddo
12897 c            enddo
12898 c          enddo
12899 c        endif
12900 #ifdef ALLSAXS
12901 c        call MPI_AllReduce(PgradX(k,1,1),PgradX_(k,1,1),3*maxsaxs*nres,
12902 c     &    MPI_DOUBLE_PRECISION,MPI_SUM,FG_COMM,IERR)
12903 c        if (fg_rank.eq.king) then
12904 c          do i=1,nres
12905 c            do l=1,3
12906 c              do k=1,nsaxs
12907 c                PgradX(k,l,i) = PgradX_(k,l,i)
12908 c              enddo
12909 c            enddo
12910 c          enddo
12911 c        endif
12912 #endif
12913       endif
12914 #endif
12915       Cnorm = 0.0d0
12916       do k=1,nsaxs
12917         Cnorm = Cnorm + Pcalc(k)
12918       enddo
12919 #ifdef MPI
12920       if (fg_rank.eq.king) then
12921 #endif
12922       Esaxs_constr = dlog(Cnorm)-wsaxs0
12923       do k=1,nsaxs
12924         if (Pcalc(k).gt.0.0d0)
12925      &  Esaxs_constr = Esaxs_constr - Psaxs(k)*dlog(Pcalc(k))
12926 #ifdef DEBUG
12927         write (iout,*) "k",k," Esaxs_constr",Esaxs_constr
12928 #endif
12929       enddo
12930 #ifdef DEBUG
12931       write (iout,*) "Cnorm",Cnorm," Esaxs_constr",Esaxs_constr
12932 #endif
12933 #ifdef MPI
12934       endif
12935 #endif
12936       gsaxsC=0.0d0
12937       gsaxsX=0.0d0
12938       do i=nnt,nct
12939         do l=1,3
12940           auxC=0.0d0
12941           auxC1=0.0d0
12942           auxX=0.0d0
12943           auxX1=0.d0
12944           do k=1,nsaxs
12945             if (Pcalc(k).gt.0)
12946      &      auxC  = auxC +Psaxs(k)*PgradC(k,l,i)/Pcalc(k)
12947             auxC1 = auxC1+PgradC(k,l,i)
12948 #ifdef ALLSAXS
12949             auxX  = auxX +Psaxs(k)*PgradX(k,l,i)/Pcalc(k)
12950             auxX1 = auxX1+PgradX(k,l,i)
12951 #endif
12952           enddo
12953           gsaxsC(l,i) = auxC - auxC1/Cnorm
12954 #ifdef ALLSAXS
12955           gsaxsX(l,i) = auxX - auxX1/Cnorm
12956 #endif
12957 c          write (iout,*) "l i",l,i," gradC",wsaxs*(auxC - auxC1/Cnorm),
12958 c     *     " gradX",wsaxs*(auxX - auxX1/Cnorm)
12959 c          write (iout,*) "l i",l,i," gradC",wsaxs*gsaxsC(l,i),
12960 c     *     " gradX",wsaxs*gsaxsX(l,i)
12961         enddo
12962       enddo
12963 #ifdef TIMING
12964       time_SAXS=time_SAXS+MPI_Wtime()-time01
12965 #endif
12966 #ifdef DEBUG
12967       write (iout,*) "gsaxsc"
12968       do i=nnt,nct
12969         write (iout,'(i5,3e15.5)') i,(gsaxsc(j,i),j=1,3)
12970       enddo
12971 #endif
12972 #ifdef MPI
12973 c      endif
12974 #endif
12975       return
12976       end
12977 c----------------------------------------------------------------------------
12978       subroutine e_saxsC(Esaxs_constr)
12979       implicit none
12980       include 'DIMENSIONS'
12981 #ifdef MPI
12982       include "mpif.h"
12983       include "COMMON.SETUP"
12984       integer IERR
12985 #endif
12986       include 'COMMON.SBRIDGE'
12987       include 'COMMON.CHAIN'
12988       include 'COMMON.GEO'
12989       include 'COMMON.DERIV'
12990       include 'COMMON.LOCAL'
12991       include 'COMMON.INTERACT'
12992       include 'COMMON.VAR'
12993       include 'COMMON.IOUNITS'
12994 c      include 'COMMON.MD'
12995 #ifdef LANG0
12996 #ifdef FIVEDIAG
12997       include 'COMMON.LANGEVIN.lang0.5diag'
12998 #else
12999       include 'COMMON.LANGEVIN.lang0'
13000 #endif
13001 #else
13002       include 'COMMON.LANGEVIN'
13003 #endif
13004       include 'COMMON.CONTROL'
13005       include 'COMMON.SAXS'
13006       include 'COMMON.NAMES'
13007       include 'COMMON.TIME1'
13008       include 'COMMON.FFIELD'
13009 c
13010       double precision Esaxs_constr
13011       integer i,iint,j,k,l
13012       double precision PgradC(3,maxres),PgradX(3,maxres),Pcalc,logPtot
13013 #ifdef MPI
13014       double precision gsaxsc_(3,maxres),gsaxsx_(3,maxres),logPtot_
13015 #endif
13016       double precision dk,dijCASPH,dijSCSPH,
13017      & sigma2CA,sigma2SC,expCASPH,expSCSPH,
13018      & CASPHgrad,SCSPHgrad,aux,auxC,auxC1,
13019      & auxX,auxX1,Cnorm
13020 c  SAXS restraint penalty function
13021 #ifdef DEBUG
13022       write(iout,*) "------- SAXS penalty function start -------"
13023       write (iout,*) "nsaxs",nsaxs
13024
13025       do i=nnt,nct
13026         print *,MyRank,"C",i,(C(j,i),j=1,3)
13027       enddo
13028       do i=nnt,nct
13029         print *,MyRank,"CSaxs",i,(Csaxs(j,i),j=1,3)
13030       enddo
13031 #endif
13032       Esaxs_constr = 0.0d0
13033       logPtot=0.0d0
13034       do j=isaxs_start,isaxs_end
13035         Pcalc=0.0d0
13036         do i=1,nres
13037           do l=1,3
13038             PgradC(l,i)=0.0d0
13039             PgradX(l,i)=0.0d0
13040           enddo
13041         enddo
13042         do i=nnt,nct
13043           if (itype(i).eq.ntyp1) cycle
13044           dijCASPH=0.0d0
13045           dijSCSPH=0.0d0
13046           do l=1,3
13047             dijCASPH=dijCASPH+(C(l,i)-Csaxs(l,j))**2
13048           enddo
13049           if (itype(i).ne.10) then
13050           do l=1,3
13051             dijSCSPH=dijSCSPH+(C(l,i+nres)-Csaxs(l,j))**2
13052           enddo
13053           endif
13054           sigma2CA=2.0d0/pstok**2
13055           sigma2SC=4.0d0/restok(itype(i))**2
13056           expCASPH = dexp(-0.5d0*sigma2CA*dijCASPH)
13057           expSCSPH = dexp(-0.5d0*sigma2SC*dijSCSPH)
13058           Pcalc = Pcalc+expCASPH+expSCSPH
13059 #ifdef DEBUG
13060           write(*,*) "processor i j Pcalc",
13061      &       MyRank,i,j,dijCASPH,dijSCSPH, Pcalc
13062 #endif
13063           CASPHgrad = sigma2CA*expCASPH
13064           SCSPHgrad = sigma2SC*expSCSPH
13065           do l=1,3
13066             aux = (C(l,i+nres)-Csaxs(l,j))*SCSPHgrad
13067             PgradX(l,i) = PgradX(l,i) + aux
13068             PgradC(l,i) = PgradC(l,i)+(C(l,i)-Csaxs(l,j))*CASPHgrad+aux
13069           enddo ! l
13070         enddo ! i
13071         do i=nnt,nct
13072           do l=1,3
13073             gsaxsc(l,i)=gsaxsc(l,i)+PgradC(l,i)/Pcalc
13074             gsaxsx(l,i)=gsaxsx(l,i)+PgradX(l,i)/Pcalc
13075           enddo
13076         enddo
13077         logPtot = logPtot - dlog(Pcalc)
13078 c        print *,"me",me,MyRank," j",j," logPcalc",-dlog(Pcalc),
13079 c     &    " logPtot",logPtot
13080       enddo ! j
13081 #ifdef MPI
13082       if (nfgtasks.gt.1) then
13083 c        write (iout,*) "logPtot before reduction",logPtot
13084         call MPI_Reduce(logPtot,logPtot_,1,MPI_DOUBLE_PRECISION,
13085      &    MPI_SUM,king,FG_COMM,IERR)
13086         logPtot = logPtot_
13087 c        write (iout,*) "logPtot after reduction",logPtot
13088         call MPI_Reduce(gsaxsC(1,1),gsaxsC_(1,1),3*nres,
13089      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
13090         if (fg_rank.eq.king) then
13091           do i=1,nres
13092             do l=1,3
13093               gsaxsC(l,i) = gsaxsC_(l,i)
13094             enddo
13095           enddo
13096         endif
13097         call MPI_Reduce(gsaxsX(1,1),gsaxsX_(1,1),3*nres,
13098      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
13099         if (fg_rank.eq.king) then
13100           do i=1,nres
13101             do l=1,3
13102               gsaxsX(l,i) = gsaxsX_(l,i)
13103             enddo
13104           enddo
13105         endif
13106       endif
13107 #endif
13108       Esaxs_constr = logPtot
13109       return
13110       end
13111 c----------------------------------------------------------------------------
13112       double precision function sscale2(r,r_cut,r0,rlamb)
13113       implicit none
13114       double precision r,gamm,r_cut,r0,rlamb,rr
13115       rr = dabs(r-r0)
13116 c      write (2,*) "r",r," r_cut",r_cut," r0",r0," rlamb",rlamb
13117 c      write (2,*) "rr",rr
13118       if(rr.lt.r_cut-rlamb) then
13119         sscale2=1.0d0
13120       else if(rr.le.r_cut.and.rr.ge.r_cut-rlamb) then
13121         gamm=(rr-(r_cut-rlamb))/rlamb
13122         sscale2=1.0d0+gamm*gamm*(2*gamm-3.0d0)
13123       else
13124         sscale2=0d0
13125       endif
13126       return
13127       end
13128 C-----------------------------------------------------------------------
13129       double precision function sscalgrad2(r,r_cut,r0,rlamb)
13130       implicit none
13131       double precision r,gamm,r_cut,r0,rlamb,rr
13132       rr = dabs(r-r0)
13133       if(rr.lt.r_cut-rlamb) then
13134         sscalgrad2=0.0d0
13135       else if(rr.le.r_cut.and.rr.ge.r_cut-rlamb) then
13136         gamm=(rr-(r_cut-rlamb))/rlamb
13137         if (r.ge.r0) then
13138           sscalgrad2=gamm*(6*gamm-6.0d0)/rlamb
13139         else
13140           sscalgrad2=-gamm*(6*gamm-6.0d0)/rlamb
13141         endif
13142       else
13143         sscalgrad2=0.0d0
13144       endif
13145       return
13146       end
13147 c------------------------------------------------------------------------
13148       double precision function boxshift(x,boxsize)
13149       implicit none
13150       double precision x,boxsize
13151       double precision xtemp
13152       xtemp=dmod(x,boxsize)
13153       if (dabs(xtemp-boxsize).lt.dabs(xtemp)) then
13154         boxshift=xtemp-boxsize
13155       else if (dabs(xtemp+boxsize).lt.dabs(xtemp)) then
13156         boxshift=xtemp+boxsize
13157       else
13158         boxshift=xtemp
13159       endif
13160       return
13161       end
13162 c--------------------------------------------------------------------------
13163       subroutine closest_img(xi,yi,zi,xj,yj,zj)
13164       include 'DIMENSIONS'
13165       include 'COMMON.CHAIN'
13166       integer xshift,yshift,zshift,subchap
13167       double precision dist_init,xj_safe,yj_safe,zj_safe,
13168      & xj_temp,yj_temp,zj_temp,dist_temp
13169       xj_safe=xj
13170       yj_safe=yj
13171       zj_safe=zj
13172       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
13173       subchap=0
13174       do xshift=-1,1
13175         do yshift=-1,1
13176           do zshift=-1,1
13177             xj=xj_safe+xshift*boxxsize
13178             yj=yj_safe+yshift*boxysize
13179             zj=zj_safe+zshift*boxzsize
13180             dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
13181             if(dist_temp.lt.dist_init) then
13182               dist_init=dist_temp
13183               xj_temp=xj
13184               yj_temp=yj
13185               zj_temp=zj
13186               subchap=1
13187             endif
13188           enddo
13189         enddo
13190       enddo
13191       if (subchap.eq.1) then
13192         xj=xj_temp-xi
13193         yj=yj_temp-yi
13194         zj=zj_temp-zi
13195       else
13196         xj=xj_safe-xi
13197         yj=yj_safe-yi
13198         zj=zj_safe-zi
13199       endif
13200       return
13201       end
13202 c--------------------------------------------------------------------------
13203       subroutine to_box(xi,yi,zi)
13204       implicit none
13205       include 'DIMENSIONS'
13206       include 'COMMON.CHAIN'
13207       double precision xi,yi,zi
13208       xi=dmod(xi,boxxsize)
13209       if (xi.lt.0.0d0) xi=xi+boxxsize
13210       yi=dmod(yi,boxysize)
13211       if (yi.lt.0.0d0) yi=yi+boxysize
13212       zi=dmod(zi,boxzsize)
13213       if (zi.lt.0.0d0) zi=zi+boxzsize
13214       return
13215       end
13216 c--------------------------------------------------------------------------
13217       subroutine lipid_layer(xi,yi,zi,sslipi,ssgradlipi)
13218       implicit none
13219       include 'DIMENSIONS'
13220       include 'COMMON.CHAIN'
13221       double precision xi,yi,zi,sslipi,ssgradlipi
13222       double precision fracinbuf
13223       double precision sscalelip,sscagradlip
13224
13225       if ((zi.gt.bordlipbot).and.(zi.lt.bordliptop)) then
13226 C the energy transfer exist
13227         if (zi.lt.buflipbot) then
13228 C what fraction I am in
13229           fracinbuf=1.0d0-((zi-bordlipbot)/lipbufthick)
13230 C lipbufthick is thickenes of lipid buffore
13231           sslipi=sscalelip(fracinbuf)
13232           ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
13233         elseif (zi.gt.bufliptop) then
13234           fracinbuf=1.0d0-((bordliptop-zi)/lipbufthick)
13235           sslipi=sscalelip(fracinbuf)
13236           ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
13237         else
13238           sslipi=1.0d0
13239           ssgradlipi=0.0
13240         endif
13241       else
13242         sslipi=0.0d0
13243         ssgradlipi=0.0
13244       endif
13245       return
13246       end