source/unres/src-5hdiag-tmp/energy_p_new_barrier.F

   1       subroutine etotal(energia)
   2       implicit real*8 (a-h,o-z)
   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 #endif
  14       include 'COMMON.SETUP'
  15       include 'COMMON.IOUNITS'
  16       double precision energia(0:n_ene)
  17       include 'COMMON.LOCAL'
  18       include 'COMMON.FFIELD'
  19       include 'COMMON.DERIV'
  20       include 'COMMON.INTERACT'
  21       include 'COMMON.SBRIDGE'
  22       include 'COMMON.CHAIN'
  23       include 'COMMON.VAR'
  24       include 'COMMON.QRESTR'
  25       include 'COMMON.CONTROL'
  26       include 'COMMON.TIME1'
  27       include 'COMMON.SPLITELE'
  28       include 'COMMON.TORCNSTR'
  29 #ifdef MPI
  30 c      print*,"ETOTAL Processor",fg_rank," absolute rank",myrank,
  31 c     & " nfgtasks",nfgtasks
  32       if (nfgtasks.gt.1) then
  33         time00=MPI_Wtime()
  34 C FG slaves call the following matching MPI_Bcast in ERGASTULUM
  35         if (fg_rank.eq.0) then
  36           call MPI_Bcast(0,1,MPI_INTEGER,king,FG_COMM,IERROR)
  37 c          print *,"Processor",myrank," BROADCAST iorder"
  38 C FG master sets up the WEIGHTS_ array which will be broadcast to the
  39 C FG slaves as WEIGHTS array.
  40           weights_(1)=wsc
  41           weights_(2)=wscp
  42           weights_(3)=welec
  43           weights_(4)=wcorr
  44           weights_(5)=wcorr5
  45           weights_(6)=wcorr6
  46           weights_(7)=wel_loc
  47           weights_(8)=wturn3
  48           weights_(9)=wturn4
  49           weights_(10)=wturn6
  50           weights_(11)=wang
  51           weights_(12)=wscloc
  52           weights_(13)=wtor
  53           weights_(14)=wtor_d
  54           weights_(15)=wstrain
  55           weights_(16)=wvdwpp
  56           weights_(17)=wbond
  57           weights_(18)=scal14
  58           weights_(21)=wsccor
  59           weights_(22)=wtube
  60           weights_(26)=wsaxs
  61 C FG Master broadcasts the WEIGHTS_ array
  62           call MPI_Bcast(weights_(1),n_ene,
  63      &        MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
  64         else
  65 C FG slaves receive the WEIGHTS array
  66           call MPI_Bcast(weights(1),n_ene,
  67      &        MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
  68           wsc=weights(1)
  69           wscp=weights(2)
  70           welec=weights(3)
  71           wcorr=weights(4)
  72           wcorr5=weights(5)
  73           wcorr6=weights(6)
  74           wel_loc=weights(7)
  75           wturn3=weights(8)
  76           wturn4=weights(9)
  77           wturn6=weights(10)
  78           wang=weights(11)
  79           wscloc=weights(12)
  80           wtor=weights(13)
  81           wtor_d=weights(14)
  82           wstrain=weights(15)
  83           wvdwpp=weights(16)
  84           wbond=weights(17)
  85           scal14=weights(18)
  86           wsccor=weights(21)
  87           wtube=weights(22)
  88           wsaxs=weights(26)
  89         endif
  90         time_Bcast=time_Bcast+MPI_Wtime()-time00
  91         time_Bcastw=time_Bcastw+MPI_Wtime()-time00
  92 c        call chainbuild_cart
  93       endif
  94 #ifndef DFA
  95       edfadis=0.0d0
  96       edfator=0.0d0
  97       edfanei=0.0d0
  98       edfabet=0.0d0
  99 #endif
 100 c      print *,'Processor',myrank,' calling etotal ipot=',ipot
 101 c      print *,'Processor',myrank,' nnt=',nnt,' nct=',nct
 102 #else
 103 c      if (modecalc.eq.12.or.modecalc.eq.14) then
 104 c        call int_from_cart1(.false.)
 105 c      endif
 106 #endif
 107 #ifdef TIMING
 108       time00=MPI_Wtime()
 109 #endif
 110 C
 111 C Compute the side-chain and electrostatic interaction energy
 112 C
 113 C      print *,ipot
 114       goto (101,102,103,104,105,106) ipot
 115 C Lennard-Jones potential.
 116   101 call elj(evdw)
 117 cd    print '(a)','Exit ELJ'
 118       goto 107
 119 C Lennard-Jones-Kihara potential (shifted).
 120   102 call eljk(evdw)
 121       goto 107
 122 C Berne-Pechukas potential (dilated LJ, angular dependence).
 123   103 call ebp(evdw)
 124       goto 107
 125 C Gay-Berne potential (shifted LJ, angular dependence).
 126   104 call egb(evdw)
 127 C      print *,"bylem w egb"
 128       goto 107
 129 C Gay-Berne-Vorobjev potential (shifted LJ, angular dependence).
 130   105 call egbv(evdw)
 131       goto 107
 132 C Soft-sphere potential
 133   106 call e_softsphere(evdw)
 134 C
 135 C Calculate electrostatic (H-bonding) energy of the main chain.
 136 C
 137   107 continue
 138 #ifdef DFA
 139 C     BARTEK for dfa test!
 140       if (wdfa_dist.gt.0) then
 141         call edfad(edfadis)
 142       else
 143         edfadis=0
 144       endif
 145 c      print*, 'edfad is finished!', edfadis
 146       if (wdfa_tor.gt.0) then
 147         call edfat(edfator)
 148       else
 149         edfator=0
 150       endif
 151 c      print*, 'edfat is finished!', edfator
 152       if (wdfa_nei.gt.0) then
 153         call edfan(edfanei)
 154       else
 155         edfanei=0
 156       endif
 157 c      print*, 'edfan is finished!', edfanei
 158       if (wdfa_beta.gt.0) then
 159         call edfab(edfabet)
 160       else
 161         edfabet=0
 162       endif
 163 #endif
 164 cmc
 165 cmc Sep-06: egb takes care of dynamic ss bonds too
 166 cmc
 167 c      if (dyn_ss) call dyn_set_nss
 168
 169 c      print *,"Processor",myrank," computed USCSC"
 170 #ifdef TIMING
 171       time01=MPI_Wtime()
 172 #endif
 173       call vec_and_deriv
 174 #ifdef TIMING
 175       time_vec=time_vec+MPI_Wtime()-time01
 176 #endif
 177 C Introduction of shielding effect first for each peptide group
 178 C the shielding factor is set this factor is describing how each
 179 C peptide group is shielded by side-chains
 180 C the matrix - shield_fac(i) the i index describe the ith between i and i+1
 181 C      write (iout,*) "shield_mode",shield_mode
 182       if (shield_mode.eq.1) then
 183        call set_shield_fac
 184       else if  (shield_mode.eq.2) then
 185        call set_shield_fac2
 186       endif
 187 c      print *,"Processor",myrank," left VEC_AND_DERIV"
 188       if (ipot.lt.6) then
 189 #ifdef SPLITELE
 190          if (welec.gt.0d0.or.wvdwpp.gt.0d0.or.wel_loc.gt.0d0.or.
 191      &       wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0
 192      &       .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0
 193      &       .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
 194 #else
 195          if (welec.gt.0d0.or.wel_loc.gt.0d0.or.
 196      &       wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0
 197      &       .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0
 198      &       .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
 199 #endif
 200             call eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
 201          else
 202             ees=0.0d0
 203             evdw1=0.0d0
 204             eel_loc=0.0d0
 205             eello_turn3=0.0d0
 206             eello_turn4=0.0d0
 207          endif
 208       else
 209         write (iout,*) "Soft-spheer ELEC potential"
 210 c        call eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,
 211 c     &   eello_turn4)
 212       endif
 213 c#ifdef TIMING
 214 c      time_enecalc=time_enecalc+MPI_Wtime()-time00
 215 c#endif
 216 c      print *,"Processor",myrank," computed UELEC"
 217 C
 218 C Calculate excluded-volume interaction energy between peptide groups
 219 C and side chains.
 220 C
 221       if (ipot.lt.6) then
 222        if(wscp.gt.0d0) then
 223         call escp(evdw2,evdw2_14)
 224        else
 225         evdw2=0
 226         evdw2_14=0
 227        endif
 228       else
 229 c        write (iout,*) "Soft-sphere SCP potential"
 230         call escp_soft_sphere(evdw2,evdw2_14)
 231       endif
 232 c
 233 c Calculate the bond-stretching energy
 234 c
 235       call ebond(estr)
 236 C
 237 C Calculate the disulfide-bridge and other energy and the contributions
 238 C from other distance constraints.
 239 cd      write (iout,*) 'Calling EHPB'
 240       call edis(ehpb)
 241 cd    print *,'EHPB exitted succesfully.'
 242 C
 243 C Calculate the virtual-bond-angle energy.
 244 C
 245       if (wang.gt.0d0) then
 246        if (tor_mode.eq.0) then
 247          call ebend(ebe)
 248        else
 249 C ebend kcc is Kubo cumulant clustered rigorous attemp to derive the
 250 C energy function
 251          call ebend_kcc(ebe)
 252        endif
 253       else
 254         ebe=0.0d0
 255       endif
 256       ethetacnstr=0.0d0
 257       if (with_theta_constr) call etheta_constr(ethetacnstr)
 258 c      print *,"Processor",myrank," computed UB"
 259 C
 260 C Calculate the SC local energy.
 261 C
 262 C      print *,"TU DOCHODZE?"
 263       call esc(escloc)
 264 c      print *,"Processor",myrank," computed USC"
 265 C
 266 C Calculate the virtual-bond torsional energy.
 267 C
 268 cd    print *,'nterm=',nterm
 269 C      print *,"tor",tor_mode
 270       if (wtor.gt.0.0d0) then
 271          if (tor_mode.eq.0) then
 272            call etor(etors)
 273          else
 274 C etor kcc is Kubo cumulant clustered rigorous attemp to derive the
 275 C energy function
 276            call etor_kcc(etors)
 277          endif
 278       else
 279         etors=0.0d0
 280       endif
 281       edihcnstr=0.0d0
 282       if (ndih_constr.gt.0) call etor_constr(edihcnstr)
 283 c      print *,"Processor",myrank," computed Utor"
 284       if (constr_homology.ge.1) then
 285         call e_modeller(ehomology_constr)
 286 c        print *,'iset=',iset,'me=',me,ehomology_constr,
 287 c     &  'Processor',fg_rank,' CG group',kolor,
 288 c     &  ' absolute rank',MyRank
 289       else
 290         ehomology_constr=0.0d0
 291       endif
 292 C
 293 C 6/23/01 Calculate double-torsional energy
 294 C
 295       if ((wtor_d.gt.0.0d0).and.(tor_mode.eq.0)) then
 296         call etor_d(etors_d)
 297       else
 298         etors_d=0
 299       endif
 300 c      print *,"Processor",myrank," computed Utord"
 301 C
 302 C 21/5/07 Calculate local sicdechain correlation energy
 303 C
 304       if (wsccor.gt.0.0d0) then
 305         call eback_sc_corr(esccor)
 306       else
 307         esccor=0.0d0
 308       endif
 309 C      print *,"PRZED MULIt"
 310 c      print *,"Processor",myrank," computed Usccorr"
 311 C
 312 C 12/1/95 Multi-body terms
 313 C
 314       n_corr=0
 315       n_corr1=0
 316       if ((wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0
 317      &    .or. wturn6.gt.0.0d0) .and. ipot.lt.6) then
 318          call multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1)
 319 c         write(2,*)'MULTIBODY_EELLO n_corr=',n_corr,' n_corr1=',n_corr1,
 320 c     &" ecorr",ecorr," ecorr5",ecorr5," ecorr6",ecorr6," eturn6",eturn6
 321 c        call flush(iout)
 322       else
 323          ecorr=0.0d0
 324          ecorr5=0.0d0
 325          ecorr6=0.0d0
 326          eturn6=0.0d0
 327       endif
 328       if ((wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) .and. ipot.lt.6) then
 329 c         write (iout,*) "Before MULTIBODY_HB ecorr",ecorr,ecorr5,ecorr6,
 330 c     &     n_corr,n_corr1
 331 c         call flush(iout)
 332          call multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
 333 c         write (iout,*) "MULTIBODY_HB ecorr",ecorr,ecorr5,ecorr6,n_corr,
 334 c     &     n_corr1
 335 c         call flush(iout)
 336       endif
 337 c      print *,"Processor",myrank," computed Ucorr"
 338 c      write (iout,*) "nsaxs",nsaxs," saxs_mode",saxs_mode
 339       if (nsaxs.gt.0 .and. saxs_mode.eq.0) then
 340         call e_saxs(Esaxs_constr)
 341 c        write (iout,*) "From Esaxs: Esaxs_constr",Esaxs_constr
 342       else if (nsaxs.gt.0 .and. saxs_mode.gt.0) then
 343         call e_saxsC(Esaxs_constr)
 344 c        write (iout,*) "From EsaxsC: Esaxs_constr",Esaxs_constr
 345       else
 346         Esaxs_constr = 0.0d0
 347       endif
 348 C
 349 C If performing constraint dynamics, call the constraint energy
 350 C  after the equilibration time
 351 c      if(usampl.and.totT.gt.eq_time) then
 352 c      write (iout,*) "usampl",usampl
 353       if(usampl) then
 354          call EconstrQ
 355          if (loc_qlike) then
 356            call Econstr_back_qlike
 357          else
 358            call Econstr_back
 359          endif
 360       else
 361          Uconst=0.0d0
 362          Uconst_back=0.0d0
 363       endif
 364 C 01/27/2015 added by adasko
 365 C the energy component below is energy transfer into lipid environment
 366 C based on partition function
 367 C      print *,"przed lipidami"
 368       if (wliptran.gt.0) then
 369         call Eliptransfer(eliptran)
 370       endif
 371 C      print *,"za lipidami"
 372       if (AFMlog.gt.0) then
 373         call AFMforce(Eafmforce)
 374       else if (selfguide.gt.0) then
 375         call AFMvel(Eafmforce)
 376       endif
 377       if (TUBElog.eq.1) then
 378 C      print *,"just before call"
 379         call calctube(Etube)
 380        elseif (TUBElog.eq.2) then
 381         call calctube2(Etube)
 382        else
 383        Etube=0.0d0
 384        endif
 385
 386 #ifdef TIMING
 387       time_enecalc=time_enecalc+MPI_Wtime()-time00
 388 #endif
 389 c      print *,"Processor",myrank," computed Uconstr"
 390 #ifdef TIMING
 391       time00=MPI_Wtime()
 392 #endif
 393 c
 394 C Sum the energies
 395 C
 396       energia(1)=evdw
 397 #ifdef SCP14
 398       energia(2)=evdw2-evdw2_14
 399       energia(18)=evdw2_14
 400 #else
 401       energia(2)=evdw2
 402       energia(18)=0.0d0
 403 #endif
 404 #ifdef SPLITELE
 405       energia(3)=ees
 406       energia(16)=evdw1
 407 #else
 408       energia(3)=ees+evdw1
 409       energia(16)=0.0d0
 410 #endif
 411       energia(4)=ecorr
 412       energia(5)=ecorr5
 413       energia(6)=ecorr6
 414       energia(7)=eel_loc
 415       energia(8)=eello_turn3
 416       energia(9)=eello_turn4
 417       energia(10)=eturn6
 418       energia(11)=ebe
 419       energia(12)=escloc
 420       energia(13)=etors
 421       energia(14)=etors_d
 422       energia(15)=ehpb
 423       energia(19)=edihcnstr
 424       energia(17)=estr
 425       energia(20)=Uconst+Uconst_back
 426       energia(21)=esccor
 427       energia(22)=eliptran
 428       energia(23)=Eafmforce
 429       energia(24)=ethetacnstr
 430       energia(25)=Etube
 431       energia(26)=Esaxs_constr
 432       energia(27)=ehomology_constr
 433       energia(28)=edfadis
 434       energia(29)=edfator
 435       energia(30)=edfanei
 436       energia(31)=edfabet
 437 c      write (iout,*) "esaxs_constr",energia(26)
 438 c    Here are the energies showed per procesor if the are more processors
 439 c    per molecule then we sum it up in sum_energy subroutine
 440 c      print *," Processor",myrank," calls SUM_ENERGY"
 441       call sum_energy(energia,.true.)
 442 c      write (iout,*) "After sum_energy: esaxs_constr",energia(26)
 443       if (dyn_ss) call dyn_set_nss
 444 c      print *," Processor",myrank," left SUM_ENERGY"
 445 #ifdef TIMING
 446       time_sumene=time_sumene+MPI_Wtime()-time00
 447 #endif
 448       return
 449       end
 450 c-------------------------------------------------------------------------------
 451       subroutine sum_energy(energia,reduce)
 452       implicit real*8 (a-h,o-z)
 453       include 'DIMENSIONS'
 454 #ifndef ISNAN
 455       external proc_proc
 456 #ifdef WINPGI
 457 cMS$ATTRIBUTES C ::  proc_proc
 458 #endif
 459 #endif
 460 #ifdef MPI
 461       include "mpif.h"
 462 #endif
 463       include 'COMMON.SETUP'
 464       include 'COMMON.IOUNITS'
 465       double precision energia(0:n_ene),enebuff(0:n_ene+1)
 466       include 'COMMON.FFIELD'
 467       include 'COMMON.DERIV'
 468       include 'COMMON.INTERACT'
 469       include 'COMMON.SBRIDGE'
 470       include 'COMMON.CHAIN'
 471       include 'COMMON.VAR'
 472       include 'COMMON.CONTROL'
 473       include 'COMMON.TIME1'
 474       logical reduce
 475 #ifdef MPI
 476       if (nfgtasks.gt.1 .and. reduce) then
 477 #ifdef DEBUG
 478         write (iout,*) "energies before REDUCE"
 479         call enerprint(energia)
 480         call flush(iout)
 481 #endif
 482         do i=0,n_ene
 483           enebuff(i)=energia(i)
 484         enddo
 485         time00=MPI_Wtime()
 486         call MPI_Barrier(FG_COMM,IERR)
 487         time_barrier_e=time_barrier_e+MPI_Wtime()-time00
 488         time00=MPI_Wtime()
 489         call MPI_Reduce(enebuff(0),energia(0),n_ene+1,
 490      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 491 #ifdef DEBUG
 492         write (iout,*) "energies after REDUCE"
 493         call enerprint(energia)
 494         call flush(iout)
 495 #endif
 496         time_Reduce=time_Reduce+MPI_Wtime()-time00
 497       endif
 498       if (fg_rank.eq.0) then
 499 #endif
 500       evdw=energia(1)
 501 #ifdef SCP14
 502       evdw2=energia(2)+energia(18)
 503       evdw2_14=energia(18)
 504 #else
 505       evdw2=energia(2)
 506 #endif
 507 #ifdef SPLITELE
 508       ees=energia(3)
 509       evdw1=energia(16)
 510 #else
 511       ees=energia(3)
 512       evdw1=0.0d0
 513 #endif
 514       ecorr=energia(4)
 515       ecorr5=energia(5)
 516       ecorr6=energia(6)
 517       eel_loc=energia(7)
 518       eello_turn3=energia(8)
 519       eello_turn4=energia(9)
 520       eturn6=energia(10)
 521       ebe=energia(11)
 522       escloc=energia(12)
 523       etors=energia(13)
 524       etors_d=energia(14)
 525       ehpb=energia(15)
 526       edihcnstr=energia(19)
 527       estr=energia(17)
 528       Uconst=energia(20)
 529       esccor=energia(21)
 530       eliptran=energia(22)
 531       Eafmforce=energia(23)
 532       ethetacnstr=energia(24)
 533       Etube=energia(25)
 534       esaxs_constr=energia(26)
 535       ehomology_constr=energia(27)
 536       edfadis=energia(28)
 537       edfator=energia(29)
 538       edfanei=energia(30)
 539       edfabet=energia(31)
 540 #ifdef SPLITELE
 541       etot=wsc*evdw+wscp*evdw2+welec*ees+wvdwpp*evdw1
 542      & +wang*ebe+wtor*etors+wscloc*escloc
 543      & +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5
 544      & +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3
 545      & +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d
 546      & +wbond*estr+wumb*Uconst+wsccor*esccor+wliptran*eliptran+Eafmforce
 547      & +ethetacnstr+wtube*Etube+wsaxs*esaxs_constr+ehomology_constr
 548      & +wdfa_dist*edfadis+wdfa_tor*edfator+wdfa_nei*edfanei
 549      & +wdfa_beta*edfabet
 550 #else
 551       etot=wsc*evdw+wscp*evdw2+welec*(ees+evdw1)
 552      & +wang*ebe+wtor*etors+wscloc*escloc
 553      & +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5
 554      & +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3
 555      & +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d
 556      & +wbond*estr+wumb*Uconst+wsccor*esccor+wliptran*eliptran
 557      & +Eafmforce
 558      & +ethetacnstr+wtube*Etube+wsaxs*esaxs_constr+ehomology_constr
 559      & +wdfa_dist*edfadis+wdfa_tor*edfator+wdfa_nei*edfanei
 560      & +wdfa_beta*edfabet
 561 #endif
 562       energia(0)=etot
 563 c detecting NaNQ
 564 #ifdef ISNAN
 565 #ifdef AIX
 566       if (isnan(etot).ne.0) energia(0)=1.0d+99
 567 #else
 568       if (isnan(etot)) energia(0)=1.0d+99
 569 #endif
 570 #else
 571       i=0
 572 #ifdef WINPGI
 573       idumm=proc_proc(etot,i)
 574 #else
 575       call proc_proc(etot,i)
 576 #endif
 577       if(i.eq.1)energia(0)=1.0d+99
 578 #endif
 579 #ifdef MPI
 580       endif
 581 #endif
 582       return
 583       end
 584 c-------------------------------------------------------------------------------
 585       subroutine sum_gradient
 586       implicit real*8 (a-h,o-z)
 587       include 'DIMENSIONS'
 588 #ifndef ISNAN
 589       external proc_proc
 590 #ifdef WINPGI
 591 cMS$ATTRIBUTES C ::  proc_proc
 592 #endif
 593 #endif
 594 #ifdef MPI
 595       include 'mpif.h'
 596 #endif
 597       double precision gradbufc(3,-1:maxres),gradbufx(3,-1:maxres),
 598      & glocbuf(4*maxres),gradbufc_sum(3,-1:maxres)
 599      & ,gloc_scbuf(3,-1:maxres)
 600       include 'COMMON.SETUP'
 601       include 'COMMON.IOUNITS'
 602       include 'COMMON.FFIELD'
 603       include 'COMMON.DERIV'
 604       include 'COMMON.INTERACT'
 605       include 'COMMON.SBRIDGE'
 606       include 'COMMON.CHAIN'
 607       include 'COMMON.VAR'
 608       include 'COMMON.CONTROL'
 609       include 'COMMON.TIME1'
 610       include 'COMMON.MAXGRAD'
 611       include 'COMMON.SCCOR'
 612       include 'COMMON.LAGRANGE'
 613       include 'COMMON.HOMOLOGY'
 614       include 'COMMON.QRESTR'
 615 #ifdef TIMING
 616       time01=MPI_Wtime()
 617 #endif
 618 #ifdef DEBUG
 619       write (iout,*) "sum_gradient gvdwc, gvdwx"
 620       do i=1,nres
 621         write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)')
 622      &   i,(gvdwx(j,i),j=1,3),(gvdwc(j,i),j=1,3)
 623       enddo
 624       call flush(iout)
 625 #endif
 626 #ifdef DEBUG
 627       write (iout,*) "sum_gradient gsaxsc, gsaxsx"
 628       do i=0,nres
 629         write (iout,'(i3,3e15.5,5x,3e15.5)')
 630      &   i,(gsaxsc(j,i),j=1,3),(gsaxsx(j,i),j=1,3)
 631       enddo
 632       call flush(iout)
 633 #endif
 634 #ifdef MPI
 635 C FG slaves call the following matching MPI_Bcast in ERGASTULUM
 636         if (nfgtasks.gt.1 .and. fg_rank.eq.0)
 637      &    call MPI_Bcast(1,1,MPI_INTEGER,king,FG_COMM,IERROR)
 638 #endif
 639 C
 640 C 9/29/08 AL Transform parts of gradients in site coordinates to the gradient
 641 C            in virtual-bond-vector coordinates
 642 C
 643 #ifdef DEBUG
 644 c      write (iout,*) "gel_loc gel_loc_long and gel_loc_loc"
 645 c      do i=1,nres-1
 646 c        write (iout,'(i5,3f10.5,2x,3f10.5,2x,f10.5)')
 647 c     &   i,(gel_loc(j,i),j=1,3),(gel_loc_long(j,i),j=1,3),gel_loc_loc(i)
 648 c      enddo
 649 c      write (iout,*) "gel_loc_tur3 gel_loc_turn4"
 650 c      do i=1,nres-1
 651 c        write (iout,'(i5,3f10.5,2x,f10.5)')
 652 c     &  i,(gcorr4_turn(j,i),j=1,3),gel_loc_turn4(i)
 653 c      enddo
 654       write (iout,*) "gradcorr5 gradcorr5_long gradcorr5_loc"
 655       do i=1,nres
 656         write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)')
 657      &   i,(gradcorr5(j,i),j=1,3),(gradcorr5_long(j,i),j=1,3),
 658      &   g_corr5_loc(i)
 659       enddo
 660       call flush(iout)
 661 #endif
 662 #ifdef DEBUG
 663       write (iout,*) "gsaxsc"
 664       do i=1,nres
 665         write (iout,'(i3,3f10.5)') i,(wsaxs*gsaxsc(j,i),j=1,3)
 666       enddo
 667       call flush(iout)
 668 #endif
 669 #ifdef SPLITELE
 670       do i=0,nct
 671         do j=1,3
 672           gradbufc(j,i)=wsc*gvdwc(j,i)+
 673      &                wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+
 674      &                welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+
 675      &                wel_loc*gel_loc_long(j,i)+
 676      &                wcorr*gradcorr_long(j,i)+
 677      &                wcorr5*gradcorr5_long(j,i)+
 678      &                wcorr6*gradcorr6_long(j,i)+
 679      &                wturn6*gcorr6_turn_long(j,i)+
 680      &                wstrain*ghpbc(j,i)
 681      &                +wliptran*gliptranc(j,i)
 682      &                +gradafm(j,i)
 683      &                +welec*gshieldc(j,i)
 684      &                +wcorr*gshieldc_ec(j,i)
 685      &                +wturn3*gshieldc_t3(j,i)
 686      &                +wturn4*gshieldc_t4(j,i)
 687      &                +wel_loc*gshieldc_ll(j,i)
 688      &                +wtube*gg_tube(j,i)
 689      &                +wsaxs*gsaxsc(j,i)
 690         enddo
 691       enddo
 692 #else
 693       do i=0,nct
 694         do j=1,3
 695           gradbufc(j,i)=wsc*gvdwc(j,i)+
 696      &                wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+
 697      &                welec*gelc_long(j,i)+
 698      &                wbond*gradb(j,i)+
 699      &                wel_loc*gel_loc_long(j,i)+
 700      &                wcorr*gradcorr_long(j,i)+
 701      &                wcorr5*gradcorr5_long(j,i)+
 702      &                wcorr6*gradcorr6_long(j,i)+
 703      &                wturn6*gcorr6_turn_long(j,i)+
 704      &                wstrain*ghpbc(j,i)
 705      &                +wliptran*gliptranc(j,i)
 706      &                +gradafm(j,i)
 707      &                 +welec*gshieldc(j,i)
 708      &                 +wcorr*gshieldc_ec(j,i)
 709      &                 +wturn4*gshieldc_t4(j,i)
 710      &                 +wel_loc*gshieldc_ll(j,i)
 711      &                +wtube*gg_tube(j,i)
 712      &                +wsaxs*gsaxsc(j,i)
 713         enddo
 714       enddo
 715 #endif
 716       do i=1,nct
 717         do j=1,3
 718           gradbufc(j,i)=gradbufc(j,i)+
 719      &                wdfa_dist*gdfad(j,i)+
 720      &                wdfa_tor*gdfat(j,i)+
 721      &                wdfa_nei*gdfan(j,i)+
 722      &                wdfa_beta*gdfab(j,i)
 723         enddo
 724       enddo
 725 #ifdef DEBUG
 726       write (iout,*) "gradc from gradbufc"
 727       do i=1,nres
 728         write (iout,'(i3,3f10.5)') i,(gradc(j,i,icg),j=1,3)
 729       enddo
 730       call flush(iout)
 731 #endif
 732 #ifdef MPI
 733       if (nfgtasks.gt.1) then
 734       time00=MPI_Wtime()
 735 #ifdef DEBUG
 736       write (iout,*) "gradbufc before allreduce"
 737       do i=1,nres
 738         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 739       enddo
 740       call flush(iout)
 741 #endif
 742       do i=0,nres
 743         do j=1,3
 744           gradbufc_sum(j,i)=gradbufc(j,i)
 745         enddo
 746       enddo
 747 c      call MPI_AllReduce(gradbufc(1,1),gradbufc_sum(1,1),3*nres,
 748 c     &    MPI_DOUBLE_PRECISION,MPI_SUM,FG_COMM,IERR)
 749 c      time_reduce=time_reduce+MPI_Wtime()-time00
 750 #ifdef DEBUG
 751 c      write (iout,*) "gradbufc_sum after allreduce"
 752 c      do i=1,nres
 753 c        write (iout,'(i3,3f10.5)') i,(gradbufc_sum(j,i),j=1,3)
 754 c      enddo
 755 c      call flush(iout)
 756 #endif
 757 #ifdef TIMING
 758 c      time_allreduce=time_allreduce+MPI_Wtime()-time00
 759 #endif
 760       do i=nnt,nres
 761         do k=1,3
 762           gradbufc(k,i)=0.0d0
 763         enddo
 764       enddo
 765 #ifdef DEBUG
 766       write (iout,*) "igrad_start",igrad_start," igrad_end",igrad_end
 767       write (iout,*) (i," jgrad_start",jgrad_start(i),
 768      &                  " jgrad_end  ",jgrad_end(i),
 769      &                  i=igrad_start,igrad_end)
 770 #endif
 771 c
 772 c Obsolete and inefficient code; we can make the effort O(n) and, therefore,
 773 c do not parallelize this part.
 774 c
 775 c      do i=igrad_start,igrad_end
 776 c        do j=jgrad_start(i),jgrad_end(i)
 777 c          do k=1,3
 778 c            gradbufc(k,i)=gradbufc(k,i)+gradbufc_sum(k,j)
 779 c          enddo
 780 c        enddo
 781 c      enddo
 782       do j=1,3
 783         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
 784       enddo
 785       do i=nres-2,-1,-1
 786         do j=1,3
 787           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
 788         enddo
 789       enddo
 790 #ifdef DEBUG
 791       write (iout,*) "gradbufc after summing"
 792       do i=1,nres
 793         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 794       enddo
 795       call flush(iout)
 796 #endif
 797       else
 798 #endif
 799 #ifdef DEBUG
 800       write (iout,*) "gradbufc"
 801       do i=1,nres
 802         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 803       enddo
 804       call flush(iout)
 805 #endif
 806       do i=-1,nres
 807         do j=1,3
 808           gradbufc_sum(j,i)=gradbufc(j,i)
 809           gradbufc(j,i)=0.0d0
 810         enddo
 811       enddo
 812       do j=1,3
 813         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
 814       enddo
 815       do i=nres-2,-1,-1
 816         do j=1,3
 817           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
 818         enddo
 819       enddo
 820 c      do i=nnt,nres-1
 821 c        do k=1,3
 822 c          gradbufc(k,i)=0.0d0
 823 c        enddo
 824 c        do j=i+1,nres
 825 c          do k=1,3
 826 c            gradbufc(k,i)=gradbufc(k,i)+gradbufc(k,j)
 827 c          enddo
 828 c        enddo
 829 c      enddo
 830 #ifdef DEBUG
 831       write (iout,*) "gradbufc after summing"
 832       do i=1,nres
 833         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 834       enddo
 835       call flush(iout)
 836 #endif
 837 #ifdef MPI
 838       endif
 839 #endif
 840       do k=1,3
 841         gradbufc(k,nres)=0.0d0
 842       enddo
 843       do i=-1,nct
 844         do j=1,3
 845 #ifdef SPLITELE
 846 C          print *,gradbufc(1,13)
 847 C          print *,welec*gelc(1,13)
 848 C          print *,wel_loc*gel_loc(1,13)
 849 C          print *,0.5d0*(wscp*gvdwc_scpp(1,13))
 850 C          print *,welec*gelc_long(1,13)+wvdwpp*gvdwpp(1,13)
 851 C          print *,wel_loc*gel_loc_long(1,13)
 852 C          print *,gradafm(1,13),"AFM"
 853           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+
 854      &                wel_loc*gel_loc(j,i)+
 855      &                0.5d0*(wscp*gvdwc_scpp(j,i)+
 856      &                welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+
 857      &                wel_loc*gel_loc_long(j,i)+
 858      &                wcorr*gradcorr_long(j,i)+
 859      &                wcorr5*gradcorr5_long(j,i)+
 860      &                wcorr6*gradcorr6_long(j,i)+
 861      &                wturn6*gcorr6_turn_long(j,i))+
 862      &                wbond*gradb(j,i)+
 863      &                wcorr*gradcorr(j,i)+
 864      &                wturn3*gcorr3_turn(j,i)+
 865      &                wturn4*gcorr4_turn(j,i)+
 866      &                wcorr5*gradcorr5(j,i)+
 867      &                wcorr6*gradcorr6(j,i)+
 868      &                wturn6*gcorr6_turn(j,i)+
 869      &                wsccor*gsccorc(j,i)
 870      &               +wscloc*gscloc(j,i)
 871      &               +wliptran*gliptranc(j,i)
 872      &                +gradafm(j,i)
 873      &                 +welec*gshieldc(j,i)
 874      &                 +welec*gshieldc_loc(j,i)
 875      &                 +wcorr*gshieldc_ec(j,i)
 876      &                 +wcorr*gshieldc_loc_ec(j,i)
 877      &                 +wturn3*gshieldc_t3(j,i)
 878      &                 +wturn3*gshieldc_loc_t3(j,i)
 879      &                 +wturn4*gshieldc_t4(j,i)
 880      &                 +wturn4*gshieldc_loc_t4(j,i)
 881      &                 +wel_loc*gshieldc_ll(j,i)
 882      &                 +wel_loc*gshieldc_loc_ll(j,i)
 883      &                +wtube*gg_tube(j,i)
 884
 885 #else
 886           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+
 887      &                wel_loc*gel_loc(j,i)+
 888      &                0.5d0*(wscp*gvdwc_scpp(j,i)+
 889      &                welec*gelc_long(j,i)+
 890      &                wel_loc*gel_loc_long(j,i)+
 891      &                wcorr*gcorr_long(j,i)+
 892      &                wcorr5*gradcorr5_long(j,i)+
 893      &                wcorr6*gradcorr6_long(j,i)+
 894      &                wturn6*gcorr6_turn_long(j,i))+
 895      &                wbond*gradb(j,i)+
 896      &                wcorr*gradcorr(j,i)+
 897      &                wturn3*gcorr3_turn(j,i)+
 898      &                wturn4*gcorr4_turn(j,i)+
 899      &                wcorr5*gradcorr5(j,i)+
 900      &                wcorr6*gradcorr6(j,i)+
 901      &                wturn6*gcorr6_turn(j,i)+
 902      &                wsccor*gsccorc(j,i)
 903      &               +wscloc*gscloc(j,i)
 904      &               +wliptran*gliptranc(j,i)
 905      &                +gradafm(j,i)
 906      &                 +welec*gshieldc(j,i)
 907      &                 +welec*gshieldc_loc(j,i)
 908      &                 +wcorr*gshieldc_ec(j,i)
 909      &                 +wcorr*gshieldc_loc_ec(j,i)
 910      &                 +wturn3*gshieldc_t3(j,i)
 911      &                 +wturn3*gshieldc_loc_t3(j,i)
 912      &                 +wturn4*gshieldc_t4(j,i)
 913      &                 +wturn4*gshieldc_loc_t4(j,i)
 914      &                 +wel_loc*gshieldc_ll(j,i)
 915      &                 +wel_loc*gshieldc_loc_ll(j,i)
 916      &                +wtube*gg_tube(j,i)
 917
 918
 919 #endif
 920           gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+
 921      &                  wbond*gradbx(j,i)+
 922      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
 923      &                  wsccor*gsccorx(j,i)
 924      &                 +wscloc*gsclocx(j,i)
 925      &                 +wliptran*gliptranx(j,i)
 926      &                 +welec*gshieldx(j,i)
 927      &                 +wcorr*gshieldx_ec(j,i)
 928      &                 +wturn3*gshieldx_t3(j,i)
 929      &                 +wturn4*gshieldx_t4(j,i)
 930      &                 +wel_loc*gshieldx_ll(j,i)
 931      &                 +wtube*gg_tube_sc(j,i)
 932      &                 +wsaxs*gsaxsx(j,i)
 933
 934
 935
 936         enddo
 937       enddo
 938       if (constr_homology.gt.0) then
 939         do i=1,nct
 940           do j=1,3
 941             gradc(j,i,icg)=gradc(j,i,icg)+duscdiff(j,i)
 942             gradx(j,i,icg)=gradx(j,i,icg)+duscdiffx(j,i)
 943           enddo
 944         enddo
 945       endif
 946 #ifdef DEBUG
 947       write (iout,*) "gradc gradx gloc after adding"
 948       do i=1,nres
 949         write (iout,'(i5,3f10.5,5x,3f10.5,5x,f10.5)')
 950      &   i,(gradc(j,i,icg),j=1,3),(gradx(j,i,icg),j=1,3),gloc(i,icg)
 951       enddo
 952 #endif
 953 #ifdef DEBUG
 954       write (iout,*) "gloc before adding corr"
 955       do i=1,4*nres
 956         write (iout,*) i,gloc(i,icg)
 957       enddo
 958 #endif
 959       do i=1,nres-3
 960         gloc(i,icg)=gloc(i,icg)+wcorr*gcorr_loc(i)
 961      &   +wcorr5*g_corr5_loc(i)
 962      &   +wcorr6*g_corr6_loc(i)
 963      &   +wturn4*gel_loc_turn4(i)
 964      &   +wturn3*gel_loc_turn3(i)
 965      &   +wturn6*gel_loc_turn6(i)
 966      &   +wel_loc*gel_loc_loc(i)
 967       enddo
 968 #ifdef DEBUG
 969       write (iout,*) "gloc after adding corr"
 970       do i=1,4*nres
 971         write (iout,*) i,gloc(i,icg)
 972       enddo
 973 #endif
 974 #ifdef MPI
 975       if (nfgtasks.gt.1) then
 976         do j=1,3
 977           do i=1,nres
 978             gradbufc(j,i)=gradc(j,i,icg)
 979             gradbufx(j,i)=gradx(j,i,icg)
 980           enddo
 981         enddo
 982         do i=1,4*nres
 983           glocbuf(i)=gloc(i,icg)
 984         enddo
 985 c#define DEBUG
 986 #ifdef DEBUG
 987       write (iout,*) "gloc_sc before reduce"
 988       do i=1,nres
 989        do j=1,1
 990         write (iout,*) i,j,gloc_sc(j,i,icg)
 991        enddo
 992       enddo
 993 #endif
 994 c#undef DEBUG
 995         do i=1,nres
 996          do j=1,3
 997           gloc_scbuf(j,i)=gloc_sc(j,i,icg)
 998          enddo
 999         enddo
1000         time00=MPI_Wtime()
1001         call MPI_Barrier(FG_COMM,IERR)
1002         time_barrier_g=time_barrier_g+MPI_Wtime()-time00
1003         time00=MPI_Wtime()
1004         call MPI_Reduce(gradbufc(1,1),gradc(1,1,icg),3*nres,
1005      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
1006         call MPI_Reduce(gradbufx(1,1),gradx(1,1,icg),3*nres,
1007      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
1008         call MPI_Reduce(glocbuf(1),gloc(1,icg),4*nres,
1009      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
1010         time_reduce=time_reduce+MPI_Wtime()-time00
1011         call MPI_Reduce(gloc_scbuf(1,1),gloc_sc(1,1,icg),3*nres,
1012      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
1013         time_reduce=time_reduce+MPI_Wtime()-time00
1014 #ifdef DEBUG
1015       write (iout,*) "gradc after reduce"
1016       do i=1,nres
1017        do j=1,3
1018         write (iout,*) i,j,gradc(j,i,icg)
1019        enddo
1020       enddo
1021 #endif
1022 #ifdef DEBUG
1023       write (iout,*) "gloc_sc after reduce"
1024       do i=1,nres
1025        do j=1,1
1026         write (iout,*) i,j,gloc_sc(j,i,icg)
1027        enddo
1028       enddo
1029 #endif
1030 #ifdef DEBUG
1031       write (iout,*) "gloc after reduce"
1032       do i=1,4*nres
1033         write (iout,*) i,gloc(i,icg)
1034       enddo
1035 #endif
1036       endif
1037 #endif
1038       if (gnorm_check) then
1039 c
1040 c Compute the maximum elements of the gradient
1041 c
1042       gvdwc_max=0.0d0
1043       gvdwc_scp_max=0.0d0
1044       gelc_max=0.0d0
1045       gvdwpp_max=0.0d0
1046       gradb_max=0.0d0
1047       ghpbc_max=0.0d0
1048       gradcorr_max=0.0d0
1049       gel_loc_max=0.0d0
1050       gcorr3_turn_max=0.0d0
1051       gcorr4_turn_max=0.0d0
1052       gradcorr5_max=0.0d0
1053       gradcorr6_max=0.0d0
1054       gcorr6_turn_max=0.0d0
1055       gsccorc_max=0.0d0
1056       gscloc_max=0.0d0
1057       gvdwx_max=0.0d0
1058       gradx_scp_max=0.0d0
1059       ghpbx_max=0.0d0
1060       gradxorr_max=0.0d0
1061       gsccorx_max=0.0d0
1062       gsclocx_max=0.0d0
1063       do i=1,nct
1064         gvdwc_norm=dsqrt(scalar(gvdwc(1,i),gvdwc(1,i)))
1065         if (gvdwc_norm.gt.gvdwc_max) gvdwc_max=gvdwc_norm
1066         gvdwc_scp_norm=dsqrt(scalar(gvdwc_scp(1,i),gvdwc_scp(1,i)))
1067         if (gvdwc_scp_norm.gt.gvdwc_scp_max)
1068      &   gvdwc_scp_max=gvdwc_scp_norm
1069         gelc_norm=dsqrt(scalar(gelc(1,i),gelc(1,i)))
1070         if (gelc_norm.gt.gelc_max) gelc_max=gelc_norm
1071         gvdwpp_norm=dsqrt(scalar(gvdwpp(1,i),gvdwpp(1,i)))
1072         if (gvdwpp_norm.gt.gvdwpp_max) gvdwpp_max=gvdwpp_norm
1073         gradb_norm=dsqrt(scalar(gradb(1,i),gradb(1,i)))
1074         if (gradb_norm.gt.gradb_max) gradb_max=gradb_norm
1075         ghpbc_norm=dsqrt(scalar(ghpbc(1,i),ghpbc(1,i)))
1076         if (ghpbc_norm.gt.ghpbc_max) ghpbc_max=ghpbc_norm
1077         gradcorr_norm=dsqrt(scalar(gradcorr(1,i),gradcorr(1,i)))
1078         if (gradcorr_norm.gt.gradcorr_max) gradcorr_max=gradcorr_norm
1079         gel_loc_norm=dsqrt(scalar(gel_loc(1,i),gel_loc(1,i)))
1080         if (gel_loc_norm.gt.gel_loc_max) gel_loc_max=gel_loc_norm
1081         gcorr3_turn_norm=dsqrt(scalar(gcorr3_turn(1,i),
1082      &    gcorr3_turn(1,i)))
1083         if (gcorr3_turn_norm.gt.gcorr3_turn_max)
1084      &    gcorr3_turn_max=gcorr3_turn_norm
1085         gcorr4_turn_norm=dsqrt(scalar(gcorr4_turn(1,i),
1086      &    gcorr4_turn(1,i)))
1087         if (gcorr4_turn_norm.gt.gcorr4_turn_max)
1088      &    gcorr4_turn_max=gcorr4_turn_norm
1089         gradcorr5_norm=dsqrt(scalar(gradcorr5(1,i),gradcorr5(1,i)))
1090         if (gradcorr5_norm.gt.gradcorr5_max)
1091      &    gradcorr5_max=gradcorr5_norm
1092         gradcorr6_norm=dsqrt(scalar(gradcorr6(1,i),gradcorr6(1,i)))
1093         if (gradcorr6_norm.gt.gradcorr6_max) gcorr6_max=gradcorr6_norm
1094         gcorr6_turn_norm=dsqrt(scalar(gcorr6_turn(1,i),
1095      &    gcorr6_turn(1,i)))
1096         if (gcorr6_turn_norm.gt.gcorr6_turn_max)
1097      &    gcorr6_turn_max=gcorr6_turn_norm
1098         gsccorr_norm=dsqrt(scalar(gsccorc(1,i),gsccorc(1,i)))
1099         if (gsccorr_norm.gt.gsccorr_max) gsccorr_max=gsccorr_norm
1100         gscloc_norm=dsqrt(scalar(gscloc(1,i),gscloc(1,i)))
1101         if (gscloc_norm.gt.gscloc_max) gscloc_max=gscloc_norm
1102         gvdwx_norm=dsqrt(scalar(gvdwx(1,i),gvdwx(1,i)))
1103         if (gvdwx_norm.gt.gvdwx_max) gvdwx_max=gvdwx_norm
1104         gradx_scp_norm=dsqrt(scalar(gradx_scp(1,i),gradx_scp(1,i)))
1105         if (gradx_scp_norm.gt.gradx_scp_max)
1106      &    gradx_scp_max=gradx_scp_norm
1107         ghpbx_norm=dsqrt(scalar(ghpbx(1,i),ghpbx(1,i)))
1108         if (ghpbx_norm.gt.ghpbx_max) ghpbx_max=ghpbx_norm
1109         gradxorr_norm=dsqrt(scalar(gradxorr(1,i),gradxorr(1,i)))
1110         if (gradxorr_norm.gt.gradxorr_max) gradxorr_max=gradxorr_norm
1111         gsccorrx_norm=dsqrt(scalar(gsccorx(1,i),gsccorx(1,i)))
1112         if (gsccorrx_norm.gt.gsccorrx_max) gsccorrx_max=gsccorrx_norm
1113         gsclocx_norm=dsqrt(scalar(gsclocx(1,i),gsclocx(1,i)))
1114         if (gsclocx_norm.gt.gsclocx_max) gsclocx_max=gsclocx_norm
1115       enddo
1116       if (gradout) then
1117 #if (defined AIX || defined CRAY)
1118         open(istat,file=statname,position="append")
1119 #else
1120         open(istat,file=statname,access="append")
1121 #endif
1122         write (istat,'(1h#,21f10.2)') gvdwc_max,gvdwc_scp_max,
1123      &     gelc_max,gvdwpp_max,gradb_max,ghpbc_max,
1124      &     gradcorr_max,gel_loc_max,gcorr3_turn_max,gcorr4_turn_max,
1125      &     gradcorr5_max,gradcorr6_max,gcorr6_turn_max,gsccorc_max,
1126      &     gscloc_max,gvdwx_max,gradx_scp_max,ghpbx_max,gradxorr_max,
1127      &     gsccorx_max,gsclocx_max
1128         close(istat)
1129         if (gvdwc_max.gt.1.0d4) then
1130           write (iout,*) "gvdwc gvdwx gradb gradbx"
1131           do i=nnt,nct
1132             write(iout,'(i5,4(3f10.2,5x))') i,(gvdwc(j,i),gvdwx(j,i),
1133      &        gradb(j,i),gradbx(j,i),j=1,3)
1134           enddo
1135           call pdbout(0.0d0,'cipiszcze',iout)
1136           call flush(iout)
1137         endif
1138       endif
1139       endif
1140 #ifdef DEBUG
1141       write (iout,*) "gradc gradx gloc"
1142       do i=1,nres
1143         write (iout,'(i5,3f10.5,5x,3f10.5,5x,f10.5)')
1144      &   i,(gradc(j,i,icg),j=1,3),(gradx(j,i,icg),j=1,3),gloc(i,icg)
1145       enddo
1146 #endif
1147 #ifdef TIMING
1148       time_sumgradient=time_sumgradient+MPI_Wtime()-time01
1149 #endif
1150       return
1151       end
1152 c-------------------------------------------------------------------------------
1153       subroutine rescale_weights(t_bath)
1154       implicit real*8 (a-h,o-z)
1155       include 'DIMENSIONS'
1156       include 'COMMON.IOUNITS'
1157       include 'COMMON.FFIELD'
1158       include 'COMMON.SBRIDGE'
1159       include 'COMMON.CONTROL'
1160       double precision kfac /2.4d0/
1161       double precision x,x2,x3,x4,x5,licznik /1.12692801104297249644/
1162 c      facT=temp0/t_bath
1163 c      facT=2*temp0/(t_bath+temp0)
1164       if (rescale_mode.eq.0) then
1165         facT=1.0d0
1166         facT2=1.0d0
1167         facT3=1.0d0
1168         facT4=1.0d0
1169         facT5=1.0d0
1170       else if (rescale_mode.eq.1) then
1171         facT=kfac/(kfac-1.0d0+t_bath/temp0)
1172         facT2=kfac**2/(kfac**2-1.0d0+(t_bath/temp0)**2)
1173         facT3=kfac**3/(kfac**3-1.0d0+(t_bath/temp0)**3)
1174         facT4=kfac**4/(kfac**4-1.0d0+(t_bath/temp0)**4)
1175         facT5=kfac**5/(kfac**5-1.0d0+(t_bath/temp0)**5)
1176       else if (rescale_mode.eq.2) then
1177         x=t_bath/temp0
1178         x2=x*x
1179         x3=x2*x
1180         x4=x3*x
1181         x5=x4*x
1182         facT=licznik/dlog(dexp(x)+dexp(-x))
1183         facT2=licznik/dlog(dexp(x2)+dexp(-x2))
1184         facT3=licznik/dlog(dexp(x3)+dexp(-x3))
1185         facT4=licznik/dlog(dexp(x4)+dexp(-x4))
1186         facT5=licznik/dlog(dexp(x5)+dexp(-x5))
1187       else
1188         write (iout,*) "Wrong RESCALE_MODE",rescale_mode
1189         write (*,*) "Wrong RESCALE_MODE",rescale_mode
1190 #ifdef MPI
1191        call MPI_Finalize(MPI_COMM_WORLD,IERROR)
1192 #endif
1193        stop 555
1194       endif
1195       if (shield_mode.gt.0) then
1196        wscp=weights(2)*fact
1197        wsc=weights(1)*fact
1198        wvdwpp=weights(16)*fact
1199       endif
1200       welec=weights(3)*fact
1201       wcorr=weights(4)*fact3
1202       wcorr5=weights(5)*fact4
1203       wcorr6=weights(6)*fact5
1204       wel_loc=weights(7)*fact2
1205       wturn3=weights(8)*fact2
1206       wturn4=weights(9)*fact3
1207       wturn6=weights(10)*fact5
1208       wtor=weights(13)*fact
1209       wtor_d=weights(14)*fact2
1210       wsccor=weights(21)*fact
1211       if (scale_umb) wumb=t_bath/temp0
1212 c      write (iout,*) "scale_umb",scale_umb
1213 c      write (iout,*) "t_bath",t_bath," temp0",temp0," wumb",wumb
1214
1215       return
1216       end
1217 C------------------------------------------------------------------------
1218       subroutine enerprint(energia)
1219       implicit real*8 (a-h,o-z)
1220       include 'DIMENSIONS'
1221       include 'COMMON.IOUNITS'
1222       include 'COMMON.FFIELD'
1223       include 'COMMON.SBRIDGE'
1224       include 'COMMON.MD'
1225       double precision energia(0:n_ene)
1226       etot=energia(0)
1227       evdw=energia(1)
1228       evdw2=energia(2)
1229 #ifdef SCP14
1230       evdw2=energia(2)+energia(18)
1231 #else
1232       evdw2=energia(2)
1233 #endif
1234       ees=energia(3)
1235 #ifdef SPLITELE
1236       evdw1=energia(16)
1237 #endif
1238       ecorr=energia(4)
1239       ecorr5=energia(5)
1240       ecorr6=energia(6)
1241       eel_loc=energia(7)
1242       eello_turn3=energia(8)
1243       eello_turn4=energia(9)
1244       eello_turn6=energia(10)
1245       ebe=energia(11)
1246       escloc=energia(12)
1247       etors=energia(13)
1248       etors_d=energia(14)
1249       ehpb=energia(15)
1250       edihcnstr=energia(19)
1251       estr=energia(17)
1252       Uconst=energia(20)
1253       esccor=energia(21)
1254       eliptran=energia(22)
1255       Eafmforce=energia(23)
1256       ethetacnstr=energia(24)
1257       etube=energia(25)
1258       esaxs=energia(26)
1259       ehomology_constr=energia(27)
1260 C     Bartek
1261       edfadis = energia(28)
1262       edfator = energia(29)
1263       edfanei = energia(30)
1264       edfabet = energia(31)
1265 #ifdef SPLITELE
1266       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,evdw1,wvdwpp,
1267      &  estr,wbond,ebe,wang,
1268      &  escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,
1269      &  ecorr,wcorr,
1270      &  ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,
1271      &  eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccor,edihcnstr,
1272      &  ethetacnstr,ebr*nss,Uconst,wumb,eliptran,wliptran,Eafmforc,
1273      &  etube,wtube,esaxs,wsaxs,ehomology_constr,
1274      &  edfadis,wdfa_dist,edfator,wdfa_tor,edfanei,wdfa_nei,
1275      &  edfabet,wdfa_beta,
1276      &  etot
1277    10 format (/'Virtual-chain energies:'//
1278      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pE16.6,' (SC-SC)'/
1279      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pE16.6,' (SC-p)'/
1280      & 'EES=   ',1pE16.6,' WEIGHT=',1pE16.6,' (p-p)'/
1281      & 'EVDWPP=',1pE16.6,' WEIGHT=',1pE16.6,' (p-p VDW)'/
1282      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pE16.6,' (stretching)'/
1283      & 'EBE=   ',1pE16.6,' WEIGHT=',1pE16.6,' (bending)'/
1284      & 'ESC=   ',1pE16.6,' WEIGHT=',1pE16.6,' (SC local)'/
1285      & 'ETORS= ',1pE16.6,' WEIGHT=',1pE16.6,' (torsional)'/
1286      & 'ETORSD=',1pE16.6,' WEIGHT=',1pE16.6,' (double torsional)'/
1287      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pE16.6,
1288      & ' (SS bridges & dist. cnstr.)'/
1289      & 'ECORR4=',1pE16.6,' WEIGHT=',1pE16.6,' (multi-body)'/
1290      & 'ECORR5=',1pE16.6,' WEIGHT=',1pE16.6,' (multi-body)'/
1291      & 'ECORR6=',1pE16.6,' WEIGHT=',1pE16.6,' (multi-body)'/
1292      & 'EELLO= ',1pE16.6,' WEIGHT=',1pE16.6,' (electrostatic-local)'/
1293      & 'ETURN3=',1pE16.6,' WEIGHT=',1pE16.6,' (turns, 3rd order)'/
1294      & 'ETURN4=',1pE16.6,' WEIGHT=',1pE16.6,' (turns, 4th order)'/
1295      & 'ETURN6=',1pE16.6,' WEIGHT=',1pE16.6,' (turns, 6th order)'/
1296      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pE16.6,' (backbone-rotamer corr)'/
1297      & 'EDIHC= ',1pE16.6,' (virtual-bond dihedral angle restraints)'/
1298      & 'ETHETC=',1pE16.6,' (virtual-bond angle restraints)'/
1299      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
1300      & 'UCONST=',1pE16.6,' WEIGHT=',1pE16.6' (umbrella restraints)'/
1301      & 'ELT=   ',1pE16.6,' WEIGHT=',1pE16.6,' (Lipid transfer)'/
1302      & 'EAFM=  ',1pE16.6,' (atomic-force microscopy)'/
1303      & 'ETUBE= ',1pE16.6,' WEIGHT=',1pE16.6,' (tube confinment)'/
1304      & 'E_SAXS=',1pE16.6,' WEIGHT=',1pE16.6,' (SAXS restraints)'/
1305      & 'H_CONS=',1pE16.6,' (Homology model constraints energy)'/
1306      & 'EDFAD= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA distance energy)'/
1307      & 'EDFAT= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA torsion energy)'/
1308      & 'EDFAN= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA NCa energy)'/
1309      & 'EDFAB= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA Beta energy)'/
1310      & 'ETOT=  ',1pE16.6,' (total)')
1311
1312 #else
1313       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,
1314      &  estr,wbond,ebe,wang,
1315      &  escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,
1316      &  ecorr,wcorr,
1317      &  ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,
1318      &  eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccor,edihcnstr,
1319      &  ethetacnstr,ebr*nss,Uconst,wumb,eliptran,wliptran,Eafmforc,
1320      &  etube,wtube,esaxs,wsaxs,ehomology_constr,
1321      &  edfadis,wdfa_dist,edfator,wdfa_tor,edfanei,wdfa_nei,
1322      &  edfabet,wdfa_beta,
1323      &  etot
1324    10 format (/'Virtual-chain energies:'//
1325      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pE16.6,' (SC-SC)'/
1326      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pE16.6,' (SC-p)'/
1327      & 'EES=   ',1pE16.6,' WEIGHT=',1pE16.6,' (p-p)'/
1328      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pE16.6,' (stretching)'/
1329      & 'EBE=   ',1pE16.6,' WEIGHT=',1pE16.6,' (bending)'/
1330      & 'ESC=   ',1pE16.6,' WEIGHT=',1pE16.6,' (SC local)'/
1331      & 'ETORS= ',1pE16.6,' WEIGHT=',1pE16.6,' (torsional)'/
1332      & 'ETORSD=',1pE16.6,' WEIGHT=',1pE16.6,' (double torsional)'/
1333      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pE16.6,
1334      & ' (SS bridges & dist. restr.)'/
1335      & 'ECORR4=',1pE16.6,' WEIGHT=',1pE16.6,' (multi-body)'/
1336      & 'ECORR5=',1pE16.6,' WEIGHT=',1pE16.6,' (multi-body)'/
1337      & 'ECORR6=',1pE16.6,' WEIGHT=',1pE16.6,' (multi-body)'/
1338      & 'EELLO= ',1pE16.6,' WEIGHT=',1pE16.6,' (electrostatic-local)'/
1339      & 'ETURN3=',1pE16.6,' WEIGHT=',1pE16.6,' (turns, 3rd order)'/
1340      & 'ETURN4=',1pE16.6,' WEIGHT=',1pE16.6,' (turns, 4th order)'/
1341      & 'ETURN6=',1pE16.6,' WEIGHT=',1pE16.6,' (turns, 6th order)'/
1342      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pE16.6,' (backbone-rotamer corr)'/
1343      & 'EDIHC= ',1pE16.6,' (virtual-bond dihedral angle restraints)'/
1344      & 'ETHETC=',1pE16.6,' (virtual-bond angle restraints)'/
1345      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
1346      & 'UCONST=',1pE16.6,' WEIGHT=',1pE16.6' (umbrella restraints)'/
1347      & 'ELT=   ',1pE16.6,' WEIGHT=',1pE16.6,' (Lipid transfer)'/
1348      & 'EAFM=  ',1pE16.6,' (atomic-force microscopy)'/
1349      & 'ETUBE= ',1pE16.6,' WEIGHT=',1pE16.6,' (tube confinment)'/
1350      & 'E_SAXS=',1pE16.6,' WEIGHT=',1pE16.6,' (SAXS restraints)'/
1351      & 'H_CONS=',1pE16.6,' (Homology model constraints energy)'/
1352      & 'EDFAD= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA distance energy)'/
1353      & 'EDFAT= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA torsion energy)'/
1354      & 'EDFAN= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA NCa energy)'/
1355      & 'EDFAB= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA Beta energy)'/
1356      & 'ETOT=  ',1pE16.6,' (total)')
1357 #endif
1358       return
1359       end
1360 C-----------------------------------------------------------------------
1361       subroutine elj(evdw)
1362 C
1363 C This subroutine calculates the interaction energy of nonbonded side chains
1364 C assuming the LJ potential of interaction.
1365 C
1366       implicit real*8 (a-h,o-z)
1367       include 'DIMENSIONS'
1368       parameter (accur=1.0d-10)
1369       include 'COMMON.GEO'
1370       include 'COMMON.VAR'
1371       include 'COMMON.LOCAL'
1372       include 'COMMON.CHAIN'
1373       include 'COMMON.DERIV'
1374       include 'COMMON.INTERACT'
1375       include 'COMMON.TORSION'
1376       include 'COMMON.SBRIDGE'
1377       include 'COMMON.NAMES'
1378       include 'COMMON.IOUNITS'
1379       include 'COMMON.CONTACTS'
1380       dimension gg(3)
1381 c      write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
1382       evdw=0.0D0
1383       do i=iatsc_s,iatsc_e
1384         itypi=iabs(itype(i))
1385         if (itypi.eq.ntyp1) cycle
1386         itypi1=iabs(itype(i+1))
1387         xi=c(1,nres+i)
1388         yi=c(2,nres+i)
1389         zi=c(3,nres+i)
1390 C Change 12/1/95
1391         num_conti=0
1392 C
1393 C Calculate SC interaction energy.
1394 C
1395         do iint=1,nint_gr(i)
1396 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
1397 cd   &                  'iend=',iend(i,iint)
1398           do j=istart(i,iint),iend(i,iint)
1399             itypj=iabs(itype(j))
1400             if (itypj.eq.ntyp1) cycle
1401             xj=c(1,nres+j)-xi
1402             yj=c(2,nres+j)-yi
1403             zj=c(3,nres+j)-zi
1404 C Change 12/1/95 to calculate four-body interactions
1405             rij=xj*xj+yj*yj+zj*zj
1406             rrij=1.0D0/rij
1407 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
1408             eps0ij=eps(itypi,itypj)
1409             fac=rrij**expon2
1410 C have you changed here?
1411             e1=fac*fac*aa
1412             e2=fac*bb
1413             evdwij=e1+e2
1414 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1415 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1416 cd          write (iout,'(2(a3,i3,2x),6(1pd12.4)/2(3(1pd12.4),5x)/)')
1417 cd   &        restyp(itypi),i,restyp(itypj),j,a(itypi,itypj),
1418 cd   &        bb(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,epsi,sigm,
1419 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1420             evdw=evdw+evdwij
1421 C
1422 C Calculate the components of the gradient in DC and X
1423 C
1424             fac=-rrij*(e1+evdwij)
1425             gg(1)=xj*fac
1426             gg(2)=yj*fac
1427             gg(3)=zj*fac
1428             do k=1,3
1429               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1430               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1431               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1432               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1433             enddo
1434 cgrad            do k=i,j-1
1435 cgrad              do l=1,3
1436 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1437 cgrad              enddo
1438 cgrad            enddo
1439 C
1440 C 12/1/95, revised on 5/20/97
1441 C
1442 C Calculate the contact function. The ith column of the array JCONT will
1443 C contain the numbers of atoms that make contacts with the atom I (of numbers
1444 C greater than I). The arrays FACONT and GACONT will contain the values of
1445 C the contact function and its derivative.
1446 C
1447 C Uncomment next line, if the correlation interactions include EVDW explicitly.
1448 c           if (j.gt.i+1 .and. evdwij.le.0.0D0) then
1449 C Uncomment next line, if the correlation interactions are contact function only
1450             if (j.gt.i+1.and. eps0ij.gt.0.0D0) then
1451               rij=dsqrt(rij)
1452               sigij=sigma(itypi,itypj)
1453               r0ij=rs0(itypi,itypj)
1454 C
1455 C Check whether the SC's are not too far to make a contact.
1456 C
1457               rcut=1.5d0*r0ij
1458               call gcont(rij,rcut,1.0d0,0.2d0*rcut,fcont,fprimcont)
1459 C Add a new contact, if the SC's are close enough, but not too close (r<sigma).
1460 C
1461               if (fcont.gt.0.0D0) then
1462 C If the SC-SC distance if close to sigma, apply spline.
1463 cAdam           call gcont(-rij,-1.03d0*sigij,2.0d0*sigij,1.0d0,
1464 cAdam &             fcont1,fprimcont1)
1465 cAdam           fcont1=1.0d0-fcont1
1466 cAdam           if (fcont1.gt.0.0d0) then
1467 cAdam             fprimcont=fprimcont*fcont1+fcont*fprimcont1
1468 cAdam             fcont=fcont*fcont1
1469 cAdam           endif
1470 C Uncomment following 4 lines to have the geometric average of the epsilon0's
1471 cga             eps0ij=1.0d0/dsqrt(eps0ij)
1472 cga             do k=1,3
1473 cga               gg(k)=gg(k)*eps0ij
1474 cga             enddo
1475 cga             eps0ij=-evdwij*eps0ij
1476 C Uncomment for AL's type of SC correlation interactions.
1477 cadam           eps0ij=-evdwij
1478                 num_conti=num_conti+1
1479                 jcont(num_conti,i)=j
1480                 facont(num_conti,i)=fcont*eps0ij
1481                 fprimcont=eps0ij*fprimcont/rij
1482                 fcont=expon*fcont
1483 cAdam           gacont(1,num_conti,i)=-fprimcont*xj+fcont*gg(1)
1484 cAdam           gacont(2,num_conti,i)=-fprimcont*yj+fcont*gg(2)
1485 cAdam           gacont(3,num_conti,i)=-fprimcont*zj+fcont*gg(3)
1486 C Uncomment following 3 lines for Skolnick's type of SC correlation.
1487                 gacont(1,num_conti,i)=-fprimcont*xj
1488                 gacont(2,num_conti,i)=-fprimcont*yj
1489                 gacont(3,num_conti,i)=-fprimcont*zj
1490 cd              write (iout,'(2i5,2f10.5)') i,j,rij,facont(num_conti,i)
1491 cd              write (iout,'(2i3,3f10.5)')
1492 cd   &           i,j,(gacont(kk,num_conti,i),kk=1,3)
1493               endif
1494             endif
1495           enddo      ! j
1496         enddo        ! iint
1497 C Change 12/1/95
1498         num_cont(i)=num_conti
1499       enddo          ! i
1500       do i=1,nct
1501         do j=1,3
1502           gvdwc(j,i)=expon*gvdwc(j,i)
1503           gvdwx(j,i)=expon*gvdwx(j,i)
1504         enddo
1505       enddo
1506 C******************************************************************************
1507 C
1508 C                              N O T E !!!
1509 C
1510 C To save time, the factor of EXPON has been extracted from ALL components
1511 C of GVDWC and GRADX. Remember to multiply them by this factor before further
1512 C use!
1513 C
1514 C******************************************************************************
1515       return
1516       end
1517 C-----------------------------------------------------------------------------
1518       subroutine eljk(evdw)
1519 C
1520 C This subroutine calculates the interaction energy of nonbonded side chains
1521 C assuming the LJK potential of interaction.
1522 C
1523       implicit real*8 (a-h,o-z)
1524       include 'DIMENSIONS'
1525       include 'COMMON.GEO'
1526       include 'COMMON.VAR'
1527       include 'COMMON.LOCAL'
1528       include 'COMMON.CHAIN'
1529       include 'COMMON.DERIV'
1530       include 'COMMON.INTERACT'
1531       include 'COMMON.IOUNITS'
1532       include 'COMMON.NAMES'
1533       dimension gg(3)
1534       logical scheck
1535 c     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
1536       evdw=0.0D0
1537       do i=iatsc_s,iatsc_e
1538         itypi=iabs(itype(i))
1539         if (itypi.eq.ntyp1) cycle
1540         itypi1=iabs(itype(i+1))
1541         xi=c(1,nres+i)
1542         yi=c(2,nres+i)
1543         zi=c(3,nres+i)
1544 C
1545 C Calculate SC interaction energy.
1546 C
1547         do iint=1,nint_gr(i)
1548           do j=istart(i,iint),iend(i,iint)
1549             itypj=iabs(itype(j))
1550             if (itypj.eq.ntyp1) cycle
1551             xj=c(1,nres+j)-xi
1552             yj=c(2,nres+j)-yi
1553             zj=c(3,nres+j)-zi
1554             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1555             fac_augm=rrij**expon
1556             e_augm=augm(itypi,itypj)*fac_augm
1557             r_inv_ij=dsqrt(rrij)
1558             rij=1.0D0/r_inv_ij
1559             r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
1560             fac=r_shift_inv**expon
1561 C have you changed here?
1562             e1=fac*fac*aa
1563             e2=fac*bb
1564             evdwij=e_augm+e1+e2
1565 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1566 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1567 cd          write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
1568 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
1569 cd   &        bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
1570 cd   &        sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
1571 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1572             evdw=evdw+evdwij
1573 C
1574 C Calculate the components of the gradient in DC and X
1575 C
1576             fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
1577             gg(1)=xj*fac
1578             gg(2)=yj*fac
1579             gg(3)=zj*fac
1580             do k=1,3
1581               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1582               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1583               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1584               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1585             enddo
1586 cgrad            do k=i,j-1
1587 cgrad              do l=1,3
1588 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1589 cgrad              enddo
1590 cgrad            enddo
1591           enddo      ! j
1592         enddo        ! iint
1593       enddo          ! i
1594       do i=1,nct
1595         do j=1,3
1596           gvdwc(j,i)=expon*gvdwc(j,i)
1597           gvdwx(j,i)=expon*gvdwx(j,i)
1598         enddo
1599       enddo
1600       return
1601       end
1602 C-----------------------------------------------------------------------------
1603       subroutine ebp(evdw)
1604 C
1605 C This subroutine calculates the interaction energy of nonbonded side chains
1606 C assuming the Berne-Pechukas potential of interaction.
1607 C
1608       implicit real*8 (a-h,o-z)
1609       include 'DIMENSIONS'
1610       include 'COMMON.GEO'
1611       include 'COMMON.VAR'
1612       include 'COMMON.LOCAL'
1613       include 'COMMON.CHAIN'
1614       include 'COMMON.DERIV'
1615       include 'COMMON.NAMES'
1616       include 'COMMON.INTERACT'
1617       include 'COMMON.IOUNITS'
1618       include 'COMMON.CALC'
1619       common /srutu/ icall
1620 c     double precision rrsave(maxdim)
1621       logical lprn
1622       evdw=0.0D0
1623 c     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
1624       evdw=0.0D0
1625 c     if (icall.eq.0) then
1626 c       lprn=.true.
1627 c     else
1628         lprn=.false.
1629 c     endif
1630       ind=0
1631       do i=iatsc_s,iatsc_e
1632         itypi=iabs(itype(i))
1633         if (itypi.eq.ntyp1) cycle
1634         itypi1=iabs(itype(i+1))
1635         xi=c(1,nres+i)
1636         yi=c(2,nres+i)
1637         zi=c(3,nres+i)
1638         dxi=dc_norm(1,nres+i)
1639         dyi=dc_norm(2,nres+i)
1640         dzi=dc_norm(3,nres+i)
1641 c        dsci_inv=dsc_inv(itypi)
1642         dsci_inv=vbld_inv(i+nres)
1643 C
1644 C Calculate SC interaction energy.
1645 C
1646         do iint=1,nint_gr(i)
1647           do j=istart(i,iint),iend(i,iint)
1648             ind=ind+1
1649             itypj=iabs(itype(j))
1650             if (itypj.eq.ntyp1) cycle
1651 c            dscj_inv=dsc_inv(itypj)
1652             dscj_inv=vbld_inv(j+nres)
1653             chi1=chi(itypi,itypj)
1654             chi2=chi(itypj,itypi)
1655             chi12=chi1*chi2
1656             chip1=chip(itypi)
1657             chip2=chip(itypj)
1658             chip12=chip1*chip2
1659             alf1=alp(itypi)
1660             alf2=alp(itypj)
1661             alf12=0.5D0*(alf1+alf2)
1662 C For diagnostics only!!!
1663 c           chi1=0.0D0
1664 c           chi2=0.0D0
1665 c           chi12=0.0D0
1666 c           chip1=0.0D0
1667 c           chip2=0.0D0
1668 c           chip12=0.0D0
1669 c           alf1=0.0D0
1670 c           alf2=0.0D0
1671 c           alf12=0.0D0
1672             xj=c(1,nres+j)-xi
1673             yj=c(2,nres+j)-yi
1674             zj=c(3,nres+j)-zi
1675             dxj=dc_norm(1,nres+j)
1676             dyj=dc_norm(2,nres+j)
1677             dzj=dc_norm(3,nres+j)
1678             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1679 cd          if (icall.eq.0) then
1680 cd            rrsave(ind)=rrij
1681 cd          else
1682 cd            rrij=rrsave(ind)
1683 cd          endif
1684             rij=dsqrt(rrij)
1685 C Calculate the angle-dependent terms of energy & contributions to derivatives.
1686             call sc_angular
1687 C Calculate whole angle-dependent part of epsilon and contributions
1688 C to its derivatives
1689 C have you changed here?
1690             fac=(rrij*sigsq)**expon2
1691             e1=fac*fac*aa
1692             e2=fac*bb
1693             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1694             eps2der=evdwij*eps3rt
1695             eps3der=evdwij*eps2rt
1696             evdwij=evdwij*eps2rt*eps3rt
1697             evdw=evdw+evdwij
1698             if (lprn) then
1699             sigm=dabs(aa/bb)**(1.0D0/6.0D0)
1700             epsi=bb**2/aa
1701 cd            write (iout,'(2(a3,i3,2x),15(0pf7.3))')
1702 cd     &        restyp(itypi),i,restyp(itypj),j,
1703 cd     &        epsi,sigm,chi1,chi2,chip1,chip2,
1704 cd     &        eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
1705 cd     &        om1,om2,om12,1.0D0/dsqrt(rrij),
1706 cd     &        evdwij
1707             endif
1708 C Calculate gradient components.
1709             e1=e1*eps1*eps2rt**2*eps3rt**2
1710             fac=-expon*(e1+evdwij)
1711             sigder=fac/sigsq
1712             fac=rrij*fac
1713 C Calculate radial part of the gradient
1714             gg(1)=xj*fac
1715             gg(2)=yj*fac
1716             gg(3)=zj*fac
1717 C Calculate the angular part of the gradient and sum add the contributions
1718 C to the appropriate components of the Cartesian gradient.
1719             call sc_grad
1720           enddo      ! j
1721         enddo        ! iint
1722       enddo          ! i
1723 c     stop
1724       return
1725       end
1726 C-----------------------------------------------------------------------------
1727       subroutine egb(evdw)
1728 C
1729 C This subroutine calculates the interaction energy of nonbonded side chains
1730 C assuming the Gay-Berne potential of interaction.
1731 C
1732       implicit real*8 (a-h,o-z)
1733       include 'DIMENSIONS'
1734       include 'COMMON.GEO'
1735       include 'COMMON.VAR'
1736       include 'COMMON.LOCAL'
1737       include 'COMMON.CHAIN'
1738       include 'COMMON.DERIV'
1739       include 'COMMON.NAMES'
1740       include 'COMMON.INTERACT'
1741       include 'COMMON.IOUNITS'
1742       include 'COMMON.CALC'
1743       include 'COMMON.CONTROL'
1744       include 'COMMON.SPLITELE'
1745       include 'COMMON.SBRIDGE'
1746       logical lprn
1747       integer xshift,yshift,zshift
1748
1749       evdw=0.0D0
1750 ccccc      energy_dec=.false.
1751 C      print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1752       evdw=0.0D0
1753       lprn=.false.
1754 c     if (icall.eq.0) lprn=.false.
1755       ind=0
1756 C the loop over all 27 posible neigbours (for xshift=0,yshift=0,zshift=0
1757 C we have the original box)
1758 C      do xshift=-1,1
1759 C      do yshift=-1,1
1760 C      do zshift=-1,1
1761       do i=iatsc_s,iatsc_e
1762         itypi=iabs(itype(i))
1763         if (itypi.eq.ntyp1) cycle
1764         itypi1=iabs(itype(i+1))
1765         xi=c(1,nres+i)
1766         yi=c(2,nres+i)
1767         zi=c(3,nres+i)
1768 C Return atom into box, boxxsize is size of box in x dimension
1769 c  134   continue
1770 c        if (xi.gt.((xshift+0.5d0)*boxxsize)) xi=xi-boxxsize
1771 c        if (xi.lt.((xshift-0.5d0)*boxxsize)) xi=xi+boxxsize
1772 C Condition for being inside the proper box
1773 c        if ((xi.gt.((xshift+0.5d0)*boxxsize)).or.
1774 c     &       (xi.lt.((xshift-0.5d0)*boxxsize))) then
1775 c        go to 134
1776 c        endif
1777 c  135   continue
1778 c        if (yi.gt.((yshift+0.5d0)*boxysize)) yi=yi-boxysize
1779 c        if (yi.lt.((yshift-0.5d0)*boxysize)) yi=yi+boxysize
1780 C Condition for being inside the proper box
1781 c        if ((yi.gt.((yshift+0.5d0)*boxysize)).or.
1782 c     &       (yi.lt.((yshift-0.5d0)*boxysize))) then
1783 c        go to 135
1784 c        endif
1785 c  136   continue
1786 c        if (zi.gt.((zshift+0.5d0)*boxzsize)) zi=zi-boxzsize
1787 c        if (zi.lt.((zshift-0.5d0)*boxzsize)) zi=zi+boxzsize
1788 C Condition for being inside the proper box
1789 c        if ((zi.gt.((zshift+0.5d0)*boxzsize)).or.
1790 c     &       (zi.lt.((zshift-0.5d0)*boxzsize))) then
1791 c        go to 136
1792 c        endif
1793           xi=mod(xi,boxxsize)
1794           if (xi.lt.0) xi=xi+boxxsize
1795           yi=mod(yi,boxysize)
1796           if (yi.lt.0) yi=yi+boxysize
1797           zi=mod(zi,boxzsize)
1798           if (zi.lt.0) zi=zi+boxzsize
1799 C define scaling factor for lipids
1800
1801 C        if (positi.le.0) positi=positi+boxzsize
1802 C        print *,i
1803 C first for peptide groups
1804 c for each residue check if it is in lipid or lipid water border area
1805        if ((zi.gt.bordlipbot)
1806      &.and.(zi.lt.bordliptop)) then
1807 C the energy transfer exist
1808         if (zi.lt.buflipbot) then
1809 C what fraction I am in
1810          fracinbuf=1.0d0-
1811      &        ((zi-bordlipbot)/lipbufthick)
1812 C lipbufthick is thickenes of lipid buffore
1813          sslipi=sscalelip(fracinbuf)
1814          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
1815         elseif (zi.gt.bufliptop) then
1816          fracinbuf=1.0d0-((bordliptop-zi)/lipbufthick)
1817          sslipi=sscalelip(fracinbuf)
1818          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
1819         else
1820          sslipi=1.0d0
1821          ssgradlipi=0.0
1822         endif
1823        else
1824          sslipi=0.0d0
1825          ssgradlipi=0.0
1826        endif
1827
1828 C          xi=xi+xshift*boxxsize
1829 C          yi=yi+yshift*boxysize
1830 C          zi=zi+zshift*boxzsize
1831
1832         dxi=dc_norm(1,nres+i)
1833         dyi=dc_norm(2,nres+i)
1834         dzi=dc_norm(3,nres+i)
1835 c        dsci_inv=dsc_inv(itypi)
1836         dsci_inv=vbld_inv(i+nres)
1837 c        write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)
1838 c        write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi
1839 C
1840 C Calculate SC interaction energy.
1841 C
1842         do iint=1,nint_gr(i)
1843           do j=istart(i,iint),iend(i,iint)
1844             IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN
1845
1846 c              write(iout,*) "PRZED ZWYKLE", evdwij
1847               call dyn_ssbond_ene(i,j,evdwij)
1848 c              write(iout,*) "PO ZWYKLE", evdwij
1849
1850               evdw=evdw+evdwij
1851               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)')
1852      &                        'evdw',i,j,evdwij,' ss'
1853 C triple bond artifac removal
1854              do k=j+1,iend(i,iint)
1855 C search over all next residues
1856               if (dyn_ss_mask(k)) then
1857 C check if they are cysteins
1858 C              write(iout,*) 'k=',k
1859
1860 c              write(iout,*) "PRZED TRI", evdwij
1861                evdwij_przed_tri=evdwij
1862               call triple_ssbond_ene(i,j,k,evdwij)
1863 c               if(evdwij_przed_tri.ne.evdwij) then
1864 c                 write (iout,*) "TRI:", evdwij, evdwij_przed_tri
1865 c               endif
1866
1867 c              write(iout,*) "PO TRI", evdwij
1868 C call the energy function that removes the artifical triple disulfide
1869 C bond the soubroutine is located in ssMD.F
1870               evdw=evdw+evdwij
1871               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)')
1872      &                        'evdw',i,j,evdwij,'tss'
1873               endif!dyn_ss_mask(k)
1874              enddo! k
1875             ELSE
1876             ind=ind+1
1877             itypj=iabs(itype(j))
1878             if (itypj.eq.ntyp1) cycle
1879 c            dscj_inv=dsc_inv(itypj)
1880             dscj_inv=vbld_inv(j+nres)
1881 c            write (iout,*) "j",j,dsc_inv(itypj),dscj_inv,
1882 c     &       1.0d0/vbld(j+nres)
1883 c            write (iout,*) "i",i," j", j," itype",itype(i),itype(j)
1884             sig0ij=sigma(itypi,itypj)
1885             chi1=chi(itypi,itypj)
1886             chi2=chi(itypj,itypi)
1887             chi12=chi1*chi2
1888             chip1=chip(itypi)
1889             chip2=chip(itypj)
1890             chip12=chip1*chip2
1891             alf1=alp(itypi)
1892             alf2=alp(itypj)
1893             alf12=0.5D0*(alf1+alf2)
1894 C For diagnostics only!!!
1895 c           chi1=0.0D0
1896 c           chi2=0.0D0
1897 c           chi12=0.0D0
1898 c           chip1=0.0D0
1899 c           chip2=0.0D0
1900 c           chip12=0.0D0
1901 c           alf1=0.0D0
1902 c           alf2=0.0D0
1903 c           alf12=0.0D0
1904             xj=c(1,nres+j)
1905             yj=c(2,nres+j)
1906             zj=c(3,nres+j)
1907 C Return atom J into box the original box
1908 c  137   continue
1909 c        if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
1910 c        if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
1911 C Condition for being inside the proper box
1912 c        if ((xj.gt.((0.5d0)*boxxsize)).or.
1913 c     &       (xj.lt.((-0.5d0)*boxxsize))) then
1914 c        go to 137
1915 c        endif
1916 c  138   continue
1917 c        if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
1918 c        if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
1919 C Condition for being inside the proper box
1920 c        if ((yj.gt.((0.5d0)*boxysize)).or.
1921 c     &       (yj.lt.((-0.5d0)*boxysize))) then
1922 c        go to 138
1923 c        endif
1924 c  139   continue
1925 c        if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
1926 c        if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
1927 C Condition for being inside the proper box
1928 c        if ((zj.gt.((0.5d0)*boxzsize)).or.
1929 c     &       (zj.lt.((-0.5d0)*boxzsize))) then
1930 c        go to 139
1931 c        endif
1932           xj=mod(xj,boxxsize)
1933           if (xj.lt.0) xj=xj+boxxsize
1934           yj=mod(yj,boxysize)
1935           if (yj.lt.0) yj=yj+boxysize
1936           zj=mod(zj,boxzsize)
1937           if (zj.lt.0) zj=zj+boxzsize
1938        if ((zj.gt.bordlipbot)
1939      &.and.(zj.lt.bordliptop)) then
1940 C the energy transfer exist
1941         if (zj.lt.buflipbot) then
1942 C what fraction I am in
1943          fracinbuf=1.0d0-
1944      &        ((zj-bordlipbot)/lipbufthick)
1945 C lipbufthick is thickenes of lipid buffore
1946          sslipj=sscalelip(fracinbuf)
1947          ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
1948         elseif (zj.gt.bufliptop) then
1949          fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
1950          sslipj=sscalelip(fracinbuf)
1951          ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
1952         else
1953          sslipj=1.0d0
1954          ssgradlipj=0.0
1955         endif
1956        else
1957          sslipj=0.0d0
1958          ssgradlipj=0.0
1959        endif
1960       aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
1961      &  +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1962       bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
1963      &  +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1964 C      write(iout,*) "tu,", i,j,aa_lip(itypi,itypj),bb_lip(itypi,itypj)
1965 C      if (aa.ne.aa_aq(itypi,itypj)) write(63,'(2e10.5)')
1966 C     &(aa-aa_aq(itypi,itypj)),(bb-bb_aq(itypi,itypj))
1967 C      if (ssgradlipj.gt.0.0d0) print *,"??WTF??"
1968 C      print *,sslipi,sslipj,bordlipbot,zi,zj
1969       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
1970       xj_safe=xj
1971       yj_safe=yj
1972       zj_safe=zj
1973       subchap=0
1974       do xshift=-1,1
1975       do yshift=-1,1
1976       do zshift=-1,1
1977           xj=xj_safe+xshift*boxxsize
1978           yj=yj_safe+yshift*boxysize
1979           zj=zj_safe+zshift*boxzsize
1980           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
1981           if(dist_temp.lt.dist_init) then
1982             dist_init=dist_temp
1983             xj_temp=xj
1984             yj_temp=yj
1985             zj_temp=zj
1986             subchap=1
1987           endif
1988        enddo
1989        enddo
1990        enddo
1991        if (subchap.eq.1) then
1992           xj=xj_temp-xi
1993           yj=yj_temp-yi
1994           zj=zj_temp-zi
1995        else
1996           xj=xj_safe-xi
1997           yj=yj_safe-yi
1998           zj=zj_safe-zi
1999        endif
2000             dxj=dc_norm(1,nres+j)
2001             dyj=dc_norm(2,nres+j)
2002             dzj=dc_norm(3,nres+j)
2003 C            xj=xj-xi
2004 C            yj=yj-yi
2005 C            zj=zj-zi
2006 c            write (iout,*) "dcnorj",dxi*dxi+dyi*dyi+dzi*dzi
2007 c            write (iout,*) "j",j," dc_norm",
2008 c     &       dc_norm(1,nres+j),dc_norm(2,nres+j),dc_norm(3,nres+j)
2009             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
2010             rij=dsqrt(rrij)
2011             sss=sscale((1.0d0/rij)/sigma(itypi,itypj))
2012             sssgrad=sscagrad((1.0d0/rij)/sigma(itypi,itypj))
2013
2014 c            write (iout,'(a7,4f8.3)')
2015 c    &      "ssscale",sss,((1.0d0/rij)/sigma(itypi,itypj)),r_cut,rlamb
2016             if (sss.gt.0.0d0) then
2017 C Calculate angle-dependent terms of energy and contributions to their
2018 C derivatives.
2019             call sc_angular
2020             sigsq=1.0D0/sigsq
2021             sig=sig0ij*dsqrt(sigsq)
2022             rij_shift=1.0D0/rij-sig+sig0ij
2023 c for diagnostics; uncomment
2024 c            rij_shift=1.2*sig0ij
2025 C I hate to put IF's in the loops, but here don't have another choice!!!!
2026             if (rij_shift.le.0.0D0) then
2027               evdw=1.0D20
2028 cd              write (iout,'(2(a3,i3,2x),17(0pf7.3))')
2029 cd     &        restyp(itypi),i,restyp(itypj),j,
2030 cd     &        rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq)
2031               return
2032             endif
2033             sigder=-sig*sigsq
2034 c---------------------------------------------------------------
2035             rij_shift=1.0D0/rij_shift
2036             fac=rij_shift**expon
2037 C here to start with
2038 C            if (c(i,3).gt.
2039             faclip=fac
2040             e1=fac*fac*aa
2041             e2=fac*bb
2042             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
2043             eps2der=evdwij*eps3rt
2044             eps3der=evdwij*eps2rt
2045 C       write(63,'(2i3,2e10.3,2f10.5)') i,j,aa,bb, evdwij,
2046 C     &((sslipi+sslipj)/2.0d0+
2047 C     &(2.0d0-sslipi-sslipj)/2.0d0)
2048 c            write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt,
2049 c     &        " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2
2050             evdwij=evdwij*eps2rt*eps3rt
2051             evdw=evdw+evdwij*sss
2052             if (lprn) then
2053             sigm=dabs(aa/bb)**(1.0D0/6.0D0)
2054             epsi=bb**2/aa
2055             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
2056      &        restyp(itypi),i,restyp(itypj),j,
2057      &        epsi,sigm,chi1,chi2,chip1,chip2,
2058      &        eps1,eps2rt**2,eps3rt**2,sig,sig0ij,
2059      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
2060      &        evdwij
2061             endif
2062
2063             if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
2064      &                        'evdw',i,j,evdwij
2065
2066 C Calculate gradient components.
2067             e1=e1*eps1*eps2rt**2*eps3rt**2
2068             fac=-expon*(e1+evdwij)*rij_shift
2069             sigder=fac*sigder
2070             fac=rij*fac
2071 c            print '(2i4,6f8.4)',i,j,sss,sssgrad*
2072 c     &      evdwij,fac,sigma(itypi,itypj),expon
2073             fac=fac+evdwij/sss*sssgrad/sigma(itypi,itypj)*rij
2074 c            fac=0.0d0
2075 C Calculate the radial part of the gradient
2076             gg_lipi(3)=eps1*(eps2rt*eps2rt)
2077      &*(eps3rt*eps3rt)*sss/2.0d0*(faclip*faclip*
2078      & (aa_lip(itypi,itypj)-aa_aq(itypi,itypj))
2079      &+faclip*(bb_lip(itypi,itypj)-bb_aq(itypi,itypj)))
2080             gg_lipj(3)=ssgradlipj*gg_lipi(3)
2081             gg_lipi(3)=gg_lipi(3)*ssgradlipi
2082 C            gg_lipi(3)=0.0d0
2083 C            gg_lipj(3)=0.0d0
2084             gg(1)=xj*fac
2085             gg(2)=yj*fac
2086             gg(3)=zj*fac
2087 C Calculate angular part of the gradient.
2088             call sc_grad
2089             endif
2090             ENDIF    ! dyn_ss
2091           enddo      ! j
2092         enddo        ! iint
2093       enddo          ! i
2094 C      enddo          ! zshift
2095 C      enddo          ! yshift
2096 C      enddo          ! xshift
2097 c      write (iout,*) "Number of loop steps in EGB:",ind
2098 cccc      energy_dec=.false.
2099       return
2100       end
2101 C-----------------------------------------------------------------------------
2102       subroutine egbv(evdw)
2103 C
2104 C This subroutine calculates the interaction energy of nonbonded side chains
2105 C assuming the Gay-Berne-Vorobjev potential of interaction.
2106 C
2107       implicit real*8 (a-h,o-z)
2108       include 'DIMENSIONS'
2109       include 'COMMON.GEO'
2110       include 'COMMON.VAR'
2111       include 'COMMON.LOCAL'
2112       include 'COMMON.CHAIN'
2113       include 'COMMON.DERIV'
2114       include 'COMMON.NAMES'
2115       include 'COMMON.INTERACT'
2116       include 'COMMON.IOUNITS'
2117       include 'COMMON.CALC'
2118       integer xshift,yshift,zshift
2119       common /srutu/ icall
2120       logical lprn
2121       evdw=0.0D0
2122 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
2123       evdw=0.0D0
2124       lprn=.false.
2125 c     if (icall.eq.0) lprn=.true.
2126       ind=0
2127       do i=iatsc_s,iatsc_e
2128         itypi=iabs(itype(i))
2129         if (itypi.eq.ntyp1) cycle
2130         itypi1=iabs(itype(i+1))
2131         xi=c(1,nres+i)
2132         yi=c(2,nres+i)
2133         zi=c(3,nres+i)
2134           xi=mod(xi,boxxsize)
2135           if (xi.lt.0) xi=xi+boxxsize
2136           yi=mod(yi,boxysize)
2137           if (yi.lt.0) yi=yi+boxysize
2138           zi=mod(zi,boxzsize)
2139           if (zi.lt.0) zi=zi+boxzsize
2140 C define scaling factor for lipids
2141
2142 C        if (positi.le.0) positi=positi+boxzsize
2143 C        print *,i
2144 C first for peptide groups
2145 c for each residue check if it is in lipid or lipid water border area
2146        if ((zi.gt.bordlipbot)
2147      &.and.(zi.lt.bordliptop)) then
2148 C the energy transfer exist
2149         if (zi.lt.buflipbot) then
2150 C what fraction I am in
2151          fracinbuf=1.0d0-
2152      &        ((zi-bordlipbot)/lipbufthick)
2153 C lipbufthick is thickenes of lipid buffore
2154          sslipi=sscalelip(fracinbuf)
2155          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
2156         elseif (zi.gt.bufliptop) then
2157          fracinbuf=1.0d0-((bordliptop-zi)/lipbufthick)
2158          sslipi=sscalelip(fracinbuf)
2159          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
2160         else
2161          sslipi=1.0d0
2162          ssgradlipi=0.0
2163         endif
2164        else
2165          sslipi=0.0d0
2166          ssgradlipi=0.0
2167        endif
2168
2169         dxi=dc_norm(1,nres+i)
2170         dyi=dc_norm(2,nres+i)
2171         dzi=dc_norm(3,nres+i)
2172 c        dsci_inv=dsc_inv(itypi)
2173         dsci_inv=vbld_inv(i+nres)
2174 C
2175 C Calculate SC interaction energy.
2176 C
2177         do iint=1,nint_gr(i)
2178           do j=istart(i,iint),iend(i,iint)
2179             ind=ind+1
2180             itypj=iabs(itype(j))
2181             if (itypj.eq.ntyp1) cycle
2182 c            dscj_inv=dsc_inv(itypj)
2183             dscj_inv=vbld_inv(j+nres)
2184             sig0ij=sigma(itypi,itypj)
2185             r0ij=r0(itypi,itypj)
2186             chi1=chi(itypi,itypj)
2187             chi2=chi(itypj,itypi)
2188             chi12=chi1*chi2
2189             chip1=chip(itypi)
2190             chip2=chip(itypj)
2191             chip12=chip1*chip2
2192             alf1=alp(itypi)
2193             alf2=alp(itypj)
2194             alf12=0.5D0*(alf1+alf2)
2195 C For diagnostics only!!!
2196 c           chi1=0.0D0
2197 c           chi2=0.0D0
2198 c           chi12=0.0D0
2199 c           chip1=0.0D0
2200 c           chip2=0.0D0
2201 c           chip12=0.0D0
2202 c           alf1=0.0D0
2203 c           alf2=0.0D0
2204 c           alf12=0.0D0
2205 C            xj=c(1,nres+j)-xi
2206 C            yj=c(2,nres+j)-yi
2207 C            zj=c(3,nres+j)-zi
2208           xj=mod(xj,boxxsize)
2209           if (xj.lt.0) xj=xj+boxxsize
2210           yj=mod(yj,boxysize)
2211           if (yj.lt.0) yj=yj+boxysize
2212           zj=mod(zj,boxzsize)
2213           if (zj.lt.0) zj=zj+boxzsize
2214        if ((zj.gt.bordlipbot)
2215      &.and.(zj.lt.bordliptop)) then
2216 C the energy transfer exist
2217         if (zj.lt.buflipbot) then
2218 C what fraction I am in
2219          fracinbuf=1.0d0-
2220      &        ((zj-bordlipbot)/lipbufthick)
2221 C lipbufthick is thickenes of lipid buffore
2222          sslipj=sscalelip(fracinbuf)
2223          ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
2224         elseif (zj.gt.bufliptop) then
2225          fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
2226          sslipj=sscalelip(fracinbuf)
2227          ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
2228         else
2229          sslipj=1.0d0
2230          ssgradlipj=0.0
2231         endif
2232        else
2233          sslipj=0.0d0
2234          ssgradlipj=0.0
2235        endif
2236       aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
2237      &  +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
2238       bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
2239      &  +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
2240 C      if (aa.ne.aa_aq(itypi,itypj)) write(63,'2e10.5')
2241 C     &(aa-aa_aq(itypi,itypj)),(bb-bb_aq(itypi,itypj))
2242 C      write(iout,*) "tu,", i,j,aa,bb,aa_lip(itypi,itypj),sslipi,sslipj
2243       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
2244       xj_safe=xj
2245       yj_safe=yj
2246       zj_safe=zj
2247       subchap=0
2248       do xshift=-1,1
2249       do yshift=-1,1
2250       do zshift=-1,1
2251           xj=xj_safe+xshift*boxxsize
2252           yj=yj_safe+yshift*boxysize
2253           zj=zj_safe+zshift*boxzsize
2254           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
2255           if(dist_temp.lt.dist_init) then
2256             dist_init=dist_temp
2257             xj_temp=xj
2258             yj_temp=yj
2259             zj_temp=zj
2260             subchap=1
2261           endif
2262        enddo
2263        enddo
2264        enddo
2265        if (subchap.eq.1) then
2266           xj=xj_temp-xi
2267           yj=yj_temp-yi
2268           zj=zj_temp-zi
2269        else
2270           xj=xj_safe-xi
2271           yj=yj_safe-yi
2272           zj=zj_safe-zi
2273        endif
2274             dxj=dc_norm(1,nres+j)
2275             dyj=dc_norm(2,nres+j)
2276             dzj=dc_norm(3,nres+j)
2277             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
2278             rij=dsqrt(rrij)
2279 C Calculate angle-dependent terms of energy and contributions to their
2280 C derivatives.
2281             call sc_angular
2282             sigsq=1.0D0/sigsq
2283             sig=sig0ij*dsqrt(sigsq)
2284             rij_shift=1.0D0/rij-sig+r0ij
2285 C I hate to put IF's in the loops, but here don't have another choice!!!!
2286             if (rij_shift.le.0.0D0) then
2287               evdw=1.0D20
2288               return
2289             endif
2290             sigder=-sig*sigsq
2291 c---------------------------------------------------------------
2292             rij_shift=1.0D0/rij_shift
2293             fac=rij_shift**expon
2294             e1=fac*fac*aa
2295             e2=fac*bb
2296             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
2297             eps2der=evdwij*eps3rt
2298             eps3der=evdwij*eps2rt
2299             fac_augm=rrij**expon
2300             e_augm=augm(itypi,itypj)*fac_augm
2301             evdwij=evdwij*eps2rt*eps3rt
2302             evdw=evdw+evdwij+e_augm
2303             if (lprn) then
2304             sigm=dabs(aa/bb)**(1.0D0/6.0D0)
2305             epsi=bb**2/aa
2306             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
2307      &        restyp(itypi),i,restyp(itypj),j,
2308      &        epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),
2309      &        chi1,chi2,chip1,chip2,
2310      &        eps1,eps2rt**2,eps3rt**2,
2311      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
2312      &        evdwij+e_augm
2313             endif
2314 C Calculate gradient components.
2315             e1=e1*eps1*eps2rt**2*eps3rt**2
2316             fac=-expon*(e1+evdwij)*rij_shift
2317             sigder=fac*sigder
2318             fac=rij*fac-2*expon*rrij*e_augm
2319             fac=fac+evdwij/sss*sssgrad/sigma(itypi,itypj)*rij
2320 C Calculate the radial part of the gradient
2321             gg(1)=xj*fac
2322             gg(2)=yj*fac
2323             gg(3)=zj*fac
2324 C Calculate angular part of the gradient.
2325             call sc_grad
2326           enddo      ! j
2327         enddo        ! iint
2328       enddo          ! i
2329       end
2330 C-----------------------------------------------------------------------------
2331       subroutine sc_angular
2332 C Calculate eps1,eps2,eps3,sigma, and parts of their derivatives in om1,om2,
2333 C om12. Called by ebp, egb, and egbv.
2334       implicit none
2335       include 'COMMON.CALC'
2336       include 'COMMON.IOUNITS'
2337       erij(1)=xj*rij
2338       erij(2)=yj*rij
2339       erij(3)=zj*rij
2340       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
2341       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
2342       om12=dxi*dxj+dyi*dyj+dzi*dzj
2343       chiom12=chi12*om12
2344 C Calculate eps1(om12) and its derivative in om12
2345       faceps1=1.0D0-om12*chiom12
2346       faceps1_inv=1.0D0/faceps1
2347       eps1=dsqrt(faceps1_inv)
2348 C Following variable is eps1*deps1/dom12
2349       eps1_om12=faceps1_inv*chiom12
2350 c diagnostics only
2351 c      faceps1_inv=om12
2352 c      eps1=om12
2353 c      eps1_om12=1.0d0
2354 c      write (iout,*) "om12",om12," eps1",eps1
2355 C Calculate sigma(om1,om2,om12) and the derivatives of sigma**2 in om1,om2,
2356 C and om12.
2357       om1om2=om1*om2
2358       chiom1=chi1*om1
2359       chiom2=chi2*om2
2360       facsig=om1*chiom1+om2*chiom2-2.0D0*om1om2*chiom12
2361       sigsq=1.0D0-facsig*faceps1_inv
2362       sigsq_om1=(chiom1-chiom12*om2)*faceps1_inv
2363       sigsq_om2=(chiom2-chiom12*om1)*faceps1_inv
2364       sigsq_om12=-chi12*(om1om2*faceps1-om12*facsig)*faceps1_inv**2
2365 c diagnostics only
2366 c      sigsq=1.0d0
2367 c      sigsq_om1=0.0d0
2368 c      sigsq_om2=0.0d0
2369 c      sigsq_om12=0.0d0
2370 c      write (iout,*) "chiom1",chiom1," chiom2",chiom2," chiom12",chiom12
2371 c      write (iout,*) "faceps1",faceps1," faceps1_inv",faceps1_inv,
2372 c     &    " eps1",eps1
2373 C Calculate eps2 and its derivatives in om1, om2, and om12.
2374       chipom1=chip1*om1
2375       chipom2=chip2*om2
2376       chipom12=chip12*om12
2377       facp=1.0D0-om12*chipom12
2378       facp_inv=1.0D0/facp
2379       facp1=om1*chipom1+om2*chipom2-2.0D0*om1om2*chipom12
2380 c      write (iout,*) "chipom1",chipom1," chipom2",chipom2,
2381 c     &  " chipom12",chipom12," facp",facp," facp_inv",facp_inv
2382 C Following variable is the square root of eps2
2383       eps2rt=1.0D0-facp1*facp_inv
2384 C Following three variables are the derivatives of the square root of eps
2385 C in om1, om2, and om12.
2386       eps2rt_om1=-4.0D0*(chipom1-chipom12*om2)*facp_inv
2387       eps2rt_om2=-4.0D0*(chipom2-chipom12*om1)*facp_inv
2388       eps2rt_om12=4.0D0*chip12*(om1om2*facp-om12*facp1)*facp_inv**2
2389 C Evaluate the "asymmetric" factor in the VDW constant, eps3
2390       eps3rt=1.0D0-alf1*om1+alf2*om2-alf12*om12
2391 c      write (iout,*) "eps2rt",eps2rt," eps3rt",eps3rt
2392 c      write (iout,*) "eps2rt_om1",eps2rt_om1," eps2rt_om2",eps2rt_om2,
2393 c     &  " eps2rt_om12",eps2rt_om12
2394 C Calculate whole angle-dependent part of epsilon and contributions
2395 C to its derivatives
2396       return
2397       end
2398 C----------------------------------------------------------------------------
2399       subroutine sc_grad
2400       implicit real*8 (a-h,o-z)
2401       include 'DIMENSIONS'
2402       include 'COMMON.CHAIN'
2403       include 'COMMON.DERIV'
2404       include 'COMMON.CALC'
2405       include 'COMMON.IOUNITS'
2406       double precision dcosom1(3),dcosom2(3)
2407 cc      print *,'sss=',sss
2408       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
2409       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
2410       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12
2411      &     -2.0D0*alf12*eps3der+sigder*sigsq_om12
2412 c diagnostics only
2413 c      eom1=0.0d0
2414 c      eom2=0.0d0
2415 c      eom12=evdwij*eps1_om12
2416 c end diagnostics
2417 c      write (iout,*) "eps2der",eps2der," eps3der",eps3der,
2418 c     &  " sigder",sigder
2419 c      write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12
2420 c      write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12
2421       do k=1,3
2422         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
2423         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
2424       enddo
2425       do k=1,3
2426         gg(k)=(gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k))*sss
2427       enddo
2428 c      write (iout,*) "gg",(gg(k),k=1,3)
2429       do k=1,3
2430         gvdwx(k,i)=gvdwx(k,i)-gg(k)+gg_lipi(k)
2431      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
2432      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv*sss
2433         gvdwx(k,j)=gvdwx(k,j)+gg(k)+gg_lipj(k)
2434      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
2435      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv*sss
2436 c        write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
2437 c     &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
2438 c        write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
2439 c     &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
2440       enddo
2441 C
2442 C Calculate the components of the gradient in DC and X
2443 C
2444 cgrad      do k=i,j-1
2445 cgrad        do l=1,3
2446 cgrad          gvdwc(l,k)=gvdwc(l,k)+gg(l)
2447 cgrad        enddo
2448 cgrad      enddo
2449       do l=1,3
2450         gvdwc(l,i)=gvdwc(l,i)-gg(l)+gg_lipi(l)
2451         gvdwc(l,j)=gvdwc(l,j)+gg(l)+gg_lipj(l)
2452       enddo
2453       return
2454       end
2455 C-----------------------------------------------------------------------
2456       subroutine e_softsphere(evdw)
2457 C
2458 C This subroutine calculates the interaction energy of nonbonded side chains
2459 C assuming the LJ potential of interaction.
2460 C
2461       implicit real*8 (a-h,o-z)
2462       include 'DIMENSIONS'
2463       parameter (accur=1.0d-10)
2464       include 'COMMON.GEO'
2465       include 'COMMON.VAR'
2466       include 'COMMON.LOCAL'
2467       include 'COMMON.CHAIN'
2468       include 'COMMON.DERIV'
2469       include 'COMMON.INTERACT'
2470       include 'COMMON.TORSION'
2471       include 'COMMON.SBRIDGE'
2472       include 'COMMON.NAMES'
2473       include 'COMMON.IOUNITS'
2474       include 'COMMON.CONTACTS'
2475       dimension gg(3)
2476 cd    print *,'Entering Esoft_sphere nnt=',nnt,' nct=',nct
2477       evdw=0.0D0
2478       do i=iatsc_s,iatsc_e
2479         itypi=iabs(itype(i))
2480         if (itypi.eq.ntyp1) cycle
2481         itypi1=iabs(itype(i+1))
2482         xi=c(1,nres+i)
2483         yi=c(2,nres+i)
2484         zi=c(3,nres+i)
2485 C
2486 C Calculate SC interaction energy.
2487 C
2488         do iint=1,nint_gr(i)
2489 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
2490 cd   &                  'iend=',iend(i,iint)
2491           do j=istart(i,iint),iend(i,iint)
2492             itypj=iabs(itype(j))
2493             if (itypj.eq.ntyp1) cycle
2494             xj=c(1,nres+j)-xi
2495             yj=c(2,nres+j)-yi
2496             zj=c(3,nres+j)-zi
2497             rij=xj*xj+yj*yj+zj*zj
2498 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
2499             r0ij=r0(itypi,itypj)
2500             r0ijsq=r0ij*r0ij
2501 c            print *,i,j,r0ij,dsqrt(rij)
2502             if (rij.lt.r0ijsq) then
2503               evdwij=0.25d0*(rij-r0ijsq)**2
2504               fac=rij-r0ijsq
2505             else
2506               evdwij=0.0d0
2507               fac=0.0d0
2508             endif
2509             evdw=evdw+evdwij
2510 C
2511 C Calculate the components of the gradient in DC and X
2512 C
2513             gg(1)=xj*fac
2514             gg(2)=yj*fac
2515             gg(3)=zj*fac
2516             do k=1,3
2517               gvdwx(k,i)=gvdwx(k,i)-gg(k)
2518               gvdwx(k,j)=gvdwx(k,j)+gg(k)
2519               gvdwc(k,i)=gvdwc(k,i)-gg(k)
2520               gvdwc(k,j)=gvdwc(k,j)+gg(k)
2521             enddo
2522 cgrad            do k=i,j-1
2523 cgrad              do l=1,3
2524 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
2525 cgrad              enddo
2526 cgrad            enddo
2527           enddo ! j
2528         enddo ! iint
2529       enddo ! i
2530       return
2531       end
2532 C--------------------------------------------------------------------------
2533       subroutine eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,
2534      &              eello_turn4)
2535 C
2536 C Soft-sphere potential of p-p interaction
2537 C
2538       implicit real*8 (a-h,o-z)
2539       include 'DIMENSIONS'
2540       include 'COMMON.CONTROL'
2541       include 'COMMON.IOUNITS'
2542       include 'COMMON.GEO'
2543       include 'COMMON.VAR'
2544       include 'COMMON.LOCAL'
2545       include 'COMMON.CHAIN'
2546       include 'COMMON.DERIV'
2547       include 'COMMON.INTERACT'
2548       include 'COMMON.CONTACTS'
2549       include 'COMMON.TORSION'
2550       include 'COMMON.VECTORS'
2551       include 'COMMON.FFIELD'
2552       dimension ggg(3)
2553       integer xshift,yshift,zshift
2554 C      write(iout,*) 'In EELEC_soft_sphere'
2555       ees=0.0D0
2556       evdw1=0.0D0
2557       eel_loc=0.0d0
2558       eello_turn3=0.0d0
2559       eello_turn4=0.0d0
2560       ind=0
2561       do i=iatel_s,iatel_e
2562         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
2563         dxi=dc(1,i)
2564         dyi=dc(2,i)
2565         dzi=dc(3,i)
2566         xmedi=c(1,i)+0.5d0*dxi
2567         ymedi=c(2,i)+0.5d0*dyi
2568         zmedi=c(3,i)+0.5d0*dzi
2569           xmedi=mod(xmedi,boxxsize)
2570           if (xmedi.lt.0) xmedi=xmedi+boxxsize
2571           ymedi=mod(ymedi,boxysize)
2572           if (ymedi.lt.0) ymedi=ymedi+boxysize
2573           zmedi=mod(zmedi,boxzsize)
2574           if (zmedi.lt.0) zmedi=zmedi+boxzsize
2575         num_conti=0
2576 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
2577         do j=ielstart(i),ielend(i)
2578           if (itype(j).eq.ntyp1 .or. itype(j+1).eq.ntyp1) cycle
2579           ind=ind+1
2580           iteli=itel(i)
2581           itelj=itel(j)
2582           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
2583           r0ij=rpp(iteli,itelj)
2584           r0ijsq=r0ij*r0ij
2585           dxj=dc(1,j)
2586           dyj=dc(2,j)
2587           dzj=dc(3,j)
2588           xj=c(1,j)+0.5D0*dxj
2589           yj=c(2,j)+0.5D0*dyj
2590           zj=c(3,j)+0.5D0*dzj
2591           xj=mod(xj,boxxsize)
2592           if (xj.lt.0) xj=xj+boxxsize
2593           yj=mod(yj,boxysize)
2594           if (yj.lt.0) yj=yj+boxysize
2595           zj=mod(zj,boxzsize)
2596           if (zj.lt.0) zj=zj+boxzsize
2597       dist_init=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
2598       xj_safe=xj
2599       yj_safe=yj
2600       zj_safe=zj
2601       isubchap=0
2602       do xshift=-1,1
2603       do yshift=-1,1
2604       do zshift=-1,1
2605           xj=xj_safe+xshift*boxxsize
2606           yj=yj_safe+yshift*boxysize
2607           zj=zj_safe+zshift*boxzsize
2608           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
2609           if(dist_temp.lt.dist_init) then
2610             dist_init=dist_temp
2611             xj_temp=xj
2612             yj_temp=yj
2613             zj_temp=zj
2614             isubchap=1
2615           endif
2616        enddo
2617        enddo
2618        enddo
2619        if (isubchap.eq.1) then
2620           xj=xj_temp-xmedi
2621           yj=yj_temp-ymedi
2622           zj=zj_temp-zmedi
2623        else
2624           xj=xj_safe-xmedi
2625           yj=yj_safe-ymedi
2626           zj=zj_safe-zmedi
2627        endif
2628           rij=xj*xj+yj*yj+zj*zj
2629             sss=sscale(sqrt(rij))
2630             sssgrad=sscagrad(sqrt(rij))
2631           if (rij.lt.r0ijsq) then
2632             evdw1ij=0.25d0*(rij-r0ijsq)**2
2633             fac=rij-r0ijsq
2634           else
2635             evdw1ij=0.0d0
2636             fac=0.0d0
2637           endif
2638           evdw1=evdw1+evdw1ij*sss
2639 C
2640 C Calculate contributions to the Cartesian gradient.
2641 C
2642           ggg(1)=fac*xj*sssgrad
2643           ggg(2)=fac*yj*sssgrad
2644           ggg(3)=fac*zj*sssgrad
2645           do k=1,3
2646             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
2647             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
2648           enddo
2649 *
2650 * Loop over residues i+1 thru j-1.
2651 *
2652 cgrad          do k=i+1,j-1
2653 cgrad            do l=1,3
2654 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
2655 cgrad            enddo
2656 cgrad          enddo
2657         enddo ! j
2658       enddo   ! i
2659 cgrad      do i=nnt,nct-1
2660 cgrad        do k=1,3
2661 cgrad          gelc(k,i)=gelc(k,i)+0.5d0*gelc(k,i)
2662 cgrad        enddo
2663 cgrad        do j=i+1,nct-1
2664 cgrad          do k=1,3
2665 cgrad            gelc(k,i)=gelc(k,i)+gelc(k,j)
2666 cgrad          enddo
2667 cgrad        enddo
2668 cgrad      enddo
2669       return
2670       end
2671 c------------------------------------------------------------------------------
2672       subroutine vec_and_deriv
2673       implicit real*8 (a-h,o-z)
2674       include 'DIMENSIONS'
2675 #ifdef MPI
2676       include 'mpif.h'
2677 #endif
2678       include 'COMMON.IOUNITS'
2679       include 'COMMON.GEO'
2680       include 'COMMON.VAR'
2681       include 'COMMON.LOCAL'
2682       include 'COMMON.CHAIN'
2683       include 'COMMON.VECTORS'
2684       include 'COMMON.SETUP'
2685       include 'COMMON.TIME1'
2686       dimension uyder(3,3,2),uzder(3,3,2),vbld_inv_temp(2)
2687 C Compute the local reference systems. For reference system (i), the
2688 C X-axis points from CA(i) to CA(i+1), the Y axis is in the
2689 C CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
2690 #ifdef PARVEC
2691       do i=ivec_start,ivec_end
2692 #else
2693       do i=1,nres-1
2694 #endif
2695           if (i.eq.nres-1) then
2696 C Case of the last full residue
2697 C Compute the Z-axis
2698             call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
2699             costh=dcos(pi-theta(nres))
2700             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2701             do k=1,3
2702               uz(k,i)=fac*uz(k,i)
2703             enddo
2704 C Compute the derivatives of uz
2705             uzder(1,1,1)= 0.0d0
2706             uzder(2,1,1)=-dc_norm(3,i-1)
2707             uzder(3,1,1)= dc_norm(2,i-1)
2708             uzder(1,2,1)= dc_norm(3,i-1)
2709             uzder(2,2,1)= 0.0d0
2710             uzder(3,2,1)=-dc_norm(1,i-1)
2711             uzder(1,3,1)=-dc_norm(2,i-1)
2712             uzder(2,3,1)= dc_norm(1,i-1)
2713             uzder(3,3,1)= 0.0d0
2714             uzder(1,1,2)= 0.0d0
2715             uzder(2,1,2)= dc_norm(3,i)
2716             uzder(3,1,2)=-dc_norm(2,i)
2717             uzder(1,2,2)=-dc_norm(3,i)
2718             uzder(2,2,2)= 0.0d0
2719             uzder(3,2,2)= dc_norm(1,i)
2720             uzder(1,3,2)= dc_norm(2,i)
2721             uzder(2,3,2)=-dc_norm(1,i)
2722             uzder(3,3,2)= 0.0d0
2723 C Compute the Y-axis
2724             facy=fac
2725             do k=1,3
2726               uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
2727             enddo
2728 C Compute the derivatives of uy
2729             do j=1,3
2730               do k=1,3
2731                 uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i)
2732      &                        -dc_norm(k,i)*dc_norm(j,i-1)
2733                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2734               enddo
2735               uyder(j,j,1)=uyder(j,j,1)-costh
2736               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2737             enddo
2738             do j=1,2
2739               do k=1,3
2740                 do l=1,3
2741                   uygrad(l,k,j,i)=uyder(l,k,j)
2742                   uzgrad(l,k,j,i)=uzder(l,k,j)
2743                 enddo
2744               enddo
2745             enddo
2746             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2747             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2748             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2749             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2750           else
2751 C Other residues
2752 C Compute the Z-axis
2753             call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
2754             costh=dcos(pi-theta(i+2))
2755             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2756             do k=1,3
2757               uz(k,i)=fac*uz(k,i)
2758             enddo
2759 C Compute the derivatives of uz
2760             uzder(1,1,1)= 0.0d0
2761             uzder(2,1,1)=-dc_norm(3,i+1)
2762             uzder(3,1,1)= dc_norm(2,i+1)
2763             uzder(1,2,1)= dc_norm(3,i+1)
2764             uzder(2,2,1)= 0.0d0
2765             uzder(3,2,1)=-dc_norm(1,i+1)
2766             uzder(1,3,1)=-dc_norm(2,i+1)
2767             uzder(2,3,1)= dc_norm(1,i+1)
2768             uzder(3,3,1)= 0.0d0
2769             uzder(1,1,2)= 0.0d0
2770             uzder(2,1,2)= dc_norm(3,i)
2771             uzder(3,1,2)=-dc_norm(2,i)
2772             uzder(1,2,2)=-dc_norm(3,i)
2773             uzder(2,2,2)= 0.0d0
2774             uzder(3,2,2)= dc_norm(1,i)
2775             uzder(1,3,2)= dc_norm(2,i)
2776             uzder(2,3,2)=-dc_norm(1,i)
2777             uzder(3,3,2)= 0.0d0
2778 C Compute the Y-axis
2779             facy=fac
2780             do k=1,3
2781               uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
2782             enddo
2783 C Compute the derivatives of uy
2784             do j=1,3
2785               do k=1,3
2786                 uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i)
2787      &                        -dc_norm(k,i)*dc_norm(j,i+1)
2788                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2789               enddo
2790               uyder(j,j,1)=uyder(j,j,1)-costh
2791               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2792             enddo
2793             do j=1,2
2794               do k=1,3
2795                 do l=1,3
2796                   uygrad(l,k,j,i)=uyder(l,k,j)
2797                   uzgrad(l,k,j,i)=uzder(l,k,j)
2798                 enddo
2799               enddo
2800             enddo
2801             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2802             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2803             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2804             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2805           endif
2806       enddo
2807       do i=1,nres-1
2808         vbld_inv_temp(1)=vbld_inv(i+1)
2809         if (i.lt.nres-1) then
2810           vbld_inv_temp(2)=vbld_inv(i+2)
2811           else
2812           vbld_inv_temp(2)=vbld_inv(i)
2813           endif
2814         do j=1,2
2815           do k=1,3
2816             do l=1,3
2817               uygrad(l,k,j,i)=vbld_inv_temp(j)*uygrad(l,k,j,i)
2818               uzgrad(l,k,j,i)=vbld_inv_temp(j)*uzgrad(l,k,j,i)
2819             enddo
2820           enddo
2821         enddo
2822       enddo
2823 #if defined(PARVEC) && defined(MPI)
2824       if (nfgtasks1.gt.1) then
2825         time00=MPI_Wtime()
2826 c        print *,"Processor",fg_rank1,kolor1," ivec_start",ivec_start,
2827 c     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks1-1),
2828 c     &   " ivec_count",(ivec_count(i),i=0,nfgtasks1-1)
2829         call MPI_Allgatherv(uy(1,ivec_start),ivec_count(fg_rank1),
2830      &   MPI_UYZ,uy(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
2831      &   FG_COMM1,IERR)
2832         call MPI_Allgatherv(uz(1,ivec_start),ivec_count(fg_rank1),
2833      &   MPI_UYZ,uz(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
2834      &   FG_COMM1,IERR)
2835         call MPI_Allgatherv(uygrad(1,1,1,ivec_start),
2836      &   ivec_count(fg_rank1),MPI_UYZGRAD,uygrad(1,1,1,1),ivec_count(0),
2837      &   ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2838         call MPI_Allgatherv(uzgrad(1,1,1,ivec_start),
2839      &   ivec_count(fg_rank1),MPI_UYZGRAD,uzgrad(1,1,1,1),ivec_count(0),
2840      &   ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2841         time_gather=time_gather+MPI_Wtime()-time00
2842       endif
2843 #endif
2844 #ifdef DEBUG
2845       if (fg_rank.eq.0) then
2846         write (iout,*) "Arrays UY and UZ"
2847         do i=1,nres-1
2848           write (iout,'(i5,3f10.5,5x,3f10.5)') i,(uy(k,i),k=1,3),
2849      &     (uz(k,i),k=1,3)
2850         enddo
2851       endif
2852 #endif
2853       return
2854       end
2855 C-----------------------------------------------------------------------------
2856       subroutine check_vecgrad
2857       implicit real*8 (a-h,o-z)
2858       include 'DIMENSIONS'
2859       include 'COMMON.IOUNITS'
2860       include 'COMMON.GEO'
2861       include 'COMMON.VAR'
2862       include 'COMMON.LOCAL'
2863       include 'COMMON.CHAIN'
2864       include 'COMMON.VECTORS'
2865       dimension uygradt(3,3,2,maxres),uzgradt(3,3,2,maxres)
2866       dimension uyt(3,maxres),uzt(3,maxres)
2867       dimension uygradn(3,3,2),uzgradn(3,3,2),erij(3)
2868       double precision delta /1.0d-7/
2869       call vec_and_deriv
2870 cd      do i=1,nres
2871 crc          write(iout,'(2i5,2(3f10.5,5x))') i,1,dc_norm(:,i)
2872 crc          write(iout,'(2i5,2(3f10.5,5x))') i,2,uy(:,i)
2873 crc          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,uz(:,i)
2874 cd          write(iout,'(2i5,2(3f10.5,5x))') i,1,
2875 cd     &     (dc_norm(if90,i),if90=1,3)
2876 cd          write(iout,'(2i5,2(3f10.5,5x))') i,2,(uy(if90,i),if90=1,3)
2877 cd          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,(uz(if90,i),if90=1,3)
2878 cd          write(iout,'(a)')
2879 cd      enddo
2880       do i=1,nres
2881         do j=1,2
2882           do k=1,3
2883             do l=1,3
2884               uygradt(l,k,j,i)=uygrad(l,k,j,i)
2885               uzgradt(l,k,j,i)=uzgrad(l,k,j,i)
2886             enddo
2887           enddo
2888         enddo
2889       enddo
2890       call vec_and_deriv
2891       do i=1,nres
2892         do j=1,3
2893           uyt(j,i)=uy(j,i)
2894           uzt(j,i)=uz(j,i)
2895         enddo
2896       enddo
2897       do i=1,nres
2898 cd        write (iout,*) 'i=',i
2899         do k=1,3
2900           erij(k)=dc_norm(k,i)
2901         enddo
2902         do j=1,3
2903           do k=1,3
2904             dc_norm(k,i)=erij(k)
2905           enddo
2906           dc_norm(j,i)=dc_norm(j,i)+delta
2907 c          fac=dsqrt(scalar(dc_norm(1,i),dc_norm(1,i)))
2908 c          do k=1,3
2909 c            dc_norm(k,i)=dc_norm(k,i)/fac
2910 c          enddo
2911 c          write (iout,*) (dc_norm(k,i),k=1,3)
2912 c          write (iout,*) (erij(k),k=1,3)
2913           call vec_and_deriv
2914           do k=1,3
2915             uygradn(k,j,1)=(uy(k,i)-uyt(k,i))/delta
2916             uygradn(k,j,2)=(uy(k,i-1)-uyt(k,i-1))/delta
2917             uzgradn(k,j,1)=(uz(k,i)-uzt(k,i))/delta
2918             uzgradn(k,j,2)=(uz(k,i-1)-uzt(k,i-1))/delta
2919           enddo
2920 c          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2921 c     &      j,(uzgradt(k,j,1,i),k=1,3),(uzgradn(k,j,1),k=1,3),
2922 c     &      (uzgradt(k,j,2,i-1),k=1,3),(uzgradn(k,j,2),k=1,3)
2923         enddo
2924         do k=1,3
2925           dc_norm(k,i)=erij(k)
2926         enddo
2927 cd        do k=1,3
2928 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2929 cd     &      k,(uygradt(k,l,1,i),l=1,3),(uygradn(k,l,1),l=1,3),
2930 cd     &      (uygradt(k,l,2,i-1),l=1,3),(uygradn(k,l,2),l=1,3)
2931 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2932 cd     &      k,(uzgradt(k,l,1,i),l=1,3),(uzgradn(k,l,1),l=1,3),
2933 cd     &      (uzgradt(k,l,2,i-1),l=1,3),(uzgradn(k,l,2),l=1,3)
2934 cd          write (iout,'(a)')
2935 cd        enddo
2936       enddo
2937       return
2938       end
2939 C--------------------------------------------------------------------------
2940       subroutine set_matrices
2941       implicit real*8 (a-h,o-z)
2942       include 'DIMENSIONS'
2943 #ifdef MPI
2944       include "mpif.h"
2945       include "COMMON.SETUP"
2946       integer IERR
2947       integer status(MPI_STATUS_SIZE)
2948 #endif
2949       include 'COMMON.IOUNITS'
2950       include 'COMMON.GEO'
2951       include 'COMMON.VAR'
2952       include 'COMMON.LOCAL'
2953       include 'COMMON.CHAIN'
2954       include 'COMMON.DERIV'
2955       include 'COMMON.INTERACT'
2956       include 'COMMON.CONTACTS'
2957       include 'COMMON.TORSION'
2958       include 'COMMON.VECTORS'
2959       include 'COMMON.FFIELD'
2960       double precision auxvec(2),auxmat(2,2)
2961 C
2962 C Compute the virtual-bond-torsional-angle dependent quantities needed
2963 C to calculate the el-loc multibody terms of various order.
2964 C
2965 c      write(iout,*) 'nphi=',nphi,nres
2966 c      write(iout,*) "itype2loc",itype2loc
2967 #ifdef PARMAT
2968       do i=ivec_start+2,ivec_end+2
2969 #else
2970       do i=3,nres+1
2971 #endif
2972         if (i.gt. nnt+2 .and. i.lt.nct+2) then
2973           iti = itype2loc(itype(i-2))
2974         else
2975           iti=nloctyp
2976         endif
2977 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2978         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2979           iti1 = itype2loc(itype(i-1))
2980         else
2981           iti1=nloctyp
2982         endif
2983 c        write(iout,*),i
2984 #ifdef NEWCORR
2985         cost1=dcos(theta(i-1))
2986         sint1=dsin(theta(i-1))
2987         sint1sq=sint1*sint1
2988         sint1cub=sint1sq*sint1
2989         sint1cost1=2*sint1*cost1
2990 c        write (iout,*) "bnew1",i,iti
2991 c        write (iout,*) (bnew1(k,1,iti),k=1,3)
2992 c        write (iout,*) (bnew1(k,2,iti),k=1,3)
2993 c        write (iout,*) "bnew2",i,iti
2994 c        write (iout,*) (bnew2(k,1,iti),k=1,3)
2995 c        write (iout,*) (bnew2(k,2,iti),k=1,3)
2996         do k=1,2
2997           b1k=bnew1(1,k,iti)+(bnew1(2,k,iti)+bnew1(3,k,iti)*cost1)*cost1
2998           b1(k,i-2)=sint1*b1k
2999           gtb1(k,i-2)=cost1*b1k-sint1sq*
3000      &              (bnew1(2,k,iti)+2*bnew1(3,k,iti)*cost1)
3001           b2k=bnew2(1,k,iti)+(bnew2(2,k,iti)+bnew2(3,k,iti)*cost1)*cost1
3002           b2(k,i-2)=sint1*b2k
3003           gtb2(k,i-2)=cost1*b2k-sint1sq*
3004      &              (bnew2(2,k,iti)+2*bnew2(3,k,iti)*cost1)
3005         enddo
3006         do k=1,2
3007           aux=ccnew(1,k,iti)+(ccnew(2,k,iti)+ccnew(3,k,iti)*cost1)*cost1
3008           cc(1,k,i-2)=sint1sq*aux
3009           gtcc(1,k,i-2)=sint1cost1*aux-sint1cub*
3010      &              (ccnew(2,k,iti)+2*ccnew(3,k,iti)*cost1)
3011           aux=ddnew(1,k,iti)+(ddnew(2,k,iti)+ddnew(3,k,iti)*cost1)*cost1
3012           dd(1,k,i-2)=sint1sq*aux
3013           gtdd(1,k,i-2)=sint1cost1*aux-sint1cub*
3014      &              (ddnew(2,k,iti)+2*ddnew(3,k,iti)*cost1)
3015         enddo
3016         cc(2,1,i-2)=cc(1,2,i-2)
3017         cc(2,2,i-2)=-cc(1,1,i-2)
3018         gtcc(2,1,i-2)=gtcc(1,2,i-2)
3019         gtcc(2,2,i-2)=-gtcc(1,1,i-2)
3020         dd(2,1,i-2)=dd(1,2,i-2)
3021         dd(2,2,i-2)=-dd(1,1,i-2)
3022         gtdd(2,1,i-2)=gtdd(1,2,i-2)
3023         gtdd(2,2,i-2)=-gtdd(1,1,i-2)
3024         do k=1,2
3025           do l=1,2
3026             aux=eenew(1,l,k,iti)+eenew(2,l,k,iti)*cost1
3027             EE(l,k,i-2)=sint1sq*aux
3028             gtEE(l,k,i-2)=sint1cost1*aux-sint1cub*eenew(2,l,k,iti)
3029           enddo
3030         enddo
3031         EE(1,1,i-2)=EE(1,1,i-2)+e0new(1,iti)*cost1
3032         EE(1,2,i-2)=EE(1,2,i-2)+e0new(2,iti)+e0new(3,iti)*cost1
3033         EE(2,1,i-2)=EE(2,1,i-2)+e0new(2,iti)*cost1+e0new(3,iti)
3034         EE(2,2,i-2)=EE(2,2,i-2)-e0new(1,iti)
3035         gtEE(1,1,i-2)=gtEE(1,1,i-2)-e0new(1,iti)*sint1
3036         gtEE(1,2,i-2)=gtEE(1,2,i-2)-e0new(3,iti)*sint1
3037         gtEE(2,1,i-2)=gtEE(2,1,i-2)-e0new(2,iti)*sint1
3038 c        b1tilde(1,i-2)=b1(1,i-2)
3039 c        b1tilde(2,i-2)=-b1(2,i-2)
3040 c        b2tilde(1,i-2)=b2(1,i-2)
3041 c        b2tilde(2,i-2)=-b2(2,i-2)
3042 #ifdef DEBUG
3043         write (iout,*) 'i=',i-2,gtb1(2,i-2),gtb1(1,i-2)
3044         write(iout,*)  'b1=',(b1(k,i-2),k=1,2)
3045         write(iout,*)  'b2=',(b2(k,i-2),k=1,2)
3046         write (iout,*) 'theta=', theta(i-1)
3047 #endif
3048 #else
3049         if (i.gt. nnt+2 .and. i.lt.nct+2) then
3050           iti = itype2loc(itype(i-2))
3051         else
3052           iti=nloctyp
3053         endif
3054 c        write (iout,*) "i",i-1," itype",itype(i-2)," iti",iti
3055 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
3056         if (i.gt. nnt+1 .and. i.lt.nct+1) then
3057           iti1 = itype2loc(itype(i-1))
3058         else
3059           iti1=nloctyp
3060         endif
3061         b1(1,i-2)=b(3,iti)
3062         b1(2,i-2)=b(5,iti)
3063         b2(1,i-2)=b(2,iti)
3064         b2(2,i-2)=b(4,iti)
3065         do k=1,2
3066           do l=1,2
3067            CC(k,l,i-2)=ccold(k,l,iti)
3068            DD(k,l,i-2)=ddold(k,l,iti)
3069            EE(k,l,i-2)=eeold(k,l,iti)
3070            gtEE(k,l,i-2)=0.0d0
3071           enddo
3072         enddo
3073 #endif
3074         b1tilde(1,i-2)= b1(1,i-2)
3075         b1tilde(2,i-2)=-b1(2,i-2)
3076         b2tilde(1,i-2)= b2(1,i-2)
3077         b2tilde(2,i-2)=-b2(2,i-2)
3078 c
3079         Ctilde(1,1,i-2)= CC(1,1,i-2)
3080         Ctilde(1,2,i-2)= CC(1,2,i-2)
3081         Ctilde(2,1,i-2)=-CC(2,1,i-2)
3082         Ctilde(2,2,i-2)=-CC(2,2,i-2)
3083 c
3084         Dtilde(1,1,i-2)= DD(1,1,i-2)
3085         Dtilde(1,2,i-2)= DD(1,2,i-2)
3086         Dtilde(2,1,i-2)=-DD(2,1,i-2)
3087         Dtilde(2,2,i-2)=-DD(2,2,i-2)
3088 #ifdef DEBUG
3089         write(iout,*) "i",i," iti",iti
3090         write(iout,*)  'b1=',(b1(k,i-2),k=1,2)
3091         write(iout,*)  'b2=',(b2(k,i-2),k=1,2)
3092 #endif
3093       enddo
3094 #ifdef PARMAT
3095       do i=ivec_start+2,ivec_end+2
3096 #else
3097       do i=3,nres+1
3098 #endif
3099         if (i .lt. nres+1) then
3100           sin1=dsin(phi(i))
3101           cos1=dcos(phi(i))
3102           sintab(i-2)=sin1
3103           costab(i-2)=cos1
3104           obrot(1,i-2)=cos1
3105           obrot(2,i-2)=sin1
3106           sin2=dsin(2*phi(i))
3107           cos2=dcos(2*phi(i))
3108           sintab2(i-2)=sin2
3109           costab2(i-2)=cos2
3110           obrot2(1,i-2)=cos2
3111           obrot2(2,i-2)=sin2
3112           Ug(1,1,i-2)=-cos1
3113           Ug(1,2,i-2)=-sin1
3114           Ug(2,1,i-2)=-sin1
3115           Ug(2,2,i-2)= cos1
3116           Ug2(1,1,i-2)=-cos2
3117           Ug2(1,2,i-2)=-sin2
3118           Ug2(2,1,i-2)=-sin2
3119           Ug2(2,2,i-2)= cos2
3120         else
3121           costab(i-2)=1.0d0
3122           sintab(i-2)=0.0d0
3123           obrot(1,i-2)=1.0d0
3124           obrot(2,i-2)=0.0d0
3125           obrot2(1,i-2)=0.0d0
3126           obrot2(2,i-2)=0.0d0
3127           Ug(1,1,i-2)=1.0d0
3128           Ug(1,2,i-2)=0.0d0
3129           Ug(2,1,i-2)=0.0d0
3130           Ug(2,2,i-2)=1.0d0
3131           Ug2(1,1,i-2)=0.0d0
3132           Ug2(1,2,i-2)=0.0d0
3133           Ug2(2,1,i-2)=0.0d0
3134           Ug2(2,2,i-2)=0.0d0
3135         endif
3136         if (i .gt. 3 .and. i .lt. nres+1) then
3137           obrot_der(1,i-2)=-sin1
3138           obrot_der(2,i-2)= cos1
3139           Ugder(1,1,i-2)= sin1
3140           Ugder(1,2,i-2)=-cos1
3141           Ugder(2,1,i-2)=-cos1
3142           Ugder(2,2,i-2)=-sin1
3143           dwacos2=cos2+cos2
3144           dwasin2=sin2+sin2
3145           obrot2_der(1,i-2)=-dwasin2
3146           obrot2_der(2,i-2)= dwacos2
3147           Ug2der(1,1,i-2)= dwasin2
3148           Ug2der(1,2,i-2)=-dwacos2
3149           Ug2der(2,1,i-2)=-dwacos2
3150           Ug2der(2,2,i-2)=-dwasin2
3151         else
3152           obrot_der(1,i-2)=0.0d0
3153           obrot_der(2,i-2)=0.0d0
3154           Ugder(1,1,i-2)=0.0d0
3155           Ugder(1,2,i-2)=0.0d0
3156           Ugder(2,1,i-2)=0.0d0
3157           Ugder(2,2,i-2)=0.0d0
3158           obrot2_der(1,i-2)=0.0d0
3159           obrot2_der(2,i-2)=0.0d0
3160           Ug2der(1,1,i-2)=0.0d0
3161           Ug2der(1,2,i-2)=0.0d0
3162           Ug2der(2,1,i-2)=0.0d0
3163           Ug2der(2,2,i-2)=0.0d0
3164         endif
3165 c        if (i.gt. iatel_s+2 .and. i.lt.iatel_e+5) then
3166         if (i.gt. nnt+2 .and. i.lt.nct+2) then
3167           iti = itype2loc(itype(i-2))
3168         else
3169           iti=nloctyp
3170         endif
3171 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
3172         if (i.gt. nnt+1 .and. i.lt.nct+1) then
3173           iti1 = itype2loc(itype(i-1))
3174         else
3175           iti1=nloctyp
3176         endif
3177 cd        write (iout,*) '*******i',i,' iti1',iti
3178 cd        write (iout,*) 'b1',b1(:,iti)
3179 cd        write (iout,*) 'b2',b2(:,iti)
3180 cd        write (iout,*) 'Ug',Ug(:,:,i-2)
3181 c        if (i .gt. iatel_s+2) then
3182         if (i .gt. nnt+2) then
3183           call matvec2(Ug(1,1,i-2),b2(1,i-2),Ub2(1,i-2))
3184 #ifdef NEWCORR
3185           call matvec2(Ug(1,1,i-2),gtb2(1,i-2),gUb2(1,i-2))
3186 c          write (iout,*) Ug(1,1,i-2),gtb2(1,i-2),gUb2(1,i-2),"chuj"
3187 #endif
3188 c          write(iout,*) "co jest kurwa", iti, EE(1,1,i),EE(2,1,i),
3189 c     &    EE(1,2,iti),EE(2,2,i)
3190           call matmat2(EE(1,1,i-2),Ug(1,1,i-2),EUg(1,1,i-2))
3191           call matmat2(gtEE(1,1,i-2),Ug(1,1,i-2),gtEUg(1,1,i-2))
3192 c          write(iout,*) "Macierz EUG",
3193 c     &    eug(1,1,i-2),eug(1,2,i-2),eug(2,1,i-2),
3194 c     &    eug(2,2,i-2)
3195           if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
3196      &    then
3197           call matmat2(CC(1,1,i-2),Ug(1,1,i-2),CUg(1,1,i-2))
3198           call matmat2(DD(1,1,i-2),Ug(1,1,i-2),DUg(1,1,i-2))
3199           call matmat2(Dtilde(1,1,i-2),Ug2(1,1,i-2),DtUg2(1,1,i-2))
3200           call matvec2(Ctilde(1,1,i-1),obrot(1,i-2),Ctobr(1,i-2))
3201           call matvec2(Dtilde(1,1,i-2),obrot2(1,i-2),Dtobr2(1,i-2))
3202           endif
3203         else
3204           do k=1,2
3205             Ub2(k,i-2)=0.0d0
3206             Ctobr(k,i-2)=0.0d0
3207             Dtobr2(k,i-2)=0.0d0
3208             do l=1,2
3209               EUg(l,k,i-2)=0.0d0
3210               CUg(l,k,i-2)=0.0d0
3211               DUg(l,k,i-2)=0.0d0
3212               DtUg2(l,k,i-2)=0.0d0
3213             enddo
3214           enddo
3215         endif
3216         call matvec2(Ugder(1,1,i-2),b2(1,i-2),Ub2der(1,i-2))
3217         call matmat2(EE(1,1,i-2),Ugder(1,1,i-2),EUgder(1,1,i-2))
3218         do k=1,2
3219           muder(k,i-2)=Ub2der(k,i-2)
3220         enddo
3221 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
3222         if (i.gt. nnt+1 .and. i.lt.nct+1) then
3223           if (itype(i-1).le.ntyp) then
3224             iti1 = itype2loc(itype(i-1))
3225           else
3226             iti1=nloctyp
3227           endif
3228         else
3229           iti1=nloctyp
3230         endif
3231         do k=1,2
3232           mu(k,i-2)=Ub2(k,i-2)+b1(k,i-1)
3233 c          mu(k,i-2)=b1(k,i-1)
3234 c          mu(k,i-2)=Ub2(k,i-2)
3235         enddo
3236 #ifdef MUOUT
3237         write (iout,'(2hmu,i3,3f8.1,12f10.5)') i-2,rad2deg*theta(i-1),
3238      &     rad2deg*theta(i),rad2deg*phi(i),mu(1,i-2),mu(2,i-2),
3239      &       -b2(1,i-2),b2(2,i-2),b1(1,i-2),b1(2,i-2),
3240      &       dsqrt(b2(1,i-1)**2+b2(2,i-1)**2)
3241      &      +dsqrt(b1(1,i-1)**2+b1(2,i-1)**2),
3242      &      ((ee(l,k,i-2),l=1,2),k=1,2)
3243 #endif
3244 cd        write (iout,*) 'mu1',mu1(:,i-2)
3245 cd        write (iout,*) 'mu2',mu2(:,i-2)
3246 cd        write (iout,*) 'mu',i-2,mu(:,i-2)
3247         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
3248      &  then
3249         call matmat2(CC(1,1,i-1),Ugder(1,1,i-2),CUgder(1,1,i-2))
3250         call matmat2(DD(1,1,i-2),Ugder(1,1,i-2),DUgder(1,1,i-2))
3251         call matmat2(Dtilde(1,1,i-2),Ug2der(1,1,i-2),DtUg2der(1,1,i-2))
3252         call matvec2(Ctilde(1,1,i-1),obrot_der(1,i-2),Ctobrder(1,i-2))
3253         call matvec2(Dtilde(1,1,i-2),obrot2_der(1,i-2),Dtobr2der(1,i-2))
3254 C Vectors and matrices dependent on a single virtual-bond dihedral.
3255         call matvec2(DD(1,1,i-2),b1tilde(1,i-1),auxvec(1))
3256         call matvec2(Ug2(1,1,i-2),auxvec(1),Ug2Db1t(1,i-2))
3257         call matvec2(Ug2der(1,1,i-2),auxvec(1),Ug2Db1tder(1,i-2))
3258         call matvec2(CC(1,1,i-1),Ub2(1,i-2),CUgb2(1,i-2))
3259         call matvec2(CC(1,1,i-1),Ub2der(1,i-2),CUgb2der(1,i-2))
3260         call matmat2(EUg(1,1,i-2),CC(1,1,i-1),EUgC(1,1,i-2))
3261         call matmat2(EUgder(1,1,i-2),CC(1,1,i-1),EUgCder(1,1,i-2))
3262         call matmat2(EUg(1,1,i-2),DD(1,1,i-1),EUgD(1,1,i-2))
3263         call matmat2(EUgder(1,1,i-2),DD(1,1,i-1),EUgDder(1,1,i-2))
3264         endif
3265       enddo
3266 C Matrices dependent on two consecutive virtual-bond dihedrals.
3267 C The order of matrices is from left to right.
3268       if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
3269      &then
3270 c      do i=max0(ivec_start,2),ivec_end
3271       do i=2,nres-1
3272         call matmat2(DtUg2(1,1,i-1),EUg(1,1,i),DtUg2EUg(1,1,i))
3273         call matmat2(DtUg2der(1,1,i-1),EUg(1,1,i),DtUg2EUgder(1,1,1,i))
3274         call matmat2(DtUg2(1,1,i-1),EUgder(1,1,i),DtUg2EUgder(1,1,2,i))
3275         call transpose2(DtUg2(1,1,i-1),auxmat(1,1))
3276         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUg(1,1,i))
3277         call matmat2(auxmat(1,1),EUgder(1,1,i),Ug2DtEUgder(1,1,2,i))
3278         call transpose2(DtUg2der(1,1,i-1),auxmat(1,1))
3279         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUgder(1,1,1,i))
3280       enddo
3281       endif
3282 #if defined(MPI) && defined(PARMAT)
3283 #ifdef DEBUG
3284 c      if (fg_rank.eq.0) then
3285         write (iout,*) "Arrays UG and UGDER before GATHER"
3286         do i=1,nres-1
3287           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3288      &     ((ug(l,k,i),l=1,2),k=1,2),
3289      &     ((ugder(l,k,i),l=1,2),k=1,2)
3290         enddo
3291         write (iout,*) "Arrays UG2 and UG2DER"
3292         do i=1,nres-1
3293           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3294      &     ((ug2(l,k,i),l=1,2),k=1,2),
3295      &     ((ug2der(l,k,i),l=1,2),k=1,2)
3296         enddo
3297         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
3298         do i=1,nres-1
3299           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3300      &     (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
3301      &     (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
3302         enddo
3303         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
3304         do i=1,nres-1
3305           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3306      &     costab(i),sintab(i),costab2(i),sintab2(i)
3307         enddo
3308         write (iout,*) "Array MUDER"
3309         do i=1,nres-1
3310           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
3311         enddo
3312 c      endif
3313 #endif
3314       if (nfgtasks.gt.1) then
3315         time00=MPI_Wtime()
3316 c        write(iout,*)"Processor",fg_rank,kolor," ivec_start",ivec_start,
3317 c     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks-1),
3318 c     &   " ivec_count",(ivec_count(i),i=0,nfgtasks-1)
3319 #ifdef MATGATHER
3320         call MPI_Allgatherv(Ub2(1,ivec_start),ivec_count(fg_rank1),
3321      &   MPI_MU,Ub2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3322      &   FG_COMM1,IERR)
3323         call MPI_Allgatherv(Ub2der(1,ivec_start),ivec_count(fg_rank1),
3324      &   MPI_MU,Ub2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3325      &   FG_COMM1,IERR)
3326         call MPI_Allgatherv(mu(1,ivec_start),ivec_count(fg_rank1),
3327      &   MPI_MU,mu(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3328      &   FG_COMM1,IERR)
3329         call MPI_Allgatherv(muder(1,ivec_start),ivec_count(fg_rank1),
3330      &   MPI_MU,muder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3331      &   FG_COMM1,IERR)
3332         call MPI_Allgatherv(Eug(1,1,ivec_start),ivec_count(fg_rank1),
3333      &   MPI_MAT1,Eug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3334      &   FG_COMM1,IERR)
3335         call MPI_Allgatherv(Eugder(1,1,ivec_start),ivec_count(fg_rank1),
3336      &   MPI_MAT1,Eugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3337      &   FG_COMM1,IERR)
3338         call MPI_Allgatherv(costab(ivec_start),ivec_count(fg_rank1),
3339      &   MPI_DOUBLE_PRECISION,costab(1),ivec_count(0),ivec_displ(0),
3340      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3341         call MPI_Allgatherv(sintab(ivec_start),ivec_count(fg_rank1),
3342      &   MPI_DOUBLE_PRECISION,sintab(1),ivec_count(0),ivec_displ(0),
3343      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3344         call MPI_Allgatherv(costab2(ivec_start),ivec_count(fg_rank1),
3345      &   MPI_DOUBLE_PRECISION,costab2(1),ivec_count(0),ivec_displ(0),
3346      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3347         call MPI_Allgatherv(sintab2(ivec_start),ivec_count(fg_rank1),
3348      &   MPI_DOUBLE_PRECISION,sintab2(1),ivec_count(0),ivec_displ(0),
3349      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3350         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
3351      &  then
3352         call MPI_Allgatherv(Ctobr(1,ivec_start),ivec_count(fg_rank1),
3353      &   MPI_MU,Ctobr(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3354      &   FG_COMM1,IERR)
3355         call MPI_Allgatherv(Ctobrder(1,ivec_start),ivec_count(fg_rank1),
3356      &   MPI_MU,Ctobrder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3357      &   FG_COMM1,IERR)
3358         call MPI_Allgatherv(Dtobr2(1,ivec_start),ivec_count(fg_rank1),
3359      &   MPI_MU,Dtobr2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3360      &   FG_COMM1,IERR)
3361        call MPI_Allgatherv(Dtobr2der(1,ivec_start),ivec_count(fg_rank1),
3362      &   MPI_MU,Dtobr2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3363      &   FG_COMM1,IERR)
3364         call MPI_Allgatherv(Ug2Db1t(1,ivec_start),ivec_count(fg_rank1),
3365      &   MPI_MU,Ug2Db1t(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3366      &   FG_COMM1,IERR)
3367         call MPI_Allgatherv(Ug2Db1tder(1,ivec_start),
3368      &   ivec_count(fg_rank1),
3369      &   MPI_MU,Ug2Db1tder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3370      &   FG_COMM1,IERR)
3371         call MPI_Allgatherv(CUgb2(1,ivec_start),ivec_count(fg_rank1),
3372      &   MPI_MU,CUgb2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3373      &   FG_COMM1,IERR)
3374         call MPI_Allgatherv(CUgb2der(1,ivec_start),ivec_count(fg_rank1),
3375      &   MPI_MU,CUgb2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3376      &   FG_COMM1,IERR)
3377         call MPI_Allgatherv(Cug(1,1,ivec_start),ivec_count(fg_rank1),
3378      &   MPI_MAT1,Cug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3379      &   FG_COMM1,IERR)
3380         call MPI_Allgatherv(Cugder(1,1,ivec_start),ivec_count(fg_rank1),
3381      &   MPI_MAT1,Cugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3382      &   FG_COMM1,IERR)
3383         call MPI_Allgatherv(Dug(1,1,ivec_start),ivec_count(fg_rank1),
3384      &   MPI_MAT1,Dug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3385      &   FG_COMM1,IERR)
3386         call MPI_Allgatherv(Dugder(1,1,ivec_start),ivec_count(fg_rank1),
3387      &   MPI_MAT1,Dugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3388      &   FG_COMM1,IERR)
3389         call MPI_Allgatherv(Dtug2(1,1,ivec_start),ivec_count(fg_rank1),
3390      &   MPI_MAT1,Dtug2(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3391      &   FG_COMM1,IERR)
3392         call MPI_Allgatherv(Dtug2der(1,1,ivec_start),
3393      &   ivec_count(fg_rank1),
3394      &   MPI_MAT1,Dtug2der(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3395      &   FG_COMM1,IERR)
3396         call MPI_Allgatherv(EugC(1,1,ivec_start),ivec_count(fg_rank1),
3397      &   MPI_MAT1,EugC(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3398      &   FG_COMM1,IERR)
3399        call MPI_Allgatherv(EugCder(1,1,ivec_start),ivec_count(fg_rank1),
3400      &   MPI_MAT1,EugCder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3401      &   FG_COMM1,IERR)
3402         call MPI_Allgatherv(EugD(1,1,ivec_start),ivec_count(fg_rank1),
3403      &   MPI_MAT1,EugD(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3404      &   FG_COMM1,IERR)
3405        call MPI_Allgatherv(EugDder(1,1,ivec_start),ivec_count(fg_rank1),
3406      &   MPI_MAT1,EugDder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3407      &   FG_COMM1,IERR)
3408         call MPI_Allgatherv(DtUg2EUg(1,1,ivec_start),
3409      &   ivec_count(fg_rank1),
3410      &   MPI_MAT1,DtUg2EUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3411      &   FG_COMM1,IERR)
3412         call MPI_Allgatherv(Ug2DtEUg(1,1,ivec_start),
3413      &   ivec_count(fg_rank1),
3414      &   MPI_MAT1,Ug2DtEUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3415      &   FG_COMM1,IERR)
3416         call MPI_Allgatherv(DtUg2EUgder(1,1,1,ivec_start),
3417      &   ivec_count(fg_rank1),
3418      &   MPI_MAT2,DtUg2EUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
3419      &   MPI_MAT2,FG_COMM1,IERR)
3420         call MPI_Allgatherv(Ug2DtEUgder(1,1,1,ivec_start),
3421      &   ivec_count(fg_rank1),
3422      &   MPI_MAT2,Ug2DtEUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
3423      &   MPI_MAT2,FG_COMM1,IERR)
3424         endif
3425 #else
3426 c Passes matrix info through the ring
3427       isend=fg_rank1
3428       irecv=fg_rank1-1
3429       if (irecv.lt.0) irecv=nfgtasks1-1
3430       iprev=irecv
3431       inext=fg_rank1+1
3432       if (inext.ge.nfgtasks1) inext=0
3433       do i=1,nfgtasks1-1
3434 c        write (iout,*) "isend",isend," irecv",irecv
3435 c        call flush(iout)
3436         lensend=lentyp(isend)
3437         lenrecv=lentyp(irecv)
3438 c        write (iout,*) "lensend",lensend," lenrecv",lenrecv
3439 c        call MPI_SENDRECV(ug(1,1,ivec_displ(isend)+1),1,
3440 c     &   MPI_ROTAT1(lensend),inext,2200+isend,
3441 c     &   ug(1,1,ivec_displ(irecv)+1),1,MPI_ROTAT1(lenrecv),
3442 c     &   iprev,2200+irecv,FG_COMM,status,IERR)
3443 c        write (iout,*) "Gather ROTAT1"
3444 c        call flush(iout)
3445 c        call MPI_SENDRECV(obrot(1,ivec_displ(isend)+1),1,
3446 c     &   MPI_ROTAT2(lensend),inext,3300+isend,
3447 c     &   obrot(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
3448 c     &   iprev,3300+irecv,FG_COMM,status,IERR)
3449 c        write (iout,*) "Gather ROTAT2"
3450 c        call flush(iout)
3451         call MPI_SENDRECV(costab(ivec_displ(isend)+1),1,
3452      &   MPI_ROTAT_OLD(lensend),inext,4400+isend,
3453      &   costab(ivec_displ(irecv)+1),1,MPI_ROTAT_OLD(lenrecv),
3454      &   iprev,4400+irecv,FG_COMM,status,IERR)
3455 c        write (iout,*) "Gather ROTAT_OLD"
3456 c        call flush(iout)
3457         call MPI_SENDRECV(mu(1,ivec_displ(isend)+1),1,
3458      &   MPI_PRECOMP11(lensend),inext,5500+isend,
3459      &   mu(1,ivec_displ(irecv)+1),1,MPI_PRECOMP11(lenrecv),
3460      &   iprev,5500+irecv,FG_COMM,status,IERR)
3461 c        write (iout,*) "Gather PRECOMP11"
3462 c        call flush(iout)
3463         call MPI_SENDRECV(Eug(1,1,ivec_displ(isend)+1),1,
3464      &   MPI_PRECOMP12(lensend),inext,6600+isend,
3465      &   Eug(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP12(lenrecv),
3466      &   iprev,6600+irecv,FG_COMM,status,IERR)
3467 c        write (iout,*) "Gather PRECOMP12"
3468 c        call flush(iout)
3469         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
3470      &  then
3471         call MPI_SENDRECV(ug2db1t(1,ivec_displ(isend)+1),1,
3472      &   MPI_ROTAT2(lensend),inext,7700+isend,
3473      &   ug2db1t(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
3474      &   iprev,7700+irecv,FG_COMM,status,IERR)
3475 c        write (iout,*) "Gather PRECOMP21"
3476 c        call flush(iout)
3477         call MPI_SENDRECV(EUgC(1,1,ivec_displ(isend)+1),1,
3478      &   MPI_PRECOMP22(lensend),inext,8800+isend,
3479      &   EUgC(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP22(lenrecv),
3480      &   iprev,8800+irecv,FG_COMM,status,IERR)
3481 c        write (iout,*) "Gather PRECOMP22"
3482 c        call flush(iout)
3483         call MPI_SENDRECV(Ug2DtEUgder(1,1,1,ivec_displ(isend)+1),1,
3484      &   MPI_PRECOMP23(lensend),inext,9900+isend,
3485      &   Ug2DtEUgder(1,1,1,ivec_displ(irecv)+1),1,
3486      &   MPI_PRECOMP23(lenrecv),
3487      &   iprev,9900+irecv,FG_COMM,status,IERR)
3488 c        write (iout,*) "Gather PRECOMP23"
3489 c        call flush(iout)
3490         endif
3491         isend=irecv
3492         irecv=irecv-1
3493         if (irecv.lt.0) irecv=nfgtasks1-1
3494       enddo
3495 #endif
3496         time_gather=time_gather+MPI_Wtime()-time00
3497       endif
3498 #ifdef DEBUG
3499 c      if (fg_rank.eq.0) then
3500         write (iout,*) "Arrays UG and UGDER"
3501         do i=1,nres-1
3502           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3503      &     ((ug(l,k,i),l=1,2),k=1,2),
3504      &     ((ugder(l,k,i),l=1,2),k=1,2)
3505         enddo
3506         write (iout,*) "Arrays UG2 and UG2DER"
3507         do i=1,nres-1
3508           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3509      &     ((ug2(l,k,i),l=1,2),k=1,2),
3510      &     ((ug2der(l,k,i),l=1,2),k=1,2)
3511         enddo
3512         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
3513         do i=1,nres-1
3514           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3515      &     (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
3516      &     (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
3517         enddo
3518         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
3519         do i=1,nres-1
3520           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3521      &     costab(i),sintab(i),costab2(i),sintab2(i)
3522         enddo
3523         write (iout,*) "Array MUDER"
3524         do i=1,nres-1
3525           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
3526         enddo
3527 c      endif
3528 #endif
3529 #endif
3530 cd      do i=1,nres
3531 cd        iti = itype2loc(itype(i))
3532 cd        write (iout,*) i
3533 cd        do j=1,2
3534 cd        write (iout,'(2f10.5,5x,2f10.5,5x,2f10.5)')
3535 cd     &  (EE(j,k,i),k=1,2),(Ug(j,k,i),k=1,2),(EUg(j,k,i),k=1,2)
3536 cd        enddo
3537 cd      enddo
3538       return
3539       end
3540 C--------------------------------------------------------------------------
3541       subroutine eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
3542 C
3543 C This subroutine calculates the average interaction energy and its gradient
3544 C in the virtual-bond vectors between non-adjacent peptide groups, based on
3545 C the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
3546 C The potential depends both on the distance of peptide-group centers and on
3547 C the orientation of the CA-CA virtual bonds.
3548 C
3549       implicit real*8 (a-h,o-z)
3550 #ifdef MPI
3551       include 'mpif.h'
3552 #endif
3553       include 'DIMENSIONS'
3554       include 'COMMON.CONTROL'
3555       include 'COMMON.SETUP'
3556       include 'COMMON.IOUNITS'
3557       include 'COMMON.GEO'
3558       include 'COMMON.VAR'
3559       include 'COMMON.LOCAL'
3560       include 'COMMON.CHAIN'
3561       include 'COMMON.DERIV'
3562       include 'COMMON.INTERACT'
3563       include 'COMMON.CONTACTS'
3564       include 'COMMON.TORSION'
3565       include 'COMMON.VECTORS'
3566       include 'COMMON.FFIELD'
3567       include 'COMMON.TIME1'
3568       include 'COMMON.SPLITELE'
3569       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
3570      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
3571       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
3572      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4),gmuij(4)
3573       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3574      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3575      &    num_conti,j1,j2
3576 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
3577 #ifdef MOMENT
3578       double precision scal_el /1.0d0/
3579 #else
3580       double precision scal_el /0.5d0/
3581 #endif
3582 C 12/13/98
3583 C 13-go grudnia roku pamietnego...
3584       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
3585      &                   0.0d0,1.0d0,0.0d0,
3586      &                   0.0d0,0.0d0,1.0d0/
3587 cd      write(iout,*) 'In EELEC'
3588 cd      do i=1,nloctyp
3589 cd        write(iout,*) 'Type',i
3590 cd        write(iout,*) 'B1',B1(:,i)
3591 cd        write(iout,*) 'B2',B2(:,i)
3592 cd        write(iout,*) 'CC',CC(:,:,i)
3593 cd        write(iout,*) 'DD',DD(:,:,i)
3594 cd        write(iout,*) 'EE',EE(:,:,i)
3595 cd      enddo
3596 cd      call check_vecgrad
3597 cd      stop
3598       if (icheckgrad.eq.1) then
3599         do i=1,nres-1
3600           fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
3601           do k=1,3
3602             dc_norm(k,i)=dc(k,i)*fac
3603           enddo
3604 c          write (iout,*) 'i',i,' fac',fac
3605         enddo
3606       endif
3607       if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
3608      &    .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or.
3609      &    wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
3610 c        call vec_and_deriv
3611 #ifdef TIMING
3612         time01=MPI_Wtime()
3613 #endif
3614         call set_matrices
3615 #ifdef TIMING
3616         time_mat=time_mat+MPI_Wtime()-time01
3617 #endif
3618       endif
3619 cd      do i=1,nres-1
3620 cd        write (iout,*) 'i=',i
3621 cd        do k=1,3
3622 cd        write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
3623 cd        enddo
3624 cd        do k=1,3
3625 cd          write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
3626 cd     &     uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
3627 cd        enddo
3628 cd      enddo
3629       t_eelecij=0.0d0
3630       ees=0.0D0
3631       evdw1=0.0D0
3632       eel_loc=0.0d0
3633       eello_turn3=0.0d0
3634       eello_turn4=0.0d0
3635       ind=0
3636       do i=1,nres
3637         num_cont_hb(i)=0
3638       enddo
3639 cd      print '(a)','Enter EELEC'
3640 cd      write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
3641       do i=1,nres
3642         gel_loc_loc(i)=0.0d0
3643         gcorr_loc(i)=0.0d0
3644       enddo
3645 c
3646 c
3647 c 9/27/08 AL Split the interaction loop to ensure load balancing of turn terms
3648 C
3649 C Loop over i,i+2 and i,i+3 pairs of the peptide groups
3650 C
3651 C 14/01/2014 TURN3,TUNR4 does no go under periodic boundry condition
3652       do i=iturn3_start,iturn3_end
3653 c        if (i.le.1) cycle
3654 C        write(iout,*) "tu jest i",i
3655         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
3656 C changes suggested by Ana to avoid out of bounds
3657 C Adam: Unnecessary: handled by iturn3_end and iturn3_start
3658 c     & .or.((i+4).gt.nres)
3659 c     & .or.((i-1).le.0)
3660 C end of changes by Ana
3661      &  .or. itype(i+2).eq.ntyp1
3662      &  .or. itype(i+3).eq.ntyp1) cycle
3663 C Adam: Instructions below will switch off existing interactions
3664 c        if(i.gt.1)then
3665 c          if(itype(i-1).eq.ntyp1)cycle
3666 c        end if
3667 c        if(i.LT.nres-3)then
3668 c          if (itype(i+4).eq.ntyp1) cycle
3669 c        end if
3670         dxi=dc(1,i)
3671         dyi=dc(2,i)
3672         dzi=dc(3,i)
3673         dx_normi=dc_norm(1,i)
3674         dy_normi=dc_norm(2,i)
3675         dz_normi=dc_norm(3,i)
3676         xmedi=c(1,i)+0.5d0*dxi
3677         ymedi=c(2,i)+0.5d0*dyi
3678         zmedi=c(3,i)+0.5d0*dzi
3679           xmedi=mod(xmedi,boxxsize)
3680           if (xmedi.lt.0) xmedi=xmedi+boxxsize
3681           ymedi=mod(ymedi,boxysize)
3682           if (ymedi.lt.0) ymedi=ymedi+boxysize
3683           zmedi=mod(zmedi,boxzsize)
3684           if (zmedi.lt.0) zmedi=zmedi+boxzsize
3685         num_conti=0
3686         call eelecij(i,i+2,ees,evdw1,eel_loc)
3687         if (wturn3.gt.0.0d0) call eturn3(i,eello_turn3)
3688         num_cont_hb(i)=num_conti
3689       enddo
3690       do i=iturn4_start,iturn4_end
3691         if (i.lt.1) cycle
3692         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
3693 C changes suggested by Ana to avoid out of bounds
3694 c     & .or.((i+5).gt.nres)
3695 c     & .or.((i-1).le.0)
3696 C end of changes suggested by Ana
3697      &    .or. itype(i+3).eq.ntyp1
3698      &    .or. itype(i+4).eq.ntyp1
3699 c     &    .or. itype(i+5).eq.ntyp1
3700 c     &    .or. itype(i).eq.ntyp1
3701 c     &    .or. itype(i-1).eq.ntyp1
3702      &                             ) cycle
3703         dxi=dc(1,i)
3704         dyi=dc(2,i)
3705         dzi=dc(3,i)
3706         dx_normi=dc_norm(1,i)
3707         dy_normi=dc_norm(2,i)
3708         dz_normi=dc_norm(3,i)
3709         xmedi=c(1,i)+0.5d0*dxi
3710         ymedi=c(2,i)+0.5d0*dyi
3711         zmedi=c(3,i)+0.5d0*dzi
3712 C Return atom into box, boxxsize is size of box in x dimension
3713 c  194   continue
3714 c        if (xmedi.gt.((0.5d0)*boxxsize)) xmedi=xmedi-boxxsize
3715 c        if (xmedi.lt.((-0.5d0)*boxxsize)) xmedi=xmedi+boxxsize
3716 C Condition for being inside the proper box
3717 c        if ((xmedi.gt.((0.5d0)*boxxsize)).or.
3718 c     &       (xmedi.lt.((-0.5d0)*boxxsize))) then
3719 c        go to 194
3720 c        endif
3721 c  195   continue
3722 c        if (ymedi.gt.((0.5d0)*boxysize)) ymedi=ymedi-boxysize
3723 c        if (ymedi.lt.((-0.5d0)*boxysize)) ymedi=ymedi+boxysize
3724 C Condition for being inside the proper box
3725 c        if ((ymedi.gt.((0.5d0)*boxysize)).or.
3726 c     &       (ymedi.lt.((-0.5d0)*boxysize))) then
3727 c        go to 195
3728 c        endif
3729 c  196   continue
3730 c        if (zmedi.gt.((0.5d0)*boxzsize)) zmedi=zmedi-boxzsize
3731 c        if (zmedi.lt.((-0.5d0)*boxzsize)) zmedi=zmedi+boxzsize
3732 C Condition for being inside the proper box
3733 c        if ((zmedi.gt.((0.5d0)*boxzsize)).or.
3734 c     &       (zmedi.lt.((-0.5d0)*boxzsize))) then
3735 c        go to 196
3736 c        endif
3737           xmedi=mod(xmedi,boxxsize)
3738           if (xmedi.lt.0) xmedi=xmedi+boxxsize
3739           ymedi=mod(ymedi,boxysize)
3740           if (ymedi.lt.0) ymedi=ymedi+boxysize
3741           zmedi=mod(zmedi,boxzsize)
3742           if (zmedi.lt.0) zmedi=zmedi+boxzsize
3743
3744         num_conti=num_cont_hb(i)
3745 c        write(iout,*) "JESTEM W PETLI"
3746         call eelecij(i,i+3,ees,evdw1,eel_loc)
3747         if (wturn4.gt.0.0d0 .and. itype(i+2).ne.ntyp1)
3748      &   call eturn4(i,eello_turn4)
3749         num_cont_hb(i)=num_conti
3750       enddo   ! i
3751 C Loop over all neighbouring boxes
3752 C      do xshift=-1,1
3753 C      do yshift=-1,1
3754 C      do zshift=-1,1
3755 c
3756 c Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
3757 c
3758 CTU KURWA
3759       do i=iatel_s,iatel_e
3760 C        do i=75,75
3761 c        if (i.le.1) cycle
3762         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
3763 C changes suggested by Ana to avoid out of bounds
3764 c     & .or.((i+2).gt.nres)
3765 c     & .or.((i-1).le.0)
3766 C end of changes by Ana
3767 c     &  .or. itype(i+2).eq.ntyp1
3768 c     &  .or. itype(i-1).eq.ntyp1
3769      &                ) cycle
3770         dxi=dc(1,i)
3771         dyi=dc(2,i)
3772         dzi=dc(3,i)
3773         dx_normi=dc_norm(1,i)
3774         dy_normi=dc_norm(2,i)
3775         dz_normi=dc_norm(3,i)
3776         xmedi=c(1,i)+0.5d0*dxi
3777         ymedi=c(2,i)+0.5d0*dyi
3778         zmedi=c(3,i)+0.5d0*dzi
3779           xmedi=mod(xmedi,boxxsize)
3780           if (xmedi.lt.0) xmedi=xmedi+boxxsize
3781           ymedi=mod(ymedi,boxysize)
3782           if (ymedi.lt.0) ymedi=ymedi+boxysize
3783           zmedi=mod(zmedi,boxzsize)
3784           if (zmedi.lt.0) zmedi=zmedi+boxzsize
3785 C          xmedi=xmedi+xshift*boxxsize
3786 C          ymedi=ymedi+yshift*boxysize
3787 C          zmedi=zmedi+zshift*boxzsize
3788
3789 C Return tom into box, boxxsize is size of box in x dimension
3790 c  164   continue
3791 c        if (xmedi.gt.((xshift+0.5d0)*boxxsize)) xmedi=xmedi-boxxsize
3792 c        if (xmedi.lt.((xshift-0.5d0)*boxxsize)) xmedi=xmedi+boxxsize
3793 C Condition for being inside the proper box
3794 c        if ((xmedi.gt.((xshift+0.5d0)*boxxsize)).or.
3795 c     &       (xmedi.lt.((xshift-0.5d0)*boxxsize))) then
3796 c        go to 164
3797 c        endif
3798 c  165   continue
3799 c        if (ymedi.gt.((yshift+0.5d0)*boxysize)) ymedi=ymedi-boxysize
3800 c        if (ymedi.lt.((yshift-0.5d0)*boxysize)) ymedi=ymedi+boxysize
3801 C Condition for being inside the proper box
3802 c        if ((ymedi.gt.((yshift+0.5d0)*boxysize)).or.
3803 c     &       (ymedi.lt.((yshift-0.5d0)*boxysize))) then
3804 c        go to 165
3805 c        endif
3806 c  166   continue
3807 c        if (zmedi.gt.((zshift+0.5d0)*boxzsize)) zmedi=zmedi-boxzsize
3808 c        if (zmedi.lt.((zshift-0.5d0)*boxzsize)) zmedi=zmedi+boxzsize
3809 cC Condition for being inside the proper box
3810 c        if ((zmedi.gt.((zshift+0.5d0)*boxzsize)).or.
3811 c     &       (zmedi.lt.((zshift-0.5d0)*boxzsize))) then
3812 c        go to 166
3813 c        endif
3814
3815 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
3816         num_conti=num_cont_hb(i)
3817 C I TU KURWA
3818         do j=ielstart(i),ielend(i)
3819 C          do j=16,17
3820 C          write (iout,*) i,j
3821 C         if (j.le.1) cycle
3822           if (itype(j).eq.ntyp1.or. itype(j+1).eq.ntyp1
3823 C changes suggested by Ana to avoid out of bounds
3824 c     & .or.((j+2).gt.nres)
3825 c     & .or.((j-1).le.0)
3826 C end of changes by Ana
3827 c     & .or.itype(j+2).eq.ntyp1
3828 c     & .or.itype(j-1).eq.ntyp1
3829      &) cycle
3830           call eelecij(i,j,ees,evdw1,eel_loc)
3831         enddo ! j
3832         num_cont_hb(i)=num_conti
3833       enddo   ! i
3834 C     enddo   ! zshift
3835 C      enddo   ! yshift
3836 C      enddo   ! xshift
3837
3838 c      write (iout,*) "Number of loop steps in EELEC:",ind
3839 cd      do i=1,nres
3840 cd        write (iout,'(i3,3f10.5,5x,3f10.5)')
3841 cd     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
3842 cd      enddo
3843 c 12/7/99 Adam eello_turn3 will be considered as a separate energy term
3844 ccc      eel_loc=eel_loc+eello_turn3
3845 cd      print *,"Processor",fg_rank," t_eelecij",t_eelecij
3846       return
3847       end
3848 C-------------------------------------------------------------------------------
3849       subroutine eelecij(i,j,ees,evdw1,eel_loc)
3850       implicit real*8 (a-h,o-z)
3851       include 'DIMENSIONS'
3852 #ifdef MPI
3853       include "mpif.h"
3854 #endif
3855       include 'COMMON.CONTROL'
3856       include 'COMMON.IOUNITS'
3857       include 'COMMON.GEO'
3858       include 'COMMON.VAR'
3859       include 'COMMON.LOCAL'
3860       include 'COMMON.CHAIN'
3861       include 'COMMON.DERIV'
3862       include 'COMMON.INTERACT'
3863       include 'COMMON.CONTACTS'
3864       include 'COMMON.TORSION'
3865       include 'COMMON.VECTORS'
3866       include 'COMMON.FFIELD'
3867       include 'COMMON.TIME1'
3868       include 'COMMON.SPLITELE'
3869       include 'COMMON.SHIELD'
3870       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
3871      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
3872       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
3873      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4),gmuij1(4),gmuji1(4),
3874      &    gmuij2(4),gmuji2(4)
3875       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3876      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3877      &    num_conti,j1,j2
3878 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
3879 #ifdef MOMENT
3880       double precision scal_el /1.0d0/
3881 #else
3882       double precision scal_el /0.5d0/
3883 #endif
3884 C 12/13/98
3885 C 13-go grudnia roku pamietnego...
3886       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
3887      &                   0.0d0,1.0d0,0.0d0,
3888      &                   0.0d0,0.0d0,1.0d0/
3889        integer xshift,yshift,zshift
3890 c          time00=MPI_Wtime()
3891 cd      write (iout,*) "eelecij",i,j
3892 c          ind=ind+1
3893           iteli=itel(i)
3894           itelj=itel(j)
3895           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
3896           aaa=app(iteli,itelj)
3897           bbb=bpp(iteli,itelj)
3898           ael6i=ael6(iteli,itelj)
3899           ael3i=ael3(iteli,itelj)
3900           dxj=dc(1,j)
3901           dyj=dc(2,j)
3902           dzj=dc(3,j)
3903           dx_normj=dc_norm(1,j)
3904           dy_normj=dc_norm(2,j)
3905           dz_normj=dc_norm(3,j)
3906 C          xj=c(1,j)+0.5D0*dxj-xmedi
3907 C          yj=c(2,j)+0.5D0*dyj-ymedi
3908 C          zj=c(3,j)+0.5D0*dzj-zmedi
3909           xj=c(1,j)+0.5D0*dxj
3910           yj=c(2,j)+0.5D0*dyj
3911           zj=c(3,j)+0.5D0*dzj
3912           xj=mod(xj,boxxsize)
3913           if (xj.lt.0) xj=xj+boxxsize
3914           yj=mod(yj,boxysize)
3915           if (yj.lt.0) yj=yj+boxysize
3916           zj=mod(zj,boxzsize)
3917           if (zj.lt.0) zj=zj+boxzsize
3918           if ((zj.lt.0).or.(xj.lt.0).or.(yj.lt.0)) write (*,*) "CHUJ"
3919       dist_init=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
3920       xj_safe=xj
3921       yj_safe=yj
3922       zj_safe=zj
3923       isubchap=0
3924       do xshift=-1,1
3925       do yshift=-1,1
3926       do zshift=-1,1
3927           xj=xj_safe+xshift*boxxsize
3928           yj=yj_safe+yshift*boxysize
3929           zj=zj_safe+zshift*boxzsize
3930           dist_temp=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
3931           if(dist_temp.lt.dist_init) then
3932             dist_init=dist_temp
3933             xj_temp=xj
3934             yj_temp=yj
3935             zj_temp=zj
3936             isubchap=1
3937           endif
3938        enddo
3939        enddo
3940        enddo
3941        if (isubchap.eq.1) then
3942           xj=xj_temp-xmedi
3943           yj=yj_temp-ymedi
3944           zj=zj_temp-zmedi
3945        else
3946           xj=xj_safe-xmedi
3947           yj=yj_safe-ymedi
3948           zj=zj_safe-zmedi
3949        endif
3950 C        if ((i+3).lt.j) then !this condition keeps for turn3 and turn4 not subject to PBC
3951 c  174   continue
3952 c        if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
3953 c        if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
3954 C Condition for being inside the proper box
3955 c        if ((xj.gt.((0.5d0)*boxxsize)).or.
3956 c     &       (xj.lt.((-0.5d0)*boxxsize))) then
3957 c        go to 174
3958 c        endif
3959 c  175   continue
3960 c        if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
3961 c        if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
3962 C Condition for being inside the proper box
3963 c        if ((yj.gt.((0.5d0)*boxysize)).or.
3964 c     &       (yj.lt.((-0.5d0)*boxysize))) then
3965 c        go to 175
3966 c        endif
3967 c  176   continue
3968 c        if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
3969 c        if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
3970 C Condition for being inside the proper box
3971 c        if ((zj.gt.((0.5d0)*boxzsize)).or.
3972 c     &       (zj.lt.((-0.5d0)*boxzsize))) then
3973 c        go to 176
3974 c        endif
3975 C        endif !endPBC condintion
3976 C        xj=xj-xmedi
3977 C        yj=yj-ymedi
3978 C        zj=zj-zmedi
3979           rij=xj*xj+yj*yj+zj*zj
3980
3981             sss=sscale(sqrt(rij))
3982             sssgrad=sscagrad(sqrt(rij))
3983 c            if (sss.gt.0.0d0) then
3984           rrmij=1.0D0/rij
3985           rij=dsqrt(rij)
3986           rmij=1.0D0/rij
3987           r3ij=rrmij*rmij
3988           r6ij=r3ij*r3ij
3989           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
3990           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
3991           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
3992           fac=cosa-3.0D0*cosb*cosg
3993           ev1=aaa*r6ij*r6ij
3994 c 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
3995           if (j.eq.i+2) ev1=scal_el*ev1
3996           ev2=bbb*r6ij
3997           fac3=ael6i*r6ij
3998           fac4=ael3i*r3ij
3999           evdwij=(ev1+ev2)
4000           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
4001           el2=fac4*fac
4002 C MARYSIA
4003 C          eesij=(el1+el2)
4004 C 12/26/95 - for the evaluation of multi-body H-bonding interactions
4005           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
4006           if (shield_mode.gt.0) then
4007 C          fac_shield(i)=0.4
4008 C          fac_shield(j)=0.6
4009           el1=el1*fac_shield(i)**2*fac_shield(j)**2
4010           el2=el2*fac_shield(i)**2*fac_shield(j)**2
4011           eesij=(el1+el2)
4012           ees=ees+eesij
4013           else
4014           fac_shield(i)=1.0
4015           fac_shield(j)=1.0
4016           eesij=(el1+el2)
4017           ees=ees+eesij
4018           endif
4019           evdw1=evdw1+evdwij*sss
4020 cd          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
4021 cd     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
4022 cd     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
4023 cd     &      xmedi,ymedi,zmedi,xj,yj,zj
4024
4025           if (energy_dec) then
4026               write (iout,'(a6,2i5,0pf7.3,2i5,3e11.3)')
4027      &'evdw1',i,j,evdwij
4028      &,iteli,itelj,aaa,evdw1,sss
4029               write (iout,'(a6,2i5,0pf7.3,2f8.3)') 'ees',i,j,eesij,
4030      &fac_shield(i),fac_shield(j)
4031           endif
4032
4033 C
4034 C Calculate contributions to the Cartesian gradient.
4035 C
4036 #ifdef SPLITELE
4037           facvdw=-6*rrmij*(ev1+evdwij)*sss
4038           facel=-3*rrmij*(el1+eesij)
4039           fac1=fac
4040           erij(1)=xj*rmij
4041           erij(2)=yj*rmij
4042           erij(3)=zj*rmij
4043
4044 *
4045 * Radial derivatives. First process both termini of the fragment (i,j)
4046 *
4047           ggg(1)=facel*xj
4048           ggg(2)=facel*yj
4049           ggg(3)=facel*zj
4050           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
4051      &  (shield_mode.gt.0)) then
4052 C          print *,i,j
4053           do ilist=1,ishield_list(i)
4054            iresshield=shield_list(ilist,i)
4055            do k=1,3
4056            rlocshield=grad_shield_side(k,ilist,i)*eesij/fac_shield(i)
4057      &      *2.0
4058            gshieldx(k,iresshield)=gshieldx(k,iresshield)+
4059      &              rlocshield
4060      & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)*2.0
4061             gshieldc(k,iresshield-1)=gshieldc(k,iresshield-1)+rlocshield
4062 C           gshieldc_loc(k,iresshield)=gshieldc_loc(k,iresshield)
4063 C     & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)
4064 C             if (iresshield.gt.i) then
4065 C               do ishi=i+1,iresshield-1
4066 C                gshieldc(k,ishi)=gshieldc(k,ishi)+rlocshield
4067 C     & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)
4068 C
4069 C              enddo
4070 C             else
4071 C               do ishi=iresshield,i
4072 C                gshieldc(k,ishi)=gshieldc(k,ishi)-rlocshield
4073 C     & -grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)
4074 C
4075 C               enddo
4076 C              endif
4077            enddo
4078           enddo
4079           do ilist=1,ishield_list(j)
4080            iresshield=shield_list(ilist,j)
4081            do k=1,3
4082            rlocshield=grad_shield_side(k,ilist,j)*eesij/fac_shield(j)
4083      &     *2.0
4084            gshieldx(k,iresshield)=gshieldx(k,iresshield)+
4085      &              rlocshield
4086      & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)*2.0
4087            gshieldc(k,iresshield-1)=gshieldc(k,iresshield-1)+rlocshield
4088
4089 C     & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
4090 C           gshieldc_loc(k,iresshield)=gshieldc_loc(k,iresshield)
4091 C     & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
4092 C             if (iresshield.gt.j) then
4093 C               do ishi=j+1,iresshield-1
4094 C                gshieldc(k,ishi)=gshieldc(k,ishi)+rlocshield
4095 C     & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
4096 C
4097 C               enddo
4098 C            else
4099 C               do ishi=iresshield,j
4100 C                gshieldc(k,ishi)=gshieldc(k,ishi)-rlocshield
4101 C     & -grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
4102 C               enddo
4103 C              endif
4104            enddo
4105           enddo
4106
4107           do k=1,3
4108             gshieldc(k,i)=gshieldc(k,i)+
4109      &              grad_shield(k,i)*eesij/fac_shield(i)*2.0
4110             gshieldc(k,j)=gshieldc(k,j)+
4111      &              grad_shield(k,j)*eesij/fac_shield(j)*2.0
4112             gshieldc(k,i-1)=gshieldc(k,i-1)+
4113      &              grad_shield(k,i)*eesij/fac_shield(i)*2.0
4114             gshieldc(k,j-1)=gshieldc(k,j-1)+
4115      &              grad_shield(k,j)*eesij/fac_shield(j)*2.0
4116
4117            enddo
4118            endif
4119 c          do k=1,3
4120 c            ghalf=0.5D0*ggg(k)
4121 c            gelc(k,i)=gelc(k,i)+ghalf
4122 c            gelc(k,j)=gelc(k,j)+ghalf
4123 c          enddo
4124 c 9/28/08 AL Gradient compotents will be summed only at the end
4125 C           print *,"before", gelc_long(1,i), gelc_long(1,j)
4126           do k=1,3
4127             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
4128 C     &                    +grad_shield(k,j)*eesij/fac_shield(j)
4129             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
4130 C     &                    +grad_shield(k,i)*eesij/fac_shield(i)
4131 C            gelc_long(k,i-1)=gelc_long(k,i-1)
4132 C     &                    +grad_shield(k,i)*eesij/fac_shield(i)
4133 C            gelc_long(k,j-1)=gelc_long(k,j-1)
4134 C     &                    +grad_shield(k,j)*eesij/fac_shield(j)
4135           enddo
4136 C           print *,"bafter", gelc_long(1,i), gelc_long(1,j)
4137
4138 *
4139 * Loop over residues i+1 thru j-1.
4140 *
4141 cgrad          do k=i+1,j-1
4142 cgrad            do l=1,3
4143 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
4144 cgrad            enddo
4145 cgrad          enddo
4146           if (sss.gt.0.0) then
4147           ggg(1)=facvdw*xj+sssgrad*rmij*evdwij*xj
4148           ggg(2)=facvdw*yj+sssgrad*rmij*evdwij*yj
4149           ggg(3)=facvdw*zj+sssgrad*rmij*evdwij*zj
4150           else
4151           ggg(1)=0.0
4152           ggg(2)=0.0
4153           ggg(3)=0.0
4154           endif
4155 c          do k=1,3
4156 c            ghalf=0.5D0*ggg(k)
4157 c            gvdwpp(k,i)=gvdwpp(k,i)+ghalf
4158 c            gvdwpp(k,j)=gvdwpp(k,j)+ghalf
4159 c          enddo
4160 c 9/28/08 AL Gradient compotents will be summed only at the end
4161           do k=1,3
4162             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
4163             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
4164           enddo
4165 *
4166 * Loop over residues i+1 thru j-1.
4167 *
4168 cgrad          do k=i+1,j-1
4169 cgrad            do l=1,3
4170 cgrad              gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
4171 cgrad            enddo
4172 cgrad          enddo
4173 #else
4174 C MARYSIA
4175           facvdw=(ev1+evdwij)*sss
4176           facel=(el1+eesij)
4177           fac1=fac
4178           fac=-3*rrmij*(facvdw+facvdw+facel)
4179           erij(1)=xj*rmij
4180           erij(2)=yj*rmij
4181           erij(3)=zj*rmij
4182 *
4183 * Radial derivatives. First process both termini of the fragment (i,j)
4184 *
4185           ggg(1)=fac*xj
4186 C+eesij*grad_shield(1,i)+eesij*grad_shield(1,j)
4187           ggg(2)=fac*yj
4188 C+eesij*grad_shield(2,i)+eesij*grad_shield(2,j)
4189           ggg(3)=fac*zj
4190 C+eesij*grad_shield(3,i)+eesij*grad_shield(3,j)
4191 c          do k=1,3
4192 c            ghalf=0.5D0*ggg(k)
4193 c            gelc(k,i)=gelc(k,i)+ghalf
4194 c            gelc(k,j)=gelc(k,j)+ghalf
4195 c          enddo
4196 c 9/28/08 AL Gradient compotents will be summed only at the end
4197           do k=1,3
4198             gelc_long(k,j)=gelc(k,j)+ggg(k)
4199             gelc_long(k,i)=gelc(k,i)-ggg(k)
4200           enddo
4201 *
4202 * Loop over residues i+1 thru j-1.
4203 *
4204 cgrad          do k=i+1,j-1
4205 cgrad            do l=1,3
4206 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
4207 cgrad            enddo
4208 cgrad          enddo
4209 c 9/28/08 AL Gradient compotents will be summed only at the end
4210           ggg(1)=facvdw*xj+sssgrad*rmij*evdwij*xj
4211           ggg(2)=facvdw*yj+sssgrad*rmij*evdwij*yj
4212           ggg(3)=facvdw*zj+sssgrad*rmij*evdwij*zj
4213           do k=1,3
4214             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
4215             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
4216           enddo
4217 #endif
4218 *
4219 * Angular part
4220 *
4221           ecosa=2.0D0*fac3*fac1+fac4
4222           fac4=-3.0D0*fac4
4223           fac3=-6.0D0*fac3
4224           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
4225           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
4226           do k=1,3
4227             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
4228             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
4229           enddo
4230 cd        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
4231 cd   &          (dcosg(k),k=1,3)
4232           do k=1,3
4233             ggg(k)=(ecosb*dcosb(k)+ecosg*dcosg(k))*
4234      &      fac_shield(i)**2*fac_shield(j)**2
4235           enddo
4236 c          do k=1,3
4237 c            ghalf=0.5D0*ggg(k)
4238 c            gelc(k,i)=gelc(k,i)+ghalf
4239 c     &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
4240 c     &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
4241 c            gelc(k,j)=gelc(k,j)+ghalf
4242 c     &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
4243 c     &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
4244 c          enddo
4245 cgrad          do k=i+1,j-1
4246 cgrad            do l=1,3
4247 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
4248 cgrad            enddo
4249 cgrad          enddo
4250 C                     print *,"before22", gelc_long(1,i), gelc_long(1,j)
4251           do k=1,3
4252             gelc(k,i)=gelc(k,i)
4253      &           +((ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
4254      &           + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1))
4255      &           *fac_shield(i)**2*fac_shield(j)**2
4256             gelc(k,j)=gelc(k,j)
4257      &           +((ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
4258      &           + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1))
4259      &           *fac_shield(i)**2*fac_shield(j)**2
4260             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
4261             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
4262           enddo
4263 C           print *,"before33", gelc_long(1,i), gelc_long(1,j)
4264
4265 C MARYSIA
4266 c          endif !sscale
4267           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
4268      &        .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0
4269      &        .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
4270 C
4271 C 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
4272 C   energy of a peptide unit is assumed in the form of a second-order
4273 C   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
4274 C   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
4275 C   are computed for EVERY pair of non-contiguous peptide groups.
4276 C
4277
4278           if (j.lt.nres-1) then
4279             j1=j+1
4280             j2=j-1
4281           else
4282             j1=j-1
4283             j2=j-2
4284           endif
4285           kkk=0
4286           lll=0
4287           do k=1,2
4288             do l=1,2
4289               kkk=kkk+1
4290               muij(kkk)=mu(k,i)*mu(l,j)
4291 c              write(iout,*) 'mumu=', mu(k,i),mu(l,j),i,j,k,l
4292 #ifdef NEWCORR
4293              gmuij1(kkk)=gtb1(k,i+1)*mu(l,j)
4294 c             write(iout,*) 'k=',k,i,gtb1(k,i+1),gtb1(k,i+1)*mu(l,j)
4295              gmuij2(kkk)=gUb2(k,i)*mu(l,j)
4296              gmuji1(kkk)=mu(k,i)*gtb1(l,j+1)
4297 c             write(iout,*) 'l=',l,j,gtb1(l,j+1),gtb1(l,j+1)*mu(k,i)
4298              gmuji2(kkk)=mu(k,i)*gUb2(l,j)
4299 #endif
4300             enddo
4301           enddo
4302 #ifdef DEBUG
4303           write (iout,*) 'EELEC: i',i,' j',j
4304           write (iout,*) 'j',j,' j1',j1,' j2',j2
4305           write(iout,*) 'muij',muij
4306 #endif
4307           ury=scalar(uy(1,i),erij)
4308           urz=scalar(uz(1,i),erij)
4309           vry=scalar(uy(1,j),erij)
4310           vrz=scalar(uz(1,j),erij)
4311           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
4312           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
4313           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
4314           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
4315           fac=dsqrt(-ael6i)*r3ij
4316 #ifdef DEBUG
4317           write (iout,*) "ury",ury," urz",urz," vry",vry," vrz",vrz
4318           write (iout,*) "uyvy",scalar(uy(1,i),uy(1,j)),
4319      &      "uyvz",scalar(uy(1,i),uz(1,j)),
4320      &      "uzvy",scalar(uz(1,i),uy(1,j)),
4321      &      "uzvz",scalar(uz(1,i),uz(1,j))
4322           write (iout,*) "a22",a22," a23",a23," a32",a32," a33",a33
4323           write (iout,*) "fac",fac
4324 #endif
4325           a22=a22*fac
4326           a23=a23*fac
4327           a32=a32*fac
4328           a33=a33*fac
4329 #ifdef DEBUG
4330           write (iout,*) "a22",a22," a23",a23," a32",a32," a33",a33
4331 #endif
4332 #undef DEBUG
4333 cd          write (iout,'(4i5,4f10.5)')
4334 cd     &     i,itortyp(itype(i)),j,itortyp(itype(j)),a22,a23,a32,a33
4335 cd          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
4336 cd          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') uy(:,i),uz(:,i),
4337 cd     &      uy(:,j),uz(:,j)
4338 cd          write (iout,'(4f10.5)')
4339 cd     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
4340 cd     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
4341 cd          write (iout,'(4f10.5)') ury,urz,vry,vrz
4342 cd           write (iout,'(9f10.5/)')
4343 cd     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
4344 C Derivatives of the elements of A in virtual-bond vectors
4345           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
4346           do k=1,3
4347             uryg(k,1)=scalar(erder(1,k),uy(1,i))
4348             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
4349             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
4350             urzg(k,1)=scalar(erder(1,k),uz(1,i))
4351             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
4352             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
4353             vryg(k,1)=scalar(erder(1,k),uy(1,j))
4354             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
4355             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
4356             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
4357             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
4358             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
4359           enddo
4360 C Compute radial contributions to the gradient
4361           facr=-3.0d0*rrmij
4362           a22der=a22*facr
4363           a23der=a23*facr
4364           a32der=a32*facr
4365           a33der=a33*facr
4366           agg(1,1)=a22der*xj
4367           agg(2,1)=a22der*yj
4368           agg(3,1)=a22der*zj
4369           agg(1,2)=a23der*xj
4370           agg(2,2)=a23der*yj
4371           agg(3,2)=a23der*zj
4372           agg(1,3)=a32der*xj
4373           agg(2,3)=a32der*yj
4374           agg(3,3)=a32der*zj
4375           agg(1,4)=a33der*xj
4376           agg(2,4)=a33der*yj
4377           agg(3,4)=a33der*zj
4378 C Add the contributions coming from er
4379           fac3=-3.0d0*fac
4380           do k=1,3
4381             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
4382             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
4383             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
4384             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
4385           enddo
4386           do k=1,3
4387 C Derivatives in DC(i)
4388 cgrad            ghalf1=0.5d0*agg(k,1)
4389 cgrad            ghalf2=0.5d0*agg(k,2)
4390 cgrad            ghalf3=0.5d0*agg(k,3)
4391 cgrad            ghalf4=0.5d0*agg(k,4)
4392             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j))
4393      &      -3.0d0*uryg(k,2)*vry)!+ghalf1
4394             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j))
4395      &      -3.0d0*uryg(k,2)*vrz)!+ghalf2
4396             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j))
4397      &      -3.0d0*urzg(k,2)*vry)!+ghalf3
4398             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j))
4399      &      -3.0d0*urzg(k,2)*vrz)!+ghalf4
4400 C Derivatives in DC(i+1)
4401             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j))
4402      &      -3.0d0*uryg(k,3)*vry)!+agg(k,1)
4403             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j))
4404      &      -3.0d0*uryg(k,3)*vrz)!+agg(k,2)
4405             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j))
4406      &      -3.0d0*urzg(k,3)*vry)!+agg(k,3)
4407             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j))
4408      &      -3.0d0*urzg(k,3)*vrz)!+agg(k,4)
4409 C Derivatives in DC(j)
4410             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i))
4411      &      -3.0d0*vryg(k,2)*ury)!+ghalf1
4412             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i))
4413      &      -3.0d0*vrzg(k,2)*ury)!+ghalf2
4414             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i))
4415      &      -3.0d0*vryg(k,2)*urz)!+ghalf3
4416             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i))
4417      &      -3.0d0*vrzg(k,2)*urz)!+ghalf4
4418 C Derivatives in DC(j+1) or DC(nres-1)
4419             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i))
4420      &      -3.0d0*vryg(k,3)*ury)
4421             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i))
4422      &      -3.0d0*vrzg(k,3)*ury)
4423             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i))
4424      &      -3.0d0*vryg(k,3)*urz)
4425             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i))
4426      &      -3.0d0*vrzg(k,3)*urz)
4427 cgrad            if (j.eq.nres-1 .and. i.lt.j-2) then
4428 cgrad              do l=1,4
4429 cgrad                aggj1(k,l)=aggj1(k,l)+agg(k,l)
4430 cgrad              enddo
4431 cgrad            endif
4432           enddo
4433           acipa(1,1)=a22
4434           acipa(1,2)=a23
4435           acipa(2,1)=a32
4436           acipa(2,2)=a33
4437           a22=-a22
4438           a23=-a23
4439           do l=1,2
4440             do k=1,3
4441               agg(k,l)=-agg(k,l)
4442               aggi(k,l)=-aggi(k,l)
4443               aggi1(k,l)=-aggi1(k,l)
4444               aggj(k,l)=-aggj(k,l)
4445               aggj1(k,l)=-aggj1(k,l)
4446             enddo
4447           enddo
4448           if (j.lt.nres-1) then
4449             a22=-a22
4450             a32=-a32
4451             do l=1,3,2
4452               do k=1,3
4453                 agg(k,l)=-agg(k,l)
4454                 aggi(k,l)=-aggi(k,l)
4455                 aggi1(k,l)=-aggi1(k,l)
4456                 aggj(k,l)=-aggj(k,l)
4457                 aggj1(k,l)=-aggj1(k,l)
4458               enddo
4459             enddo
4460           else
4461             a22=-a22
4462             a23=-a23
4463             a32=-a32
4464             a33=-a33
4465             do l=1,4
4466               do k=1,3
4467                 agg(k,l)=-agg(k,l)
4468                 aggi(k,l)=-aggi(k,l)
4469                 aggi1(k,l)=-aggi1(k,l)
4470                 aggj(k,l)=-aggj(k,l)
4471                 aggj1(k,l)=-aggj1(k,l)
4472               enddo
4473             enddo
4474           endif
4475           ENDIF ! WCORR
4476           IF (wel_loc.gt.0.0d0) THEN
4477 C Contribution to the local-electrostatic energy coming from the i-j pair
4478           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3)
4479      &     +a33*muij(4)
4480 #ifdef DEBUG
4481           write (iout,*) "muij",muij," a22",a22," a23",a23," a32",a32,
4482      &     " a33",a33
4483           write (iout,*) "ij",i,j," eel_loc_ij",eel_loc_ij,
4484      &     " wel_loc",wel_loc
4485 #endif
4486           if (shield_mode.eq.0) then
4487            fac_shield(i)=1.0
4488            fac_shield(j)=1.0
4489 C          else
4490 C           fac_shield(i)=0.4
4491 C           fac_shield(j)=0.6
4492           endif
4493           eel_loc_ij=eel_loc_ij
4494      &    *fac_shield(i)*fac_shield(j)
4495 c          if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
4496 c     &            'eelloc',i,j,eel_loc_ij
4497 C Now derivative over eel_loc
4498           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
4499      &  (shield_mode.gt.0)) then
4500 C          print *,i,j
4501
4502           do ilist=1,ishield_list(i)
4503            iresshield=shield_list(ilist,i)
4504            do k=1,3
4505            rlocshield=grad_shield_side(k,ilist,i)*eel_loc_ij
4506      &                                          /fac_shield(i)
4507 C     &      *2.0
4508            gshieldx_ll(k,iresshield)=gshieldx_ll(k,iresshield)+
4509      &              rlocshield
4510      & +grad_shield_loc(k,ilist,i)*eel_loc_ij/fac_shield(i)
4511             gshieldc_ll(k,iresshield-1)=gshieldc_ll(k,iresshield-1)
4512      &      +rlocshield
4513            enddo
4514           enddo
4515           do ilist=1,ishield_list(j)
4516            iresshield=shield_list(ilist,j)
4517            do k=1,3
4518            rlocshield=grad_shield_side(k,ilist,j)*eel_loc_ij
4519      &                                       /fac_shield(j)
4520 C     &     *2.0
4521            gshieldx_ll(k,iresshield)=gshieldx_ll(k,iresshield)+
4522      &              rlocshield
4523      & +grad_shield_loc(k,ilist,j)*eel_loc_ij/fac_shield(j)
4524            gshieldc_ll(k,iresshield-1)=gshieldc_ll(k,iresshield-1)
4525      &             +rlocshield
4526
4527            enddo
4528           enddo
4529
4530           do k=1,3
4531             gshieldc_ll(k,i)=gshieldc_ll(k,i)+
4532      &              grad_shield(k,i)*eel_loc_ij/fac_shield(i)
4533             gshieldc_ll(k,j)=gshieldc_ll(k,j)+
4534      &              grad_shield(k,j)*eel_loc_ij/fac_shield(j)
4535             gshieldc_ll(k,i-1)=gshieldc_ll(k,i-1)+
4536      &              grad_shield(k,i)*eel_loc_ij/fac_shield(i)
4537             gshieldc_ll(k,j-1)=gshieldc_ll(k,j-1)+
4538      &              grad_shield(k,j)*eel_loc_ij/fac_shield(j)
4539            enddo
4540            endif
4541
4542
4543 c          write (iout,*) 'i',i,' j',j,itype(i),itype(j),
4544 c     &                     ' eel_loc_ij',eel_loc_ij
4545 C          write(iout,*) 'muije=',i,j,muij(1),muij(2),muij(3),muij(4)
4546 C Calculate patrial derivative for theta angle
4547 #ifdef NEWCORR
4548          geel_loc_ij=(a22*gmuij1(1)
4549      &     +a23*gmuij1(2)
4550      &     +a32*gmuij1(3)
4551      &     +a33*gmuij1(4))
4552      &    *fac_shield(i)*fac_shield(j)
4553 c         write(iout,*) "derivative over thatai"
4554 c         write(iout,*) a22*gmuij1(1), a23*gmuij1(2) ,a32*gmuij1(3),
4555 c     &   a33*gmuij1(4)
4556          gloc(nphi+i,icg)=gloc(nphi+i,icg)+
4557      &      geel_loc_ij*wel_loc
4558 c         write(iout,*) "derivative over thatai-1"
4559 c         write(iout,*) a22*gmuij2(1), a23*gmuij2(2) ,a32*gmuij2(3),
4560 c     &   a33*gmuij2(4)
4561          geel_loc_ij=
4562      &     a22*gmuij2(1)
4563      &     +a23*gmuij2(2)
4564      &     +a32*gmuij2(3)
4565      &     +a33*gmuij2(4)
4566          gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
4567      &      geel_loc_ij*wel_loc
4568      &    *fac_shield(i)*fac_shield(j)
4569
4570 c  Derivative over j residue
4571          geel_loc_ji=a22*gmuji1(1)
4572      &     +a23*gmuji1(2)
4573      &     +a32*gmuji1(3)
4574      &     +a33*gmuji1(4)
4575 c         write(iout,*) "derivative over thataj"
4576 c         write(iout,*) a22*gmuji1(1), a23*gmuji1(2) ,a32*gmuji1(3),
4577 c     &   a33*gmuji1(4)
4578
4579         gloc(nphi+j,icg)=gloc(nphi+j,icg)+
4580      &      geel_loc_ji*wel_loc
4581      &    *fac_shield(i)*fac_shield(j)
4582
4583          geel_loc_ji=
4584      &     +a22*gmuji2(1)
4585      &     +a23*gmuji2(2)
4586      &     +a32*gmuji2(3)
4587      &     +a33*gmuji2(4)
4588 c         write(iout,*) "derivative over thataj-1"
4589 c         write(iout,*) a22*gmuji2(1), a23*gmuji2(2) ,a32*gmuji2(3),
4590 c     &   a33*gmuji2(4)
4591          gloc(nphi+j-1,icg)=gloc(nphi+j-1,icg)+
4592      &      geel_loc_ji*wel_loc
4593      &    *fac_shield(i)*fac_shield(j)
4594 #endif
4595 cd          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
4596
4597           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
4598      &            'eelloc',i,j,eel_loc_ij
4599 c           if (eel_loc_ij.ne.0)
4600 c     &      write (iout,'(a4,2i4,8f9.5)')'chuj',
4601 c     &     i,j,a22,muij(1),a23,muij(2),a32,muij(3),a33,muij(4)
4602
4603           eel_loc=eel_loc+eel_loc_ij
4604 C Partial derivatives in virtual-bond dihedral angles gamma
4605           if (i.gt.1)
4606      &    gel_loc_loc(i-1)=gel_loc_loc(i-1)+
4607      &            (a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j)
4608      &           +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j))
4609      &    *fac_shield(i)*fac_shield(j)
4610
4611           gel_loc_loc(j-1)=gel_loc_loc(j-1)+
4612      &           (a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j)
4613      &           +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j))
4614      &    *fac_shield(i)*fac_shield(j)
4615 C Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
4616           do l=1,3
4617             ggg(l)=(agg(l,1)*muij(1)+
4618      &          agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4))
4619      &    *fac_shield(i)*fac_shield(j)
4620             gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l)
4621             gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l)
4622 cgrad            ghalf=0.5d0*ggg(l)
4623 cgrad            gel_loc(l,i)=gel_loc(l,i)+ghalf
4624 cgrad            gel_loc(l,j)=gel_loc(l,j)+ghalf
4625           enddo
4626 cgrad          do k=i+1,j2
4627 cgrad            do l=1,3
4628 cgrad              gel_loc(l,k)=gel_loc(l,k)+ggg(l)
4629 cgrad            enddo
4630 cgrad          enddo
4631 C Remaining derivatives of eello
4632           do l=1,3
4633             gel_loc(l,i)=gel_loc(l,i)+(aggi(l,1)*muij(1)+
4634      &        aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4))
4635      &    *fac_shield(i)*fac_shield(j)
4636
4637             gel_loc(l,i+1)=gel_loc(l,i+1)+(aggi1(l,1)*muij(1)+
4638      &     aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4))
4639      &    *fac_shield(i)*fac_shield(j)
4640
4641             gel_loc(l,j)=gel_loc(l,j)+(aggj(l,1)*muij(1)+
4642      &       aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4))
4643      &    *fac_shield(i)*fac_shield(j)
4644
4645             gel_loc(l,j1)=gel_loc(l,j1)+(aggj1(l,1)*muij(1)+
4646      &     aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4))
4647      &    *fac_shield(i)*fac_shield(j)
4648
4649           enddo
4650           ENDIF
4651 C Change 12/26/95 to calculate four-body contributions to H-bonding energy
4652 c          if (j.gt.i+1 .and. num_conti.le.maxconts) then
4653           if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0
4654      &       .and. num_conti.le.maxconts) then
4655 c            write (iout,*) i,j," entered corr"
4656 C
4657 C Calculate the contact function. The ith column of the array JCONT will
4658 C contain the numbers of atoms that make contacts with the atom I (of numbers
4659 C greater than I). The arrays FACONT and GACONT will contain the values of
4660 C the contact function and its derivative.
4661 c           r0ij=1.02D0*rpp(iteli,itelj)
4662 c           r0ij=1.11D0*rpp(iteli,itelj)
4663             r0ij=2.20D0*rpp(iteli,itelj)
4664 c           r0ij=1.55D0*rpp(iteli,itelj)
4665             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
4666             if (fcont.gt.0.0D0) then
4667               num_conti=num_conti+1
4668               if (num_conti.gt.maxconts) then
4669                 write (iout,*) 'WARNING - max. # of contacts exceeded;',
4670      &                         ' will skip next contacts for this conf.'
4671               else
4672                 jcont_hb(num_conti,i)=j
4673 cd                write (iout,*) "i",i," j",j," num_conti",num_conti,
4674 cd     &           " jcont_hb",jcont_hb(num_conti,i)
4675                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.
4676      &          wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
4677 C 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
4678 C  terms.
4679                 d_cont(num_conti,i)=rij
4680 cd                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
4681 C     --- Electrostatic-interaction matrix ---
4682                 a_chuj(1,1,num_conti,i)=a22
4683                 a_chuj(1,2,num_conti,i)=a23
4684                 a_chuj(2,1,num_conti,i)=a32
4685                 a_chuj(2,2,num_conti,i)=a33
4686 C     --- Gradient of rij
4687                 do kkk=1,3
4688                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
4689                 enddo
4690                 kkll=0
4691                 do k=1,2
4692                   do l=1,2
4693                     kkll=kkll+1
4694                     do m=1,3
4695                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
4696                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
4697                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
4698                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
4699                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
4700                     enddo
4701                   enddo
4702                 enddo
4703                 ENDIF
4704                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
4705 C Calculate contact energies
4706                 cosa4=4.0D0*cosa
4707                 wij=cosa-3.0D0*cosb*cosg
4708                 cosbg1=cosb+cosg
4709                 cosbg2=cosb-cosg
4710 c               fac3=dsqrt(-ael6i)/r0ij**3
4711                 fac3=dsqrt(-ael6i)*r3ij
4712 c                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
4713                 ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
4714                 if (ees0tmp.gt.0) then
4715                   ees0pij=dsqrt(ees0tmp)
4716                 else
4717                   ees0pij=0
4718                 endif
4719 c                ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
4720                 ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
4721                 if (ees0tmp.gt.0) then
4722                   ees0mij=dsqrt(ees0tmp)
4723                 else
4724                   ees0mij=0
4725                 endif
4726 c               ees0mij=0.0D0
4727                 if (shield_mode.eq.0) then
4728                 fac_shield(i)=1.0d0
4729                 fac_shield(j)=1.0d0
4730                 else
4731                 ees0plist(num_conti,i)=j
4732 C                fac_shield(i)=0.4d0
4733 C                fac_shield(j)=0.6d0
4734                 endif
4735                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij)
4736      &          *fac_shield(i)*fac_shield(j)
4737                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij)
4738      &          *fac_shield(i)*fac_shield(j)
4739 C Diagnostics. Comment out or remove after debugging!
4740 c               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
4741 c               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
4742 c               ees0m(num_conti,i)=0.0D0
4743 C End diagnostics.
4744 c               write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
4745 c    & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
4746 C Angular derivatives of the contact function
4747                 ees0pij1=fac3/ees0pij
4748                 ees0mij1=fac3/ees0mij
4749                 fac3p=-3.0D0*fac3*rrmij
4750                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
4751                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
4752 c               ees0mij1=0.0D0
4753                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
4754                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
4755                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
4756                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
4757                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
4758                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
4759                 ecosap=ecosa1+ecosa2
4760                 ecosbp=ecosb1+ecosb2
4761                 ecosgp=ecosg1+ecosg2
4762                 ecosam=ecosa1-ecosa2
4763                 ecosbm=ecosb1-ecosb2
4764                 ecosgm=ecosg1-ecosg2
4765 C Diagnostics
4766 c               ecosap=ecosa1
4767 c               ecosbp=ecosb1
4768 c               ecosgp=ecosg1
4769 c               ecosam=0.0D0
4770 c               ecosbm=0.0D0
4771 c               ecosgm=0.0D0
4772 C End diagnostics
4773                 facont_hb(num_conti,i)=fcont
4774                 fprimcont=fprimcont/rij
4775 cd              facont_hb(num_conti,i)=1.0D0
4776 C Following line is for diagnostics.
4777 cd              fprimcont=0.0D0
4778                 do k=1,3
4779                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
4780                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
4781                 enddo
4782                 do k=1,3
4783                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
4784                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
4785                 enddo
4786                 gggp(1)=gggp(1)+ees0pijp*xj
4787                 gggp(2)=gggp(2)+ees0pijp*yj
4788                 gggp(3)=gggp(3)+ees0pijp*zj
4789                 gggm(1)=gggm(1)+ees0mijp*xj
4790                 gggm(2)=gggm(2)+ees0mijp*yj
4791                 gggm(3)=gggm(3)+ees0mijp*zj
4792 C Derivatives due to the contact function
4793                 gacont_hbr(1,num_conti,i)=fprimcont*xj
4794                 gacont_hbr(2,num_conti,i)=fprimcont*yj
4795                 gacont_hbr(3,num_conti,i)=fprimcont*zj
4796                 do k=1,3
4797 c
4798 c 10/24/08 cgrad and ! comments indicate the parts of the code removed
4799 c          following the change of gradient-summation algorithm.
4800 c
4801 cgrad                  ghalfp=0.5D0*gggp(k)
4802 cgrad                  ghalfm=0.5D0*gggm(k)
4803                   gacontp_hb1(k,num_conti,i)=!ghalfp
4804      &              +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i))
4805      &              + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
4806      &          *fac_shield(i)*fac_shield(j)
4807
4808                   gacontp_hb2(k,num_conti,i)=!ghalfp
4809      &              +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j))
4810      &              + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
4811      &          *fac_shield(i)*fac_shield(j)
4812
4813                   gacontp_hb3(k,num_conti,i)=gggp(k)
4814      &          *fac_shield(i)*fac_shield(j)
4815
4816                   gacontm_hb1(k,num_conti,i)=!ghalfm
4817      &              +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i))
4818      &              + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
4819      &          *fac_shield(i)*fac_shield(j)
4820
4821                   gacontm_hb2(k,num_conti,i)=!ghalfm
4822      &              +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j))
4823      &              + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
4824      &          *fac_shield(i)*fac_shield(j)
4825
4826                   gacontm_hb3(k,num_conti,i)=gggm(k)
4827      &          *fac_shield(i)*fac_shield(j)
4828
4829                 enddo
4830 C Diagnostics. Comment out or remove after debugging!
4831 cdiag           do k=1,3
4832 cdiag             gacontp_hb1(k,num_conti,i)=0.0D0
4833 cdiag             gacontp_hb2(k,num_conti,i)=0.0D0
4834 cdiag             gacontp_hb3(k,num_conti,i)=0.0D0
4835 cdiag             gacontm_hb1(k,num_conti,i)=0.0D0
4836 cdiag             gacontm_hb2(k,num_conti,i)=0.0D0
4837 cdiag             gacontm_hb3(k,num_conti,i)=0.0D0
4838 cdiag           enddo
4839               ENDIF ! wcorr
4840               endif  ! num_conti.le.maxconts
4841             endif  ! fcont.gt.0
4842           endif    ! j.gt.i+1
4843           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
4844             do k=1,4
4845               do l=1,3
4846                 ghalf=0.5d0*agg(l,k)
4847                 aggi(l,k)=aggi(l,k)+ghalf
4848                 aggi1(l,k)=aggi1(l,k)+agg(l,k)
4849                 aggj(l,k)=aggj(l,k)+ghalf
4850               enddo
4851             enddo
4852             if (j.eq.nres-1 .and. i.lt.j-2) then
4853               do k=1,4
4854                 do l=1,3
4855                   aggj1(l,k)=aggj1(l,k)+agg(l,k)
4856                 enddo
4857               enddo
4858             endif
4859           endif
4860 c          t_eelecij=t_eelecij+MPI_Wtime()-time00
4861       return
4862       end
4863 C-----------------------------------------------------------------------------
4864       subroutine eturn3(i,eello_turn3)
4865 C Third- and fourth-order contributions from turns
4866       implicit real*8 (a-h,o-z)
4867       include 'DIMENSIONS'
4868       include 'COMMON.IOUNITS'
4869       include 'COMMON.GEO'
4870       include 'COMMON.VAR'
4871       include 'COMMON.LOCAL'
4872       include 'COMMON.CHAIN'
4873       include 'COMMON.DERIV'
4874       include 'COMMON.INTERACT'
4875       include 'COMMON.CONTACTS'
4876       include 'COMMON.TORSION'
4877       include 'COMMON.VECTORS'
4878       include 'COMMON.FFIELD'
4879       include 'COMMON.CONTROL'
4880       include 'COMMON.SHIELD'
4881       dimension ggg(3)
4882       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
4883      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
4884      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2),gpizda1(2,2),
4885      &  gpizda2(2,2),auxgmat1(2,2),auxgmatt1(2,2),
4886      &  auxgmat2(2,2),auxgmatt2(2,2)
4887       double precision agg(3,4),aggi(3,4),aggi1(3,4),
4888      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
4889       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
4890      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
4891      &    num_conti,j1,j2
4892       j=i+2
4893 c      write (iout,*) "eturn3",i,j,j1,j2
4894       a_temp(1,1)=a22
4895       a_temp(1,2)=a23
4896       a_temp(2,1)=a32
4897       a_temp(2,2)=a33
4898 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4899 C
4900 C               Third-order contributions
4901 C
4902 C                 (i+2)o----(i+3)
4903 C                      | |
4904 C                      | |
4905 C                 (i+1)o----i
4906 C
4907 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4908 cd        call checkint_turn3(i,a_temp,eello_turn3_num)
4909         call matmat2(EUg(1,1,i+1),EUg(1,1,i+2),auxmat(1,1))
4910 c auxalary matices for theta gradient
4911 c auxalary matrix for i+1 and constant i+2
4912         call matmat2(gtEUg(1,1,i+1),EUg(1,1,i+2),auxgmat1(1,1))
4913 c auxalary matrix for i+2 and constant i+1
4914         call matmat2(EUg(1,1,i+1),gtEUg(1,1,i+2),auxgmat2(1,1))
4915         call transpose2(auxmat(1,1),auxmat1(1,1))
4916         call transpose2(auxgmat1(1,1),auxgmatt1(1,1))
4917         call transpose2(auxgmat2(1,1),auxgmatt2(1,1))
4918         call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4919         call matmat2(a_temp(1,1),auxgmatt1(1,1),gpizda1(1,1))
4920         call matmat2(a_temp(1,1),auxgmatt2(1,1),gpizda2(1,1))
4921         if (shield_mode.eq.0) then
4922         fac_shield(i)=1.0
4923         fac_shield(j)=1.0
4924 C        else
4925 C        fac_shield(i)=0.4
4926 C        fac_shield(j)=0.6
4927         endif
4928         eello_turn3=eello_turn3+0.5d0*(pizda(1,1)+pizda(2,2))
4929      &  *fac_shield(i)*fac_shield(j)
4930         eello_t3=0.5d0*(pizda(1,1)+pizda(2,2))
4931      &  *fac_shield(i)*fac_shield(j)
4932         if (energy_dec) write (iout,'(6heturn3,2i5,0pf7.3)') i,i+2,
4933      &    eello_t3
4934 C#ifdef NEWCORR
4935 C Derivatives in theta
4936         gloc(nphi+i,icg)=gloc(nphi+i,icg)
4937      &  +0.5d0*(gpizda1(1,1)+gpizda1(2,2))*wturn3
4938      &   *fac_shield(i)*fac_shield(j)
4939         gloc(nphi+i+1,icg)=gloc(nphi+i+1,icg)
4940      &  +0.5d0*(gpizda2(1,1)+gpizda2(2,2))*wturn3
4941      &   *fac_shield(i)*fac_shield(j)
4942 C#endif
4943
4944 C Derivatives in shield mode
4945           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
4946      &  (shield_mode.gt.0)) then
4947 C          print *,i,j
4948
4949           do ilist=1,ishield_list(i)
4950            iresshield=shield_list(ilist,i)
4951            do k=1,3
4952            rlocshield=grad_shield_side(k,ilist,i)*eello_t3/fac_shield(i)
4953 C     &      *2.0
4954            gshieldx_t3(k,iresshield)=gshieldx_t3(k,iresshield)+
4955      &              rlocshield
4956      & +grad_shield_loc(k,ilist,i)*eello_t3/fac_shield(i)
4957             gshieldc_t3(k,iresshield-1)=gshieldc_t3(k,iresshield-1)
4958      &      +rlocshield
4959            enddo
4960           enddo
4961           do ilist=1,ishield_list(j)
4962            iresshield=shield_list(ilist,j)
4963            do k=1,3
4964            rlocshield=grad_shield_side(k,ilist,j)*eello_t3/fac_shield(j)
4965 C     &     *2.0
4966            gshieldx_t3(k,iresshield)=gshieldx_t3(k,iresshield)+
4967      &              rlocshield
4968      & +grad_shield_loc(k,ilist,j)*eello_t3/fac_shield(j)
4969            gshieldc_t3(k,iresshield-1)=gshieldc_t3(k,iresshield-1)
4970      &             +rlocshield
4971
4972            enddo
4973           enddo
4974
4975           do k=1,3
4976             gshieldc_t3(k,i)=gshieldc_t3(k,i)+
4977      &              grad_shield(k,i)*eello_t3/fac_shield(i)
4978             gshieldc_t3(k,j)=gshieldc_t3(k,j)+
4979      &              grad_shield(k,j)*eello_t3/fac_shield(j)
4980             gshieldc_t3(k,i-1)=gshieldc_t3(k,i-1)+
4981      &              grad_shield(k,i)*eello_t3/fac_shield(i)
4982             gshieldc_t3(k,j-1)=gshieldc_t3(k,j-1)+
4983      &              grad_shield(k,j)*eello_t3/fac_shield(j)
4984            enddo
4985            endif
4986
4987 C        if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
4988 cd        write (2,*) 'i,',i,' j',j,'eello_turn3',
4989 cd     &    0.5d0*(pizda(1,1)+pizda(2,2)),
4990 cd     &    ' eello_turn3_num',4*eello_turn3_num
4991 C Derivatives in gamma(i)
4992         call matmat2(EUgder(1,1,i+1),EUg(1,1,i+2),auxmat2(1,1))
4993         call transpose2(auxmat2(1,1),auxmat3(1,1))
4994         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
4995         gel_loc_turn3(i)=gel_loc_turn3(i)+0.5d0*(pizda(1,1)+pizda(2,2))
4996      &   *fac_shield(i)*fac_shield(j)
4997 C Derivatives in gamma(i+1)
4998         call matmat2(EUg(1,1,i+1),EUgder(1,1,i+2),auxmat2(1,1))
4999         call transpose2(auxmat2(1,1),auxmat3(1,1))
5000         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
5001         gel_loc_turn3(i+1)=gel_loc_turn3(i+1)
5002      &    +0.5d0*(pizda(1,1)+pizda(2,2))
5003      &   *fac_shield(i)*fac_shield(j)
5004 C Cartesian derivatives
5005         do l=1,3
5006 c            ghalf1=0.5d0*agg(l,1)
5007 c            ghalf2=0.5d0*agg(l,2)
5008 c            ghalf3=0.5d0*agg(l,3)
5009 c            ghalf4=0.5d0*agg(l,4)
5010           a_temp(1,1)=aggi(l,1)!+ghalf1
5011           a_temp(1,2)=aggi(l,2)!+ghalf2
5012           a_temp(2,1)=aggi(l,3)!+ghalf3
5013           a_temp(2,2)=aggi(l,4)!+ghalf4
5014           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
5015           gcorr3_turn(l,i)=gcorr3_turn(l,i)
5016      &      +0.5d0*(pizda(1,1)+pizda(2,2))
5017      &   *fac_shield(i)*fac_shield(j)
5018
5019           a_temp(1,1)=aggi1(l,1)!+agg(l,1)
5020           a_temp(1,2)=aggi1(l,2)!+agg(l,2)
5021           a_temp(2,1)=aggi1(l,3)!+agg(l,3)
5022           a_temp(2,2)=aggi1(l,4)!+agg(l,4)
5023           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
5024           gcorr3_turn(l,i+1)=gcorr3_turn(l,i+1)
5025      &      +0.5d0*(pizda(1,1)+pizda(2,2))
5026      &   *fac_shield(i)*fac_shield(j)
5027           a_temp(1,1)=aggj(l,1)!+ghalf1
5028           a_temp(1,2)=aggj(l,2)!+ghalf2
5029           a_temp(2,1)=aggj(l,3)!+ghalf3
5030           a_temp(2,2)=aggj(l,4)!+ghalf4
5031           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
5032           gcorr3_turn(l,j)=gcorr3_turn(l,j)
5033      &      +0.5d0*(pizda(1,1)+pizda(2,2))
5034      &   *fac_shield(i)*fac_shield(j)
5035           a_temp(1,1)=aggj1(l,1)
5036           a_temp(1,2)=aggj1(l,2)
5037           a_temp(2,1)=aggj1(l,3)
5038           a_temp(2,2)=aggj1(l,4)
5039           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
5040           gcorr3_turn(l,j1)=gcorr3_turn(l,j1)
5041      &      +0.5d0*(pizda(1,1)+pizda(2,2))
5042      &   *fac_shield(i)*fac_shield(j)
5043         enddo
5044       return
5045       end
5046 C-------------------------------------------------------------------------------
5047       subroutine eturn4(i,eello_turn4)
5048 C Third- and fourth-order contributions from turns
5049       implicit real*8 (a-h,o-z)
5050       include 'DIMENSIONS'
5051       include 'COMMON.IOUNITS'
5052       include 'COMMON.GEO'
5053       include 'COMMON.VAR'
5054       include 'COMMON.LOCAL'
5055       include 'COMMON.CHAIN'
5056       include 'COMMON.DERIV'
5057       include 'COMMON.INTERACT'
5058       include 'COMMON.CONTACTS'
5059       include 'COMMON.TORSION'
5060       include 'COMMON.VECTORS'
5061       include 'COMMON.FFIELD'
5062       include 'COMMON.CONTROL'
5063       include 'COMMON.SHIELD'
5064       dimension ggg(3)
5065       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
5066      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
5067      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2),auxgvec(2),
5068      &  auxgEvec1(2),auxgEvec2(2),auxgEvec3(2),
5069      &  gte1t(2,2),gte2t(2,2),gte3t(2,2),
5070      &  gte1a(2,2),gtae3(2,2),gtae3e2(2,2), ae3gte2(2,2),
5071      &  gtEpizda1(2,2),gtEpizda2(2,2),gtEpizda3(2,2)
5072       double precision agg(3,4),aggi(3,4),aggi1(3,4),
5073      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
5074       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
5075      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
5076      &    num_conti,j1,j2
5077       j=i+3
5078 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
5079 C
5080 C               Fourth-order contributions
5081 C
5082 C                 (i+3)o----(i+4)
5083 C                     /  |
5084 C               (i+2)o   |
5085 C                     \  |
5086 C                 (i+1)o----i
5087 C
5088 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
5089 cd        call checkint_turn4(i,a_temp,eello_turn4_num)
5090 c        write (iout,*) "eturn4 i",i," j",j," j1",j1," j2",j2
5091 c        write(iout,*)"WCHODZE W PROGRAM"
5092         a_temp(1,1)=a22
5093         a_temp(1,2)=a23
5094         a_temp(2,1)=a32
5095         a_temp(2,2)=a33
5096         iti1=itype2loc(itype(i+1))
5097         iti2=itype2loc(itype(i+2))
5098         iti3=itype2loc(itype(i+3))
5099 c        write(iout,*) "iti1",iti1," iti2",iti2," iti3",iti3
5100         call transpose2(EUg(1,1,i+1),e1t(1,1))
5101         call transpose2(Eug(1,1,i+2),e2t(1,1))
5102         call transpose2(Eug(1,1,i+3),e3t(1,1))
5103 C Ematrix derivative in theta
5104         call transpose2(gtEUg(1,1,i+1),gte1t(1,1))
5105         call transpose2(gtEug(1,1,i+2),gte2t(1,1))
5106         call transpose2(gtEug(1,1,i+3),gte3t(1,1))
5107         call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5108 c       eta1 in derivative theta
5109         call matmat2(gte1t(1,1),a_temp(1,1),gte1a(1,1))
5110         call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5111 c       auxgvec is derivative of Ub2 so i+3 theta
5112         call matvec2(e1a(1,1),gUb2(1,i+3),auxgvec(1))
5113 c       auxalary matrix of E i+1
5114         call matvec2(gte1a(1,1),Ub2(1,i+3),auxgEvec1(1))
5115 c        s1=0.0
5116 c        gs1=0.0
5117         s1=scalar2(b1(1,i+2),auxvec(1))
5118 c derivative of theta i+2 with constant i+3
5119         gs23=scalar2(gtb1(1,i+2),auxvec(1))
5120 c derivative of theta i+2 with constant i+2
5121         gs32=scalar2(b1(1,i+2),auxgvec(1))
5122 c derivative of E matix in theta of i+1
5123         gsE13=scalar2(b1(1,i+2),auxgEvec1(1))
5124
5125         call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5126 c       ea31 in derivative theta
5127         call matmat2(a_temp(1,1),gte3t(1,1),gtae3(1,1))
5128         call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5129 c auxilary matrix auxgvec of Ub2 with constant E matirx
5130         call matvec2(ae3(1,1),gUb2(1,i+2),auxgvec(1))
5131 c auxilary matrix auxgEvec1 of E matix with Ub2 constant
5132         call matvec2(gtae3(1,1),Ub2(1,i+2),auxgEvec3(1))
5133
5134 c        s2=0.0
5135 c        gs2=0.0
5136         s2=scalar2(b1(1,i+1),auxvec(1))
5137 c derivative of theta i+1 with constant i+3
5138         gs13=scalar2(gtb1(1,i+1),auxvec(1))
5139 c derivative of theta i+2 with constant i+1
5140         gs21=scalar2(b1(1,i+1),auxgvec(1))
5141 c derivative of theta i+3 with constant i+1
5142         gsE31=scalar2(b1(1,i+1),auxgEvec3(1))
5143 c        write(iout,*) gs1,gs2,'i=',i,auxgvec(1),gUb2(1,i+2),gtb1(1,i+2),
5144 c     &  gtb1(1,i+1)
5145         call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5146 c two derivatives over diffetent matrices
5147 c gtae3e2 is derivative over i+3
5148         call matmat2(gtae3(1,1),e2t(1,1),gtae3e2(1,1))
5149 c ae3gte2 is derivative over i+2
5150         call matmat2(ae3(1,1),gte2t(1,1),ae3gte2(1,1))
5151         call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5152 c three possible derivative over theta E matices
5153 c i+1
5154         call matmat2(ae3e2(1,1),gte1t(1,1),gtEpizda1(1,1))
5155 c i+2
5156         call matmat2(ae3gte2(1,1),e1t(1,1),gtEpizda2(1,1))
5157 c i+3
5158         call matmat2(gtae3e2(1,1),e1t(1,1),gtEpizda3(1,1))
5159         s3=0.5d0*(pizda(1,1)+pizda(2,2))
5160
5161         gsEE1=0.5d0*(gtEpizda1(1,1)+gtEpizda1(2,2))
5162         gsEE2=0.5d0*(gtEpizda2(1,1)+gtEpizda2(2,2))
5163         gsEE3=0.5d0*(gtEpizda3(1,1)+gtEpizda3(2,2))
5164         if (shield_mode.eq.0) then
5165         fac_shield(i)=1.0
5166         fac_shield(j)=1.0
5167 C        else
5168 C        fac_shield(i)=0.6
5169 C        fac_shield(j)=0.4
5170         endif
5171         eello_turn4=eello_turn4-(s1+s2+s3)
5172      &  *fac_shield(i)*fac_shield(j)
5173         eello_t4=-(s1+s2+s3)
5174      &  *fac_shield(i)*fac_shield(j)
5175 c             write(iout,*)'chujOWO', auxvec(1),b1(1,iti2)
5176         if (energy_dec) write (iout,'(a6,2i5,0pf7.3,3f7.3)')
5177      &      'eturn4',i,j,-(s1+s2+s3),s1,s2,s3
5178 C Now derivative over shield:
5179           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
5180      &  (shield_mode.gt.0)) then
5181 C          print *,i,j
5182
5183           do ilist=1,ishield_list(i)
5184            iresshield=shield_list(ilist,i)
5185            do k=1,3
5186            rlocshield=grad_shield_side(k,ilist,i)*eello_t4/fac_shield(i)
5187 C     &      *2.0
5188            gshieldx_t4(k,iresshield)=gshieldx_t4(k,iresshield)+
5189      &              rlocshield
5190      & +grad_shield_loc(k,ilist,i)*eello_t4/fac_shield(i)
5191             gshieldc_t4(k,iresshield-1)=gshieldc_t4(k,iresshield-1)
5192      &      +rlocshield
5193            enddo
5194           enddo
5195           do ilist=1,ishield_list(j)
5196            iresshield=shield_list(ilist,j)
5197            do k=1,3
5198            rlocshield=grad_shield_side(k,ilist,j)*eello_t4/fac_shield(j)
5199 C     &     *2.0
5200            gshieldx_t4(k,iresshield)=gshieldx_t4(k,iresshield)+
5201      &              rlocshield
5202      & +grad_shield_loc(k,ilist,j)*eello_t4/fac_shield(j)
5203            gshieldc_t4(k,iresshield-1)=gshieldc_t4(k,iresshield-1)
5204      &             +rlocshield
5205
5206            enddo
5207           enddo
5208
5209           do k=1,3
5210             gshieldc_t4(k,i)=gshieldc_t4(k,i)+
5211      &              grad_shield(k,i)*eello_t4/fac_shield(i)
5212             gshieldc_t4(k,j)=gshieldc_t4(k,j)+
5213      &              grad_shield(k,j)*eello_t4/fac_shield(j)
5214             gshieldc_t4(k,i-1)=gshieldc_t4(k,i-1)+
5215      &              grad_shield(k,i)*eello_t4/fac_shield(i)
5216             gshieldc_t4(k,j-1)=gshieldc_t4(k,j-1)+
5217      &              grad_shield(k,j)*eello_t4/fac_shield(j)
5218            enddo
5219            endif
5220
5221
5222
5223
5224
5225
5226 cd        write (2,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
5227 cd     &    ' eello_turn4_num',8*eello_turn4_num
5228 #ifdef NEWCORR
5229         gloc(nphi+i,icg)=gloc(nphi+i,icg)
5230      &                  -(gs13+gsE13+gsEE1)*wturn4
5231      &  *fac_shield(i)*fac_shield(j)
5232         gloc(nphi+i+1,icg)= gloc(nphi+i+1,icg)
5233      &                    -(gs23+gs21+gsEE2)*wturn4
5234      &  *fac_shield(i)*fac_shield(j)
5235
5236         gloc(nphi+i+2,icg)= gloc(nphi+i+2,icg)
5237      &                    -(gs32+gsE31+gsEE3)*wturn4
5238      &  *fac_shield(i)*fac_shield(j)
5239
5240 c         gloc(nphi+i+1,icg)=gloc(nphi+i+1,icg)-
5241 c     &   gs2
5242 #endif
5243         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
5244      &      'eturn4',i,j,-(s1+s2+s3)
5245 c        write (iout,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
5246 c     &    ' eello_turn4_num',8*eello_turn4_num
5247 C Derivatives in gamma(i)
5248         call transpose2(EUgder(1,1,i+1),e1tder(1,1))
5249         call matmat2(e1tder(1,1),a_temp(1,1),auxmat(1,1))
5250         call matvec2(auxmat(1,1),Ub2(1,i+3),auxvec(1))
5251         s1=scalar2(b1(1,i+2),auxvec(1))
5252         call matmat2(ae3e2(1,1),e1tder(1,1),pizda(1,1))
5253         s3=0.5d0*(pizda(1,1)+pizda(2,2))
5254         gel_loc_turn4(i)=gel_loc_turn4(i)-(s1+s3)
5255      &  *fac_shield(i)*fac_shield(j)
5256 C Derivatives in gamma(i+1)
5257         call transpose2(EUgder(1,1,i+2),e2tder(1,1))
5258         call matvec2(ae3(1,1),Ub2der(1,i+2),auxvec(1))
5259         s2=scalar2(b1(1,i+1),auxvec(1))
5260         call matmat2(ae3(1,1),e2tder(1,1),auxmat(1,1))
5261         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
5262         s3=0.5d0*(pizda(1,1)+pizda(2,2))
5263         gel_loc_turn4(i+1)=gel_loc_turn4(i+1)-(s2+s3)
5264      &  *fac_shield(i)*fac_shield(j)
5265 C Derivatives in gamma(i+2)
5266         call transpose2(EUgder(1,1,i+3),e3tder(1,1))
5267         call matvec2(e1a(1,1),Ub2der(1,i+3),auxvec(1))
5268         s1=scalar2(b1(1,i+2),auxvec(1))
5269         call matmat2(a_temp(1,1),e3tder(1,1),auxmat(1,1))
5270         call matvec2(auxmat(1,1),Ub2(1,i+2),auxvec(1))
5271         s2=scalar2(b1(1,i+1),auxvec(1))
5272         call matmat2(auxmat(1,1),e2t(1,1),auxmat3(1,1))
5273         call matmat2(auxmat3(1,1),e1t(1,1),pizda(1,1))
5274         s3=0.5d0*(pizda(1,1)+pizda(2,2))
5275         gel_loc_turn4(i+2)=gel_loc_turn4(i+2)-(s1+s2+s3)
5276      &  *fac_shield(i)*fac_shield(j)
5277 C Cartesian derivatives
5278 C Derivatives of this turn contributions in DC(i+2)
5279         if (j.lt.nres-1) then
5280           do l=1,3
5281             a_temp(1,1)=agg(l,1)
5282             a_temp(1,2)=agg(l,2)
5283             a_temp(2,1)=agg(l,3)
5284             a_temp(2,2)=agg(l,4)
5285             call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5286             call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5287             s1=scalar2(b1(1,i+2),auxvec(1))
5288             call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5289             call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5290             s2=scalar2(b1(1,i+1),auxvec(1))
5291             call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5292             call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5293             s3=0.5d0*(pizda(1,1)+pizda(2,2))
5294             ggg(l)=-(s1+s2+s3)
5295             gcorr4_turn(l,i+2)=gcorr4_turn(l,i+2)-(s1+s2+s3)
5296      &  *fac_shield(i)*fac_shield(j)
5297           enddo
5298         endif
5299 C Remaining derivatives of this turn contribution
5300         do l=1,3
5301           a_temp(1,1)=aggi(l,1)
5302           a_temp(1,2)=aggi(l,2)
5303           a_temp(2,1)=aggi(l,3)
5304           a_temp(2,2)=aggi(l,4)
5305           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5306           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5307           s1=scalar2(b1(1,i+2),auxvec(1))
5308           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5309           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5310           s2=scalar2(b1(1,i+1),auxvec(1))
5311           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5312           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5313           s3=0.5d0*(pizda(1,1)+pizda(2,2))
5314           gcorr4_turn(l,i)=gcorr4_turn(l,i)-(s1+s2+s3)
5315      &  *fac_shield(i)*fac_shield(j)
5316           a_temp(1,1)=aggi1(l,1)
5317           a_temp(1,2)=aggi1(l,2)
5318           a_temp(2,1)=aggi1(l,3)
5319           a_temp(2,2)=aggi1(l,4)
5320           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5321           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5322           s1=scalar2(b1(1,i+2),auxvec(1))
5323           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5324           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5325           s2=scalar2(b1(1,i+1),auxvec(1))
5326           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5327           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5328           s3=0.5d0*(pizda(1,1)+pizda(2,2))
5329           gcorr4_turn(l,i+1)=gcorr4_turn(l,i+1)-(s1+s2+s3)
5330      &  *fac_shield(i)*fac_shield(j)
5331           a_temp(1,1)=aggj(l,1)
5332           a_temp(1,2)=aggj(l,2)
5333           a_temp(2,1)=aggj(l,3)
5334           a_temp(2,2)=aggj(l,4)
5335           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5336           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5337           s1=scalar2(b1(1,i+2),auxvec(1))
5338           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5339           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5340           s2=scalar2(b1(1,i+1),auxvec(1))
5341           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5342           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5343           s3=0.5d0*(pizda(1,1)+pizda(2,2))
5344           gcorr4_turn(l,j)=gcorr4_turn(l,j)-(s1+s2+s3)
5345      &  *fac_shield(i)*fac_shield(j)
5346           a_temp(1,1)=aggj1(l,1)
5347           a_temp(1,2)=aggj1(l,2)
5348           a_temp(2,1)=aggj1(l,3)
5349           a_temp(2,2)=aggj1(l,4)
5350           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5351           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5352           s1=scalar2(b1(1,i+2),auxvec(1))
5353           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5354           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5355           s2=scalar2(b1(1,i+1),auxvec(1))
5356           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5357           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5358           s3=0.5d0*(pizda(1,1)+pizda(2,2))
5359 c          write (iout,*) "s1",s1," s2",s2," s3",s3," s1+s2+s3",s1+s2+s3
5360           gcorr4_turn(l,j1)=gcorr4_turn(l,j1)-(s1+s2+s3)
5361      &  *fac_shield(i)*fac_shield(j)
5362         enddo
5363       return
5364       end
5365 C-----------------------------------------------------------------------------
5366       subroutine vecpr(u,v,w)
5367       implicit real*8(a-h,o-z)
5368       dimension u(3),v(3),w(3)
5369       w(1)=u(2)*v(3)-u(3)*v(2)
5370       w(2)=-u(1)*v(3)+u(3)*v(1)
5371       w(3)=u(1)*v(2)-u(2)*v(1)
5372       return
5373       end
5374 C-----------------------------------------------------------------------------
5375       subroutine unormderiv(u,ugrad,unorm,ungrad)
5376 C This subroutine computes the derivatives of a normalized vector u, given
5377 C the derivatives computed without normalization conditions, ugrad. Returns
5378 C ungrad.
5379       implicit none
5380       double precision u(3),ugrad(3,3),unorm,ungrad(3,3)
5381       double precision vec(3)
5382       double precision scalar
5383       integer i,j
5384 c      write (2,*) 'ugrad',ugrad
5385 c      write (2,*) 'u',u
5386       do i=1,3
5387         vec(i)=scalar(ugrad(1,i),u(1))
5388       enddo
5389 c      write (2,*) 'vec',vec
5390       do i=1,3
5391         do j=1,3
5392           ungrad(j,i)=(ugrad(j,i)-u(j)*vec(i))*unorm
5393         enddo
5394       enddo
5395 c      write (2,*) 'ungrad',ungrad
5396       return
5397       end
5398 C-----------------------------------------------------------------------------
5399       subroutine escp_soft_sphere(evdw2,evdw2_14)
5400 C
5401 C This subroutine calculates the excluded-volume interaction energy between
5402 C peptide-group centers and side chains and its gradient in virtual-bond and
5403 C side-chain vectors.
5404 C
5405       implicit real*8 (a-h,o-z)
5406       include 'DIMENSIONS'
5407       include 'COMMON.GEO'
5408       include 'COMMON.VAR'
5409       include 'COMMON.LOCAL'
5410       include 'COMMON.CHAIN'
5411       include 'COMMON.DERIV'
5412       include 'COMMON.INTERACT'
5413       include 'COMMON.FFIELD'
5414       include 'COMMON.IOUNITS'
5415       include 'COMMON.CONTROL'
5416       dimension ggg(3)
5417       integer xshift,yshift,zshift
5418       evdw2=0.0D0
5419       evdw2_14=0.0d0
5420       r0_scp=4.5d0
5421 cd    print '(a)','Enter ESCP'
5422 cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
5423 C      do xshift=-1,1
5424 C      do yshift=-1,1
5425 C      do zshift=-1,1
5426       do i=iatscp_s,iatscp_e
5427         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
5428         iteli=itel(i)
5429         xi=0.5D0*(c(1,i)+c(1,i+1))
5430         yi=0.5D0*(c(2,i)+c(2,i+1))
5431         zi=0.5D0*(c(3,i)+c(3,i+1))
5432 C Return atom into box, boxxsize is size of box in x dimension
5433 c  134   continue
5434 c        if (xi.gt.((xshift+0.5d0)*boxxsize)) xi=xi-boxxsize
5435 c        if (xi.lt.((xshift-0.5d0)*boxxsize)) xi=xi+boxxsize
5436 C Condition for being inside the proper box
5437 c        if ((xi.gt.((xshift+0.5d0)*boxxsize)).or.
5438 c     &       (xi.lt.((xshift-0.5d0)*boxxsize))) then
5439 c        go to 134
5440 c        endif
5441 c  135   continue
5442 c        if (yi.gt.((yshift+0.5d0)*boxysize)) yi=yi-boxysize
5443 c        if (yi.lt.((yshift-0.5d0)*boxysize)) yi=yi+boxysize
5444 C Condition for being inside the proper box
5445 c        if ((yi.gt.((yshift+0.5d0)*boxysize)).or.
5446 c     &       (yi.lt.((yshift-0.5d0)*boxysize))) then
5447 c        go to 135
5448 c c       endif
5449 c  136   continue
5450 c        if (zi.gt.((zshift+0.5d0)*boxzsize)) zi=zi-boxzsize
5451 c        if (zi.lt.((zshift-0.5d0)*boxzsize)) zi=zi+boxzsize
5452 cC Condition for being inside the proper box
5453 c        if ((zi.gt.((zshift+0.5d0)*boxzsize)).or.
5454 c     &       (zi.lt.((zshift-0.5d0)*boxzsize))) then
5455 c        go to 136
5456 c        endif
5457           xi=mod(xi,boxxsize)
5458           if (xi.lt.0) xi=xi+boxxsize
5459           yi=mod(yi,boxysize)
5460           if (yi.lt.0) yi=yi+boxysize
5461           zi=mod(zi,boxzsize)
5462           if (zi.lt.0) zi=zi+boxzsize
5463 C          xi=xi+xshift*boxxsize
5464 C          yi=yi+yshift*boxysize
5465 C          zi=zi+zshift*boxzsize
5466         do iint=1,nscp_gr(i)
5467
5468         do j=iscpstart(i,iint),iscpend(i,iint)
5469           if (itype(j).eq.ntyp1) cycle
5470           itypj=iabs(itype(j))
5471 C Uncomment following three lines for SC-p interactions
5472 c         xj=c(1,nres+j)-xi
5473 c         yj=c(2,nres+j)-yi
5474 c         zj=c(3,nres+j)-zi
5475 C Uncomment following three lines for Ca-p interactions
5476           xj=c(1,j)
5477           yj=c(2,j)
5478           zj=c(3,j)
5479 c  174   continue
5480 c        if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
5481 c        if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
5482 C Condition for being inside the proper box
5483 c        if ((xj.gt.((0.5d0)*boxxsize)).or.
5484 c     &       (xj.lt.((-0.5d0)*boxxsize))) then
5485 c        go to 174
5486 c        endif
5487 c  175   continue
5488 c        if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
5489 c        if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
5490 cC Condition for being inside the proper box
5491 c        if ((yj.gt.((0.5d0)*boxysize)).or.
5492 c     &       (yj.lt.((-0.5d0)*boxysize))) then
5493 c        go to 175
5494 c        endif
5495 c  176   continue
5496 c        if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
5497 c        if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
5498 C Condition for being inside the proper box
5499 c        if ((zj.gt.((0.5d0)*boxzsize)).or.
5500 c     &       (zj.lt.((-0.5d0)*boxzsize))) then
5501 c        go to 176
5502           xj=mod(xj,boxxsize)
5503           if (xj.lt.0) xj=xj+boxxsize
5504           yj=mod(yj,boxysize)
5505           if (yj.lt.0) yj=yj+boxysize
5506           zj=mod(zj,boxzsize)
5507           if (zj.lt.0) zj=zj+boxzsize
5508       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
5509       xj_safe=xj
5510       yj_safe=yj
5511       zj_safe=zj
5512       subchap=0
5513       do xshift=-1,1
5514       do yshift=-1,1
5515       do zshift=-1,1
5516           xj=xj_safe+xshift*boxxsize
5517           yj=yj_safe+yshift*boxysize
5518           zj=zj_safe+zshift*boxzsize
5519           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
5520           if(dist_temp.lt.dist_init) then
5521             dist_init=dist_temp
5522             xj_temp=xj
5523             yj_temp=yj
5524             zj_temp=zj
5525             subchap=1
5526           endif
5527        enddo
5528        enddo
5529        enddo
5530        if (subchap.eq.1) then
5531           xj=xj_temp-xi
5532           yj=yj_temp-yi
5533           zj=zj_temp-zi
5534        else
5535           xj=xj_safe-xi
5536           yj=yj_safe-yi
5537           zj=zj_safe-zi
5538        endif
5539 c c       endif
5540 C          xj=xj-xi
5541 C          yj=yj-yi
5542 C          zj=zj-zi
5543           rij=xj*xj+yj*yj+zj*zj
5544
5545           r0ij=r0_scp
5546           r0ijsq=r0ij*r0ij
5547           if (rij.lt.r0ijsq) then
5548             evdwij=0.25d0*(rij-r0ijsq)**2
5549             fac=rij-r0ijsq
5550           else
5551             evdwij=0.0d0
5552             fac=0.0d0
5553           endif
5554           evdw2=evdw2+evdwij
5555 C
5556 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
5557 C
5558           ggg(1)=xj*fac
5559           ggg(2)=yj*fac
5560           ggg(3)=zj*fac
5561 cgrad          if (j.lt.i) then
5562 cd          write (iout,*) 'j<i'
5563 C Uncomment following three lines for SC-p interactions
5564 c           do k=1,3
5565 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
5566 c           enddo
5567 cgrad          else
5568 cd          write (iout,*) 'j>i'
5569 cgrad            do k=1,3
5570 cgrad              ggg(k)=-ggg(k)
5571 C Uncomment following line for SC-p interactions
5572 c             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
5573 cgrad            enddo
5574 cgrad          endif
5575 cgrad          do k=1,3
5576 cgrad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
5577 cgrad          enddo
5578 cgrad          kstart=min0(i+1,j)
5579 cgrad          kend=max0(i-1,j-1)
5580 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
5581 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
5582 cgrad          do k=kstart,kend
5583 cgrad            do l=1,3
5584 cgrad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
5585 cgrad            enddo
5586 cgrad          enddo
5587           do k=1,3
5588             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
5589             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
5590           enddo
5591         enddo
5592
5593         enddo ! iint
5594       enddo ! i
5595 C      enddo !zshift
5596 C      enddo !yshift
5597 C      enddo !xshift
5598       return
5599       end
5600 C-----------------------------------------------------------------------------
5601       subroutine escp(evdw2,evdw2_14)
5602 C
5603 C This subroutine calculates the excluded-volume interaction energy between
5604 C peptide-group centers and side chains and its gradient in virtual-bond and
5605 C side-chain vectors.
5606 C
5607       implicit real*8 (a-h,o-z)
5608       include 'DIMENSIONS'
5609       include 'COMMON.GEO'
5610       include 'COMMON.VAR'
5611       include 'COMMON.LOCAL'
5612       include 'COMMON.CHAIN'
5613       include 'COMMON.DERIV'
5614       include 'COMMON.INTERACT'
5615       include 'COMMON.FFIELD'
5616       include 'COMMON.IOUNITS'
5617       include 'COMMON.CONTROL'
5618       include 'COMMON.SPLITELE'
5619       integer xshift,yshift,zshift
5620       dimension ggg(3)
5621       evdw2=0.0D0
5622       evdw2_14=0.0d0
5623 c        print *,boxxsize,boxysize,boxzsize,'wymiary pudla'
5624 cd    print '(a)','Enter ESCP'
5625 cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
5626 C      do xshift=-1,1
5627 C      do yshift=-1,1
5628 C      do zshift=-1,1
5629       if (energy_dec) write (iout,*) "escp:",r_cut,rlamb
5630       do i=iatscp_s,iatscp_e
5631         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
5632         iteli=itel(i)
5633         xi=0.5D0*(c(1,i)+c(1,i+1))
5634         yi=0.5D0*(c(2,i)+c(2,i+1))
5635         zi=0.5D0*(c(3,i)+c(3,i+1))
5636           xi=mod(xi,boxxsize)
5637           if (xi.lt.0) xi=xi+boxxsize
5638           yi=mod(yi,boxysize)
5639           if (yi.lt.0) yi=yi+boxysize
5640           zi=mod(zi,boxzsize)
5641           if (zi.lt.0) zi=zi+boxzsize
5642 c          xi=xi+xshift*boxxsize
5643 c          yi=yi+yshift*boxysize
5644 c          zi=zi+zshift*boxzsize
5645 c        print *,xi,yi,zi,'polozenie i'
5646 C Return atom into box, boxxsize is size of box in x dimension
5647 c  134   continue
5648 c        if (xi.gt.((xshift+0.5d0)*boxxsize)) xi=xi-boxxsize
5649 c        if (xi.lt.((xshift-0.5d0)*boxxsize)) xi=xi+boxxsize
5650 C Condition for being inside the proper box
5651 c        if ((xi.gt.((xshift+0.5d0)*boxxsize)).or.
5652 c     &       (xi.lt.((xshift-0.5d0)*boxxsize))) then
5653 c        go to 134
5654 c        endif
5655 c  135   continue
5656 c          print *,xi,boxxsize,"pierwszy"
5657
5658 c        if (yi.gt.((yshift+0.5d0)*boxysize)) yi=yi-boxysize
5659 c        if (yi.lt.((yshift-0.5d0)*boxysize)) yi=yi+boxysize
5660 C Condition for being inside the proper box
5661 c        if ((yi.gt.((yshift+0.5d0)*boxysize)).or.
5662 c     &       (yi.lt.((yshift-0.5d0)*boxysize))) then
5663 c        go to 135
5664 c        endif
5665 c  136   continue
5666 c        if (zi.gt.((zshift+0.5d0)*boxzsize)) zi=zi-boxzsize
5667 c        if (zi.lt.((zshift-0.5d0)*boxzsize)) zi=zi+boxzsize
5668 C Condition for being inside the proper box
5669 c        if ((zi.gt.((zshift+0.5d0)*boxzsize)).or.
5670 c     &       (zi.lt.((zshift-0.5d0)*boxzsize))) then
5671 c        go to 136
5672 c        endif
5673         do iint=1,nscp_gr(i)
5674
5675         do j=iscpstart(i,iint),iscpend(i,iint)
5676           itypj=iabs(itype(j))
5677           if (itypj.eq.ntyp1) cycle
5678 C Uncomment following three lines for SC-p interactions
5679 c         xj=c(1,nres+j)-xi
5680 c         yj=c(2,nres+j)-yi
5681 c         zj=c(3,nres+j)-zi
5682 C Uncomment following three lines for Ca-p interactions
5683           xj=c(1,j)
5684           yj=c(2,j)
5685           zj=c(3,j)
5686           xj=mod(xj,boxxsize)
5687           if (xj.lt.0) xj=xj+boxxsize
5688           yj=mod(yj,boxysize)
5689           if (yj.lt.0) yj=yj+boxysize
5690           zj=mod(zj,boxzsize)
5691           if (zj.lt.0) zj=zj+boxzsize
5692 c  174   continue
5693 c        if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
5694 c        if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
5695 C Condition for being inside the proper box
5696 c        if ((xj.gt.((0.5d0)*boxxsize)).or.
5697 c     &       (xj.lt.((-0.5d0)*boxxsize))) then
5698 c        go to 174
5699 c        endif
5700 c  175   continue
5701 c        if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
5702 c        if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
5703 cC Condition for being inside the proper box
5704 c        if ((yj.gt.((0.5d0)*boxysize)).or.
5705 c     &       (yj.lt.((-0.5d0)*boxysize))) then
5706 c        go to 175
5707 c        endif
5708 c  176   continue
5709 c        if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
5710 c        if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
5711 C Condition for being inside the proper box
5712 c        if ((zj.gt.((0.5d0)*boxzsize)).or.
5713 c     &       (zj.lt.((-0.5d0)*boxzsize))) then
5714 c        go to 176
5715 c        endif
5716 CHERE IS THE CALCULATION WHICH MIRROR IMAGE IS THE CLOSEST ONE
5717       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
5718       xj_safe=xj
5719       yj_safe=yj
5720       zj_safe=zj
5721       subchap=0
5722       do xshift=-1,1
5723       do yshift=-1,1
5724       do zshift=-1,1
5725           xj=xj_safe+xshift*boxxsize
5726           yj=yj_safe+yshift*boxysize
5727           zj=zj_safe+zshift*boxzsize
5728           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
5729           if(dist_temp.lt.dist_init) then
5730             dist_init=dist_temp
5731             xj_temp=xj
5732             yj_temp=yj
5733             zj_temp=zj
5734             subchap=1
5735           endif
5736        enddo
5737        enddo
5738        enddo
5739        if (subchap.eq.1) then
5740           xj=xj_temp-xi
5741           yj=yj_temp-yi
5742           zj=zj_temp-zi
5743        else
5744           xj=xj_safe-xi
5745           yj=yj_safe-yi
5746           zj=zj_safe-zi
5747        endif
5748 c          print *,xj,yj,zj,'polozenie j'
5749           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
5750 c          print *,rrij
5751           sss=sscale(1.0d0/(dsqrt(rrij)))
5752 c          print *,r_cut,1.0d0/dsqrt(rrij),sss,'tu patrz'
5753 c          if (sss.eq.0) print *,'czasem jest OK'
5754           if (sss.le.0.0d0) cycle
5755           sssgrad=sscagrad(1.0d0/(dsqrt(rrij)))
5756           fac=rrij**expon2
5757           e1=fac*fac*aad(itypj,iteli)
5758           e2=fac*bad(itypj,iteli)
5759           if (iabs(j-i) .le. 2) then
5760             e1=scal14*e1
5761             e2=scal14*e2
5762             evdw2_14=evdw2_14+(e1+e2)*sss
5763           endif
5764           evdwij=e1+e2
5765           evdw2=evdw2+evdwij*sss
5766           if (energy_dec) write (iout,'(a6,2i5,0pf7.3,2i3,3e11.3)')
5767      &        'evdw2',i,j,evdwij,iteli,itypj,fac,aad(itypj,iteli),
5768      &       bad(itypj,iteli)
5769 C
5770 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
5771 C
5772           fac=-(evdwij+e1)*rrij*sss
5773           fac=fac+(evdwij)*sssgrad*dsqrt(rrij)/expon
5774           ggg(1)=xj*fac
5775           ggg(2)=yj*fac
5776           ggg(3)=zj*fac
5777 cgrad          if (j.lt.i) then
5778 cd          write (iout,*) 'j<i'
5779 C Uncomment following three lines for SC-p interactions
5780 c           do k=1,3
5781 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
5782 c           enddo
5783 cgrad          else
5784 cd          write (iout,*) 'j>i'
5785 cgrad            do k=1,3
5786 cgrad              ggg(k)=-ggg(k)
5787 C Uncomment following line for SC-p interactions
5788 ccgrad             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
5789 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
5790 cgrad            enddo
5791 cgrad          endif
5792 cgrad          do k=1,3
5793 cgrad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
5794 cgrad          enddo
5795 cgrad          kstart=min0(i+1,j)
5796 cgrad          kend=max0(i-1,j-1)
5797 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
5798 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
5799 cgrad          do k=kstart,kend
5800 cgrad            do l=1,3
5801 cgrad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
5802 cgrad            enddo
5803 cgrad          enddo
5804           do k=1,3
5805             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
5806             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
5807           enddo
5808 c        endif !endif for sscale cutoff
5809         enddo ! j
5810
5811         enddo ! iint
5812       enddo ! i
5813 c      enddo !zshift
5814 c      enddo !yshift
5815 c      enddo !xshift
5816       do i=1,nct
5817         do j=1,3
5818           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
5819           gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
5820           gradx_scp(j,i)=expon*gradx_scp(j,i)
5821         enddo
5822       enddo
5823 C******************************************************************************
5824 C
5825 C                              N O T E !!!
5826 C
5827 C To save time the factor EXPON has been extracted from ALL components
5828 C of GVDWC and GRADX. Remember to multiply them by this factor before further
5829 C use!
5830 C
5831 C******************************************************************************
5832       return
5833       end
5834 C--------------------------------------------------------------------------
5835       subroutine edis(ehpb)
5836 C
5837 C Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors.
5838 C
5839       implicit real*8 (a-h,o-z)
5840       include 'DIMENSIONS'
5841       include 'COMMON.SBRIDGE'
5842       include 'COMMON.CHAIN'
5843       include 'COMMON.DERIV'
5844       include 'COMMON.VAR'
5845       include 'COMMON.INTERACT'
5846       include 'COMMON.IOUNITS'
5847       include 'COMMON.CONTROL'
5848       dimension ggg(3),ggg_peak(3,1000)
5849       ehpb=0.0D0
5850       do i=1,3
5851        ggg(i)=0.0d0
5852       enddo
5853 c 8/21/18 AL: added explicit restraints on reference coords
5854 c      write (iout,*) "restr_on_coord",restr_on_coord
5855       if (restr_on_coord) then
5856
5857       do i=nnt,nct
5858         ecoor=0.0d0
5859         if (itype(i).eq.ntyp1) cycle
5860         do j=1,3
5861           ecoor=ecoor+(c(j,i)-cref(j,i))**2
5862           ghpbc(j,i)=ghpbc(j,i)+bfac(i)*(c(j,i)-cref(j,i))
5863         enddo
5864         if (itype(i).ne.10) then
5865           do j=1,3
5866             ecoor=ecoor+(c(j,i+nres)-cref(j,i+nres))**2
5867             ghpbx(j,i)=ghpbx(j,i)+bfac(i)*(c(j,i+nres)-cref(j,i+nres))
5868           enddo
5869         endif
5870         if (energy_dec) write (iout,*)
5871      &     "i",i," bfac",bfac(i)," ecoor",ecoor
5872         ehpb=ehpb+0.5d0*bfac(i)*ecoor
5873       enddo
5874
5875       endif
5876 C      write (iout,*) ,"link_end",link_end,constr_dist
5877 cd      write(iout,*)'edis: nhpb=',nhpb,' fbr=',fbr
5878 c      write(iout,*)'link_start=',link_start,' link_end=',link_end,
5879 c     &  " constr_dist",constr_dist," link_start_peak",link_start_peak,
5880 c     &  " link_end_peak",link_end_peak
5881       if (link_end.eq.0.and.link_end_peak.eq.0) return
5882       do i=link_start_peak,link_end_peak
5883         ehpb_peak=0.0d0
5884 c        print *,"i",i," link_end_peak",link_end_peak," ipeak",
5885 c     &   ipeak(1,i),ipeak(2,i)
5886         do ip=ipeak(1,i),ipeak(2,i)
5887           ii=ihpb_peak(ip)
5888           jj=jhpb_peak(ip)
5889           dd=dist(ii,jj)
5890           iip=ip-ipeak(1,i)+1
5891 C iii and jjj point to the residues for which the distance is assigned.
5892 c          if (ii.gt.nres) then
5893 c            iii=ii-nres
5894 c            jjj=jj-nres
5895 c          else
5896 c            iii=ii
5897 c            jjj=jj
5898 c          endif
5899           if (ii.gt.nres) then
5900             iii=ii-nres
5901           else
5902             iii=ii
5903           endif
5904           if (jj.gt.nres) then
5905             jjj=jj-nres
5906           else
5907             jjj=jj
5908           endif
5909           aux=rlornmr1(dd,dhpb_peak(ip),dhpb1_peak(ip),forcon_peak(ip))
5910           aux=dexp(-scal_peak*aux)
5911           ehpb_peak=ehpb_peak+aux
5912           fac=rlornmr1prim(dd,dhpb_peak(ip),dhpb1_peak(ip),
5913      &      forcon_peak(ip))*aux/dd
5914           do j=1,3
5915             ggg_peak(j,iip)=fac*(c(j,jj)-c(j,ii))
5916           enddo
5917           if (energy_dec) write (iout,'(a6,3i5,6f10.3,i5)')
5918      &      "edisL",i,ii,jj,dd,dhpb_peak(ip),dhpb1_peak(ip),
5919      &      forcon_peak(ip),fordepth_peak(ip),ehpb_peak
5920         enddo
5921 c        write (iout,*) "ehpb_peak",ehpb_peak," scal_peak",scal_peak
5922         ehpb=ehpb-fordepth_peak(ipeak(1,i))*dlog(ehpb_peak)/scal_peak
5923         do ip=ipeak(1,i),ipeak(2,i)
5924           iip=ip-ipeak(1,i)+1
5925           do j=1,3
5926             ggg(j)=ggg_peak(j,iip)/ehpb_peak
5927           enddo
5928           ii=ihpb_peak(ip)
5929           jj=jhpb_peak(ip)
5930 C iii and jjj point to the residues for which the distance is assigned.
5931 c          if (ii.gt.nres) then
5932 c            iii=ii-nres
5933 c            jjj=jj-nres
5934 c          else
5935 c            iii=ii
5936 c            jjj=jj
5937 c          endif
5938           if (ii.gt.nres) then
5939             iii=ii-nres
5940           else
5941             iii=ii
5942           endif
5943           if (jj.gt.nres) then
5944             jjj=jj-nres
5945           else
5946             jjj=jj
5947           endif
5948           if (iii.lt.ii) then
5949             do j=1,3
5950               ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
5951             enddo
5952           endif
5953           if (jjj.lt.jj) then
5954             do j=1,3
5955               ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
5956             enddo
5957           endif
5958           do k=1,3
5959             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
5960             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
5961           enddo
5962         enddo
5963       enddo
5964       do i=link_start,link_end
5965 C If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a
5966 C CA-CA distance used in regularization of structure.
5967         ii=ihpb(i)
5968         jj=jhpb(i)
5969 C iii and jjj point to the residues for which the distance is assigned.
5970         if (ii.gt.nres) then
5971           iii=ii-nres
5972         else
5973           iii=ii
5974         endif
5975         if (jj.gt.nres) then
5976           jjj=jj-nres
5977         else
5978           jjj=jj
5979         endif
5980 c        write (iout,*) "i",i," ii",ii," iii",iii," jj",jj," jjj",jjj,
5981 c     &    dhpb(i),dhpb1(i),forcon(i)
5982 C 24/11/03 AL: SS bridges handled separately because of introducing a specific
5983 C    distance and angle dependent SS bond potential.
5984 C        if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and.
5985 C     & iabs(itype(jjj)).eq.1) then
5986 cmc        if (ii.gt.nres .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then
5987 C 18/07/06 MC: Use the convention that the first nss pairs are SS bonds
5988         if (.not.dyn_ss .and. i.le.nss) then
5989 C 15/02/13 CC dynamic SSbond - additional check
5990           if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and.
5991      &        iabs(itype(jjj)).eq.1) then
5992            call ssbond_ene(iii,jjj,eij)
5993            ehpb=ehpb+2*eij
5994          endif
5995 cd          write (iout,*) "eij",eij
5996 cd   &   ' waga=',waga,' fac=',fac
5997 !        else if (ii.gt.nres .and. jj.gt.nres) then
5998         else
5999 C Calculate the distance between the two points and its difference from the
6000 C target distance.
6001           dd=dist(ii,jj)
6002           if (irestr_type(i).eq.11) then
6003             ehpb=ehpb+fordepth(i)!**4.0d0
6004      &           *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i))
6005             fac=fordepth(i)!**4.0d0
6006      &           *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd
6007             if (energy_dec) write (iout,'(a6,2i5,6f10.3,i5)')
6008      &        "edisL",ii,jj,dd,dhpb(i),dhpb1(i),forcon(i),fordepth(i),
6009      &        ehpb,irestr_type(i)
6010           else if (irestr_type(i).eq.10) then
6011 c AL 6//19/2018 cross-link restraints
6012             xdis = 0.5d0*(dd/forcon(i))**2
6013             expdis = dexp(-xdis)
6014 c            aux=(dhpb(i)+dhpb1(i)*xdis)*expdis+fordepth(i)
6015             aux=(dhpb(i)+dhpb1(i)*xdis*xdis)*expdis+fordepth(i)
6016 c            write (iout,*)"HERE: xdis",xdis," expdis",expdis," aux",aux,
6017 c     &          " wboltzd",wboltzd
6018             ehpb=ehpb-wboltzd*xlscore(i)*dlog(aux)
6019 c            fac=-wboltzd*(dhpb1(i)*(1.0d0-xdis)-dhpb(i))
6020             fac=-wboltzd*xlscore(i)*(dhpb1(i)*(2.0d0-xdis)*xdis-dhpb(i))
6021      &           *expdis/(aux*forcon(i)**2)
6022             if (energy_dec) write(iout,'(a6,2i5,6f10.3,i5)')
6023      &        "edisX",ii,jj,dd,dhpb(i),dhpb1(i),forcon(i),fordepth(i),
6024      &        -wboltzd*xlscore(i)*dlog(aux),irestr_type(i)
6025           else if (irestr_type(i).eq.2) then
6026 c Quartic restraints
6027             ehpb=ehpb+forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
6028             if (energy_dec) write(iout,'(a6,2i5,5f10.3,i5)')
6029      &      "edisQ",ii,jj,dd,dhpb(i),dhpb1(i),forcon(i),
6030      &      forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i)),irestr_type(i)
6031             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
6032           else
6033 c Quadratic restraints
6034             rdis=dd-dhpb(i)
6035 C Get the force constant corresponding to this distance.
6036             waga=forcon(i)
6037 C Calculate the contribution to energy.
6038             ehpb=ehpb+0.5d0*waga*rdis*rdis
6039             if (energy_dec) write(iout,'(a6,2i5,5f10.3,i5)')
6040      &      "edisS",ii,jj,dd,dhpb(i),dhpb1(i),forcon(i),
6041      &       0.5d0*waga*rdis*rdis,irestr_type(i)
6042 C
6043 C Evaluate gradient.
6044 C
6045             fac=waga*rdis/dd
6046           endif
6047 c Calculate Cartesian gradient
6048           do j=1,3
6049             ggg(j)=fac*(c(j,jj)-c(j,ii))
6050           enddo
6051 cd      print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
6052 C If this is a SC-SC distance, we need to calculate the contributions to the
6053 C Cartesian gradient in the SC vectors (ghpbx).
6054           if (iii.lt.ii) then
6055             do j=1,3
6056               ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
6057             enddo
6058           endif
6059           if (jjj.lt.jj) then
6060             do j=1,3
6061               ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
6062             enddo
6063           endif
6064           do k=1,3
6065             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
6066             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
6067           enddo
6068         endif
6069       enddo
6070       return
6071       end
6072 C--------------------------------------------------------------------------
6073       subroutine ssbond_ene(i,j,eij)
6074 C
6075 C Calculate the distance and angle dependent SS-bond potential energy
6076 C using a free-energy function derived based on RHF/6-31G** ab initio
6077 C calculations of diethyl disulfide.
6078 C
6079 C A. Liwo and U. Kozlowska, 11/24/03
6080 C
6081       implicit real*8 (a-h,o-z)
6082       include 'DIMENSIONS'
6083       include 'COMMON.SBRIDGE'
6084       include 'COMMON.CHAIN'
6085       include 'COMMON.DERIV'
6086       include 'COMMON.LOCAL'
6087       include 'COMMON.INTERACT'
6088       include 'COMMON.VAR'
6089       include 'COMMON.IOUNITS'
6090       double precision erij(3),dcosom1(3),dcosom2(3),gg(3)
6091       itypi=iabs(itype(i))
6092       xi=c(1,nres+i)
6093       yi=c(2,nres+i)
6094       zi=c(3,nres+i)
6095       dxi=dc_norm(1,nres+i)
6096       dyi=dc_norm(2,nres+i)
6097       dzi=dc_norm(3,nres+i)
6098 c      dsci_inv=dsc_inv(itypi)
6099       dsci_inv=vbld_inv(nres+i)
6100       itypj=iabs(itype(j))
6101 c      dscj_inv=dsc_inv(itypj)
6102       dscj_inv=vbld_inv(nres+j)
6103       xj=c(1,nres+j)-xi
6104       yj=c(2,nres+j)-yi
6105       zj=c(3,nres+j)-zi
6106       dxj=dc_norm(1,nres+j)
6107       dyj=dc_norm(2,nres+j)
6108       dzj=dc_norm(3,nres+j)
6109       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
6110       rij=dsqrt(rrij)
6111       erij(1)=xj*rij
6112       erij(2)=yj*rij
6113       erij(3)=zj*rij
6114       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
6115       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
6116       om12=dxi*dxj+dyi*dyj+dzi*dzj
6117       do k=1,3
6118         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
6119         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
6120       enddo
6121       rij=1.0d0/rij
6122       deltad=rij-d0cm
6123       deltat1=1.0d0-om1
6124       deltat2=1.0d0+om2
6125       deltat12=om2-om1+2.0d0
6126       cosphi=om12-om1*om2
6127       eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2)
6128      &  +akct*deltad*deltat12
6129      &  +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi+ebr
6130 c      write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth,
6131 c     &  " akct",akct," deltad",deltad," deltat",deltat1,deltat2,
6132 c     &  " deltat12",deltat12," eij",eij
6133       ed=2*akcm*deltad+akct*deltat12
6134       pom1=akct*deltad
6135       pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
6136       eom1=-2*akth*deltat1-pom1-om2*pom2
6137       eom2= 2*akth*deltat2+pom1-om1*pom2
6138       eom12=pom2
6139       do k=1,3
6140         ggk=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
6141         ghpbx(k,i)=ghpbx(k,i)-ggk
6142      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
6143      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
6144         ghpbx(k,j)=ghpbx(k,j)+ggk
6145      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
6146      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
6147         ghpbc(k,i)=ghpbc(k,i)-ggk
6148         ghpbc(k,j)=ghpbc(k,j)+ggk
6149       enddo
6150 C
6151 C Calculate the components of the gradient in DC and X
6152 C
6153 cgrad      do k=i,j-1
6154 cgrad        do l=1,3
6155 cgrad          ghpbc(l,k)=ghpbc(l,k)+gg(l)
6156 cgrad        enddo
6157 cgrad      enddo
6158       return
6159       end
6160 C--------------------------------------------------------------------------
6161       subroutine ebond(estr)
6162 c
6163 c Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
6164 c
6165       implicit real*8 (a-h,o-z)
6166       include 'DIMENSIONS'
6167       include 'COMMON.LOCAL'
6168       include 'COMMON.GEO'
6169       include 'COMMON.INTERACT'
6170       include 'COMMON.DERIV'
6171       include 'COMMON.VAR'
6172       include 'COMMON.CHAIN'
6173       include 'COMMON.IOUNITS'
6174       include 'COMMON.NAMES'
6175       include 'COMMON.FFIELD'
6176       include 'COMMON.CONTROL'
6177       include 'COMMON.SETUP'
6178       double precision u(3),ud(3)
6179       estr=0.0d0
6180       estr1=0.0d0
6181       do i=ibondp_start,ibondp_end
6182         if (itype(i-1).eq.ntyp1 .and. itype(i).eq.ntyp1) cycle
6183 c          estr1=estr1+gnmr1(vbld(i),-1.0d0,distchainmax)
6184 c          do j=1,3
6185 c          gradb(j,i-1)=gnmr1prim(vbld(i),-1.0d0,distchainmax)
6186 c     &      *dc(j,i-1)/vbld(i)
6187 c          enddo
6188 c          if (energy_dec) write(iout,*)
6189 c     &       "estr1",i,gnmr1(vbld(i),-1.0d0,distchainmax)
6190 c        else
6191 C       Checking if it involves dummy (NH3+ or COO-) group
6192          if (itype(i-1).eq.ntyp1 .or. itype(i).eq.ntyp1) then
6193 C YES   vbldpDUM is the equlibrium length of spring for Dummy atom
6194         diff = vbld(i)-vbldpDUM
6195         if (energy_dec) write(iout,*) "dum_bond",i,diff
6196          else
6197 C NO    vbldp0 is the equlibrium lenght of spring for peptide group
6198         diff = vbld(i)-vbldp0
6199          endif
6200         if (energy_dec)    write (iout,'(a7,i5,4f7.3)')
6201      &     "estr bb",i,vbld(i),vbldp0,diff,AKP*diff*diff
6202         estr=estr+diff*diff
6203         do j=1,3
6204           gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)
6205         enddo
6206 c        write (iout,'(i5,3f10.5)') i,(gradb(j,i-1),j=1,3)
6207 c        endif
6208       enddo
6209
6210       estr=0.5d0*AKP*estr+estr1
6211 c
6212 c 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included
6213 c
6214       do i=ibond_start,ibond_end
6215         iti=iabs(itype(i))
6216         if (iti.ne.10 .and. iti.ne.ntyp1) then
6217           nbi=nbondterm(iti)
6218           if (nbi.eq.1) then
6219             diff=vbld(i+nres)-vbldsc0(1,iti)
6220             if (energy_dec)  write (iout,*)
6221      &      "estr sc",i,iti,vbld(i+nres),vbldsc0(1,iti),diff,
6222      &      AKSC(1,iti),AKSC(1,iti)*diff*diff
6223             estr=estr+0.5d0*AKSC(1,iti)*diff*diff
6224             do j=1,3
6225               gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
6226             enddo
6227           else
6228             do j=1,nbi
6229               diff=vbld(i+nres)-vbldsc0(j,iti)
6230               ud(j)=aksc(j,iti)*diff
6231               u(j)=abond0(j,iti)+0.5d0*ud(j)*diff
6232             enddo
6233             uprod=u(1)
6234             do j=2,nbi
6235               uprod=uprod*u(j)
6236             enddo
6237             usum=0.0d0
6238             usumsqder=0.0d0
6239             do j=1,nbi
6240               uprod1=1.0d0
6241               uprod2=1.0d0
6242               do k=1,nbi
6243                 if (k.ne.j) then
6244                   uprod1=uprod1*u(k)
6245                   uprod2=uprod2*u(k)*u(k)
6246                 endif
6247               enddo
6248               usum=usum+uprod1
6249               usumsqder=usumsqder+ud(j)*uprod2
6250             enddo
6251             estr=estr+uprod/usum
6252             do j=1,3
6253              gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
6254             enddo
6255           endif
6256         endif
6257       enddo
6258       return
6259       end
6260 #ifdef CRYST_THETA
6261 C--------------------------------------------------------------------------
6262       subroutine ebend(etheta)
6263 C
6264 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
6265 C angles gamma and its derivatives in consecutive thetas and gammas.
6266 C
6267       implicit real*8 (a-h,o-z)
6268       include 'DIMENSIONS'
6269       include 'COMMON.LOCAL'
6270       include 'COMMON.GEO'
6271       include 'COMMON.INTERACT'
6272       include 'COMMON.DERIV'
6273       include 'COMMON.VAR'
6274       include 'COMMON.CHAIN'
6275       include 'COMMON.IOUNITS'
6276       include 'COMMON.NAMES'
6277       include 'COMMON.FFIELD'
6278       include 'COMMON.CONTROL'
6279       include 'COMMON.TORCNSTR'
6280       common /calcthet/ term1,term2,termm,diffak,ratak,
6281      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
6282      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
6283       double precision y(2),z(2)
6284       delta=0.02d0*pi
6285 c      time11=dexp(-2*time)
6286 c      time12=1.0d0
6287       etheta=0.0D0
6288 c     write (*,'(a,i2)') 'EBEND ICG=',icg
6289       do i=ithet_start,ithet_end
6290         if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
6291      &  .or.itype(i).eq.ntyp1) cycle
6292 C Zero the energy function and its derivative at 0 or pi.
6293         call splinthet(theta(i),0.5d0*delta,ss,ssd)
6294         it=itype(i-1)
6295         ichir1=isign(1,itype(i-2))
6296         ichir2=isign(1,itype(i))
6297          if (itype(i-2).eq.10) ichir1=isign(1,itype(i-1))
6298          if (itype(i).eq.10) ichir2=isign(1,itype(i-1))
6299          if (itype(i-1).eq.10) then
6300           itype1=isign(10,itype(i-2))
6301           ichir11=isign(1,itype(i-2))
6302           ichir12=isign(1,itype(i-2))
6303           itype2=isign(10,itype(i))
6304           ichir21=isign(1,itype(i))
6305           ichir22=isign(1,itype(i))
6306          endif
6307
6308         if (i.gt.3 .and. itype(i-3).ne.ntyp1) then
6309 #ifdef OSF
6310           phii=phi(i)
6311           if (phii.ne.phii) phii=150.0
6312 #else
6313           phii=phi(i)
6314 #endif
6315           y(1)=dcos(phii)
6316           y(2)=dsin(phii)
6317         else
6318           y(1)=0.0D0
6319           y(2)=0.0D0
6320         endif
6321         if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
6322 #ifdef OSF
6323           phii1=phi(i+1)
6324           if (phii1.ne.phii1) phii1=150.0
6325           phii1=pinorm(phii1)
6326           z(1)=cos(phii1)
6327 #else
6328           phii1=phi(i+1)
6329 #endif
6330           z(1)=dcos(phii1)
6331           z(2)=dsin(phii1)
6332         else
6333           z(1)=0.0D0
6334           z(2)=0.0D0
6335         endif
6336 C Calculate the "mean" value of theta from the part of the distribution
6337 C dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2).
6338 C In following comments this theta will be referred to as t_c.
6339         thet_pred_mean=0.0d0
6340         do k=1,2
6341             athetk=athet(k,it,ichir1,ichir2)
6342             bthetk=bthet(k,it,ichir1,ichir2)
6343           if (it.eq.10) then
6344              athetk=athet(k,itype1,ichir11,ichir12)
6345              bthetk=bthet(k,itype2,ichir21,ichir22)
6346           endif
6347          thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k)
6348 c         write(iout,*) 'chuj tu', y(k),z(k)
6349         enddo
6350         dthett=thet_pred_mean*ssd
6351         thet_pred_mean=thet_pred_mean*ss+a0thet(it)
6352 C Derivatives of the "mean" values in gamma1 and gamma2.
6353         dthetg1=(-athet(1,it,ichir1,ichir2)*y(2)
6354      &+athet(2,it,ichir1,ichir2)*y(1))*ss
6355          dthetg2=(-bthet(1,it,ichir1,ichir2)*z(2)
6356      &          +bthet(2,it,ichir1,ichir2)*z(1))*ss
6357          if (it.eq.10) then
6358       dthetg1=(-athet(1,itype1,ichir11,ichir12)*y(2)
6359      &+athet(2,itype1,ichir11,ichir12)*y(1))*ss
6360         dthetg2=(-bthet(1,itype2,ichir21,ichir22)*z(2)
6361      &         +bthet(2,itype2,ichir21,ichir22)*z(1))*ss
6362          endif
6363         if (theta(i).gt.pi-delta) then
6364           call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,
6365      &         E_tc0)
6366           call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0)
6367           call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
6368           call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,
6369      &        E_theta)
6370           call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,
6371      &        E_tc)
6372         else if (theta(i).lt.delta) then
6373           call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0)
6374           call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
6375           call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,
6376      &        E_theta)
6377           call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0)
6378           call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,
6379      &        E_tc)
6380         else
6381           call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,
6382      &        E_theta,E_tc)
6383         endif
6384         etheta=etheta+ethetai
6385         if (energy_dec) write (iout,'(a6,i5,0pf7.3,f7.3,i5)')
6386      &      'ebend',i,ethetai,theta(i),itype(i)
6387         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1
6388         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2
6389         gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)+gloc(nphi+i-2,icg)
6390       enddo
6391
6392 C Ufff.... We've done all this!!!
6393       return
6394       end
6395 C---------------------------------------------------------------------------
6396       subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,
6397      &     E_tc)
6398       implicit real*8 (a-h,o-z)
6399       include 'DIMENSIONS'
6400       include 'COMMON.LOCAL'
6401       include 'COMMON.IOUNITS'
6402       common /calcthet/ term1,term2,termm,diffak,ratak,
6403      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
6404      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
6405 C Calculate the contributions to both Gaussian lobes.
6406 C 6/6/97 - Deform the Gaussians using the factor of 1/(1+time)
6407 C The "polynomial part" of the "standard deviation" of this part of
6408 C the distributioni.
6409 ccc        write (iout,*) thetai,thet_pred_mean
6410         sig=polthet(3,it)
6411         do j=2,0,-1
6412           sig=sig*thet_pred_mean+polthet(j,it)
6413         enddo
6414 C Derivative of the "interior part" of the "standard deviation of the"
6415 C gamma-dependent Gaussian lobe in t_c.
6416         sigtc=3*polthet(3,it)
6417         do j=2,1,-1
6418           sigtc=sigtc*thet_pred_mean+j*polthet(j,it)
6419         enddo
6420         sigtc=sig*sigtc
6421 C Set the parameters of both Gaussian lobes of the distribution.
6422 C "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc)
6423         fac=sig*sig+sigc0(it)
6424         sigcsq=fac+fac
6425         sigc=1.0D0/sigcsq
6426 C Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c
6427         sigsqtc=-4.0D0*sigcsq*sigtc
6428 c       print *,i,sig,sigtc,sigsqtc
6429 C Following variable (sigtc) is d[sigma(t_c)]/dt_c
6430         sigtc=-sigtc/(fac*fac)
6431 C Following variable is sigma(t_c)**(-2)
6432         sigcsq=sigcsq*sigcsq
6433         sig0i=sig0(it)
6434         sig0inv=1.0D0/sig0i**2
6435         delthec=thetai-thet_pred_mean
6436         delthe0=thetai-theta0i
6437         term1=-0.5D0*sigcsq*delthec*delthec
6438         term2=-0.5D0*sig0inv*delthe0*delthe0
6439 C        write (iout,*)'term1',term1,term2,sigcsq,delthec,sig0inv,delthe0
6440 C Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and
6441 C NaNs in taking the logarithm. We extract the largest exponent which is added
6442 C to the energy (this being the log of the distribution) at the end of energy
6443 C term evaluation for this virtual-bond angle.
6444         if (term1.gt.term2) then
6445           termm=term1
6446           term2=dexp(term2-termm)
6447           term1=1.0d0
6448         else
6449           termm=term2
6450           term1=dexp(term1-termm)
6451           term2=1.0d0
6452         endif
6453 C The ratio between the gamma-independent and gamma-dependent lobes of
6454 C the distribution is a Gaussian function of thet_pred_mean too.
6455         diffak=gthet(2,it)-thet_pred_mean
6456         ratak=diffak/gthet(3,it)**2
6457         ak=dexp(gthet(1,it)-0.5D0*diffak*ratak)
6458 C Let's differentiate it in thet_pred_mean NOW.
6459         aktc=ak*ratak
6460 C Now put together the distribution terms to make complete distribution.
6461         termexp=term1+ak*term2
6462         termpre=sigc+ak*sig0i
6463 C Contribution of the bending energy from this theta is just the -log of
6464 C the sum of the contributions from the two lobes and the pre-exponential
6465 C factor. Simple enough, isn't it?
6466         ethetai=(-dlog(termexp)-termm+dlog(termpre))
6467 C       write (iout,*) 'termexp',termexp,termm,termpre,i
6468 C NOW the derivatives!!!
6469 C 6/6/97 Take into account the deformation.
6470         E_theta=(delthec*sigcsq*term1
6471      &       +ak*delthe0*sig0inv*term2)/termexp
6472         E_tc=((sigtc+aktc*sig0i)/termpre
6473      &      -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+
6474      &       aktc*term2)/termexp)
6475       return
6476       end
6477 c-----------------------------------------------------------------------------
6478       subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)
6479       implicit real*8 (a-h,o-z)
6480       include 'DIMENSIONS'
6481       include 'COMMON.LOCAL'
6482       include 'COMMON.IOUNITS'
6483       common /calcthet/ term1,term2,termm,diffak,ratak,
6484      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
6485      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
6486       delthec=thetai-thet_pred_mean
6487       delthe0=thetai-theta0i
6488 C "Thank you" to MAPLE (probably spared one day of hand-differentiation).
6489       t3 = thetai-thet_pred_mean
6490       t6 = t3**2
6491       t9 = term1
6492       t12 = t3*sigcsq
6493       t14 = t12+t6*sigsqtc
6494       t16 = 1.0d0
6495       t21 = thetai-theta0i
6496       t23 = t21**2
6497       t26 = term2
6498       t27 = t21*t26
6499       t32 = termexp
6500       t40 = t32**2
6501       E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9
6502      & -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40
6503      & *(-t12*t9-ak*sig0inv*t27)
6504       return
6505       end
6506 #else
6507 C--------------------------------------------------------------------------
6508       subroutine ebend(etheta)
6509 C
6510 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
6511 C angles gamma and its derivatives in consecutive thetas and gammas.
6512 C ab initio-derived potentials from
6513 c Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203
6514 C
6515       implicit real*8 (a-h,o-z)
6516       include 'DIMENSIONS'
6517       include 'COMMON.LOCAL'
6518       include 'COMMON.GEO'
6519       include 'COMMON.INTERACT'
6520       include 'COMMON.DERIV'
6521       include 'COMMON.VAR'
6522       include 'COMMON.CHAIN'
6523       include 'COMMON.IOUNITS'
6524       include 'COMMON.NAMES'
6525       include 'COMMON.FFIELD'
6526       include 'COMMON.CONTROL'
6527       include 'COMMON.TORCNSTR'
6528       double precision coskt(mmaxtheterm),sinkt(mmaxtheterm),
6529      & cosph1(maxsingle),sinph1(maxsingle),cosph2(maxsingle),
6530      & sinph2(maxsingle),cosph1ph2(maxdouble,maxdouble),
6531      & sinph1ph2(maxdouble,maxdouble)
6532       logical lprn /.false./, lprn1 /.false./
6533       etheta=0.0D0
6534       do i=ithet_start,ithet_end
6535 c        print *,i,itype(i-1),itype(i),itype(i-2)
6536         if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
6537      &  .or.itype(i).eq.ntyp1) cycle
6538 C        print *,i,theta(i)
6539         if (iabs(itype(i+1)).eq.20) iblock=2
6540         if (iabs(itype(i+1)).ne.20) iblock=1
6541         dethetai=0.0d0
6542         dephii=0.0d0
6543         dephii1=0.0d0
6544         theti2=0.5d0*theta(i)
6545         ityp2=ithetyp((itype(i-1)))
6546         do k=1,nntheterm
6547           coskt(k)=dcos(k*theti2)
6548           sinkt(k)=dsin(k*theti2)
6549         enddo
6550 C        print *,ethetai
6551         if (i.gt.3 .and. itype(i-3).ne.ntyp1) then
6552 #ifdef OSF
6553           phii=phi(i)
6554           if (phii.ne.phii) phii=150.0
6555 #else
6556           phii=phi(i)
6557 #endif
6558           ityp1=ithetyp((itype(i-2)))
6559 C propagation of chirality for glycine type
6560           do k=1,nsingle
6561             cosph1(k)=dcos(k*phii)
6562             sinph1(k)=dsin(k*phii)
6563           enddo
6564         else
6565           phii=0.0d0
6566           do k=1,nsingle
6567           ityp1=ithetyp((itype(i-2)))
6568             cosph1(k)=0.0d0
6569             sinph1(k)=0.0d0
6570           enddo
6571         endif
6572         if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
6573 #ifdef OSF
6574           phii1=phi(i+1)
6575           if (phii1.ne.phii1) phii1=150.0
6576           phii1=pinorm(phii1)
6577 #else
6578           phii1=phi(i+1)
6579 #endif
6580           ityp3=ithetyp((itype(i)))
6581           do k=1,nsingle
6582             cosph2(k)=dcos(k*phii1)
6583             sinph2(k)=dsin(k*phii1)
6584           enddo
6585         else
6586           phii1=0.0d0
6587           ityp3=ithetyp((itype(i)))
6588           do k=1,nsingle
6589             cosph2(k)=0.0d0
6590             sinph2(k)=0.0d0
6591           enddo
6592         endif
6593         ethetai=aa0thet(ityp1,ityp2,ityp3,iblock)
6594         do k=1,ndouble
6595           do l=1,k-1
6596             ccl=cosph1(l)*cosph2(k-l)
6597             ssl=sinph1(l)*sinph2(k-l)
6598             scl=sinph1(l)*cosph2(k-l)
6599             csl=cosph1(l)*sinph2(k-l)
6600             cosph1ph2(l,k)=ccl-ssl
6601             cosph1ph2(k,l)=ccl+ssl
6602             sinph1ph2(l,k)=scl+csl
6603             sinph1ph2(k,l)=scl-csl
6604           enddo
6605         enddo
6606         if (lprn) then
6607         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,
6608      &    " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
6609         write (iout,*) "coskt and sinkt"
6610         do k=1,nntheterm
6611           write (iout,*) k,coskt(k),sinkt(k)
6612         enddo
6613         endif
6614         do k=1,ntheterm
6615           ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3,iblock)*sinkt(k)
6616           dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3,iblock)
6617      &      *coskt(k)
6618           if (lprn)
6619      &    write (iout,*) "k",k,"
6620      &     aathet",aathet(k,ityp1,ityp2,ityp3,iblock),
6621      &     " ethetai",ethetai
6622         enddo
6623         if (lprn) then
6624         write (iout,*) "cosph and sinph"
6625         do k=1,nsingle
6626           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
6627         enddo
6628         write (iout,*) "cosph1ph2 and sinph2ph2"
6629         do k=2,ndouble
6630           do l=1,k-1
6631             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),
6632      &         sinph1ph2(l,k),sinph1ph2(k,l)
6633           enddo
6634         enddo
6635         write(iout,*) "ethetai",ethetai
6636         endif
6637 C       print *,ethetai
6638         do m=1,ntheterm2
6639           do k=1,nsingle
6640             aux=bbthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)
6641      &         +ccthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k)
6642      &         +ddthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)
6643      &         +eethet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k)
6644             ethetai=ethetai+sinkt(m)*aux
6645             dethetai=dethetai+0.5d0*m*aux*coskt(m)
6646             dephii=dephii+k*sinkt(m)*(
6647      &          ccthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)-
6648      &          bbthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k))
6649             dephii1=dephii1+k*sinkt(m)*(
6650      &          eethet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)-
6651      &          ddthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k))
6652             if (lprn)
6653      &      write (iout,*) "m",m," k",k," bbthet",
6654      &         bbthet(k,m,ityp1,ityp2,ityp3,iblock)," ccthet",
6655      &         ccthet(k,m,ityp1,ityp2,ityp3,iblock)," ddthet",
6656      &         ddthet(k,m,ityp1,ityp2,ityp3,iblock)," eethet",
6657      &         eethet(k,m,ityp1,ityp2,ityp3,iblock)," ethetai",ethetai
6658 C        print *,"tu",cosph1(k),sinph1(k),cosph2(k),sinph2(k)
6659           enddo
6660         enddo
6661 C        print *,"cosph1", (cosph1(k), k=1,nsingle)
6662 C        print *,"cosph2", (cosph2(k), k=1,nsingle)
6663 C        print *,"sinph1", (sinph1(k), k=1,nsingle)
6664 C        print *,"sinph2", (sinph2(k), k=1,nsingle)
6665         if (lprn)
6666      &  write(iout,*) "ethetai",ethetai
6667 C        print *,"tu",cosph1(k),sinph1(k),cosph2(k),sinph2(k)
6668         do m=1,ntheterm3
6669           do k=2,ndouble
6670             do l=1,k-1
6671               aux=ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
6672      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l)+
6673      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
6674      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)
6675               ethetai=ethetai+sinkt(m)*aux
6676               dethetai=dethetai+0.5d0*m*coskt(m)*aux
6677               dephii=dephii+l*sinkt(m)*(
6678      &           -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)-
6679      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
6680      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
6681      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
6682               dephii1=dephii1+(k-l)*sinkt(m)*(
6683      &           -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
6684      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
6685      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)-
6686      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
6687               if (lprn) then
6688               write (iout,*) "m",m," k",k," l",l," ffthet",
6689      &            ffthet(l,k,m,ityp1,ityp2,ityp3,iblock),
6690      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)," ggthet",
6691      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock),
6692      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock),
6693      &            " ethetai",ethetai
6694               write (iout,*) cosph1ph2(l,k)*sinkt(m),
6695      &            cosph1ph2(k,l)*sinkt(m),
6696      &            sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
6697               endif
6698             enddo
6699           enddo
6700         enddo
6701 10      continue
6702 c        lprn1=.true.
6703 C        print *,ethetai
6704         if (lprn1)
6705      &    write (iout,'(i2,3f8.1,9h ethetai ,f10.5)')
6706      &   i,theta(i)*rad2deg,phii*rad2deg,
6707      &   phii1*rad2deg,ethetai
6708 c        lprn1=.false.
6709         etheta=etheta+ethetai
6710         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
6711         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
6712         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)+wang*dethetai
6713       enddo
6714
6715       return
6716       end
6717 #endif
6718 #ifdef CRYST_SC
6719 c-----------------------------------------------------------------------------
6720       subroutine esc(escloc)
6721 C Calculate the local energy of a side chain and its derivatives in the
6722 C corresponding virtual-bond valence angles THETA and the spherical angles
6723 C ALPHA and OMEGA.
6724       implicit real*8 (a-h,o-z)
6725       include 'DIMENSIONS'
6726       include 'COMMON.GEO'
6727       include 'COMMON.LOCAL'
6728       include 'COMMON.VAR'
6729       include 'COMMON.INTERACT'
6730       include 'COMMON.DERIV'
6731       include 'COMMON.CHAIN'
6732       include 'COMMON.IOUNITS'
6733       include 'COMMON.NAMES'
6734       include 'COMMON.FFIELD'
6735       include 'COMMON.CONTROL'
6736       double precision x(3),dersc(3),xemp(3),dersc0(3),dersc1(3),
6737      &     ddersc0(3),ddummy(3),xtemp(3),temp(3)
6738       common /sccalc/ time11,time12,time112,theti,it,nlobit
6739       delta=0.02d0*pi
6740       escloc=0.0D0
6741 c     write (iout,'(a)') 'ESC'
6742       do i=loc_start,loc_end
6743         it=itype(i)
6744         if (it.eq.ntyp1) cycle
6745         if (it.eq.10) goto 1
6746         nlobit=nlob(iabs(it))
6747 c       print *,'i=',i,' it=',it,' nlobit=',nlobit
6748 c       write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
6749         theti=theta(i+1)-pipol
6750         x(1)=dtan(theti)
6751         x(2)=alph(i)
6752         x(3)=omeg(i)
6753
6754         if (x(2).gt.pi-delta) then
6755           xtemp(1)=x(1)
6756           xtemp(2)=pi-delta
6757           xtemp(3)=x(3)
6758           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
6759           xtemp(2)=pi
6760           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
6761           call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),
6762      &        escloci,dersc(2))
6763           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
6764      &        ddersc0(1),dersc(1))
6765           call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),
6766      &        ddersc0(3),dersc(3))
6767           xtemp(2)=pi-delta
6768           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
6769           xtemp(2)=pi
6770           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
6771           call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,
6772      &            dersc0(2),esclocbi,dersc02)
6773           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
6774      &            dersc12,dersc01)
6775           call splinthet(x(2),0.5d0*delta,ss,ssd)
6776           dersc0(1)=dersc01
6777           dersc0(2)=dersc02
6778           dersc0(3)=0.0d0
6779           do k=1,3
6780             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
6781           enddo
6782           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
6783 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
6784 c    &             esclocbi,ss,ssd
6785           escloci=ss*escloci+(1.0d0-ss)*esclocbi
6786 c         escloci=esclocbi
6787 c         write (iout,*) escloci
6788         else if (x(2).lt.delta) then
6789           xtemp(1)=x(1)
6790           xtemp(2)=delta
6791           xtemp(3)=x(3)
6792           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
6793           xtemp(2)=0.0d0
6794           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
6795           call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),
6796      &        escloci,dersc(2))
6797           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
6798      &        ddersc0(1),dersc(1))
6799           call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),
6800      &        ddersc0(3),dersc(3))
6801           xtemp(2)=delta
6802           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
6803           xtemp(2)=0.0d0
6804           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
6805           call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,
6806      &            dersc0(2),esclocbi,dersc02)
6807           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
6808      &            dersc12,dersc01)
6809           dersc0(1)=dersc01
6810           dersc0(2)=dersc02
6811           dersc0(3)=0.0d0
6812           call splinthet(x(2),0.5d0*delta,ss,ssd)
6813           do k=1,3
6814             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
6815           enddo
6816           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
6817 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
6818 c    &             esclocbi,ss,ssd
6819           escloci=ss*escloci+(1.0d0-ss)*esclocbi
6820 c         write (iout,*) escloci
6821         else
6822           call enesc(x,escloci,dersc,ddummy,.false.)
6823         endif
6824
6825         escloc=escloc+escloci
6826         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
6827      &     'escloc',i,escloci
6828 c       write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
6829
6830         gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
6831      &   wscloc*dersc(1)
6832         gloc(ialph(i,1),icg)=wscloc*dersc(2)
6833         gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
6834     1   continue
6835       enddo
6836       return
6837       end
6838 C---------------------------------------------------------------------------
6839       subroutine enesc(x,escloci,dersc,ddersc,mixed)
6840       implicit real*8 (a-h,o-z)
6841       include 'DIMENSIONS'
6842       include 'COMMON.GEO'
6843       include 'COMMON.LOCAL'
6844       include 'COMMON.IOUNITS'
6845       common /sccalc/ time11,time12,time112,theti,it,nlobit
6846       double precision x(3),z(3),Ax(3,maxlob,-1:1),dersc(3),ddersc(3)
6847       double precision contr(maxlob,-1:1)
6848       logical mixed
6849 c       write (iout,*) 'it=',it,' nlobit=',nlobit
6850         escloc_i=0.0D0
6851         do j=1,3
6852           dersc(j)=0.0D0
6853           if (mixed) ddersc(j)=0.0d0
6854         enddo
6855         x3=x(3)
6856
6857 C Because of periodicity of the dependence of the SC energy in omega we have
6858 C to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
6859 C To avoid underflows, first compute & store the exponents.
6860
6861         do iii=-1,1
6862
6863           x(3)=x3+iii*dwapi
6864
6865           do j=1,nlobit
6866             do k=1,3
6867               z(k)=x(k)-censc(k,j,it)
6868             enddo
6869             do k=1,3
6870               Axk=0.0D0
6871               do l=1,3
6872                 Axk=Axk+gaussc(l,k,j,it)*z(l)
6873               enddo
6874               Ax(k,j,iii)=Axk
6875             enddo
6876             expfac=0.0D0
6877             do k=1,3
6878               expfac=expfac+Ax(k,j,iii)*z(k)
6879             enddo
6880             contr(j,iii)=expfac
6881           enddo ! j
6882
6883         enddo ! iii
6884
6885         x(3)=x3
6886 C As in the case of ebend, we want to avoid underflows in exponentiation and
6887 C subsequent NaNs and INFs in energy calculation.
6888 C Find the largest exponent
6889         emin=contr(1,-1)
6890         do iii=-1,1
6891           do j=1,nlobit
6892             if (emin.gt.contr(j,iii)) emin=contr(j,iii)
6893           enddo
6894         enddo
6895         emin=0.5D0*emin
6896 cd      print *,'it=',it,' emin=',emin
6897
6898 C Compute the contribution to SC energy and derivatives
6899         do iii=-1,1
6900
6901           do j=1,nlobit
6902 #ifdef OSF
6903             adexp=bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin
6904             if(adexp.ne.adexp) adexp=1.0
6905             expfac=dexp(adexp)
6906 #else
6907             expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin)
6908 #endif
6909 cd          print *,'j=',j,' expfac=',expfac
6910             escloc_i=escloc_i+expfac
6911             do k=1,3
6912               dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
6913             enddo
6914             if (mixed) then
6915               do k=1,3,2
6916                 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii)
6917      &            +gaussc(k,2,j,it))*expfac
6918               enddo
6919             endif
6920           enddo
6921
6922         enddo ! iii
6923
6924         dersc(1)=dersc(1)/cos(theti)**2
6925         ddersc(1)=ddersc(1)/cos(theti)**2
6926         ddersc(3)=ddersc(3)
6927
6928         escloci=-(dlog(escloc_i)-emin)
6929         do j=1,3
6930           dersc(j)=dersc(j)/escloc_i
6931         enddo
6932         if (mixed) then
6933           do j=1,3,2
6934             ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
6935           enddo
6936         endif
6937       return
6938       end
6939 C------------------------------------------------------------------------------
6940       subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
6941       implicit real*8 (a-h,o-z)
6942       include 'DIMENSIONS'
6943       include 'COMMON.GEO'
6944       include 'COMMON.LOCAL'
6945       include 'COMMON.IOUNITS'
6946       common /sccalc/ time11,time12,time112,theti,it,nlobit
6947       double precision x(3),z(3),Ax(3,maxlob),dersc(3)
6948       double precision contr(maxlob)
6949       logical mixed
6950
6951       escloc_i=0.0D0
6952
6953       do j=1,3
6954         dersc(j)=0.0D0
6955       enddo
6956
6957       do j=1,nlobit
6958         do k=1,2
6959           z(k)=x(k)-censc(k,j,it)
6960         enddo
6961         z(3)=dwapi
6962         do k=1,3
6963           Axk=0.0D0
6964           do l=1,3
6965             Axk=Axk+gaussc(l,k,j,it)*z(l)
6966           enddo
6967           Ax(k,j)=Axk
6968         enddo
6969         expfac=0.0D0
6970         do k=1,3
6971           expfac=expfac+Ax(k,j)*z(k)
6972         enddo
6973         contr(j)=expfac
6974       enddo ! j
6975
6976 C As in the case of ebend, we want to avoid underflows in exponentiation and
6977 C subsequent NaNs and INFs in energy calculation.
6978 C Find the largest exponent
6979       emin=contr(1)
6980       do j=1,nlobit
6981         if (emin.gt.contr(j)) emin=contr(j)
6982       enddo
6983       emin=0.5D0*emin
6984
6985 C Compute the contribution to SC energy and derivatives
6986
6987       dersc12=0.0d0
6988       do j=1,nlobit
6989         expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j)+emin)
6990         escloc_i=escloc_i+expfac
6991         do k=1,2
6992           dersc(k)=dersc(k)+Ax(k,j)*expfac
6993         enddo
6994         if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j)
6995      &            +gaussc(1,2,j,it))*expfac
6996         dersc(3)=0.0d0
6997       enddo
6998
6999       dersc(1)=dersc(1)/cos(theti)**2
7000       dersc12=dersc12/cos(theti)**2
7001       escloci=-(dlog(escloc_i)-emin)
7002       do j=1,2
7003         dersc(j)=dersc(j)/escloc_i
7004       enddo
7005       if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
7006       return
7007       end
7008 #else
7009 c----------------------------------------------------------------------------------
7010       subroutine esc(escloc)
7011 C Calculate the local energy of a side chain and its derivatives in the
7012 C corresponding virtual-bond valence angles THETA and the spherical angles
7013 C ALPHA and OMEGA derived from AM1 all-atom calculations.
7014 C added by Urszula Kozlowska. 07/11/2007
7015 C
7016       implicit real*8 (a-h,o-z)
7017       include 'DIMENSIONS'
7018       include 'COMMON.GEO'
7019       include 'COMMON.LOCAL'
7020       include 'COMMON.VAR'
7021       include 'COMMON.SCROT'
7022       include 'COMMON.INTERACT'
7023       include 'COMMON.DERIV'
7024       include 'COMMON.CHAIN'
7025       include 'COMMON.IOUNITS'
7026       include 'COMMON.NAMES'
7027       include 'COMMON.FFIELD'
7028       include 'COMMON.CONTROL'
7029       include 'COMMON.VECTORS'
7030       double precision x_prime(3),y_prime(3),z_prime(3)
7031      &    , sumene,dsc_i,dp2_i,x(65),
7032      &     xx,yy,zz,sumene1,sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6,
7033      &    de_dxx,de_dyy,de_dzz,de_dt
7034       double precision s1_t,s1_6_t,s2_t,s2_6_t
7035       double precision
7036      & dXX_Ci1(3),dYY_Ci1(3),dZZ_Ci1(3),dXX_Ci(3),
7037      & dYY_Ci(3),dZZ_Ci(3),dXX_XYZ(3),dYY_XYZ(3),dZZ_XYZ(3),
7038      & dt_dCi(3),dt_dCi1(3)
7039       common /sccalc/ time11,time12,time112,theti,it,nlobit
7040       delta=0.02d0*pi
7041       escloc=0.0D0
7042       do i=loc_start,loc_end
7043         if (itype(i).eq.ntyp1) cycle
7044         costtab(i+1) =dcos(theta(i+1))
7045         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
7046         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
7047         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
7048         cosfac2=0.5d0/(1.0d0+costtab(i+1))
7049         cosfac=dsqrt(cosfac2)
7050         sinfac2=0.5d0/(1.0d0-costtab(i+1))
7051         sinfac=dsqrt(sinfac2)
7052         it=iabs(itype(i))
7053         if (it.eq.10) goto 1
7054 c
7055 C  Compute the axes of tghe local cartesian coordinates system; store in
7056 c   x_prime, y_prime and z_prime
7057 c
7058         do j=1,3
7059           x_prime(j) = 0.00
7060           y_prime(j) = 0.00
7061           z_prime(j) = 0.00
7062         enddo
7063 C        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
7064 C     &   dc_norm(3,i+nres)
7065         do j = 1,3
7066           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
7067           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
7068         enddo
7069         do j = 1,3
7070           z_prime(j) = -uz(j,i-1)*dsign(1.0d0,dfloat(itype(i)))
7071         enddo
7072 c       write (2,*) "i",i
7073 c       write (2,*) "x_prime",(x_prime(j),j=1,3)
7074 c       write (2,*) "y_prime",(y_prime(j),j=1,3)
7075 c       write (2,*) "z_prime",(z_prime(j),j=1,3)
7076 c       write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
7077 c      & " xy",scalar(x_prime(1),y_prime(1)),
7078 c      & " xz",scalar(x_prime(1),z_prime(1)),
7079 c      & " yy",scalar(y_prime(1),y_prime(1)),
7080 c      & " yz",scalar(y_prime(1),z_prime(1)),
7081 c      & " zz",scalar(z_prime(1),z_prime(1))
7082 c
7083 C Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
7084 C to local coordinate system. Store in xx, yy, zz.
7085 c
7086         xx=0.0d0
7087         yy=0.0d0
7088         zz=0.0d0
7089         do j = 1,3
7090           xx = xx + x_prime(j)*dc_norm(j,i+nres)
7091           yy = yy + y_prime(j)*dc_norm(j,i+nres)
7092           zz = zz + z_prime(j)*dc_norm(j,i+nres)
7093         enddo
7094
7095         xxtab(i)=xx
7096         yytab(i)=yy
7097         zztab(i)=zz
7098 C
7099 C Compute the energy of the ith side cbain
7100 C
7101 c        write (2,*) "xx",xx," yy",yy," zz",zz
7102         it=iabs(itype(i))
7103         do j = 1,65
7104           x(j) = sc_parmin(j,it)
7105         enddo
7106 #ifdef CHECK_COORD
7107 Cc diagnostics - remove later
7108         xx1 = dcos(alph(2))
7109         yy1 = dsin(alph(2))*dcos(omeg(2))
7110         zz1 = -dsign(1.0,dfloat(itype(i)))*dsin(alph(2))*dsin(omeg(2))
7111         write(2,'(3f8.1,3f9.3,1x,3f9.3)')
7112      &    alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,
7113      &    xx1,yy1,zz1
7114 C,"  --- ", xx_w,yy_w,zz_w
7115 c end diagnostics
7116 #endif
7117         sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
7118      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
7119      &   + x(10)*yy*zz
7120         sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
7121      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
7122      & + x(20)*yy*zz
7123         sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
7124      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
7125      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
7126      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
7127      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
7128      &  +x(40)*xx*yy*zz
7129         sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
7130      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
7131      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
7132      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
7133      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
7134      &  +x(60)*xx*yy*zz
7135         dsc_i   = 0.743d0+x(61)
7136         dp2_i   = 1.9d0+x(62)
7137         dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
7138      &          *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
7139         dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
7140      &          *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
7141         s1=(1+x(63))/(0.1d0 + dscp1)
7142         s1_6=(1+x(64))/(0.1d0 + dscp1**6)
7143         s2=(1+x(65))/(0.1d0 + dscp2)
7144         s2_6=(1+x(65))/(0.1d0 + dscp2**6)
7145         sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6)
7146      & + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
7147 c        write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
7148 c     &   sumene4,
7149 c     &   dscp1,dscp2,sumene
7150 c        sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
7151         escloc = escloc + sumene
7152 c        write (2,*) "i",i," escloc",sumene,escloc,it,itype(i)
7153 c     & ,zz,xx,yy
7154 c#define DEBUG
7155 #ifdef DEBUG
7156 C
7157 C This section to check the numerical derivatives of the energy of ith side
7158 C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
7159 C #define DEBUG in the code to turn it on.
7160 C
7161         write (2,*) "sumene               =",sumene
7162         aincr=1.0d-7
7163         xxsave=xx
7164         xx=xx+aincr
7165         write (2,*) xx,yy,zz
7166         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
7167         de_dxx_num=(sumenep-sumene)/aincr
7168         xx=xxsave
7169         write (2,*) "xx+ sumene from enesc=",sumenep
7170         yysave=yy
7171         yy=yy+aincr
7172         write (2,*) xx,yy,zz
7173         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
7174         de_dyy_num=(sumenep-sumene)/aincr
7175         yy=yysave
7176         write (2,*) "yy+ sumene from enesc=",sumenep
7177         zzsave=zz
7178         zz=zz+aincr
7179         write (2,*) xx,yy,zz
7180         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
7181         de_dzz_num=(sumenep-sumene)/aincr
7182         zz=zzsave
7183         write (2,*) "zz+ sumene from enesc=",sumenep
7184         costsave=cost2tab(i+1)
7185         sintsave=sint2tab(i+1)
7186         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
7187         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
7188         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
7189         de_dt_num=(sumenep-sumene)/aincr
7190         write (2,*) " t+ sumene from enesc=",sumenep
7191         cost2tab(i+1)=costsave
7192         sint2tab(i+1)=sintsave
7193 C End of diagnostics section.
7194 #endif
7195 C
7196 C Compute the gradient of esc
7197 C
7198 c        zz=zz*dsign(1.0,dfloat(itype(i)))
7199         pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
7200         pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
7201         pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
7202         pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
7203         pom_dx=dsc_i*dp2_i*cost2tab(i+1)
7204         pom_dy=dsc_i*dp2_i*sint2tab(i+1)
7205         pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
7206         pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
7207         pom1=(sumene3*sint2tab(i+1)+sumene1)
7208      &     *(pom_s1/dscp1+pom_s16*dscp1**4)
7209         pom2=(sumene4*cost2tab(i+1)+sumene2)
7210      &     *(pom_s2/dscp2+pom_s26*dscp2**4)
7211         sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
7212         sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2
7213      &  +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2)
7214      &  +x(40)*yy*zz
7215         sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
7216         sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2
7217      &  +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2)
7218      &  +x(60)*yy*zz
7219         de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6)
7220      &        +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6)
7221      &        +(pom1+pom2)*pom_dx
7222 #ifdef DEBUG
7223         write(2,*), "de_dxx = ", de_dxx,de_dxx_num,itype(i)
7224 #endif
7225 C
7226         sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
7227         sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2
7228      &  +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2)
7229      &  +x(40)*xx*zz
7230         sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
7231         sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz
7232      &  +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz
7233      &  +x(59)*zz**2 +x(60)*xx*zz
7234         de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6)
7235      &        +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6)
7236      &        +(pom1-pom2)*pom_dy
7237 #ifdef DEBUG
7238         write(2,*), "de_dyy = ", de_dyy,de_dyy_num,itype(i)
7239 #endif
7240 C
7241         de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy
7242      &  +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx
7243      &  +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6)
7244      &  +(x(4) + 2*x(7)*zz+  x(8)*xx + x(10)*yy)*(s1+s1_6)
7245      &  +(x(44)+2*x(47)*zz +x(48)*xx   +x(50)*yy  +3*x(53)*zz**2
7246      &  +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy
7247      &  +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6)
7248      &  + ( x(14) + 2*x(17)*zz+  x(18)*xx + x(20)*yy)*(s2+s2_6)
7249 #ifdef DEBUG
7250         write(2,*), "de_dzz = ", de_dzz,de_dzz_num,itype(i)
7251 #endif
7252 C
7253         de_dt =  0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6)
7254      &  -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6)
7255      &  +pom1*pom_dt1+pom2*pom_dt2
7256 #ifdef DEBUG
7257         write(2,*), "de_dt = ", de_dt,de_dt_num,itype(i)
7258 #endif
7259 c#undef DEBUG
7260 c
7261 C
7262        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
7263        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
7264        cosfac2xx=cosfac2*xx
7265        sinfac2yy=sinfac2*yy
7266        do k = 1,3
7267          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))*
7268      &      vbld_inv(i+1)
7269          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))*
7270      &      vbld_inv(i)
7271          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
7272          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
7273 c         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
7274 c     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
7275 c         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
7276 c     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
7277          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
7278          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
7279          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
7280          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
7281          dZZ_Ci1(k)=0.0d0
7282          dZZ_Ci(k)=0.0d0
7283          do j=1,3
7284            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)
7285      &     *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
7286            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)
7287      &     *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
7288          enddo
7289
7290          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
7291          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
7292          dZZ_XYZ(k)=vbld_inv(i+nres)*
7293      &   (z_prime(k)-zz*dC_norm(k,i+nres))
7294 c
7295          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
7296          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
7297        enddo
7298
7299        do k=1,3
7300          dXX_Ctab(k,i)=dXX_Ci(k)
7301          dXX_C1tab(k,i)=dXX_Ci1(k)
7302          dYY_Ctab(k,i)=dYY_Ci(k)
7303          dYY_C1tab(k,i)=dYY_Ci1(k)
7304          dZZ_Ctab(k,i)=dZZ_Ci(k)
7305          dZZ_C1tab(k,i)=dZZ_Ci1(k)
7306          dXX_XYZtab(k,i)=dXX_XYZ(k)
7307          dYY_XYZtab(k,i)=dYY_XYZ(k)
7308          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
7309        enddo
7310
7311        do k = 1,3
7312 c         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
7313 c     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
7314 c         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
7315 c     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
7316 c         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
7317 c     &    dt_dci(k)
7318 c         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
7319 c     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
7320          gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k)
7321      &    +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
7322          gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k)
7323      &    +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
7324          gsclocx(k,i)=                 de_dxx*dxx_XYZ(k)
7325      &    +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
7326        enddo
7327 c       write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
7328 c     &  (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
7329
7330 C to check gradient call subroutine check_grad
7331
7332     1 continue
7333       enddo
7334       return
7335       end
7336 c------------------------------------------------------------------------------
7337       double precision function enesc(x,xx,yy,zz,cost2,sint2)
7338       implicit none
7339       double precision x(65),xx,yy,zz,cost2,sint2,sumene1,sumene2,
7340      & sumene3,sumene4,sumene,dsc_i,dp2_i,dscp1,dscp2,s1,s1_6,s2,s2_6
7341       sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
7342      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
7343      &   + x(10)*yy*zz
7344       sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
7345      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
7346      & + x(20)*yy*zz
7347       sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
7348      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
7349      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
7350      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
7351      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
7352      &  +x(40)*xx*yy*zz
7353       sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
7354      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
7355      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
7356      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
7357      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
7358      &  +x(60)*xx*yy*zz
7359       dsc_i   = 0.743d0+x(61)
7360       dp2_i   = 1.9d0+x(62)
7361       dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
7362      &          *(xx*cost2+yy*sint2))
7363       dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
7364      &          *(xx*cost2-yy*sint2))
7365       s1=(1+x(63))/(0.1d0 + dscp1)
7366       s1_6=(1+x(64))/(0.1d0 + dscp1**6)
7367       s2=(1+x(65))/(0.1d0 + dscp2)
7368       s2_6=(1+x(65))/(0.1d0 + dscp2**6)
7369       sumene = ( sumene3*sint2 + sumene1)*(s1+s1_6)
7370      & + (sumene4*cost2 +sumene2)*(s2+s2_6)
7371       enesc=sumene
7372       return
7373       end
7374 #endif
7375 c------------------------------------------------------------------------------
7376       subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
7377 C
7378 C This procedure calculates two-body contact function g(rij) and its derivative:
7379 C
7380 C           eps0ij                                     !       x < -1
7381 C g(rij) =  esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5)  ! -1 =< x =< 1
7382 C            0                                         !       x > 1
7383 C
7384 C where x=(rij-r0ij)/delta
7385 C
7386 C rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
7387 C
7388       implicit none
7389       double precision rij,r0ij,eps0ij,fcont,fprimcont
7390       double precision x,x2,x4,delta
7391 c     delta=0.02D0*r0ij
7392 c      delta=0.2D0*r0ij
7393       x=(rij-r0ij)/delta
7394       if (x.lt.-1.0D0) then
7395         fcont=eps0ij
7396         fprimcont=0.0D0
7397       else if (x.le.1.0D0) then
7398         x2=x*x
7399         x4=x2*x2
7400         fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
7401         fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
7402       else
7403         fcont=0.0D0
7404         fprimcont=0.0D0
7405       endif
7406       return
7407       end
7408 c------------------------------------------------------------------------------
7409       subroutine splinthet(theti,delta,ss,ssder)
7410       implicit real*8 (a-h,o-z)
7411       include 'DIMENSIONS'
7412       include 'COMMON.VAR'
7413       include 'COMMON.GEO'
7414       thetup=pi-delta
7415       thetlow=delta
7416       if (theti.gt.pipol) then
7417         call gcont(theti,thetup,1.0d0,delta,ss,ssder)
7418       else
7419         call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
7420         ssder=-ssder
7421       endif
7422       return
7423       end
7424 c------------------------------------------------------------------------------
7425       subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
7426       implicit none
7427       double precision x,x0,delta,f0,f1,fprim0,f,fprim
7428       double precision ksi,ksi2,ksi3,a1,a2,a3
7429       a1=fprim0*delta/(f1-f0)
7430       a2=3.0d0-2.0d0*a1
7431       a3=a1-2.0d0
7432       ksi=(x-x0)/delta
7433       ksi2=ksi*ksi
7434       ksi3=ksi2*ksi
7435       f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
7436       fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
7437       return
7438       end
7439 c------------------------------------------------------------------------------
7440       subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
7441       implicit none
7442       double precision x,x0,delta,f0x,f1x,fprim0x,fx
7443       double precision ksi,ksi2,ksi3,a1,a2,a3
7444       ksi=(x-x0)/delta
7445       ksi2=ksi*ksi
7446       ksi3=ksi2*ksi
7447       a1=fprim0x*delta
7448       a2=3*(f1x-f0x)-2*fprim0x*delta
7449       a3=fprim0x*delta-2*(f1x-f0x)
7450       fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
7451       return
7452       end
7453 C-----------------------------------------------------------------------------
7454 #ifdef CRYST_TOR
7455 C-----------------------------------------------------------------------------
7456       subroutine etor(etors)
7457       implicit real*8 (a-h,o-z)
7458       include 'DIMENSIONS'
7459       include 'COMMON.VAR'
7460       include 'COMMON.GEO'
7461       include 'COMMON.LOCAL'
7462       include 'COMMON.TORSION'
7463       include 'COMMON.INTERACT'
7464       include 'COMMON.DERIV'
7465       include 'COMMON.CHAIN'
7466       include 'COMMON.NAMES'
7467       include 'COMMON.IOUNITS'
7468       include 'COMMON.FFIELD'
7469       include 'COMMON.TORCNSTR'
7470       include 'COMMON.CONTROL'
7471       logical lprn
7472 C Set lprn=.true. for debugging
7473       lprn=.false.
7474 c      lprn=.true.
7475       etors=0.0D0
7476       do i=iphi_start,iphi_end
7477       etors_ii=0.0D0
7478         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
7479      &      .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
7480         itori=itortyp(itype(i-2))
7481         itori1=itortyp(itype(i-1))
7482         phii=phi(i)
7483         gloci=0.0D0
7484 C Proline-Proline pair is a special case...
7485         if (itori.eq.3 .and. itori1.eq.3) then
7486           if (phii.gt.-dwapi3) then
7487             cosphi=dcos(3*phii)
7488             fac=1.0D0/(1.0D0-cosphi)
7489             etorsi=v1(1,3,3)*fac
7490             etorsi=etorsi+etorsi
7491             etors=etors+etorsi-v1(1,3,3)
7492             if (energy_dec) etors_ii=etors_ii+etorsi-v1(1,3,3)
7493             gloci=gloci-3*fac*etorsi*dsin(3*phii)
7494           endif
7495           do j=1,3
7496             v1ij=v1(j+1,itori,itori1)
7497             v2ij=v2(j+1,itori,itori1)
7498             cosphi=dcos(j*phii)
7499             sinphi=dsin(j*phii)
7500             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7501             if (energy_dec) etors_ii=etors_ii+
7502      &                              v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7503             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7504           enddo
7505         else
7506           do j=1,nterm_old
7507             v1ij=v1(j,itori,itori1)
7508             v2ij=v2(j,itori,itori1)
7509             cosphi=dcos(j*phii)
7510             sinphi=dsin(j*phii)
7511             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7512             if (energy_dec) etors_ii=etors_ii+
7513      &                  v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7514             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7515           enddo
7516         endif
7517         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
7518              'etor',i,etors_ii
7519         if (lprn)
7520      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
7521      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
7522      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
7523         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
7524 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
7525       enddo
7526       return
7527       end
7528 c------------------------------------------------------------------------------
7529       subroutine etor_d(etors_d)
7530       etors_d=0.0d0
7531       return
7532       end
7533 c----------------------------------------------------------------------------
7534 c LICZENIE WIEZOW Z ROWNANIA ENERGII MODELLERA
7535       subroutine e_modeller(ehomology_constr)
7536       ehomology_constr=0.0d0
7537       write (iout,*) "!!!!!UWAGA, JESTEM W DZIWNEJ PETLI, TEST!!!!!"
7538       return
7539       end
7540 C !!!!!!!! NIE CZYTANE !!!!!!!!!!!
7541
7542 c------------------------------------------------------------------------------
7543       subroutine etor_d(etors_d)
7544       etors_d=0.0d0
7545       return
7546       end
7547 c----------------------------------------------------------------------------
7548 #else
7549       subroutine etor(etors)
7550       implicit real*8 (a-h,o-z)
7551       include 'DIMENSIONS'
7552       include 'COMMON.VAR'
7553       include 'COMMON.GEO'
7554       include 'COMMON.LOCAL'
7555       include 'COMMON.TORSION'
7556       include 'COMMON.INTERACT'
7557       include 'COMMON.DERIV'
7558       include 'COMMON.CHAIN'
7559       include 'COMMON.NAMES'
7560       include 'COMMON.IOUNITS'
7561       include 'COMMON.FFIELD'
7562       include 'COMMON.TORCNSTR'
7563       include 'COMMON.CONTROL'
7564       logical lprn
7565 C Set lprn=.true. for debugging
7566       lprn=.false.
7567 c     lprn=.true.
7568       etors=0.0D0
7569       do i=iphi_start,iphi_end
7570 C ANY TWO ARE DUMMY ATOMS in row CYCLE
7571 c        if (((itype(i-3).eq.ntyp1).and.(itype(i-2).eq.ntyp1)).or.
7572 c     &      ((itype(i-2).eq.ntyp1).and.(itype(i-1).eq.ntyp1))  .or.
7573 c     &      ((itype(i-1).eq.ntyp1).and.(itype(i).eq.ntyp1))) cycle
7574         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
7575      &      .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
7576 C In current verion the ALL DUMMY ATOM POTENTIALS ARE OFF
7577 C For introducing the NH3+ and COO- group please check the etor_d for reference
7578 C and guidance
7579         etors_ii=0.0D0
7580          if (iabs(itype(i)).eq.20) then
7581          iblock=2
7582          else
7583          iblock=1
7584          endif
7585         itori=itortyp(itype(i-2))
7586         itori1=itortyp(itype(i-1))
7587         phii=phi(i)
7588         gloci=0.0D0
7589 C Regular cosine and sine terms
7590         do j=1,nterm(itori,itori1,iblock)
7591           v1ij=v1(j,itori,itori1,iblock)
7592           v2ij=v2(j,itori,itori1,iblock)
7593           cosphi=dcos(j*phii)
7594           sinphi=dsin(j*phii)
7595           etors=etors+v1ij*cosphi+v2ij*sinphi
7596           if (energy_dec) etors_ii=etors_ii+
7597      &                v1ij*cosphi+v2ij*sinphi
7598           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7599         enddo
7600 C Lorentz terms
7601 C                         v1
7602 C  E = SUM ----------------------------------- - v1
7603 C          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
7604 C
7605         cosphi=dcos(0.5d0*phii)
7606         sinphi=dsin(0.5d0*phii)
7607         do j=1,nlor(itori,itori1,iblock)
7608           vl1ij=vlor1(j,itori,itori1)
7609           vl2ij=vlor2(j,itori,itori1)
7610           vl3ij=vlor3(j,itori,itori1)
7611           pom=vl2ij*cosphi+vl3ij*sinphi
7612           pom1=1.0d0/(pom*pom+1.0d0)
7613           etors=etors+vl1ij*pom1
7614           if (energy_dec) etors_ii=etors_ii+
7615      &                vl1ij*pom1
7616           pom=-pom*pom1*pom1
7617           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
7618         enddo
7619 C Subtract the constant term
7620         etors=etors-v0(itori,itori1,iblock)
7621           if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
7622      &         'etor',i,etors_ii-v0(itori,itori1,iblock)
7623         if (lprn)
7624      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
7625      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
7626      &  (v1(j,itori,itori1,iblock),j=1,6),
7627      &  (v2(j,itori,itori1,iblock),j=1,6)
7628         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
7629 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
7630       enddo
7631       return
7632       end
7633 c----------------------------------------------------------------------------
7634       subroutine etor_d(etors_d)
7635 C 6/23/01 Compute double torsional energy
7636       implicit real*8 (a-h,o-z)
7637       include 'DIMENSIONS'
7638       include 'COMMON.VAR'
7639       include 'COMMON.GEO'
7640       include 'COMMON.LOCAL'
7641       include 'COMMON.TORSION'
7642       include 'COMMON.INTERACT'
7643       include 'COMMON.DERIV'
7644       include 'COMMON.CHAIN'
7645       include 'COMMON.NAMES'
7646       include 'COMMON.IOUNITS'
7647       include 'COMMON.FFIELD'
7648       include 'COMMON.TORCNSTR'
7649       logical lprn
7650 C Set lprn=.true. for debugging
7651       lprn=.false.
7652 c     lprn=.true.
7653       etors_d=0.0D0
7654 c      write(iout,*) "a tu??"
7655       do i=iphid_start,iphid_end
7656 C ANY TWO ARE DUMMY ATOMS in row CYCLE
7657 C        if (((itype(i-3).eq.ntyp1).and.(itype(i-2).eq.ntyp1)).or.
7658 C     &      ((itype(i-2).eq.ntyp1).and.(itype(i-1).eq.ntyp1)).or.
7659 C     &      ((itype(i-1).eq.ntyp1).and.(itype(i).eq.ntyp1))  .or.
7660 C     &      ((itype(i).eq.ntyp1).and.(itype(i+1).eq.ntyp1))) cycle
7661          if ((itype(i-2).eq.ntyp1).or.itype(i-3).eq.ntyp1.or.
7662      &  (itype(i-1).eq.ntyp1).or.(itype(i).eq.ntyp1).or.
7663      &  (itype(i+1).eq.ntyp1)) cycle
7664 C In current verion the ALL DUMMY ATOM POTENTIALS ARE OFF
7665         itori=itortyp(itype(i-2))
7666         itori1=itortyp(itype(i-1))
7667         itori2=itortyp(itype(i))
7668         phii=phi(i)
7669         phii1=phi(i+1)
7670         gloci1=0.0D0
7671         gloci2=0.0D0
7672         iblock=1
7673         if (iabs(itype(i+1)).eq.20) iblock=2
7674 C Iblock=2 Proline type
7675 C ADASKO: WHEN PARAMETERS FOR THIS TYPE OF BLOCKING GROUP IS READY UNCOMMENT
7676 C CHECK WEATHER THERE IS NECCESITY FOR iblock=3 for COO-
7677 C        if (itype(i+1).eq.ntyp1) iblock=3
7678 C The problem of NH3+ group can be resolved by adding new parameters please note if there
7679 C IS or IS NOT need for this
7680 C IF Yes uncomment below and add to parmread.F appropriate changes and to v1cij and so on
7681 C        is (itype(i-3).eq.ntyp1) ntblock=2
7682 C        ntblock is N-terminal blocking group
7683
7684 C Regular cosine and sine terms
7685         do j=1,ntermd_1(itori,itori1,itori2,iblock)
7686 C Example of changes for NH3+ blocking group
7687 C       do j=1,ntermd_1(itori,itori1,itori2,iblock,ntblock)
7688 C          v1cij=v1c(1,j,itori,itori1,itori2,iblock,ntblock)
7689           v1cij=v1c(1,j,itori,itori1,itori2,iblock)
7690           v1sij=v1s(1,j,itori,itori1,itori2,iblock)
7691           v2cij=v1c(2,j,itori,itori1,itori2,iblock)
7692           v2sij=v1s(2,j,itori,itori1,itori2,iblock)
7693           cosphi1=dcos(j*phii)
7694           sinphi1=dsin(j*phii)
7695           cosphi2=dcos(j*phii1)
7696           sinphi2=dsin(j*phii1)
7697           etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+
7698      &     v2cij*cosphi2+v2sij*sinphi2
7699           gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
7700           gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
7701         enddo
7702         do k=2,ntermd_2(itori,itori1,itori2,iblock)
7703           do l=1,k-1
7704             v1cdij = v2c(k,l,itori,itori1,itori2,iblock)
7705             v2cdij = v2c(l,k,itori,itori1,itori2,iblock)
7706             v1sdij = v2s(k,l,itori,itori1,itori2,iblock)
7707             v2sdij = v2s(l,k,itori,itori1,itori2,iblock)
7708             cosphi1p2=dcos(l*phii+(k-l)*phii1)
7709             cosphi1m2=dcos(l*phii-(k-l)*phii1)
7710             sinphi1p2=dsin(l*phii+(k-l)*phii1)
7711             sinphi1m2=dsin(l*phii-(k-l)*phii1)
7712             etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+
7713      &        v1sdij*sinphi1p2+v2sdij*sinphi1m2
7714             gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2
7715      &        -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
7716             gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2
7717      &        -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
7718           enddo
7719         enddo
7720         gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*gloci1
7721         gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*gloci2
7722       enddo
7723       return
7724       end
7725 #endif
7726 C----------------------------------------------------------------------------------
7727 C The rigorous attempt to derive energy function
7728       subroutine etor_kcc(etors)
7729       implicit real*8 (a-h,o-z)
7730       include 'DIMENSIONS'
7731       include 'COMMON.VAR'
7732       include 'COMMON.GEO'
7733       include 'COMMON.LOCAL'
7734       include 'COMMON.TORSION'
7735       include 'COMMON.INTERACT'
7736       include 'COMMON.DERIV'
7737       include 'COMMON.CHAIN'
7738       include 'COMMON.NAMES'
7739       include 'COMMON.IOUNITS'
7740       include 'COMMON.FFIELD'
7741       include 'COMMON.TORCNSTR'
7742       include 'COMMON.CONTROL'
7743       double precision c1(0:maxval_kcc),c2(0:maxval_kcc)
7744       logical lprn
7745 c      double precision thybt1(maxtermkcc),thybt2(maxtermkcc)
7746 C Set lprn=.true. for debugging
7747       lprn=energy_dec
7748 c     lprn=.true.
7749 C      print *,"wchodze kcc"
7750       if (lprn) write (iout,*) "etor_kcc tor_mode",tor_mode
7751       etors=0.0D0
7752       do i=iphi_start,iphi_end
7753 C ANY TWO ARE DUMMY ATOMS in row CYCLE
7754 c        if (((itype(i-3).eq.ntyp1).and.(itype(i-2).eq.ntyp1)).or.
7755 c     &      ((itype(i-2).eq.ntyp1).and.(itype(i-1).eq.ntyp1))  .or.
7756 c     &      ((itype(i-1).eq.ntyp1).and.(itype(i).eq.ntyp1))) cycle
7757         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
7758      &      .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
7759         itori=itortyp(itype(i-2))
7760         itori1=itortyp(itype(i-1))
7761         phii=phi(i)
7762         glocig=0.0D0
7763         glocit1=0.0d0
7764         glocit2=0.0d0
7765 C to avoid multiple devision by 2
7766 c        theti22=0.5d0*theta(i)
7767 C theta 12 is the theta_1 /2
7768 C theta 22 is theta_2 /2
7769 c        theti12=0.5d0*theta(i-1)
7770 C and appropriate sinus function
7771         sinthet1=dsin(theta(i-1))
7772         sinthet2=dsin(theta(i))
7773         costhet1=dcos(theta(i-1))
7774         costhet2=dcos(theta(i))
7775 C to speed up lets store its mutliplication
7776         sint1t2=sinthet2*sinthet1
7777         sint1t2n=1.0d0
7778 C \sum_{i=1}^n (sin(theta_1) * sin(theta_2))^n * (c_n* cos(n*gamma)
7779 C +d_n*sin(n*gamma)) *
7780 C \sum_{i=1}^m (1+a_m*Tb_m(cos(theta_1 /2))+b_m*Tb_m(cos(theta_2 /2)))
7781 C we have two sum 1) Non-Chebyshev which is with n and gamma
7782         nval=nterm_kcc_Tb(itori,itori1)
7783         c1(0)=0.0d0
7784         c2(0)=0.0d0
7785         c1(1)=1.0d0
7786         c2(1)=1.0d0
7787         do j=2,nval
7788           c1(j)=c1(j-1)*costhet1
7789           c2(j)=c2(j-1)*costhet2
7790         enddo
7791         etori=0.0d0
7792         do j=1,nterm_kcc(itori,itori1)
7793           cosphi=dcos(j*phii)
7794           sinphi=dsin(j*phii)
7795           sint1t2n1=sint1t2n
7796           sint1t2n=sint1t2n*sint1t2
7797           sumvalc=0.0d0
7798           gradvalct1=0.0d0
7799           gradvalct2=0.0d0
7800           do k=1,nval
7801             do l=1,nval
7802               sumvalc=sumvalc+v1_kcc(l,k,j,itori1,itori)*c1(k)*c2(l)
7803               gradvalct1=gradvalct1+
7804      &           (k-1)*v1_kcc(l,k,j,itori1,itori)*c1(k-1)*c2(l)
7805               gradvalct2=gradvalct2+
7806      &           (l-1)*v1_kcc(l,k,j,itori1,itori)*c1(k)*c2(l-1)
7807             enddo
7808           enddo
7809           gradvalct1=-gradvalct1*sinthet1
7810           gradvalct2=-gradvalct2*sinthet2
7811           sumvals=0.0d0
7812           gradvalst1=0.0d0
7813           gradvalst2=0.0d0
7814           do k=1,nval
7815             do l=1,nval
7816               sumvals=sumvals+v2_kcc(l,k,j,itori1,itori)*c1(k)*c2(l)
7817               gradvalst1=gradvalst1+
7818      &           (k-1)*v2_kcc(l,k,j,itori1,itori)*c1(k-1)*c2(l)
7819               gradvalst2=gradvalst2+
7820      &           (l-1)*v2_kcc(l,k,j,itori1,itori)*c1(k)*c2(l-1)
7821             enddo
7822           enddo
7823           gradvalst1=-gradvalst1*sinthet1
7824           gradvalst2=-gradvalst2*sinthet2
7825           if (lprn) write (iout,*)j,"sumvalc",sumvalc," sumvals",sumvals
7826           etori=etori+sint1t2n*(sumvalc*cosphi+sumvals*sinphi)
7827 C glocig is the gradient local i site in gamma
7828           glocig=glocig+j*sint1t2n*(sumvals*cosphi-sumvalc*sinphi)
7829 C now gradient over theta_1
7830           glocit1=glocit1+sint1t2n*(gradvalct1*cosphi+gradvalst1*sinphi)
7831      &   +j*sint1t2n1*costhet1*sinthet2*(sumvalc*cosphi+sumvals*sinphi)
7832           glocit2=glocit2+sint1t2n*(gradvalct2*cosphi+gradvalst2*sinphi)
7833      &   +j*sint1t2n1*sinthet1*costhet2*(sumvalc*cosphi+sumvals*sinphi)
7834         enddo ! j
7835         etors=etors+etori
7836 C derivative over gamma
7837         gloc(i-3,icg)=gloc(i-3,icg)+wtor*glocig
7838 C derivative over theta1
7839         gloc(nphi+i-3,icg)=gloc(nphi+i-3,icg)+wtor*glocit1
7840 C now derivative over theta2
7841         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)+wtor*glocit2
7842         if (lprn) then
7843           write (iout,*) i-2,i-1,itype(i-2),itype(i-1),itori,itori1,
7844      &       theta(i-1)*rad2deg,theta(i)*rad2deg,phii*rad2deg,etori
7845           write (iout,*) "c1",(c1(k),k=0,nval),
7846      &    " c2",(c2(k),k=0,nval)
7847         endif
7848       enddo
7849       return
7850       end
7851 c---------------------------------------------------------------------------------------------
7852       subroutine etor_constr(edihcnstr)
7853       implicit real*8 (a-h,o-z)
7854       include 'DIMENSIONS'
7855       include 'COMMON.VAR'
7856       include 'COMMON.GEO'
7857       include 'COMMON.LOCAL'
7858       include 'COMMON.TORSION'
7859       include 'COMMON.INTERACT'
7860       include 'COMMON.DERIV'
7861       include 'COMMON.CHAIN'
7862       include 'COMMON.NAMES'
7863       include 'COMMON.IOUNITS'
7864       include 'COMMON.FFIELD'
7865       include 'COMMON.TORCNSTR'
7866       include 'COMMON.BOUNDS'
7867       include 'COMMON.CONTROL'
7868 ! 6/20/98 - dihedral angle constraints
7869       edihcnstr=0.0d0
7870 c      do i=1,ndih_constr
7871       if (raw_psipred) then
7872         do i=idihconstr_start,idihconstr_end
7873           itori=idih_constr(i)
7874           phii=phi(itori)
7875           gaudih_i=vpsipred(1,i)
7876           gauder_i=0.0d0
7877           do j=1,2
7878             s = sdihed(j,i)
7879             cos_i=(1.0d0-dcos(phii-phibound(j,i)))/s**2
7880             dexpcos_i=dexp(-cos_i*cos_i)
7881             gaudih_i=gaudih_i+vpsipred(j+1,i)*dexpcos_i
7882             gauder_i=gauder_i-2*vpsipred(j+1,i)*dsin(phii-phibound(j,i))
7883      &            *cos_i*dexpcos_i/s**2
7884           enddo
7885           edihcnstr=edihcnstr-wdihc*dlog(gaudih_i)
7886           gloc(itori-3,icg)=gloc(itori-3,icg)-wdihc*gauder_i/gaudih_i
7887           if (energy_dec)
7888      &     write (iout,'(2i5,f8.3,f8.5,2(f8.5,2f8.3),f10.5)')
7889      &     i,itori,phii*rad2deg,vpsipred(1,i),vpsipred(2,i),
7890      &     phibound(1,i)*rad2deg,sdihed(1,i)*rad2deg,vpsipred(3,i),
7891      &     phibound(2,i)*rad2deg,sdihed(2,i)*rad2deg,
7892      &     -wdihc*dlog(gaudih_i)
7893         enddo
7894       else
7895
7896       do i=idihconstr_start,idihconstr_end
7897         itori=idih_constr(i)
7898         phii=phi(itori)
7899         difi=pinorm(phii-phi0(i))
7900         if (difi.gt.drange(i)) then
7901           difi=difi-drange(i)
7902           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
7903           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
7904         else if (difi.lt.-drange(i)) then
7905           difi=difi+drange(i)
7906           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
7907           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
7908         else
7909           difi=0.0
7910         endif
7911       enddo
7912
7913       endif
7914
7915       return
7916       end
7917 c----------------------------------------------------------------------------
7918 c MODELLER restraint function
7919       subroutine e_modeller(ehomology_constr)
7920       implicit real*8 (a-h,o-z)
7921       include 'DIMENSIONS'
7922
7923       integer nnn, i, j, k, ki, irec, l
7924       integer katy, odleglosci, test7
7925       real*8 odleg, odleg2, odleg3, kat, kat2, kat3, gdih(max_template)
7926       real*8 Eval,Erot
7927       real*8 distance(max_template),distancek(max_template),
7928      &    min_odl,godl(max_template),dih_diff(max_template)
7929
7930 c
7931 c     FP - 30/10/2014 Temporary specifications for homology restraints
7932 c
7933       double precision utheta_i,gutheta_i,sum_gtheta,sum_sgtheta,
7934      &                 sgtheta
7935       double precision, dimension (maxres) :: guscdiff,usc_diff
7936       double precision, dimension (max_template) ::
7937      &           gtheta,dscdiff,uscdiffk,guscdiff2,guscdiff3,
7938      &           theta_diff
7939 c
7940
7941       include 'COMMON.SBRIDGE'
7942       include 'COMMON.CHAIN'
7943       include 'COMMON.GEO'
7944       include 'COMMON.DERIV'
7945       include 'COMMON.LOCAL'
7946       include 'COMMON.INTERACT'
7947       include 'COMMON.VAR'
7948       include 'COMMON.IOUNITS'
7949       include 'COMMON.MD'
7950       include 'COMMON.HOMOLOGY'
7951       include 'COMMON.QRESTR'
7952       include 'COMMON.CONTROL'
7953 c
7954 c     From subroutine Econstr_back
7955 c
7956       include 'COMMON.NAMES'
7957       include 'COMMON.TIME1'
7958 c
7959
7960
7961       do i=1,max_template
7962         distancek(i)=9999999.9
7963       enddo
7964
7965
7966       odleg=0.0d0
7967
7968 c Pseudo-energy and gradient from homology restraints (MODELLER-like
7969 c function)
7970 C AL 5/2/14 - Introduce list of restraints
7971 c     write(iout,*) "waga_theta",waga_theta,"waga_d",waga_d
7972 #ifdef DEBUG
7973       write(iout,*) "------- dist restrs start -------"
7974 #endif
7975       do ii = link_start_homo,link_end_homo
7976          i = ires_homo(ii)
7977          j = jres_homo(ii)
7978          dij=dist(i,j)
7979 c        write (iout,*) "dij(",i,j,") =",dij
7980          nexl=0
7981          do k=1,constr_homology
7982 c           write(iout,*) ii,k,i,j,l_homo(k,ii),dij,odl(k,ii)
7983            if(.not.l_homo(k,ii)) then
7984              nexl=nexl+1
7985              cycle
7986            endif
7987            distance(k)=odl(k,ii)-dij
7988 c          write (iout,*) "distance(",k,") =",distance(k)
7989 c
7990 c          For Gaussian-type Urestr
7991 c
7992            distancek(k)=0.5d0*distance(k)**2*sigma_odl(k,ii) ! waga_dist rmvd from Gaussian argument
7993 c          write (iout,*) "sigma_odl(",k,ii,") =",sigma_odl(k,ii)
7994 c          write (iout,*) "distancek(",k,") =",distancek(k)
7995 c          distancek(k)=0.5d0*waga_dist*distance(k)**2*sigma_odl(k,ii)
7996 c
7997 c          For Lorentzian-type Urestr
7998 c
7999            if (waga_dist.lt.0.0d0) then
8000               sigma_odlir(k,ii)=dsqrt(1/sigma_odl(k,ii))
8001               distancek(k)=distance(k)**2/(sigma_odlir(k,ii)*
8002      &                     (distance(k)**2+sigma_odlir(k,ii)**2))
8003            endif
8004          enddo
8005
8006 c         min_odl=minval(distancek)
8007          do kk=1,constr_homology
8008           if(l_homo(kk,ii)) then
8009             min_odl=distancek(kk)
8010             exit
8011           endif
8012          enddo
8013          do kk=1,constr_homology
8014           if(l_homo(kk,ii) .and. distancek(kk).lt.min_odl)
8015      &              min_odl=distancek(kk)
8016          enddo
8017
8018 c        write (iout,* )"min_odl",min_odl
8019 #ifdef DEBUG
8020          write (iout,*) "ij dij",i,j,dij
8021          write (iout,*) "distance",(distance(k),k=1,constr_homology)
8022          write (iout,*) "distancek",(distancek(k),k=1,constr_homology)
8023          write (iout,* )"min_odl",min_odl
8024 #endif
8025 #ifdef OLDRESTR
8026          odleg2=0.0d0
8027 #else
8028          if (waga_dist.ge.0.0d0) then
8029            odleg2=nexl
8030          else
8031            odleg2=0.0d0
8032          endif
8033 #endif
8034          do k=1,constr_homology
8035 c Nie wiem po co to liczycie jeszcze raz!
8036 c            odleg3=-waga_dist(iset)*((distance(i,j,k)**2)/
8037 c     &              (2*(sigma_odl(i,j,k))**2))
8038            if(.not.l_homo(k,ii)) cycle
8039            if (waga_dist.ge.0.0d0) then
8040 c
8041 c          For Gaussian-type Urestr
8042 c
8043             godl(k)=dexp(-distancek(k)+min_odl)
8044             odleg2=odleg2+godl(k)
8045 c
8046 c          For Lorentzian-type Urestr
8047 c
8048            else
8049             odleg2=odleg2+distancek(k)
8050            endif
8051
8052 ccc       write(iout,779) i,j,k, "odleg2=",odleg2, "odleg3=", odleg3,
8053 ccc     & "dEXP(odleg3)=", dEXP(odleg3),"distance(i,j,k)^2=",
8054 ccc     & distance(i,j,k)**2, "dist(i+1,j+1)=", dist(i+1,j+1),
8055 ccc     & "sigma_odl(i,j,k)=", sigma_odl(i,j,k)
8056
8057          enddo
8058 c        write (iout,*) "godl",(godl(k),k=1,constr_homology) ! exponents
8059 c        write (iout,*) "ii i j",ii,i,j," odleg2",odleg2 ! sum of exps
8060 #ifdef DEBUG
8061          write (iout,*) "godl",(godl(k),k=1,constr_homology) ! exponents
8062          write (iout,*) "ii i j",ii,i,j," odleg2",odleg2 ! sum of exps
8063 #endif
8064            if (waga_dist.ge.0.0d0) then
8065 c
8066 c          For Gaussian-type Urestr
8067 c
8068               odleg=odleg-dLOG(odleg2/constr_homology)+min_odl
8069 c
8070 c          For Lorentzian-type Urestr
8071 c
8072            else
8073               odleg=odleg+odleg2/constr_homology
8074            endif
8075 c
8076 c        write (iout,*) "odleg",odleg ! sum of -ln-s
8077 c Gradient
8078 c
8079 c          For Gaussian-type Urestr
8080 c
8081          if (waga_dist.ge.0.0d0) sum_godl=odleg2
8082          sum_sgodl=0.0d0
8083          do k=1,constr_homology
8084 c            godl=dexp(((-(distance(i,j,k)**2)/(2*(sigma_odl(i,j,k))**2))
8085 c     &           *waga_dist)+min_odl
8086 c          sgodl=-godl(k)*distance(k)*sigma_odl(k,ii)*waga_dist
8087 c
8088          if(.not.l_homo(k,ii)) cycle
8089          if (waga_dist.ge.0.0d0) then
8090 c          For Gaussian-type Urestr
8091 c
8092            sgodl=-godl(k)*distance(k)*sigma_odl(k,ii) ! waga_dist rmvd
8093 c
8094 c          For Lorentzian-type Urestr
8095 c
8096          else
8097            sgodl=-2*sigma_odlir(k,ii)*(distance(k)/(distance(k)**2+
8098      &           sigma_odlir(k,ii)**2)**2)
8099          endif
8100            sum_sgodl=sum_sgodl+sgodl
8101
8102 c            sgodl2=sgodl2+sgodl
8103 c      write(iout,*) i, j, k, distance(i,j,k), "W GRADIENCIE1"
8104 c      write(iout,*) "constr_homology=",constr_homology
8105 c      write(iout,*) i, j, k, "TEST K"
8106          enddo
8107          if (waga_dist.ge.0.0d0) then
8108 c
8109 c          For Gaussian-type Urestr
8110 c
8111             grad_odl3=waga_homology(iset)*waga_dist
8112      &                *sum_sgodl/(sum_godl*dij)
8113 c
8114 c          For Lorentzian-type Urestr
8115 c
8116          else
8117 c Original grad expr modified by analogy w Gaussian-type Urestr grad
8118 c           grad_odl3=-waga_homology(iset)*waga_dist*sum_sgodl
8119             grad_odl3=-waga_homology(iset)*waga_dist*
8120      &                sum_sgodl/(constr_homology*dij)
8121          endif
8122 c
8123 c        grad_odl3=sum_sgodl/(sum_godl*dij)
8124
8125
8126 c      write(iout,*) i, j, k, distance(i,j,k), "W GRADIENCIE2"
8127 c      write(iout,*) (distance(i,j,k)**2), (2*(sigma_odl(i,j,k))**2),
8128 c     &              (-(distance(i,j,k)**2)/(2*(sigma_odl(i,j,k))**2))
8129
8130 ccc      write(iout,*) godl, sgodl, grad_odl3
8131
8132 c          grad_odl=grad_odl+grad_odl3
8133
8134          do jik=1,3
8135             ggodl=grad_odl3*(c(jik,i)-c(jik,j))
8136 ccc      write(iout,*) c(jik,i+1), c(jik,j+1), (c(jik,i+1)-c(jik,j+1))
8137 ccc      write(iout,746) "GRAD_ODL_1", i, j, jik, ggodl,
8138 ccc     &              ghpbc(jik,i+1), ghpbc(jik,j+1)
8139             ghpbc(jik,i)=ghpbc(jik,i)+ggodl
8140             ghpbc(jik,j)=ghpbc(jik,j)-ggodl
8141 ccc      write(iout,746) "GRAD_ODL_2", i, j, jik, ggodl,
8142 ccc     &              ghpbc(jik,i+1), ghpbc(jik,j+1)
8143 c         if (i.eq.25.and.j.eq.27) then
8144 c         write(iout,*) "jik",jik,"i",i,"j",j
8145 c         write(iout,*) "sum_sgodl",sum_sgodl,"sgodl",sgodl
8146 c         write(iout,*) "grad_odl3",grad_odl3
8147 c         write(iout,*) "c(",jik,i,")",c(jik,i),"c(",jik,j,")",c(jik,j)
8148 c         write(iout,*) "ggodl",ggodl
8149 c         write(iout,*) "ghpbc(",jik,i,")",
8150 c     &                 ghpbc(jik,i),"ghpbc(",jik,j,")",
8151 c     &                 ghpbc(jik,j)
8152 c         endif
8153          enddo
8154 ccc       write(iout,778)"TEST: odleg2=", odleg2, "DLOG(odleg2)=",
8155 ccc     & dLOG(odleg2),"-odleg=", -odleg
8156
8157       enddo ! ii-loop for dist
8158 #ifdef DEBUG
8159       write(iout,*) "------- dist restrs end -------"
8160 c     if (waga_angle.eq.1.0d0 .or. waga_theta.eq.1.0d0 .or.
8161 c    &     waga_d.eq.1.0d0) call sum_gradient
8162 #endif
8163 c Pseudo-energy and gradient from dihedral-angle restraints from
8164 c homology templates
8165 c      write (iout,*) "End of distance loop"
8166 c      call flush(iout)
8167       kat=0.0d0
8168 c      write (iout,*) idihconstr_start_homo,idihconstr_end_homo
8169 #ifdef DEBUG
8170       write(iout,*) "------- dih restrs start -------"
8171       do i=idihconstr_start_homo,idihconstr_end_homo
8172         write (iout,*) "gloc_init(",i,icg,")",gloc(i,icg)
8173       enddo
8174 #endif
8175       do i=idihconstr_start_homo,idihconstr_end_homo
8176         kat2=0.0d0
8177 c        betai=beta(i,i+1,i+2,i+3)
8178         betai = phi(i)
8179 c       write (iout,*) "betai =",betai
8180         do k=1,constr_homology
8181           dih_diff(k)=pinorm(dih(k,i)-betai)
8182 cd          write (iout,'(a8,2i4,2f15.8)') "dih_diff",i,k,dih_diff(k)
8183 cd     &                  ,sigma_dih(k,i)
8184 c          if (dih_diff(i,k).gt.3.14159) dih_diff(i,k)=
8185 c     &                                   -(6.28318-dih_diff(i,k))
8186 c          if (dih_diff(i,k).lt.-3.14159) dih_diff(i,k)=
8187 c     &                                   6.28318+dih_diff(i,k)
8188 #ifdef OLD_DIHED
8189           kat3=-0.5d0*dih_diff(k)**2*sigma_dih(k,i) ! waga_angle rmvd from Gaussian argument
8190 #else
8191           kat3=(dcos(dih_diff(k))-1)*sigma_dih(k,i) ! waga_angle rmvd from Gaussian argument
8192 #endif
8193 c         kat3=-0.5d0*waga_angle*dih_diff(k)**2*sigma_dih(k,i)
8194           gdih(k)=dexp(kat3)
8195           kat2=kat2+gdih(k)
8196 c          write(iout,*) "kat2=", kat2, "exp(kat3)=", exp(kat3)
8197 c          write(*,*)""
8198         enddo
8199 c       write (iout,*) "gdih",(gdih(k),k=1,constr_homology) ! exps
8200 c       write (iout,*) "i",i," betai",betai," kat2",kat2 ! sum of exps
8201 #ifdef DEBUG
8202         write (iout,*) "i",i," betai",betai," kat2",kat2
8203         write (iout,*) "gdih",(gdih(k),k=1,constr_homology)
8204 #endif
8205         if (kat2.le.1.0d-14) cycle
8206         kat=kat-dLOG(kat2/constr_homology)
8207 c       write (iout,*) "kat",kat ! sum of -ln-s
8208
8209 ccc       write(iout,778)"TEST: kat2=", kat2, "DLOG(kat2)=",
8210 ccc     & dLOG(kat2), "-kat=", -kat
8211
8212 c ----------------------------------------------------------------------
8213 c Gradient
8214 c ----------------------------------------------------------------------
8215
8216         sum_gdih=kat2
8217         sum_sgdih=0.0d0
8218         do k=1,constr_homology
8219 #ifdef OLD_DIHED
8220           sgdih=-gdih(k)*dih_diff(k)*sigma_dih(k,i)  ! waga_angle rmvd
8221 #else
8222           sgdih=-gdih(k)*dsin(dih_diff(k))*sigma_dih(k,i)  ! waga_angle rmvd
8223 #endif
8224 c         sgdih=-gdih(k)*dih_diff(k)*sigma_dih(k,i)*waga_angle
8225           sum_sgdih=sum_sgdih+sgdih
8226         enddo
8227 c       grad_dih3=sum_sgdih/sum_gdih
8228         grad_dih3=waga_homology(iset)*waga_angle*sum_sgdih/sum_gdih
8229
8230 c      write(iout,*)i,k,gdih,sgdih,beta(i+1,i+2,i+3,i+4),grad_dih3
8231 ccc      write(iout,747) "GRAD_KAT_1", i, nphi, icg, grad_dih3,
8232 ccc     & gloc(nphi+i-3,icg)
8233         gloc(i-3,icg)=gloc(i-3,icg)+grad_dih3
8234 c        if (i.eq.25) then
8235 c        write(iout,*) "i",i,"icg",icg,"gloc(",i,icg,")",gloc(i,icg)
8236 c        endif
8237 ccc      write(iout,747) "GRAD_KAT_2", i, nphi, icg, grad_dih3,
8238 ccc     & gloc(nphi+i-3,icg)
8239
8240       enddo ! i-loop for dih
8241 #ifdef DEBUG
8242       write(iout,*) "------- dih restrs end -------"
8243 #endif
8244
8245 c Pseudo-energy and gradient for theta angle restraints from
8246 c homology templates
8247 c FP 01/15 - inserted from econstr_local_test.F, loop structure
8248 c adapted
8249
8250 c
8251 c     For constr_homology reference structures (FP)
8252 c
8253 c     Uconst_back_tot=0.0d0
8254       Eval=0.0d0
8255       Erot=0.0d0
8256 c     Econstr_back legacy
8257       do i=1,nres
8258 c     do i=ithet_start,ithet_end
8259        dutheta(i)=0.0d0
8260 c     enddo
8261 c     do i=loc_start,loc_end
8262         do j=1,3
8263           duscdiff(j,i)=0.0d0
8264           duscdiffx(j,i)=0.0d0
8265         enddo
8266       enddo
8267 c
8268 c     do iref=1,nref
8269 c     write (iout,*) "ithet_start =",ithet_start,"ithet_end =",ithet_end
8270 c     write (iout,*) "waga_theta",waga_theta
8271       if (waga_theta.gt.0.0d0) then
8272 #ifdef DEBUG
8273       write (iout,*) "usampl",usampl
8274       write(iout,*) "------- theta restrs start -------"
8275 c     do i=ithet_start,ithet_end
8276 c       write (iout,*) "gloc_init(",nphi+i,icg,")",gloc(nphi+i,icg)
8277 c     enddo
8278 #endif
8279 c     write (iout,*) "maxres",maxres,"nres",nres
8280
8281       do i=ithet_start,ithet_end
8282 c
8283 c     do i=1,nfrag_back
8284 c       ii = ifrag_back(2,i,iset)-ifrag_back(1,i,iset)
8285 c
8286 c Deviation of theta angles wrt constr_homology ref structures
8287 c
8288         utheta_i=0.0d0 ! argument of Gaussian for single k
8289         gutheta_i=0.0d0 ! Sum of Gaussians over constr_homology ref structures
8290 c       do j=ifrag_back(1,i,iset)+2,ifrag_back(2,i,iset) ! original loop
8291 c       over residues in a fragment
8292 c       write (iout,*) "theta(",i,")=",theta(i)
8293         do k=1,constr_homology
8294 c
8295 c         dtheta_i=theta(j)-thetaref(j,iref)
8296 c         dtheta_i=thetaref(k,i)-theta(i) ! original form without indexing
8297           theta_diff(k)=thetatpl(k,i)-theta(i)
8298 cd          write (iout,'(a8,2i4,2f15.8)') "theta_diff",i,k,theta_diff(k)
8299 cd     &                  ,sigma_theta(k,i)
8300
8301 c
8302           utheta_i=-0.5d0*theta_diff(k)**2*sigma_theta(k,i) ! waga_theta rmvd from Gaussian argument
8303 c         utheta_i=-0.5d0*waga_theta*theta_diff(k)**2*sigma_theta(k,i) ! waga_theta?
8304           gtheta(k)=dexp(utheta_i) ! + min_utheta_i?
8305           gutheta_i=gutheta_i+gtheta(k)  ! Sum of Gaussians (pk)
8306 c         Gradient for single Gaussian restraint in subr Econstr_back
8307 c         dutheta(j-2)=dutheta(j-2)+wfrag_back(1,i,iset)*dtheta_i/(ii-1)
8308 c
8309         enddo
8310 c       write (iout,*) "gtheta",(gtheta(k),k=1,constr_homology) ! exps
8311 c       write (iout,*) "i",i," gutheta_i",gutheta_i ! sum of exps
8312
8313 c
8314 c         Gradient for multiple Gaussian restraint
8315         sum_gtheta=gutheta_i
8316         sum_sgtheta=0.0d0
8317         do k=1,constr_homology
8318 c        New generalized expr for multiple Gaussian from Econstr_back
8319          sgtheta=-gtheta(k)*theta_diff(k)*sigma_theta(k,i) ! waga_theta rmvd
8320 c
8321 c        sgtheta=-gtheta(k)*theta_diff(k)*sigma_theta(k,i)*waga_theta ! right functional form?
8322           sum_sgtheta=sum_sgtheta+sgtheta ! cum variable
8323         enddo
8324 c       Final value of gradient using same var as in Econstr_back
8325         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)
8326      &      +sum_sgtheta/sum_gtheta*waga_theta
8327      &               *waga_homology(iset)
8328 c        dutheta(i-2)=sum_sgtheta/sum_gtheta*waga_theta
8329 c     &               *waga_homology(iset)
8330 c       dutheta(i)=sum_sgtheta/sum_gtheta
8331 c
8332 c       Uconst_back=Uconst_back+waga_theta*utheta(i) ! waga_theta added as weight
8333         Eval=Eval-dLOG(gutheta_i/constr_homology)
8334 c       write (iout,*) "utheta(",i,")=",utheta(i) ! -ln of sum of exps
8335 c       write (iout,*) "Uconst_back",Uconst_back ! sum of -ln-s
8336 c       Uconst_back=Uconst_back+utheta(i)
8337       enddo ! (i-loop for theta)
8338 #ifdef DEBUG
8339       write(iout,*) "------- theta restrs end -------"
8340 #endif
8341       endif
8342 c
8343 c Deviation of local SC geometry
8344 c
8345 c Separation of two i-loops (instructed by AL - 11/3/2014)
8346 c
8347 c     write (iout,*) "loc_start =",loc_start,"loc_end =",loc_end
8348 c     write (iout,*) "waga_d",waga_d
8349
8350 #ifdef DEBUG
8351       write(iout,*) "------- SC restrs start -------"
8352       write (iout,*) "Initial duscdiff,duscdiffx"
8353       do i=loc_start,loc_end
8354         write (iout,*) i,(duscdiff(jik,i),jik=1,3),
8355      &                 (duscdiffx(jik,i),jik=1,3)
8356       enddo
8357 #endif
8358       do i=loc_start,loc_end
8359         usc_diff_i=0.0d0 ! argument of Gaussian for single k
8360         guscdiff(i)=0.0d0 ! Sum of Gaussians over constr_homology ref structures
8361 c       do j=ifrag_back(1,i,iset)+1,ifrag_back(2,i,iset)-1 ! Econstr_back legacy
8362 c       write(iout,*) "xxtab, yytab, zztab"
8363 c       write(iout,'(i5,3f8.2)') i,xxtab(i),yytab(i),zztab(i)
8364         do k=1,constr_homology
8365 c
8366           dxx=-xxtpl(k,i)+xxtab(i) ! Diff b/w x component of ith SC vector in model and kth ref str?
8367 c                                    Original sign inverted for calc of gradients (s. Econstr_back)
8368           dyy=-yytpl(k,i)+yytab(i) ! ibid y
8369           dzz=-zztpl(k,i)+zztab(i) ! ibid z
8370 c         write(iout,*) "dxx, dyy, dzz"
8371 cd          write(iout,'(2i5,4f8.2)') k,i,dxx,dyy,dzz,sigma_d(k,i)
8372 c
8373           usc_diff_i=-0.5d0*(dxx**2+dyy**2+dzz**2)*sigma_d(k,i)  ! waga_d rmvd from Gaussian argument
8374 c         usc_diff(i)=-0.5d0*waga_d*(dxx**2+dyy**2+dzz**2)*sigma_d(k,i) ! waga_d?
8375 c         uscdiffk(k)=usc_diff(i)
8376           guscdiff2(k)=dexp(usc_diff_i) ! without min_scdiff
8377 c          write(iout,*) "i",i," k",k," sigma_d",sigma_d(k,i),
8378 c     &       " guscdiff2",guscdiff2(k)
8379           guscdiff(i)=guscdiff(i)+guscdiff2(k)  !Sum of Gaussians (pk)
8380 c          write (iout,'(i5,6f10.5)') j,xxtab(j),yytab(j),zztab(j),
8381 c     &      xxref(j),yyref(j),zzref(j)
8382         enddo
8383 c
8384 c       Gradient
8385 c
8386 c       Generalized expression for multiple Gaussian acc to that for a single
8387 c       Gaussian in Econstr_back as instructed by AL (FP - 03/11/2014)
8388 c
8389 c       Original implementation
8390 c       sum_guscdiff=guscdiff(i)
8391 c
8392 c       sum_sguscdiff=0.0d0
8393 c       do k=1,constr_homology
8394 c          sguscdiff=-guscdiff2(k)*dscdiff(k)*sigma_d(k,i)*waga_d !waga_d?
8395 c          sguscdiff=-guscdiff3(k)*dscdiff(k)*sigma_d(k,i)*waga_d ! w min_uscdiff
8396 c          sum_sguscdiff=sum_sguscdiff+sguscdiff
8397 c       enddo
8398 c
8399 c       Implementation of new expressions for gradient (Jan. 2015)
8400 c
8401 c       grad_uscdiff=sum_sguscdiff/(sum_guscdiff*dtab) !?
8402         do k=1,constr_homology
8403 c
8404 c       New calculation of dxx, dyy, and dzz corrected by AL (07/11), was missing and wrong
8405 c       before. Now the drivatives should be correct
8406 c
8407           dxx=-xxtpl(k,i)+xxtab(i) ! Diff b/w x component of ith SC vector in model and kth ref str?
8408 c                                  Original sign inverted for calc of gradients (s. Econstr_back)
8409           dyy=-yytpl(k,i)+yytab(i) ! ibid y
8410           dzz=-zztpl(k,i)+zztab(i) ! ibid z
8411 c
8412 c         New implementation
8413 c
8414           sum_guscdiff=guscdiff2(k)*!(dsqrt(dxx*dxx+dyy*dyy+dzz*dzz))* -> wrong!
8415      &                 sigma_d(k,i) ! for the grad wrt r'
8416 c         sum_sguscdiff=sum_sguscdiff+sum_guscdiff
8417 c
8418 c
8419 c        New implementation
8420          sum_guscdiff = waga_homology(iset)*waga_d*sum_guscdiff
8421          do jik=1,3
8422             duscdiff(jik,i-1)=duscdiff(jik,i-1)+
8423      &      sum_guscdiff*(dXX_C1tab(jik,i)*dxx+
8424      &      dYY_C1tab(jik,i)*dyy+dZZ_C1tab(jik,i)*dzz)/guscdiff(i)
8425             duscdiff(jik,i)=duscdiff(jik,i)+
8426      &      sum_guscdiff*(dXX_Ctab(jik,i)*dxx+
8427      &      dYY_Ctab(jik,i)*dyy+dZZ_Ctab(jik,i)*dzz)/guscdiff(i)
8428             duscdiffx(jik,i)=duscdiffx(jik,i)+
8429      &      sum_guscdiff*(dXX_XYZtab(jik,i)*dxx+
8430      &      dYY_XYZtab(jik,i)*dyy+dZZ_XYZtab(jik,i)*dzz)/guscdiff(i)
8431 c
8432 #ifdef DEBUG
8433              write(iout,*) "jik",jik,"i",i
8434              write(iout,*) "dxx, dyy, dzz"
8435              write(iout,'(2i5,3f8.2)') k,i,dxx,dyy,dzz
8436              write(iout,*) "guscdiff2(",k,")",guscdiff2(k)
8437 c            write(iout,*) "sum_sguscdiff",sum_sguscdiff
8438 cc           write(iout,*) "dXX_Ctab(",jik,i,")",dXX_Ctab(jik,i)
8439 c            write(iout,*) "dYY_Ctab(",jik,i,")",dYY_Ctab(jik,i)
8440 c            write(iout,*) "dZZ_Ctab(",jik,i,")",dZZ_Ctab(jik,i)
8441 c            write(iout,*) "dXX_C1tab(",jik,i,")",dXX_C1tab(jik,i)
8442 c            write(iout,*) "dYY_C1tab(",jik,i,")",dYY_C1tab(jik,i)
8443 c            write(iout,*) "dZZ_C1tab(",jik,i,")",dZZ_C1tab(jik,i)
8444 c            write(iout,*) "dXX_XYZtab(",jik,i,")",dXX_XYZtab(jik,i)
8445 c            write(iout,*) "dYY_XYZtab(",jik,i,")",dYY_XYZtab(jik,i)
8446 c            write(iout,*) "dZZ_XYZtab(",jik,i,")",dZZ_XYZtab(jik,i)
8447 c            write(iout,*) "duscdiff(",jik,i-1,")",duscdiff(jik,i-1)
8448 c            write(iout,*) "duscdiff(",jik,i,")",duscdiff(jik,i)
8449 c            write(iout,*) "duscdiffx(",jik,i,")",duscdiffx(jik,i)
8450 c            endif
8451 #endif
8452          enddo
8453         enddo
8454 c
8455 c       uscdiff(i)=-dLOG(guscdiff(i)/(ii-1))      ! Weighting by (ii-1) required?
8456 c        usc_diff(i)=-dLOG(guscdiff(i)/constr_homology) ! + min_uscdiff ?
8457 c
8458 c        write (iout,*) i," uscdiff",uscdiff(i)
8459 c
8460 c Put together deviations from local geometry
8461
8462 c       Uconst_back=Uconst_back+wfrag_back(1,i,iset)*utheta(i)+
8463 c      &            wfrag_back(3,i,iset)*uscdiff(i)
8464         Erot=Erot-dLOG(guscdiff(i)/constr_homology)
8465 c       write (iout,*) "usc_diff(",i,")=",usc_diff(i) ! -ln of sum of exps
8466 c       write (iout,*) "Uconst_back",Uconst_back ! cum sum of -ln-s
8467 c       Uconst_back=Uconst_back+usc_diff(i)
8468 c
8469 c     Gradient of multiple Gaussian restraint (FP - 04/11/2014 - right?)
8470 c
8471 c     New implment: multiplied by sum_sguscdiff
8472 c
8473
8474       enddo ! (i-loop for dscdiff)
8475
8476 c      endif
8477
8478 #ifdef DEBUG
8479       write(iout,*) "------- SC restrs end -------"
8480         write (iout,*) "------ After SC loop in e_modeller ------"
8481         do i=loc_start,loc_end
8482          write (iout,*) "i",i," gradc",(gradc(j,i,icg),j=1,3)
8483          write (iout,*) "i",i," gradx",(gradx(j,i,icg),j=1,3)
8484         enddo
8485       if (waga_theta.eq.1.0d0) then
8486       write (iout,*) "in e_modeller after SC restr end: dutheta"
8487       do i=ithet_start,ithet_end
8488         write (iout,*) i,dutheta(i)
8489       enddo
8490       endif
8491       if (waga_d.eq.1.0d0) then
8492       write (iout,*) "e_modeller after SC loop: duscdiff/x"
8493       do i=1,nres
8494         write (iout,*) i,(duscdiff(j,i),j=1,3)
8495         write (iout,*) i,(duscdiffx(j,i),j=1,3)
8496       enddo
8497       endif
8498 #endif
8499
8500 c Total energy from homology restraints
8501 #ifdef DEBUG
8502       write (iout,*) "odleg",odleg," kat",kat
8503 #endif
8504 c
8505 c Addition of energy of theta angle and SC local geom over constr_homologs ref strs
8506 c
8507 c     ehomology_constr=odleg+kat
8508 c
8509 c     For Lorentzian-type Urestr
8510 c
8511
8512       if (waga_dist.ge.0.0d0) then
8513 c
8514 c          For Gaussian-type Urestr
8515 c
8516         ehomology_constr=(waga_dist*odleg+waga_angle*kat+
8517      &              waga_theta*Eval+waga_d*Erot)*waga_homology(iset)
8518 c     write (iout,*) "ehomology_constr=",ehomology_constr
8519       else
8520 c
8521 c          For Lorentzian-type Urestr
8522 c
8523         ehomology_constr=(-waga_dist*odleg+waga_angle*kat+
8524      &              waga_theta*Eval+waga_d*Erot)*waga_homology(iset)
8525 c     write (iout,*) "ehomology_constr=",ehomology_constr
8526       endif
8527 #ifdef DEBUG
8528       write (iout,*) "odleg",waga_dist,odleg," kat",waga_angle,kat,
8529      & "Eval",waga_theta,eval,
8530      &   "Erot",waga_d,Erot
8531       write (iout,*) "ehomology_constr",ehomology_constr
8532 #endif
8533       return
8534 c
8535 c FP 01/15 end
8536 c
8537   748 format(a8,f12.3,a6,f12.3,a7,f12.3)
8538   747 format(a12,i4,i4,i4,f8.3,f8.3)
8539   746 format(a12,i4,i4,i4,f8.3,f8.3,f8.3)
8540   778 format(a7,1X,f10.3,1X,a4,1X,f10.3,1X,a5,1X,f10.3)
8541   779 format(i3,1X,i3,1X,i2,1X,a7,1X,f7.3,1X,a7,1X,f7.3,1X,a13,1X,
8542      &       f7.3,1X,a17,1X,f9.3,1X,a10,1X,f8.3,1X,a10,1X,f8.3)
8543       end
8544 c----------------------------------------------------------------------------
8545 C The rigorous attempt to derive energy function
8546       subroutine ebend_kcc(etheta)
8547
8548       implicit real*8 (a-h,o-z)
8549       include 'DIMENSIONS'
8550       include 'COMMON.VAR'
8551       include 'COMMON.GEO'
8552       include 'COMMON.LOCAL'
8553       include 'COMMON.TORSION'
8554       include 'COMMON.INTERACT'
8555       include 'COMMON.DERIV'
8556       include 'COMMON.CHAIN'
8557       include 'COMMON.NAMES'
8558       include 'COMMON.IOUNITS'
8559       include 'COMMON.FFIELD'
8560       include 'COMMON.TORCNSTR'
8561       include 'COMMON.CONTROL'
8562       logical lprn
8563       double precision thybt1(maxang_kcc)
8564 C Set lprn=.true. for debugging
8565       lprn=energy_dec
8566 c     lprn=.true.
8567 C      print *,"wchodze kcc"
8568       if (lprn) write (iout,*) "ebend_kcc tor_mode",tor_mode
8569       etheta=0.0D0
8570       do i=ithet_start,ithet_end
8571 c        print *,i,itype(i-1),itype(i),itype(i-2)
8572         if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
8573      &  .or.itype(i).eq.ntyp1) cycle
8574         iti=iabs(itortyp(itype(i-1)))
8575         sinthet=dsin(theta(i))
8576         costhet=dcos(theta(i))
8577         do j=1,nbend_kcc_Tb(iti)
8578           thybt1(j)=v1bend_chyb(j,iti)
8579         enddo
8580         sumth1thyb=v1bend_chyb(0,iti)+
8581      &    tschebyshev(1,nbend_kcc_Tb(iti),thybt1(1),costhet)
8582         if (lprn) write (iout,*) i-1,itype(i-1),iti,theta(i)*rad2deg,
8583      &    sumth1thyb
8584         ihelp=nbend_kcc_Tb(iti)-1
8585         gradthybt1=gradtschebyshev(0,ihelp,thybt1(1),costhet)
8586         etheta=etheta+sumth1thyb
8587 C        print *,sumth1thyb,gradthybt1,sinthet*(-0.5d0)
8588         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)-wang*gradthybt1*sinthet
8589       enddo
8590       return
8591       end
8592 c-------------------------------------------------------------------------------------
8593       subroutine etheta_constr(ethetacnstr)
8594
8595       implicit real*8 (a-h,o-z)
8596       include 'DIMENSIONS'
8597       include 'COMMON.VAR'
8598       include 'COMMON.GEO'
8599       include 'COMMON.LOCAL'
8600       include 'COMMON.TORSION'
8601       include 'COMMON.INTERACT'
8602       include 'COMMON.DERIV'
8603       include 'COMMON.CHAIN'
8604       include 'COMMON.NAMES'
8605       include 'COMMON.IOUNITS'
8606       include 'COMMON.FFIELD'
8607       include 'COMMON.TORCNSTR'
8608       include 'COMMON.CONTROL'
8609       ethetacnstr=0.0d0
8610 C      print *,ithetaconstr_start,ithetaconstr_end,"TU"
8611       do i=ithetaconstr_start,ithetaconstr_end
8612         itheta=itheta_constr(i)
8613         thetiii=theta(itheta)
8614         difi=pinorm(thetiii-theta_constr0(i))
8615         if (difi.gt.theta_drange(i)) then
8616           difi=difi-theta_drange(i)
8617           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
8618           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
8619      &    +for_thet_constr(i)*difi**3
8620         else if (difi.lt.-drange(i)) then
8621           difi=difi+drange(i)
8622           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
8623           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
8624      &    +for_thet_constr(i)*difi**3
8625         else
8626           difi=0.0
8627         endif
8628        if (energy_dec) then
8629         write (iout,'(a6,2i5,4f8.3,2e14.5)') "ethetc",
8630      &    i,itheta,rad2deg*thetiii,
8631      &    rad2deg*theta_constr0(i),  rad2deg*theta_drange(i),
8632      &    rad2deg*difi,0.25d0*for_thet_constr(i)*difi**4,
8633      &    gloc(itheta+nphi-2,icg)
8634         endif
8635       enddo
8636       return
8637       end
8638 c------------------------------------------------------------------------------
8639       subroutine eback_sc_corr(esccor)
8640 c 7/21/2007 Correlations between the backbone-local and side-chain-local
8641 c        conformational states; temporarily implemented as differences
8642 c        between UNRES torsional potentials (dependent on three types of
8643 c        residues) and the torsional potentials dependent on all 20 types
8644 c        of residues computed from AM1  energy surfaces of terminally-blocked
8645 c        amino-acid residues.
8646       implicit real*8 (a-h,o-z)
8647       include 'DIMENSIONS'
8648       include 'COMMON.VAR'
8649       include 'COMMON.GEO'
8650       include 'COMMON.LOCAL'
8651       include 'COMMON.TORSION'
8652       include 'COMMON.SCCOR'
8653       include 'COMMON.INTERACT'
8654       include 'COMMON.DERIV'
8655       include 'COMMON.CHAIN'
8656       include 'COMMON.NAMES'
8657       include 'COMMON.IOUNITS'
8658       include 'COMMON.FFIELD'
8659       include 'COMMON.CONTROL'
8660       logical lprn
8661 C Set lprn=.true. for debugging
8662       lprn=.false.
8663 c      lprn=.true.
8664 c      write (iout,*) "EBACK_SC_COR",itau_start,itau_end
8665       esccor=0.0D0
8666       do i=itau_start,itau_end
8667         if ((itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)) cycle
8668         esccor_ii=0.0D0
8669         isccori=isccortyp(itype(i-2))
8670         isccori1=isccortyp(itype(i-1))
8671 c      write (iout,*) "EBACK_SC_COR",i,nterm_sccor(isccori,isccori1)
8672         phii=phi(i)
8673         do intertyp=1,3 !intertyp
8674 cc Added 09 May 2012 (Adasko)
8675 cc  Intertyp means interaction type of backbone mainchain correlation:
8676 c   1 = SC...Ca...Ca...Ca
8677 c   2 = Ca...Ca...Ca...SC
8678 c   3 = SC...Ca...Ca...SCi
8679         gloci=0.0D0
8680         if (((intertyp.eq.3).and.((itype(i-2).eq.10).or.
8681      &      (itype(i-1).eq.10).or.(itype(i-2).eq.ntyp1).or.
8682      &      (itype(i-1).eq.ntyp1)))
8683      &    .or. ((intertyp.eq.1).and.((itype(i-2).eq.10)
8684      &     .or.(itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)
8685      &     .or.(itype(i).eq.ntyp1)))
8686      &    .or.((intertyp.eq.2).and.((itype(i-1).eq.10).or.
8687      &      (itype(i-1).eq.ntyp1).or.(itype(i-2).eq.ntyp1).or.
8688      &      (itype(i-3).eq.ntyp1)))) cycle
8689         if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1).eq.ntyp1)) cycle
8690         if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres).eq.ntyp1))
8691      & cycle
8692        do j=1,nterm_sccor(isccori,isccori1)
8693           v1ij=v1sccor(j,intertyp,isccori,isccori1)
8694           v2ij=v2sccor(j,intertyp,isccori,isccori1)
8695           cosphi=dcos(j*tauangle(intertyp,i))
8696           sinphi=dsin(j*tauangle(intertyp,i))
8697           esccor=esccor+v1ij*cosphi+v2ij*sinphi
8698           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
8699         enddo
8700 c      write (iout,*) "EBACK_SC_COR",i,v1ij*cosphi+v2ij*sinphi,intertyp
8701         gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci
8702         if (lprn)
8703      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
8704      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,isccori,isccori1,
8705      &  (v1sccor(j,intertyp,isccori,isccori1),j=1,6)
8706      & ,(v2sccor(j,intertyp,isccori,isccori1),j=1,6)
8707         gsccor_loc(i-3)=gsccor_loc(i-3)+gloci
8708        enddo !intertyp
8709       enddo
8710
8711       return
8712       end
8713 c----------------------------------------------------------------------------
8714       subroutine multibody(ecorr)
8715 C This subroutine calculates multi-body contributions to energy following
8716 C the idea of Skolnick et al. If side chains I and J make a contact and
8717 C at the same time side chains I+1 and J+1 make a contact, an extra
8718 C contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
8719       implicit real*8 (a-h,o-z)
8720       include 'DIMENSIONS'
8721       include 'COMMON.IOUNITS'
8722       include 'COMMON.DERIV'
8723       include 'COMMON.INTERACT'
8724       include 'COMMON.CONTACTS'
8725       double precision gx(3),gx1(3)
8726       logical lprn
8727
8728 C Set lprn=.true. for debugging
8729       lprn=.false.
8730
8731       if (lprn) then
8732         write (iout,'(a)') 'Contact function values:'
8733         do i=nnt,nct-2
8734           write (iout,'(i2,20(1x,i2,f10.5))')
8735      &        i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
8736         enddo
8737       endif
8738       ecorr=0.0D0
8739       do i=nnt,nct
8740         do j=1,3
8741           gradcorr(j,i)=0.0D0
8742           gradxorr(j,i)=0.0D0
8743         enddo
8744       enddo
8745       do i=nnt,nct-2
8746
8747         DO ISHIFT = 3,4
8748
8749         i1=i+ishift
8750         num_conti=num_cont(i)
8751         num_conti1=num_cont(i1)
8752         do jj=1,num_conti
8753           j=jcont(jj,i)
8754           do kk=1,num_conti1
8755             j1=jcont(kk,i1)
8756             if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
8757 cd          write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
8758 cd   &                   ' ishift=',ishift
8759 C Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
8760 C The system gains extra energy.
8761               ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
8762             endif   ! j1==j+-ishift
8763           enddo     ! kk
8764         enddo       ! jj
8765
8766         ENDDO ! ISHIFT
8767
8768       enddo         ! i
8769       return
8770       end
8771 c------------------------------------------------------------------------------
8772       double precision function esccorr(i,j,k,l,jj,kk)
8773       implicit real*8 (a-h,o-z)
8774       include 'DIMENSIONS'
8775       include 'COMMON.IOUNITS'
8776       include 'COMMON.DERIV'
8777       include 'COMMON.INTERACT'
8778       include 'COMMON.CONTACTS'
8779       include 'COMMON.SHIELD'
8780       double precision gx(3),gx1(3)
8781       logical lprn
8782       lprn=.false.
8783       eij=facont(jj,i)
8784       ekl=facont(kk,k)
8785 cd    write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
8786 C Calculate the multi-body contribution to energy.
8787 C Calculate multi-body contributions to the gradient.
8788 cd    write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
8789 cd   & k,l,(gacont(m,kk,k),m=1,3)
8790       do m=1,3
8791         gx(m) =ekl*gacont(m,jj,i)
8792         gx1(m)=eij*gacont(m,kk,k)
8793         gradxorr(m,i)=gradxorr(m,i)-gx(m)
8794         gradxorr(m,j)=gradxorr(m,j)+gx(m)
8795         gradxorr(m,k)=gradxorr(m,k)-gx1(m)
8796         gradxorr(m,l)=gradxorr(m,l)+gx1(m)
8797       enddo
8798       do m=i,j-1
8799         do ll=1,3
8800           gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
8801         enddo
8802       enddo
8803       do m=k,l-1
8804         do ll=1,3
8805           gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
8806         enddo
8807       enddo
8808       esccorr=-eij*ekl
8809       return
8810       end
8811 c------------------------------------------------------------------------------
8812       subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
8813 C This subroutine calculates multi-body contributions to hydrogen-bonding
8814       implicit real*8 (a-h,o-z)
8815       include 'DIMENSIONS'
8816       include 'COMMON.IOUNITS'
8817 #ifdef MPI
8818       include "mpif.h"
8819       parameter (max_cont=maxconts)
8820       parameter (max_dim=26)
8821       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
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 status(MPI_STATUS_SIZE),req(maxconts*2),
8826      &  status_array(MPI_STATUS_SIZE,maxconts*2)
8827 #endif
8828       include 'COMMON.SETUP'
8829       include 'COMMON.FFIELD'
8830       include 'COMMON.DERIV'
8831       include 'COMMON.INTERACT'
8832       include 'COMMON.CONTACTS'
8833       include 'COMMON.CONTROL'
8834       include 'COMMON.LOCAL'
8835       double precision gx(3),gx1(3),time00
8836       logical lprn,ldone
8837
8838 C Set lprn=.true. for debugging
8839       lprn=.false.
8840 #ifdef MPI
8841       n_corr=0
8842       n_corr1=0
8843       if (nfgtasks.le.1) goto 30
8844       if (lprn) then
8845         write (iout,'(a)') 'Contact function values before RECEIVE:'
8846         do i=nnt,nct-2
8847           write (iout,'(2i3,50(1x,i2,f5.2))')
8848      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
8849      &    j=1,num_cont_hb(i))
8850         enddo
8851         call flush(iout)
8852       endif
8853       do i=1,ntask_cont_from
8854         ncont_recv(i)=0
8855       enddo
8856       do i=1,ntask_cont_to
8857         ncont_sent(i)=0
8858       enddo
8859 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
8860 c     & ntask_cont_to
8861 C Make the list of contacts to send to send to other procesors
8862 c      write (iout,*) "limits",max0(iturn4_end-1,iatel_s),iturn3_end
8863 c      call flush(iout)
8864       do i=iturn3_start,iturn3_end
8865 c        write (iout,*) "make contact list turn3",i," num_cont",
8866 c     &    num_cont_hb(i)
8867         call add_hb_contact(i,i+2,iturn3_sent_local(1,i))
8868       enddo
8869       do i=iturn4_start,iturn4_end
8870 c        write (iout,*) "make contact list turn4",i," num_cont",
8871 c     &   num_cont_hb(i)
8872         call add_hb_contact(i,i+3,iturn4_sent_local(1,i))
8873       enddo
8874       do ii=1,nat_sent
8875         i=iat_sent(ii)
8876 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
8877 c     &    num_cont_hb(i)
8878         do j=1,num_cont_hb(i)
8879         do k=1,4
8880           jjc=jcont_hb(j,i)
8881           iproc=iint_sent_local(k,jjc,ii)
8882 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
8883           if (iproc.gt.0) then
8884             ncont_sent(iproc)=ncont_sent(iproc)+1
8885             nn=ncont_sent(iproc)
8886             zapas(1,nn,iproc)=i
8887             zapas(2,nn,iproc)=jjc
8888             zapas(3,nn,iproc)=facont_hb(j,i)
8889             zapas(4,nn,iproc)=ees0p(j,i)
8890             zapas(5,nn,iproc)=ees0m(j,i)
8891             zapas(6,nn,iproc)=gacont_hbr(1,j,i)
8892             zapas(7,nn,iproc)=gacont_hbr(2,j,i)
8893             zapas(8,nn,iproc)=gacont_hbr(3,j,i)
8894             zapas(9,nn,iproc)=gacontm_hb1(1,j,i)
8895             zapas(10,nn,iproc)=gacontm_hb1(2,j,i)
8896             zapas(11,nn,iproc)=gacontm_hb1(3,j,i)
8897             zapas(12,nn,iproc)=gacontp_hb1(1,j,i)
8898             zapas(13,nn,iproc)=gacontp_hb1(2,j,i)
8899             zapas(14,nn,iproc)=gacontp_hb1(3,j,i)
8900             zapas(15,nn,iproc)=gacontm_hb2(1,j,i)
8901             zapas(16,nn,iproc)=gacontm_hb2(2,j,i)
8902             zapas(17,nn,iproc)=gacontm_hb2(3,j,i)
8903             zapas(18,nn,iproc)=gacontp_hb2(1,j,i)
8904             zapas(19,nn,iproc)=gacontp_hb2(2,j,i)
8905             zapas(20,nn,iproc)=gacontp_hb2(3,j,i)
8906             zapas(21,nn,iproc)=gacontm_hb3(1,j,i)
8907             zapas(22,nn,iproc)=gacontm_hb3(2,j,i)
8908             zapas(23,nn,iproc)=gacontm_hb3(3,j,i)
8909             zapas(24,nn,iproc)=gacontp_hb3(1,j,i)
8910             zapas(25,nn,iproc)=gacontp_hb3(2,j,i)
8911             zapas(26,nn,iproc)=gacontp_hb3(3,j,i)
8912           endif
8913         enddo
8914         enddo
8915       enddo
8916       if (lprn) then
8917       write (iout,*)
8918      &  "Numbers of contacts to be sent to other processors",
8919      &  (ncont_sent(i),i=1,ntask_cont_to)
8920       write (iout,*) "Contacts sent"
8921       do ii=1,ntask_cont_to
8922         nn=ncont_sent(ii)
8923         iproc=itask_cont_to(ii)
8924         write (iout,*) nn," contacts to processor",iproc,
8925      &   " of CONT_TO_COMM group"
8926         do i=1,nn
8927           write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
8928         enddo
8929       enddo
8930       call flush(iout)
8931       endif
8932       CorrelType=477
8933       CorrelID=fg_rank+1
8934       CorrelType1=478
8935       CorrelID1=nfgtasks+fg_rank+1
8936       ireq=0
8937 C Receive the numbers of needed contacts from other processors
8938       do ii=1,ntask_cont_from
8939         iproc=itask_cont_from(ii)
8940         ireq=ireq+1
8941         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
8942      &    FG_COMM,req(ireq),IERR)
8943       enddo
8944 c      write (iout,*) "IRECV ended"
8945 c      call flush(iout)
8946 C Send the number of contacts needed by other processors
8947       do ii=1,ntask_cont_to
8948         iproc=itask_cont_to(ii)
8949         ireq=ireq+1
8950         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
8951      &    FG_COMM,req(ireq),IERR)
8952       enddo
8953 c      write (iout,*) "ISEND ended"
8954 c      write (iout,*) "number of requests (nn)",ireq
8955 c      call flush(iout)
8956       if (ireq.gt.0)
8957      &  call MPI_Waitall(ireq,req,status_array,ierr)
8958 c      write (iout,*)
8959 c     &  "Numbers of contacts to be received from other processors",
8960 c     &  (ncont_recv(i),i=1,ntask_cont_from)
8961 c      call flush(iout)
8962 C Receive contacts
8963       ireq=0
8964       do ii=1,ntask_cont_from
8965         iproc=itask_cont_from(ii)
8966         nn=ncont_recv(ii)
8967 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
8968 c     &   " of CONT_TO_COMM group"
8969 c        call flush(iout)
8970         if (nn.gt.0) then
8971           ireq=ireq+1
8972           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
8973      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
8974 c          write (iout,*) "ireq,req",ireq,req(ireq)
8975         endif
8976       enddo
8977 C Send the contacts to processors that need them
8978       do ii=1,ntask_cont_to
8979         iproc=itask_cont_to(ii)
8980         nn=ncont_sent(ii)
8981 c        write (iout,*) nn," contacts to processor",iproc,
8982 c     &   " of CONT_TO_COMM group"
8983         if (nn.gt.0) then
8984           ireq=ireq+1
8985           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
8986      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
8987 c          write (iout,*) "ireq,req",ireq,req(ireq)
8988 c          do i=1,nn
8989 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
8990 c          enddo
8991         endif
8992       enddo
8993 c      write (iout,*) "number of requests (contacts)",ireq
8994 c      write (iout,*) "req",(req(i),i=1,4)
8995 c      call flush(iout)
8996       if (ireq.gt.0)
8997      & call MPI_Waitall(ireq,req,status_array,ierr)
8998       do iii=1,ntask_cont_from
8999         iproc=itask_cont_from(iii)
9000         nn=ncont_recv(iii)
9001         if (lprn) then
9002         write (iout,*) "Received",nn," contacts from processor",iproc,
9003      &   " of CONT_FROM_COMM group"
9004         call flush(iout)
9005         do i=1,nn
9006           write(iout,'(2f5.0,4f10.5)')(zapas_recv(j,i,iii),j=1,5)
9007         enddo
9008         call flush(iout)
9009         endif
9010         do i=1,nn
9011           ii=zapas_recv(1,i,iii)
9012 c Flag the received contacts to prevent double-counting
9013           jj=-zapas_recv(2,i,iii)
9014 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
9015 c          call flush(iout)
9016           nnn=num_cont_hb(ii)+1
9017           num_cont_hb(ii)=nnn
9018           jcont_hb(nnn,ii)=jj
9019           facont_hb(nnn,ii)=zapas_recv(3,i,iii)
9020           ees0p(nnn,ii)=zapas_recv(4,i,iii)
9021           ees0m(nnn,ii)=zapas_recv(5,i,iii)
9022           gacont_hbr(1,nnn,ii)=zapas_recv(6,i,iii)
9023           gacont_hbr(2,nnn,ii)=zapas_recv(7,i,iii)
9024           gacont_hbr(3,nnn,ii)=zapas_recv(8,i,iii)
9025           gacontm_hb1(1,nnn,ii)=zapas_recv(9,i,iii)
9026           gacontm_hb1(2,nnn,ii)=zapas_recv(10,i,iii)
9027           gacontm_hb1(3,nnn,ii)=zapas_recv(11,i,iii)
9028           gacontp_hb1(1,nnn,ii)=zapas_recv(12,i,iii)
9029           gacontp_hb1(2,nnn,ii)=zapas_recv(13,i,iii)
9030           gacontp_hb1(3,nnn,ii)=zapas_recv(14,i,iii)
9031           gacontm_hb2(1,nnn,ii)=zapas_recv(15,i,iii)
9032           gacontm_hb2(2,nnn,ii)=zapas_recv(16,i,iii)
9033           gacontm_hb2(3,nnn,ii)=zapas_recv(17,i,iii)
9034           gacontp_hb2(1,nnn,ii)=zapas_recv(18,i,iii)
9035           gacontp_hb2(2,nnn,ii)=zapas_recv(19,i,iii)
9036           gacontp_hb2(3,nnn,ii)=zapas_recv(20,i,iii)
9037           gacontm_hb3(1,nnn,ii)=zapas_recv(21,i,iii)
9038           gacontm_hb3(2,nnn,ii)=zapas_recv(22,i,iii)
9039           gacontm_hb3(3,nnn,ii)=zapas_recv(23,i,iii)
9040           gacontp_hb3(1,nnn,ii)=zapas_recv(24,i,iii)
9041           gacontp_hb3(2,nnn,ii)=zapas_recv(25,i,iii)
9042           gacontp_hb3(3,nnn,ii)=zapas_recv(26,i,iii)
9043         enddo
9044       enddo
9045       if (lprn) then
9046         write (iout,'(a)') 'Contact function values after receive:'
9047         do i=nnt,nct-2
9048           write (iout,'(2i3,50(1x,i3,f5.2))')
9049      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
9050      &    j=1,num_cont_hb(i))
9051         enddo
9052         call flush(iout)
9053       endif
9054    30 continue
9055 #endif
9056       if (lprn) then
9057         write (iout,'(a)') 'Contact function values:'
9058         do i=nnt,nct-2
9059           write (iout,'(2i3,50(1x,i3,f5.2))')
9060      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
9061      &    j=1,num_cont_hb(i))
9062         enddo
9063         call flush(iout)
9064       endif
9065       ecorr=0.0D0
9066 C Remove the loop below after debugging !!!
9067       do i=nnt,nct
9068         do j=1,3
9069           gradcorr(j,i)=0.0D0
9070           gradxorr(j,i)=0.0D0
9071         enddo
9072       enddo
9073 C Calculate the local-electrostatic correlation terms
9074       do i=min0(iatel_s,iturn4_start),max0(iatel_e,iturn3_end)
9075         i1=i+1
9076         num_conti=num_cont_hb(i)
9077         num_conti1=num_cont_hb(i+1)
9078         do jj=1,num_conti
9079           j=jcont_hb(jj,i)
9080           jp=iabs(j)
9081           do kk=1,num_conti1
9082             j1=jcont_hb(kk,i1)
9083             jp1=iabs(j1)
9084 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
9085 c     &         ' jj=',jj,' kk=',kk
9086 c            call flush(iout)
9087             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
9088      &          .or. j.lt.0 .and. j1.gt.0) .and.
9089      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
9090 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
9091 C The system gains extra energy.
9092               ecorr=ecorr+ehbcorr(i,jp,i+1,jp1,jj,kk,0.72D0,0.32D0)
9093               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
9094      &            'ecorrh',i,j,ehbcorr(i,j,i+1,j1,jj,kk,0.72D0,0.32D0)
9095               n_corr=n_corr+1
9096             else if (j1.eq.j) then
9097 C Contacts I-J and I-(J+1) occur simultaneously.
9098 C The system loses extra energy.
9099 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
9100             endif
9101           enddo ! kk
9102           do kk=1,num_conti
9103             j1=jcont_hb(kk,i)
9104 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
9105 c    &         ' jj=',jj,' kk=',kk
9106             if (j1.eq.j+1) then
9107 C Contacts I-J and (I+1)-J occur simultaneously.
9108 C The system loses extra energy.
9109 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
9110             endif ! j1==j+1
9111           enddo ! kk
9112         enddo ! jj
9113       enddo ! i
9114       return
9115       end
9116 c------------------------------------------------------------------------------
9117       subroutine add_hb_contact(ii,jj,itask)
9118       implicit real*8 (a-h,o-z)
9119       include "DIMENSIONS"
9120       include "COMMON.IOUNITS"
9121       integer max_cont
9122       integer max_dim
9123       parameter (max_cont=maxconts)
9124       parameter (max_dim=26)
9125       include "COMMON.CONTACTS"
9126       double precision zapas(max_dim,maxconts,max_fg_procs),
9127      &  zapas_recv(max_dim,maxconts,max_fg_procs)
9128       common /przechowalnia/ zapas
9129       integer i,j,ii,jj,iproc,itask(4),nn
9130 c      write (iout,*) "itask",itask
9131       do i=1,2
9132         iproc=itask(i)
9133         if (iproc.gt.0) then
9134           do j=1,num_cont_hb(ii)
9135             jjc=jcont_hb(j,ii)
9136 c            write (iout,*) "i",ii," j",jj," jjc",jjc
9137             if (jjc.eq.jj) then
9138               ncont_sent(iproc)=ncont_sent(iproc)+1
9139               nn=ncont_sent(iproc)
9140               zapas(1,nn,iproc)=ii
9141               zapas(2,nn,iproc)=jjc
9142               zapas(3,nn,iproc)=facont_hb(j,ii)
9143               zapas(4,nn,iproc)=ees0p(j,ii)
9144               zapas(5,nn,iproc)=ees0m(j,ii)
9145               zapas(6,nn,iproc)=gacont_hbr(1,j,ii)
9146               zapas(7,nn,iproc)=gacont_hbr(2,j,ii)
9147               zapas(8,nn,iproc)=gacont_hbr(3,j,ii)
9148               zapas(9,nn,iproc)=gacontm_hb1(1,j,ii)
9149               zapas(10,nn,iproc)=gacontm_hb1(2,j,ii)
9150               zapas(11,nn,iproc)=gacontm_hb1(3,j,ii)
9151               zapas(12,nn,iproc)=gacontp_hb1(1,j,ii)
9152               zapas(13,nn,iproc)=gacontp_hb1(2,j,ii)
9153               zapas(14,nn,iproc)=gacontp_hb1(3,j,ii)
9154               zapas(15,nn,iproc)=gacontm_hb2(1,j,ii)
9155               zapas(16,nn,iproc)=gacontm_hb2(2,j,ii)
9156               zapas(17,nn,iproc)=gacontm_hb2(3,j,ii)
9157               zapas(18,nn,iproc)=gacontp_hb2(1,j,ii)
9158               zapas(19,nn,iproc)=gacontp_hb2(2,j,ii)
9159               zapas(20,nn,iproc)=gacontp_hb2(3,j,ii)
9160               zapas(21,nn,iproc)=gacontm_hb3(1,j,ii)
9161               zapas(22,nn,iproc)=gacontm_hb3(2,j,ii)
9162               zapas(23,nn,iproc)=gacontm_hb3(3,j,ii)
9163               zapas(24,nn,iproc)=gacontp_hb3(1,j,ii)
9164               zapas(25,nn,iproc)=gacontp_hb3(2,j,ii)
9165               zapas(26,nn,iproc)=gacontp_hb3(3,j,ii)
9166               exit
9167             endif
9168           enddo
9169         endif
9170       enddo
9171       return
9172       end
9173 c------------------------------------------------------------------------------
9174       subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,
9175      &  n_corr1)
9176 C This subroutine calculates multi-body contributions to hydrogen-bonding
9177       implicit real*8 (a-h,o-z)
9178       include 'DIMENSIONS'
9179       include 'COMMON.IOUNITS'
9180 #ifdef MPI
9181       include "mpif.h"
9182       parameter (max_cont=maxconts)
9183       parameter (max_dim=70)
9184       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
9185       double precision zapas(max_dim,maxconts,max_fg_procs),
9186      &  zapas_recv(max_dim,maxconts,max_fg_procs)
9187       common /przechowalnia/ zapas
9188       integer status(MPI_STATUS_SIZE),req(maxconts*2),
9189      &  status_array(MPI_STATUS_SIZE,maxconts*2)
9190 #endif
9191       include 'COMMON.SETUP'
9192       include 'COMMON.FFIELD'
9193       include 'COMMON.DERIV'
9194       include 'COMMON.LOCAL'
9195       include 'COMMON.INTERACT'
9196       include 'COMMON.CONTACTS'
9197       include 'COMMON.CHAIN'
9198       include 'COMMON.CONTROL'
9199       include 'COMMON.SHIELD'
9200       double precision gx(3),gx1(3)
9201       integer num_cont_hb_old(maxres)
9202       logical lprn,ldone
9203       double precision eello4,eello5,eelo6,eello_turn6
9204       external eello4,eello5,eello6,eello_turn6
9205 C Set lprn=.true. for debugging
9206       lprn=.false.
9207       eturn6=0.0d0
9208 #ifdef MPI
9209       do i=1,nres
9210         num_cont_hb_old(i)=num_cont_hb(i)
9211       enddo
9212       n_corr=0
9213       n_corr1=0
9214       if (nfgtasks.le.1) goto 30
9215       if (lprn) then
9216         write (iout,'(a)') 'Contact function values before RECEIVE:'
9217         do i=nnt,nct-2
9218           write (iout,'(2i3,50(1x,i2,f5.2))')
9219      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
9220      &    j=1,num_cont_hb(i))
9221         enddo
9222       endif
9223       do i=1,ntask_cont_from
9224         ncont_recv(i)=0
9225       enddo
9226       do i=1,ntask_cont_to
9227         ncont_sent(i)=0
9228       enddo
9229 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
9230 c     & ntask_cont_to
9231 C Make the list of contacts to send to send to other procesors
9232       do i=iturn3_start,iturn3_end
9233 c        write (iout,*) "make contact list turn3",i," num_cont",
9234 c     &    num_cont_hb(i)
9235         call add_hb_contact_eello(i,i+2,iturn3_sent_local(1,i))
9236       enddo
9237       do i=iturn4_start,iturn4_end
9238 c        write (iout,*) "make contact list turn4",i," num_cont",
9239 c     &   num_cont_hb(i)
9240         call add_hb_contact_eello(i,i+3,iturn4_sent_local(1,i))
9241       enddo
9242       do ii=1,nat_sent
9243         i=iat_sent(ii)
9244 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
9245 c     &    num_cont_hb(i)
9246         do j=1,num_cont_hb(i)
9247         do k=1,4
9248           jjc=jcont_hb(j,i)
9249           iproc=iint_sent_local(k,jjc,ii)
9250 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
9251           if (iproc.ne.0) then
9252             ncont_sent(iproc)=ncont_sent(iproc)+1
9253             nn=ncont_sent(iproc)
9254             zapas(1,nn,iproc)=i
9255             zapas(2,nn,iproc)=jjc
9256             zapas(3,nn,iproc)=d_cont(j,i)
9257             ind=3
9258             do kk=1,3
9259               ind=ind+1
9260               zapas(ind,nn,iproc)=grij_hb_cont(kk,j,i)
9261             enddo
9262             do kk=1,2
9263               do ll=1,2
9264                 ind=ind+1
9265                 zapas(ind,nn,iproc)=a_chuj(ll,kk,j,i)
9266               enddo
9267             enddo
9268             do jj=1,5
9269               do kk=1,3
9270                 do ll=1,2
9271                   do mm=1,2
9272                     ind=ind+1
9273                     zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,i)
9274                   enddo
9275                 enddo
9276               enddo
9277             enddo
9278           endif
9279         enddo
9280         enddo
9281       enddo
9282       if (lprn) then
9283       write (iout,*)
9284      &  "Numbers of contacts to be sent to other processors",
9285      &  (ncont_sent(i),i=1,ntask_cont_to)
9286       write (iout,*) "Contacts sent"
9287       do ii=1,ntask_cont_to
9288         nn=ncont_sent(ii)
9289         iproc=itask_cont_to(ii)
9290         write (iout,*) nn," contacts to processor",iproc,
9291      &   " of CONT_TO_COMM group"
9292         do i=1,nn
9293           write(iout,'(2f5.0,10f10.5)')(zapas(j,i,ii),j=1,10)
9294         enddo
9295       enddo
9296       call flush(iout)
9297       endif
9298       CorrelType=477
9299       CorrelID=fg_rank+1
9300       CorrelType1=478
9301       CorrelID1=nfgtasks+fg_rank+1
9302       ireq=0
9303 C Receive the numbers of needed contacts from other processors
9304       do ii=1,ntask_cont_from
9305         iproc=itask_cont_from(ii)
9306         ireq=ireq+1
9307         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
9308      &    FG_COMM,req(ireq),IERR)
9309       enddo
9310 c      write (iout,*) "IRECV ended"
9311 c      call flush(iout)
9312 C Send the number of contacts needed by other processors
9313       do ii=1,ntask_cont_to
9314         iproc=itask_cont_to(ii)
9315         ireq=ireq+1
9316         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
9317      &    FG_COMM,req(ireq),IERR)
9318       enddo
9319 c      write (iout,*) "ISEND ended"
9320 c      write (iout,*) "number of requests (nn)",ireq
9321 c      call flush(iout)
9322       if (ireq.gt.0)
9323      &  call MPI_Waitall(ireq,req,status_array,ierr)
9324 c      write (iout,*)
9325 c     &  "Numbers of contacts to be received from other processors",
9326 c     &  (ncont_recv(i),i=1,ntask_cont_from)
9327 c      call flush(iout)
9328 C Receive contacts
9329       ireq=0
9330       do ii=1,ntask_cont_from
9331         iproc=itask_cont_from(ii)
9332         nn=ncont_recv(ii)
9333 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
9334 c     &   " of CONT_TO_COMM group"
9335 c        call flush(iout)
9336         if (nn.gt.0) then
9337           ireq=ireq+1
9338           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
9339      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
9340 c          write (iout,*) "ireq,req",ireq,req(ireq)
9341         endif
9342       enddo
9343 C Send the contacts to processors that need them
9344       do ii=1,ntask_cont_to
9345         iproc=itask_cont_to(ii)
9346         nn=ncont_sent(ii)
9347 c        write (iout,*) nn," contacts to processor",iproc,
9348 c     &   " of CONT_TO_COMM group"
9349         if (nn.gt.0) then
9350           ireq=ireq+1
9351           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
9352      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
9353 c          write (iout,*) "ireq,req",ireq,req(ireq)
9354 c          do i=1,nn
9355 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
9356 c          enddo
9357         endif
9358       enddo
9359 c      write (iout,*) "number of requests (contacts)",ireq
9360 c      write (iout,*) "req",(req(i),i=1,4)
9361 c      call flush(iout)
9362       if (ireq.gt.0)
9363      & call MPI_Waitall(ireq,req,status_array,ierr)
9364       do iii=1,ntask_cont_from
9365         iproc=itask_cont_from(iii)
9366         nn=ncont_recv(iii)
9367         if (lprn) then
9368         write (iout,*) "Received",nn," contacts from processor",iproc,
9369      &   " of CONT_FROM_COMM group"
9370         call flush(iout)
9371         do i=1,nn
9372           write(iout,'(2f5.0,10f10.5)')(zapas_recv(j,i,iii),j=1,10)
9373         enddo
9374         call flush(iout)
9375         endif
9376         do i=1,nn
9377           ii=zapas_recv(1,i,iii)
9378 c Flag the received contacts to prevent double-counting
9379           jj=-zapas_recv(2,i,iii)
9380 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
9381 c          call flush(iout)
9382           nnn=num_cont_hb(ii)+1
9383           num_cont_hb(ii)=nnn
9384           jcont_hb(nnn,ii)=jj
9385           d_cont(nnn,ii)=zapas_recv(3,i,iii)
9386           ind=3
9387           do kk=1,3
9388             ind=ind+1
9389             grij_hb_cont(kk,nnn,ii)=zapas_recv(ind,i,iii)
9390           enddo
9391           do kk=1,2
9392             do ll=1,2
9393               ind=ind+1
9394               a_chuj(ll,kk,nnn,ii)=zapas_recv(ind,i,iii)
9395             enddo
9396           enddo
9397           do jj=1,5
9398             do kk=1,3
9399               do ll=1,2
9400                 do mm=1,2
9401                   ind=ind+1
9402                   a_chuj_der(mm,ll,kk,jj,nnn,ii)=zapas_recv(ind,i,iii)
9403                 enddo
9404               enddo
9405             enddo
9406           enddo
9407         enddo
9408       enddo
9409       if (lprn) then
9410         write (iout,'(a)') 'Contact function values after receive:'
9411         do i=nnt,nct-2
9412           write (iout,'(2i3,50(1x,i3,5f6.3))')
9413      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
9414      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
9415         enddo
9416         call flush(iout)
9417       endif
9418    30 continue
9419 #endif
9420       if (lprn) then
9421         write (iout,'(a)') 'Contact function values:'
9422         do i=nnt,nct-2
9423           write (iout,'(2i3,50(1x,i2,5f6.3))')
9424      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
9425      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
9426         enddo
9427       endif
9428       ecorr=0.0D0
9429       ecorr5=0.0d0
9430       ecorr6=0.0d0
9431 C Remove the loop below after debugging !!!
9432       do i=nnt,nct
9433         do j=1,3
9434           gradcorr(j,i)=0.0D0
9435           gradxorr(j,i)=0.0D0
9436         enddo
9437       enddo
9438 C Calculate the dipole-dipole interaction energies
9439       if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
9440       do i=iatel_s,iatel_e+1
9441         num_conti=num_cont_hb(i)
9442         do jj=1,num_conti
9443           j=jcont_hb(jj,i)
9444 #ifdef MOMENT
9445           call dipole(i,j,jj)
9446 #endif
9447         enddo
9448       enddo
9449       endif
9450 C Calculate the local-electrostatic correlation terms
9451 c                write (iout,*) "gradcorr5 in eello5 before loop"
9452 c                do iii=1,nres
9453 c                  write (iout,'(i5,3f10.5)')
9454 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
9455 c                enddo
9456       do i=min0(iatel_s,iturn4_start),max0(iatel_e+1,iturn3_end+1)
9457 c        write (iout,*) "corr loop i",i
9458         i1=i+1
9459         num_conti=num_cont_hb(i)
9460         num_conti1=num_cont_hb(i+1)
9461         do jj=1,num_conti
9462           j=jcont_hb(jj,i)
9463           jp=iabs(j)
9464           do kk=1,num_conti1
9465             j1=jcont_hb(kk,i1)
9466             jp1=iabs(j1)
9467 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
9468 c     &         ' jj=',jj,' kk=',kk
9469 c            if (j1.eq.j+1 .or. j1.eq.j-1) then
9470             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
9471      &          .or. j.lt.0 .and. j1.gt.0) .and.
9472      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
9473 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
9474 C The system gains extra energy.
9475               n_corr=n_corr+1
9476               sqd1=dsqrt(d_cont(jj,i))
9477               sqd2=dsqrt(d_cont(kk,i1))
9478               sred_geom = sqd1*sqd2
9479               IF (sred_geom.lt.cutoff_corr) THEN
9480                 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,
9481      &            ekont,fprimcont)
9482 cd               write (iout,*) 'i=',i,' j=',jp,' i1=',i1,' j1=',jp1,
9483 cd     &         ' jj=',jj,' kk=',kk
9484                 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
9485                 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
9486                 do l=1,3
9487                   g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
9488                   g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
9489                 enddo
9490                 n_corr1=n_corr1+1
9491 cd               write (iout,*) 'sred_geom=',sred_geom,
9492 cd     &          ' ekont=',ekont,' fprim=',fprimcont,
9493 cd     &          ' fac_prim1',fac_prim1,' fac_prim2',fac_prim2
9494 cd               write (iout,*) "g_contij",g_contij
9495 cd               write (iout,*) "grij_hb_cont i",grij_hb_cont(:,jj,i)
9496 cd               write (iout,*) "grij_hb_cont i1",grij_hb_cont(:,jj,i1)
9497                 call calc_eello(i,jp,i+1,jp1,jj,kk)
9498                 if (wcorr4.gt.0.0d0)
9499      &            ecorr=ecorr+eello4(i,jp,i+1,jp1,jj,kk)
9500 CC     &            *fac_shield(i)**2*fac_shield(j)**2
9501                   if (energy_dec.and.wcorr4.gt.0.0d0)
9502      1                 write (iout,'(a6,4i5,0pf7.3)')
9503      2                'ecorr4',i,j,i+1,j1,eello4(i,jp,i+1,jp1,jj,kk)
9504 c                write (iout,*) "gradcorr5 before eello5"
9505 c                do iii=1,nres
9506 c                  write (iout,'(i5,3f10.5)')
9507 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
9508 c                enddo
9509                 if (wcorr5.gt.0.0d0)
9510      &            ecorr5=ecorr5+eello5(i,jp,i+1,jp1,jj,kk)
9511 c                write (iout,*) "gradcorr5 after eello5"
9512 c                do iii=1,nres
9513 c                  write (iout,'(i5,3f10.5)')
9514 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
9515 c                enddo
9516                   if (energy_dec.and.wcorr5.gt.0.0d0)
9517      1                 write (iout,'(a6,4i5,0pf7.3)')
9518      2                'ecorr5',i,j,i+1,j1,eello5(i,jp,i+1,jp1,jj,kk)
9519 cd                write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
9520 cd                write(2,*)'ijkl',i,jp,i+1,jp1
9521                 if (wcorr6.gt.0.0d0 .and. (jp.ne.i+4 .or. jp1.ne.i+3
9522      &               .or. wturn6.eq.0.0d0))then
9523 cd                  write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
9524                   ecorr6=ecorr6+eello6(i,jp,i+1,jp1,jj,kk)
9525                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
9526      1                'ecorr6',i,j,i+1,j1,eello6(i,jp,i+1,jp1,jj,kk)
9527 cd                write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
9528 cd     &            'ecorr6=',ecorr6
9529 cd                write (iout,'(4e15.5)') sred_geom,
9530 cd     &          dabs(eello4(i,jp,i+1,jp1,jj,kk)),
9531 cd     &          dabs(eello5(i,jp,i+1,jp1,jj,kk)),
9532 cd     &          dabs(eello6(i,jp,i+1,jp1,jj,kk))
9533                 else if (wturn6.gt.0.0d0
9534      &            .and. (jp.eq.i+4 .and. jp1.eq.i+3)) then
9535 cd                  write (iout,*) '******eturn6: i,j,i+1,j1',i,jip,i+1,jp1
9536                   eturn6=eturn6+eello_turn6(i,jj,kk)
9537                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
9538      1                 'eturn6',i,j,i+1,j1,eello_turn6(i,jj,kk)
9539 cd                  write (2,*) 'multibody_eello:eturn6',eturn6
9540                 endif
9541               ENDIF
9542 1111          continue
9543             endif
9544           enddo ! kk
9545         enddo ! jj
9546       enddo ! i
9547       do i=1,nres
9548         num_cont_hb(i)=num_cont_hb_old(i)
9549       enddo
9550 c                write (iout,*) "gradcorr5 in eello5"
9551 c                do iii=1,nres
9552 c                  write (iout,'(i5,3f10.5)')
9553 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
9554 c                enddo
9555       return
9556       end
9557 c------------------------------------------------------------------------------
9558       subroutine add_hb_contact_eello(ii,jj,itask)
9559       implicit real*8 (a-h,o-z)
9560       include "DIMENSIONS"
9561       include "COMMON.IOUNITS"
9562       integer max_cont
9563       integer max_dim
9564       parameter (max_cont=maxconts)
9565       parameter (max_dim=70)
9566       include "COMMON.CONTACTS"
9567       double precision zapas(max_dim,maxconts,max_fg_procs),
9568      &  zapas_recv(max_dim,maxconts,max_fg_procs)
9569       common /przechowalnia/ zapas
9570       integer i,j,ii,jj,iproc,itask(4),nn
9571 c      write (iout,*) "itask",itask
9572       do i=1,2
9573         iproc=itask(i)
9574         if (iproc.gt.0) then
9575           do j=1,num_cont_hb(ii)
9576             jjc=jcont_hb(j,ii)
9577 c            write (iout,*) "send turns i",ii," j",jj," jjc",jjc
9578             if (jjc.eq.jj) then
9579               ncont_sent(iproc)=ncont_sent(iproc)+1
9580               nn=ncont_sent(iproc)
9581               zapas(1,nn,iproc)=ii
9582               zapas(2,nn,iproc)=jjc
9583               zapas(3,nn,iproc)=d_cont(j,ii)
9584               ind=3
9585               do kk=1,3
9586                 ind=ind+1
9587                 zapas(ind,nn,iproc)=grij_hb_cont(kk,j,ii)
9588               enddo
9589               do kk=1,2
9590                 do ll=1,2
9591                   ind=ind+1
9592                   zapas(ind,nn,iproc)=a_chuj(ll,kk,j,ii)
9593                 enddo
9594               enddo
9595               do jj=1,5
9596                 do kk=1,3
9597                   do ll=1,2
9598                     do mm=1,2
9599                       ind=ind+1
9600                       zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,ii)
9601                     enddo
9602                   enddo
9603                 enddo
9604               enddo
9605               exit
9606             endif
9607           enddo
9608         endif
9609       enddo
9610       return
9611       end
9612 c------------------------------------------------------------------------------
9613       double precision function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
9614       implicit real*8 (a-h,o-z)
9615       include 'DIMENSIONS'
9616       include 'COMMON.IOUNITS'
9617       include 'COMMON.DERIV'
9618       include 'COMMON.INTERACT'
9619       include 'COMMON.CONTACTS'
9620       include 'COMMON.SHIELD'
9621       include 'COMMON.CONTROL'
9622       double precision gx(3),gx1(3)
9623       logical lprn
9624       lprn=.false.
9625 C      print *,"wchodze",fac_shield(i),shield_mode
9626       eij=facont_hb(jj,i)
9627       ekl=facont_hb(kk,k)
9628       ees0pij=ees0p(jj,i)
9629       ees0pkl=ees0p(kk,k)
9630       ees0mij=ees0m(jj,i)
9631       ees0mkl=ees0m(kk,k)
9632       ekont=eij*ekl
9633       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
9634 C*
9635 C     & fac_shield(i)**2*fac_shield(j)**2
9636 cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
9637 C Following 4 lines for diagnostics.
9638 cd    ees0pkl=0.0D0
9639 cd    ees0pij=1.0D0
9640 cd    ees0mkl=0.0D0
9641 cd    ees0mij=1.0D0
9642 c      write (iout,'(2(a,2i3,a,f10.5,a,2f10.5),a,f10.5,a,$)')
9643 c     & 'Contacts ',i,j,
9644 c     & ' eij',eij,' eesij',ees0pij,ees0mij,' and ',k,l
9645 c     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' energy=',ekont*ees,
9646 c     & 'gradcorr_long'
9647 C Calculate the multi-body contribution to energy.
9648 C      ecorr=ecorr+ekont*ees
9649 C Calculate multi-body contributions to the gradient.
9650       coeffpees0pij=coeffp*ees0pij
9651       coeffmees0mij=coeffm*ees0mij
9652       coeffpees0pkl=coeffp*ees0pkl
9653       coeffmees0mkl=coeffm*ees0mkl
9654       do ll=1,3
9655 cgrad        ghalfi=ees*ekl*gacont_hbr(ll,jj,i)
9656         gradcorr(ll,i)=gradcorr(ll,i)!+0.5d0*ghalfi
9657      &  -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+
9658      &  coeffmees0mkl*gacontm_hb1(ll,jj,i))
9659         gradcorr(ll,j)=gradcorr(ll,j)!+0.5d0*ghalfi
9660      &  -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+
9661      &  coeffmees0mkl*gacontm_hb2(ll,jj,i))
9662 cgrad        ghalfk=ees*eij*gacont_hbr(ll,kk,k)
9663         gradcorr(ll,k)=gradcorr(ll,k)!+0.5d0*ghalfk
9664      &  -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+
9665      &  coeffmees0mij*gacontm_hb1(ll,kk,k))
9666         gradcorr(ll,l)=gradcorr(ll,l)!+0.5d0*ghalfk
9667      &  -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+
9668      &  coeffmees0mij*gacontm_hb2(ll,kk,k))
9669         gradlongij=ees*ekl*gacont_hbr(ll,jj,i)-
9670      &     ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+
9671      &     coeffmees0mkl*gacontm_hb3(ll,jj,i))
9672         gradcorr_long(ll,j)=gradcorr_long(ll,j)+gradlongij
9673         gradcorr_long(ll,i)=gradcorr_long(ll,i)-gradlongij
9674         gradlongkl=ees*eij*gacont_hbr(ll,kk,k)-
9675      &     ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+
9676      &     coeffmees0mij*gacontm_hb3(ll,kk,k))
9677         gradcorr_long(ll,l)=gradcorr_long(ll,l)+gradlongkl
9678         gradcorr_long(ll,k)=gradcorr_long(ll,k)-gradlongkl
9679 c        write (iout,'(2f10.5,2x,$)') gradlongij,gradlongkl
9680       enddo
9681 c      write (iout,*)
9682 cgrad      do m=i+1,j-1
9683 cgrad        do ll=1,3
9684 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
9685 cgrad     &     ees*ekl*gacont_hbr(ll,jj,i)-
9686 cgrad     &     ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
9687 cgrad     &     coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
9688 cgrad        enddo
9689 cgrad      enddo
9690 cgrad      do m=k+1,l-1
9691 cgrad        do ll=1,3
9692 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
9693 cgrad     &     ees*eij*gacont_hbr(ll,kk,k)-
9694 cgrad     &     ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
9695 cgrad     &     coeffm*ees0mij*gacontm_hb3(ll,kk,k))
9696 cgrad        enddo
9697 cgrad      enddo
9698 c      write (iout,*) "ehbcorr",ekont*ees
9699 C      print *,ekont,ees,i,k
9700       ehbcorr=ekont*ees
9701 C now gradient over shielding
9702 C      return
9703       if (shield_mode.gt.0) then
9704        j=ees0plist(jj,i)
9705        l=ees0plist(kk,k)
9706 C        print *,i,j,fac_shield(i),fac_shield(j),
9707 C     &fac_shield(k),fac_shield(l)
9708         if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
9709      &      (fac_shield(k).gt.0).and.(fac_shield(l).gt.0)) then
9710           do ilist=1,ishield_list(i)
9711            iresshield=shield_list(ilist,i)
9712            do m=1,3
9713            rlocshield=grad_shield_side(m,ilist,i)*ehbcorr/fac_shield(i)
9714 C     &      *2.0
9715            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
9716      &              rlocshield
9717      & +grad_shield_loc(m,ilist,i)*ehbcorr/fac_shield(i)
9718             gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
9719      &+rlocshield
9720            enddo
9721           enddo
9722           do ilist=1,ishield_list(j)
9723            iresshield=shield_list(ilist,j)
9724            do m=1,3
9725            rlocshield=grad_shield_side(m,ilist,j)*ehbcorr/fac_shield(j)
9726 C     &     *2.0
9727            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
9728      &              rlocshield
9729      & +grad_shield_loc(m,ilist,j)*ehbcorr/fac_shield(j)
9730            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
9731      &     +rlocshield
9732            enddo
9733           enddo
9734
9735           do ilist=1,ishield_list(k)
9736            iresshield=shield_list(ilist,k)
9737            do m=1,3
9738            rlocshield=grad_shield_side(m,ilist,k)*ehbcorr/fac_shield(k)
9739 C     &     *2.0
9740            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
9741      &              rlocshield
9742      & +grad_shield_loc(m,ilist,k)*ehbcorr/fac_shield(k)
9743            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
9744      &     +rlocshield
9745            enddo
9746           enddo
9747           do ilist=1,ishield_list(l)
9748            iresshield=shield_list(ilist,l)
9749            do m=1,3
9750            rlocshield=grad_shield_side(m,ilist,l)*ehbcorr/fac_shield(l)
9751 C     &     *2.0
9752            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
9753      &              rlocshield
9754      & +grad_shield_loc(m,ilist,l)*ehbcorr/fac_shield(l)
9755            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
9756      &     +rlocshield
9757            enddo
9758           enddo
9759 C          print *,gshieldx(m,iresshield)
9760           do m=1,3
9761             gshieldc_ec(m,i)=gshieldc_ec(m,i)+
9762      &              grad_shield(m,i)*ehbcorr/fac_shield(i)
9763             gshieldc_ec(m,j)=gshieldc_ec(m,j)+
9764      &              grad_shield(m,j)*ehbcorr/fac_shield(j)
9765             gshieldc_ec(m,i-1)=gshieldc_ec(m,i-1)+
9766      &              grad_shield(m,i)*ehbcorr/fac_shield(i)
9767             gshieldc_ec(m,j-1)=gshieldc_ec(m,j-1)+
9768      &              grad_shield(m,j)*ehbcorr/fac_shield(j)
9769
9770             gshieldc_ec(m,k)=gshieldc_ec(m,k)+
9771      &              grad_shield(m,k)*ehbcorr/fac_shield(k)
9772             gshieldc_ec(m,l)=gshieldc_ec(m,l)+
9773      &              grad_shield(m,l)*ehbcorr/fac_shield(l)
9774             gshieldc_ec(m,k-1)=gshieldc_ec(m,k-1)+
9775      &              grad_shield(m,k)*ehbcorr/fac_shield(k)
9776             gshieldc_ec(m,l-1)=gshieldc_ec(m,l-1)+
9777      &              grad_shield(m,l)*ehbcorr/fac_shield(l)
9778
9779            enddo
9780       endif
9781       endif
9782       return
9783       end
9784 #ifdef MOMENT
9785 C---------------------------------------------------------------------------
9786       subroutine dipole(i,j,jj)
9787       implicit real*8 (a-h,o-z)
9788       include 'DIMENSIONS'
9789       include 'COMMON.IOUNITS'
9790       include 'COMMON.CHAIN'
9791       include 'COMMON.FFIELD'
9792       include 'COMMON.DERIV'
9793       include 'COMMON.INTERACT'
9794       include 'COMMON.CONTACTS'
9795       include 'COMMON.TORSION'
9796       include 'COMMON.VAR'
9797       include 'COMMON.GEO'
9798       dimension dipi(2,2),dipj(2,2),dipderi(2),dipderj(2),auxvec(2),
9799      &  auxmat(2,2)
9800       iti1 = itortyp(itype(i+1))
9801       if (j.lt.nres-1) then
9802         itj1 = itype2loc(itype(j+1))
9803       else
9804         itj1=nloctyp
9805       endif
9806       do iii=1,2
9807         dipi(iii,1)=Ub2(iii,i)
9808         dipderi(iii)=Ub2der(iii,i)
9809         dipi(iii,2)=b1(iii,i+1)
9810         dipj(iii,1)=Ub2(iii,j)
9811         dipderj(iii)=Ub2der(iii,j)
9812         dipj(iii,2)=b1(iii,j+1)
9813       enddo
9814       kkk=0
9815       do iii=1,2
9816         call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
9817         do jjj=1,2
9818           kkk=kkk+1
9819           dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
9820         enddo
9821       enddo
9822       do kkk=1,5
9823         do lll=1,3
9824           mmm=0
9825           do iii=1,2
9826             call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),
9827      &        auxvec(1))
9828             do jjj=1,2
9829               mmm=mmm+1
9830               dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
9831             enddo
9832           enddo
9833         enddo
9834       enddo
9835       call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
9836       call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
9837       do iii=1,2
9838         dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
9839       enddo
9840       call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
9841       do iii=1,2
9842         dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
9843       enddo
9844       return
9845       end
9846 #endif
9847 C---------------------------------------------------------------------------
9848       subroutine calc_eello(i,j,k,l,jj,kk)
9849 C
9850 C This subroutine computes matrices and vectors needed to calculate
9851 C the fourth-, fifth-, and sixth-order local-electrostatic terms.
9852 C
9853       implicit real*8 (a-h,o-z)
9854       include 'DIMENSIONS'
9855       include 'COMMON.IOUNITS'
9856       include 'COMMON.CHAIN'
9857       include 'COMMON.DERIV'
9858       include 'COMMON.INTERACT'
9859       include 'COMMON.CONTACTS'
9860       include 'COMMON.TORSION'
9861       include 'COMMON.VAR'
9862       include 'COMMON.GEO'
9863       include 'COMMON.FFIELD'
9864       double precision aa1(2,2),aa2(2,2),aa1t(2,2),aa2t(2,2),
9865      &  aa1tder(2,2,3,5),aa2tder(2,2,3,5),auxmat(2,2)
9866       logical lprn
9867       common /kutas/ lprn
9868 cd      write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
9869 cd     & ' jj=',jj,' kk=',kk
9870 cd      if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
9871 cd      write (iout,*) "a_chujij",((a_chuj(iii,jjj,jj,i),iii=1,2),jjj=1,2)
9872 cd      write (iout,*) "a_chujkl",((a_chuj(iii,jjj,kk,k),iii=1,2),jjj=1,2)
9873       do iii=1,2
9874         do jjj=1,2
9875           aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
9876           aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
9877         enddo
9878       enddo
9879       call transpose2(aa1(1,1),aa1t(1,1))
9880       call transpose2(aa2(1,1),aa2t(1,1))
9881       do kkk=1,5
9882         do lll=1,3
9883           call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),
9884      &      aa1tder(1,1,lll,kkk))
9885           call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),
9886      &      aa2tder(1,1,lll,kkk))
9887         enddo
9888       enddo
9889       if (l.eq.j+1) then
9890 C parallel orientation of the two CA-CA-CA frames.
9891         if (i.gt.1) then
9892           iti=itype2loc(itype(i))
9893         else
9894           iti=nloctyp
9895         endif
9896         itk1=itype2loc(itype(k+1))
9897         itj=itype2loc(itype(j))
9898         if (l.lt.nres-1) then
9899           itl1=itype2loc(itype(l+1))
9900         else
9901           itl1=nloctyp
9902         endif
9903 C A1 kernel(j+1) A2T
9904 cd        do iii=1,2
9905 cd          write (iout,'(3f10.5,5x,3f10.5)')
9906 cd     &     (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
9907 cd        enddo
9908         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9909      &   aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),
9910      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
9911 C Following matrices are needed only for 6-th order cumulants
9912         IF (wcorr6.gt.0.0d0) THEN
9913         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9914      &   aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),
9915      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
9916         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9917      &   aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),
9918      &   Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
9919      &   ADtEAderx(1,1,1,1,1,1))
9920         lprn=.false.
9921         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9922      &   aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),
9923      &   DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
9924      &   ADtEA1derx(1,1,1,1,1,1))
9925         ENDIF
9926 C End 6-th order cumulants
9927 cd        lprn=.false.
9928 cd        if (lprn) then
9929 cd        write (2,*) 'In calc_eello6'
9930 cd        do iii=1,2
9931 cd          write (2,*) 'iii=',iii
9932 cd          do kkk=1,5
9933 cd            write (2,*) 'kkk=',kkk
9934 cd            do jjj=1,2
9935 cd              write (2,'(3(2f10.5),5x)')
9936 cd     &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
9937 cd            enddo
9938 cd          enddo
9939 cd        enddo
9940 cd        endif
9941         call transpose2(EUgder(1,1,k),auxmat(1,1))
9942         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
9943         call transpose2(EUg(1,1,k),auxmat(1,1))
9944         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
9945         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
9946 C AL 4/16/16: Derivatives of the quantitied related to matrices C, D, and E
9947 c    in theta; to be sriten later.
9948 c#ifdef NEWCORR
9949 c        call transpose2(gtEE(1,1,k),auxmat(1,1))
9950 c        call matmat2(auxmat(1,1),AEA(1,1,1),EAEAdert(1,1,1,1))
9951 c        call transpose2(EUg(1,1,k),auxmat(1,1))
9952 c        call matmat2(auxmat(1,1),AEAdert(1,1,1),EAEAdert(1,1,2,1))
9953 c#endif
9954         do iii=1,2
9955           do kkk=1,5
9956             do lll=1,3
9957               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
9958      &          EAEAderx(1,1,lll,kkk,iii,1))
9959             enddo
9960           enddo
9961         enddo
9962 C A1T kernel(i+1) A2
9963         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
9964      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),
9965      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
9966 C Following matrices are needed only for 6-th order cumulants
9967         IF (wcorr6.gt.0.0d0) THEN
9968         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
9969      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),
9970      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
9971         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
9972      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),
9973      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
9974      &   ADtEAderx(1,1,1,1,1,2))
9975         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
9976      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),
9977      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
9978      &   ADtEA1derx(1,1,1,1,1,2))
9979         ENDIF
9980 C End 6-th order cumulants
9981         call transpose2(EUgder(1,1,l),auxmat(1,1))
9982         call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
9983         call transpose2(EUg(1,1,l),auxmat(1,1))
9984         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
9985         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
9986         do iii=1,2
9987           do kkk=1,5
9988             do lll=1,3
9989               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
9990      &          EAEAderx(1,1,lll,kkk,iii,2))
9991             enddo
9992           enddo
9993         enddo
9994 C AEAb1 and AEAb2
9995 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
9996 C They are needed only when the fifth- or the sixth-order cumulants are
9997 C indluded.
9998         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
9999         call transpose2(AEA(1,1,1),auxmat(1,1))
10000         call matvec2(auxmat(1,1),b1(1,i),AEAb1(1,1,1))
10001         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
10002         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
10003         call transpose2(AEAderg(1,1,1),auxmat(1,1))
10004         call matvec2(auxmat(1,1),b1(1,i),AEAb1derg(1,1,1))
10005         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
10006         call matvec2(AEA(1,1,1),b1(1,k+1),AEAb1(1,2,1))
10007         call matvec2(AEAderg(1,1,1),b1(1,k+1),AEAb1derg(1,2,1))
10008         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
10009         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
10010         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
10011         call transpose2(AEA(1,1,2),auxmat(1,1))
10012         call matvec2(auxmat(1,1),b1(1,j),AEAb1(1,1,2))
10013         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
10014         call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
10015         call transpose2(AEAderg(1,1,2),auxmat(1,1))
10016         call matvec2(auxmat(1,1),b1(1,j),AEAb1derg(1,1,2))
10017         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
10018         call matvec2(AEA(1,1,2),b1(1,l+1),AEAb1(1,2,2))
10019         call matvec2(AEAderg(1,1,2),b1(1,l+1),AEAb1derg(1,2,2))
10020         call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
10021         call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
10022         call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
10023 C Calculate the Cartesian derivatives of the vectors.
10024         do iii=1,2
10025           do kkk=1,5
10026             do lll=1,3
10027               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
10028               call matvec2(auxmat(1,1),b1(1,i),
10029      &          AEAb1derx(1,lll,kkk,iii,1,1))
10030               call matvec2(auxmat(1,1),Ub2(1,i),
10031      &          AEAb2derx(1,lll,kkk,iii,1,1))
10032               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
10033      &          AEAb1derx(1,lll,kkk,iii,2,1))
10034               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
10035      &          AEAb2derx(1,lll,kkk,iii,2,1))
10036               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
10037               call matvec2(auxmat(1,1),b1(1,j),
10038      &          AEAb1derx(1,lll,kkk,iii,1,2))
10039               call matvec2(auxmat(1,1),Ub2(1,j),
10040      &          AEAb2derx(1,lll,kkk,iii,1,2))
10041               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,l+1),
10042      &          AEAb1derx(1,lll,kkk,iii,2,2))
10043               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),
10044      &          AEAb2derx(1,lll,kkk,iii,2,2))
10045             enddo
10046           enddo
10047         enddo
10048         ENDIF
10049 C End vectors
10050       else
10051 C Antiparallel orientation of the two CA-CA-CA frames.
10052         if (i.gt.1) then
10053           iti=itype2loc(itype(i))
10054         else
10055           iti=nloctyp
10056         endif
10057         itk1=itype2loc(itype(k+1))
10058         itl=itype2loc(itype(l))
10059         itj=itype2loc(itype(j))
10060         if (j.lt.nres-1) then
10061           itj1=itype2loc(itype(j+1))
10062         else
10063           itj1=nloctyp
10064         endif
10065 C A2 kernel(j-1)T A1T
10066         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
10067      &   aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),
10068      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
10069 C Following matrices are needed only for 6-th order cumulants
10070         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
10071      &     j.eq.i+4 .and. l.eq.i+3)) THEN
10072         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
10073      &   aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),
10074      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
10075         call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
10076      &   aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),
10077      &   Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
10078      &   ADtEAderx(1,1,1,1,1,1))
10079         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
10080      &   aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),
10081      &   DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
10082      &   ADtEA1derx(1,1,1,1,1,1))
10083         ENDIF
10084 C End 6-th order cumulants
10085         call transpose2(EUgder(1,1,k),auxmat(1,1))
10086         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
10087         call transpose2(EUg(1,1,k),auxmat(1,1))
10088         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
10089         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
10090         do iii=1,2
10091           do kkk=1,5
10092             do lll=1,3
10093               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
10094      &          EAEAderx(1,1,lll,kkk,iii,1))
10095             enddo
10096           enddo
10097         enddo
10098 C A2T kernel(i+1)T A1
10099         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
10100      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),
10101      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
10102 C Following matrices are needed only for 6-th order cumulants
10103         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
10104      &     j.eq.i+4 .and. l.eq.i+3)) THEN
10105         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
10106      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),
10107      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
10108         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
10109      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),
10110      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
10111      &   ADtEAderx(1,1,1,1,1,2))
10112         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
10113      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),
10114      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
10115      &   ADtEA1derx(1,1,1,1,1,2))
10116         ENDIF
10117 C End 6-th order cumulants
10118         call transpose2(EUgder(1,1,j),auxmat(1,1))
10119         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
10120         call transpose2(EUg(1,1,j),auxmat(1,1))
10121         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
10122         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
10123         do iii=1,2
10124           do kkk=1,5
10125             do lll=1,3
10126               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
10127      &          EAEAderx(1,1,lll,kkk,iii,2))
10128             enddo
10129           enddo
10130         enddo
10131 C AEAb1 and AEAb2
10132 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
10133 C They are needed only when the fifth- or the sixth-order cumulants are
10134 C indluded.
10135         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or.
10136      &    (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
10137         call transpose2(AEA(1,1,1),auxmat(1,1))
10138         call matvec2(auxmat(1,1),b1(1,i),AEAb1(1,1,1))
10139         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
10140         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
10141         call transpose2(AEAderg(1,1,1),auxmat(1,1))
10142         call matvec2(auxmat(1,1),b1(1,i),AEAb1derg(1,1,1))
10143         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
10144         call matvec2(AEA(1,1,1),b1(1,k+1),AEAb1(1,2,1))
10145         call matvec2(AEAderg(1,1,1),b1(1,k+1),AEAb1derg(1,2,1))
10146         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
10147         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
10148         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
10149         call transpose2(AEA(1,1,2),auxmat(1,1))
10150         call matvec2(auxmat(1,1),b1(1,j+1),AEAb1(1,1,2))
10151         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
10152         call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
10153         call transpose2(AEAderg(1,1,2),auxmat(1,1))
10154         call matvec2(auxmat(1,1),b1(1,l),AEAb1(1,1,2))
10155         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
10156         call matvec2(AEA(1,1,2),b1(1,j+1),AEAb1(1,2,2))
10157         call matvec2(AEAderg(1,1,2),b1(1,j+1),AEAb1derg(1,2,2))
10158         call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
10159         call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
10160         call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
10161 C Calculate the Cartesian derivatives of the vectors.
10162         do iii=1,2
10163           do kkk=1,5
10164             do lll=1,3
10165               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
10166               call matvec2(auxmat(1,1),b1(1,i),
10167      &          AEAb1derx(1,lll,kkk,iii,1,1))
10168               call matvec2(auxmat(1,1),Ub2(1,i),
10169      &          AEAb2derx(1,lll,kkk,iii,1,1))
10170               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
10171      &          AEAb1derx(1,lll,kkk,iii,2,1))
10172               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
10173      &          AEAb2derx(1,lll,kkk,iii,2,1))
10174               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
10175               call matvec2(auxmat(1,1),b1(1,l),
10176      &          AEAb1derx(1,lll,kkk,iii,1,2))
10177               call matvec2(auxmat(1,1),Ub2(1,l),
10178      &          AEAb2derx(1,lll,kkk,iii,1,2))
10179               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,j+1),
10180      &          AEAb1derx(1,lll,kkk,iii,2,2))
10181               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),
10182      &          AEAb2derx(1,lll,kkk,iii,2,2))
10183             enddo
10184           enddo
10185         enddo
10186         ENDIF
10187 C End vectors
10188       endif
10189       return
10190       end
10191 C---------------------------------------------------------------------------
10192       subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,
10193      &  KK,KKderg,AKA,AKAderg,AKAderx)
10194       implicit none
10195       integer nderg
10196       logical transp
10197       double precision aa1(2,2),aa2t(2,2),aa1derx(2,2,3,5),
10198      &  aa2tderx(2,2,3,5),KK(2,2),KKderg(2,2,nderg),AKA(2,2),
10199      &  AKAderg(2,2,nderg),AKAderx(2,2,3,5,2)
10200       integer iii,kkk,lll
10201       integer jjj,mmm
10202       logical lprn
10203       common /kutas/ lprn
10204       call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
10205       do iii=1,nderg
10206         call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,
10207      &    AKAderg(1,1,iii))
10208       enddo
10209 cd      if (lprn) write (2,*) 'In kernel'
10210       do kkk=1,5
10211 cd        if (lprn) write (2,*) 'kkk=',kkk
10212         do lll=1,3
10213           call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),
10214      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
10215 cd          if (lprn) then
10216 cd            write (2,*) 'lll=',lll
10217 cd            write (2,*) 'iii=1'
10218 cd            do jjj=1,2
10219 cd              write (2,'(3(2f10.5),5x)')
10220 cd     &        (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
10221 cd            enddo
10222 cd          endif
10223           call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),
10224      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
10225 cd          if (lprn) then
10226 cd            write (2,*) 'lll=',lll
10227 cd            write (2,*) 'iii=2'
10228 cd            do jjj=1,2
10229 cd              write (2,'(3(2f10.5),5x)')
10230 cd     &        (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
10231 cd            enddo
10232 cd          endif
10233         enddo
10234       enddo
10235       return
10236       end
10237 C---------------------------------------------------------------------------
10238       double precision function eello4(i,j,k,l,jj,kk)
10239       implicit real*8 (a-h,o-z)
10240       include 'DIMENSIONS'
10241       include 'COMMON.IOUNITS'
10242       include 'COMMON.CHAIN'
10243       include 'COMMON.DERIV'
10244       include 'COMMON.INTERACT'
10245       include 'COMMON.CONTACTS'
10246       include 'COMMON.TORSION'
10247       include 'COMMON.VAR'
10248       include 'COMMON.GEO'
10249       double precision pizda(2,2),ggg1(3),ggg2(3)
10250 cd      if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
10251 cd        eello4=0.0d0
10252 cd        return
10253 cd      endif
10254 cd      print *,'eello4:',i,j,k,l,jj,kk
10255 cd      write (2,*) 'i',i,' j',j,' k',k,' l',l
10256 cd      call checkint4(i,j,k,l,jj,kk,eel4_num)
10257 cold      eij=facont_hb(jj,i)
10258 cold      ekl=facont_hb(kk,k)
10259 cold      ekont=eij*ekl
10260       eel4=-EAEA(1,1,1)-EAEA(2,2,1)
10261 cd      eel41=-EAEA(1,1,2)-EAEA(2,2,2)
10262       gcorr_loc(k-1)=gcorr_loc(k-1)
10263      &   -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
10264       if (l.eq.j+1) then
10265         gcorr_loc(l-1)=gcorr_loc(l-1)
10266      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
10267 C Al 4/16/16: Derivatives in theta, to be added later.
10268 c#ifdef NEWCORR
10269 c        gcorr_loc(nphi+l-1)=gcorr_loc(nphi+l-1)
10270 c     &     -ekont*(EAEAdert(1,1,2,1)+EAEAdert(2,2,2,1))
10271 c#endif
10272       else
10273         gcorr_loc(j-1)=gcorr_loc(j-1)
10274      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
10275 c#ifdef NEWCORR
10276 c        gcorr_loc(nphi+j-1)=gcorr_loc(nphi+j-1)
10277 c     &     -ekont*(EAEAdert(1,1,2,1)+EAEAdert(2,2,2,1))
10278 c#endif
10279       endif
10280       do iii=1,2
10281         do kkk=1,5
10282           do lll=1,3
10283             derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1)
10284      &                        -EAEAderx(2,2,lll,kkk,iii,1)
10285 cd            derx(lll,kkk,iii)=0.0d0
10286           enddo
10287         enddo
10288       enddo
10289 cd      gcorr_loc(l-1)=0.0d0
10290 cd      gcorr_loc(j-1)=0.0d0
10291 cd      gcorr_loc(k-1)=0.0d0
10292 cd      eel4=1.0d0
10293 cd      write (iout,*)'Contacts have occurred for peptide groups',
10294 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l,
10295 cd     &  ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
10296       if (j.lt.nres-1) then
10297         j1=j+1
10298         j2=j-1
10299       else
10300         j1=j-1
10301         j2=j-2
10302       endif
10303       if (l.lt.nres-1) then
10304         l1=l+1
10305         l2=l-1
10306       else
10307         l1=l-1
10308         l2=l-2
10309       endif
10310       do ll=1,3
10311 cgrad        ggg1(ll)=eel4*g_contij(ll,1)
10312 cgrad        ggg2(ll)=eel4*g_contij(ll,2)
10313         glongij=eel4*g_contij(ll,1)+ekont*derx(ll,1,1)
10314         glongkl=eel4*g_contij(ll,2)+ekont*derx(ll,1,2)
10315 cgrad        ghalf=0.5d0*ggg1(ll)
10316         gradcorr(ll,i)=gradcorr(ll,i)+ekont*derx(ll,2,1)
10317         gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
10318         gradcorr(ll,j)=gradcorr(ll,j)+ekont*derx(ll,4,1)
10319         gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
10320         gradcorr_long(ll,j)=gradcorr_long(ll,j)+glongij
10321         gradcorr_long(ll,i)=gradcorr_long(ll,i)-glongij
10322 cgrad        ghalf=0.5d0*ggg2(ll)
10323         gradcorr(ll,k)=gradcorr(ll,k)+ekont*derx(ll,2,2)
10324         gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
10325         gradcorr(ll,l)=gradcorr(ll,l)+ekont*derx(ll,4,2)
10326         gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
10327         gradcorr_long(ll,l)=gradcorr_long(ll,l)+glongkl
10328         gradcorr_long(ll,k)=gradcorr_long(ll,k)-glongkl
10329       enddo
10330 cgrad      do m=i+1,j-1
10331 cgrad        do ll=1,3
10332 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
10333 cgrad        enddo
10334 cgrad      enddo
10335 cgrad      do m=k+1,l-1
10336 cgrad        do ll=1,3
10337 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
10338 cgrad        enddo
10339 cgrad      enddo
10340 cgrad      do m=i+2,j2
10341 cgrad        do ll=1,3
10342 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
10343 cgrad        enddo
10344 cgrad      enddo
10345 cgrad      do m=k+2,l2
10346 cgrad        do ll=1,3
10347 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
10348 cgrad        enddo
10349 cgrad      enddo
10350 cd      do iii=1,nres-3
10351 cd        write (2,*) iii,gcorr_loc(iii)
10352 cd      enddo
10353       eello4=ekont*eel4
10354 cd      write (2,*) 'ekont',ekont
10355 cd      write (iout,*) 'eello4',ekont*eel4
10356       return
10357       end
10358 C---------------------------------------------------------------------------
10359       double precision function eello5(i,j,k,l,jj,kk)
10360       implicit real*8 (a-h,o-z)
10361       include 'DIMENSIONS'
10362       include 'COMMON.IOUNITS'
10363       include 'COMMON.CHAIN'
10364       include 'COMMON.DERIV'
10365       include 'COMMON.INTERACT'
10366       include 'COMMON.CONTACTS'
10367       include 'COMMON.TORSION'
10368       include 'COMMON.VAR'
10369       include 'COMMON.GEO'
10370       double precision pizda(2,2),auxmat(2,2),auxmat1(2,2),vv(2)
10371       double precision ggg1(3),ggg2(3)
10372 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10373 C                                                                              C
10374 C                            Parallel chains                                   C
10375 C                                                                              C
10376 C          o             o                   o             o                   C
10377 C         /l\           / \             \   / \           / \   /              C
10378 C        /   \         /   \             \ /   \         /   \ /               C
10379 C       j| o |l1       | o |              o| o |         | o |o                C
10380 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
10381 C      \i/   \         /   \ /             /   \         /   \                 C
10382 C       o    k1             o                                                  C
10383 C         (I)          (II)                (III)          (IV)                 C
10384 C                                                                              C
10385 C      eello5_1        eello5_2            eello5_3       eello5_4             C
10386 C                                                                              C
10387 C                            Antiparallel chains                               C
10388 C                                                                              C
10389 C          o             o                   o             o                   C
10390 C         /j\           / \             \   / \           / \   /              C
10391 C        /   \         /   \             \ /   \         /   \ /               C
10392 C      j1| o |l        | o |              o| o |         | o |o                C
10393 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
10394 C      \i/   \         /   \ /             /   \         /   \                 C
10395 C       o     k1            o                                                  C
10396 C         (I)          (II)                (III)          (IV)                 C
10397 C                                                                              C
10398 C      eello5_1        eello5_2            eello5_3       eello5_4             C
10399 C                                                                              C
10400 C o denotes a local interaction, vertical lines an electrostatic interaction.  C
10401 C                                                                              C
10402 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10403 cd      if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
10404 cd        eello5=0.0d0
10405 cd        return
10406 cd      endif
10407 cd      write (iout,*)
10408 cd     &   'EELLO5: Contacts have occurred for peptide groups',i,j,
10409 cd     &   ' and',k,l
10410       itk=itype2loc(itype(k))
10411       itl=itype2loc(itype(l))
10412       itj=itype2loc(itype(j))
10413       eello5_1=0.0d0
10414       eello5_2=0.0d0
10415       eello5_3=0.0d0
10416       eello5_4=0.0d0
10417 cd      call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
10418 cd     &   eel5_3_num,eel5_4_num)
10419       do iii=1,2
10420         do kkk=1,5
10421           do lll=1,3
10422             derx(lll,kkk,iii)=0.0d0
10423           enddo
10424         enddo
10425       enddo
10426 cd      eij=facont_hb(jj,i)
10427 cd      ekl=facont_hb(kk,k)
10428 cd      ekont=eij*ekl
10429 cd      write (iout,*)'Contacts have occurred for peptide groups',
10430 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l
10431 cd      goto 1111
10432 C Contribution from the graph I.
10433 cd      write (2,*) 'AEA  ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
10434 cd      write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
10435       call transpose2(EUg(1,1,k),auxmat(1,1))
10436       call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
10437       vv(1)=pizda(1,1)-pizda(2,2)
10438       vv(2)=pizda(1,2)+pizda(2,1)
10439       eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k))
10440      & +0.5d0*scalar2(vv(1),Dtobr2(1,i))
10441 C Explicit gradient in virtual-dihedral angles.
10442       if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1)
10443      & +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k))
10444      & +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
10445       call transpose2(EUgder(1,1,k),auxmat1(1,1))
10446       call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
10447       vv(1)=pizda(1,1)-pizda(2,2)
10448       vv(2)=pizda(1,2)+pizda(2,1)
10449       g_corr5_loc(k-1)=g_corr5_loc(k-1)
10450      & +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k))
10451      & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
10452       call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
10453       vv(1)=pizda(1,1)-pizda(2,2)
10454       vv(2)=pizda(1,2)+pizda(2,1)
10455       if (l.eq.j+1) then
10456         if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1)
10457      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
10458      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
10459       else
10460         if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1)
10461      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
10462      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
10463       endif
10464 C Cartesian gradient
10465       do iii=1,2
10466         do kkk=1,5
10467           do lll=1,3
10468             call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),
10469      &        pizda(1,1))
10470             vv(1)=pizda(1,1)-pizda(2,2)
10471             vv(2)=pizda(1,2)+pizda(2,1)
10472             derx(lll,kkk,iii)=derx(lll,kkk,iii)
10473      &       +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k))
10474      &       +0.5d0*scalar2(vv(1),Dtobr2(1,i))
10475           enddo
10476         enddo
10477       enddo
10478 c      goto 1112
10479 c1111  continue
10480 C Contribution from graph II
10481       call transpose2(EE(1,1,k),auxmat(1,1))
10482       call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
10483       vv(1)=pizda(1,1)+pizda(2,2)
10484       vv(2)=pizda(2,1)-pizda(1,2)
10485       eello5_2=scalar2(AEAb1(1,2,1),b1(1,k))
10486      & -0.5d0*scalar2(vv(1),Ctobr(1,k))
10487 C Explicit gradient in virtual-dihedral angles.
10488       g_corr5_loc(k-1)=g_corr5_loc(k-1)
10489      & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
10490       call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
10491       vv(1)=pizda(1,1)+pizda(2,2)
10492       vv(2)=pizda(2,1)-pizda(1,2)
10493       if (l.eq.j+1) then
10494         g_corr5_loc(l-1)=g_corr5_loc(l-1)
10495      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,k))
10496      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
10497       else
10498         g_corr5_loc(j-1)=g_corr5_loc(j-1)
10499      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,k))
10500      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
10501       endif
10502 C Cartesian gradient
10503       do iii=1,2
10504         do kkk=1,5
10505           do lll=1,3
10506             call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
10507      &        pizda(1,1))
10508             vv(1)=pizda(1,1)+pizda(2,2)
10509             vv(2)=pizda(2,1)-pizda(1,2)
10510             derx(lll,kkk,iii)=derx(lll,kkk,iii)
10511      &       +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,k))
10512      &       -0.5d0*scalar2(vv(1),Ctobr(1,k))
10513           enddo
10514         enddo
10515       enddo
10516 cd      goto 1112
10517 cd1111  continue
10518       if (l.eq.j+1) then
10519 cd        goto 1110
10520 C Parallel orientation
10521 C Contribution from graph III
10522         call transpose2(EUg(1,1,l),auxmat(1,1))
10523         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
10524         vv(1)=pizda(1,1)-pizda(2,2)
10525         vv(2)=pizda(1,2)+pizda(2,1)
10526         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l))
10527      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j))
10528 C Explicit gradient in virtual-dihedral angles.
10529         g_corr5_loc(j-1)=g_corr5_loc(j-1)
10530      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l))
10531      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
10532         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
10533         vv(1)=pizda(1,1)-pizda(2,2)
10534         vv(2)=pizda(1,2)+pizda(2,1)
10535         g_corr5_loc(k-1)=g_corr5_loc(k-1)
10536      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l))
10537      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
10538         call transpose2(EUgder(1,1,l),auxmat1(1,1))
10539         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
10540         vv(1)=pizda(1,1)-pizda(2,2)
10541         vv(2)=pizda(1,2)+pizda(2,1)
10542         g_corr5_loc(l-1)=g_corr5_loc(l-1)
10543      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l))
10544      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
10545 C Cartesian gradient
10546         do iii=1,2
10547           do kkk=1,5
10548             do lll=1,3
10549               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
10550      &          pizda(1,1))
10551               vv(1)=pizda(1,1)-pizda(2,2)
10552               vv(2)=pizda(1,2)+pizda(2,1)
10553               derx(lll,kkk,iii)=derx(lll,kkk,iii)
10554      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l))
10555      &         +0.5d0*scalar2(vv(1),Dtobr2(1,j))
10556             enddo
10557           enddo
10558         enddo
10559 cd        goto 1112
10560 C Contribution from graph IV
10561 cd1110    continue
10562         call transpose2(EE(1,1,l),auxmat(1,1))
10563         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
10564         vv(1)=pizda(1,1)+pizda(2,2)
10565         vv(2)=pizda(2,1)-pizda(1,2)
10566         eello5_4=scalar2(AEAb1(1,2,2),b1(1,l))
10567      &   -0.5d0*scalar2(vv(1),Ctobr(1,l))
10568 C Explicit gradient in virtual-dihedral angles.
10569         g_corr5_loc(l-1)=g_corr5_loc(l-1)
10570      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
10571         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
10572         vv(1)=pizda(1,1)+pizda(2,2)
10573         vv(2)=pizda(2,1)-pizda(1,2)
10574         g_corr5_loc(k-1)=g_corr5_loc(k-1)
10575      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,l))
10576      &   -0.5d0*scalar2(vv(1),Ctobr(1,l)))
10577 C Cartesian gradient
10578         do iii=1,2
10579           do kkk=1,5
10580             do lll=1,3
10581               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
10582      &          pizda(1,1))
10583               vv(1)=pizda(1,1)+pizda(2,2)
10584               vv(2)=pizda(2,1)-pizda(1,2)
10585               derx(lll,kkk,iii)=derx(lll,kkk,iii)
10586      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,l))
10587      &         -0.5d0*scalar2(vv(1),Ctobr(1,l))
10588             enddo
10589           enddo
10590         enddo
10591       else
10592 C Antiparallel orientation
10593 C Contribution from graph III
10594 c        goto 1110
10595         call transpose2(EUg(1,1,j),auxmat(1,1))
10596         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
10597         vv(1)=pizda(1,1)-pizda(2,2)
10598         vv(2)=pizda(1,2)+pizda(2,1)
10599         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j))
10600      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l))
10601 C Explicit gradient in virtual-dihedral angles.
10602         g_corr5_loc(l-1)=g_corr5_loc(l-1)
10603      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j))
10604      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
10605         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
10606         vv(1)=pizda(1,1)-pizda(2,2)
10607         vv(2)=pizda(1,2)+pizda(2,1)
10608         g_corr5_loc(k-1)=g_corr5_loc(k-1)
10609      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j))
10610      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
10611         call transpose2(EUgder(1,1,j),auxmat1(1,1))
10612         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
10613         vv(1)=pizda(1,1)-pizda(2,2)
10614         vv(2)=pizda(1,2)+pizda(2,1)
10615         g_corr5_loc(j-1)=g_corr5_loc(j-1)
10616      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j))
10617      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
10618 C Cartesian gradient
10619         do iii=1,2
10620           do kkk=1,5
10621             do lll=1,3
10622               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
10623      &          pizda(1,1))
10624               vv(1)=pizda(1,1)-pizda(2,2)
10625               vv(2)=pizda(1,2)+pizda(2,1)
10626               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
10627      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j))
10628      &         +0.5d0*scalar2(vv(1),Dtobr2(1,l))
10629             enddo
10630           enddo
10631         enddo
10632 cd        goto 1112
10633 C Contribution from graph IV
10634 1110    continue
10635         call transpose2(EE(1,1,j),auxmat(1,1))
10636         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
10637         vv(1)=pizda(1,1)+pizda(2,2)
10638         vv(2)=pizda(2,1)-pizda(1,2)
10639         eello5_4=scalar2(AEAb1(1,2,2),b1(1,j))
10640      &   -0.5d0*scalar2(vv(1),Ctobr(1,j))
10641 C Explicit gradient in virtual-dihedral angles.
10642         g_corr5_loc(j-1)=g_corr5_loc(j-1)
10643      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
10644         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
10645         vv(1)=pizda(1,1)+pizda(2,2)
10646         vv(2)=pizda(2,1)-pizda(1,2)
10647         g_corr5_loc(k-1)=g_corr5_loc(k-1)
10648      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,j))
10649      &   -0.5d0*scalar2(vv(1),Ctobr(1,j)))
10650 C Cartesian gradient
10651         do iii=1,2
10652           do kkk=1,5
10653             do lll=1,3
10654               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
10655      &          pizda(1,1))
10656               vv(1)=pizda(1,1)+pizda(2,2)
10657               vv(2)=pizda(2,1)-pizda(1,2)
10658               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
10659      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,j))
10660      &         -0.5d0*scalar2(vv(1),Ctobr(1,j))
10661             enddo
10662           enddo
10663         enddo
10664       endif
10665 1112  continue
10666       eel5=eello5_1+eello5_2+eello5_3+eello5_4
10667 cd      if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
10668 cd        write (2,*) 'ijkl',i,j,k,l
10669 cd        write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
10670 cd     &     ' eello5_3',eello5_3,' eello5_4',eello5_4
10671 cd      endif
10672 cd      write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
10673 cd      write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
10674 cd      write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
10675 cd      write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
10676       if (j.lt.nres-1) then
10677         j1=j+1
10678         j2=j-1
10679       else
10680         j1=j-1
10681         j2=j-2
10682       endif
10683       if (l.lt.nres-1) then
10684         l1=l+1
10685         l2=l-1
10686       else
10687         l1=l-1
10688         l2=l-2
10689       endif
10690 cd      eij=1.0d0
10691 cd      ekl=1.0d0
10692 cd      ekont=1.0d0
10693 cd      write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
10694 C 2/11/08 AL Gradients over DC's connecting interacting sites will be
10695 C        summed up outside the subrouine as for the other subroutines
10696 C        handling long-range interactions. The old code is commented out
10697 C        with "cgrad" to keep track of changes.
10698       do ll=1,3
10699 cgrad        ggg1(ll)=eel5*g_contij(ll,1)
10700 cgrad        ggg2(ll)=eel5*g_contij(ll,2)
10701         gradcorr5ij=eel5*g_contij(ll,1)+ekont*derx(ll,1,1)
10702         gradcorr5kl=eel5*g_contij(ll,2)+ekont*derx(ll,1,2)
10703 c        write (iout,'(a,3i3,a,5f8.3,2i3,a,5f8.3,a,f8.3)')
10704 c     &   "ecorr5",ll,i,j," derx",derx(ll,2,1),derx(ll,3,1),derx(ll,4,1),
10705 c     &   derx(ll,5,1),k,l," derx",derx(ll,2,2),derx(ll,3,2),
10706 c     &   derx(ll,4,2),derx(ll,5,2)," ekont",ekont
10707 c        write (iout,'(a,3i3,a,3f8.3,2i3,a,3f8.3)')
10708 c     &   "ecorr5",ll,i,j," gradcorr5",g_contij(ll,1),derx(ll,1,1),
10709 c     &   gradcorr5ij,
10710 c     &   k,l," gradcorr5",g_contij(ll,2),derx(ll,1,2),gradcorr5kl
10711 cold        ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
10712 cgrad        ghalf=0.5d0*ggg1(ll)
10713 cd        ghalf=0.0d0
10714         gradcorr5(ll,i)=gradcorr5(ll,i)+ekont*derx(ll,2,1)
10715         gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
10716         gradcorr5(ll,j)=gradcorr5(ll,j)+ekont*derx(ll,4,1)
10717         gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
10718         gradcorr5_long(ll,j)=gradcorr5_long(ll,j)+gradcorr5ij
10719         gradcorr5_long(ll,i)=gradcorr5_long(ll,i)-gradcorr5ij
10720 cold        ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
10721 cgrad        ghalf=0.5d0*ggg2(ll)
10722 cd        ghalf=0.0d0
10723         gradcorr5(ll,k)=gradcorr5(ll,k)+ekont*derx(ll,2,2)
10724         gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
10725         gradcorr5(ll,l)=gradcorr5(ll,l)+ekont*derx(ll,4,2)
10726         gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
10727         gradcorr5_long(ll,l)=gradcorr5_long(ll,l)+gradcorr5kl
10728         gradcorr5_long(ll,k)=gradcorr5_long(ll,k)-gradcorr5kl
10729       enddo
10730 cd      goto 1112
10731 cgrad      do m=i+1,j-1
10732 cgrad        do ll=1,3
10733 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
10734 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
10735 cgrad        enddo
10736 cgrad      enddo
10737 cgrad      do m=k+1,l-1
10738 cgrad        do ll=1,3
10739 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
10740 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
10741 cgrad        enddo
10742 cgrad      enddo
10743 c1112  continue
10744 cgrad      do m=i+2,j2
10745 cgrad        do ll=1,3
10746 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
10747 cgrad        enddo
10748 cgrad      enddo
10749 cgrad      do m=k+2,l2
10750 cgrad        do ll=1,3
10751 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
10752 cgrad        enddo
10753 cgrad      enddo
10754 cd      do iii=1,nres-3
10755 cd        write (2,*) iii,g_corr5_loc(iii)
10756 cd      enddo
10757       eello5=ekont*eel5
10758 cd      write (2,*) 'ekont',ekont
10759 cd      write (iout,*) 'eello5',ekont*eel5
10760       return
10761       end
10762 c--------------------------------------------------------------------------
10763       double precision function eello6(i,j,k,l,jj,kk)
10764       implicit real*8 (a-h,o-z)
10765       include 'DIMENSIONS'
10766       include 'COMMON.IOUNITS'
10767       include 'COMMON.CHAIN'
10768       include 'COMMON.DERIV'
10769       include 'COMMON.INTERACT'
10770       include 'COMMON.CONTACTS'
10771       include 'COMMON.TORSION'
10772       include 'COMMON.VAR'
10773       include 'COMMON.GEO'
10774       include 'COMMON.FFIELD'
10775       double precision ggg1(3),ggg2(3)
10776 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
10777 cd        eello6=0.0d0
10778 cd        return
10779 cd      endif
10780 cd      write (iout,*)
10781 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
10782 cd     &   ' and',k,l
10783       eello6_1=0.0d0
10784       eello6_2=0.0d0
10785       eello6_3=0.0d0
10786       eello6_4=0.0d0
10787       eello6_5=0.0d0
10788       eello6_6=0.0d0
10789 cd      call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
10790 cd     &   eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
10791       do iii=1,2
10792         do kkk=1,5
10793           do lll=1,3
10794             derx(lll,kkk,iii)=0.0d0
10795           enddo
10796         enddo
10797       enddo
10798 cd      eij=facont_hb(jj,i)
10799 cd      ekl=facont_hb(kk,k)
10800 cd      ekont=eij*ekl
10801 cd      eij=1.0d0
10802 cd      ekl=1.0d0
10803 cd      ekont=1.0d0
10804       if (l.eq.j+1) then
10805         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
10806         eello6_2=eello6_graph1(j,i,l,k,2,.false.)
10807         eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
10808         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
10809         eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
10810         eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
10811       else
10812         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
10813         eello6_2=eello6_graph1(l,k,j,i,2,.true.)
10814         eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
10815         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
10816         if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
10817           eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
10818         else
10819           eello6_5=0.0d0
10820         endif
10821         eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
10822       endif
10823 C If turn contributions are considered, they will be handled separately.
10824       eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
10825 cd      write(iout,*) 'eello6_1',eello6_1!,' eel6_1_num',16*eel6_1_num
10826 cd      write(iout,*) 'eello6_2',eello6_2!,' eel6_2_num',16*eel6_2_num
10827 cd      write(iout,*) 'eello6_3',eello6_3!,' eel6_3_num',16*eel6_3_num
10828 cd      write(iout,*) 'eello6_4',eello6_4!,' eel6_4_num',16*eel6_4_num
10829 cd      write(iout,*) 'eello6_5',eello6_5!,' eel6_5_num',16*eel6_5_num
10830 cd      write(iout,*) 'eello6_6',eello6_6!,' eel6_6_num',16*eel6_6_num
10831 cd      goto 1112
10832       if (j.lt.nres-1) then
10833         j1=j+1
10834         j2=j-1
10835       else
10836         j1=j-1
10837         j2=j-2
10838       endif
10839       if (l.lt.nres-1) then
10840         l1=l+1
10841         l2=l-1
10842       else
10843         l1=l-1
10844         l2=l-2
10845       endif
10846       do ll=1,3
10847 cgrad        ggg1(ll)=eel6*g_contij(ll,1)
10848 cgrad        ggg2(ll)=eel6*g_contij(ll,2)
10849 cold        ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
10850 cgrad        ghalf=0.5d0*ggg1(ll)
10851 cd        ghalf=0.0d0
10852         gradcorr6ij=eel6*g_contij(ll,1)+ekont*derx(ll,1,1)
10853         gradcorr6kl=eel6*g_contij(ll,2)+ekont*derx(ll,1,2)
10854         gradcorr6(ll,i)=gradcorr6(ll,i)+ekont*derx(ll,2,1)
10855         gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
10856         gradcorr6(ll,j)=gradcorr6(ll,j)+ekont*derx(ll,4,1)
10857         gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
10858         gradcorr6_long(ll,j)=gradcorr6_long(ll,j)+gradcorr6ij
10859         gradcorr6_long(ll,i)=gradcorr6_long(ll,i)-gradcorr6ij
10860 cgrad        ghalf=0.5d0*ggg2(ll)
10861 cold        ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
10862 cd        ghalf=0.0d0
10863         gradcorr6(ll,k)=gradcorr6(ll,k)+ekont*derx(ll,2,2)
10864         gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
10865         gradcorr6(ll,l)=gradcorr6(ll,l)+ekont*derx(ll,4,2)
10866         gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
10867         gradcorr6_long(ll,l)=gradcorr6_long(ll,l)+gradcorr6kl
10868         gradcorr6_long(ll,k)=gradcorr6_long(ll,k)-gradcorr6kl
10869       enddo
10870 cd      goto 1112
10871 cgrad      do m=i+1,j-1
10872 cgrad        do ll=1,3
10873 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
10874 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
10875 cgrad        enddo
10876 cgrad      enddo
10877 cgrad      do m=k+1,l-1
10878 cgrad        do ll=1,3
10879 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
10880 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
10881 cgrad        enddo
10882 cgrad      enddo
10883 cgrad1112  continue
10884 cgrad      do m=i+2,j2
10885 cgrad        do ll=1,3
10886 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
10887 cgrad        enddo
10888 cgrad      enddo
10889 cgrad      do m=k+2,l2
10890 cgrad        do ll=1,3
10891 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
10892 cgrad        enddo
10893 cgrad      enddo
10894 cd      do iii=1,nres-3
10895 cd        write (2,*) iii,g_corr6_loc(iii)
10896 cd      enddo
10897       eello6=ekont*eel6
10898 cd      write (2,*) 'ekont',ekont
10899 cd      write (iout,*) 'eello6',ekont*eel6
10900       return
10901       end
10902 c--------------------------------------------------------------------------
10903       double precision function eello6_graph1(i,j,k,l,imat,swap)
10904       implicit real*8 (a-h,o-z)
10905       include 'DIMENSIONS'
10906       include 'COMMON.IOUNITS'
10907       include 'COMMON.CHAIN'
10908       include 'COMMON.DERIV'
10909       include 'COMMON.INTERACT'
10910       include 'COMMON.CONTACTS'
10911       include 'COMMON.TORSION'
10912       include 'COMMON.VAR'
10913       include 'COMMON.GEO'
10914       double precision vv(2),vv1(2),pizda(2,2),auxmat(2,2),pizda1(2,2)
10915       logical swap
10916       logical lprn
10917       common /kutas/ lprn
10918 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10919 C                                                                              C
10920 C      Parallel       Antiparallel                                             C
10921 C                                                                              C
10922 C          o             o                                                     C
10923 C         /l\           /j\                                                    C
10924 C        /   \         /   \                                                   C
10925 C       /| o |         | o |\                                                  C
10926 C     \ j|/k\|  /   \  |/k\|l /                                                C
10927 C      \ /   \ /     \ /   \ /                                                 C
10928 C       o     o       o     o                                                  C
10929 C       i             i                                                        C
10930 C                                                                              C
10931 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10932       itk=itype2loc(itype(k))
10933       s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
10934       s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
10935       s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
10936       call transpose2(EUgC(1,1,k),auxmat(1,1))
10937       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
10938       vv1(1)=pizda1(1,1)-pizda1(2,2)
10939       vv1(2)=pizda1(1,2)+pizda1(2,1)
10940       s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
10941       vv(1)=AEAb1(1,2,imat)*b1(1,k)-AEAb1(2,2,imat)*b1(2,k)
10942       vv(2)=AEAb1(1,2,imat)*b1(2,k)+AEAb1(2,2,imat)*b1(1,k)
10943       s5=scalar2(vv(1),Dtobr2(1,i))
10944 cd      write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
10945       eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
10946       if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1)
10947      & -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i))
10948      & -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k))
10949      & +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k))
10950      & +0.5d0*scalar2(vv1(1),Dtobr2der(1,i))
10951      & +scalar2(vv(1),Dtobr2der(1,i)))
10952       call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
10953       vv1(1)=pizda1(1,1)-pizda1(2,2)
10954       vv1(2)=pizda1(1,2)+pizda1(2,1)
10955       vv(1)=AEAb1derg(1,2,imat)*b1(1,k)-AEAb1derg(2,2,imat)*b1(2,k)
10956       vv(2)=AEAb1derg(1,2,imat)*b1(2,k)+AEAb1derg(2,2,imat)*b1(1,k)
10957       if (l.eq.j+1) then
10958         g_corr6_loc(l-1)=g_corr6_loc(l-1)
10959      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
10960      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
10961      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
10962      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
10963       else
10964         g_corr6_loc(j-1)=g_corr6_loc(j-1)
10965      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
10966      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
10967      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
10968      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
10969       endif
10970       call transpose2(EUgCder(1,1,k),auxmat(1,1))
10971       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
10972       vv1(1)=pizda1(1,1)-pizda1(2,2)
10973       vv1(2)=pizda1(1,2)+pizda1(2,1)
10974       if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1)
10975      & +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k))
10976      & +scalar2(AEAb2(1,1,imat),CUgb2der(1,k))
10977      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
10978       do iii=1,2
10979         if (swap) then
10980           ind=3-iii
10981         else
10982           ind=iii
10983         endif
10984         do kkk=1,5
10985           do lll=1,3
10986             s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
10987             s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
10988             s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
10989             call transpose2(EUgC(1,1,k),auxmat(1,1))
10990             call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
10991      &        pizda1(1,1))
10992             vv1(1)=pizda1(1,1)-pizda1(2,2)
10993             vv1(2)=pizda1(1,2)+pizda1(2,1)
10994             s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
10995             vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,k)
10996      &       -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,k)
10997             vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,k)
10998      &       +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,k)
10999             s5=scalar2(vv(1),Dtobr2(1,i))
11000             derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
11001           enddo
11002         enddo
11003       enddo
11004       return
11005       end
11006 c----------------------------------------------------------------------------
11007       double precision function eello6_graph2(i,j,k,l,jj,kk,swap)
11008       implicit real*8 (a-h,o-z)
11009       include 'DIMENSIONS'
11010       include 'COMMON.IOUNITS'
11011       include 'COMMON.CHAIN'
11012       include 'COMMON.DERIV'
11013       include 'COMMON.INTERACT'
11014       include 'COMMON.CONTACTS'
11015       include 'COMMON.TORSION'
11016       include 'COMMON.VAR'
11017       include 'COMMON.GEO'
11018       logical swap
11019       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
11020      & auxvec1(2),auxvec2(2),auxmat1(2,2)
11021       logical lprn
11022       common /kutas/ lprn
11023 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
11024 C                                                                              C
11025 C      Parallel       Antiparallel                                             C
11026 C                                                                              C
11027 C          o             o                                                     C
11028 C     \   /l\           /j\   /                                                C
11029 C      \ /   \         /   \ /                                                 C
11030 C       o| o |         | o |o                                                  C
11031 C     \ j|/k\|      \  |/k\|l                                                  C
11032 C      \ /   \       \ /   \                                                   C
11033 C       o             o                                                        C
11034 C       i             i                                                        C
11035 C                                                                              C
11036 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
11037 cd      write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
11038 C AL 7/4/01 s1 would occur in the sixth-order moment,
11039 C           but not in a cluster cumulant
11040 #ifdef MOMENT
11041       s1=dip(1,jj,i)*dip(1,kk,k)
11042 #endif
11043       call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
11044       s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
11045       call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
11046       s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
11047       call transpose2(EUg(1,1,k),auxmat(1,1))
11048       call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
11049       vv(1)=pizda(1,1)-pizda(2,2)
11050       vv(2)=pizda(1,2)+pizda(2,1)
11051       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
11052 cd      write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
11053 #ifdef MOMENT
11054       eello6_graph2=-(s1+s2+s3+s4)
11055 #else
11056       eello6_graph2=-(s2+s3+s4)
11057 #endif
11058 c      eello6_graph2=-s3
11059 C Derivatives in gamma(i-1)
11060       if (i.gt.1) then
11061 #ifdef MOMENT
11062         s1=dipderg(1,jj,i)*dip(1,kk,k)
11063 #endif
11064         s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
11065         call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
11066         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
11067         s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
11068 #ifdef MOMENT
11069         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
11070 #else
11071         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
11072 #endif
11073 c        g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
11074       endif
11075 C Derivatives in gamma(k-1)
11076 #ifdef MOMENT
11077       s1=dip(1,jj,i)*dipderg(1,kk,k)
11078 #endif
11079       call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
11080       s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
11081       call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
11082       s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
11083       call transpose2(EUgder(1,1,k),auxmat1(1,1))
11084       call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
11085       vv(1)=pizda(1,1)-pizda(2,2)
11086       vv(2)=pizda(1,2)+pizda(2,1)
11087       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
11088 #ifdef MOMENT
11089       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
11090 #else
11091       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
11092 #endif
11093 c      g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
11094 C Derivatives in gamma(j-1) or gamma(l-1)
11095       if (j.gt.1) then
11096 #ifdef MOMENT
11097         s1=dipderg(3,jj,i)*dip(1,kk,k)
11098 #endif
11099         call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
11100         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
11101         s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
11102         call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
11103         vv(1)=pizda(1,1)-pizda(2,2)
11104         vv(2)=pizda(1,2)+pizda(2,1)
11105         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
11106 #ifdef MOMENT
11107         if (swap) then
11108           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
11109         else
11110           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
11111         endif
11112 #endif
11113         g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
11114 c        g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
11115       endif
11116 C Derivatives in gamma(l-1) or gamma(j-1)
11117       if (l.gt.1) then
11118 #ifdef MOMENT
11119         s1=dip(1,jj,i)*dipderg(3,kk,k)
11120 #endif
11121         call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
11122         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
11123         call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
11124         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
11125         call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
11126         vv(1)=pizda(1,1)-pizda(2,2)
11127         vv(2)=pizda(1,2)+pizda(2,1)
11128         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
11129 #ifdef MOMENT
11130         if (swap) then
11131           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
11132         else
11133           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
11134         endif
11135 #endif
11136         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
11137 c        g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
11138       endif
11139 C Cartesian derivatives.
11140       if (lprn) then
11141         write (2,*) 'In eello6_graph2'
11142         do iii=1,2
11143           write (2,*) 'iii=',iii
11144           do kkk=1,5
11145             write (2,*) 'kkk=',kkk
11146             do jjj=1,2
11147               write (2,'(3(2f10.5),5x)')
11148      &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
11149             enddo
11150           enddo
11151         enddo
11152       endif
11153       do iii=1,2
11154         do kkk=1,5
11155           do lll=1,3
11156 #ifdef MOMENT
11157             if (iii.eq.1) then
11158               s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
11159             else
11160               s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
11161             endif
11162 #endif
11163             call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),
11164      &        auxvec(1))
11165             s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
11166             call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),
11167      &        auxvec(1))
11168             s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
11169             call transpose2(EUg(1,1,k),auxmat(1,1))
11170             call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),
11171      &        pizda(1,1))
11172             vv(1)=pizda(1,1)-pizda(2,2)
11173             vv(2)=pizda(1,2)+pizda(2,1)
11174             s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
11175 cd            write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
11176 #ifdef MOMENT
11177             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
11178 #else
11179             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
11180 #endif
11181             if (swap) then
11182               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
11183             else
11184               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
11185             endif
11186           enddo
11187         enddo
11188       enddo
11189       return
11190       end
11191 c----------------------------------------------------------------------------
11192       double precision function eello6_graph3(i,j,k,l,jj,kk,swap)
11193       implicit real*8 (a-h,o-z)
11194       include 'DIMENSIONS'
11195       include 'COMMON.IOUNITS'
11196       include 'COMMON.CHAIN'
11197       include 'COMMON.DERIV'
11198       include 'COMMON.INTERACT'
11199       include 'COMMON.CONTACTS'
11200       include 'COMMON.TORSION'
11201       include 'COMMON.VAR'
11202       include 'COMMON.GEO'
11203       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2)
11204       logical swap
11205 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
11206 C                                                                              C
11207 C      Parallel       Antiparallel                                             C
11208 C                                                                              C
11209 C          o             o                                                     C
11210 C         /l\   /   \   /j\                                                    C
11211 C        /   \ /     \ /   \                                                   C
11212 C       /| o |o       o| o |\                                                  C
11213 C       j|/k\|  /      |/k\|l /                                                C
11214 C        /   \ /       /   \ /                                                 C
11215 C       /     o       /     o                                                  C
11216 C       i             i                                                        C
11217 C                                                                              C
11218 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
11219 C
11220 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
11221 C           energy moment and not to the cluster cumulant.
11222       iti=itortyp(itype(i))
11223       if (j.lt.nres-1) then
11224         itj1=itype2loc(itype(j+1))
11225       else
11226         itj1=nloctyp
11227       endif
11228       itk=itype2loc(itype(k))
11229       itk1=itype2loc(itype(k+1))
11230       if (l.lt.nres-1) then
11231         itl1=itype2loc(itype(l+1))
11232       else
11233         itl1=nloctyp
11234       endif
11235 #ifdef MOMENT
11236       s1=dip(4,jj,i)*dip(4,kk,k)
11237 #endif
11238       call matvec2(AECA(1,1,1),b1(1,k+1),auxvec(1))
11239       s2=0.5d0*scalar2(b1(1,k),auxvec(1))
11240       call matvec2(AECA(1,1,2),b1(1,l+1),auxvec(1))
11241       s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
11242       call transpose2(EE(1,1,k),auxmat(1,1))
11243       call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
11244       vv(1)=pizda(1,1)+pizda(2,2)
11245       vv(2)=pizda(2,1)-pizda(1,2)
11246       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
11247 cd      write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4,
11248 cd     & "sum",-(s2+s3+s4)
11249 #ifdef MOMENT
11250       eello6_graph3=-(s1+s2+s3+s4)
11251 #else
11252       eello6_graph3=-(s2+s3+s4)
11253 #endif
11254 c      eello6_graph3=-s4
11255 C Derivatives in gamma(k-1)
11256       call matvec2(AECAderg(1,1,2),b1(1,l+1),auxvec(1))
11257       s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
11258       s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
11259       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
11260 C Derivatives in gamma(l-1)
11261       call matvec2(AECAderg(1,1,1),b1(1,k+1),auxvec(1))
11262       s2=0.5d0*scalar2(b1(1,k),auxvec(1))
11263       call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
11264       vv(1)=pizda(1,1)+pizda(2,2)
11265       vv(2)=pizda(2,1)-pizda(1,2)
11266       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
11267       g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
11268 C Cartesian derivatives.
11269       do iii=1,2
11270         do kkk=1,5
11271           do lll=1,3
11272 #ifdef MOMENT
11273             if (iii.eq.1) then
11274               s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
11275             else
11276               s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
11277             endif
11278 #endif
11279             call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
11280      &        auxvec(1))
11281             s2=0.5d0*scalar2(b1(1,k),auxvec(1))
11282             call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,l+1),
11283      &        auxvec(1))
11284             s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
11285             call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),
11286      &        pizda(1,1))
11287             vv(1)=pizda(1,1)+pizda(2,2)
11288             vv(2)=pizda(2,1)-pizda(1,2)
11289             s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
11290 #ifdef MOMENT
11291             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
11292 #else
11293             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
11294 #endif
11295             if (swap) then
11296               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
11297             else
11298               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
11299             endif
11300 c            derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
11301           enddo
11302         enddo
11303       enddo
11304       return
11305       end
11306 c----------------------------------------------------------------------------
11307       double precision function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
11308       implicit real*8 (a-h,o-z)
11309       include 'DIMENSIONS'
11310       include 'COMMON.IOUNITS'
11311       include 'COMMON.CHAIN'
11312       include 'COMMON.DERIV'
11313       include 'COMMON.INTERACT'
11314       include 'COMMON.CONTACTS'
11315       include 'COMMON.TORSION'
11316       include 'COMMON.VAR'
11317       include 'COMMON.GEO'
11318       include 'COMMON.FFIELD'
11319       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
11320      & auxvec1(2),auxmat1(2,2)
11321       logical swap
11322 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
11323 C                                                                              C
11324 C      Parallel       Antiparallel                                             C
11325 C                                                                              C
11326 C          o             o                                                     C
11327 C         /l\   /   \   /j\                                                    C
11328 C        /   \ /     \ /   \                                                   C
11329 C       /| o |o       o| o |\                                                  C
11330 C     \ j|/k\|      \  |/k\|l                                                  C
11331 C      \ /   \       \ /   \                                                   C
11332 C       o     \       o     \                                                  C
11333 C       i             i                                                        C
11334 C                                                                              C
11335 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
11336 C
11337 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
11338 C           energy moment and not to the cluster cumulant.
11339 cd      write (2,*) 'eello_graph4: wturn6',wturn6
11340       iti=itype2loc(itype(i))
11341       itj=itype2loc(itype(j))
11342       if (j.lt.nres-1) then
11343         itj1=itype2loc(itype(j+1))
11344       else
11345         itj1=nloctyp
11346       endif
11347       itk=itype2loc(itype(k))
11348       if (k.lt.nres-1) then
11349         itk1=itype2loc(itype(k+1))
11350       else
11351         itk1=nloctyp
11352       endif
11353       itl=itype2loc(itype(l))
11354       if (l.lt.nres-1) then
11355         itl1=itype2loc(itype(l+1))
11356       else
11357         itl1=nloctyp
11358       endif
11359 cd      write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
11360 cd      write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
11361 cd     & ' itl',itl,' itl1',itl1
11362 #ifdef MOMENT
11363       if (imat.eq.1) then
11364         s1=dip(3,jj,i)*dip(3,kk,k)
11365       else
11366         s1=dip(2,jj,j)*dip(2,kk,l)
11367       endif
11368 #endif
11369       call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
11370       s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
11371       if (j.eq.l+1) then
11372         call matvec2(ADtEA1(1,1,3-imat),b1(1,j+1),auxvec1(1))
11373         s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
11374       else
11375         call matvec2(ADtEA1(1,1,3-imat),b1(1,l+1),auxvec1(1))
11376         s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
11377       endif
11378       call transpose2(EUg(1,1,k),auxmat(1,1))
11379       call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
11380       vv(1)=pizda(1,1)-pizda(2,2)
11381       vv(2)=pizda(2,1)+pizda(1,2)
11382       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
11383 cd      write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
11384 #ifdef MOMENT
11385       eello6_graph4=-(s1+s2+s3+s4)
11386 #else
11387       eello6_graph4=-(s2+s3+s4)
11388 #endif
11389 C Derivatives in gamma(i-1)
11390       if (i.gt.1) then
11391 #ifdef MOMENT
11392         if (imat.eq.1) then
11393           s1=dipderg(2,jj,i)*dip(3,kk,k)
11394         else
11395           s1=dipderg(4,jj,j)*dip(2,kk,l)
11396         endif
11397 #endif
11398         s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
11399         if (j.eq.l+1) then
11400           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,j+1),auxvec1(1))
11401           s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
11402         else
11403           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,l+1),auxvec1(1))
11404           s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
11405         endif
11406         s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
11407         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
11408 cd          write (2,*) 'turn6 derivatives'
11409 #ifdef MOMENT
11410           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
11411 #else
11412           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
11413 #endif
11414         else
11415 #ifdef MOMENT
11416           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
11417 #else
11418           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
11419 #endif
11420         endif
11421       endif
11422 C Derivatives in gamma(k-1)
11423 #ifdef MOMENT
11424       if (imat.eq.1) then
11425         s1=dip(3,jj,i)*dipderg(2,kk,k)
11426       else
11427         s1=dip(2,jj,j)*dipderg(4,kk,l)
11428       endif
11429 #endif
11430       call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
11431       s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
11432       if (j.eq.l+1) then
11433         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,j+1),auxvec1(1))
11434         s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
11435       else
11436         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,l+1),auxvec1(1))
11437         s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
11438       endif
11439       call transpose2(EUgder(1,1,k),auxmat1(1,1))
11440       call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
11441       vv(1)=pizda(1,1)-pizda(2,2)
11442       vv(2)=pizda(2,1)+pizda(1,2)
11443       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
11444       if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
11445 #ifdef MOMENT
11446         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
11447 #else
11448         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
11449 #endif
11450       else
11451 #ifdef MOMENT
11452         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
11453 #else
11454         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
11455 #endif
11456       endif
11457 C Derivatives in gamma(j-1) or gamma(l-1)
11458       if (l.eq.j+1 .and. l.gt.1) then
11459         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
11460         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
11461         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
11462         vv(1)=pizda(1,1)-pizda(2,2)
11463         vv(2)=pizda(2,1)+pizda(1,2)
11464         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
11465         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
11466       else if (j.gt.1) then
11467         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
11468         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
11469         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
11470         vv(1)=pizda(1,1)-pizda(2,2)
11471         vv(2)=pizda(2,1)+pizda(1,2)
11472         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
11473         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
11474           gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
11475         else
11476           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
11477         endif
11478       endif
11479 C Cartesian derivatives.
11480       do iii=1,2
11481         do kkk=1,5
11482           do lll=1,3
11483 #ifdef MOMENT
11484             if (iii.eq.1) then
11485               if (imat.eq.1) then
11486                 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
11487               else
11488                 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
11489               endif
11490             else
11491               if (imat.eq.1) then
11492                 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
11493               else
11494                 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
11495               endif
11496             endif
11497 #endif
11498             call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),
11499      &        auxvec(1))
11500             s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
11501             if (j.eq.l+1) then
11502               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
11503      &          b1(1,j+1),auxvec(1))
11504               s3=-0.5d0*scalar2(b1(1,j),auxvec(1))
11505             else
11506               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
11507      &          b1(1,l+1),auxvec(1))
11508               s3=-0.5d0*scalar2(b1(1,l),auxvec(1))
11509             endif
11510             call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
11511      &        pizda(1,1))
11512             vv(1)=pizda(1,1)-pizda(2,2)
11513             vv(2)=pizda(2,1)+pizda(1,2)
11514             s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
11515             if (swap) then
11516               if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
11517 #ifdef MOMENT
11518                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
11519      &             -(s1+s2+s4)
11520 #else
11521                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
11522      &             -(s2+s4)
11523 #endif
11524                 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
11525               else
11526 #ifdef MOMENT
11527                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
11528 #else
11529                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
11530 #endif
11531                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
11532               endif
11533             else
11534 #ifdef MOMENT
11535               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
11536 #else
11537               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
11538 #endif
11539               if (l.eq.j+1) then
11540                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
11541               else
11542                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
11543               endif
11544             endif
11545           enddo
11546         enddo
11547       enddo
11548       return
11549       end
11550 c----------------------------------------------------------------------------
11551       double precision function eello_turn6(i,jj,kk)
11552       implicit real*8 (a-h,o-z)
11553       include 'DIMENSIONS'
11554       include 'COMMON.IOUNITS'
11555       include 'COMMON.CHAIN'
11556       include 'COMMON.DERIV'
11557       include 'COMMON.INTERACT'
11558       include 'COMMON.CONTACTS'
11559       include 'COMMON.TORSION'
11560       include 'COMMON.VAR'
11561       include 'COMMON.GEO'
11562       double precision vtemp1(2),vtemp2(2),vtemp3(2),vtemp4(2),
11563      &  atemp(2,2),auxmat(2,2),achuj_temp(2,2),gtemp(2,2),gvec(2),
11564      &  ggg1(3),ggg2(3)
11565       double precision vtemp1d(2),vtemp2d(2),vtemp3d(2),vtemp4d(2),
11566      &  atempd(2,2),auxmatd(2,2),achuj_tempd(2,2),gtempd(2,2),gvecd(2)
11567 C 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
11568 C           the respective energy moment and not to the cluster cumulant.
11569       s1=0.0d0
11570       s8=0.0d0
11571       s13=0.0d0
11572 c
11573       eello_turn6=0.0d0
11574       j=i+4
11575       k=i+1
11576       l=i+3
11577       iti=itype2loc(itype(i))
11578       itk=itype2loc(itype(k))
11579       itk1=itype2loc(itype(k+1))
11580       itl=itype2loc(itype(l))
11581       itj=itype2loc(itype(j))
11582 cd      write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
11583 cd      write (2,*) 'i',i,' k',k,' j',j,' l',l
11584 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
11585 cd        eello6=0.0d0
11586 cd        return
11587 cd      endif
11588 cd      write (iout,*)
11589 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
11590 cd     &   ' and',k,l
11591 cd      call checkint_turn6(i,jj,kk,eel_turn6_num)
11592       do iii=1,2
11593         do kkk=1,5
11594           do lll=1,3
11595             derx_turn(lll,kkk,iii)=0.0d0
11596           enddo
11597         enddo
11598       enddo
11599 cd      eij=1.0d0
11600 cd      ekl=1.0d0
11601 cd      ekont=1.0d0
11602       eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
11603 cd      eello6_5=0.0d0
11604 cd      write (2,*) 'eello6_5',eello6_5
11605 #ifdef MOMENT
11606       call transpose2(AEA(1,1,1),auxmat(1,1))
11607       call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
11608       ss1=scalar2(Ub2(1,i+2),b1(1,l))
11609       s1 = (auxmat(1,1)+auxmat(2,2))*ss1
11610 #endif
11611       call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1(1))
11612       call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
11613       s2 = scalar2(b1(1,k),vtemp1(1))
11614 #ifdef MOMENT
11615       call transpose2(AEA(1,1,2),atemp(1,1))
11616       call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
11617       call matvec2(Ug2(1,1,i+2),dd(1,1,k+1),vtemp2(1))
11618       s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,l),vtemp2(1))
11619 #endif
11620       call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
11621       call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
11622       s12 = scalar2(Ub2(1,i+2),vtemp3(1))
11623 #ifdef MOMENT
11624       call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
11625       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
11626       call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
11627       call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
11628       ss13 = scalar2(b1(1,k),vtemp4(1))
11629       s13 = (gtemp(1,1)+gtemp(2,2))*ss13
11630 #endif
11631 c      write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
11632 c      s1=0.0d0
11633 c      s2=0.0d0
11634 c      s8=0.0d0
11635 c      s12=0.0d0
11636 c      s13=0.0d0
11637       eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
11638 C Derivatives in gamma(i+2)
11639       s1d =0.0d0
11640       s8d =0.0d0
11641 #ifdef MOMENT
11642       call transpose2(AEA(1,1,1),auxmatd(1,1))
11643       call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
11644       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
11645       call transpose2(AEAderg(1,1,2),atempd(1,1))
11646       call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
11647       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,l),vtemp2(1))
11648 #endif
11649       call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
11650       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
11651       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
11652 c      s1d=0.0d0
11653 c      s2d=0.0d0
11654 c      s8d=0.0d0
11655 c      s12d=0.0d0
11656 c      s13d=0.0d0
11657       gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
11658 C Derivatives in gamma(i+3)
11659 #ifdef MOMENT
11660       call transpose2(AEA(1,1,1),auxmatd(1,1))
11661       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
11662       ss1d=scalar2(Ub2der(1,i+2),b1(1,l))
11663       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
11664 #endif
11665       call matvec2(EUgder(1,1,i+2),b1(1,l),vtemp1d(1))
11666       call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
11667       s2d = scalar2(b1(1,k),vtemp1d(1))
11668 #ifdef MOMENT
11669       call matvec2(Ug2der(1,1,i+2),dd(1,1,k+1),vtemp2d(1))
11670       s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,l),vtemp2d(1))
11671 #endif
11672       s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
11673 #ifdef MOMENT
11674       call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
11675       call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
11676       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
11677 #endif
11678 c      s1d=0.0d0
11679 c      s2d=0.0d0
11680 c      s8d=0.0d0
11681 c      s12d=0.0d0
11682 c      s13d=0.0d0
11683 #ifdef MOMENT
11684       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
11685      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
11686 #else
11687       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
11688      &               -0.5d0*ekont*(s2d+s12d)
11689 #endif
11690 C Derivatives in gamma(i+4)
11691       call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
11692       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
11693       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
11694 #ifdef MOMENT
11695       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
11696       call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
11697       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
11698 #endif
11699 c      s1d=0.0d0
11700 c      s2d=0.0d0
11701 c      s8d=0.0d0
11702 C      s12d=0.0d0
11703 c      s13d=0.0d0
11704 #ifdef MOMENT
11705       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
11706 #else
11707       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
11708 #endif
11709 C Derivatives in gamma(i+5)
11710 #ifdef MOMENT
11711       call transpose2(AEAderg(1,1,1),auxmatd(1,1))
11712       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
11713       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
11714 #endif
11715       call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1d(1))
11716       call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
11717       s2d = scalar2(b1(1,k),vtemp1d(1))
11718 #ifdef MOMENT
11719       call transpose2(AEA(1,1,2),atempd(1,1))
11720       call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
11721       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,l),vtemp2(1))
11722 #endif
11723       call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
11724       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
11725 #ifdef MOMENT
11726       call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
11727       ss13d = scalar2(b1(1,k),vtemp4d(1))
11728       s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
11729 #endif
11730 c      s1d=0.0d0
11731 c      s2d=0.0d0
11732 c      s8d=0.0d0
11733 c      s12d=0.0d0
11734 c      s13d=0.0d0
11735 #ifdef MOMENT
11736       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
11737      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
11738 #else
11739       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
11740      &               -0.5d0*ekont*(s2d+s12d)
11741 #endif
11742 C Cartesian derivatives
11743       do iii=1,2
11744         do kkk=1,5
11745           do lll=1,3
11746 #ifdef MOMENT
11747             call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
11748             call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
11749             s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
11750 #endif
11751             call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1(1))
11752             call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),
11753      &          vtemp1d(1))
11754             s2d = scalar2(b1(1,k),vtemp1d(1))
11755 #ifdef MOMENT
11756             call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
11757             call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
11758             s8d = -(atempd(1,1)+atempd(2,2))*
11759      &           scalar2(cc(1,1,l),vtemp2(1))
11760 #endif
11761             call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),
11762      &           auxmatd(1,1))
11763             call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
11764             s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
11765 c      s1d=0.0d0
11766 c      s2d=0.0d0
11767 c      s8d=0.0d0
11768 c      s12d=0.0d0
11769 c      s13d=0.0d0
11770 #ifdef MOMENT
11771             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
11772      &        - 0.5d0*(s1d+s2d)
11773 #else
11774             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
11775      &        - 0.5d0*s2d
11776 #endif
11777 #ifdef MOMENT
11778             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
11779      &        - 0.5d0*(s8d+s12d)
11780 #else
11781             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
11782      &        - 0.5d0*s12d
11783 #endif
11784           enddo
11785         enddo
11786       enddo
11787 #ifdef MOMENT
11788       do kkk=1,5
11789         do lll=1,3
11790           call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),
11791      &      achuj_tempd(1,1))
11792           call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
11793           call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
11794           s13d=(gtempd(1,1)+gtempd(2,2))*ss13
11795           derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
11796           call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),
11797      &      vtemp4d(1))
11798           ss13d = scalar2(b1(1,k),vtemp4d(1))
11799           s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
11800           derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
11801         enddo
11802       enddo
11803 #endif
11804 cd      write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
11805 cd     &  16*eel_turn6_num
11806 cd      goto 1112
11807       if (j.lt.nres-1) then
11808         j1=j+1
11809         j2=j-1
11810       else
11811         j1=j-1
11812         j2=j-2
11813       endif
11814       if (l.lt.nres-1) then
11815         l1=l+1
11816         l2=l-1
11817       else
11818         l1=l-1
11819         l2=l-2
11820       endif
11821       do ll=1,3
11822 cgrad        ggg1(ll)=eel_turn6*g_contij(ll,1)
11823 cgrad        ggg2(ll)=eel_turn6*g_contij(ll,2)
11824 cgrad        ghalf=0.5d0*ggg1(ll)
11825 cd        ghalf=0.0d0
11826         gturn6ij=eel_turn6*g_contij(ll,1)+ekont*derx_turn(ll,1,1)
11827         gturn6kl=eel_turn6*g_contij(ll,2)+ekont*derx_turn(ll,1,2)
11828         gcorr6_turn(ll,i)=gcorr6_turn(ll,i)!+ghalf
11829      &    +ekont*derx_turn(ll,2,1)
11830         gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
11831         gcorr6_turn(ll,j)=gcorr6_turn(ll,j)!+ghalf
11832      &    +ekont*derx_turn(ll,4,1)
11833         gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
11834         gcorr6_turn_long(ll,j)=gcorr6_turn_long(ll,j)+gturn6ij
11835         gcorr6_turn_long(ll,i)=gcorr6_turn_long(ll,i)-gturn6ij
11836 cgrad        ghalf=0.5d0*ggg2(ll)
11837 cd        ghalf=0.0d0
11838         gcorr6_turn(ll,k)=gcorr6_turn(ll,k)!+ghalf
11839      &    +ekont*derx_turn(ll,2,2)
11840         gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
11841         gcorr6_turn(ll,l)=gcorr6_turn(ll,l)!+ghalf
11842      &    +ekont*derx_turn(ll,4,2)
11843         gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
11844         gcorr6_turn_long(ll,l)=gcorr6_turn_long(ll,l)+gturn6kl
11845         gcorr6_turn_long(ll,k)=gcorr6_turn_long(ll,k)-gturn6kl
11846       enddo
11847 cd      goto 1112
11848 cgrad      do m=i+1,j-1
11849 cgrad        do ll=1,3
11850 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
11851 cgrad        enddo
11852 cgrad      enddo
11853 cgrad      do m=k+1,l-1
11854 cgrad        do ll=1,3
11855 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
11856 cgrad        enddo
11857 cgrad      enddo
11858 cgrad1112  continue
11859 cgrad      do m=i+2,j2
11860 cgrad        do ll=1,3
11861 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
11862 cgrad        enddo
11863 cgrad      enddo
11864 cgrad      do m=k+2,l2
11865 cgrad        do ll=1,3
11866 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
11867 cgrad        enddo
11868 cgrad      enddo
11869 cd      do iii=1,nres-3
11870 cd        write (2,*) iii,g_corr6_loc(iii)
11871 cd      enddo
11872       eello_turn6=ekont*eel_turn6
11873 cd      write (2,*) 'ekont',ekont
11874 cd      write (2,*) 'eel_turn6',ekont*eel_turn6
11875       return
11876       end
11877
11878 C-----------------------------------------------------------------------------
11879       double precision function scalar(u,v)
11880 !DIR$ INLINEALWAYS scalar
11881 #ifndef OSF
11882 cDEC$ ATTRIBUTES FORCEINLINE::scalar
11883 #endif
11884       implicit none
11885       double precision u(3),v(3)
11886 cd      double precision sc
11887 cd      integer i
11888 cd      sc=0.0d0
11889 cd      do i=1,3
11890 cd        sc=sc+u(i)*v(i)
11891 cd      enddo
11892 cd      scalar=sc
11893
11894       scalar=u(1)*v(1)+u(2)*v(2)+u(3)*v(3)
11895       return
11896       end
11897 crc-------------------------------------------------
11898       SUBROUTINE MATVEC2(A1,V1,V2)
11899 !DIR$ INLINEALWAYS MATVEC2
11900 #ifndef OSF
11901 cDEC$ ATTRIBUTES FORCEINLINE::MATVEC2
11902 #endif
11903       implicit real*8 (a-h,o-z)
11904       include 'DIMENSIONS'
11905       DIMENSION A1(2,2),V1(2),V2(2)
11906 c      DO 1 I=1,2
11907 c        VI=0.0
11908 c        DO 3 K=1,2
11909 c    3     VI=VI+A1(I,K)*V1(K)
11910 c        Vaux(I)=VI
11911 c    1 CONTINUE
11912
11913       vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
11914       vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
11915
11916       v2(1)=vaux1
11917       v2(2)=vaux2
11918       END
11919 C---------------------------------------
11920       SUBROUTINE MATMAT2(A1,A2,A3)
11921 #ifndef OSF
11922 cDEC$ ATTRIBUTES FORCEINLINE::MATMAT2
11923 #endif
11924       implicit real*8 (a-h,o-z)
11925       include 'DIMENSIONS'
11926       DIMENSION A1(2,2),A2(2,2),A3(2,2)
11927 c      DIMENSION AI3(2,2)
11928 c        DO  J=1,2
11929 c          A3IJ=0.0
11930 c          DO K=1,2
11931 c           A3IJ=A3IJ+A1(I,K)*A2(K,J)
11932 c          enddo
11933 c          A3(I,J)=A3IJ
11934 c       enddo
11935 c      enddo
11936
11937       ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
11938       ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
11939       ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
11940       ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
11941
11942       A3(1,1)=AI3_11
11943       A3(2,1)=AI3_21
11944       A3(1,2)=AI3_12
11945       A3(2,2)=AI3_22
11946       END
11947
11948 c-------------------------------------------------------------------------
11949       double precision function scalar2(u,v)
11950 !DIR$ INLINEALWAYS scalar2
11951       implicit none
11952       double precision u(2),v(2)
11953       double precision sc
11954       integer i
11955       scalar2=u(1)*v(1)+u(2)*v(2)
11956       return
11957       end
11958
11959 C-----------------------------------------------------------------------------
11960
11961       subroutine transpose2(a,at)
11962 !DIR$ INLINEALWAYS transpose2
11963 #ifndef OSF
11964 cDEC$ ATTRIBUTES FORCEINLINE::transpose2
11965 #endif
11966       implicit none
11967       double precision a(2,2),at(2,2)
11968       at(1,1)=a(1,1)
11969       at(1,2)=a(2,1)
11970       at(2,1)=a(1,2)
11971       at(2,2)=a(2,2)
11972       return
11973       end
11974 c--------------------------------------------------------------------------
11975       subroutine transpose(n,a,at)
11976       implicit none
11977       integer n,i,j
11978       double precision a(n,n),at(n,n)
11979       do i=1,n
11980         do j=1,n
11981           at(j,i)=a(i,j)
11982         enddo
11983       enddo
11984       return
11985       end
11986 C---------------------------------------------------------------------------
11987       subroutine prodmat3(a1,a2,kk,transp,prod)
11988 !DIR$ INLINEALWAYS prodmat3
11989 #ifndef OSF
11990 cDEC$ ATTRIBUTES FORCEINLINE::prodmat3
11991 #endif
11992       implicit none
11993       integer i,j
11994       double precision a1(2,2),a2(2,2),a2t(2,2),kk(2,2),prod(2,2)
11995       logical transp
11996 crc      double precision auxmat(2,2),prod_(2,2)
11997
11998       if (transp) then
11999 crc        call transpose2(kk(1,1),auxmat(1,1))
12000 crc        call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
12001 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
12002
12003            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1)
12004      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
12005            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2)
12006      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
12007            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1)
12008      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
12009            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2)
12010      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
12011
12012       else
12013 crc        call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
12014 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
12015
12016            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1)
12017      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
12018            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2)
12019      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
12020            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1)
12021      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
12022            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2)
12023      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
12024
12025       endif
12026 c      call transpose2(a2(1,1),a2t(1,1))
12027
12028 crc      print *,transp
12029 crc      print *,((prod_(i,j),i=1,2),j=1,2)
12030 crc      print *,((prod(i,j),i=1,2),j=1,2)
12031
12032       return
12033       end
12034 CCC----------------------------------------------
12035       subroutine Eliptransfer(eliptran)
12036       implicit real*8 (a-h,o-z)
12037       include 'DIMENSIONS'
12038       include 'COMMON.GEO'
12039       include 'COMMON.VAR'
12040       include 'COMMON.LOCAL'
12041       include 'COMMON.CHAIN'
12042       include 'COMMON.DERIV'
12043       include 'COMMON.NAMES'
12044       include 'COMMON.INTERACT'
12045       include 'COMMON.IOUNITS'
12046       include 'COMMON.CALC'
12047       include 'COMMON.CONTROL'
12048       include 'COMMON.SPLITELE'
12049       include 'COMMON.SBRIDGE'
12050 C this is done by Adasko
12051 C      print *,"wchodze"
12052 C structure of box:
12053 C      water
12054 C--bordliptop-- buffore starts
12055 C--bufliptop--- here true lipid starts
12056 C      lipid
12057 C--buflipbot--- lipid ends buffore starts
12058 C--bordlipbot--buffore ends
12059       eliptran=0.0
12060       do i=ilip_start,ilip_end
12061 C       do i=1,1
12062         if (itype(i).eq.ntyp1) cycle
12063
12064         positi=(mod(((c(3,i)+c(3,i+1))/2.0d0),boxzsize))
12065         if (positi.le.0.0) positi=positi+boxzsize
12066 C        print *,i
12067 C first for peptide groups
12068 c for each residue check if it is in lipid or lipid water border area
12069        if ((positi.gt.bordlipbot)
12070      &.and.(positi.lt.bordliptop)) then
12071 C the energy transfer exist
12072         if (positi.lt.buflipbot) then
12073 C what fraction I am in
12074          fracinbuf=1.0d0-
12075      &        ((positi-bordlipbot)/lipbufthick)
12076 C lipbufthick is thickenes of lipid buffore
12077          sslip=sscalelip(fracinbuf)
12078          ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
12079          eliptran=eliptran+sslip*pepliptran
12080          gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
12081          gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
12082 C         gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
12083
12084 C        print *,"doing sccale for lower part"
12085 C         print *,i,sslip,fracinbuf,ssgradlip
12086         elseif (positi.gt.bufliptop) then
12087          fracinbuf=1.0d0-((bordliptop-positi)/lipbufthick)
12088          sslip=sscalelip(fracinbuf)
12089          ssgradlip=sscagradlip(fracinbuf)/lipbufthick
12090          eliptran=eliptran+sslip*pepliptran
12091          gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
12092          gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
12093 C         gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
12094 C          print *, "doing sscalefor top part"
12095 C         print *,i,sslip,fracinbuf,ssgradlip
12096         else
12097          eliptran=eliptran+pepliptran
12098 C         print *,"I am in true lipid"
12099         endif
12100 C       else
12101 C       eliptran=elpitran+0.0 ! I am in water
12102        endif
12103        enddo
12104 C       print *, "nic nie bylo w lipidzie?"
12105 C now multiply all by the peptide group transfer factor
12106 C       eliptran=eliptran*pepliptran
12107 C now the same for side chains
12108 CV       do i=1,1
12109        do i=ilip_start,ilip_end
12110         if (itype(i).eq.ntyp1) cycle
12111         positi=(mod(c(3,i+nres),boxzsize))
12112         if (positi.le.0) positi=positi+boxzsize
12113 C       print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop
12114 c for each residue check if it is in lipid or lipid water border area
12115 C       respos=mod(c(3,i+nres),boxzsize)
12116 C       print *,positi,bordlipbot,buflipbot
12117        if ((positi.gt.bordlipbot)
12118      & .and.(positi.lt.bordliptop)) then
12119 C the energy transfer exist
12120         if (positi.lt.buflipbot) then
12121          fracinbuf=1.0d0-
12122      &     ((positi-bordlipbot)/lipbufthick)
12123 C lipbufthick is thickenes of lipid buffore
12124          sslip=sscalelip(fracinbuf)
12125          ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
12126          eliptran=eliptran+sslip*liptranene(itype(i))
12127          gliptranx(3,i)=gliptranx(3,i)
12128      &+ssgradlip*liptranene(itype(i))
12129          gliptranc(3,i-1)= gliptranc(3,i-1)
12130      &+ssgradlip*liptranene(itype(i))
12131 C         print *,"doing sccale for lower part"
12132         elseif (positi.gt.bufliptop) then
12133          fracinbuf=1.0d0-
12134      &((bordliptop-positi)/lipbufthick)
12135          sslip=sscalelip(fracinbuf)
12136          ssgradlip=sscagradlip(fracinbuf)/lipbufthick
12137          eliptran=eliptran+sslip*liptranene(itype(i))
12138          gliptranx(3,i)=gliptranx(3,i)
12139      &+ssgradlip*liptranene(itype(i))
12140          gliptranc(3,i-1)= gliptranc(3,i-1)
12141      &+ssgradlip*liptranene(itype(i))
12142 C          print *, "doing sscalefor top part",sslip,fracinbuf
12143         else
12144          eliptran=eliptran+liptranene(itype(i))
12145 C         print *,"I am in true lipid"
12146         endif
12147         endif ! if in lipid or buffor
12148 C       else
12149 C       eliptran=elpitran+0.0 ! I am in water
12150        enddo
12151        return
12152        end
12153 C---------------------------------------------------------
12154 C AFM soubroutine for constant force
12155        subroutine AFMforce(Eafmforce)
12156        implicit real*8 (a-h,o-z)
12157       include 'DIMENSIONS'
12158       include 'COMMON.GEO'
12159       include 'COMMON.VAR'
12160       include 'COMMON.LOCAL'
12161       include 'COMMON.CHAIN'
12162       include 'COMMON.DERIV'
12163       include 'COMMON.NAMES'
12164       include 'COMMON.INTERACT'
12165       include 'COMMON.IOUNITS'
12166       include 'COMMON.CALC'
12167       include 'COMMON.CONTROL'
12168       include 'COMMON.SPLITELE'
12169       include 'COMMON.SBRIDGE'
12170       real*8 diffafm(3)
12171       dist=0.0d0
12172       Eafmforce=0.0d0
12173       do i=1,3
12174       diffafm(i)=c(i,afmend)-c(i,afmbeg)
12175       dist=dist+diffafm(i)**2
12176       enddo
12177       dist=dsqrt(dist)
12178       Eafmforce=-forceAFMconst*(dist-distafminit)
12179       do i=1,3
12180       gradafm(i,afmend-1)=-forceAFMconst*diffafm(i)/dist
12181       gradafm(i,afmbeg-1)=forceAFMconst*diffafm(i)/dist
12182       enddo
12183 C      print *,'AFM',Eafmforce
12184       return
12185       end
12186 C---------------------------------------------------------
12187 C AFM subroutine with pseudoconstant velocity
12188        subroutine AFMvel(Eafmforce)
12189        implicit real*8 (a-h,o-z)
12190       include 'DIMENSIONS'
12191       include 'COMMON.GEO'
12192       include 'COMMON.VAR'
12193       include 'COMMON.LOCAL'
12194       include 'COMMON.CHAIN'
12195       include 'COMMON.DERIV'
12196       include 'COMMON.NAMES'
12197       include 'COMMON.INTERACT'
12198       include 'COMMON.IOUNITS'
12199       include 'COMMON.CALC'
12200       include 'COMMON.CONTROL'
12201       include 'COMMON.SPLITELE'
12202       include 'COMMON.SBRIDGE'
12203       real*8 diffafm(3)
12204 C Only for check grad COMMENT if not used for checkgrad
12205 C      totT=3.0d0
12206 C--------------------------------------------------------
12207 C      print *,"wchodze"
12208       dist=0.0d0
12209       Eafmforce=0.0d0
12210       do i=1,3
12211       diffafm(i)=c(i,afmend)-c(i,afmbeg)
12212       dist=dist+diffafm(i)**2
12213       enddo
12214       dist=dsqrt(dist)
12215       Eafmforce=0.5d0*forceAFMconst
12216      & *(distafminit+totTafm*velAFMconst-dist)**2
12217 C      Eafmforce=-forceAFMconst*(dist-distafminit)
12218       do i=1,3
12219       gradafm(i,afmend-1)=-forceAFMconst*
12220      &(distafminit+totTafm*velAFMconst-dist)
12221      &*diffafm(i)/dist
12222       gradafm(i,afmbeg-1)=forceAFMconst*
12223      &(distafminit+totTafm*velAFMconst-dist)
12224      &*diffafm(i)/dist
12225       enddo
12226 C      print *,'AFM',Eafmforce,totTafm*velAFMconst,dist
12227       return
12228       end
12229 C-----------------------------------------------------------
12230 C first for shielding is setting of function of side-chains
12231        subroutine set_shield_fac
12232       implicit real*8 (a-h,o-z)
12233       include 'DIMENSIONS'
12234       include 'COMMON.CHAIN'
12235       include 'COMMON.DERIV'
12236       include 'COMMON.IOUNITS'
12237       include 'COMMON.SHIELD'
12238       include 'COMMON.INTERACT'
12239 C this is the squar root 77 devided by 81 the epislion in lipid (in protein)
12240       double precision div77_81/0.974996043d0/,
12241      &div4_81/0.2222222222d0/,sh_frac_dist_grad(3)
12242
12243 C the vector between center of side_chain and peptide group
12244        double precision pep_side(3),long,side_calf(3),
12245      &pept_group(3),costhet_grad(3),cosphi_grad_long(3),
12246      &cosphi_grad_loc(3),pep_side_norm(3),side_calf_norm(3)
12247 C the line belowe needs to be changed for FGPROC>1
12248       do i=1,nres-1
12249       if ((itype(i).eq.ntyp1).and.itype(i+1).eq.ntyp1) cycle
12250       ishield_list(i)=0
12251 Cif there two consequtive dummy atoms there is no peptide group between them
12252 C the line below has to be changed for FGPROC>1
12253       VolumeTotal=0.0
12254       do k=1,nres
12255        if ((itype(k).eq.ntyp1).or.(itype(k).eq.10)) cycle
12256        dist_pep_side=0.0
12257        dist_side_calf=0.0
12258        do j=1,3
12259 C first lets set vector conecting the ithe side-chain with kth side-chain
12260       pep_side(j)=c(j,k+nres)-(c(j,i)+c(j,i+1))/2.0d0
12261 C      pep_side(j)=2.0d0
12262 C and vector conecting the side-chain with its proper calfa
12263       side_calf(j)=c(j,k+nres)-c(j,k)
12264 C      side_calf(j)=2.0d0
12265       pept_group(j)=c(j,i)-c(j,i+1)
12266 C lets have their lenght
12267       dist_pep_side=pep_side(j)**2+dist_pep_side
12268       dist_side_calf=dist_side_calf+side_calf(j)**2
12269       dist_pept_group=dist_pept_group+pept_group(j)**2
12270       enddo
12271        dist_pep_side=dsqrt(dist_pep_side)
12272        dist_pept_group=dsqrt(dist_pept_group)
12273        dist_side_calf=dsqrt(dist_side_calf)
12274       do j=1,3
12275         pep_side_norm(j)=pep_side(j)/dist_pep_side
12276         side_calf_norm(j)=dist_side_calf
12277       enddo
12278 C now sscale fraction
12279        sh_frac_dist=-(dist_pep_side-rpp(1,1)-buff_shield)/buff_shield
12280 C       print *,buff_shield,"buff"
12281 C now sscale
12282         if (sh_frac_dist.le.0.0) cycle
12283 C If we reach here it means that this side chain reaches the shielding sphere
12284 C Lets add him to the list for gradient
12285         ishield_list(i)=ishield_list(i)+1
12286 C ishield_list is a list of non 0 side-chain that contribute to factor gradient
12287 C this list is essential otherwise problem would be O3
12288         shield_list(ishield_list(i),i)=k
12289 C Lets have the sscale value
12290         if (sh_frac_dist.gt.1.0) then
12291          scale_fac_dist=1.0d0
12292          do j=1,3
12293          sh_frac_dist_grad(j)=0.0d0
12294          enddo
12295         else
12296          scale_fac_dist=-sh_frac_dist*sh_frac_dist
12297      &                   *(2.0*sh_frac_dist-3.0d0)
12298          fac_help_scale=6.0*(sh_frac_dist-sh_frac_dist**2)
12299      &                  /dist_pep_side/buff_shield*0.5
12300 C remember for the final gradient multiply sh_frac_dist_grad(j)
12301 C for side_chain by factor -2 !
12302          do j=1,3
12303          sh_frac_dist_grad(j)=fac_help_scale*pep_side(j)
12304 C         print *,"jestem",scale_fac_dist,fac_help_scale,
12305 C     &                    sh_frac_dist_grad(j)
12306          enddo
12307         endif
12308 C        if ((i.eq.3).and.(k.eq.2)) then
12309 C        print *,i,sh_frac_dist,dist_pep,fac_help_scale,scale_fac_dist
12310 C     & ,"TU"
12311 C        endif
12312
12313 C this is what is now we have the distance scaling now volume...
12314       short=short_r_sidechain(itype(k))
12315       long=long_r_sidechain(itype(k))
12316       costhet=1.0d0/dsqrt(1.0+short**2/dist_pep_side**2)
12317 C now costhet_grad
12318 C       costhet=0.0d0
12319        costhet_fac=costhet**3*short**2*(-0.5)/dist_pep_side**4
12320 C       costhet_fac=0.0d0
12321        do j=1,3
12322          costhet_grad(j)=costhet_fac*pep_side(j)
12323        enddo
12324 C remember for the final gradient multiply costhet_grad(j)
12325 C for side_chain by factor -2 !
12326 C fac alfa is angle between CB_k,CA_k, CA_i,CA_i+1
12327 C pep_side0pept_group is vector multiplication
12328       pep_side0pept_group=0.0
12329       do j=1,3
12330       pep_side0pept_group=pep_side0pept_group+pep_side(j)*side_calf(j)
12331       enddo
12332       cosalfa=(pep_side0pept_group/
12333      & (dist_pep_side*dist_side_calf))
12334       fac_alfa_sin=1.0-cosalfa**2
12335       fac_alfa_sin=dsqrt(fac_alfa_sin)
12336       rkprim=fac_alfa_sin*(long-short)+short
12337 C now costhet_grad
12338        cosphi=1.0d0/dsqrt(1.0+rkprim**2/dist_pep_side**2)
12339        cosphi_fac=cosphi**3*rkprim**2*(-0.5)/dist_pep_side**4
12340
12341        do j=1,3
12342          cosphi_grad_long(j)=cosphi_fac*pep_side(j)
12343      &+cosphi**3*0.5/dist_pep_side**2*(-rkprim)
12344      &*(long-short)/fac_alfa_sin*cosalfa/
12345      &((dist_pep_side*dist_side_calf))*
12346      &((side_calf(j))-cosalfa*
12347      &((pep_side(j)/dist_pep_side)*dist_side_calf))
12348
12349         cosphi_grad_loc(j)=cosphi**3*0.5/dist_pep_side**2*(-rkprim)
12350      &*(long-short)/fac_alfa_sin*cosalfa
12351      &/((dist_pep_side*dist_side_calf))*
12352      &(pep_side(j)-
12353      &cosalfa*side_calf(j)/dist_side_calf*dist_pep_side)
12354        enddo
12355
12356       VofOverlap=VSolvSphere/2.0d0*(1.0-costhet)*(1.0-cosphi)
12357      &                    /VSolvSphere_div
12358      &                    *wshield
12359 C now the gradient...
12360 C grad_shield is gradient of Calfa for peptide groups
12361 C      write(iout,*) "shield_compon",i,k,VSolvSphere,scale_fac_dist,
12362 C     &               costhet,cosphi
12363 C       write(iout,*) "cosphi_compon",i,k,pep_side0pept_group,
12364 C     & dist_pep_side,dist_side_calf,c(1,k+nres),c(1,k),itype(k)
12365       do j=1,3
12366       grad_shield(j,i)=grad_shield(j,i)
12367 C gradient po skalowaniu
12368      &                +(sh_frac_dist_grad(j)
12369 C  gradient po costhet
12370      &-scale_fac_dist*costhet_grad(j)/(1.0-costhet)
12371      &-scale_fac_dist*(cosphi_grad_long(j))
12372      &/(1.0-cosphi) )*div77_81
12373      &*VofOverlap
12374 C grad_shield_side is Cbeta sidechain gradient
12375       grad_shield_side(j,ishield_list(i),i)=
12376      &        (sh_frac_dist_grad(j)*(-2.0d0)
12377      &       +scale_fac_dist*costhet_grad(j)*2.0d0/(1.0-costhet)
12378      &       +scale_fac_dist*(cosphi_grad_long(j))
12379      &        *2.0d0/(1.0-cosphi))
12380      &        *div77_81*VofOverlap
12381
12382        grad_shield_loc(j,ishield_list(i),i)=
12383      &   scale_fac_dist*cosphi_grad_loc(j)
12384      &        *2.0d0/(1.0-cosphi)
12385      &        *div77_81*VofOverlap
12386       enddo
12387       VolumeTotal=VolumeTotal+VofOverlap*scale_fac_dist
12388       enddo
12389       fac_shield(i)=VolumeTotal*div77_81+div4_81
12390 c      write(2,*) "TOTAL VOLUME",i,VolumeTotal,fac_shield(i)
12391       enddo
12392       return
12393       end
12394 C--------------------------------------------------------------------------
12395       double precision function tschebyshev(m,n,x,y)
12396       implicit none
12397       include "DIMENSIONS"
12398       integer i,m,n
12399       double precision x(n),y,yy(0:maxvar),aux
12400 c Tschebyshev polynomial. Note that the first term is omitted
12401 c m=0: the constant term is included
12402 c m=1: the constant term is not included
12403       yy(0)=1.0d0
12404       yy(1)=y
12405       do i=2,n
12406         yy(i)=2*yy(1)*yy(i-1)-yy(i-2)
12407       enddo
12408       aux=0.0d0
12409       do i=m,n
12410         aux=aux+x(i)*yy(i)
12411       enddo
12412       tschebyshev=aux
12413       return
12414       end
12415 C--------------------------------------------------------------------------
12416       double precision function gradtschebyshev(m,n,x,y)
12417       implicit none
12418       include "DIMENSIONS"
12419       integer i,m,n
12420       double precision x(n+1),y,yy(0:maxvar),aux
12421 c Tschebyshev polynomial. Note that the first term is omitted
12422 c m=0: the constant term is included
12423 c m=1: the constant term is not included
12424       yy(0)=1.0d0
12425       yy(1)=2.0d0*y
12426       do i=2,n
12427         yy(i)=2*y*yy(i-1)-yy(i-2)
12428       enddo
12429       aux=0.0d0
12430       do i=m,n
12431         aux=aux+x(i+1)*yy(i)*(i+1)
12432 C        print *, x(i+1),yy(i),i
12433       enddo
12434       gradtschebyshev=aux
12435       return
12436       end
12437 C------------------------------------------------------------------------
12438 C first for shielding is setting of function of side-chains
12439        subroutine set_shield_fac2
12440       implicit real*8 (a-h,o-z)
12441       include 'DIMENSIONS'
12442       include 'COMMON.CHAIN'
12443       include 'COMMON.DERIV'
12444       include 'COMMON.IOUNITS'
12445       include 'COMMON.SHIELD'
12446       include 'COMMON.INTERACT'
12447 C this is the squar root 77 devided by 81 the epislion in lipid (in protein)
12448       double precision div77_81/0.974996043d0/,
12449      &div4_81/0.2222222222d0/,sh_frac_dist_grad(3)
12450
12451 C the vector between center of side_chain and peptide group
12452        double precision pep_side(3),long,side_calf(3),
12453      &pept_group(3),costhet_grad(3),cosphi_grad_long(3),
12454      &cosphi_grad_loc(3),pep_side_norm(3),side_calf_norm(3)
12455 C the line belowe needs to be changed for FGPROC>1
12456       do i=1,nres-1
12457       if ((itype(i).eq.ntyp1).and.itype(i+1).eq.ntyp1) cycle
12458       ishield_list(i)=0
12459 Cif there two consequtive dummy atoms there is no peptide group between them
12460 C the line below has to be changed for FGPROC>1
12461       VolumeTotal=0.0
12462       do k=1,nres
12463        if ((itype(k).eq.ntyp1).or.(itype(k).eq.10)) cycle
12464        dist_pep_side=0.0
12465        dist_side_calf=0.0
12466        do j=1,3
12467 C first lets set vector conecting the ithe side-chain with kth side-chain
12468       pep_side(j)=c(j,k+nres)-(c(j,i)+c(j,i+1))/2.0d0
12469 C      pep_side(j)=2.0d0
12470 C and vector conecting the side-chain with its proper calfa
12471       side_calf(j)=c(j,k+nres)-c(j,k)
12472 C      side_calf(j)=2.0d0
12473       pept_group(j)=c(j,i)-c(j,i+1)
12474 C lets have their lenght
12475       dist_pep_side=pep_side(j)**2+dist_pep_side
12476       dist_side_calf=dist_side_calf+side_calf(j)**2
12477       dist_pept_group=dist_pept_group+pept_group(j)**2
12478       enddo
12479        dist_pep_side=dsqrt(dist_pep_side)
12480        dist_pept_group=dsqrt(dist_pept_group)
12481        dist_side_calf=dsqrt(dist_side_calf)
12482       do j=1,3
12483         pep_side_norm(j)=pep_side(j)/dist_pep_side
12484         side_calf_norm(j)=dist_side_calf
12485       enddo
12486 C now sscale fraction
12487        sh_frac_dist=-(dist_pep_side-rpp(1,1)-buff_shield)/buff_shield
12488 C       print *,buff_shield,"buff"
12489 C now sscale
12490         if (sh_frac_dist.le.0.0) cycle
12491 C If we reach here it means that this side chain reaches the shielding sphere
12492 C Lets add him to the list for gradient
12493         ishield_list(i)=ishield_list(i)+1
12494 C ishield_list is a list of non 0 side-chain that contribute to factor gradient
12495 C this list is essential otherwise problem would be O3
12496         shield_list(ishield_list(i),i)=k
12497 C Lets have the sscale value
12498         if (sh_frac_dist.gt.1.0) then
12499          scale_fac_dist=1.0d0
12500          do j=1,3
12501          sh_frac_dist_grad(j)=0.0d0
12502          enddo
12503         else
12504          scale_fac_dist=-sh_frac_dist*sh_frac_dist
12505      &                   *(2.0d0*sh_frac_dist-3.0d0)
12506          fac_help_scale=6.0d0*(sh_frac_dist-sh_frac_dist**2)
12507      &                  /dist_pep_side/buff_shield*0.5d0
12508 C remember for the final gradient multiply sh_frac_dist_grad(j)
12509 C for side_chain by factor -2 !
12510          do j=1,3
12511          sh_frac_dist_grad(j)=fac_help_scale*pep_side(j)
12512 C         sh_frac_dist_grad(j)=0.0d0
12513 C         scale_fac_dist=1.0d0
12514 C         print *,"jestem",scale_fac_dist,fac_help_scale,
12515 C     &                    sh_frac_dist_grad(j)
12516          enddo
12517         endif
12518 C this is what is now we have the distance scaling now volume...
12519       short=short_r_sidechain(itype(k))
12520       long=long_r_sidechain(itype(k))
12521       costhet=1.0d0/dsqrt(1.0d0+short**2/dist_pep_side**2)
12522       sinthet=short/dist_pep_side*costhet
12523 C now costhet_grad
12524 C       costhet=0.6d0
12525 C       sinthet=0.8
12526        costhet_fac=costhet**3*short**2*(-0.5d0)/dist_pep_side**4
12527 C       sinthet_fac=costhet**2*0.5d0*(short**3/dist_pep_side**4*costhet
12528 C     &             -short/dist_pep_side**2/costhet)
12529 C       costhet_fac=0.0d0
12530        do j=1,3
12531          costhet_grad(j)=costhet_fac*pep_side(j)
12532        enddo
12533 C remember for the final gradient multiply costhet_grad(j)
12534 C for side_chain by factor -2 !
12535 C fac alfa is angle between CB_k,CA_k, CA_i,CA_i+1
12536 C pep_side0pept_group is vector multiplication
12537       pep_side0pept_group=0.0d0
12538       do j=1,3
12539       pep_side0pept_group=pep_side0pept_group+pep_side(j)*side_calf(j)
12540       enddo
12541       cosalfa=(pep_side0pept_group/
12542      & (dist_pep_side*dist_side_calf))
12543       fac_alfa_sin=1.0d0-cosalfa**2
12544       fac_alfa_sin=dsqrt(fac_alfa_sin)
12545       rkprim=fac_alfa_sin*(long-short)+short
12546 C      rkprim=short
12547
12548 C now costhet_grad
12549        cosphi=1.0d0/dsqrt(1.0d0+rkprim**2/dist_pep_side**2)
12550 C       cosphi=0.6
12551        cosphi_fac=cosphi**3*rkprim**2*(-0.5d0)/dist_pep_side**4
12552        sinphi=rkprim/dist_pep_side/dsqrt(1.0d0+rkprim**2/
12553      &      dist_pep_side**2)
12554 C       sinphi=0.8
12555        do j=1,3
12556          cosphi_grad_long(j)=cosphi_fac*pep_side(j)
12557      &+cosphi**3*0.5d0/dist_pep_side**2*(-rkprim)
12558      &*(long-short)/fac_alfa_sin*cosalfa/
12559      &((dist_pep_side*dist_side_calf))*
12560      &((side_calf(j))-cosalfa*
12561      &((pep_side(j)/dist_pep_side)*dist_side_calf))
12562 C       cosphi_grad_long(j)=0.0d0
12563         cosphi_grad_loc(j)=cosphi**3*0.5d0/dist_pep_side**2*(-rkprim)
12564      &*(long-short)/fac_alfa_sin*cosalfa
12565      &/((dist_pep_side*dist_side_calf))*
12566      &(pep_side(j)-
12567      &cosalfa*side_calf(j)/dist_side_calf*dist_pep_side)
12568 C       cosphi_grad_loc(j)=0.0d0
12569        enddo
12570 C      print *,sinphi,sinthet
12571 c      write (iout,*) "VSolvSphere",VSolvSphere," VSolvSphere_div",
12572 c     &  VSolvSphere_div," sinphi",sinphi," sinthet",sinthet
12573       VofOverlap=VSolvSphere/2.0d0*(1.0d0-dsqrt(1.0d0-sinphi*sinthet))
12574      &                    /VSolvSphere_div
12575 C     &                    *wshield
12576 C now the gradient...
12577       do j=1,3
12578       grad_shield(j,i)=grad_shield(j,i)
12579 C gradient po skalowaniu
12580      &                +(sh_frac_dist_grad(j)*VofOverlap
12581 C  gradient po costhet
12582      &       +scale_fac_dist*VSolvSphere/VSolvSphere_div/4.0d0*
12583      &(1.0d0/(-dsqrt(1.0d0-sinphi*sinthet))*(
12584      &       sinphi/sinthet*costhet*costhet_grad(j)
12585      &      +sinthet/sinphi*cosphi*cosphi_grad_long(j)))
12586      & )*wshield
12587 C grad_shield_side is Cbeta sidechain gradient
12588       grad_shield_side(j,ishield_list(i),i)=
12589      &        (sh_frac_dist_grad(j)*(-2.0d0)
12590      &        *VofOverlap
12591      &       -scale_fac_dist*VSolvSphere/VSolvSphere_div/2.0d0*
12592      &(1.0d0/(-dsqrt(1.0d0-sinphi*sinthet))*(
12593      &       sinphi/sinthet*costhet*costhet_grad(j)
12594      &      +sinthet/sinphi*cosphi*cosphi_grad_long(j)))
12595      &       )*wshield
12596
12597        grad_shield_loc(j,ishield_list(i),i)=
12598      &       scale_fac_dist*VSolvSphere/VSolvSphere_div/2.0d0*
12599      &(1.0d0/(dsqrt(1.0d0-sinphi*sinthet))*(
12600      &       sinthet/sinphi*cosphi*cosphi_grad_loc(j)
12601      &        ))
12602      &        *wshield
12603       enddo
12604 c      write (iout,*) "VofOverlap",VofOverlap," scale_fac_dist",
12605 c     & scale_fac_dist
12606       VolumeTotal=VolumeTotal+VofOverlap*scale_fac_dist
12607       enddo
12608       fac_shield(i)=VolumeTotal*wshield+(1.0d0-wshield)
12609 c      write(2,*) "TOTAL VOLUME",i,VolumeTotal,fac_shield(i),
12610 c     &  " wshield",wshield
12611 c      write(2,*) "TU",rpp(1,1),short,long,buff_shield
12612       enddo
12613       return
12614       end
12615 C-----------------------------------------------------------------------
12616 C-----------------------------------------------------------
12617 C This subroutine is to mimic the histone like structure but as well can be
12618 C utilizet to nanostructures (infinit) small modification has to be used to
12619 C make it finite (z gradient at the ends has to be changes as well as the x,y
12620 C gradient has to be modified at the ends
12621 C The energy function is Kihara potential
12622 C E=4esp*((sigma/(r-r0))^12 - (sigma/(r-r0))^6)
12623 C 4eps is depth of well sigma is r_minimum r is distance from center of tube
12624 C and r0 is the excluded size of nanotube (can be set to 0 if we want just a
12625 C simple Kihara potential
12626       subroutine calctube(Etube)
12627        implicit real*8 (a-h,o-z)
12628       include 'DIMENSIONS'
12629       include 'COMMON.GEO'
12630       include 'COMMON.VAR'
12631       include 'COMMON.LOCAL'
12632       include 'COMMON.CHAIN'
12633       include 'COMMON.DERIV'
12634       include 'COMMON.NAMES'
12635       include 'COMMON.INTERACT'
12636       include 'COMMON.IOUNITS'
12637       include 'COMMON.CALC'
12638       include 'COMMON.CONTROL'
12639       include 'COMMON.SPLITELE'
12640       include 'COMMON.SBRIDGE'
12641       double precision tub_r,vectube(3),enetube(maxres*2)
12642       Etube=0.0d0
12643       do i=1,2*nres
12644         enetube(i)=0.0d0
12645       enddo
12646 C first we calculate the distance from tube center
12647 C first sugare-phosphate group for NARES this would be peptide group
12648 C for UNRES
12649       do i=1,nres
12650 C lets ommit dummy atoms for now
12651        if ((itype(i).eq.ntyp1).or.(itype(i+1).eq.ntyp1)) cycle
12652 C now calculate distance from center of tube and direction vectors
12653       vectube(1)=mod((c(1,i)+c(1,i+1))/2.0d0,boxxsize)
12654           if (vectube(1).lt.0) vectube(1)=vectube(1)+boxxsize
12655       vectube(2)=mod((c(2,i)+c(2,i+1))/2.0d0,boxxsize)
12656           if (vectube(2).lt.0) vectube(2)=vectube(2)+boxxsize
12657       vectube(1)=vectube(1)-tubecenter(1)
12658       vectube(2)=vectube(2)-tubecenter(2)
12659
12660 C      print *,"x",(c(1,i)+c(1,i+1))/2.0d0,tubecenter(1)
12661 C      print *,"y",(c(2,i)+c(2,i+1))/2.0d0,tubecenter(2)
12662
12663 C as the tube is infinity we do not calculate the Z-vector use of Z
12664 C as chosen axis
12665       vectube(3)=0.0d0
12666 C now calculte the distance
12667        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
12668 C now normalize vector
12669       vectube(1)=vectube(1)/tub_r
12670       vectube(2)=vectube(2)/tub_r
12671 C calculte rdiffrence between r and r0
12672       rdiff=tub_r-tubeR0
12673 C and its 6 power
12674       rdiff6=rdiff**6.0d0
12675 C for vectorization reasons we will sumup at the end to avoid depenence of previous
12676        enetube(i)=pep_aa_tube/rdiff6**2.0d0-pep_bb_tube/rdiff6
12677 C       write(iout,*) "TU13",i,rdiff6,enetube(i)
12678 C       print *,rdiff,rdiff6,pep_aa_tube
12679 C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
12680 C now we calculate gradient
12681        fac=(-12.0d0*pep_aa_tube/rdiff6+
12682      &       6.0d0*pep_bb_tube)/rdiff6/rdiff
12683 C       write(iout,'(a5,i4,f12.1,3f12.5)') "TU13",i,rdiff6,enetube(i),
12684 C     &rdiff,fac
12685
12686 C now direction of gg_tube vector
12687         do j=1,3
12688         gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac/2.0d0
12689         gg_tube(j,i)=gg_tube(j,i)+vectube(j)*fac/2.0d0
12690         enddo
12691         enddo
12692 C basically thats all code now we split for side-chains (REMEMBER to sum up at the END)
12693         do i=1,nres
12694 C Lets not jump over memory as we use many times iti
12695          iti=itype(i)
12696 C lets ommit dummy atoms for now
12697          if ((iti.eq.ntyp1)
12698 C in UNRES uncomment the line below as GLY has no side-chain...
12699 C      .or.(iti.eq.10)
12700      &   ) cycle
12701           vectube(1)=c(1,i+nres)
12702           vectube(1)=mod(vectube(1),boxxsize)
12703           if (vectube(1).lt.0) vectube(1)=vectube(1)+boxxsize
12704           vectube(2)=c(2,i+nres)
12705           vectube(2)=mod(vectube(2),boxxsize)
12706           if (vectube(2).lt.0) vectube(2)=vectube(2)+boxxsize
12707
12708       vectube(1)=vectube(1)-tubecenter(1)
12709       vectube(2)=vectube(2)-tubecenter(2)
12710
12711 C as the tube is infinity we do not calculate the Z-vector use of Z
12712 C as chosen axis
12713       vectube(3)=0.0d0
12714 C now calculte the distance
12715        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
12716 C now normalize vector
12717       vectube(1)=vectube(1)/tub_r
12718       vectube(2)=vectube(2)/tub_r
12719 C calculte rdiffrence between r and r0
12720       rdiff=tub_r-tubeR0
12721 C and its 6 power
12722       rdiff6=rdiff**6.0d0
12723 C for vectorization reasons we will sumup at the end to avoid depenence of previous
12724        sc_aa_tube=sc_aa_tube_par(iti)
12725        sc_bb_tube=sc_bb_tube_par(iti)
12726        enetube(i+nres)=sc_aa_tube/rdiff6**2.0d0-sc_bb_tube/rdiff6
12727 C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
12728 C now we calculate gradient
12729        fac=-12.0d0*sc_aa_tube/rdiff6**2.0d0/rdiff+
12730      &       6.0d0*sc_bb_tube/rdiff6/rdiff
12731 C now direction of gg_tube vector
12732          do j=1,3
12733           gg_tube_SC(j,i)=gg_tube_SC(j,i)+vectube(j)*fac
12734           gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac
12735          enddo
12736         enddo
12737         do i=1,2*nres
12738           Etube=Etube+enetube(i)
12739         enddo
12740 C        print *,"ETUBE", etube
12741         return
12742         end
12743 C TO DO 1) add to total energy
12744 C       2) add to gradient summation
12745 C       3) add reading parameters (AND of course oppening of PARAM file)
12746 C       4) add reading the center of tube
12747 C       5) add COMMONs
12748 C       6) add to zerograd
12749
12750 C-----------------------------------------------------------------------
12751 C-----------------------------------------------------------
12752 C This subroutine is to mimic the histone like structure but as well can be
12753 C utilizet to nanostructures (infinit) small modification has to be used to
12754 C make it finite (z gradient at the ends has to be changes as well as the x,y
12755 C gradient has to be modified at the ends
12756 C The energy function is Kihara potential
12757 C E=4esp*((sigma/(r-r0))^12 - (sigma/(r-r0))^6)
12758 C 4eps is depth of well sigma is r_minimum r is distance from center of tube
12759 C and r0 is the excluded size of nanotube (can be set to 0 if we want just a
12760 C simple Kihara potential
12761       subroutine calctube2(Etube)
12762        implicit real*8 (a-h,o-z)
12763       include 'DIMENSIONS'
12764       include 'COMMON.GEO'
12765       include 'COMMON.VAR'
12766       include 'COMMON.LOCAL'
12767       include 'COMMON.CHAIN'
12768       include 'COMMON.DERIV'
12769       include 'COMMON.NAMES'
12770       include 'COMMON.INTERACT'
12771       include 'COMMON.IOUNITS'
12772       include 'COMMON.CALC'
12773       include 'COMMON.CONTROL'
12774       include 'COMMON.SPLITELE'
12775       include 'COMMON.SBRIDGE'
12776       double precision tub_r,vectube(3),enetube(maxres*2)
12777       Etube=0.0d0
12778       do i=1,2*nres
12779         enetube(i)=0.0d0
12780       enddo
12781 C first we calculate the distance from tube center
12782 C first sugare-phosphate group for NARES this would be peptide group
12783 C for UNRES
12784       do i=1,nres
12785 C lets ommit dummy atoms for now
12786        if ((itype(i).eq.ntyp1).or.(itype(i+1).eq.ntyp1)) cycle
12787 C now calculate distance from center of tube and direction vectors
12788       vectube(1)=mod((c(1,i)+c(1,i+1))/2.0d0,boxxsize)
12789           if (vectube(1).lt.0) vectube(1)=vectube(1)+boxxsize
12790       vectube(2)=mod((c(2,i)+c(2,i+1))/2.0d0,boxxsize)
12791           if (vectube(2).lt.0) vectube(2)=vectube(2)+boxxsize
12792       vectube(1)=vectube(1)-tubecenter(1)
12793       vectube(2)=vectube(2)-tubecenter(2)
12794
12795 C      print *,"x",(c(1,i)+c(1,i+1))/2.0d0,tubecenter(1)
12796 C      print *,"y",(c(2,i)+c(2,i+1))/2.0d0,tubecenter(2)
12797
12798 C as the tube is infinity we do not calculate the Z-vector use of Z
12799 C as chosen axis
12800       vectube(3)=0.0d0
12801 C now calculte the distance
12802        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
12803 C now normalize vector
12804       vectube(1)=vectube(1)/tub_r
12805       vectube(2)=vectube(2)/tub_r
12806 C calculte rdiffrence between r and r0
12807       rdiff=tub_r-tubeR0
12808 C and its 6 power
12809       rdiff6=rdiff**6.0d0
12810 C for vectorization reasons we will sumup at the end to avoid depenence of previous
12811        enetube(i)=pep_aa_tube/rdiff6**2.0d0-pep_bb_tube/rdiff6
12812 C       write(iout,*) "TU13",i,rdiff6,enetube(i)
12813 C       print *,rdiff,rdiff6,pep_aa_tube
12814 C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
12815 C now we calculate gradient
12816        fac=(-12.0d0*pep_aa_tube/rdiff6+
12817      &       6.0d0*pep_bb_tube)/rdiff6/rdiff
12818 C       write(iout,'(a5,i4,f12.1,3f12.5)') "TU13",i,rdiff6,enetube(i),
12819 C     &rdiff,fac
12820
12821 C now direction of gg_tube vector
12822         do j=1,3
12823         gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac/2.0d0
12824         gg_tube(j,i)=gg_tube(j,i)+vectube(j)*fac/2.0d0
12825         enddo
12826         enddo
12827 C basically thats all code now we split for side-chains (REMEMBER to sum up at the END)
12828         do i=1,nres
12829 C Lets not jump over memory as we use many times iti
12830          iti=itype(i)
12831 C lets ommit dummy atoms for now
12832          if ((iti.eq.ntyp1)
12833 C in UNRES uncomment the line below as GLY has no side-chain...
12834      &      .or.(iti.eq.10)
12835      &   ) cycle
12836           vectube(1)=c(1,i+nres)
12837           vectube(1)=mod(vectube(1),boxxsize)
12838           if (vectube(1).lt.0) vectube(1)=vectube(1)+boxxsize
12839           vectube(2)=c(2,i+nres)
12840           vectube(2)=mod(vectube(2),boxxsize)
12841           if (vectube(2).lt.0) vectube(2)=vectube(2)+boxxsize
12842
12843       vectube(1)=vectube(1)-tubecenter(1)
12844       vectube(2)=vectube(2)-tubecenter(2)
12845 C THIS FRAGMENT MAKES TUBE FINITE
12846         positi=(mod(c(3,i+nres),boxzsize))
12847         if (positi.le.0) positi=positi+boxzsize
12848 C       print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop
12849 c for each residue check if it is in lipid or lipid water border area
12850 C       respos=mod(c(3,i+nres),boxzsize)
12851        print *,positi,bordtubebot,buftubebot,bordtubetop
12852        if ((positi.gt.bordtubebot)
12853      & .and.(positi.lt.bordtubetop)) then
12854 C the energy transfer exist
12855         if (positi.lt.buftubebot) then
12856          fracinbuf=1.0d0-
12857      &     ((positi-bordtubebot)/tubebufthick)
12858 C lipbufthick is thickenes of lipid buffore
12859          sstube=sscalelip(fracinbuf)
12860          ssgradtube=-sscagradlip(fracinbuf)/tubebufthick
12861          print *,ssgradtube, sstube,tubetranene(itype(i))
12862          enetube(i+nres)=enetube(i+nres)+sstube*tubetranene(itype(i))
12863          gg_tube_SC(3,i)=gg_tube_SC(3,i)
12864      &+ssgradtube*tubetranene(itype(i))
12865          gg_tube(3,i-1)= gg_tube(3,i-1)
12866      &+ssgradtube*tubetranene(itype(i))
12867 C         print *,"doing sccale for lower part"
12868         elseif (positi.gt.buftubetop) then
12869          fracinbuf=1.0d0-
12870      &((bordtubetop-positi)/tubebufthick)
12871          sstube=sscalelip(fracinbuf)
12872          ssgradtube=sscagradlip(fracinbuf)/tubebufthick
12873          enetube(i+nres)=enetube(i+nres)+sstube*tubetranene(itype(i))
12874 C         gg_tube_SC(3,i)=gg_tube_SC(3,i)
12875 C     &+ssgradtube*tubetranene(itype(i))
12876 C         gg_tube(3,i-1)= gg_tube(3,i-1)
12877 C     &+ssgradtube*tubetranene(itype(i))
12878 C          print *, "doing sscalefor top part",sslip,fracinbuf
12879         else
12880          sstube=1.0d0
12881          ssgradtube=0.0d0
12882          enetube(i+nres)=enetube(i+nres)+sstube*tubetranene(itype(i))
12883 C         print *,"I am in true lipid"
12884         endif
12885         else
12886 C          sstube=0.0d0
12887 C          ssgradtube=0.0d0
12888         cycle
12889         endif ! if in lipid or buffor
12890 CEND OF FINITE FRAGMENT
12891 C as the tube is infinity we do not calculate the Z-vector use of Z
12892 C as chosen axis
12893       vectube(3)=0.0d0
12894 C now calculte the distance
12895        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
12896 C now normalize vector
12897       vectube(1)=vectube(1)/tub_r
12898       vectube(2)=vectube(2)/tub_r
12899 C calculte rdiffrence between r and r0
12900       rdiff=tub_r-tubeR0
12901 C and its 6 power
12902       rdiff6=rdiff**6.0d0
12903 C for vectorization reasons we will sumup at the end to avoid depenence of previous
12904        sc_aa_tube=sc_aa_tube_par(iti)
12905        sc_bb_tube=sc_bb_tube_par(iti)
12906        enetube(i+nres)=(sc_aa_tube/rdiff6**2.0d0-sc_bb_tube/rdiff6)
12907      &                 *sstube+enetube(i+nres)
12908 C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
12909 C now we calculate gradient
12910        fac=(-12.0d0*sc_aa_tube/rdiff6**2.0d0/rdiff+
12911      &       6.0d0*sc_bb_tube/rdiff6/rdiff)*sstube
12912 C now direction of gg_tube vector
12913          do j=1,3
12914           gg_tube_SC(j,i)=gg_tube_SC(j,i)+vectube(j)*fac
12915           gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac
12916          enddo
12917          gg_tube_SC(3,i)=gg_tube_SC(3,i)
12918      &+ssgradtube*enetube(i+nres)/sstube
12919          gg_tube(3,i-1)= gg_tube(3,i-1)
12920      &+ssgradtube*enetube(i+nres)/sstube
12921
12922         enddo
12923         do i=1,2*nres
12924           Etube=Etube+enetube(i)
12925         enddo
12926 C        print *,"ETUBE", etube
12927         return
12928         end
12929 C TO DO 1) add to total energy
12930 C       2) add to gradient summation
12931 C       3) add reading parameters (AND of course oppening of PARAM file)
12932 C       4) add reading the center of tube
12933 C       5) add COMMONs
12934 C       6) add to zerograd
12935 c----------------------------------------------------------------------------
12936       subroutine e_saxs(Esaxs_constr)
12937       implicit none
12938       include 'DIMENSIONS'
12939 #ifdef MPI
12940       include "mpif.h"
12941       include "COMMON.SETUP"
12942       integer IERR
12943 #endif
12944       include 'COMMON.SBRIDGE'
12945       include 'COMMON.CHAIN'
12946       include 'COMMON.GEO'
12947       include 'COMMON.DERIV'
12948       include 'COMMON.LOCAL'
12949       include 'COMMON.INTERACT'
12950       include 'COMMON.VAR'
12951       include 'COMMON.IOUNITS'
12952       include 'COMMON.MD'
12953 #ifndef LANG0
12954       include 'COMMON.LANGEVIN'
12955 #else
12956       include 'COMMON.LANGEVIN.lang0'
12957 #endif
12958       include 'COMMON.CONTROL'
12959       include 'COMMON.NAMES'
12960       include 'COMMON.TIME1'
12961       include 'COMMON.FFIELD'
12962       include 'COMMON.SAXS'
12963 c
12964       double precision Esaxs_constr
12965       integer i,iint,j,k,l
12966       double precision PgradC(maxSAXS,3,maxres),
12967      &  PgradX(maxSAXS,3,maxres),Pcalc(maxSAXS)
12968 #ifdef MPI
12969       double precision PgradC_(maxSAXS,3,maxres),
12970      &  PgradX_(maxSAXS,3,maxres),Pcalc_(maxSAXS)
12971 #endif
12972       double precision dk,dijCACA,dijCASC,dijSCCA,dijSCSC,
12973      & sigma2CACA,sigma2CASC,sigma2SCCA,sigma2SCSC,expCACA,expCASC,
12974      & expSCCA,expSCSC,CASCgrad,SCCAgrad,SCSCgrad,aux,auxC,auxC1,
12975      & auxX,auxX1,CACAgrad,Cnorm,sigmaCACA,threesig
12976       double precision sss2,ssgrad2,rrr,sscalgrad2,sscale2
12977       double precision dist,mygauss,mygaussder
12978       external dist
12979       integer llicz,lllicz
12980       double precision time01
12981 c  SAXS restraint penalty function
12982 #ifdef DEBUG
12983       write(iout,*) "------- SAXS penalty function start -------"
12984       write (iout,*) "nsaxs",nsaxs
12985       write (iout,*) "Esaxs: iatsc_s",iatsc_s," iatsc_e",iatsc_e
12986       write (iout,*) "Psaxs"
12987       do i=1,nsaxs
12988         write (iout,'(i5,e15.5)') i, Psaxs(i)
12989       enddo
12990 #endif
12991 #ifdef TIMING
12992       time01=MPI_Wtime()
12993 #endif
12994       Esaxs_constr = 0.0d0
12995       do k=1,nsaxs
12996         Pcalc(k)=0.0d0
12997         do j=1,nres
12998           do l=1,3
12999             PgradC(k,l,j)=0.0d0
13000             PgradX(k,l,j)=0.0d0
13001           enddo
13002         enddo
13003       enddo
13004 c      lllicz=0
13005       do i=iatsc_s,iatsc_e
13006        if (itype(i).eq.ntyp1) cycle
13007        do iint=1,nint_gr(i)
13008          do j=istart(i,iint),iend(i,iint)
13009            if (itype(j).eq.ntyp1) cycle
13010 #ifdef ALLSAXS
13011            dijCACA=dist(i,j)
13012            dijCASC=dist(i,j+nres)
13013            dijSCCA=dist(i+nres,j)
13014            dijSCSC=dist(i+nres,j+nres)
13015            sigma2CACA=2.0d0/(pstok**2)
13016            sigma2CASC=4.0d0/(pstok**2+restok(itype(j))**2)
13017            sigma2SCCA=4.0d0/(pstok**2+restok(itype(i))**2)
13018            sigma2SCSC=4.0d0/(restok(itype(j))**2+restok(itype(i))**2)
13019            do k=1,nsaxs
13020              dk = distsaxs(k)
13021              expCACA = dexp(-0.5d0*sigma2CACA*(dijCACA-dk)**2)
13022              if (itype(j).ne.10) then
13023              expCASC = dexp(-0.5d0*sigma2CASC*(dijCASC-dk)**2)
13024              else
13025              endif
13026              expCASC = 0.0d0
13027              if (itype(i).ne.10) then
13028              expSCCA = dexp(-0.5d0*sigma2SCCA*(dijSCCA-dk)**2)
13029              else
13030              expSCCA = 0.0d0
13031              endif
13032              if (itype(i).ne.10 .and. itype(j).ne.10) then
13033              expSCSC = dexp(-0.5d0*sigma2SCSC*(dijSCSC-dk)**2)
13034              else
13035              expSCSC = 0.0d0
13036              endif
13037              Pcalc(k) = Pcalc(k)+expCACA+expCASC+expSCCA+expSCSC
13038 #ifdef DEBUG
13039              write(iout,*) "i j k Pcalc",i,j,Pcalc(k)
13040 #endif
13041              CACAgrad = sigma2CACA*(dijCACA-dk)*expCACA
13042              CASCgrad = sigma2CASC*(dijCASC-dk)*expCASC
13043              SCCAgrad = sigma2SCCA*(dijSCCA-dk)*expSCCA
13044              SCSCgrad = sigma2SCSC*(dijSCSC-dk)*expSCSC
13045              do l=1,3
13046 c CA CA
13047                aux = CACAgrad*(C(l,j)-C(l,i))/dijCACA
13048                PgradC(k,l,i) = PgradC(k,l,i)-aux
13049                PgradC(k,l,j) = PgradC(k,l,j)+aux
13050 c CA SC
13051                if (itype(j).ne.10) then
13052                aux = CASCgrad*(C(l,j+nres)-C(l,i))/dijCASC
13053                PgradC(k,l,i) = PgradC(k,l,i)-aux
13054                PgradC(k,l,j) = PgradC(k,l,j)+aux
13055                PgradX(k,l,j) = PgradX(k,l,j)+aux
13056                endif
13057 c SC CA
13058                if (itype(i).ne.10) then
13059                aux = SCCAgrad*(C(l,j)-C(l,i+nres))/dijSCCA
13060                PgradX(k,l,i) = PgradX(k,l,i)-aux
13061                PgradC(k,l,i) = PgradC(k,l,i)-aux
13062                PgradC(k,l,j) = PgradC(k,l,j)+aux
13063                endif
13064 c SC SC
13065                if (itype(i).ne.10 .and. itype(j).ne.10) then
13066                aux = SCSCgrad*(C(l,j+nres)-C(l,i+nres))/dijSCSC
13067                PgradC(k,l,i) = PgradC(k,l,i)-aux
13068                PgradC(k,l,j) = PgradC(k,l,j)+aux
13069                PgradX(k,l,i) = PgradX(k,l,i)-aux
13070                PgradX(k,l,j) = PgradX(k,l,j)+aux
13071                endif
13072              enddo ! l
13073            enddo ! k
13074 #else
13075            dijCACA=dist(i,j)
13076            sigma2CACA=scal_rad**2*0.25d0/
13077      &        (restok(itype(j))**2+restok(itype(i))**2)
13078 c           write (iout,*) "scal_rad",scal_rad," restok",restok(itype(j))
13079 c     &       ,restok(itype(i)),"sigma",1.0d0/dsqrt(sigma2CACA)
13080 #ifdef MYGAUSS
13081            sigmaCACA=dsqrt(sigma2CACA)
13082            threesig=3.0d0/sigmaCACA
13083 c           llicz=0
13084            do k=1,nsaxs
13085              dk = distsaxs(k)
13086              if (dabs(dijCACA-dk).ge.threesig) cycle
13087 c             llicz=llicz+1
13088 c             lllicz=lllicz+1
13089              aux = sigmaCACA*(dijCACA-dk)
13090              expCACA = mygauss(aux)
13091 c             if (expcaca.eq.0.0d0) cycle
13092              Pcalc(k) = Pcalc(k)+expCACA
13093              CACAgrad = -sigmaCACA*mygaussder(aux)
13094 c             write (iout,*) "i,j,k,aux",i,j,k,CACAgrad
13095              do l=1,3
13096                aux = CACAgrad*(C(l,j)-C(l,i))/dijCACA
13097                PgradC(k,l,i) = PgradC(k,l,i)-aux
13098                PgradC(k,l,j) = PgradC(k,l,j)+aux
13099              enddo ! l
13100            enddo ! k
13101 c           write (iout,*) "i",i," j",j," llicz",llicz
13102 #else
13103            IF (saxs_cutoff.eq.0) THEN
13104            do k=1,nsaxs
13105              dk = distsaxs(k)
13106              expCACA = dexp(-0.5d0*sigma2CACA*(dijCACA-dk)**2)
13107              Pcalc(k) = Pcalc(k)+expCACA
13108              CACAgrad = sigma2CACA*(dijCACA-dk)*expCACA
13109              do l=1,3
13110                aux = CACAgrad*(C(l,j)-C(l,i))/dijCACA
13111                PgradC(k,l,i) = PgradC(k,l,i)-aux
13112                PgradC(k,l,j) = PgradC(k,l,j)+aux
13113              enddo ! l
13114            enddo ! k
13115            ELSE
13116            rrr = saxs_cutoff*2.0d0/dsqrt(sigma2CACA)
13117            do k=1,nsaxs
13118              dk = distsaxs(k)
13119 c             write (2,*) "ijk",i,j,k
13120              sss2 = sscale2(dijCACA,rrr,dk,0.3d0)
13121              if (sss2.eq.0.0d0) cycle
13122              ssgrad2 = sscalgrad2(dijCACA,rrr,dk,0.3d0)
13123              if (energy_dec) write(iout,'(a4,3i5,8f10.4)')
13124      &          'saxs',i,j,k,dijCACA,restok(itype(i)),restok(itype(j)),
13125      &          1.0d0/dsqrt(sigma2CACA),rrr,dk,
13126      &           sss2,ssgrad2
13127              expCACA = dexp(-0.5d0*sigma2CACA*(dijCACA-dk)**2)*sss2
13128              Pcalc(k) = Pcalc(k)+expCACA
13129 #ifdef DEBUG
13130              write(iout,*) "i j k Pcalc",i,j,Pcalc(k)
13131 #endif
13132              CACAgrad = -sigma2CACA*(dijCACA-dk)*expCACA+
13133      &             ssgrad2*expCACA/sss2
13134              do l=1,3
13135 c CA CA
13136                aux = CACAgrad*(C(l,j)-C(l,i))/dijCACA
13137                PgradC(k,l,i) = PgradC(k,l,i)+aux
13138                PgradC(k,l,j) = PgradC(k,l,j)-aux
13139              enddo ! l
13140            enddo ! k
13141            ENDIF
13142 #endif
13143 #endif
13144          enddo ! j
13145        enddo ! iint
13146       enddo ! i
13147 c#ifdef TIMING
13148 c      time_SAXS=time_SAXS+MPI_Wtime()-time01
13149 c#endif
13150 c      write (iout,*) "lllicz",lllicz
13151 c#ifdef TIMING
13152 c      time01=MPI_Wtime()
13153 c#endif
13154 #ifdef MPI
13155       if (nfgtasks.gt.1) then
13156        call MPI_AllReduce(Pcalc(1),Pcalc_(1),nsaxs,MPI_DOUBLE_PRECISION,
13157      &    MPI_SUM,FG_COMM,IERR)
13158 c        if (fg_rank.eq.king) then
13159           do k=1,nsaxs
13160             Pcalc(k) = Pcalc_(k)
13161           enddo
13162 c        endif
13163 c        call MPI_AllReduce(PgradC(k,1,1),PgradC_(k,1,1),3*maxsaxs*nres,
13164 c     &    MPI_DOUBLE_PRECISION,MPI_SUM,FG_COMM,IERR)
13165 c        if (fg_rank.eq.king) then
13166 c          do i=1,nres
13167 c            do l=1,3
13168 c              do k=1,nsaxs
13169 c                PgradC(k,l,i) = PgradC_(k,l,i)
13170 c              enddo
13171 c            enddo
13172 c          enddo
13173 c        endif
13174 #ifdef ALLSAXS
13175 c        call MPI_AllReduce(PgradX(k,1,1),PgradX_(k,1,1),3*maxsaxs*nres,
13176 c     &    MPI_DOUBLE_PRECISION,MPI_SUM,FG_COMM,IERR)
13177 c        if (fg_rank.eq.king) then
13178 c          do i=1,nres
13179 c            do l=1,3
13180 c              do k=1,nsaxs
13181 c                PgradX(k,l,i) = PgradX_(k,l,i)
13182 c              enddo
13183 c            enddo
13184 c          enddo
13185 c        endif
13186 #endif
13187       endif
13188 #endif
13189       Cnorm = 0.0d0
13190       do k=1,nsaxs
13191         Cnorm = Cnorm + Pcalc(k)
13192       enddo
13193 #ifdef MPI
13194       if (fg_rank.eq.king) then
13195 #endif
13196       Esaxs_constr = dlog(Cnorm)-wsaxs0
13197       do k=1,nsaxs
13198         if (Pcalc(k).gt.0.0d0)
13199      &  Esaxs_constr = Esaxs_constr - Psaxs(k)*dlog(Pcalc(k))
13200 #ifdef DEBUG
13201         write (iout,*) "k",k," Esaxs_constr",Esaxs_constr
13202 #endif
13203       enddo
13204 #ifdef DEBUG
13205       write (iout,*) "Cnorm",Cnorm," Esaxs_constr",Esaxs_constr
13206 #endif
13207 #ifdef MPI
13208       endif
13209 #endif
13210       gsaxsC=0.0d0
13211       gsaxsX=0.0d0
13212       do i=nnt,nct
13213         do l=1,3
13214           auxC=0.0d0
13215           auxC1=0.0d0
13216           auxX=0.0d0
13217           auxX1=0.d0
13218           do k=1,nsaxs
13219             if (Pcalc(k).gt.0)
13220      &      auxC  = auxC +Psaxs(k)*PgradC(k,l,i)/Pcalc(k)
13221             auxC1 = auxC1+PgradC(k,l,i)
13222 #ifdef ALLSAXS
13223             auxX  = auxX +Psaxs(k)*PgradX(k,l,i)/Pcalc(k)
13224             auxX1 = auxX1+PgradX(k,l,i)
13225 #endif
13226           enddo
13227           gsaxsC(l,i) = auxC - auxC1/Cnorm
13228 #ifdef ALLSAXS
13229           gsaxsX(l,i) = auxX - auxX1/Cnorm
13230 #endif
13231 c          write (iout,*) "l i",l,i," gradC",wsaxs*(auxC - auxC1/Cnorm),
13232 c     *     " gradX",wsaxs*(auxX - auxX1/Cnorm)
13233 c          write (iout,*) "l i",l,i," gradC",wsaxs*gsaxsC(l,i),
13234 c     *     " gradX",wsaxs*gsaxsX(l,i)
13235         enddo
13236       enddo
13237 #ifdef TIMING
13238       time_SAXS=time_SAXS+MPI_Wtime()-time01
13239 #endif
13240 #ifdef DEBUG
13241       write (iout,*) "gsaxsc"
13242       do i=nnt,nct
13243         write (iout,'(i5,3e15.5)') i,(gsaxsc(j,i),j=1,3)
13244       enddo
13245 #endif
13246 #ifdef MPI
13247 c      endif
13248 #endif
13249       return
13250       end
13251 c----------------------------------------------------------------------------
13252       subroutine e_saxsC(Esaxs_constr)
13253       implicit none
13254       include 'DIMENSIONS'
13255 #ifdef MPI
13256       include "mpif.h"
13257       include "COMMON.SETUP"
13258       integer IERR
13259 #endif
13260       include 'COMMON.SBRIDGE'
13261       include 'COMMON.CHAIN'
13262       include 'COMMON.GEO'
13263       include 'COMMON.DERIV'
13264       include 'COMMON.LOCAL'
13265       include 'COMMON.INTERACT'
13266       include 'COMMON.VAR'
13267       include 'COMMON.IOUNITS'
13268       include 'COMMON.MD'
13269 #ifndef LANG0
13270       include 'COMMON.LANGEVIN'
13271 #else
13272       include 'COMMON.LANGEVIN.lang0'
13273 #endif
13274       include 'COMMON.CONTROL'
13275       include 'COMMON.NAMES'
13276       include 'COMMON.TIME1'
13277       include 'COMMON.FFIELD'
13278       include 'COMMON.SAXS'
13279 c
13280       double precision Esaxs_constr
13281       integer i,iint,j,k,l
13282       double precision PgradC(3,maxres),PgradX(3,maxres),Pcalc,logPtot
13283 #ifdef MPI
13284       double precision gsaxsc_(3,maxres),gsaxsx_(3,maxres),logPtot_
13285 #endif
13286       double precision dk,dijCASPH,dijSCSPH,
13287      & sigma2CA,sigma2SC,expCASPH,expSCSPH,
13288      & CASPHgrad,SCSPHgrad,aux,auxC,auxC1,
13289      & auxX,auxX1,Cnorm
13290 c  SAXS restraint penalty function
13291 #ifdef DEBUG
13292       write(iout,*) "------- SAXS penalty function start -------"
13293       write (iout,*) "nsaxs",nsaxs
13294
13295       do i=nnt,nct
13296         print *,MyRank,"C",i,(C(j,i),j=1,3)
13297       enddo
13298       do i=nnt,nct
13299         print *,MyRank,"CSaxs",i,(Csaxs(j,i),j=1,3)
13300       enddo
13301 #endif
13302       Esaxs_constr = 0.0d0
13303       logPtot=0.0d0
13304       do j=isaxs_start,isaxs_end
13305         Pcalc=0.0d0
13306         do i=1,nres
13307           do l=1,3
13308             PgradC(l,i)=0.0d0
13309             PgradX(l,i)=0.0d0
13310           enddo
13311         enddo
13312         do i=nnt,nct
13313           if (itype(i).eq.ntyp1) cycle
13314           dijCASPH=0.0d0
13315           dijSCSPH=0.0d0
13316           do l=1,3
13317             dijCASPH=dijCASPH+(C(l,i)-Csaxs(l,j))**2
13318           enddo
13319           if (itype(i).ne.10) then
13320           do l=1,3
13321             dijSCSPH=dijSCSPH+(C(l,i+nres)-Csaxs(l,j))**2
13322           enddo
13323           endif
13324           sigma2CA=2.0d0/pstok**2
13325           sigma2SC=4.0d0/restok(itype(i))**2
13326           expCASPH = dexp(-0.5d0*sigma2CA*dijCASPH)
13327           expSCSPH = dexp(-0.5d0*sigma2SC*dijSCSPH)
13328           Pcalc = Pcalc+expCASPH+expSCSPH
13329 #ifdef DEBUG
13330           write(*,*) "processor i j Pcalc",
13331      &       MyRank,i,j,dijCASPH,dijSCSPH, Pcalc
13332 #endif
13333           CASPHgrad = sigma2CA*expCASPH
13334           SCSPHgrad = sigma2SC*expSCSPH
13335           do l=1,3
13336             aux = (C(l,i+nres)-Csaxs(l,j))*SCSPHgrad
13337             PgradX(l,i) = PgradX(l,i) + aux
13338             PgradC(l,i) = PgradC(l,i)+(C(l,i)-Csaxs(l,j))*CASPHgrad+aux
13339           enddo ! l
13340         enddo ! i
13341         do i=nnt,nct
13342           do l=1,3
13343             gsaxsc(l,i)=gsaxsc(l,i)+PgradC(l,i)/Pcalc
13344             gsaxsx(l,i)=gsaxsx(l,i)+PgradX(l,i)/Pcalc
13345           enddo
13346         enddo
13347         logPtot = logPtot - dlog(Pcalc)
13348 c        print *,"me",me,MyRank," j",j," logPcalc",-dlog(Pcalc),
13349 c     &    " logPtot",logPtot
13350       enddo ! j
13351 #ifdef MPI
13352       if (nfgtasks.gt.1) then
13353 c        write (iout,*) "logPtot before reduction",logPtot
13354         call MPI_Reduce(logPtot,logPtot_,1,MPI_DOUBLE_PRECISION,
13355      &    MPI_SUM,king,FG_COMM,IERR)
13356         logPtot = logPtot_
13357 c        write (iout,*) "logPtot after reduction",logPtot
13358         call MPI_Reduce(gsaxsC(1,1),gsaxsC_(1,1),3*nres,
13359      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
13360         if (fg_rank.eq.king) then
13361           do i=1,nres
13362             do l=1,3
13363               gsaxsC(l,i) = gsaxsC_(l,i)
13364             enddo
13365           enddo
13366         endif
13367         call MPI_Reduce(gsaxsX(1,1),gsaxsX_(1,1),3*nres,
13368      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
13369         if (fg_rank.eq.king) then
13370           do i=1,nres
13371             do l=1,3
13372               gsaxsX(l,i) = gsaxsX_(l,i)
13373             enddo
13374           enddo
13375         endif
13376       endif
13377 #endif
13378       Esaxs_constr = logPtot
13379       return
13380       end
13381 c----------------------------------------------------------------------------
13382       double precision function sscale2(r,r_cut,r0,rlamb)
13383       implicit none
13384       double precision r,gamm,r_cut,r0,rlamb,rr
13385       rr = dabs(r-r0)
13386 c      write (2,*) "r",r," r_cut",r_cut," r0",r0," rlamb",rlamb
13387 c      write (2,*) "rr",rr
13388       if(rr.lt.r_cut-rlamb) then
13389         sscale2=1.0d0
13390       else if(rr.le.r_cut.and.rr.ge.r_cut-rlamb) then
13391         gamm=(rr-(r_cut-rlamb))/rlamb
13392         sscale2=1.0d0+gamm*gamm*(2*gamm-3.0d0)
13393       else
13394         sscale2=0d0
13395       endif
13396       return
13397       end
13398 C-----------------------------------------------------------------------
13399       double precision function sscalgrad2(r,r_cut,r0,rlamb)
13400       implicit none
13401       double precision r,gamm,r_cut,r0,rlamb,rr
13402       rr = dabs(r-r0)
13403       if(rr.lt.r_cut-rlamb) then
13404         sscalgrad2=0.0d0
13405       else if(rr.le.r_cut.and.rr.ge.r_cut-rlamb) then
13406         gamm=(rr-(r_cut-rlamb))/rlamb
13407         if (r.ge.r0) then
13408           sscalgrad2=gamm*(6*gamm-6.0d0)/rlamb
13409         else
13410           sscalgrad2=-gamm*(6*gamm-6.0d0)/rlamb
13411         endif
13412       else
13413         sscalgrad2=0.0d0
13414       endif
13415       return
13416       end