source/unres/src_MD-M-SAXS-homology/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.MD'
  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.MD'
 613 #ifdef TIMING
 614       time01=MPI_Wtime()
 615 #endif
 616 #ifdef DEBUG
 617       write (iout,*) "sum_gradient gvdwc, gvdwx"
 618       do i=1,nres
 619         write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)')
 620      &   i,(gvdwx(j,i),j=1,3),(gvdwc(j,i),j=1,3)
 621       enddo
 622       call flush(iout)
 623 #endif
 624 #ifdef DEBUG
 625       write (iout,*) "sum_gradient gsaxsc, gsaxsx"
 626       do i=0,nres
 627         write (iout,'(i3,3e15.5,5x,3e15.5)')
 628      &   i,(gsaxsc(j,i),j=1,3),(gsaxsx(j,i),j=1,3)
 629       enddo
 630       call flush(iout)
 631 #endif
 632 #ifdef MPI
 633 C FG slaves call the following matching MPI_Bcast in ERGASTULUM
 634         if (nfgtasks.gt.1 .and. fg_rank.eq.0)
 635      &    call MPI_Bcast(1,1,MPI_INTEGER,king,FG_COMM,IERROR)
 636 #endif
 637 C
 638 C 9/29/08 AL Transform parts of gradients in site coordinates to the gradient
 639 C            in virtual-bond-vector coordinates
 640 C
 641 #ifdef DEBUG
 642 c      write (iout,*) "gel_loc gel_loc_long and gel_loc_loc"
 643 c      do i=1,nres-1
 644 c        write (iout,'(i5,3f10.5,2x,3f10.5,2x,f10.5)')
 645 c     &   i,(gel_loc(j,i),j=1,3),(gel_loc_long(j,i),j=1,3),gel_loc_loc(i)
 646 c      enddo
 647 c      write (iout,*) "gel_loc_tur3 gel_loc_turn4"
 648 c      do i=1,nres-1
 649 c        write (iout,'(i5,3f10.5,2x,f10.5)')
 650 c     &  i,(gcorr4_turn(j,i),j=1,3),gel_loc_turn4(i)
 651 c      enddo
 652       write (iout,*) "gradcorr5 gradcorr5_long gradcorr5_loc"
 653       do i=1,nres
 654         write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)')
 655      &   i,(gradcorr5(j,i),j=1,3),(gradcorr5_long(j,i),j=1,3),
 656      &   g_corr5_loc(i)
 657       enddo
 658       call flush(iout)
 659 #endif
 660 #ifdef DEBUG
 661       write (iout,*) "gsaxsc"
 662       do i=1,nres
 663         write (iout,'(i3,3f10.5)') i,(wsaxs*gsaxsc(j,i),j=1,3)
 664       enddo
 665       call flush(iout)
 666 #endif
 667 #ifdef SPLITELE
 668       do i=0,nct
 669         do j=1,3
 670           gradbufc(j,i)=wsc*gvdwc(j,i)+
 671      &                wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+
 672      &                welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+
 673      &                wel_loc*gel_loc_long(j,i)+
 674      &                wcorr*gradcorr_long(j,i)+
 675      &                wcorr5*gradcorr5_long(j,i)+
 676      &                wcorr6*gradcorr6_long(j,i)+
 677      &                wturn6*gcorr6_turn_long(j,i)+
 678      &                wstrain*ghpbc(j,i)
 679      &                +wliptran*gliptranc(j,i)
 680      &                +gradafm(j,i)
 681      &                +welec*gshieldc(j,i)
 682      &                +wcorr*gshieldc_ec(j,i)
 683      &                +wturn3*gshieldc_t3(j,i)
 684      &                +wturn4*gshieldc_t4(j,i)
 685      &                +wel_loc*gshieldc_ll(j,i)
 686      &                +wtube*gg_tube(j,i)
 687      &                +wsaxs*gsaxsc(j,i)
 688         enddo
 689       enddo
 690 #else
 691       do i=0,nct
 692         do j=1,3
 693           gradbufc(j,i)=wsc*gvdwc(j,i)+
 694      &                wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+
 695      &                welec*gelc_long(j,i)+
 696      &                wbond*gradb(j,i)+
 697      &                wel_loc*gel_loc_long(j,i)+
 698      &                wcorr*gradcorr_long(j,i)+
 699      &                wcorr5*gradcorr5_long(j,i)+
 700      &                wcorr6*gradcorr6_long(j,i)+
 701      &                wturn6*gcorr6_turn_long(j,i)+
 702      &                wstrain*ghpbc(j,i)
 703      &                +wliptran*gliptranc(j,i)
 704      &                +gradafm(j,i)
 705      &                 +welec*gshieldc(j,i)
 706      &                 +wcorr*gshieldc_ec(j,i)
 707      &                 +wturn4*gshieldc_t4(j,i)
 708      &                 +wel_loc*gshieldc_ll(j,i)
 709      &                +wtube*gg_tube(j,i)
 710      &                +wsaxs*gsaxsc(j,i)
 711         enddo
 712       enddo
 713 #endif
 714       do i=1,nct
 715         do j=1,3
 716           gradbufc(j,i)=gradbufc(j,i)+
 717      &                wdfa_dist*gdfad(j,i)+
 718      &                wdfa_tor*gdfat(j,i)+
 719      &                wdfa_nei*gdfan(j,i)+
 720      &                wdfa_beta*gdfab(j,i)
 721         enddo
 722       enddo
 723 #ifdef DEBUG
 724       write (iout,*) "gradc from gradbufc"
 725       do i=1,nres
 726         write (iout,'(i3,3f10.5)') i,(gradc(j,i,icg),j=1,3)
 727       enddo
 728       call flush(iout)
 729 #endif
 730 #ifdef MPI
 731       if (nfgtasks.gt.1) then
 732       time00=MPI_Wtime()
 733 #ifdef DEBUG
 734       write (iout,*) "gradbufc before allreduce"
 735       do i=1,nres
 736         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 737       enddo
 738       call flush(iout)
 739 #endif
 740       do i=0,nres
 741         do j=1,3
 742           gradbufc_sum(j,i)=gradbufc(j,i)
 743         enddo
 744       enddo
 745 c      call MPI_AllReduce(gradbufc(1,1),gradbufc_sum(1,1),3*nres,
 746 c     &    MPI_DOUBLE_PRECISION,MPI_SUM,FG_COMM,IERR)
 747 c      time_reduce=time_reduce+MPI_Wtime()-time00
 748 #ifdef DEBUG
 749 c      write (iout,*) "gradbufc_sum after allreduce"
 750 c      do i=1,nres
 751 c        write (iout,'(i3,3f10.5)') i,(gradbufc_sum(j,i),j=1,3)
 752 c      enddo
 753 c      call flush(iout)
 754 #endif
 755 #ifdef TIMING
 756 c      time_allreduce=time_allreduce+MPI_Wtime()-time00
 757 #endif
 758       do i=nnt,nres
 759         do k=1,3
 760           gradbufc(k,i)=0.0d0
 761         enddo
 762       enddo
 763 #ifdef DEBUG
 764       write (iout,*) "igrad_start",igrad_start," igrad_end",igrad_end
 765       write (iout,*) (i," jgrad_start",jgrad_start(i),
 766      &                  " jgrad_end  ",jgrad_end(i),
 767      &                  i=igrad_start,igrad_end)
 768 #endif
 769 c
 770 c Obsolete and inefficient code; we can make the effort O(n) and, therefore,
 771 c do not parallelize this part.
 772 c
 773 c      do i=igrad_start,igrad_end
 774 c        do j=jgrad_start(i),jgrad_end(i)
 775 c          do k=1,3
 776 c            gradbufc(k,i)=gradbufc(k,i)+gradbufc_sum(k,j)
 777 c          enddo
 778 c        enddo
 779 c      enddo
 780       do j=1,3
 781         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
 782       enddo
 783       do i=nres-2,-1,-1
 784         do j=1,3
 785           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
 786         enddo
 787       enddo
 788 #ifdef DEBUG
 789       write (iout,*) "gradbufc after summing"
 790       do i=1,nres
 791         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 792       enddo
 793       call flush(iout)
 794 #endif
 795       else
 796 #endif
 797 #ifdef DEBUG
 798       write (iout,*) "gradbufc"
 799       do i=1,nres
 800         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 801       enddo
 802       call flush(iout)
 803 #endif
 804       do i=-1,nres
 805         do j=1,3
 806           gradbufc_sum(j,i)=gradbufc(j,i)
 807           gradbufc(j,i)=0.0d0
 808         enddo
 809       enddo
 810       do j=1,3
 811         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
 812       enddo
 813       do i=nres-2,-1,-1
 814         do j=1,3
 815           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
 816         enddo
 817       enddo
 818 c      do i=nnt,nres-1
 819 c        do k=1,3
 820 c          gradbufc(k,i)=0.0d0
 821 c        enddo
 822 c        do j=i+1,nres
 823 c          do k=1,3
 824 c            gradbufc(k,i)=gradbufc(k,i)+gradbufc(k,j)
 825 c          enddo
 826 c        enddo
 827 c      enddo
 828 #ifdef DEBUG
 829       write (iout,*) "gradbufc after summing"
 830       do i=1,nres
 831         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 832       enddo
 833       call flush(iout)
 834 #endif
 835 #ifdef MPI
 836       endif
 837 #endif
 838       do k=1,3
 839         gradbufc(k,nres)=0.0d0
 840       enddo
 841       do i=-1,nct
 842         do j=1,3
 843 #ifdef SPLITELE
 844 C          print *,gradbufc(1,13)
 845 C          print *,welec*gelc(1,13)
 846 C          print *,wel_loc*gel_loc(1,13)
 847 C          print *,0.5d0*(wscp*gvdwc_scpp(1,13))
 848 C          print *,welec*gelc_long(1,13)+wvdwpp*gvdwpp(1,13)
 849 C          print *,wel_loc*gel_loc_long(1,13)
 850 C          print *,gradafm(1,13),"AFM"
 851           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+
 852      &                wel_loc*gel_loc(j,i)+
 853      &                0.5d0*(wscp*gvdwc_scpp(j,i)+
 854      &                welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+
 855      &                wel_loc*gel_loc_long(j,i)+
 856      &                wcorr*gradcorr_long(j,i)+
 857      &                wcorr5*gradcorr5_long(j,i)+
 858      &                wcorr6*gradcorr6_long(j,i)+
 859      &                wturn6*gcorr6_turn_long(j,i))+
 860      &                wbond*gradb(j,i)+
 861      &                wcorr*gradcorr(j,i)+
 862      &                wturn3*gcorr3_turn(j,i)+
 863      &                wturn4*gcorr4_turn(j,i)+
 864      &                wcorr5*gradcorr5(j,i)+
 865      &                wcorr6*gradcorr6(j,i)+
 866      &                wturn6*gcorr6_turn(j,i)+
 867      &                wsccor*gsccorc(j,i)
 868      &               +wscloc*gscloc(j,i)
 869      &               +wliptran*gliptranc(j,i)
 870      &                +gradafm(j,i)
 871      &                 +welec*gshieldc(j,i)
 872      &                 +welec*gshieldc_loc(j,i)
 873      &                 +wcorr*gshieldc_ec(j,i)
 874      &                 +wcorr*gshieldc_loc_ec(j,i)
 875      &                 +wturn3*gshieldc_t3(j,i)
 876      &                 +wturn3*gshieldc_loc_t3(j,i)
 877      &                 +wturn4*gshieldc_t4(j,i)
 878      &                 +wturn4*gshieldc_loc_t4(j,i)
 879      &                 +wel_loc*gshieldc_ll(j,i)
 880      &                 +wel_loc*gshieldc_loc_ll(j,i)
 881      &                +wtube*gg_tube(j,i)
 882
 883 #else
 884           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+
 885      &                wel_loc*gel_loc(j,i)+
 886      &                0.5d0*(wscp*gvdwc_scpp(j,i)+
 887      &                welec*gelc_long(j,i)+
 888      &                wel_loc*gel_loc_long(j,i)+
 889      &                wcorr*gcorr_long(j,i)+
 890      &                wcorr5*gradcorr5_long(j,i)+
 891      &                wcorr6*gradcorr6_long(j,i)+
 892      &                wturn6*gcorr6_turn_long(j,i))+
 893      &                wbond*gradb(j,i)+
 894      &                wcorr*gradcorr(j,i)+
 895      &                wturn3*gcorr3_turn(j,i)+
 896      &                wturn4*gcorr4_turn(j,i)+
 897      &                wcorr5*gradcorr5(j,i)+
 898      &                wcorr6*gradcorr6(j,i)+
 899      &                wturn6*gcorr6_turn(j,i)+
 900      &                wsccor*gsccorc(j,i)
 901      &               +wscloc*gscloc(j,i)
 902      &               +wliptran*gliptranc(j,i)
 903      &                +gradafm(j,i)
 904      &                 +welec*gshieldc(j,i)
 905      &                 +welec*gshieldc_loc(j,i)
 906      &                 +wcorr*gshieldc_ec(j,i)
 907      &                 +wcorr*gshieldc_loc_ec(j,i)
 908      &                 +wturn3*gshieldc_t3(j,i)
 909      &                 +wturn3*gshieldc_loc_t3(j,i)
 910      &                 +wturn4*gshieldc_t4(j,i)
 911      &                 +wturn4*gshieldc_loc_t4(j,i)
 912      &                 +wel_loc*gshieldc_ll(j,i)
 913      &                 +wel_loc*gshieldc_loc_ll(j,i)
 914      &                +wtube*gg_tube(j,i)
 915
 916
 917 #endif
 918           gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+
 919      &                  wbond*gradbx(j,i)+
 920      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
 921      &                  wsccor*gsccorx(j,i)
 922      &                 +wscloc*gsclocx(j,i)
 923      &                 +wliptran*gliptranx(j,i)
 924      &                 +welec*gshieldx(j,i)
 925      &                 +wcorr*gshieldx_ec(j,i)
 926      &                 +wturn3*gshieldx_t3(j,i)
 927      &                 +wturn4*gshieldx_t4(j,i)
 928      &                 +wel_loc*gshieldx_ll(j,i)
 929      &                 +wtube*gg_tube_sc(j,i)
 930      &                 +wsaxs*gsaxsx(j,i)
 931
 932
 933
 934         enddo
 935       enddo
 936       if (constr_homology.gt.0) then
 937         do i=1,nct
 938           do j=1,3
 939             gradc(j,i,icg)=gradc(j,i,icg)+duscdiff(j,i)
 940             gradx(j,i,icg)=gradx(j,i,icg)+duscdiffx(j,i)
 941           enddo
 942         enddo
 943       endif
 944 #ifdef DEBUG
 945       write (iout,*) "gradc gradx gloc after adding"
 946       do i=1,nres
 947         write (iout,'(i5,3f10.5,5x,3f10.5,5x,f10.5)')
 948      &   i,(gradc(j,i,icg),j=1,3),(gradx(j,i,icg),j=1,3),gloc(i,icg)
 949       enddo
 950 #endif
 951 #ifdef DEBUG
 952       write (iout,*) "gloc before adding corr"
 953       do i=1,4*nres
 954         write (iout,*) i,gloc(i,icg)
 955       enddo
 956 #endif
 957       do i=1,nres-3
 958         gloc(i,icg)=gloc(i,icg)+wcorr*gcorr_loc(i)
 959      &   +wcorr5*g_corr5_loc(i)
 960      &   +wcorr6*g_corr6_loc(i)
 961      &   +wturn4*gel_loc_turn4(i)
 962      &   +wturn3*gel_loc_turn3(i)
 963      &   +wturn6*gel_loc_turn6(i)
 964      &   +wel_loc*gel_loc_loc(i)
 965       enddo
 966 #ifdef DEBUG
 967       write (iout,*) "gloc after adding corr"
 968       do i=1,4*nres
 969         write (iout,*) i,gloc(i,icg)
 970       enddo
 971 #endif
 972 #ifdef MPI
 973       if (nfgtasks.gt.1) then
 974         do j=1,3
 975           do i=1,nres
 976             gradbufc(j,i)=gradc(j,i,icg)
 977             gradbufx(j,i)=gradx(j,i,icg)
 978           enddo
 979         enddo
 980         do i=1,4*nres
 981           glocbuf(i)=gloc(i,icg)
 982         enddo
 983 c#define DEBUG
 984 #ifdef DEBUG
 985       write (iout,*) "gloc_sc before reduce"
 986       do i=1,nres
 987        do j=1,1
 988         write (iout,*) i,j,gloc_sc(j,i,icg)
 989        enddo
 990       enddo
 991 #endif
 992 c#undef DEBUG
 993         do i=1,nres
 994          do j=1,3
 995           gloc_scbuf(j,i)=gloc_sc(j,i,icg)
 996          enddo
 997         enddo
 998         time00=MPI_Wtime()
 999         call MPI_Barrier(FG_COMM,IERR)
1000         time_barrier_g=time_barrier_g+MPI_Wtime()-time00
1001         time00=MPI_Wtime()
1002         call MPI_Reduce(gradbufc(1,1),gradc(1,1,icg),3*nres,
1003      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
1004         call MPI_Reduce(gradbufx(1,1),gradx(1,1,icg),3*nres,
1005      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
1006         call MPI_Reduce(glocbuf(1),gloc(1,icg),4*nres,
1007      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
1008         time_reduce=time_reduce+MPI_Wtime()-time00
1009         call MPI_Reduce(gloc_scbuf(1,1),gloc_sc(1,1,icg),3*nres,
1010      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
1011         time_reduce=time_reduce+MPI_Wtime()-time00
1012 #ifdef DEBUG
1013       write (iout,*) "gradc after reduce"
1014       do i=1,nres
1015        do j=1,3
1016         write (iout,*) i,j,gradc(j,i,icg)
1017        enddo
1018       enddo
1019 #endif
1020 #ifdef DEBUG
1021       write (iout,*) "gloc_sc after reduce"
1022       do i=1,nres
1023        do j=1,1
1024         write (iout,*) i,j,gloc_sc(j,i,icg)
1025        enddo
1026       enddo
1027 #endif
1028 #ifdef DEBUG
1029       write (iout,*) "gloc after reduce"
1030       do i=1,4*nres
1031         write (iout,*) i,gloc(i,icg)
1032       enddo
1033 #endif
1034       endif
1035 #endif
1036       if (gnorm_check) then
1037 c
1038 c Compute the maximum elements of the gradient
1039 c
1040       gvdwc_max=0.0d0
1041       gvdwc_scp_max=0.0d0
1042       gelc_max=0.0d0
1043       gvdwpp_max=0.0d0
1044       gradb_max=0.0d0
1045       ghpbc_max=0.0d0
1046       gradcorr_max=0.0d0
1047       gel_loc_max=0.0d0
1048       gcorr3_turn_max=0.0d0
1049       gcorr4_turn_max=0.0d0
1050       gradcorr5_max=0.0d0
1051       gradcorr6_max=0.0d0
1052       gcorr6_turn_max=0.0d0
1053       gsccorc_max=0.0d0
1054       gscloc_max=0.0d0
1055       gvdwx_max=0.0d0
1056       gradx_scp_max=0.0d0
1057       ghpbx_max=0.0d0
1058       gradxorr_max=0.0d0
1059       gsccorx_max=0.0d0
1060       gsclocx_max=0.0d0
1061       do i=1,nct
1062         gvdwc_norm=dsqrt(scalar(gvdwc(1,i),gvdwc(1,i)))
1063         if (gvdwc_norm.gt.gvdwc_max) gvdwc_max=gvdwc_norm
1064         gvdwc_scp_norm=dsqrt(scalar(gvdwc_scp(1,i),gvdwc_scp(1,i)))
1065         if (gvdwc_scp_norm.gt.gvdwc_scp_max)
1066      &   gvdwc_scp_max=gvdwc_scp_norm
1067         gelc_norm=dsqrt(scalar(gelc(1,i),gelc(1,i)))
1068         if (gelc_norm.gt.gelc_max) gelc_max=gelc_norm
1069         gvdwpp_norm=dsqrt(scalar(gvdwpp(1,i),gvdwpp(1,i)))
1070         if (gvdwpp_norm.gt.gvdwpp_max) gvdwpp_max=gvdwpp_norm
1071         gradb_norm=dsqrt(scalar(gradb(1,i),gradb(1,i)))
1072         if (gradb_norm.gt.gradb_max) gradb_max=gradb_norm
1073         ghpbc_norm=dsqrt(scalar(ghpbc(1,i),ghpbc(1,i)))
1074         if (ghpbc_norm.gt.ghpbc_max) ghpbc_max=ghpbc_norm
1075         gradcorr_norm=dsqrt(scalar(gradcorr(1,i),gradcorr(1,i)))
1076         if (gradcorr_norm.gt.gradcorr_max) gradcorr_max=gradcorr_norm
1077         gel_loc_norm=dsqrt(scalar(gel_loc(1,i),gel_loc(1,i)))
1078         if (gel_loc_norm.gt.gel_loc_max) gel_loc_max=gel_loc_norm
1079         gcorr3_turn_norm=dsqrt(scalar(gcorr3_turn(1,i),
1080      &    gcorr3_turn(1,i)))
1081         if (gcorr3_turn_norm.gt.gcorr3_turn_max)
1082      &    gcorr3_turn_max=gcorr3_turn_norm
1083         gcorr4_turn_norm=dsqrt(scalar(gcorr4_turn(1,i),
1084      &    gcorr4_turn(1,i)))
1085         if (gcorr4_turn_norm.gt.gcorr4_turn_max)
1086      &    gcorr4_turn_max=gcorr4_turn_norm
1087         gradcorr5_norm=dsqrt(scalar(gradcorr5(1,i),gradcorr5(1,i)))
1088         if (gradcorr5_norm.gt.gradcorr5_max)
1089      &    gradcorr5_max=gradcorr5_norm
1090         gradcorr6_norm=dsqrt(scalar(gradcorr6(1,i),gradcorr6(1,i)))
1091         if (gradcorr6_norm.gt.gradcorr6_max) gcorr6_max=gradcorr6_norm
1092         gcorr6_turn_norm=dsqrt(scalar(gcorr6_turn(1,i),
1093      &    gcorr6_turn(1,i)))
1094         if (gcorr6_turn_norm.gt.gcorr6_turn_max)
1095      &    gcorr6_turn_max=gcorr6_turn_norm
1096         gsccorr_norm=dsqrt(scalar(gsccorc(1,i),gsccorc(1,i)))
1097         if (gsccorr_norm.gt.gsccorr_max) gsccorr_max=gsccorr_norm
1098         gscloc_norm=dsqrt(scalar(gscloc(1,i),gscloc(1,i)))
1099         if (gscloc_norm.gt.gscloc_max) gscloc_max=gscloc_norm
1100         gvdwx_norm=dsqrt(scalar(gvdwx(1,i),gvdwx(1,i)))
1101         if (gvdwx_norm.gt.gvdwx_max) gvdwx_max=gvdwx_norm
1102         gradx_scp_norm=dsqrt(scalar(gradx_scp(1,i),gradx_scp(1,i)))
1103         if (gradx_scp_norm.gt.gradx_scp_max)
1104      &    gradx_scp_max=gradx_scp_norm
1105         ghpbx_norm=dsqrt(scalar(ghpbx(1,i),ghpbx(1,i)))
1106         if (ghpbx_norm.gt.ghpbx_max) ghpbx_max=ghpbx_norm
1107         gradxorr_norm=dsqrt(scalar(gradxorr(1,i),gradxorr(1,i)))
1108         if (gradxorr_norm.gt.gradxorr_max) gradxorr_max=gradxorr_norm
1109         gsccorrx_norm=dsqrt(scalar(gsccorx(1,i),gsccorx(1,i)))
1110         if (gsccorrx_norm.gt.gsccorrx_max) gsccorrx_max=gsccorrx_norm
1111         gsclocx_norm=dsqrt(scalar(gsclocx(1,i),gsclocx(1,i)))
1112         if (gsclocx_norm.gt.gsclocx_max) gsclocx_max=gsclocx_norm
1113       enddo
1114       if (gradout) then
1115 #if (defined AIX || defined CRAY)
1116         open(istat,file=statname,position="append")
1117 #else
1118         open(istat,file=statname,access="append")
1119 #endif
1120         write (istat,'(1h#,21f10.2)') gvdwc_max,gvdwc_scp_max,
1121      &     gelc_max,gvdwpp_max,gradb_max,ghpbc_max,
1122      &     gradcorr_max,gel_loc_max,gcorr3_turn_max,gcorr4_turn_max,
1123      &     gradcorr5_max,gradcorr6_max,gcorr6_turn_max,gsccorc_max,
1124      &     gscloc_max,gvdwx_max,gradx_scp_max,ghpbx_max,gradxorr_max,
1125      &     gsccorx_max,gsclocx_max
1126         close(istat)
1127         if (gvdwc_max.gt.1.0d4) then
1128           write (iout,*) "gvdwc gvdwx gradb gradbx"
1129           do i=nnt,nct
1130             write(iout,'(i5,4(3f10.2,5x))') i,(gvdwc(j,i),gvdwx(j,i),
1131      &        gradb(j,i),gradbx(j,i),j=1,3)
1132           enddo
1133           call pdbout(0.0d0,'cipiszcze',iout)
1134           call flush(iout)
1135         endif
1136       endif
1137       endif
1138 #ifdef DEBUG
1139       write (iout,*) "gradc gradx gloc"
1140       do i=1,nres
1141         write (iout,'(i5,3f10.5,5x,3f10.5,5x,f10.5)')
1142      &   i,(gradc(j,i,icg),j=1,3),(gradx(j,i,icg),j=1,3),gloc(i,icg)
1143       enddo
1144 #endif
1145 #ifdef TIMING
1146       time_sumgradient=time_sumgradient+MPI_Wtime()-time01
1147 #endif
1148       return
1149       end
1150 c-------------------------------------------------------------------------------
1151       subroutine rescale_weights(t_bath)
1152       implicit real*8 (a-h,o-z)
1153       include 'DIMENSIONS'
1154       include 'COMMON.IOUNITS'
1155       include 'COMMON.FFIELD'
1156       include 'COMMON.SBRIDGE'
1157       include 'COMMON.CONTROL'
1158       double precision kfac /2.4d0/
1159       double precision x,x2,x3,x4,x5,licznik /1.12692801104297249644/
1160 c      facT=temp0/t_bath
1161 c      facT=2*temp0/(t_bath+temp0)
1162       if (rescale_mode.eq.0) then
1163         facT=1.0d0
1164         facT2=1.0d0
1165         facT3=1.0d0
1166         facT4=1.0d0
1167         facT5=1.0d0
1168       else if (rescale_mode.eq.1) then
1169         facT=kfac/(kfac-1.0d0+t_bath/temp0)
1170         facT2=kfac**2/(kfac**2-1.0d0+(t_bath/temp0)**2)
1171         facT3=kfac**3/(kfac**3-1.0d0+(t_bath/temp0)**3)
1172         facT4=kfac**4/(kfac**4-1.0d0+(t_bath/temp0)**4)
1173         facT5=kfac**5/(kfac**5-1.0d0+(t_bath/temp0)**5)
1174       else if (rescale_mode.eq.2) then
1175         x=t_bath/temp0
1176         x2=x*x
1177         x3=x2*x
1178         x4=x3*x
1179         x5=x4*x
1180         facT=licznik/dlog(dexp(x)+dexp(-x))
1181         facT2=licznik/dlog(dexp(x2)+dexp(-x2))
1182         facT3=licznik/dlog(dexp(x3)+dexp(-x3))
1183         facT4=licznik/dlog(dexp(x4)+dexp(-x4))
1184         facT5=licznik/dlog(dexp(x5)+dexp(-x5))
1185       else
1186         write (iout,*) "Wrong RESCALE_MODE",rescale_mode
1187         write (*,*) "Wrong RESCALE_MODE",rescale_mode
1188 #ifdef MPI
1189        call MPI_Finalize(MPI_COMM_WORLD,IERROR)
1190 #endif
1191        stop 555
1192       endif
1193       if (shield_mode.gt.0) then
1194        wscp=weights(2)*fact
1195        wsc=weights(1)*fact
1196        wvdwpp=weights(16)*fact
1197       endif
1198       welec=weights(3)*fact
1199       wcorr=weights(4)*fact3
1200       wcorr5=weights(5)*fact4
1201       wcorr6=weights(6)*fact5
1202       wel_loc=weights(7)*fact2
1203       wturn3=weights(8)*fact2
1204       wturn4=weights(9)*fact3
1205       wturn6=weights(10)*fact5
1206       wtor=weights(13)*fact
1207       wtor_d=weights(14)*fact2
1208       wsccor=weights(21)*fact
1209       if (scale_umb) wumb=t_bath/temp0
1210 c      write (iout,*) "scale_umb",scale_umb
1211 c      write (iout,*) "t_bath",t_bath," temp0",temp0," wumb",wumb
1212
1213       return
1214       end
1215 C------------------------------------------------------------------------
1216       subroutine enerprint(energia)
1217       implicit real*8 (a-h,o-z)
1218       include 'DIMENSIONS'
1219       include 'COMMON.IOUNITS'
1220       include 'COMMON.FFIELD'
1221       include 'COMMON.SBRIDGE'
1222       include 'COMMON.MD'
1223       double precision energia(0:n_ene)
1224       etot=energia(0)
1225       evdw=energia(1)
1226       evdw2=energia(2)
1227 #ifdef SCP14
1228       evdw2=energia(2)+energia(18)
1229 #else
1230       evdw2=energia(2)
1231 #endif
1232       ees=energia(3)
1233 #ifdef SPLITELE
1234       evdw1=energia(16)
1235 #endif
1236       ecorr=energia(4)
1237       ecorr5=energia(5)
1238       ecorr6=energia(6)
1239       eel_loc=energia(7)
1240       eello_turn3=energia(8)
1241       eello_turn4=energia(9)
1242       eello_turn6=energia(10)
1243       ebe=energia(11)
1244       escloc=energia(12)
1245       etors=energia(13)
1246       etors_d=energia(14)
1247       ehpb=energia(15)
1248       edihcnstr=energia(19)
1249       estr=energia(17)
1250       Uconst=energia(20)
1251       esccor=energia(21)
1252       eliptran=energia(22)
1253       Eafmforce=energia(23)
1254       ethetacnstr=energia(24)
1255       etube=energia(25)
1256       esaxs=energia(26)
1257       ehomology_constr=energia(27)
1258 C     Bartek
1259       edfadis = energia(28)
1260       edfator = energia(29)
1261       edfanei = energia(30)
1262       edfabet = energia(31)
1263 #ifdef SPLITELE
1264       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,evdw1,wvdwpp,
1265      &  estr,wbond,ebe,wang,
1266      &  escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,
1267      &  ecorr,wcorr,
1268      &  ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,
1269      &  eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccor,edihcnstr,
1270      &  ethetacnstr,ebr*nss,Uconst,wumb,eliptran,wliptran,Eafmforc,
1271      &  etube,wtube,esaxs,wsaxs,ehomology_constr,
1272      &  edfadis,wdfa_dist,edfator,wdfa_tor,edfanei,wdfa_nei,
1273      &  edfabet,wdfa_beta,
1274      &  etot
1275    10 format (/'Virtual-chain energies:'//
1276      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
1277      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
1278      & 'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/
1279      & 'EVDWPP=',1pE16.6,' WEIGHT=',1pD16.6,' (p-p VDW)'/
1280      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
1281      & 'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
1282      & 'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
1283      & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
1284      & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
1285      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6,
1286      & ' (SS bridges & dist. cnstr.)'/
1287      & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1288      & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1289      & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1290      & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
1291      & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
1292      & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
1293      & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
1294      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
1295      & 'EDIHC= ',1pE16.6,' (virtual-bond dihedral angle restraints)'/
1296      & 'ETHETC=',1pE16.6,' (virtual-bond angle restraints)'/
1297      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
1298      & 'UCONST=',1pE16.6,' WEIGHT=',1pD16.6' (umbrella restraints)'/
1299      & 'ELT=   ',1pE16.6,' WEIGHT=',1pD16.6,' (Lipid transfer)'/
1300      & 'EAFM=  ',1pE16.6,' (atomic-force microscopy)'/
1301      & 'ETUBE= ',1pE16.6,' WEIGHT=',1pD16.6,' (tube confinment)'/
1302      & 'E_SAXS=',1pE16.6,' WEIGHT=',1pD16.6,' (SAXS restraints)'/
1303      & 'H_CONS=',1pE16.6,' (Homology model constraints energy)'/
1304      & 'EDFAD= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA distance energy)'/
1305      & 'EDFAT= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA torsion energy)'/
1306      & 'EDFAN= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA NCa energy)'/
1307      & 'EDFAB= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA Beta energy)'/
1308      & 'ETOT=  ',1pE16.6,' (total)')
1309
1310 #else
1311       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,
1312      &  estr,wbond,ebe,wang,
1313      &  escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,
1314      &  ecorr,wcorr,
1315      &  ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,
1316      &  eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccor,edihcnstr,
1317      &  ethetacnstr,ebr*nss,Uconst,wumb,eliptran,wliptran,Eafmforc,
1318      &  etube,wtube,esaxs,wsaxs,ehomology_constr,
1319      &  edfadis,wdfa_dist,edfator,wdfa_tor,edfanei,wdfa_nei,
1320      &  edfabet,wdfa_beta,
1321      &  etot
1322    10 format (/'Virtual-chain energies:'//
1323      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
1324      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
1325      & 'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/
1326      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
1327      & 'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
1328      & 'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
1329      & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
1330      & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
1331      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6,
1332      & ' (SS bridges & dist. restr.)'/
1333      & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1334      & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1335      & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1336      & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
1337      & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
1338      & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
1339      & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
1340      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
1341      & 'EDIHC= ',1pE16.6,' (virtual-bond dihedral angle restraints)'/
1342      & 'ETHETC=',1pE16.6,' (virtual-bond angle restraints)'/
1343      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
1344      & 'UCONST=',1pE16.6,' WEIGHT=',1pD16.6' (umbrella restraints)'/
1345      & 'ELT=   ',1pE16.6,' WEIGHT=',1pD16.6,' (Lipid transfer)'/
1346      & 'EAFM=  ',1pE16.6,' (atomic-force microscopy)'/
1347      & 'ETUBE= ',1pE16.6,' WEIGHT=',1pD16.6,' (tube confinment)'/
1348      & 'E_SAXS=',1pE16.6,' WEIGHT=',1pD16.6,' (SAXS restraints)'/
1349      & 'H_CONS=',1pE16.6,' (Homology model constraints energy)'/
1350      & 'EDFAD= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA distance energy)'/
1351      & 'EDFAT= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA torsion energy)'/
1352      & 'EDFAN= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA NCa energy)'/
1353      & 'EDFAB= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA Beta energy)'/
1354      & 'ETOT=  ',1pE16.6,' (total)')
1355 #endif
1356       return
1357       end
1358 C-----------------------------------------------------------------------
1359       subroutine elj(evdw)
1360 C
1361 C This subroutine calculates the interaction energy of nonbonded side chains
1362 C assuming the LJ potential of interaction.
1363 C
1364       implicit real*8 (a-h,o-z)
1365       include 'DIMENSIONS'
1366       parameter (accur=1.0d-10)
1367       include 'COMMON.GEO'
1368       include 'COMMON.VAR'
1369       include 'COMMON.LOCAL'
1370       include 'COMMON.CHAIN'
1371       include 'COMMON.DERIV'
1372       include 'COMMON.INTERACT'
1373       include 'COMMON.TORSION'
1374       include 'COMMON.SBRIDGE'
1375       include 'COMMON.NAMES'
1376       include 'COMMON.IOUNITS'
1377       include 'COMMON.CONTACTS'
1378       dimension gg(3)
1379 c      write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
1380       evdw=0.0D0
1381       do i=iatsc_s,iatsc_e
1382         itypi=iabs(itype(i))
1383         if (itypi.eq.ntyp1) cycle
1384         itypi1=iabs(itype(i+1))
1385         xi=c(1,nres+i)
1386         yi=c(2,nres+i)
1387         zi=c(3,nres+i)
1388 C Change 12/1/95
1389         num_conti=0
1390 C
1391 C Calculate SC interaction energy.
1392 C
1393         do iint=1,nint_gr(i)
1394 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
1395 cd   &                  'iend=',iend(i,iint)
1396           do j=istart(i,iint),iend(i,iint)
1397             itypj=iabs(itype(j))
1398             if (itypj.eq.ntyp1) cycle
1399             xj=c(1,nres+j)-xi
1400             yj=c(2,nres+j)-yi
1401             zj=c(3,nres+j)-zi
1402 C Change 12/1/95 to calculate four-body interactions
1403             rij=xj*xj+yj*yj+zj*zj
1404             rrij=1.0D0/rij
1405 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
1406             eps0ij=eps(itypi,itypj)
1407             fac=rrij**expon2
1408 C have you changed here?
1409             e1=fac*fac*aa
1410             e2=fac*bb
1411             evdwij=e1+e2
1412 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1413 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1414 cd          write (iout,'(2(a3,i3,2x),6(1pd12.4)/2(3(1pd12.4),5x)/)')
1415 cd   &        restyp(itypi),i,restyp(itypj),j,a(itypi,itypj),
1416 cd   &        bb(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,epsi,sigm,
1417 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1418             evdw=evdw+evdwij
1419 C
1420 C Calculate the components of the gradient in DC and X
1421 C
1422             fac=-rrij*(e1+evdwij)
1423             gg(1)=xj*fac
1424             gg(2)=yj*fac
1425             gg(3)=zj*fac
1426             do k=1,3
1427               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1428               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1429               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1430               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1431             enddo
1432 cgrad            do k=i,j-1
1433 cgrad              do l=1,3
1434 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1435 cgrad              enddo
1436 cgrad            enddo
1437 C
1438 C 12/1/95, revised on 5/20/97
1439 C
1440 C Calculate the contact function. The ith column of the array JCONT will
1441 C contain the numbers of atoms that make contacts with the atom I (of numbers
1442 C greater than I). The arrays FACONT and GACONT will contain the values of
1443 C the contact function and its derivative.
1444 C
1445 C Uncomment next line, if the correlation interactions include EVDW explicitly.
1446 c           if (j.gt.i+1 .and. evdwij.le.0.0D0) then
1447 C Uncomment next line, if the correlation interactions are contact function only
1448             if (j.gt.i+1.and. eps0ij.gt.0.0D0) then
1449               rij=dsqrt(rij)
1450               sigij=sigma(itypi,itypj)
1451               r0ij=rs0(itypi,itypj)
1452 C
1453 C Check whether the SC's are not too far to make a contact.
1454 C
1455               rcut=1.5d0*r0ij
1456               call gcont(rij,rcut,1.0d0,0.2d0*rcut,fcont,fprimcont)
1457 C Add a new contact, if the SC's are close enough, but not too close (r<sigma).
1458 C
1459               if (fcont.gt.0.0D0) then
1460 C If the SC-SC distance if close to sigma, apply spline.
1461 cAdam           call gcont(-rij,-1.03d0*sigij,2.0d0*sigij,1.0d0,
1462 cAdam &             fcont1,fprimcont1)
1463 cAdam           fcont1=1.0d0-fcont1
1464 cAdam           if (fcont1.gt.0.0d0) then
1465 cAdam             fprimcont=fprimcont*fcont1+fcont*fprimcont1
1466 cAdam             fcont=fcont*fcont1
1467 cAdam           endif
1468 C Uncomment following 4 lines to have the geometric average of the epsilon0's
1469 cga             eps0ij=1.0d0/dsqrt(eps0ij)
1470 cga             do k=1,3
1471 cga               gg(k)=gg(k)*eps0ij
1472 cga             enddo
1473 cga             eps0ij=-evdwij*eps0ij
1474 C Uncomment for AL's type of SC correlation interactions.
1475 cadam           eps0ij=-evdwij
1476                 num_conti=num_conti+1
1477                 jcont(num_conti,i)=j
1478                 facont(num_conti,i)=fcont*eps0ij
1479                 fprimcont=eps0ij*fprimcont/rij
1480                 fcont=expon*fcont
1481 cAdam           gacont(1,num_conti,i)=-fprimcont*xj+fcont*gg(1)
1482 cAdam           gacont(2,num_conti,i)=-fprimcont*yj+fcont*gg(2)
1483 cAdam           gacont(3,num_conti,i)=-fprimcont*zj+fcont*gg(3)
1484 C Uncomment following 3 lines for Skolnick's type of SC correlation.
1485                 gacont(1,num_conti,i)=-fprimcont*xj
1486                 gacont(2,num_conti,i)=-fprimcont*yj
1487                 gacont(3,num_conti,i)=-fprimcont*zj
1488 cd              write (iout,'(2i5,2f10.5)') i,j,rij,facont(num_conti,i)
1489 cd              write (iout,'(2i3,3f10.5)')
1490 cd   &           i,j,(gacont(kk,num_conti,i),kk=1,3)
1491               endif
1492             endif
1493           enddo      ! j
1494         enddo        ! iint
1495 C Change 12/1/95
1496         num_cont(i)=num_conti
1497       enddo          ! i
1498       do i=1,nct
1499         do j=1,3
1500           gvdwc(j,i)=expon*gvdwc(j,i)
1501           gvdwx(j,i)=expon*gvdwx(j,i)
1502         enddo
1503       enddo
1504 C******************************************************************************
1505 C
1506 C                              N O T E !!!
1507 C
1508 C To save time, the factor of EXPON has been extracted from ALL components
1509 C of GVDWC and GRADX. Remember to multiply them by this factor before further
1510 C use!
1511 C
1512 C******************************************************************************
1513       return
1514       end
1515 C-----------------------------------------------------------------------------
1516       subroutine eljk(evdw)
1517 C
1518 C This subroutine calculates the interaction energy of nonbonded side chains
1519 C assuming the LJK potential of interaction.
1520 C
1521       implicit real*8 (a-h,o-z)
1522       include 'DIMENSIONS'
1523       include 'COMMON.GEO'
1524       include 'COMMON.VAR'
1525       include 'COMMON.LOCAL'
1526       include 'COMMON.CHAIN'
1527       include 'COMMON.DERIV'
1528       include 'COMMON.INTERACT'
1529       include 'COMMON.IOUNITS'
1530       include 'COMMON.NAMES'
1531       dimension gg(3)
1532       logical scheck
1533 c     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
1534       evdw=0.0D0
1535       do i=iatsc_s,iatsc_e
1536         itypi=iabs(itype(i))
1537         if (itypi.eq.ntyp1) cycle
1538         itypi1=iabs(itype(i+1))
1539         xi=c(1,nres+i)
1540         yi=c(2,nres+i)
1541         zi=c(3,nres+i)
1542 C
1543 C Calculate SC interaction energy.
1544 C
1545         do iint=1,nint_gr(i)
1546           do j=istart(i,iint),iend(i,iint)
1547             itypj=iabs(itype(j))
1548             if (itypj.eq.ntyp1) cycle
1549             xj=c(1,nres+j)-xi
1550             yj=c(2,nres+j)-yi
1551             zj=c(3,nres+j)-zi
1552             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1553             fac_augm=rrij**expon
1554             e_augm=augm(itypi,itypj)*fac_augm
1555             r_inv_ij=dsqrt(rrij)
1556             rij=1.0D0/r_inv_ij
1557             r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
1558             fac=r_shift_inv**expon
1559 C have you changed here?
1560             e1=fac*fac*aa
1561             e2=fac*bb
1562             evdwij=e_augm+e1+e2
1563 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1564 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1565 cd          write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
1566 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
1567 cd   &        bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
1568 cd   &        sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
1569 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1570             evdw=evdw+evdwij
1571 C
1572 C Calculate the components of the gradient in DC and X
1573 C
1574             fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
1575             gg(1)=xj*fac
1576             gg(2)=yj*fac
1577             gg(3)=zj*fac
1578             do k=1,3
1579               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1580               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1581               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1582               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1583             enddo
1584 cgrad            do k=i,j-1
1585 cgrad              do l=1,3
1586 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1587 cgrad              enddo
1588 cgrad            enddo
1589           enddo      ! j
1590         enddo        ! iint
1591       enddo          ! i
1592       do i=1,nct
1593         do j=1,3
1594           gvdwc(j,i)=expon*gvdwc(j,i)
1595           gvdwx(j,i)=expon*gvdwx(j,i)
1596         enddo
1597       enddo
1598       return
1599       end
1600 C-----------------------------------------------------------------------------
1601       subroutine ebp(evdw)
1602 C
1603 C This subroutine calculates the interaction energy of nonbonded side chains
1604 C assuming the Berne-Pechukas potential of interaction.
1605 C
1606       implicit real*8 (a-h,o-z)
1607       include 'DIMENSIONS'
1608       include 'COMMON.GEO'
1609       include 'COMMON.VAR'
1610       include 'COMMON.LOCAL'
1611       include 'COMMON.CHAIN'
1612       include 'COMMON.DERIV'
1613       include 'COMMON.NAMES'
1614       include 'COMMON.INTERACT'
1615       include 'COMMON.IOUNITS'
1616       include 'COMMON.CALC'
1617       common /srutu/ icall
1618 c     double precision rrsave(maxdim)
1619       logical lprn
1620       evdw=0.0D0
1621 c     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
1622       evdw=0.0D0
1623 c     if (icall.eq.0) then
1624 c       lprn=.true.
1625 c     else
1626         lprn=.false.
1627 c     endif
1628       ind=0
1629       do i=iatsc_s,iatsc_e
1630         itypi=iabs(itype(i))
1631         if (itypi.eq.ntyp1) cycle
1632         itypi1=iabs(itype(i+1))
1633         xi=c(1,nres+i)
1634         yi=c(2,nres+i)
1635         zi=c(3,nres+i)
1636         dxi=dc_norm(1,nres+i)
1637         dyi=dc_norm(2,nres+i)
1638         dzi=dc_norm(3,nres+i)
1639 c        dsci_inv=dsc_inv(itypi)
1640         dsci_inv=vbld_inv(i+nres)
1641 C
1642 C Calculate SC interaction energy.
1643 C
1644         do iint=1,nint_gr(i)
1645           do j=istart(i,iint),iend(i,iint)
1646             ind=ind+1
1647             itypj=iabs(itype(j))
1648             if (itypj.eq.ntyp1) cycle
1649 c            dscj_inv=dsc_inv(itypj)
1650             dscj_inv=vbld_inv(j+nres)
1651             chi1=chi(itypi,itypj)
1652             chi2=chi(itypj,itypi)
1653             chi12=chi1*chi2
1654             chip1=chip(itypi)
1655             chip2=chip(itypj)
1656             chip12=chip1*chip2
1657             alf1=alp(itypi)
1658             alf2=alp(itypj)
1659             alf12=0.5D0*(alf1+alf2)
1660 C For diagnostics only!!!
1661 c           chi1=0.0D0
1662 c           chi2=0.0D0
1663 c           chi12=0.0D0
1664 c           chip1=0.0D0
1665 c           chip2=0.0D0
1666 c           chip12=0.0D0
1667 c           alf1=0.0D0
1668 c           alf2=0.0D0
1669 c           alf12=0.0D0
1670             xj=c(1,nres+j)-xi
1671             yj=c(2,nres+j)-yi
1672             zj=c(3,nres+j)-zi
1673             dxj=dc_norm(1,nres+j)
1674             dyj=dc_norm(2,nres+j)
1675             dzj=dc_norm(3,nres+j)
1676             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1677 cd          if (icall.eq.0) then
1678 cd            rrsave(ind)=rrij
1679 cd          else
1680 cd            rrij=rrsave(ind)
1681 cd          endif
1682             rij=dsqrt(rrij)
1683 C Calculate the angle-dependent terms of energy & contributions to derivatives.
1684             call sc_angular
1685 C Calculate whole angle-dependent part of epsilon and contributions
1686 C to its derivatives
1687 C have you changed here?
1688             fac=(rrij*sigsq)**expon2
1689             e1=fac*fac*aa
1690             e2=fac*bb
1691             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1692             eps2der=evdwij*eps3rt
1693             eps3der=evdwij*eps2rt
1694             evdwij=evdwij*eps2rt*eps3rt
1695             evdw=evdw+evdwij
1696             if (lprn) then
1697             sigm=dabs(aa/bb)**(1.0D0/6.0D0)
1698             epsi=bb**2/aa
1699 cd            write (iout,'(2(a3,i3,2x),15(0pf7.3))')
1700 cd     &        restyp(itypi),i,restyp(itypj),j,
1701 cd     &        epsi,sigm,chi1,chi2,chip1,chip2,
1702 cd     &        eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
1703 cd     &        om1,om2,om12,1.0D0/dsqrt(rrij),
1704 cd     &        evdwij
1705             endif
1706 C Calculate gradient components.
1707             e1=e1*eps1*eps2rt**2*eps3rt**2
1708             fac=-expon*(e1+evdwij)
1709             sigder=fac/sigsq
1710             fac=rrij*fac
1711 C Calculate radial part of the gradient
1712             gg(1)=xj*fac
1713             gg(2)=yj*fac
1714             gg(3)=zj*fac
1715 C Calculate the angular part of the gradient and sum add the contributions
1716 C to the appropriate components of the Cartesian gradient.
1717             call sc_grad
1718           enddo      ! j
1719         enddo        ! iint
1720       enddo          ! i
1721 c     stop
1722       return
1723       end
1724 C-----------------------------------------------------------------------------
1725       subroutine egb(evdw)
1726 C
1727 C This subroutine calculates the interaction energy of nonbonded side chains
1728 C assuming the Gay-Berne potential of interaction.
1729 C
1730       implicit real*8 (a-h,o-z)
1731       include 'DIMENSIONS'
1732       include 'COMMON.GEO'
1733       include 'COMMON.VAR'
1734       include 'COMMON.LOCAL'
1735       include 'COMMON.CHAIN'
1736       include 'COMMON.DERIV'
1737       include 'COMMON.NAMES'
1738       include 'COMMON.INTERACT'
1739       include 'COMMON.IOUNITS'
1740       include 'COMMON.CALC'
1741       include 'COMMON.CONTROL'
1742       include 'COMMON.SPLITELE'
1743       include 'COMMON.SBRIDGE'
1744       logical lprn
1745       integer xshift,yshift,zshift
1746
1747       evdw=0.0D0
1748 ccccc      energy_dec=.false.
1749 C      print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1750       evdw=0.0D0
1751       lprn=.false.
1752 c     if (icall.eq.0) lprn=.false.
1753       ind=0
1754 C the loop over all 27 posible neigbours (for xshift=0,yshift=0,zshift=0
1755 C we have the original box)
1756 C      do xshift=-1,1
1757 C      do yshift=-1,1
1758 C      do zshift=-1,1
1759       do i=iatsc_s,iatsc_e
1760         itypi=iabs(itype(i))
1761         if (itypi.eq.ntyp1) cycle
1762         itypi1=iabs(itype(i+1))
1763         xi=c(1,nres+i)
1764         yi=c(2,nres+i)
1765         zi=c(3,nres+i)
1766 C Return atom into box, boxxsize is size of box in x dimension
1767 c  134   continue
1768 c        if (xi.gt.((xshift+0.5d0)*boxxsize)) xi=xi-boxxsize
1769 c        if (xi.lt.((xshift-0.5d0)*boxxsize)) xi=xi+boxxsize
1770 C Condition for being inside the proper box
1771 c        if ((xi.gt.((xshift+0.5d0)*boxxsize)).or.
1772 c     &       (xi.lt.((xshift-0.5d0)*boxxsize))) then
1773 c        go to 134
1774 c        endif
1775 c  135   continue
1776 c        if (yi.gt.((yshift+0.5d0)*boxysize)) yi=yi-boxysize
1777 c        if (yi.lt.((yshift-0.5d0)*boxysize)) yi=yi+boxysize
1778 C Condition for being inside the proper box
1779 c        if ((yi.gt.((yshift+0.5d0)*boxysize)).or.
1780 c     &       (yi.lt.((yshift-0.5d0)*boxysize))) then
1781 c        go to 135
1782 c        endif
1783 c  136   continue
1784 c        if (zi.gt.((zshift+0.5d0)*boxzsize)) zi=zi-boxzsize
1785 c        if (zi.lt.((zshift-0.5d0)*boxzsize)) zi=zi+boxzsize
1786 C Condition for being inside the proper box
1787 c        if ((zi.gt.((zshift+0.5d0)*boxzsize)).or.
1788 c     &       (zi.lt.((zshift-0.5d0)*boxzsize))) then
1789 c        go to 136
1790 c        endif
1791           xi=mod(xi,boxxsize)
1792           if (xi.lt.0) xi=xi+boxxsize
1793           yi=mod(yi,boxysize)
1794           if (yi.lt.0) yi=yi+boxysize
1795           zi=mod(zi,boxzsize)
1796           if (zi.lt.0) zi=zi+boxzsize
1797 C define scaling factor for lipids
1798
1799 C        if (positi.le.0) positi=positi+boxzsize
1800 C        print *,i
1801 C first for peptide groups
1802 c for each residue check if it is in lipid or lipid water border area
1803        if ((zi.gt.bordlipbot)
1804      &.and.(zi.lt.bordliptop)) then
1805 C the energy transfer exist
1806         if (zi.lt.buflipbot) then
1807 C what fraction I am in
1808          fracinbuf=1.0d0-
1809      &        ((zi-bordlipbot)/lipbufthick)
1810 C lipbufthick is thickenes of lipid buffore
1811          sslipi=sscalelip(fracinbuf)
1812          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
1813         elseif (zi.gt.bufliptop) then
1814          fracinbuf=1.0d0-((bordliptop-zi)/lipbufthick)
1815          sslipi=sscalelip(fracinbuf)
1816          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
1817         else
1818          sslipi=1.0d0
1819          ssgradlipi=0.0
1820         endif
1821        else
1822          sslipi=0.0d0
1823          ssgradlipi=0.0
1824        endif
1825
1826 C          xi=xi+xshift*boxxsize
1827 C          yi=yi+yshift*boxysize
1828 C          zi=zi+zshift*boxzsize
1829
1830         dxi=dc_norm(1,nres+i)
1831         dyi=dc_norm(2,nres+i)
1832         dzi=dc_norm(3,nres+i)
1833 c        dsci_inv=dsc_inv(itypi)
1834         dsci_inv=vbld_inv(i+nres)
1835 c        write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)
1836 c        write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi
1837 C
1838 C Calculate SC interaction energy.
1839 C
1840         do iint=1,nint_gr(i)
1841           do j=istart(i,iint),iend(i,iint)
1842             IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN
1843
1844 c              write(iout,*) "PRZED ZWYKLE", evdwij
1845               call dyn_ssbond_ene(i,j,evdwij)
1846 c              write(iout,*) "PO ZWYKLE", evdwij
1847
1848               evdw=evdw+evdwij
1849               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)')
1850      &                        'evdw',i,j,evdwij,' ss'
1851 C triple bond artifac removal
1852              do k=j+1,iend(i,iint)
1853 C search over all next residues
1854               if (dyn_ss_mask(k)) then
1855 C check if they are cysteins
1856 C              write(iout,*) 'k=',k
1857
1858 c              write(iout,*) "PRZED TRI", evdwij
1859                evdwij_przed_tri=evdwij
1860               call triple_ssbond_ene(i,j,k,evdwij)
1861 c               if(evdwij_przed_tri.ne.evdwij) then
1862 c                 write (iout,*) "TRI:", evdwij, evdwij_przed_tri
1863 c               endif
1864
1865 c              write(iout,*) "PO TRI", evdwij
1866 C call the energy function that removes the artifical triple disulfide
1867 C bond the soubroutine is located in ssMD.F
1868               evdw=evdw+evdwij
1869               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)')
1870      &                        'evdw',i,j,evdwij,'tss'
1871               endif!dyn_ss_mask(k)
1872              enddo! k
1873             ELSE
1874             ind=ind+1
1875             itypj=iabs(itype(j))
1876             if (itypj.eq.ntyp1) cycle
1877 c            dscj_inv=dsc_inv(itypj)
1878             dscj_inv=vbld_inv(j+nres)
1879 c            write (iout,*) "j",j,dsc_inv(itypj),dscj_inv,
1880 c     &       1.0d0/vbld(j+nres)
1881 c            write (iout,*) "i",i," j", j," itype",itype(i),itype(j)
1882             sig0ij=sigma(itypi,itypj)
1883             chi1=chi(itypi,itypj)
1884             chi2=chi(itypj,itypi)
1885             chi12=chi1*chi2
1886             chip1=chip(itypi)
1887             chip2=chip(itypj)
1888             chip12=chip1*chip2
1889             alf1=alp(itypi)
1890             alf2=alp(itypj)
1891             alf12=0.5D0*(alf1+alf2)
1892 C For diagnostics only!!!
1893 c           chi1=0.0D0
1894 c           chi2=0.0D0
1895 c           chi12=0.0D0
1896 c           chip1=0.0D0
1897 c           chip2=0.0D0
1898 c           chip12=0.0D0
1899 c           alf1=0.0D0
1900 c           alf2=0.0D0
1901 c           alf12=0.0D0
1902             xj=c(1,nres+j)
1903             yj=c(2,nres+j)
1904             zj=c(3,nres+j)
1905 C Return atom J into box the original box
1906 c  137   continue
1907 c        if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
1908 c        if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
1909 C Condition for being inside the proper box
1910 c        if ((xj.gt.((0.5d0)*boxxsize)).or.
1911 c     &       (xj.lt.((-0.5d0)*boxxsize))) then
1912 c        go to 137
1913 c        endif
1914 c  138   continue
1915 c        if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
1916 c        if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
1917 C Condition for being inside the proper box
1918 c        if ((yj.gt.((0.5d0)*boxysize)).or.
1919 c     &       (yj.lt.((-0.5d0)*boxysize))) then
1920 c        go to 138
1921 c        endif
1922 c  139   continue
1923 c        if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
1924 c        if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
1925 C Condition for being inside the proper box
1926 c        if ((zj.gt.((0.5d0)*boxzsize)).or.
1927 c     &       (zj.lt.((-0.5d0)*boxzsize))) then
1928 c        go to 139
1929 c        endif
1930           xj=mod(xj,boxxsize)
1931           if (xj.lt.0) xj=xj+boxxsize
1932           yj=mod(yj,boxysize)
1933           if (yj.lt.0) yj=yj+boxysize
1934           zj=mod(zj,boxzsize)
1935           if (zj.lt.0) zj=zj+boxzsize
1936        if ((zj.gt.bordlipbot)
1937      &.and.(zj.lt.bordliptop)) then
1938 C the energy transfer exist
1939         if (zj.lt.buflipbot) then
1940 C what fraction I am in
1941          fracinbuf=1.0d0-
1942      &        ((zj-bordlipbot)/lipbufthick)
1943 C lipbufthick is thickenes of lipid buffore
1944          sslipj=sscalelip(fracinbuf)
1945          ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
1946         elseif (zj.gt.bufliptop) then
1947          fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
1948          sslipj=sscalelip(fracinbuf)
1949          ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
1950         else
1951          sslipj=1.0d0
1952          ssgradlipj=0.0
1953         endif
1954        else
1955          sslipj=0.0d0
1956          ssgradlipj=0.0
1957        endif
1958       aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
1959      &  +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1960       bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
1961      &  +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1962 C      write(iout,*) "tu,", i,j,aa_lip(itypi,itypj),bb_lip(itypi,itypj)
1963 C      if (aa.ne.aa_aq(itypi,itypj)) write(63,'(2e10.5)')
1964 C     &(aa-aa_aq(itypi,itypj)),(bb-bb_aq(itypi,itypj))
1965 C      if (ssgradlipj.gt.0.0d0) print *,"??WTF??"
1966 C      print *,sslipi,sslipj,bordlipbot,zi,zj
1967       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
1968       xj_safe=xj
1969       yj_safe=yj
1970       zj_safe=zj
1971       subchap=0
1972       do xshift=-1,1
1973       do yshift=-1,1
1974       do zshift=-1,1
1975           xj=xj_safe+xshift*boxxsize
1976           yj=yj_safe+yshift*boxysize
1977           zj=zj_safe+zshift*boxzsize
1978           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
1979           if(dist_temp.lt.dist_init) then
1980             dist_init=dist_temp
1981             xj_temp=xj
1982             yj_temp=yj
1983             zj_temp=zj
1984             subchap=1
1985           endif
1986        enddo
1987        enddo
1988        enddo
1989        if (subchap.eq.1) then
1990           xj=xj_temp-xi
1991           yj=yj_temp-yi
1992           zj=zj_temp-zi
1993        else
1994           xj=xj_safe-xi
1995           yj=yj_safe-yi
1996           zj=zj_safe-zi
1997        endif
1998             dxj=dc_norm(1,nres+j)
1999             dyj=dc_norm(2,nres+j)
2000             dzj=dc_norm(3,nres+j)
2001 C            xj=xj-xi
2002 C            yj=yj-yi
2003 C            zj=zj-zi
2004 c            write (iout,*) "dcnorj",dxi*dxi+dyi*dyi+dzi*dzi
2005 c            write (iout,*) "j",j," dc_norm",
2006 c     &       dc_norm(1,nres+j),dc_norm(2,nres+j),dc_norm(3,nres+j)
2007             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
2008             rij=dsqrt(rrij)
2009             sss=sscale((1.0d0/rij)/sigma(itypi,itypj))
2010             sssgrad=sscagrad((1.0d0/rij)/sigma(itypi,itypj))
2011
2012 c            write (iout,'(a7,4f8.3)')
2013 c    &      "ssscale",sss,((1.0d0/rij)/sigma(itypi,itypj)),r_cut,rlamb
2014             if (sss.gt.0.0d0) then
2015 C Calculate angle-dependent terms of energy and contributions to their
2016 C derivatives.
2017             call sc_angular
2018             sigsq=1.0D0/sigsq
2019             sig=sig0ij*dsqrt(sigsq)
2020             rij_shift=1.0D0/rij-sig+sig0ij
2021 c for diagnostics; uncomment
2022 c            rij_shift=1.2*sig0ij
2023 C I hate to put IF's in the loops, but here don't have another choice!!!!
2024             if (rij_shift.le.0.0D0) then
2025               evdw=1.0D20
2026 cd              write (iout,'(2(a3,i3,2x),17(0pf7.3))')
2027 cd     &        restyp(itypi),i,restyp(itypj),j,
2028 cd     &        rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq)
2029               return
2030             endif
2031             sigder=-sig*sigsq
2032 c---------------------------------------------------------------
2033             rij_shift=1.0D0/rij_shift
2034             fac=rij_shift**expon
2035 C here to start with
2036 C            if (c(i,3).gt.
2037             faclip=fac
2038             e1=fac*fac*aa
2039             e2=fac*bb
2040             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
2041             eps2der=evdwij*eps3rt
2042             eps3der=evdwij*eps2rt
2043 C       write(63,'(2i3,2e10.3,2f10.5)') i,j,aa,bb, evdwij,
2044 C     &((sslipi+sslipj)/2.0d0+
2045 C     &(2.0d0-sslipi-sslipj)/2.0d0)
2046 c            write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt,
2047 c     &        " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2
2048             evdwij=evdwij*eps2rt*eps3rt
2049             evdw=evdw+evdwij*sss
2050             if (lprn) then
2051             sigm=dabs(aa/bb)**(1.0D0/6.0D0)
2052             epsi=bb**2/aa
2053             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
2054      &        restyp(itypi),i,restyp(itypj),j,
2055      &        epsi,sigm,chi1,chi2,chip1,chip2,
2056      &        eps1,eps2rt**2,eps3rt**2,sig,sig0ij,
2057      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
2058      &        evdwij
2059             endif
2060
2061             if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
2062      &                        'evdw',i,j,evdwij
2063
2064 C Calculate gradient components.
2065             e1=e1*eps1*eps2rt**2*eps3rt**2
2066             fac=-expon*(e1+evdwij)*rij_shift
2067             sigder=fac*sigder
2068             fac=rij*fac
2069 c            print '(2i4,6f8.4)',i,j,sss,sssgrad*
2070 c     &      evdwij,fac,sigma(itypi,itypj),expon
2071             fac=fac+evdwij/sss*sssgrad/sigma(itypi,itypj)*rij
2072 c            fac=0.0d0
2073 C Calculate the radial part of the gradient
2074             gg_lipi(3)=eps1*(eps2rt*eps2rt)
2075      &*(eps3rt*eps3rt)*sss/2.0d0*(faclip*faclip*
2076      & (aa_lip(itypi,itypj)-aa_aq(itypi,itypj))
2077      &+faclip*(bb_lip(itypi,itypj)-bb_aq(itypi,itypj)))
2078             gg_lipj(3)=ssgradlipj*gg_lipi(3)
2079             gg_lipi(3)=gg_lipi(3)*ssgradlipi
2080 C            gg_lipi(3)=0.0d0
2081 C            gg_lipj(3)=0.0d0
2082             gg(1)=xj*fac
2083             gg(2)=yj*fac
2084             gg(3)=zj*fac
2085 C Calculate angular part of the gradient.
2086             call sc_grad
2087             endif
2088             ENDIF    ! dyn_ss
2089           enddo      ! j
2090         enddo        ! iint
2091       enddo          ! i
2092 C      enddo          ! zshift
2093 C      enddo          ! yshift
2094 C      enddo          ! xshift
2095 c      write (iout,*) "Number of loop steps in EGB:",ind
2096 cccc      energy_dec=.false.
2097       return
2098       end
2099 C-----------------------------------------------------------------------------
2100       subroutine egbv(evdw)
2101 C
2102 C This subroutine calculates the interaction energy of nonbonded side chains
2103 C assuming the Gay-Berne-Vorobjev potential of interaction.
2104 C
2105       implicit real*8 (a-h,o-z)
2106       include 'DIMENSIONS'
2107       include 'COMMON.GEO'
2108       include 'COMMON.VAR'
2109       include 'COMMON.LOCAL'
2110       include 'COMMON.CHAIN'
2111       include 'COMMON.DERIV'
2112       include 'COMMON.NAMES'
2113       include 'COMMON.INTERACT'
2114       include 'COMMON.IOUNITS'
2115       include 'COMMON.CALC'
2116       integer xshift,yshift,zshift
2117       common /srutu/ icall
2118       logical lprn
2119       evdw=0.0D0
2120 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
2121       evdw=0.0D0
2122       lprn=.false.
2123 c     if (icall.eq.0) lprn=.true.
2124       ind=0
2125       do i=iatsc_s,iatsc_e
2126         itypi=iabs(itype(i))
2127         if (itypi.eq.ntyp1) cycle
2128         itypi1=iabs(itype(i+1))
2129         xi=c(1,nres+i)
2130         yi=c(2,nres+i)
2131         zi=c(3,nres+i)
2132           xi=mod(xi,boxxsize)
2133           if (xi.lt.0) xi=xi+boxxsize
2134           yi=mod(yi,boxysize)
2135           if (yi.lt.0) yi=yi+boxysize
2136           zi=mod(zi,boxzsize)
2137           if (zi.lt.0) zi=zi+boxzsize
2138 C define scaling factor for lipids
2139
2140 C        if (positi.le.0) positi=positi+boxzsize
2141 C        print *,i
2142 C first for peptide groups
2143 c for each residue check if it is in lipid or lipid water border area
2144        if ((zi.gt.bordlipbot)
2145      &.and.(zi.lt.bordliptop)) then
2146 C the energy transfer exist
2147         if (zi.lt.buflipbot) then
2148 C what fraction I am in
2149          fracinbuf=1.0d0-
2150      &        ((zi-bordlipbot)/lipbufthick)
2151 C lipbufthick is thickenes of lipid buffore
2152          sslipi=sscalelip(fracinbuf)
2153          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
2154         elseif (zi.gt.bufliptop) then
2155          fracinbuf=1.0d0-((bordliptop-zi)/lipbufthick)
2156          sslipi=sscalelip(fracinbuf)
2157          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
2158         else
2159          sslipi=1.0d0
2160          ssgradlipi=0.0
2161         endif
2162        else
2163          sslipi=0.0d0
2164          ssgradlipi=0.0
2165        endif
2166
2167         dxi=dc_norm(1,nres+i)
2168         dyi=dc_norm(2,nres+i)
2169         dzi=dc_norm(3,nres+i)
2170 c        dsci_inv=dsc_inv(itypi)
2171         dsci_inv=vbld_inv(i+nres)
2172 C
2173 C Calculate SC interaction energy.
2174 C
2175         do iint=1,nint_gr(i)
2176           do j=istart(i,iint),iend(i,iint)
2177             ind=ind+1
2178             itypj=iabs(itype(j))
2179             if (itypj.eq.ntyp1) cycle
2180 c            dscj_inv=dsc_inv(itypj)
2181             dscj_inv=vbld_inv(j+nres)
2182             sig0ij=sigma(itypi,itypj)
2183             r0ij=r0(itypi,itypj)
2184             chi1=chi(itypi,itypj)
2185             chi2=chi(itypj,itypi)
2186             chi12=chi1*chi2
2187             chip1=chip(itypi)
2188             chip2=chip(itypj)
2189             chip12=chip1*chip2
2190             alf1=alp(itypi)
2191             alf2=alp(itypj)
2192             alf12=0.5D0*(alf1+alf2)
2193 C For diagnostics only!!!
2194 c           chi1=0.0D0
2195 c           chi2=0.0D0
2196 c           chi12=0.0D0
2197 c           chip1=0.0D0
2198 c           chip2=0.0D0
2199 c           chip12=0.0D0
2200 c           alf1=0.0D0
2201 c           alf2=0.0D0
2202 c           alf12=0.0D0
2203 C            xj=c(1,nres+j)-xi
2204 C            yj=c(2,nres+j)-yi
2205 C            zj=c(3,nres+j)-zi
2206           xj=mod(xj,boxxsize)
2207           if (xj.lt.0) xj=xj+boxxsize
2208           yj=mod(yj,boxysize)
2209           if (yj.lt.0) yj=yj+boxysize
2210           zj=mod(zj,boxzsize)
2211           if (zj.lt.0) zj=zj+boxzsize
2212        if ((zj.gt.bordlipbot)
2213      &.and.(zj.lt.bordliptop)) then
2214 C the energy transfer exist
2215         if (zj.lt.buflipbot) then
2216 C what fraction I am in
2217          fracinbuf=1.0d0-
2218      &        ((zj-bordlipbot)/lipbufthick)
2219 C lipbufthick is thickenes of lipid buffore
2220          sslipj=sscalelip(fracinbuf)
2221          ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
2222         elseif (zj.gt.bufliptop) then
2223          fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
2224          sslipj=sscalelip(fracinbuf)
2225          ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
2226         else
2227          sslipj=1.0d0
2228          ssgradlipj=0.0
2229         endif
2230        else
2231          sslipj=0.0d0
2232          ssgradlipj=0.0
2233        endif
2234       aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
2235      &  +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
2236       bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
2237      &  +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
2238 C      if (aa.ne.aa_aq(itypi,itypj)) write(63,'2e10.5')
2239 C     &(aa-aa_aq(itypi,itypj)),(bb-bb_aq(itypi,itypj))
2240 C      write(iout,*) "tu,", i,j,aa,bb,aa_lip(itypi,itypj),sslipi,sslipj
2241       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
2242       xj_safe=xj
2243       yj_safe=yj
2244       zj_safe=zj
2245       subchap=0
2246       do xshift=-1,1
2247       do yshift=-1,1
2248       do zshift=-1,1
2249           xj=xj_safe+xshift*boxxsize
2250           yj=yj_safe+yshift*boxysize
2251           zj=zj_safe+zshift*boxzsize
2252           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
2253           if(dist_temp.lt.dist_init) then
2254             dist_init=dist_temp
2255             xj_temp=xj
2256             yj_temp=yj
2257             zj_temp=zj
2258             subchap=1
2259           endif
2260        enddo
2261        enddo
2262        enddo
2263        if (subchap.eq.1) then
2264           xj=xj_temp-xi
2265           yj=yj_temp-yi
2266           zj=zj_temp-zi
2267        else
2268           xj=xj_safe-xi
2269           yj=yj_safe-yi
2270           zj=zj_safe-zi
2271        endif
2272             dxj=dc_norm(1,nres+j)
2273             dyj=dc_norm(2,nres+j)
2274             dzj=dc_norm(3,nres+j)
2275             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
2276             rij=dsqrt(rrij)
2277 C Calculate angle-dependent terms of energy and contributions to their
2278 C derivatives.
2279             call sc_angular
2280             sigsq=1.0D0/sigsq
2281             sig=sig0ij*dsqrt(sigsq)
2282             rij_shift=1.0D0/rij-sig+r0ij
2283 C I hate to put IF's in the loops, but here don't have another choice!!!!
2284             if (rij_shift.le.0.0D0) then
2285               evdw=1.0D20
2286               return
2287             endif
2288             sigder=-sig*sigsq
2289 c---------------------------------------------------------------
2290             rij_shift=1.0D0/rij_shift
2291             fac=rij_shift**expon
2292             e1=fac*fac*aa
2293             e2=fac*bb
2294             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
2295             eps2der=evdwij*eps3rt
2296             eps3der=evdwij*eps2rt
2297             fac_augm=rrij**expon
2298             e_augm=augm(itypi,itypj)*fac_augm
2299             evdwij=evdwij*eps2rt*eps3rt
2300             evdw=evdw+evdwij+e_augm
2301             if (lprn) then
2302             sigm=dabs(aa/bb)**(1.0D0/6.0D0)
2303             epsi=bb**2/aa
2304             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
2305      &        restyp(itypi),i,restyp(itypj),j,
2306      &        epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),
2307      &        chi1,chi2,chip1,chip2,
2308      &        eps1,eps2rt**2,eps3rt**2,
2309      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
2310      &        evdwij+e_augm
2311             endif
2312 C Calculate gradient components.
2313             e1=e1*eps1*eps2rt**2*eps3rt**2
2314             fac=-expon*(e1+evdwij)*rij_shift
2315             sigder=fac*sigder
2316             fac=rij*fac-2*expon*rrij*e_augm
2317             fac=fac+evdwij/sss*sssgrad/sigma(itypi,itypj)*rij
2318 C Calculate the radial part of the gradient
2319             gg(1)=xj*fac
2320             gg(2)=yj*fac
2321             gg(3)=zj*fac
2322 C Calculate angular part of the gradient.
2323             call sc_grad
2324           enddo      ! j
2325         enddo        ! iint
2326       enddo          ! i
2327       end
2328 C-----------------------------------------------------------------------------
2329       subroutine sc_angular
2330 C Calculate eps1,eps2,eps3,sigma, and parts of their derivatives in om1,om2,
2331 C om12. Called by ebp, egb, and egbv.
2332       implicit none
2333       include 'COMMON.CALC'
2334       include 'COMMON.IOUNITS'
2335       erij(1)=xj*rij
2336       erij(2)=yj*rij
2337       erij(3)=zj*rij
2338       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
2339       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
2340       om12=dxi*dxj+dyi*dyj+dzi*dzj
2341       chiom12=chi12*om12
2342 C Calculate eps1(om12) and its derivative in om12
2343       faceps1=1.0D0-om12*chiom12
2344       faceps1_inv=1.0D0/faceps1
2345       eps1=dsqrt(faceps1_inv)
2346 C Following variable is eps1*deps1/dom12
2347       eps1_om12=faceps1_inv*chiom12
2348 c diagnostics only
2349 c      faceps1_inv=om12
2350 c      eps1=om12
2351 c      eps1_om12=1.0d0
2352 c      write (iout,*) "om12",om12," eps1",eps1
2353 C Calculate sigma(om1,om2,om12) and the derivatives of sigma**2 in om1,om2,
2354 C and om12.
2355       om1om2=om1*om2
2356       chiom1=chi1*om1
2357       chiom2=chi2*om2
2358       facsig=om1*chiom1+om2*chiom2-2.0D0*om1om2*chiom12
2359       sigsq=1.0D0-facsig*faceps1_inv
2360       sigsq_om1=(chiom1-chiom12*om2)*faceps1_inv
2361       sigsq_om2=(chiom2-chiom12*om1)*faceps1_inv
2362       sigsq_om12=-chi12*(om1om2*faceps1-om12*facsig)*faceps1_inv**2
2363 c diagnostics only
2364 c      sigsq=1.0d0
2365 c      sigsq_om1=0.0d0
2366 c      sigsq_om2=0.0d0
2367 c      sigsq_om12=0.0d0
2368 c      write (iout,*) "chiom1",chiom1," chiom2",chiom2," chiom12",chiom12
2369 c      write (iout,*) "faceps1",faceps1," faceps1_inv",faceps1_inv,
2370 c     &    " eps1",eps1
2371 C Calculate eps2 and its derivatives in om1, om2, and om12.
2372       chipom1=chip1*om1
2373       chipom2=chip2*om2
2374       chipom12=chip12*om12
2375       facp=1.0D0-om12*chipom12
2376       facp_inv=1.0D0/facp
2377       facp1=om1*chipom1+om2*chipom2-2.0D0*om1om2*chipom12
2378 c      write (iout,*) "chipom1",chipom1," chipom2",chipom2,
2379 c     &  " chipom12",chipom12," facp",facp," facp_inv",facp_inv
2380 C Following variable is the square root of eps2
2381       eps2rt=1.0D0-facp1*facp_inv
2382 C Following three variables are the derivatives of the square root of eps
2383 C in om1, om2, and om12.
2384       eps2rt_om1=-4.0D0*(chipom1-chipom12*om2)*facp_inv
2385       eps2rt_om2=-4.0D0*(chipom2-chipom12*om1)*facp_inv
2386       eps2rt_om12=4.0D0*chip12*(om1om2*facp-om12*facp1)*facp_inv**2
2387 C Evaluate the "asymmetric" factor in the VDW constant, eps3
2388       eps3rt=1.0D0-alf1*om1+alf2*om2-alf12*om12
2389 c      write (iout,*) "eps2rt",eps2rt," eps3rt",eps3rt
2390 c      write (iout,*) "eps2rt_om1",eps2rt_om1," eps2rt_om2",eps2rt_om2,
2391 c     &  " eps2rt_om12",eps2rt_om12
2392 C Calculate whole angle-dependent part of epsilon and contributions
2393 C to its derivatives
2394       return
2395       end
2396 C----------------------------------------------------------------------------
2397       subroutine sc_grad
2398       implicit real*8 (a-h,o-z)
2399       include 'DIMENSIONS'
2400       include 'COMMON.CHAIN'
2401       include 'COMMON.DERIV'
2402       include 'COMMON.CALC'
2403       include 'COMMON.IOUNITS'
2404       double precision dcosom1(3),dcosom2(3)
2405 cc      print *,'sss=',sss
2406       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
2407       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
2408       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12
2409      &     -2.0D0*alf12*eps3der+sigder*sigsq_om12
2410 c diagnostics only
2411 c      eom1=0.0d0
2412 c      eom2=0.0d0
2413 c      eom12=evdwij*eps1_om12
2414 c end diagnostics
2415 c      write (iout,*) "eps2der",eps2der," eps3der",eps3der,
2416 c     &  " sigder",sigder
2417 c      write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12
2418 c      write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12
2419       do k=1,3
2420         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
2421         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
2422       enddo
2423       do k=1,3
2424         gg(k)=(gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k))*sss
2425       enddo
2426 c      write (iout,*) "gg",(gg(k),k=1,3)
2427       do k=1,3
2428         gvdwx(k,i)=gvdwx(k,i)-gg(k)+gg_lipi(k)
2429      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
2430      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv*sss
2431         gvdwx(k,j)=gvdwx(k,j)+gg(k)+gg_lipj(k)
2432      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
2433      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv*sss
2434 c        write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
2435 c     &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
2436 c        write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
2437 c     &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
2438       enddo
2439 C
2440 C Calculate the components of the gradient in DC and X
2441 C
2442 cgrad      do k=i,j-1
2443 cgrad        do l=1,3
2444 cgrad          gvdwc(l,k)=gvdwc(l,k)+gg(l)
2445 cgrad        enddo
2446 cgrad      enddo
2447       do l=1,3
2448         gvdwc(l,i)=gvdwc(l,i)-gg(l)+gg_lipi(l)
2449         gvdwc(l,j)=gvdwc(l,j)+gg(l)+gg_lipj(l)
2450       enddo
2451       return
2452       end
2453 C-----------------------------------------------------------------------
2454       subroutine e_softsphere(evdw)
2455 C
2456 C This subroutine calculates the interaction energy of nonbonded side chains
2457 C assuming the LJ potential of interaction.
2458 C
2459       implicit real*8 (a-h,o-z)
2460       include 'DIMENSIONS'
2461       parameter (accur=1.0d-10)
2462       include 'COMMON.GEO'
2463       include 'COMMON.VAR'
2464       include 'COMMON.LOCAL'
2465       include 'COMMON.CHAIN'
2466       include 'COMMON.DERIV'
2467       include 'COMMON.INTERACT'
2468       include 'COMMON.TORSION'
2469       include 'COMMON.SBRIDGE'
2470       include 'COMMON.NAMES'
2471       include 'COMMON.IOUNITS'
2472       include 'COMMON.CONTACTS'
2473       dimension gg(3)
2474 cd    print *,'Entering Esoft_sphere nnt=',nnt,' nct=',nct
2475       evdw=0.0D0
2476       do i=iatsc_s,iatsc_e
2477         itypi=iabs(itype(i))
2478         if (itypi.eq.ntyp1) cycle
2479         itypi1=iabs(itype(i+1))
2480         xi=c(1,nres+i)
2481         yi=c(2,nres+i)
2482         zi=c(3,nres+i)
2483 C
2484 C Calculate SC interaction energy.
2485 C
2486         do iint=1,nint_gr(i)
2487 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
2488 cd   &                  'iend=',iend(i,iint)
2489           do j=istart(i,iint),iend(i,iint)
2490             itypj=iabs(itype(j))
2491             if (itypj.eq.ntyp1) cycle
2492             xj=c(1,nres+j)-xi
2493             yj=c(2,nres+j)-yi
2494             zj=c(3,nres+j)-zi
2495             rij=xj*xj+yj*yj+zj*zj
2496 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
2497             r0ij=r0(itypi,itypj)
2498             r0ijsq=r0ij*r0ij
2499 c            print *,i,j,r0ij,dsqrt(rij)
2500             if (rij.lt.r0ijsq) then
2501               evdwij=0.25d0*(rij-r0ijsq)**2
2502               fac=rij-r0ijsq
2503             else
2504               evdwij=0.0d0
2505               fac=0.0d0
2506             endif
2507             evdw=evdw+evdwij
2508 C
2509 C Calculate the components of the gradient in DC and X
2510 C
2511             gg(1)=xj*fac
2512             gg(2)=yj*fac
2513             gg(3)=zj*fac
2514             do k=1,3
2515               gvdwx(k,i)=gvdwx(k,i)-gg(k)
2516               gvdwx(k,j)=gvdwx(k,j)+gg(k)
2517               gvdwc(k,i)=gvdwc(k,i)-gg(k)
2518               gvdwc(k,j)=gvdwc(k,j)+gg(k)
2519             enddo
2520 cgrad            do k=i,j-1
2521 cgrad              do l=1,3
2522 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
2523 cgrad              enddo
2524 cgrad            enddo
2525           enddo ! j
2526         enddo ! iint
2527       enddo ! i
2528       return
2529       end
2530 C--------------------------------------------------------------------------
2531       subroutine eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,
2532      &              eello_turn4)
2533 C
2534 C Soft-sphere potential of p-p interaction
2535 C
2536       implicit real*8 (a-h,o-z)
2537       include 'DIMENSIONS'
2538       include 'COMMON.CONTROL'
2539       include 'COMMON.IOUNITS'
2540       include 'COMMON.GEO'
2541       include 'COMMON.VAR'
2542       include 'COMMON.LOCAL'
2543       include 'COMMON.CHAIN'
2544       include 'COMMON.DERIV'
2545       include 'COMMON.INTERACT'
2546       include 'COMMON.CONTACTS'
2547       include 'COMMON.TORSION'
2548       include 'COMMON.VECTORS'
2549       include 'COMMON.FFIELD'
2550       dimension ggg(3)
2551       integer xshift,yshift,zshift
2552 C      write(iout,*) 'In EELEC_soft_sphere'
2553       ees=0.0D0
2554       evdw1=0.0D0
2555       eel_loc=0.0d0
2556       eello_turn3=0.0d0
2557       eello_turn4=0.0d0
2558       ind=0
2559       do i=iatel_s,iatel_e
2560         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
2561         dxi=dc(1,i)
2562         dyi=dc(2,i)
2563         dzi=dc(3,i)
2564         xmedi=c(1,i)+0.5d0*dxi
2565         ymedi=c(2,i)+0.5d0*dyi
2566         zmedi=c(3,i)+0.5d0*dzi
2567           xmedi=mod(xmedi,boxxsize)
2568           if (xmedi.lt.0) xmedi=xmedi+boxxsize
2569           ymedi=mod(ymedi,boxysize)
2570           if (ymedi.lt.0) ymedi=ymedi+boxysize
2571           zmedi=mod(zmedi,boxzsize)
2572           if (zmedi.lt.0) zmedi=zmedi+boxzsize
2573         num_conti=0
2574 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
2575         do j=ielstart(i),ielend(i)
2576           if (itype(j).eq.ntyp1 .or. itype(j+1).eq.ntyp1) cycle
2577           ind=ind+1
2578           iteli=itel(i)
2579           itelj=itel(j)
2580           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
2581           r0ij=rpp(iteli,itelj)
2582           r0ijsq=r0ij*r0ij
2583           dxj=dc(1,j)
2584           dyj=dc(2,j)
2585           dzj=dc(3,j)
2586           xj=c(1,j)+0.5D0*dxj
2587           yj=c(2,j)+0.5D0*dyj
2588           zj=c(3,j)+0.5D0*dzj
2589           xj=mod(xj,boxxsize)
2590           if (xj.lt.0) xj=xj+boxxsize
2591           yj=mod(yj,boxysize)
2592           if (yj.lt.0) yj=yj+boxysize
2593           zj=mod(zj,boxzsize)
2594           if (zj.lt.0) zj=zj+boxzsize
2595       dist_init=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
2596       xj_safe=xj
2597       yj_safe=yj
2598       zj_safe=zj
2599       isubchap=0
2600       do xshift=-1,1
2601       do yshift=-1,1
2602       do zshift=-1,1
2603           xj=xj_safe+xshift*boxxsize
2604           yj=yj_safe+yshift*boxysize
2605           zj=zj_safe+zshift*boxzsize
2606           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
2607           if(dist_temp.lt.dist_init) then
2608             dist_init=dist_temp
2609             xj_temp=xj
2610             yj_temp=yj
2611             zj_temp=zj
2612             isubchap=1
2613           endif
2614        enddo
2615        enddo
2616        enddo
2617        if (isubchap.eq.1) then
2618           xj=xj_temp-xmedi
2619           yj=yj_temp-ymedi
2620           zj=zj_temp-zmedi
2621        else
2622           xj=xj_safe-xmedi
2623           yj=yj_safe-ymedi
2624           zj=zj_safe-zmedi
2625        endif
2626           rij=xj*xj+yj*yj+zj*zj
2627             sss=sscale(sqrt(rij))
2628             sssgrad=sscagrad(sqrt(rij))
2629           if (rij.lt.r0ijsq) then
2630             evdw1ij=0.25d0*(rij-r0ijsq)**2
2631             fac=rij-r0ijsq
2632           else
2633             evdw1ij=0.0d0
2634             fac=0.0d0
2635           endif
2636           evdw1=evdw1+evdw1ij*sss
2637 C
2638 C Calculate contributions to the Cartesian gradient.
2639 C
2640           ggg(1)=fac*xj*sssgrad
2641           ggg(2)=fac*yj*sssgrad
2642           ggg(3)=fac*zj*sssgrad
2643           do k=1,3
2644             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
2645             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
2646           enddo
2647 *
2648 * Loop over residues i+1 thru j-1.
2649 *
2650 cgrad          do k=i+1,j-1
2651 cgrad            do l=1,3
2652 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
2653 cgrad            enddo
2654 cgrad          enddo
2655         enddo ! j
2656       enddo   ! i
2657 cgrad      do i=nnt,nct-1
2658 cgrad        do k=1,3
2659 cgrad          gelc(k,i)=gelc(k,i)+0.5d0*gelc(k,i)
2660 cgrad        enddo
2661 cgrad        do j=i+1,nct-1
2662 cgrad          do k=1,3
2663 cgrad            gelc(k,i)=gelc(k,i)+gelc(k,j)
2664 cgrad          enddo
2665 cgrad        enddo
2666 cgrad      enddo
2667       return
2668       end
2669 c------------------------------------------------------------------------------
2670       subroutine vec_and_deriv
2671       implicit real*8 (a-h,o-z)
2672       include 'DIMENSIONS'
2673 #ifdef MPI
2674       include 'mpif.h'
2675 #endif
2676       include 'COMMON.IOUNITS'
2677       include 'COMMON.GEO'
2678       include 'COMMON.VAR'
2679       include 'COMMON.LOCAL'
2680       include 'COMMON.CHAIN'
2681       include 'COMMON.VECTORS'
2682       include 'COMMON.SETUP'
2683       include 'COMMON.TIME1'
2684       dimension uyder(3,3,2),uzder(3,3,2),vbld_inv_temp(2)
2685 C Compute the local reference systems. For reference system (i), the
2686 C X-axis points from CA(i) to CA(i+1), the Y axis is in the
2687 C CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
2688 #ifdef PARVEC
2689       do i=ivec_start,ivec_end
2690 #else
2691       do i=1,nres-1
2692 #endif
2693           if (i.eq.nres-1) then
2694 C Case of the last full residue
2695 C Compute the Z-axis
2696             call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
2697             costh=dcos(pi-theta(nres))
2698             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2699             do k=1,3
2700               uz(k,i)=fac*uz(k,i)
2701             enddo
2702 C Compute the derivatives of uz
2703             uzder(1,1,1)= 0.0d0
2704             uzder(2,1,1)=-dc_norm(3,i-1)
2705             uzder(3,1,1)= dc_norm(2,i-1)
2706             uzder(1,2,1)= dc_norm(3,i-1)
2707             uzder(2,2,1)= 0.0d0
2708             uzder(3,2,1)=-dc_norm(1,i-1)
2709             uzder(1,3,1)=-dc_norm(2,i-1)
2710             uzder(2,3,1)= dc_norm(1,i-1)
2711             uzder(3,3,1)= 0.0d0
2712             uzder(1,1,2)= 0.0d0
2713             uzder(2,1,2)= dc_norm(3,i)
2714             uzder(3,1,2)=-dc_norm(2,i)
2715             uzder(1,2,2)=-dc_norm(3,i)
2716             uzder(2,2,2)= 0.0d0
2717             uzder(3,2,2)= dc_norm(1,i)
2718             uzder(1,3,2)= dc_norm(2,i)
2719             uzder(2,3,2)=-dc_norm(1,i)
2720             uzder(3,3,2)= 0.0d0
2721 C Compute the Y-axis
2722             facy=fac
2723             do k=1,3
2724               uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
2725             enddo
2726 C Compute the derivatives of uy
2727             do j=1,3
2728               do k=1,3
2729                 uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i)
2730      &                        -dc_norm(k,i)*dc_norm(j,i-1)
2731                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2732               enddo
2733               uyder(j,j,1)=uyder(j,j,1)-costh
2734               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2735             enddo
2736             do j=1,2
2737               do k=1,3
2738                 do l=1,3
2739                   uygrad(l,k,j,i)=uyder(l,k,j)
2740                   uzgrad(l,k,j,i)=uzder(l,k,j)
2741                 enddo
2742               enddo
2743             enddo
2744             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2745             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2746             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2747             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2748           else
2749 C Other residues
2750 C Compute the Z-axis
2751             call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
2752             costh=dcos(pi-theta(i+2))
2753             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2754             do k=1,3
2755               uz(k,i)=fac*uz(k,i)
2756             enddo
2757 C Compute the derivatives of uz
2758             uzder(1,1,1)= 0.0d0
2759             uzder(2,1,1)=-dc_norm(3,i+1)
2760             uzder(3,1,1)= dc_norm(2,i+1)
2761             uzder(1,2,1)= dc_norm(3,i+1)
2762             uzder(2,2,1)= 0.0d0
2763             uzder(3,2,1)=-dc_norm(1,i+1)
2764             uzder(1,3,1)=-dc_norm(2,i+1)
2765             uzder(2,3,1)= dc_norm(1,i+1)
2766             uzder(3,3,1)= 0.0d0
2767             uzder(1,1,2)= 0.0d0
2768             uzder(2,1,2)= dc_norm(3,i)
2769             uzder(3,1,2)=-dc_norm(2,i)
2770             uzder(1,2,2)=-dc_norm(3,i)
2771             uzder(2,2,2)= 0.0d0
2772             uzder(3,2,2)= dc_norm(1,i)
2773             uzder(1,3,2)= dc_norm(2,i)
2774             uzder(2,3,2)=-dc_norm(1,i)
2775             uzder(3,3,2)= 0.0d0
2776 C Compute the Y-axis
2777             facy=fac
2778             do k=1,3
2779               uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
2780             enddo
2781 C Compute the derivatives of uy
2782             do j=1,3
2783               do k=1,3
2784                 uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i)
2785      &                        -dc_norm(k,i)*dc_norm(j,i+1)
2786                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2787               enddo
2788               uyder(j,j,1)=uyder(j,j,1)-costh
2789               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2790             enddo
2791             do j=1,2
2792               do k=1,3
2793                 do l=1,3
2794                   uygrad(l,k,j,i)=uyder(l,k,j)
2795                   uzgrad(l,k,j,i)=uzder(l,k,j)
2796                 enddo
2797               enddo
2798             enddo
2799             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2800             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2801             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2802             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2803           endif
2804       enddo
2805       do i=1,nres-1
2806         vbld_inv_temp(1)=vbld_inv(i+1)
2807         if (i.lt.nres-1) then
2808           vbld_inv_temp(2)=vbld_inv(i+2)
2809           else
2810           vbld_inv_temp(2)=vbld_inv(i)
2811           endif
2812         do j=1,2
2813           do k=1,3
2814             do l=1,3
2815               uygrad(l,k,j,i)=vbld_inv_temp(j)*uygrad(l,k,j,i)
2816               uzgrad(l,k,j,i)=vbld_inv_temp(j)*uzgrad(l,k,j,i)
2817             enddo
2818           enddo
2819         enddo
2820       enddo
2821 #if defined(PARVEC) && defined(MPI)
2822       if (nfgtasks1.gt.1) then
2823         time00=MPI_Wtime()
2824 c        print *,"Processor",fg_rank1,kolor1," ivec_start",ivec_start,
2825 c     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks1-1),
2826 c     &   " ivec_count",(ivec_count(i),i=0,nfgtasks1-1)
2827         call MPI_Allgatherv(uy(1,ivec_start),ivec_count(fg_rank1),
2828      &   MPI_UYZ,uy(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
2829      &   FG_COMM1,IERR)
2830         call MPI_Allgatherv(uz(1,ivec_start),ivec_count(fg_rank1),
2831      &   MPI_UYZ,uz(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
2832      &   FG_COMM1,IERR)
2833         call MPI_Allgatherv(uygrad(1,1,1,ivec_start),
2834      &   ivec_count(fg_rank1),MPI_UYZGRAD,uygrad(1,1,1,1),ivec_count(0),
2835      &   ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2836         call MPI_Allgatherv(uzgrad(1,1,1,ivec_start),
2837      &   ivec_count(fg_rank1),MPI_UYZGRAD,uzgrad(1,1,1,1),ivec_count(0),
2838      &   ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2839         time_gather=time_gather+MPI_Wtime()-time00
2840       endif
2841 #endif
2842 #ifdef DEBUG
2843       if (fg_rank.eq.0) then
2844         write (iout,*) "Arrays UY and UZ"
2845         do i=1,nres-1
2846           write (iout,'(i5,3f10.5,5x,3f10.5)') i,(uy(k,i),k=1,3),
2847      &     (uz(k,i),k=1,3)
2848         enddo
2849       endif
2850 #endif
2851       return
2852       end
2853 C-----------------------------------------------------------------------------
2854       subroutine check_vecgrad
2855       implicit real*8 (a-h,o-z)
2856       include 'DIMENSIONS'
2857       include 'COMMON.IOUNITS'
2858       include 'COMMON.GEO'
2859       include 'COMMON.VAR'
2860       include 'COMMON.LOCAL'
2861       include 'COMMON.CHAIN'
2862       include 'COMMON.VECTORS'
2863       dimension uygradt(3,3,2,maxres),uzgradt(3,3,2,maxres)
2864       dimension uyt(3,maxres),uzt(3,maxres)
2865       dimension uygradn(3,3,2),uzgradn(3,3,2),erij(3)
2866       double precision delta /1.0d-7/
2867       call vec_and_deriv
2868 cd      do i=1,nres
2869 crc          write(iout,'(2i5,2(3f10.5,5x))') i,1,dc_norm(:,i)
2870 crc          write(iout,'(2i5,2(3f10.5,5x))') i,2,uy(:,i)
2871 crc          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,uz(:,i)
2872 cd          write(iout,'(2i5,2(3f10.5,5x))') i,1,
2873 cd     &     (dc_norm(if90,i),if90=1,3)
2874 cd          write(iout,'(2i5,2(3f10.5,5x))') i,2,(uy(if90,i),if90=1,3)
2875 cd          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,(uz(if90,i),if90=1,3)
2876 cd          write(iout,'(a)')
2877 cd      enddo
2878       do i=1,nres
2879         do j=1,2
2880           do k=1,3
2881             do l=1,3
2882               uygradt(l,k,j,i)=uygrad(l,k,j,i)
2883               uzgradt(l,k,j,i)=uzgrad(l,k,j,i)
2884             enddo
2885           enddo
2886         enddo
2887       enddo
2888       call vec_and_deriv
2889       do i=1,nres
2890         do j=1,3
2891           uyt(j,i)=uy(j,i)
2892           uzt(j,i)=uz(j,i)
2893         enddo
2894       enddo
2895       do i=1,nres
2896 cd        write (iout,*) 'i=',i
2897         do k=1,3
2898           erij(k)=dc_norm(k,i)
2899         enddo
2900         do j=1,3
2901           do k=1,3
2902             dc_norm(k,i)=erij(k)
2903           enddo
2904           dc_norm(j,i)=dc_norm(j,i)+delta
2905 c          fac=dsqrt(scalar(dc_norm(1,i),dc_norm(1,i)))
2906 c          do k=1,3
2907 c            dc_norm(k,i)=dc_norm(k,i)/fac
2908 c          enddo
2909 c          write (iout,*) (dc_norm(k,i),k=1,3)
2910 c          write (iout,*) (erij(k),k=1,3)
2911           call vec_and_deriv
2912           do k=1,3
2913             uygradn(k,j,1)=(uy(k,i)-uyt(k,i))/delta
2914             uygradn(k,j,2)=(uy(k,i-1)-uyt(k,i-1))/delta
2915             uzgradn(k,j,1)=(uz(k,i)-uzt(k,i))/delta
2916             uzgradn(k,j,2)=(uz(k,i-1)-uzt(k,i-1))/delta
2917           enddo
2918 c          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2919 c     &      j,(uzgradt(k,j,1,i),k=1,3),(uzgradn(k,j,1),k=1,3),
2920 c     &      (uzgradt(k,j,2,i-1),k=1,3),(uzgradn(k,j,2),k=1,3)
2921         enddo
2922         do k=1,3
2923           dc_norm(k,i)=erij(k)
2924         enddo
2925 cd        do k=1,3
2926 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2927 cd     &      k,(uygradt(k,l,1,i),l=1,3),(uygradn(k,l,1),l=1,3),
2928 cd     &      (uygradt(k,l,2,i-1),l=1,3),(uygradn(k,l,2),l=1,3)
2929 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2930 cd     &      k,(uzgradt(k,l,1,i),l=1,3),(uzgradn(k,l,1),l=1,3),
2931 cd     &      (uzgradt(k,l,2,i-1),l=1,3),(uzgradn(k,l,2),l=1,3)
2932 cd          write (iout,'(a)')
2933 cd        enddo
2934       enddo
2935       return
2936       end
2937 C--------------------------------------------------------------------------
2938       subroutine set_matrices
2939       implicit real*8 (a-h,o-z)
2940       include 'DIMENSIONS'
2941 #ifdef MPI
2942       include "mpif.h"
2943       include "COMMON.SETUP"
2944       integer IERR
2945       integer status(MPI_STATUS_SIZE)
2946 #endif
2947       include 'COMMON.IOUNITS'
2948       include 'COMMON.GEO'
2949       include 'COMMON.VAR'
2950       include 'COMMON.LOCAL'
2951       include 'COMMON.CHAIN'
2952       include 'COMMON.DERIV'
2953       include 'COMMON.INTERACT'
2954       include 'COMMON.CONTACTS'
2955       include 'COMMON.TORSION'
2956       include 'COMMON.VECTORS'
2957       include 'COMMON.FFIELD'
2958       double precision auxvec(2),auxmat(2,2)
2959 C
2960 C Compute the virtual-bond-torsional-angle dependent quantities needed
2961 C to calculate the el-loc multibody terms of various order.
2962 C
2963 c      write(iout,*) 'nphi=',nphi,nres
2964 c      write(iout,*) "itype2loc",itype2loc
2965 #ifdef PARMAT
2966       do i=ivec_start+2,ivec_end+2
2967 #else
2968       do i=3,nres+1
2969 #endif
2970         if (i.gt. nnt+2 .and. i.lt.nct+2) then
2971           iti = itype2loc(itype(i-2))
2972         else
2973           iti=nloctyp
2974         endif
2975 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2976         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2977           iti1 = itype2loc(itype(i-1))
2978         else
2979           iti1=nloctyp
2980         endif
2981 c        write(iout,*),i
2982 #ifdef NEWCORR
2983         cost1=dcos(theta(i-1))
2984         sint1=dsin(theta(i-1))
2985         sint1sq=sint1*sint1
2986         sint1cub=sint1sq*sint1
2987         sint1cost1=2*sint1*cost1
2988 c        write (iout,*) "bnew1",i,iti
2989 c        write (iout,*) (bnew1(k,1,iti),k=1,3)
2990 c        write (iout,*) (bnew1(k,2,iti),k=1,3)
2991 c        write (iout,*) "bnew2",i,iti
2992 c        write (iout,*) (bnew2(k,1,iti),k=1,3)
2993 c        write (iout,*) (bnew2(k,2,iti),k=1,3)
2994         do k=1,2
2995           b1k=bnew1(1,k,iti)+(bnew1(2,k,iti)+bnew1(3,k,iti)*cost1)*cost1
2996           b1(k,i-2)=sint1*b1k
2997           gtb1(k,i-2)=cost1*b1k-sint1sq*
2998      &              (bnew1(2,k,iti)+2*bnew1(3,k,iti)*cost1)
2999           b2k=bnew2(1,k,iti)+(bnew2(2,k,iti)+bnew2(3,k,iti)*cost1)*cost1
3000           b2(k,i-2)=sint1*b2k
3001           gtb2(k,i-2)=cost1*b2k-sint1sq*
3002      &              (bnew2(2,k,iti)+2*bnew2(3,k,iti)*cost1)
3003         enddo
3004         do k=1,2
3005           aux=ccnew(1,k,iti)+(ccnew(2,k,iti)+ccnew(3,k,iti)*cost1)*cost1
3006           cc(1,k,i-2)=sint1sq*aux
3007           gtcc(1,k,i-2)=sint1cost1*aux-sint1cub*
3008      &              (ccnew(2,k,iti)+2*ccnew(3,k,iti)*cost1)
3009           aux=ddnew(1,k,iti)+(ddnew(2,k,iti)+ddnew(3,k,iti)*cost1)*cost1
3010           dd(1,k,i-2)=sint1sq*aux
3011           gtdd(1,k,i-2)=sint1cost1*aux-sint1cub*
3012      &              (ddnew(2,k,iti)+2*ddnew(3,k,iti)*cost1)
3013         enddo
3014         cc(2,1,i-2)=cc(1,2,i-2)
3015         cc(2,2,i-2)=-cc(1,1,i-2)
3016         gtcc(2,1,i-2)=gtcc(1,2,i-2)
3017         gtcc(2,2,i-2)=-gtcc(1,1,i-2)
3018         dd(2,1,i-2)=dd(1,2,i-2)
3019         dd(2,2,i-2)=-dd(1,1,i-2)
3020         gtdd(2,1,i-2)=gtdd(1,2,i-2)
3021         gtdd(2,2,i-2)=-gtdd(1,1,i-2)
3022         do k=1,2
3023           do l=1,2
3024             aux=eenew(1,l,k,iti)+eenew(2,l,k,iti)*cost1
3025             EE(l,k,i-2)=sint1sq*aux
3026             gtEE(l,k,i-2)=sint1cost1*aux-sint1cub*eenew(2,l,k,iti)
3027           enddo
3028         enddo
3029         EE(1,1,i-2)=EE(1,1,i-2)+e0new(1,iti)*cost1
3030         EE(1,2,i-2)=EE(1,2,i-2)+e0new(2,iti)+e0new(3,iti)*cost1
3031         EE(2,1,i-2)=EE(2,1,i-2)+e0new(2,iti)*cost1+e0new(3,iti)
3032         EE(2,2,i-2)=EE(2,2,i-2)-e0new(1,iti)
3033         gtEE(1,1,i-2)=gtEE(1,1,i-2)-e0new(1,iti)*sint1
3034         gtEE(1,2,i-2)=gtEE(1,2,i-2)-e0new(3,iti)*sint1
3035         gtEE(2,1,i-2)=gtEE(2,1,i-2)-e0new(2,iti)*sint1
3036 c        b1tilde(1,i-2)=b1(1,i-2)
3037 c        b1tilde(2,i-2)=-b1(2,i-2)
3038 c        b2tilde(1,i-2)=b2(1,i-2)
3039 c        b2tilde(2,i-2)=-b2(2,i-2)
3040 #ifdef DEBUG
3041         write (iout,*) 'i=',i-2,gtb1(2,i-2),gtb1(1,i-2)
3042         write(iout,*)  'b1=',(b1(k,i-2),k=1,2)
3043         write(iout,*)  'b2=',(b2(k,i-2),k=1,2)
3044         write (iout,*) 'theta=', theta(i-1)
3045 #endif
3046 #else
3047         if (i.gt. nnt+2 .and. i.lt.nct+2) then
3048           iti = itype2loc(itype(i-2))
3049         else
3050           iti=nloctyp
3051         endif
3052 c        write (iout,*) "i",i-1," itype",itype(i-2)," iti",iti
3053 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
3054         if (i.gt. nnt+1 .and. i.lt.nct+1) then
3055           iti1 = itype2loc(itype(i-1))
3056         else
3057           iti1=nloctyp
3058         endif
3059         b1(1,i-2)=b(3,iti)
3060         b1(2,i-2)=b(5,iti)
3061         b2(1,i-2)=b(2,iti)
3062         b2(2,i-2)=b(4,iti)
3063         do k=1,2
3064           do l=1,2
3065            CC(k,l,i-2)=ccold(k,l,iti)
3066            DD(k,l,i-2)=ddold(k,l,iti)
3067            EE(k,l,i-2)=eeold(k,l,iti)
3068            gtEE(k,l,i-2)=0.0d0
3069           enddo
3070         enddo
3071 #endif
3072         b1tilde(1,i-2)= b1(1,i-2)
3073         b1tilde(2,i-2)=-b1(2,i-2)
3074         b2tilde(1,i-2)= b2(1,i-2)
3075         b2tilde(2,i-2)=-b2(2,i-2)
3076 c
3077         Ctilde(1,1,i-2)= CC(1,1,i-2)
3078         Ctilde(1,2,i-2)= CC(1,2,i-2)
3079         Ctilde(2,1,i-2)=-CC(2,1,i-2)
3080         Ctilde(2,2,i-2)=-CC(2,2,i-2)
3081 c
3082         Dtilde(1,1,i-2)= DD(1,1,i-2)
3083         Dtilde(1,2,i-2)= DD(1,2,i-2)
3084         Dtilde(2,1,i-2)=-DD(2,1,i-2)
3085         Dtilde(2,2,i-2)=-DD(2,2,i-2)
3086 #ifdef DEBUG
3087         write(iout,*) "i",i," iti",iti
3088         write(iout,*)  'b1=',(b1(k,i-2),k=1,2)
3089         write(iout,*)  'b2=',(b2(k,i-2),k=1,2)
3090 #endif
3091       enddo
3092 #ifdef PARMAT
3093       do i=ivec_start+2,ivec_end+2
3094 #else
3095       do i=3,nres+1
3096 #endif
3097         if (i .lt. nres+1) then
3098           sin1=dsin(phi(i))
3099           cos1=dcos(phi(i))
3100           sintab(i-2)=sin1
3101           costab(i-2)=cos1
3102           obrot(1,i-2)=cos1
3103           obrot(2,i-2)=sin1
3104           sin2=dsin(2*phi(i))
3105           cos2=dcos(2*phi(i))
3106           sintab2(i-2)=sin2
3107           costab2(i-2)=cos2
3108           obrot2(1,i-2)=cos2
3109           obrot2(2,i-2)=sin2
3110           Ug(1,1,i-2)=-cos1
3111           Ug(1,2,i-2)=-sin1
3112           Ug(2,1,i-2)=-sin1
3113           Ug(2,2,i-2)= cos1
3114           Ug2(1,1,i-2)=-cos2
3115           Ug2(1,2,i-2)=-sin2
3116           Ug2(2,1,i-2)=-sin2
3117           Ug2(2,2,i-2)= cos2
3118         else
3119           costab(i-2)=1.0d0
3120           sintab(i-2)=0.0d0
3121           obrot(1,i-2)=1.0d0
3122           obrot(2,i-2)=0.0d0
3123           obrot2(1,i-2)=0.0d0
3124           obrot2(2,i-2)=0.0d0
3125           Ug(1,1,i-2)=1.0d0
3126           Ug(1,2,i-2)=0.0d0
3127           Ug(2,1,i-2)=0.0d0
3128           Ug(2,2,i-2)=1.0d0
3129           Ug2(1,1,i-2)=0.0d0
3130           Ug2(1,2,i-2)=0.0d0
3131           Ug2(2,1,i-2)=0.0d0
3132           Ug2(2,2,i-2)=0.0d0
3133         endif
3134         if (i .gt. 3 .and. i .lt. nres+1) then
3135           obrot_der(1,i-2)=-sin1
3136           obrot_der(2,i-2)= cos1
3137           Ugder(1,1,i-2)= sin1
3138           Ugder(1,2,i-2)=-cos1
3139           Ugder(2,1,i-2)=-cos1
3140           Ugder(2,2,i-2)=-sin1
3141           dwacos2=cos2+cos2
3142           dwasin2=sin2+sin2
3143           obrot2_der(1,i-2)=-dwasin2
3144           obrot2_der(2,i-2)= dwacos2
3145           Ug2der(1,1,i-2)= dwasin2
3146           Ug2der(1,2,i-2)=-dwacos2
3147           Ug2der(2,1,i-2)=-dwacos2
3148           Ug2der(2,2,i-2)=-dwasin2
3149         else
3150           obrot_der(1,i-2)=0.0d0
3151           obrot_der(2,i-2)=0.0d0
3152           Ugder(1,1,i-2)=0.0d0
3153           Ugder(1,2,i-2)=0.0d0
3154           Ugder(2,1,i-2)=0.0d0
3155           Ugder(2,2,i-2)=0.0d0
3156           obrot2_der(1,i-2)=0.0d0
3157           obrot2_der(2,i-2)=0.0d0
3158           Ug2der(1,1,i-2)=0.0d0
3159           Ug2der(1,2,i-2)=0.0d0
3160           Ug2der(2,1,i-2)=0.0d0
3161           Ug2der(2,2,i-2)=0.0d0
3162         endif
3163 c        if (i.gt. iatel_s+2 .and. i.lt.iatel_e+5) then
3164         if (i.gt. nnt+2 .and. i.lt.nct+2) then
3165           iti = itype2loc(itype(i-2))
3166         else
3167           iti=nloctyp
3168         endif
3169 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
3170         if (i.gt. nnt+1 .and. i.lt.nct+1) then
3171           iti1 = itype2loc(itype(i-1))
3172         else
3173           iti1=nloctyp
3174         endif
3175 cd        write (iout,*) '*******i',i,' iti1',iti
3176 cd        write (iout,*) 'b1',b1(:,iti)
3177 cd        write (iout,*) 'b2',b2(:,iti)
3178 cd        write (iout,*) 'Ug',Ug(:,:,i-2)
3179 c        if (i .gt. iatel_s+2) then
3180         if (i .gt. nnt+2) then
3181           call matvec2(Ug(1,1,i-2),b2(1,i-2),Ub2(1,i-2))
3182 #ifdef NEWCORR
3183           call matvec2(Ug(1,1,i-2),gtb2(1,i-2),gUb2(1,i-2))
3184 c          write (iout,*) Ug(1,1,i-2),gtb2(1,i-2),gUb2(1,i-2),"chuj"
3185 #endif
3186 c          write(iout,*) "co jest kurwa", iti, EE(1,1,i),EE(2,1,i),
3187 c     &    EE(1,2,iti),EE(2,2,i)
3188           call matmat2(EE(1,1,i-2),Ug(1,1,i-2),EUg(1,1,i-2))
3189           call matmat2(gtEE(1,1,i-2),Ug(1,1,i-2),gtEUg(1,1,i-2))
3190 c          write(iout,*) "Macierz EUG",
3191 c     &    eug(1,1,i-2),eug(1,2,i-2),eug(2,1,i-2),
3192 c     &    eug(2,2,i-2)
3193           if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
3194      &    then
3195           call matmat2(CC(1,1,i-2),Ug(1,1,i-2),CUg(1,1,i-2))
3196           call matmat2(DD(1,1,i-2),Ug(1,1,i-2),DUg(1,1,i-2))
3197           call matmat2(Dtilde(1,1,i-2),Ug2(1,1,i-2),DtUg2(1,1,i-2))
3198           call matvec2(Ctilde(1,1,i-1),obrot(1,i-2),Ctobr(1,i-2))
3199           call matvec2(Dtilde(1,1,i-2),obrot2(1,i-2),Dtobr2(1,i-2))
3200           endif
3201         else
3202           do k=1,2
3203             Ub2(k,i-2)=0.0d0
3204             Ctobr(k,i-2)=0.0d0
3205             Dtobr2(k,i-2)=0.0d0
3206             do l=1,2
3207               EUg(l,k,i-2)=0.0d0
3208               CUg(l,k,i-2)=0.0d0
3209               DUg(l,k,i-2)=0.0d0
3210               DtUg2(l,k,i-2)=0.0d0
3211             enddo
3212           enddo
3213         endif
3214         call matvec2(Ugder(1,1,i-2),b2(1,i-2),Ub2der(1,i-2))
3215         call matmat2(EE(1,1,i-2),Ugder(1,1,i-2),EUgder(1,1,i-2))
3216         do k=1,2
3217           muder(k,i-2)=Ub2der(k,i-2)
3218         enddo
3219 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
3220         if (i.gt. nnt+1 .and. i.lt.nct+1) then
3221           if (itype(i-1).le.ntyp) then
3222             iti1 = itype2loc(itype(i-1))
3223           else
3224             iti1=nloctyp
3225           endif
3226         else
3227           iti1=nloctyp
3228         endif
3229         do k=1,2
3230           mu(k,i-2)=Ub2(k,i-2)+b1(k,i-1)
3231 c          mu(k,i-2)=b1(k,i-1)
3232 c          mu(k,i-2)=Ub2(k,i-2)
3233         enddo
3234 #ifdef MUOUT
3235         write (iout,'(2hmu,i3,3f8.1,12f10.5)') i-2,rad2deg*theta(i-1),
3236      &     rad2deg*theta(i),rad2deg*phi(i),mu(1,i-2),mu(2,i-2),
3237      &       -b2(1,i-2),b2(2,i-2),b1(1,i-2),b1(2,i-2),
3238      &       dsqrt(b2(1,i-1)**2+b2(2,i-1)**2)
3239      &      +dsqrt(b1(1,i-1)**2+b1(2,i-1)**2),
3240      &      ((ee(l,k,i-2),l=1,2),k=1,2)
3241 #endif
3242 cd        write (iout,*) 'mu1',mu1(:,i-2)
3243 cd        write (iout,*) 'mu2',mu2(:,i-2)
3244 cd        write (iout,*) 'mu',i-2,mu(:,i-2)
3245         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
3246      &  then
3247         call matmat2(CC(1,1,i-1),Ugder(1,1,i-2),CUgder(1,1,i-2))
3248         call matmat2(DD(1,1,i-2),Ugder(1,1,i-2),DUgder(1,1,i-2))
3249         call matmat2(Dtilde(1,1,i-2),Ug2der(1,1,i-2),DtUg2der(1,1,i-2))
3250         call matvec2(Ctilde(1,1,i-1),obrot_der(1,i-2),Ctobrder(1,i-2))
3251         call matvec2(Dtilde(1,1,i-2),obrot2_der(1,i-2),Dtobr2der(1,i-2))
3252 C Vectors and matrices dependent on a single virtual-bond dihedral.
3253         call matvec2(DD(1,1,i-2),b1tilde(1,i-1),auxvec(1))
3254         call matvec2(Ug2(1,1,i-2),auxvec(1),Ug2Db1t(1,i-2))
3255         call matvec2(Ug2der(1,1,i-2),auxvec(1),Ug2Db1tder(1,i-2))
3256         call matvec2(CC(1,1,i-1),Ub2(1,i-2),CUgb2(1,i-2))
3257         call matvec2(CC(1,1,i-1),Ub2der(1,i-2),CUgb2der(1,i-2))
3258         call matmat2(EUg(1,1,i-2),CC(1,1,i-1),EUgC(1,1,i-2))
3259         call matmat2(EUgder(1,1,i-2),CC(1,1,i-1),EUgCder(1,1,i-2))
3260         call matmat2(EUg(1,1,i-2),DD(1,1,i-1),EUgD(1,1,i-2))
3261         call matmat2(EUgder(1,1,i-2),DD(1,1,i-1),EUgDder(1,1,i-2))
3262         endif
3263       enddo
3264 C Matrices dependent on two consecutive virtual-bond dihedrals.
3265 C The order of matrices is from left to right.
3266       if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
3267      &then
3268 c      do i=max0(ivec_start,2),ivec_end
3269       do i=2,nres-1
3270         call matmat2(DtUg2(1,1,i-1),EUg(1,1,i),DtUg2EUg(1,1,i))
3271         call matmat2(DtUg2der(1,1,i-1),EUg(1,1,i),DtUg2EUgder(1,1,1,i))
3272         call matmat2(DtUg2(1,1,i-1),EUgder(1,1,i),DtUg2EUgder(1,1,2,i))
3273         call transpose2(DtUg2(1,1,i-1),auxmat(1,1))
3274         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUg(1,1,i))
3275         call matmat2(auxmat(1,1),EUgder(1,1,i),Ug2DtEUgder(1,1,2,i))
3276         call transpose2(DtUg2der(1,1,i-1),auxmat(1,1))
3277         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUgder(1,1,1,i))
3278       enddo
3279       endif
3280 #if defined(MPI) && defined(PARMAT)
3281 #ifdef DEBUG
3282 c      if (fg_rank.eq.0) then
3283         write (iout,*) "Arrays UG and UGDER before GATHER"
3284         do i=1,nres-1
3285           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3286      &     ((ug(l,k,i),l=1,2),k=1,2),
3287      &     ((ugder(l,k,i),l=1,2),k=1,2)
3288         enddo
3289         write (iout,*) "Arrays UG2 and UG2DER"
3290         do i=1,nres-1
3291           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3292      &     ((ug2(l,k,i),l=1,2),k=1,2),
3293      &     ((ug2der(l,k,i),l=1,2),k=1,2)
3294         enddo
3295         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
3296         do i=1,nres-1
3297           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3298      &     (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
3299      &     (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
3300         enddo
3301         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
3302         do i=1,nres-1
3303           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3304      &     costab(i),sintab(i),costab2(i),sintab2(i)
3305         enddo
3306         write (iout,*) "Array MUDER"
3307         do i=1,nres-1
3308           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
3309         enddo
3310 c      endif
3311 #endif
3312       if (nfgtasks.gt.1) then
3313         time00=MPI_Wtime()
3314 c        write(iout,*)"Processor",fg_rank,kolor," ivec_start",ivec_start,
3315 c     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks-1),
3316 c     &   " ivec_count",(ivec_count(i),i=0,nfgtasks-1)
3317 #ifdef MATGATHER
3318         call MPI_Allgatherv(Ub2(1,ivec_start),ivec_count(fg_rank1),
3319      &   MPI_MU,Ub2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3320      &   FG_COMM1,IERR)
3321         call MPI_Allgatherv(Ub2der(1,ivec_start),ivec_count(fg_rank1),
3322      &   MPI_MU,Ub2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3323      &   FG_COMM1,IERR)
3324         call MPI_Allgatherv(mu(1,ivec_start),ivec_count(fg_rank1),
3325      &   MPI_MU,mu(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3326      &   FG_COMM1,IERR)
3327         call MPI_Allgatherv(muder(1,ivec_start),ivec_count(fg_rank1),
3328      &   MPI_MU,muder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3329      &   FG_COMM1,IERR)
3330         call MPI_Allgatherv(Eug(1,1,ivec_start),ivec_count(fg_rank1),
3331      &   MPI_MAT1,Eug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3332      &   FG_COMM1,IERR)
3333         call MPI_Allgatherv(Eugder(1,1,ivec_start),ivec_count(fg_rank1),
3334      &   MPI_MAT1,Eugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3335      &   FG_COMM1,IERR)
3336         call MPI_Allgatherv(costab(ivec_start),ivec_count(fg_rank1),
3337      &   MPI_DOUBLE_PRECISION,costab(1),ivec_count(0),ivec_displ(0),
3338      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3339         call MPI_Allgatherv(sintab(ivec_start),ivec_count(fg_rank1),
3340      &   MPI_DOUBLE_PRECISION,sintab(1),ivec_count(0),ivec_displ(0),
3341      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3342         call MPI_Allgatherv(costab2(ivec_start),ivec_count(fg_rank1),
3343      &   MPI_DOUBLE_PRECISION,costab2(1),ivec_count(0),ivec_displ(0),
3344      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3345         call MPI_Allgatherv(sintab2(ivec_start),ivec_count(fg_rank1),
3346      &   MPI_DOUBLE_PRECISION,sintab2(1),ivec_count(0),ivec_displ(0),
3347      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3348         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
3349      &  then
3350         call MPI_Allgatherv(Ctobr(1,ivec_start),ivec_count(fg_rank1),
3351      &   MPI_MU,Ctobr(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3352      &   FG_COMM1,IERR)
3353         call MPI_Allgatherv(Ctobrder(1,ivec_start),ivec_count(fg_rank1),
3354      &   MPI_MU,Ctobrder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3355      &   FG_COMM1,IERR)
3356         call MPI_Allgatherv(Dtobr2(1,ivec_start),ivec_count(fg_rank1),
3357      &   MPI_MU,Dtobr2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3358      &   FG_COMM1,IERR)
3359        call MPI_Allgatherv(Dtobr2der(1,ivec_start),ivec_count(fg_rank1),
3360      &   MPI_MU,Dtobr2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3361      &   FG_COMM1,IERR)
3362         call MPI_Allgatherv(Ug2Db1t(1,ivec_start),ivec_count(fg_rank1),
3363      &   MPI_MU,Ug2Db1t(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3364      &   FG_COMM1,IERR)
3365         call MPI_Allgatherv(Ug2Db1tder(1,ivec_start),
3366      &   ivec_count(fg_rank1),
3367      &   MPI_MU,Ug2Db1tder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3368      &   FG_COMM1,IERR)
3369         call MPI_Allgatherv(CUgb2(1,ivec_start),ivec_count(fg_rank1),
3370      &   MPI_MU,CUgb2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3371      &   FG_COMM1,IERR)
3372         call MPI_Allgatherv(CUgb2der(1,ivec_start),ivec_count(fg_rank1),
3373      &   MPI_MU,CUgb2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3374      &   FG_COMM1,IERR)
3375         call MPI_Allgatherv(Cug(1,1,ivec_start),ivec_count(fg_rank1),
3376      &   MPI_MAT1,Cug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3377      &   FG_COMM1,IERR)
3378         call MPI_Allgatherv(Cugder(1,1,ivec_start),ivec_count(fg_rank1),
3379      &   MPI_MAT1,Cugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3380      &   FG_COMM1,IERR)
3381         call MPI_Allgatherv(Dug(1,1,ivec_start),ivec_count(fg_rank1),
3382      &   MPI_MAT1,Dug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3383      &   FG_COMM1,IERR)
3384         call MPI_Allgatherv(Dugder(1,1,ivec_start),ivec_count(fg_rank1),
3385      &   MPI_MAT1,Dugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3386      &   FG_COMM1,IERR)
3387         call MPI_Allgatherv(Dtug2(1,1,ivec_start),ivec_count(fg_rank1),
3388      &   MPI_MAT1,Dtug2(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3389      &   FG_COMM1,IERR)
3390         call MPI_Allgatherv(Dtug2der(1,1,ivec_start),
3391      &   ivec_count(fg_rank1),
3392      &   MPI_MAT1,Dtug2der(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3393      &   FG_COMM1,IERR)
3394         call MPI_Allgatherv(EugC(1,1,ivec_start),ivec_count(fg_rank1),
3395      &   MPI_MAT1,EugC(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3396      &   FG_COMM1,IERR)
3397        call MPI_Allgatherv(EugCder(1,1,ivec_start),ivec_count(fg_rank1),
3398      &   MPI_MAT1,EugCder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3399      &   FG_COMM1,IERR)
3400         call MPI_Allgatherv(EugD(1,1,ivec_start),ivec_count(fg_rank1),
3401      &   MPI_MAT1,EugD(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3402      &   FG_COMM1,IERR)
3403        call MPI_Allgatherv(EugDder(1,1,ivec_start),ivec_count(fg_rank1),
3404      &   MPI_MAT1,EugDder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3405      &   FG_COMM1,IERR)
3406         call MPI_Allgatherv(DtUg2EUg(1,1,ivec_start),
3407      &   ivec_count(fg_rank1),
3408      &   MPI_MAT1,DtUg2EUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3409      &   FG_COMM1,IERR)
3410         call MPI_Allgatherv(Ug2DtEUg(1,1,ivec_start),
3411      &   ivec_count(fg_rank1),
3412      &   MPI_MAT1,Ug2DtEUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3413      &   FG_COMM1,IERR)
3414         call MPI_Allgatherv(DtUg2EUgder(1,1,1,ivec_start),
3415      &   ivec_count(fg_rank1),
3416      &   MPI_MAT2,DtUg2EUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
3417      &   MPI_MAT2,FG_COMM1,IERR)
3418         call MPI_Allgatherv(Ug2DtEUgder(1,1,1,ivec_start),
3419      &   ivec_count(fg_rank1),
3420      &   MPI_MAT2,Ug2DtEUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
3421      &   MPI_MAT2,FG_COMM1,IERR)
3422         endif
3423 #else
3424 c Passes matrix info through the ring
3425       isend=fg_rank1
3426       irecv=fg_rank1-1
3427       if (irecv.lt.0) irecv=nfgtasks1-1
3428       iprev=irecv
3429       inext=fg_rank1+1
3430       if (inext.ge.nfgtasks1) inext=0
3431       do i=1,nfgtasks1-1
3432 c        write (iout,*) "isend",isend," irecv",irecv
3433 c        call flush(iout)
3434         lensend=lentyp(isend)
3435         lenrecv=lentyp(irecv)
3436 c        write (iout,*) "lensend",lensend," lenrecv",lenrecv
3437 c        call MPI_SENDRECV(ug(1,1,ivec_displ(isend)+1),1,
3438 c     &   MPI_ROTAT1(lensend),inext,2200+isend,
3439 c     &   ug(1,1,ivec_displ(irecv)+1),1,MPI_ROTAT1(lenrecv),
3440 c     &   iprev,2200+irecv,FG_COMM,status,IERR)
3441 c        write (iout,*) "Gather ROTAT1"
3442 c        call flush(iout)
3443 c        call MPI_SENDRECV(obrot(1,ivec_displ(isend)+1),1,
3444 c     &   MPI_ROTAT2(lensend),inext,3300+isend,
3445 c     &   obrot(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
3446 c     &   iprev,3300+irecv,FG_COMM,status,IERR)
3447 c        write (iout,*) "Gather ROTAT2"
3448 c        call flush(iout)
3449         call MPI_SENDRECV(costab(ivec_displ(isend)+1),1,
3450      &   MPI_ROTAT_OLD(lensend),inext,4400+isend,
3451      &   costab(ivec_displ(irecv)+1),1,MPI_ROTAT_OLD(lenrecv),
3452      &   iprev,4400+irecv,FG_COMM,status,IERR)
3453 c        write (iout,*) "Gather ROTAT_OLD"
3454 c        call flush(iout)
3455         call MPI_SENDRECV(mu(1,ivec_displ(isend)+1),1,
3456      &   MPI_PRECOMP11(lensend),inext,5500+isend,
3457      &   mu(1,ivec_displ(irecv)+1),1,MPI_PRECOMP11(lenrecv),
3458      &   iprev,5500+irecv,FG_COMM,status,IERR)
3459 c        write (iout,*) "Gather PRECOMP11"
3460 c        call flush(iout)
3461         call MPI_SENDRECV(Eug(1,1,ivec_displ(isend)+1),1,
3462      &   MPI_PRECOMP12(lensend),inext,6600+isend,
3463      &   Eug(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP12(lenrecv),
3464      &   iprev,6600+irecv,FG_COMM,status,IERR)
3465 c        write (iout,*) "Gather PRECOMP12"
3466 c        call flush(iout)
3467         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
3468      &  then
3469         call MPI_SENDRECV(ug2db1t(1,ivec_displ(isend)+1),1,
3470      &   MPI_ROTAT2(lensend),inext,7700+isend,
3471      &   ug2db1t(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
3472      &   iprev,7700+irecv,FG_COMM,status,IERR)
3473 c        write (iout,*) "Gather PRECOMP21"
3474 c        call flush(iout)
3475         call MPI_SENDRECV(EUgC(1,1,ivec_displ(isend)+1),1,
3476      &   MPI_PRECOMP22(lensend),inext,8800+isend,
3477      &   EUgC(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP22(lenrecv),
3478      &   iprev,8800+irecv,FG_COMM,status,IERR)
3479 c        write (iout,*) "Gather PRECOMP22"
3480 c        call flush(iout)
3481         call MPI_SENDRECV(Ug2DtEUgder(1,1,1,ivec_displ(isend)+1),1,
3482      &   MPI_PRECOMP23(lensend),inext,9900+isend,
3483      &   Ug2DtEUgder(1,1,1,ivec_displ(irecv)+1),1,
3484      &   MPI_PRECOMP23(lenrecv),
3485      &   iprev,9900+irecv,FG_COMM,status,IERR)
3486 c        write (iout,*) "Gather PRECOMP23"
3487 c        call flush(iout)
3488         endif
3489         isend=irecv
3490         irecv=irecv-1
3491         if (irecv.lt.0) irecv=nfgtasks1-1
3492       enddo
3493 #endif
3494         time_gather=time_gather+MPI_Wtime()-time00
3495       endif
3496 #ifdef DEBUG
3497 c      if (fg_rank.eq.0) then
3498         write (iout,*) "Arrays UG and UGDER"
3499         do i=1,nres-1
3500           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3501      &     ((ug(l,k,i),l=1,2),k=1,2),
3502      &     ((ugder(l,k,i),l=1,2),k=1,2)
3503         enddo
3504         write (iout,*) "Arrays UG2 and UG2DER"
3505         do i=1,nres-1
3506           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3507      &     ((ug2(l,k,i),l=1,2),k=1,2),
3508      &     ((ug2der(l,k,i),l=1,2),k=1,2)
3509         enddo
3510         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
3511         do i=1,nres-1
3512           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3513      &     (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
3514      &     (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
3515         enddo
3516         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
3517         do i=1,nres-1
3518           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3519      &     costab(i),sintab(i),costab2(i),sintab2(i)
3520         enddo
3521         write (iout,*) "Array MUDER"
3522         do i=1,nres-1
3523           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
3524         enddo
3525 c      endif
3526 #endif
3527 #endif
3528 cd      do i=1,nres
3529 cd        iti = itype2loc(itype(i))
3530 cd        write (iout,*) i
3531 cd        do j=1,2
3532 cd        write (iout,'(2f10.5,5x,2f10.5,5x,2f10.5)')
3533 cd     &  (EE(j,k,i),k=1,2),(Ug(j,k,i),k=1,2),(EUg(j,k,i),k=1,2)
3534 cd        enddo
3535 cd      enddo
3536       return
3537       end
3538 C--------------------------------------------------------------------------
3539       subroutine eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
3540 C
3541 C This subroutine calculates the average interaction energy and its gradient
3542 C in the virtual-bond vectors between non-adjacent peptide groups, based on
3543 C the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
3544 C The potential depends both on the distance of peptide-group centers and on
3545 C the orientation of the CA-CA virtual bonds.
3546 C
3547       implicit real*8 (a-h,o-z)
3548 #ifdef MPI
3549       include 'mpif.h'
3550 #endif
3551       include 'DIMENSIONS'
3552       include 'COMMON.CONTROL'
3553       include 'COMMON.SETUP'
3554       include 'COMMON.IOUNITS'
3555       include 'COMMON.GEO'
3556       include 'COMMON.VAR'
3557       include 'COMMON.LOCAL'
3558       include 'COMMON.CHAIN'
3559       include 'COMMON.DERIV'
3560       include 'COMMON.INTERACT'
3561       include 'COMMON.CONTACTS'
3562       include 'COMMON.TORSION'
3563       include 'COMMON.VECTORS'
3564       include 'COMMON.FFIELD'
3565       include 'COMMON.TIME1'
3566       include 'COMMON.SPLITELE'
3567       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
3568      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
3569       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
3570      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4),gmuij(4)
3571       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3572      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3573      &    num_conti,j1,j2
3574 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
3575 #ifdef MOMENT
3576       double precision scal_el /1.0d0/
3577 #else
3578       double precision scal_el /0.5d0/
3579 #endif
3580 C 12/13/98
3581 C 13-go grudnia roku pamietnego...
3582       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
3583      &                   0.0d0,1.0d0,0.0d0,
3584      &                   0.0d0,0.0d0,1.0d0/
3585 cd      write(iout,*) 'In EELEC'
3586 cd      do i=1,nloctyp
3587 cd        write(iout,*) 'Type',i
3588 cd        write(iout,*) 'B1',B1(:,i)
3589 cd        write(iout,*) 'B2',B2(:,i)
3590 cd        write(iout,*) 'CC',CC(:,:,i)
3591 cd        write(iout,*) 'DD',DD(:,:,i)
3592 cd        write(iout,*) 'EE',EE(:,:,i)
3593 cd      enddo
3594 cd      call check_vecgrad
3595 cd      stop
3596       if (icheckgrad.eq.1) then
3597         do i=1,nres-1
3598           fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
3599           do k=1,3
3600             dc_norm(k,i)=dc(k,i)*fac
3601           enddo
3602 c          write (iout,*) 'i',i,' fac',fac
3603         enddo
3604       endif
3605       if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
3606      &    .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or.
3607      &    wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
3608 c        call vec_and_deriv
3609 #ifdef TIMING
3610         time01=MPI_Wtime()
3611 #endif
3612         call set_matrices
3613 #ifdef TIMING
3614         time_mat=time_mat+MPI_Wtime()-time01
3615 #endif
3616       endif
3617 cd      do i=1,nres-1
3618 cd        write (iout,*) 'i=',i
3619 cd        do k=1,3
3620 cd        write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
3621 cd        enddo
3622 cd        do k=1,3
3623 cd          write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
3624 cd     &     uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
3625 cd        enddo
3626 cd      enddo
3627       t_eelecij=0.0d0
3628       ees=0.0D0
3629       evdw1=0.0D0
3630       eel_loc=0.0d0
3631       eello_turn3=0.0d0
3632       eello_turn4=0.0d0
3633       ind=0
3634       do i=1,nres
3635         num_cont_hb(i)=0
3636       enddo
3637 cd      print '(a)','Enter EELEC'
3638 cd      write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
3639       do i=1,nres
3640         gel_loc_loc(i)=0.0d0
3641         gcorr_loc(i)=0.0d0
3642       enddo
3643 c
3644 c
3645 c 9/27/08 AL Split the interaction loop to ensure load balancing of turn terms
3646 C
3647 C Loop over i,i+2 and i,i+3 pairs of the peptide groups
3648 C
3649 C 14/01/2014 TURN3,TUNR4 does no go under periodic boundry condition
3650       do i=iturn3_start,iturn3_end
3651 c        if (i.le.1) cycle
3652 C        write(iout,*) "tu jest i",i
3653         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
3654 C changes suggested by Ana to avoid out of bounds
3655 C Adam: Unnecessary: handled by iturn3_end and iturn3_start
3656 c     & .or.((i+4).gt.nres)
3657 c     & .or.((i-1).le.0)
3658 C end of changes by Ana
3659      &  .or. itype(i+2).eq.ntyp1
3660      &  .or. itype(i+3).eq.ntyp1) cycle
3661 C Adam: Instructions below will switch off existing interactions
3662 c        if(i.gt.1)then
3663 c          if(itype(i-1).eq.ntyp1)cycle
3664 c        end if
3665 c        if(i.LT.nres-3)then
3666 c          if (itype(i+4).eq.ntyp1) cycle
3667 c        end if
3668         dxi=dc(1,i)
3669         dyi=dc(2,i)
3670         dzi=dc(3,i)
3671         dx_normi=dc_norm(1,i)
3672         dy_normi=dc_norm(2,i)
3673         dz_normi=dc_norm(3,i)
3674         xmedi=c(1,i)+0.5d0*dxi
3675         ymedi=c(2,i)+0.5d0*dyi
3676         zmedi=c(3,i)+0.5d0*dzi
3677           xmedi=mod(xmedi,boxxsize)
3678           if (xmedi.lt.0) xmedi=xmedi+boxxsize
3679           ymedi=mod(ymedi,boxysize)
3680           if (ymedi.lt.0) ymedi=ymedi+boxysize
3681           zmedi=mod(zmedi,boxzsize)
3682           if (zmedi.lt.0) zmedi=zmedi+boxzsize
3683         num_conti=0
3684         call eelecij(i,i+2,ees,evdw1,eel_loc)
3685         if (wturn3.gt.0.0d0) call eturn3(i,eello_turn3)
3686         num_cont_hb(i)=num_conti
3687       enddo
3688       do i=iturn4_start,iturn4_end
3689         if (i.lt.1) cycle
3690         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
3691 C changes suggested by Ana to avoid out of bounds
3692 c     & .or.((i+5).gt.nres)
3693 c     & .or.((i-1).le.0)
3694 C end of changes suggested by Ana
3695      &    .or. itype(i+3).eq.ntyp1
3696      &    .or. itype(i+4).eq.ntyp1
3697 c     &    .or. itype(i+5).eq.ntyp1
3698 c     &    .or. itype(i).eq.ntyp1
3699 c     &    .or. itype(i-1).eq.ntyp1
3700      &                             ) cycle
3701         dxi=dc(1,i)
3702         dyi=dc(2,i)
3703         dzi=dc(3,i)
3704         dx_normi=dc_norm(1,i)
3705         dy_normi=dc_norm(2,i)
3706         dz_normi=dc_norm(3,i)
3707         xmedi=c(1,i)+0.5d0*dxi
3708         ymedi=c(2,i)+0.5d0*dyi
3709         zmedi=c(3,i)+0.5d0*dzi
3710 C Return atom into box, boxxsize is size of box in x dimension
3711 c  194   continue
3712 c        if (xmedi.gt.((0.5d0)*boxxsize)) xmedi=xmedi-boxxsize
3713 c        if (xmedi.lt.((-0.5d0)*boxxsize)) xmedi=xmedi+boxxsize
3714 C Condition for being inside the proper box
3715 c        if ((xmedi.gt.((0.5d0)*boxxsize)).or.
3716 c     &       (xmedi.lt.((-0.5d0)*boxxsize))) then
3717 c        go to 194
3718 c        endif
3719 c  195   continue
3720 c        if (ymedi.gt.((0.5d0)*boxysize)) ymedi=ymedi-boxysize
3721 c        if (ymedi.lt.((-0.5d0)*boxysize)) ymedi=ymedi+boxysize
3722 C Condition for being inside the proper box
3723 c        if ((ymedi.gt.((0.5d0)*boxysize)).or.
3724 c     &       (ymedi.lt.((-0.5d0)*boxysize))) then
3725 c        go to 195
3726 c        endif
3727 c  196   continue
3728 c        if (zmedi.gt.((0.5d0)*boxzsize)) zmedi=zmedi-boxzsize
3729 c        if (zmedi.lt.((-0.5d0)*boxzsize)) zmedi=zmedi+boxzsize
3730 C Condition for being inside the proper box
3731 c        if ((zmedi.gt.((0.5d0)*boxzsize)).or.
3732 c     &       (zmedi.lt.((-0.5d0)*boxzsize))) then
3733 c        go to 196
3734 c        endif
3735           xmedi=mod(xmedi,boxxsize)
3736           if (xmedi.lt.0) xmedi=xmedi+boxxsize
3737           ymedi=mod(ymedi,boxysize)
3738           if (ymedi.lt.0) ymedi=ymedi+boxysize
3739           zmedi=mod(zmedi,boxzsize)
3740           if (zmedi.lt.0) zmedi=zmedi+boxzsize
3741
3742         num_conti=num_cont_hb(i)
3743 c        write(iout,*) "JESTEM W PETLI"
3744         call eelecij(i,i+3,ees,evdw1,eel_loc)
3745         if (wturn4.gt.0.0d0 .and. itype(i+2).ne.ntyp1)
3746      &   call eturn4(i,eello_turn4)
3747         num_cont_hb(i)=num_conti
3748       enddo   ! i
3749 C Loop over all neighbouring boxes
3750 C      do xshift=-1,1
3751 C      do yshift=-1,1
3752 C      do zshift=-1,1
3753 c
3754 c Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
3755 c
3756 CTU KURWA
3757       do i=iatel_s,iatel_e
3758 C        do i=75,75
3759 c        if (i.le.1) cycle
3760         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
3761 C changes suggested by Ana to avoid out of bounds
3762 c     & .or.((i+2).gt.nres)
3763 c     & .or.((i-1).le.0)
3764 C end of changes by Ana
3765 c     &  .or. itype(i+2).eq.ntyp1
3766 c     &  .or. itype(i-1).eq.ntyp1
3767      &                ) cycle
3768         dxi=dc(1,i)
3769         dyi=dc(2,i)
3770         dzi=dc(3,i)
3771         dx_normi=dc_norm(1,i)
3772         dy_normi=dc_norm(2,i)
3773         dz_normi=dc_norm(3,i)
3774         xmedi=c(1,i)+0.5d0*dxi
3775         ymedi=c(2,i)+0.5d0*dyi
3776         zmedi=c(3,i)+0.5d0*dzi
3777           xmedi=mod(xmedi,boxxsize)
3778           if (xmedi.lt.0) xmedi=xmedi+boxxsize
3779           ymedi=mod(ymedi,boxysize)
3780           if (ymedi.lt.0) ymedi=ymedi+boxysize
3781           zmedi=mod(zmedi,boxzsize)
3782           if (zmedi.lt.0) zmedi=zmedi+boxzsize
3783 C          xmedi=xmedi+xshift*boxxsize
3784 C          ymedi=ymedi+yshift*boxysize
3785 C          zmedi=zmedi+zshift*boxzsize
3786
3787 C Return tom into box, boxxsize is size of box in x dimension
3788 c  164   continue
3789 c        if (xmedi.gt.((xshift+0.5d0)*boxxsize)) xmedi=xmedi-boxxsize
3790 c        if (xmedi.lt.((xshift-0.5d0)*boxxsize)) xmedi=xmedi+boxxsize
3791 C Condition for being inside the proper box
3792 c        if ((xmedi.gt.((xshift+0.5d0)*boxxsize)).or.
3793 c     &       (xmedi.lt.((xshift-0.5d0)*boxxsize))) then
3794 c        go to 164
3795 c        endif
3796 c  165   continue
3797 c        if (ymedi.gt.((yshift+0.5d0)*boxysize)) ymedi=ymedi-boxysize
3798 c        if (ymedi.lt.((yshift-0.5d0)*boxysize)) ymedi=ymedi+boxysize
3799 C Condition for being inside the proper box
3800 c        if ((ymedi.gt.((yshift+0.5d0)*boxysize)).or.
3801 c     &       (ymedi.lt.((yshift-0.5d0)*boxysize))) then
3802 c        go to 165
3803 c        endif
3804 c  166   continue
3805 c        if (zmedi.gt.((zshift+0.5d0)*boxzsize)) zmedi=zmedi-boxzsize
3806 c        if (zmedi.lt.((zshift-0.5d0)*boxzsize)) zmedi=zmedi+boxzsize
3807 cC Condition for being inside the proper box
3808 c        if ((zmedi.gt.((zshift+0.5d0)*boxzsize)).or.
3809 c     &       (zmedi.lt.((zshift-0.5d0)*boxzsize))) then
3810 c        go to 166
3811 c        endif
3812
3813 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
3814         num_conti=num_cont_hb(i)
3815 C I TU KURWA
3816         do j=ielstart(i),ielend(i)
3817 C          do j=16,17
3818 C          write (iout,*) i,j
3819 C         if (j.le.1) cycle
3820           if (itype(j).eq.ntyp1.or. itype(j+1).eq.ntyp1
3821 C changes suggested by Ana to avoid out of bounds
3822 c     & .or.((j+2).gt.nres)
3823 c     & .or.((j-1).le.0)
3824 C end of changes by Ana
3825 c     & .or.itype(j+2).eq.ntyp1
3826 c     & .or.itype(j-1).eq.ntyp1
3827      &) cycle
3828           call eelecij(i,j,ees,evdw1,eel_loc)
3829         enddo ! j
3830         num_cont_hb(i)=num_conti
3831       enddo   ! i
3832 C     enddo   ! zshift
3833 C      enddo   ! yshift
3834 C      enddo   ! xshift
3835
3836 c      write (iout,*) "Number of loop steps in EELEC:",ind
3837 cd      do i=1,nres
3838 cd        write (iout,'(i3,3f10.5,5x,3f10.5)')
3839 cd     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
3840 cd      enddo
3841 c 12/7/99 Adam eello_turn3 will be considered as a separate energy term
3842 ccc      eel_loc=eel_loc+eello_turn3
3843 cd      print *,"Processor",fg_rank," t_eelecij",t_eelecij
3844       return
3845       end
3846 C-------------------------------------------------------------------------------
3847       subroutine eelecij(i,j,ees,evdw1,eel_loc)
3848       implicit real*8 (a-h,o-z)
3849       include 'DIMENSIONS'
3850 #ifdef MPI
3851       include "mpif.h"
3852 #endif
3853       include 'COMMON.CONTROL'
3854       include 'COMMON.IOUNITS'
3855       include 'COMMON.GEO'
3856       include 'COMMON.VAR'
3857       include 'COMMON.LOCAL'
3858       include 'COMMON.CHAIN'
3859       include 'COMMON.DERIV'
3860       include 'COMMON.INTERACT'
3861       include 'COMMON.CONTACTS'
3862       include 'COMMON.TORSION'
3863       include 'COMMON.VECTORS'
3864       include 'COMMON.FFIELD'
3865       include 'COMMON.TIME1'
3866       include 'COMMON.SPLITELE'
3867       include 'COMMON.SHIELD'
3868       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
3869      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
3870       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
3871      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4),gmuij1(4),gmuji1(4),
3872      &    gmuij2(4),gmuji2(4)
3873       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3874      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3875      &    num_conti,j1,j2
3876 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
3877 #ifdef MOMENT
3878       double precision scal_el /1.0d0/
3879 #else
3880       double precision scal_el /0.5d0/
3881 #endif
3882 C 12/13/98
3883 C 13-go grudnia roku pamietnego...
3884       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
3885      &                   0.0d0,1.0d0,0.0d0,
3886      &                   0.0d0,0.0d0,1.0d0/
3887        integer xshift,yshift,zshift
3888 c          time00=MPI_Wtime()
3889 cd      write (iout,*) "eelecij",i,j
3890 c          ind=ind+1
3891           iteli=itel(i)
3892           itelj=itel(j)
3893           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
3894           aaa=app(iteli,itelj)
3895           bbb=bpp(iteli,itelj)
3896           ael6i=ael6(iteli,itelj)
3897           ael3i=ael3(iteli,itelj)
3898           dxj=dc(1,j)
3899           dyj=dc(2,j)
3900           dzj=dc(3,j)
3901           dx_normj=dc_norm(1,j)
3902           dy_normj=dc_norm(2,j)
3903           dz_normj=dc_norm(3,j)
3904 C          xj=c(1,j)+0.5D0*dxj-xmedi
3905 C          yj=c(2,j)+0.5D0*dyj-ymedi
3906 C          zj=c(3,j)+0.5D0*dzj-zmedi
3907           xj=c(1,j)+0.5D0*dxj
3908           yj=c(2,j)+0.5D0*dyj
3909           zj=c(3,j)+0.5D0*dzj
3910           xj=mod(xj,boxxsize)
3911           if (xj.lt.0) xj=xj+boxxsize
3912           yj=mod(yj,boxysize)
3913           if (yj.lt.0) yj=yj+boxysize
3914           zj=mod(zj,boxzsize)
3915           if (zj.lt.0) zj=zj+boxzsize
3916           if ((zj.lt.0).or.(xj.lt.0).or.(yj.lt.0)) write (*,*) "CHUJ"
3917       dist_init=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
3918       xj_safe=xj
3919       yj_safe=yj
3920       zj_safe=zj
3921       isubchap=0
3922       do xshift=-1,1
3923       do yshift=-1,1
3924       do zshift=-1,1
3925           xj=xj_safe+xshift*boxxsize
3926           yj=yj_safe+yshift*boxysize
3927           zj=zj_safe+zshift*boxzsize
3928           dist_temp=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
3929           if(dist_temp.lt.dist_init) then
3930             dist_init=dist_temp
3931             xj_temp=xj
3932             yj_temp=yj
3933             zj_temp=zj
3934             isubchap=1
3935           endif
3936        enddo
3937        enddo
3938        enddo
3939        if (isubchap.eq.1) then
3940           xj=xj_temp-xmedi
3941           yj=yj_temp-ymedi
3942           zj=zj_temp-zmedi
3943        else
3944           xj=xj_safe-xmedi
3945           yj=yj_safe-ymedi
3946           zj=zj_safe-zmedi
3947        endif
3948 C        if ((i+3).lt.j) then !this condition keeps for turn3 and turn4 not subject to PBC
3949 c  174   continue
3950 c        if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
3951 c        if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
3952 C Condition for being inside the proper box
3953 c        if ((xj.gt.((0.5d0)*boxxsize)).or.
3954 c     &       (xj.lt.((-0.5d0)*boxxsize))) then
3955 c        go to 174
3956 c        endif
3957 c  175   continue
3958 c        if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
3959 c        if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
3960 C Condition for being inside the proper box
3961 c        if ((yj.gt.((0.5d0)*boxysize)).or.
3962 c     &       (yj.lt.((-0.5d0)*boxysize))) then
3963 c        go to 175
3964 c        endif
3965 c  176   continue
3966 c        if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
3967 c        if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
3968 C Condition for being inside the proper box
3969 c        if ((zj.gt.((0.5d0)*boxzsize)).or.
3970 c     &       (zj.lt.((-0.5d0)*boxzsize))) then
3971 c        go to 176
3972 c        endif
3973 C        endif !endPBC condintion
3974 C        xj=xj-xmedi
3975 C        yj=yj-ymedi
3976 C        zj=zj-zmedi
3977           rij=xj*xj+yj*yj+zj*zj
3978
3979             sss=sscale(sqrt(rij))
3980             sssgrad=sscagrad(sqrt(rij))
3981 c            if (sss.gt.0.0d0) then
3982           rrmij=1.0D0/rij
3983           rij=dsqrt(rij)
3984           rmij=1.0D0/rij
3985           r3ij=rrmij*rmij
3986           r6ij=r3ij*r3ij
3987           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
3988           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
3989           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
3990           fac=cosa-3.0D0*cosb*cosg
3991           ev1=aaa*r6ij*r6ij
3992 c 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
3993           if (j.eq.i+2) ev1=scal_el*ev1
3994           ev2=bbb*r6ij
3995           fac3=ael6i*r6ij
3996           fac4=ael3i*r3ij
3997           evdwij=(ev1+ev2)
3998           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
3999           el2=fac4*fac
4000 C MARYSIA
4001 C          eesij=(el1+el2)
4002 C 12/26/95 - for the evaluation of multi-body H-bonding interactions
4003           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
4004           if (shield_mode.gt.0) then
4005 C          fac_shield(i)=0.4
4006 C          fac_shield(j)=0.6
4007           el1=el1*fac_shield(i)**2*fac_shield(j)**2
4008           el2=el2*fac_shield(i)**2*fac_shield(j)**2
4009           eesij=(el1+el2)
4010           ees=ees+eesij
4011           else
4012           fac_shield(i)=1.0
4013           fac_shield(j)=1.0
4014           eesij=(el1+el2)
4015           ees=ees+eesij
4016           endif
4017           evdw1=evdw1+evdwij*sss
4018 cd          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
4019 cd     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
4020 cd     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
4021 cd     &      xmedi,ymedi,zmedi,xj,yj,zj
4022
4023           if (energy_dec) then
4024               write (iout,'(a6,2i5,0pf7.3,2i5,3e11.3)')
4025      &'evdw1',i,j,evdwij
4026      &,iteli,itelj,aaa,evdw1,sss
4027               write (iout,'(a6,2i5,0pf7.3,2f8.3)') 'ees',i,j,eesij,
4028      &fac_shield(i),fac_shield(j)
4029           endif
4030
4031 C
4032 C Calculate contributions to the Cartesian gradient.
4033 C
4034 #ifdef SPLITELE
4035           facvdw=-6*rrmij*(ev1+evdwij)*sss
4036           facel=-3*rrmij*(el1+eesij)
4037           fac1=fac
4038           erij(1)=xj*rmij
4039           erij(2)=yj*rmij
4040           erij(3)=zj*rmij
4041
4042 *
4043 * Radial derivatives. First process both termini of the fragment (i,j)
4044 *
4045           ggg(1)=facel*xj
4046           ggg(2)=facel*yj
4047           ggg(3)=facel*zj
4048           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
4049      &  (shield_mode.gt.0)) then
4050 C          print *,i,j
4051           do ilist=1,ishield_list(i)
4052            iresshield=shield_list(ilist,i)
4053            do k=1,3
4054            rlocshield=grad_shield_side(k,ilist,i)*eesij/fac_shield(i)
4055      &      *2.0
4056            gshieldx(k,iresshield)=gshieldx(k,iresshield)+
4057      &              rlocshield
4058      & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)*2.0
4059             gshieldc(k,iresshield-1)=gshieldc(k,iresshield-1)+rlocshield
4060 C           gshieldc_loc(k,iresshield)=gshieldc_loc(k,iresshield)
4061 C     & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)
4062 C             if (iresshield.gt.i) then
4063 C               do ishi=i+1,iresshield-1
4064 C                gshieldc(k,ishi)=gshieldc(k,ishi)+rlocshield
4065 C     & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)
4066 C
4067 C              enddo
4068 C             else
4069 C               do ishi=iresshield,i
4070 C                gshieldc(k,ishi)=gshieldc(k,ishi)-rlocshield
4071 C     & -grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)
4072 C
4073 C               enddo
4074 C              endif
4075            enddo
4076           enddo
4077           do ilist=1,ishield_list(j)
4078            iresshield=shield_list(ilist,j)
4079            do k=1,3
4080            rlocshield=grad_shield_side(k,ilist,j)*eesij/fac_shield(j)
4081      &     *2.0
4082            gshieldx(k,iresshield)=gshieldx(k,iresshield)+
4083      &              rlocshield
4084      & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)*2.0
4085            gshieldc(k,iresshield-1)=gshieldc(k,iresshield-1)+rlocshield
4086
4087 C     & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
4088 C           gshieldc_loc(k,iresshield)=gshieldc_loc(k,iresshield)
4089 C     & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
4090 C             if (iresshield.gt.j) then
4091 C               do ishi=j+1,iresshield-1
4092 C                gshieldc(k,ishi)=gshieldc(k,ishi)+rlocshield
4093 C     & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
4094 C
4095 C               enddo
4096 C            else
4097 C               do ishi=iresshield,j
4098 C                gshieldc(k,ishi)=gshieldc(k,ishi)-rlocshield
4099 C     & -grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
4100 C               enddo
4101 C              endif
4102            enddo
4103           enddo
4104
4105           do k=1,3
4106             gshieldc(k,i)=gshieldc(k,i)+
4107      &              grad_shield(k,i)*eesij/fac_shield(i)*2.0
4108             gshieldc(k,j)=gshieldc(k,j)+
4109      &              grad_shield(k,j)*eesij/fac_shield(j)*2.0
4110             gshieldc(k,i-1)=gshieldc(k,i-1)+
4111      &              grad_shield(k,i)*eesij/fac_shield(i)*2.0
4112             gshieldc(k,j-1)=gshieldc(k,j-1)+
4113      &              grad_shield(k,j)*eesij/fac_shield(j)*2.0
4114
4115            enddo
4116            endif
4117 c          do k=1,3
4118 c            ghalf=0.5D0*ggg(k)
4119 c            gelc(k,i)=gelc(k,i)+ghalf
4120 c            gelc(k,j)=gelc(k,j)+ghalf
4121 c          enddo
4122 c 9/28/08 AL Gradient compotents will be summed only at the end
4123 C           print *,"before", gelc_long(1,i), gelc_long(1,j)
4124           do k=1,3
4125             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
4126 C     &                    +grad_shield(k,j)*eesij/fac_shield(j)
4127             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
4128 C     &                    +grad_shield(k,i)*eesij/fac_shield(i)
4129 C            gelc_long(k,i-1)=gelc_long(k,i-1)
4130 C     &                    +grad_shield(k,i)*eesij/fac_shield(i)
4131 C            gelc_long(k,j-1)=gelc_long(k,j-1)
4132 C     &                    +grad_shield(k,j)*eesij/fac_shield(j)
4133           enddo
4134 C           print *,"bafter", gelc_long(1,i), gelc_long(1,j)
4135
4136 *
4137 * Loop over residues i+1 thru j-1.
4138 *
4139 cgrad          do k=i+1,j-1
4140 cgrad            do l=1,3
4141 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
4142 cgrad            enddo
4143 cgrad          enddo
4144           if (sss.gt.0.0) then
4145           ggg(1)=facvdw*xj+sssgrad*rmij*evdwij*xj
4146           ggg(2)=facvdw*yj+sssgrad*rmij*evdwij*yj
4147           ggg(3)=facvdw*zj+sssgrad*rmij*evdwij*zj
4148           else
4149           ggg(1)=0.0
4150           ggg(2)=0.0
4151           ggg(3)=0.0
4152           endif
4153 c          do k=1,3
4154 c            ghalf=0.5D0*ggg(k)
4155 c            gvdwpp(k,i)=gvdwpp(k,i)+ghalf
4156 c            gvdwpp(k,j)=gvdwpp(k,j)+ghalf
4157 c          enddo
4158 c 9/28/08 AL Gradient compotents will be summed only at the end
4159           do k=1,3
4160             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
4161             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
4162           enddo
4163 *
4164 * Loop over residues i+1 thru j-1.
4165 *
4166 cgrad          do k=i+1,j-1
4167 cgrad            do l=1,3
4168 cgrad              gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
4169 cgrad            enddo
4170 cgrad          enddo
4171 #else
4172 C MARYSIA
4173           facvdw=(ev1+evdwij)*sss
4174           facel=(el1+eesij)
4175           fac1=fac
4176           fac=-3*rrmij*(facvdw+facvdw+facel)
4177           erij(1)=xj*rmij
4178           erij(2)=yj*rmij
4179           erij(3)=zj*rmij
4180 *
4181 * Radial derivatives. First process both termini of the fragment (i,j)
4182 *
4183           ggg(1)=fac*xj
4184 C+eesij*grad_shield(1,i)+eesij*grad_shield(1,j)
4185           ggg(2)=fac*yj
4186 C+eesij*grad_shield(2,i)+eesij*grad_shield(2,j)
4187           ggg(3)=fac*zj
4188 C+eesij*grad_shield(3,i)+eesij*grad_shield(3,j)
4189 c          do k=1,3
4190 c            ghalf=0.5D0*ggg(k)
4191 c            gelc(k,i)=gelc(k,i)+ghalf
4192 c            gelc(k,j)=gelc(k,j)+ghalf
4193 c          enddo
4194 c 9/28/08 AL Gradient compotents will be summed only at the end
4195           do k=1,3
4196             gelc_long(k,j)=gelc(k,j)+ggg(k)
4197             gelc_long(k,i)=gelc(k,i)-ggg(k)
4198           enddo
4199 *
4200 * Loop over residues i+1 thru j-1.
4201 *
4202 cgrad          do k=i+1,j-1
4203 cgrad            do l=1,3
4204 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
4205 cgrad            enddo
4206 cgrad          enddo
4207 c 9/28/08 AL Gradient compotents will be summed only at the end
4208           ggg(1)=facvdw*xj+sssgrad*rmij*evdwij*xj
4209           ggg(2)=facvdw*yj+sssgrad*rmij*evdwij*yj
4210           ggg(3)=facvdw*zj+sssgrad*rmij*evdwij*zj
4211           do k=1,3
4212             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
4213             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
4214           enddo
4215 #endif
4216 *
4217 * Angular part
4218 *
4219           ecosa=2.0D0*fac3*fac1+fac4
4220           fac4=-3.0D0*fac4
4221           fac3=-6.0D0*fac3
4222           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
4223           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
4224           do k=1,3
4225             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
4226             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
4227           enddo
4228 cd        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
4229 cd   &          (dcosg(k),k=1,3)
4230           do k=1,3
4231             ggg(k)=(ecosb*dcosb(k)+ecosg*dcosg(k))*
4232      &      fac_shield(i)**2*fac_shield(j)**2
4233           enddo
4234 c          do k=1,3
4235 c            ghalf=0.5D0*ggg(k)
4236 c            gelc(k,i)=gelc(k,i)+ghalf
4237 c     &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
4238 c     &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
4239 c            gelc(k,j)=gelc(k,j)+ghalf
4240 c     &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
4241 c     &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
4242 c          enddo
4243 cgrad          do k=i+1,j-1
4244 cgrad            do l=1,3
4245 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
4246 cgrad            enddo
4247 cgrad          enddo
4248 C                     print *,"before22", gelc_long(1,i), gelc_long(1,j)
4249           do k=1,3
4250             gelc(k,i)=gelc(k,i)
4251      &           +((ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
4252      &           + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1))
4253      &           *fac_shield(i)**2*fac_shield(j)**2
4254             gelc(k,j)=gelc(k,j)
4255      &           +((ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
4256      &           + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1))
4257      &           *fac_shield(i)**2*fac_shield(j)**2
4258             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
4259             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
4260           enddo
4261 C           print *,"before33", gelc_long(1,i), gelc_long(1,j)
4262
4263 C MARYSIA
4264 c          endif !sscale
4265           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
4266      &        .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0
4267      &        .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
4268 C
4269 C 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
4270 C   energy of a peptide unit is assumed in the form of a second-order
4271 C   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
4272 C   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
4273 C   are computed for EVERY pair of non-contiguous peptide groups.
4274 C
4275
4276           if (j.lt.nres-1) then
4277             j1=j+1
4278             j2=j-1
4279           else
4280             j1=j-1
4281             j2=j-2
4282           endif
4283           kkk=0
4284           lll=0
4285           do k=1,2
4286             do l=1,2
4287               kkk=kkk+1
4288               muij(kkk)=mu(k,i)*mu(l,j)
4289 c              write(iout,*) 'mumu=', mu(k,i),mu(l,j),i,j,k,l
4290 #ifdef NEWCORR
4291              gmuij1(kkk)=gtb1(k,i+1)*mu(l,j)
4292 c             write(iout,*) 'k=',k,i,gtb1(k,i+1),gtb1(k,i+1)*mu(l,j)
4293              gmuij2(kkk)=gUb2(k,i)*mu(l,j)
4294              gmuji1(kkk)=mu(k,i)*gtb1(l,j+1)
4295 c             write(iout,*) 'l=',l,j,gtb1(l,j+1),gtb1(l,j+1)*mu(k,i)
4296              gmuji2(kkk)=mu(k,i)*gUb2(l,j)
4297 #endif
4298             enddo
4299           enddo
4300 #ifdef DEBUG
4301           write (iout,*) 'EELEC: i',i,' j',j
4302           write (iout,*) 'j',j,' j1',j1,' j2',j2
4303           write(iout,*) 'muij',muij
4304 #endif
4305           ury=scalar(uy(1,i),erij)
4306           urz=scalar(uz(1,i),erij)
4307           vry=scalar(uy(1,j),erij)
4308           vrz=scalar(uz(1,j),erij)
4309           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
4310           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
4311           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
4312           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
4313           fac=dsqrt(-ael6i)*r3ij
4314 #ifdef DEBUG
4315           write (iout,*) "ury",ury," urz",urz," vry",vry," vrz",vrz
4316           write (iout,*) "uyvy",scalar(uy(1,i),uy(1,j)),
4317      &      "uyvz",scalar(uy(1,i),uz(1,j)),
4318      &      "uzvy",scalar(uz(1,i),uy(1,j)),
4319      &      "uzvz",scalar(uz(1,i),uz(1,j))
4320           write (iout,*) "a22",a22," a23",a23," a32",a32," a33",a33
4321           write (iout,*) "fac",fac
4322 #endif
4323           a22=a22*fac
4324           a23=a23*fac
4325           a32=a32*fac
4326           a33=a33*fac
4327 #ifdef DEBUG
4328           write (iout,*) "a22",a22," a23",a23," a32",a32," a33",a33
4329 #endif
4330 #undef DEBUG
4331 cd          write (iout,'(4i5,4f10.5)')
4332 cd     &     i,itortyp(itype(i)),j,itortyp(itype(j)),a22,a23,a32,a33
4333 cd          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
4334 cd          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') uy(:,i),uz(:,i),
4335 cd     &      uy(:,j),uz(:,j)
4336 cd          write (iout,'(4f10.5)')
4337 cd     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
4338 cd     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
4339 cd          write (iout,'(4f10.5)') ury,urz,vry,vrz
4340 cd           write (iout,'(9f10.5/)')
4341 cd     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
4342 C Derivatives of the elements of A in virtual-bond vectors
4343           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
4344           do k=1,3
4345             uryg(k,1)=scalar(erder(1,k),uy(1,i))
4346             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
4347             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
4348             urzg(k,1)=scalar(erder(1,k),uz(1,i))
4349             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
4350             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
4351             vryg(k,1)=scalar(erder(1,k),uy(1,j))
4352             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
4353             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
4354             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
4355             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
4356             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
4357           enddo
4358 C Compute radial contributions to the gradient
4359           facr=-3.0d0*rrmij
4360           a22der=a22*facr
4361           a23der=a23*facr
4362           a32der=a32*facr
4363           a33der=a33*facr
4364           agg(1,1)=a22der*xj
4365           agg(2,1)=a22der*yj
4366           agg(3,1)=a22der*zj
4367           agg(1,2)=a23der*xj
4368           agg(2,2)=a23der*yj
4369           agg(3,2)=a23der*zj
4370           agg(1,3)=a32der*xj
4371           agg(2,3)=a32der*yj
4372           agg(3,3)=a32der*zj
4373           agg(1,4)=a33der*xj
4374           agg(2,4)=a33der*yj
4375           agg(3,4)=a33der*zj
4376 C Add the contributions coming from er
4377           fac3=-3.0d0*fac
4378           do k=1,3
4379             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
4380             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
4381             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
4382             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
4383           enddo
4384           do k=1,3
4385 C Derivatives in DC(i)
4386 cgrad            ghalf1=0.5d0*agg(k,1)
4387 cgrad            ghalf2=0.5d0*agg(k,2)
4388 cgrad            ghalf3=0.5d0*agg(k,3)
4389 cgrad            ghalf4=0.5d0*agg(k,4)
4390             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j))
4391      &      -3.0d0*uryg(k,2)*vry)!+ghalf1
4392             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j))
4393      &      -3.0d0*uryg(k,2)*vrz)!+ghalf2
4394             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j))
4395      &      -3.0d0*urzg(k,2)*vry)!+ghalf3
4396             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j))
4397      &      -3.0d0*urzg(k,2)*vrz)!+ghalf4
4398 C Derivatives in DC(i+1)
4399             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j))
4400      &      -3.0d0*uryg(k,3)*vry)!+agg(k,1)
4401             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j))
4402      &      -3.0d0*uryg(k,3)*vrz)!+agg(k,2)
4403             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j))
4404      &      -3.0d0*urzg(k,3)*vry)!+agg(k,3)
4405             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j))
4406      &      -3.0d0*urzg(k,3)*vrz)!+agg(k,4)
4407 C Derivatives in DC(j)
4408             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i))
4409      &      -3.0d0*vryg(k,2)*ury)!+ghalf1
4410             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i))
4411      &      -3.0d0*vrzg(k,2)*ury)!+ghalf2
4412             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i))
4413      &      -3.0d0*vryg(k,2)*urz)!+ghalf3
4414             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i))
4415      &      -3.0d0*vrzg(k,2)*urz)!+ghalf4
4416 C Derivatives in DC(j+1) or DC(nres-1)
4417             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i))
4418      &      -3.0d0*vryg(k,3)*ury)
4419             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i))
4420      &      -3.0d0*vrzg(k,3)*ury)
4421             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i))
4422      &      -3.0d0*vryg(k,3)*urz)
4423             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i))
4424      &      -3.0d0*vrzg(k,3)*urz)
4425 cgrad            if (j.eq.nres-1 .and. i.lt.j-2) then
4426 cgrad              do l=1,4
4427 cgrad                aggj1(k,l)=aggj1(k,l)+agg(k,l)
4428 cgrad              enddo
4429 cgrad            endif
4430           enddo
4431           acipa(1,1)=a22
4432           acipa(1,2)=a23
4433           acipa(2,1)=a32
4434           acipa(2,2)=a33
4435           a22=-a22
4436           a23=-a23
4437           do l=1,2
4438             do k=1,3
4439               agg(k,l)=-agg(k,l)
4440               aggi(k,l)=-aggi(k,l)
4441               aggi1(k,l)=-aggi1(k,l)
4442               aggj(k,l)=-aggj(k,l)
4443               aggj1(k,l)=-aggj1(k,l)
4444             enddo
4445           enddo
4446           if (j.lt.nres-1) then
4447             a22=-a22
4448             a32=-a32
4449             do l=1,3,2
4450               do k=1,3
4451                 agg(k,l)=-agg(k,l)
4452                 aggi(k,l)=-aggi(k,l)
4453                 aggi1(k,l)=-aggi1(k,l)
4454                 aggj(k,l)=-aggj(k,l)
4455                 aggj1(k,l)=-aggj1(k,l)
4456               enddo
4457             enddo
4458           else
4459             a22=-a22
4460             a23=-a23
4461             a32=-a32
4462             a33=-a33
4463             do l=1,4
4464               do k=1,3
4465                 agg(k,l)=-agg(k,l)
4466                 aggi(k,l)=-aggi(k,l)
4467                 aggi1(k,l)=-aggi1(k,l)
4468                 aggj(k,l)=-aggj(k,l)
4469                 aggj1(k,l)=-aggj1(k,l)
4470               enddo
4471             enddo
4472           endif
4473           ENDIF ! WCORR
4474           IF (wel_loc.gt.0.0d0) THEN
4475 C Contribution to the local-electrostatic energy coming from the i-j pair
4476           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3)
4477      &     +a33*muij(4)
4478 #ifdef DEBUG
4479           write (iout,*) "muij",muij," a22",a22," a23",a23," a32",a32,
4480      &     " a33",a33
4481           write (iout,*) "ij",i,j," eel_loc_ij",eel_loc_ij,
4482      &     " wel_loc",wel_loc
4483 #endif
4484           if (shield_mode.eq.0) then
4485            fac_shield(i)=1.0
4486            fac_shield(j)=1.0
4487 C          else
4488 C           fac_shield(i)=0.4
4489 C           fac_shield(j)=0.6
4490           endif
4491           eel_loc_ij=eel_loc_ij
4492      &    *fac_shield(i)*fac_shield(j)
4493 c          if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
4494 c     &            'eelloc',i,j,eel_loc_ij
4495 C Now derivative over eel_loc
4496           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
4497      &  (shield_mode.gt.0)) then
4498 C          print *,i,j
4499
4500           do ilist=1,ishield_list(i)
4501            iresshield=shield_list(ilist,i)
4502            do k=1,3
4503            rlocshield=grad_shield_side(k,ilist,i)*eel_loc_ij
4504      &                                          /fac_shield(i)
4505 C     &      *2.0
4506            gshieldx_ll(k,iresshield)=gshieldx_ll(k,iresshield)+
4507      &              rlocshield
4508      & +grad_shield_loc(k,ilist,i)*eel_loc_ij/fac_shield(i)
4509             gshieldc_ll(k,iresshield-1)=gshieldc_ll(k,iresshield-1)
4510      &      +rlocshield
4511            enddo
4512           enddo
4513           do ilist=1,ishield_list(j)
4514            iresshield=shield_list(ilist,j)
4515            do k=1,3
4516            rlocshield=grad_shield_side(k,ilist,j)*eel_loc_ij
4517      &                                       /fac_shield(j)
4518 C     &     *2.0
4519            gshieldx_ll(k,iresshield)=gshieldx_ll(k,iresshield)+
4520      &              rlocshield
4521      & +grad_shield_loc(k,ilist,j)*eel_loc_ij/fac_shield(j)
4522            gshieldc_ll(k,iresshield-1)=gshieldc_ll(k,iresshield-1)
4523      &             +rlocshield
4524
4525            enddo
4526           enddo
4527
4528           do k=1,3
4529             gshieldc_ll(k,i)=gshieldc_ll(k,i)+
4530      &              grad_shield(k,i)*eel_loc_ij/fac_shield(i)
4531             gshieldc_ll(k,j)=gshieldc_ll(k,j)+
4532      &              grad_shield(k,j)*eel_loc_ij/fac_shield(j)
4533             gshieldc_ll(k,i-1)=gshieldc_ll(k,i-1)+
4534      &              grad_shield(k,i)*eel_loc_ij/fac_shield(i)
4535             gshieldc_ll(k,j-1)=gshieldc_ll(k,j-1)+
4536      &              grad_shield(k,j)*eel_loc_ij/fac_shield(j)
4537            enddo
4538            endif
4539
4540
4541 c          write (iout,*) 'i',i,' j',j,itype(i),itype(j),
4542 c     &                     ' eel_loc_ij',eel_loc_ij
4543 C          write(iout,*) 'muije=',i,j,muij(1),muij(2),muij(3),muij(4)
4544 C Calculate patrial derivative for theta angle
4545 #ifdef NEWCORR
4546          geel_loc_ij=(a22*gmuij1(1)
4547      &     +a23*gmuij1(2)
4548      &     +a32*gmuij1(3)
4549      &     +a33*gmuij1(4))
4550      &    *fac_shield(i)*fac_shield(j)
4551 c         write(iout,*) "derivative over thatai"
4552 c         write(iout,*) a22*gmuij1(1), a23*gmuij1(2) ,a32*gmuij1(3),
4553 c     &   a33*gmuij1(4)
4554          gloc(nphi+i,icg)=gloc(nphi+i,icg)+
4555      &      geel_loc_ij*wel_loc
4556 c         write(iout,*) "derivative over thatai-1"
4557 c         write(iout,*) a22*gmuij2(1), a23*gmuij2(2) ,a32*gmuij2(3),
4558 c     &   a33*gmuij2(4)
4559          geel_loc_ij=
4560      &     a22*gmuij2(1)
4561      &     +a23*gmuij2(2)
4562      &     +a32*gmuij2(3)
4563      &     +a33*gmuij2(4)
4564          gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
4565      &      geel_loc_ij*wel_loc
4566      &    *fac_shield(i)*fac_shield(j)
4567
4568 c  Derivative over j residue
4569          geel_loc_ji=a22*gmuji1(1)
4570      &     +a23*gmuji1(2)
4571      &     +a32*gmuji1(3)
4572      &     +a33*gmuji1(4)
4573 c         write(iout,*) "derivative over thataj"
4574 c         write(iout,*) a22*gmuji1(1), a23*gmuji1(2) ,a32*gmuji1(3),
4575 c     &   a33*gmuji1(4)
4576
4577         gloc(nphi+j,icg)=gloc(nphi+j,icg)+
4578      &      geel_loc_ji*wel_loc
4579      &    *fac_shield(i)*fac_shield(j)
4580
4581          geel_loc_ji=
4582      &     +a22*gmuji2(1)
4583      &     +a23*gmuji2(2)
4584      &     +a32*gmuji2(3)
4585      &     +a33*gmuji2(4)
4586 c         write(iout,*) "derivative over thataj-1"
4587 c         write(iout,*) a22*gmuji2(1), a23*gmuji2(2) ,a32*gmuji2(3),
4588 c     &   a33*gmuji2(4)
4589          gloc(nphi+j-1,icg)=gloc(nphi+j-1,icg)+
4590      &      geel_loc_ji*wel_loc
4591      &    *fac_shield(i)*fac_shield(j)
4592 #endif
4593 cd          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
4594
4595           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
4596      &            'eelloc',i,j,eel_loc_ij
4597 c           if (eel_loc_ij.ne.0)
4598 c     &      write (iout,'(a4,2i4,8f9.5)')'chuj',
4599 c     &     i,j,a22,muij(1),a23,muij(2),a32,muij(3),a33,muij(4)
4600
4601           eel_loc=eel_loc+eel_loc_ij
4602 C Partial derivatives in virtual-bond dihedral angles gamma
4603           if (i.gt.1)
4604      &    gel_loc_loc(i-1)=gel_loc_loc(i-1)+
4605      &            (a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j)
4606      &           +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j))
4607      &    *fac_shield(i)*fac_shield(j)
4608
4609           gel_loc_loc(j-1)=gel_loc_loc(j-1)+
4610      &           (a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j)
4611      &           +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j))
4612      &    *fac_shield(i)*fac_shield(j)
4613 C Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
4614           do l=1,3
4615             ggg(l)=(agg(l,1)*muij(1)+
4616      &          agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4))
4617      &    *fac_shield(i)*fac_shield(j)
4618             gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l)
4619             gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l)
4620 cgrad            ghalf=0.5d0*ggg(l)
4621 cgrad            gel_loc(l,i)=gel_loc(l,i)+ghalf
4622 cgrad            gel_loc(l,j)=gel_loc(l,j)+ghalf
4623           enddo
4624 cgrad          do k=i+1,j2
4625 cgrad            do l=1,3
4626 cgrad              gel_loc(l,k)=gel_loc(l,k)+ggg(l)
4627 cgrad            enddo
4628 cgrad          enddo
4629 C Remaining derivatives of eello
4630           do l=1,3
4631             gel_loc(l,i)=gel_loc(l,i)+(aggi(l,1)*muij(1)+
4632      &        aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4))
4633      &    *fac_shield(i)*fac_shield(j)
4634
4635             gel_loc(l,i+1)=gel_loc(l,i+1)+(aggi1(l,1)*muij(1)+
4636      &     aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4))
4637      &    *fac_shield(i)*fac_shield(j)
4638
4639             gel_loc(l,j)=gel_loc(l,j)+(aggj(l,1)*muij(1)+
4640      &       aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4))
4641      &    *fac_shield(i)*fac_shield(j)
4642
4643             gel_loc(l,j1)=gel_loc(l,j1)+(aggj1(l,1)*muij(1)+
4644      &     aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4))
4645      &    *fac_shield(i)*fac_shield(j)
4646
4647           enddo
4648           ENDIF
4649 C Change 12/26/95 to calculate four-body contributions to H-bonding energy
4650 c          if (j.gt.i+1 .and. num_conti.le.maxconts) then
4651           if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0
4652      &       .and. num_conti.le.maxconts) then
4653 c            write (iout,*) i,j," entered corr"
4654 C
4655 C Calculate the contact function. The ith column of the array JCONT will
4656 C contain the numbers of atoms that make contacts with the atom I (of numbers
4657 C greater than I). The arrays FACONT and GACONT will contain the values of
4658 C the contact function and its derivative.
4659 c           r0ij=1.02D0*rpp(iteli,itelj)
4660 c           r0ij=1.11D0*rpp(iteli,itelj)
4661             r0ij=2.20D0*rpp(iteli,itelj)
4662 c           r0ij=1.55D0*rpp(iteli,itelj)
4663             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
4664             if (fcont.gt.0.0D0) then
4665               num_conti=num_conti+1
4666               if (num_conti.gt.maxconts) then
4667                 write (iout,*) 'WARNING - max. # of contacts exceeded;',
4668      &                         ' will skip next contacts for this conf.'
4669               else
4670                 jcont_hb(num_conti,i)=j
4671 cd                write (iout,*) "i",i," j",j," num_conti",num_conti,
4672 cd     &           " jcont_hb",jcont_hb(num_conti,i)
4673                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.
4674      &          wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
4675 C 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
4676 C  terms.
4677                 d_cont(num_conti,i)=rij
4678 cd                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
4679 C     --- Electrostatic-interaction matrix ---
4680                 a_chuj(1,1,num_conti,i)=a22
4681                 a_chuj(1,2,num_conti,i)=a23
4682                 a_chuj(2,1,num_conti,i)=a32
4683                 a_chuj(2,2,num_conti,i)=a33
4684 C     --- Gradient of rij
4685                 do kkk=1,3
4686                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
4687                 enddo
4688                 kkll=0
4689                 do k=1,2
4690                   do l=1,2
4691                     kkll=kkll+1
4692                     do m=1,3
4693                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
4694                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
4695                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
4696                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
4697                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
4698                     enddo
4699                   enddo
4700                 enddo
4701                 ENDIF
4702                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
4703 C Calculate contact energies
4704                 cosa4=4.0D0*cosa
4705                 wij=cosa-3.0D0*cosb*cosg
4706                 cosbg1=cosb+cosg
4707                 cosbg2=cosb-cosg
4708 c               fac3=dsqrt(-ael6i)/r0ij**3
4709                 fac3=dsqrt(-ael6i)*r3ij
4710 c                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
4711                 ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
4712                 if (ees0tmp.gt.0) then
4713                   ees0pij=dsqrt(ees0tmp)
4714                 else
4715                   ees0pij=0
4716                 endif
4717 c                ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
4718                 ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
4719                 if (ees0tmp.gt.0) then
4720                   ees0mij=dsqrt(ees0tmp)
4721                 else
4722                   ees0mij=0
4723                 endif
4724 c               ees0mij=0.0D0
4725                 if (shield_mode.eq.0) then
4726                 fac_shield(i)=1.0d0
4727                 fac_shield(j)=1.0d0
4728                 else
4729                 ees0plist(num_conti,i)=j
4730 C                fac_shield(i)=0.4d0
4731 C                fac_shield(j)=0.6d0
4732                 endif
4733                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij)
4734      &          *fac_shield(i)*fac_shield(j)
4735                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij)
4736      &          *fac_shield(i)*fac_shield(j)
4737 C Diagnostics. Comment out or remove after debugging!
4738 c               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
4739 c               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
4740 c               ees0m(num_conti,i)=0.0D0
4741 C End diagnostics.
4742 c               write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
4743 c    & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
4744 C Angular derivatives of the contact function
4745                 ees0pij1=fac3/ees0pij
4746                 ees0mij1=fac3/ees0mij
4747                 fac3p=-3.0D0*fac3*rrmij
4748                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
4749                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
4750 c               ees0mij1=0.0D0
4751                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
4752                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
4753                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
4754                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
4755                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
4756                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
4757                 ecosap=ecosa1+ecosa2
4758                 ecosbp=ecosb1+ecosb2
4759                 ecosgp=ecosg1+ecosg2
4760                 ecosam=ecosa1-ecosa2
4761                 ecosbm=ecosb1-ecosb2
4762                 ecosgm=ecosg1-ecosg2
4763 C Diagnostics
4764 c               ecosap=ecosa1
4765 c               ecosbp=ecosb1
4766 c               ecosgp=ecosg1
4767 c               ecosam=0.0D0
4768 c               ecosbm=0.0D0
4769 c               ecosgm=0.0D0
4770 C End diagnostics
4771                 facont_hb(num_conti,i)=fcont
4772                 fprimcont=fprimcont/rij
4773 cd              facont_hb(num_conti,i)=1.0D0
4774 C Following line is for diagnostics.
4775 cd              fprimcont=0.0D0
4776                 do k=1,3
4777                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
4778                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
4779                 enddo
4780                 do k=1,3
4781                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
4782                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
4783                 enddo
4784                 gggp(1)=gggp(1)+ees0pijp*xj
4785                 gggp(2)=gggp(2)+ees0pijp*yj
4786                 gggp(3)=gggp(3)+ees0pijp*zj
4787                 gggm(1)=gggm(1)+ees0mijp*xj
4788                 gggm(2)=gggm(2)+ees0mijp*yj
4789                 gggm(3)=gggm(3)+ees0mijp*zj
4790 C Derivatives due to the contact function
4791                 gacont_hbr(1,num_conti,i)=fprimcont*xj
4792                 gacont_hbr(2,num_conti,i)=fprimcont*yj
4793                 gacont_hbr(3,num_conti,i)=fprimcont*zj
4794                 do k=1,3
4795 c
4796 c 10/24/08 cgrad and ! comments indicate the parts of the code removed
4797 c          following the change of gradient-summation algorithm.
4798 c
4799 cgrad                  ghalfp=0.5D0*gggp(k)
4800 cgrad                  ghalfm=0.5D0*gggm(k)
4801                   gacontp_hb1(k,num_conti,i)=!ghalfp
4802      &              +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i))
4803      &              + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
4804      &          *fac_shield(i)*fac_shield(j)
4805
4806                   gacontp_hb2(k,num_conti,i)=!ghalfp
4807      &              +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j))
4808      &              + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
4809      &          *fac_shield(i)*fac_shield(j)
4810
4811                   gacontp_hb3(k,num_conti,i)=gggp(k)
4812      &          *fac_shield(i)*fac_shield(j)
4813
4814                   gacontm_hb1(k,num_conti,i)=!ghalfm
4815      &              +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i))
4816      &              + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
4817      &          *fac_shield(i)*fac_shield(j)
4818
4819                   gacontm_hb2(k,num_conti,i)=!ghalfm
4820      &              +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j))
4821      &              + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
4822      &          *fac_shield(i)*fac_shield(j)
4823
4824                   gacontm_hb3(k,num_conti,i)=gggm(k)
4825      &          *fac_shield(i)*fac_shield(j)
4826
4827                 enddo
4828 C Diagnostics. Comment out or remove after debugging!
4829 cdiag           do k=1,3
4830 cdiag             gacontp_hb1(k,num_conti,i)=0.0D0
4831 cdiag             gacontp_hb2(k,num_conti,i)=0.0D0
4832 cdiag             gacontp_hb3(k,num_conti,i)=0.0D0
4833 cdiag             gacontm_hb1(k,num_conti,i)=0.0D0
4834 cdiag             gacontm_hb2(k,num_conti,i)=0.0D0
4835 cdiag             gacontm_hb3(k,num_conti,i)=0.0D0
4836 cdiag           enddo
4837               ENDIF ! wcorr
4838               endif  ! num_conti.le.maxconts
4839             endif  ! fcont.gt.0
4840           endif    ! j.gt.i+1
4841           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
4842             do k=1,4
4843               do l=1,3
4844                 ghalf=0.5d0*agg(l,k)
4845                 aggi(l,k)=aggi(l,k)+ghalf
4846                 aggi1(l,k)=aggi1(l,k)+agg(l,k)
4847                 aggj(l,k)=aggj(l,k)+ghalf
4848               enddo
4849             enddo
4850             if (j.eq.nres-1 .and. i.lt.j-2) then
4851               do k=1,4
4852                 do l=1,3
4853                   aggj1(l,k)=aggj1(l,k)+agg(l,k)
4854                 enddo
4855               enddo
4856             endif
4857           endif
4858 c          t_eelecij=t_eelecij+MPI_Wtime()-time00
4859       return
4860       end
4861 C-----------------------------------------------------------------------------
4862       subroutine eturn3(i,eello_turn3)
4863 C Third- and fourth-order contributions from turns
4864       implicit real*8 (a-h,o-z)
4865       include 'DIMENSIONS'
4866       include 'COMMON.IOUNITS'
4867       include 'COMMON.GEO'
4868       include 'COMMON.VAR'
4869       include 'COMMON.LOCAL'
4870       include 'COMMON.CHAIN'
4871       include 'COMMON.DERIV'
4872       include 'COMMON.INTERACT'
4873       include 'COMMON.CONTACTS'
4874       include 'COMMON.TORSION'
4875       include 'COMMON.VECTORS'
4876       include 'COMMON.FFIELD'
4877       include 'COMMON.CONTROL'
4878       include 'COMMON.SHIELD'
4879       dimension ggg(3)
4880       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
4881      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
4882      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2),gpizda1(2,2),
4883      &  gpizda2(2,2),auxgmat1(2,2),auxgmatt1(2,2),
4884      &  auxgmat2(2,2),auxgmatt2(2,2)
4885       double precision agg(3,4),aggi(3,4),aggi1(3,4),
4886      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
4887       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
4888      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
4889      &    num_conti,j1,j2
4890       j=i+2
4891 c      write (iout,*) "eturn3",i,j,j1,j2
4892       a_temp(1,1)=a22
4893       a_temp(1,2)=a23
4894       a_temp(2,1)=a32
4895       a_temp(2,2)=a33
4896 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4897 C
4898 C               Third-order contributions
4899 C
4900 C                 (i+2)o----(i+3)
4901 C                      | |
4902 C                      | |
4903 C                 (i+1)o----i
4904 C
4905 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4906 cd        call checkint_turn3(i,a_temp,eello_turn3_num)
4907         call matmat2(EUg(1,1,i+1),EUg(1,1,i+2),auxmat(1,1))
4908 c auxalary matices for theta gradient
4909 c auxalary matrix for i+1 and constant i+2
4910         call matmat2(gtEUg(1,1,i+1),EUg(1,1,i+2),auxgmat1(1,1))
4911 c auxalary matrix for i+2 and constant i+1
4912         call matmat2(EUg(1,1,i+1),gtEUg(1,1,i+2),auxgmat2(1,1))
4913         call transpose2(auxmat(1,1),auxmat1(1,1))
4914         call transpose2(auxgmat1(1,1),auxgmatt1(1,1))
4915         call transpose2(auxgmat2(1,1),auxgmatt2(1,1))
4916         call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4917         call matmat2(a_temp(1,1),auxgmatt1(1,1),gpizda1(1,1))
4918         call matmat2(a_temp(1,1),auxgmatt2(1,1),gpizda2(1,1))
4919         if (shield_mode.eq.0) then
4920         fac_shield(i)=1.0
4921         fac_shield(j)=1.0
4922 C        else
4923 C        fac_shield(i)=0.4
4924 C        fac_shield(j)=0.6
4925         endif
4926         eello_turn3=eello_turn3+0.5d0*(pizda(1,1)+pizda(2,2))
4927      &  *fac_shield(i)*fac_shield(j)
4928         eello_t3=0.5d0*(pizda(1,1)+pizda(2,2))
4929      &  *fac_shield(i)*fac_shield(j)
4930         if (energy_dec) write (iout,'(6heturn3,2i5,0pf7.3)') i,i+2,
4931      &    eello_t3
4932 C#ifdef NEWCORR
4933 C Derivatives in theta
4934         gloc(nphi+i,icg)=gloc(nphi+i,icg)
4935      &  +0.5d0*(gpizda1(1,1)+gpizda1(2,2))*wturn3
4936      &   *fac_shield(i)*fac_shield(j)
4937         gloc(nphi+i+1,icg)=gloc(nphi+i+1,icg)
4938      &  +0.5d0*(gpizda2(1,1)+gpizda2(2,2))*wturn3
4939      &   *fac_shield(i)*fac_shield(j)
4940 C#endif
4941
4942 C Derivatives in shield mode
4943           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
4944      &  (shield_mode.gt.0)) then
4945 C          print *,i,j
4946
4947           do ilist=1,ishield_list(i)
4948            iresshield=shield_list(ilist,i)
4949            do k=1,3
4950            rlocshield=grad_shield_side(k,ilist,i)*eello_t3/fac_shield(i)
4951 C     &      *2.0
4952            gshieldx_t3(k,iresshield)=gshieldx_t3(k,iresshield)+
4953      &              rlocshield
4954      & +grad_shield_loc(k,ilist,i)*eello_t3/fac_shield(i)
4955             gshieldc_t3(k,iresshield-1)=gshieldc_t3(k,iresshield-1)
4956      &      +rlocshield
4957            enddo
4958           enddo
4959           do ilist=1,ishield_list(j)
4960            iresshield=shield_list(ilist,j)
4961            do k=1,3
4962            rlocshield=grad_shield_side(k,ilist,j)*eello_t3/fac_shield(j)
4963 C     &     *2.0
4964            gshieldx_t3(k,iresshield)=gshieldx_t3(k,iresshield)+
4965      &              rlocshield
4966      & +grad_shield_loc(k,ilist,j)*eello_t3/fac_shield(j)
4967            gshieldc_t3(k,iresshield-1)=gshieldc_t3(k,iresshield-1)
4968      &             +rlocshield
4969
4970            enddo
4971           enddo
4972
4973           do k=1,3
4974             gshieldc_t3(k,i)=gshieldc_t3(k,i)+
4975      &              grad_shield(k,i)*eello_t3/fac_shield(i)
4976             gshieldc_t3(k,j)=gshieldc_t3(k,j)+
4977      &              grad_shield(k,j)*eello_t3/fac_shield(j)
4978             gshieldc_t3(k,i-1)=gshieldc_t3(k,i-1)+
4979      &              grad_shield(k,i)*eello_t3/fac_shield(i)
4980             gshieldc_t3(k,j-1)=gshieldc_t3(k,j-1)+
4981      &              grad_shield(k,j)*eello_t3/fac_shield(j)
4982            enddo
4983            endif
4984
4985 C        if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
4986 cd        write (2,*) 'i,',i,' j',j,'eello_turn3',
4987 cd     &    0.5d0*(pizda(1,1)+pizda(2,2)),
4988 cd     &    ' eello_turn3_num',4*eello_turn3_num
4989 C Derivatives in gamma(i)
4990         call matmat2(EUgder(1,1,i+1),EUg(1,1,i+2),auxmat2(1,1))
4991         call transpose2(auxmat2(1,1),auxmat3(1,1))
4992         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
4993         gel_loc_turn3(i)=gel_loc_turn3(i)+0.5d0*(pizda(1,1)+pizda(2,2))
4994      &   *fac_shield(i)*fac_shield(j)
4995 C Derivatives in gamma(i+1)
4996         call matmat2(EUg(1,1,i+1),EUgder(1,1,i+2),auxmat2(1,1))
4997         call transpose2(auxmat2(1,1),auxmat3(1,1))
4998         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
4999         gel_loc_turn3(i+1)=gel_loc_turn3(i+1)
5000      &    +0.5d0*(pizda(1,1)+pizda(2,2))
5001      &   *fac_shield(i)*fac_shield(j)
5002 C Cartesian derivatives
5003         do l=1,3
5004 c            ghalf1=0.5d0*agg(l,1)
5005 c            ghalf2=0.5d0*agg(l,2)
5006 c            ghalf3=0.5d0*agg(l,3)
5007 c            ghalf4=0.5d0*agg(l,4)
5008           a_temp(1,1)=aggi(l,1)!+ghalf1
5009           a_temp(1,2)=aggi(l,2)!+ghalf2
5010           a_temp(2,1)=aggi(l,3)!+ghalf3
5011           a_temp(2,2)=aggi(l,4)!+ghalf4
5012           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
5013           gcorr3_turn(l,i)=gcorr3_turn(l,i)
5014      &      +0.5d0*(pizda(1,1)+pizda(2,2))
5015      &   *fac_shield(i)*fac_shield(j)
5016
5017           a_temp(1,1)=aggi1(l,1)!+agg(l,1)
5018           a_temp(1,2)=aggi1(l,2)!+agg(l,2)
5019           a_temp(2,1)=aggi1(l,3)!+agg(l,3)
5020           a_temp(2,2)=aggi1(l,4)!+agg(l,4)
5021           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
5022           gcorr3_turn(l,i+1)=gcorr3_turn(l,i+1)
5023      &      +0.5d0*(pizda(1,1)+pizda(2,2))
5024      &   *fac_shield(i)*fac_shield(j)
5025           a_temp(1,1)=aggj(l,1)!+ghalf1
5026           a_temp(1,2)=aggj(l,2)!+ghalf2
5027           a_temp(2,1)=aggj(l,3)!+ghalf3
5028           a_temp(2,2)=aggj(l,4)!+ghalf4
5029           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
5030           gcorr3_turn(l,j)=gcorr3_turn(l,j)
5031      &      +0.5d0*(pizda(1,1)+pizda(2,2))
5032      &   *fac_shield(i)*fac_shield(j)
5033           a_temp(1,1)=aggj1(l,1)
5034           a_temp(1,2)=aggj1(l,2)
5035           a_temp(2,1)=aggj1(l,3)
5036           a_temp(2,2)=aggj1(l,4)
5037           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
5038           gcorr3_turn(l,j1)=gcorr3_turn(l,j1)
5039      &      +0.5d0*(pizda(1,1)+pizda(2,2))
5040      &   *fac_shield(i)*fac_shield(j)
5041         enddo
5042       return
5043       end
5044 C-------------------------------------------------------------------------------
5045       subroutine eturn4(i,eello_turn4)
5046 C Third- and fourth-order contributions from turns
5047       implicit real*8 (a-h,o-z)
5048       include 'DIMENSIONS'
5049       include 'COMMON.IOUNITS'
5050       include 'COMMON.GEO'
5051       include 'COMMON.VAR'
5052       include 'COMMON.LOCAL'
5053       include 'COMMON.CHAIN'
5054       include 'COMMON.DERIV'
5055       include 'COMMON.INTERACT'
5056       include 'COMMON.CONTACTS'
5057       include 'COMMON.TORSION'
5058       include 'COMMON.VECTORS'
5059       include 'COMMON.FFIELD'
5060       include 'COMMON.CONTROL'
5061       include 'COMMON.SHIELD'
5062       dimension ggg(3)
5063       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
5064      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
5065      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2),auxgvec(2),
5066      &  auxgEvec1(2),auxgEvec2(2),auxgEvec3(2),
5067      &  gte1t(2,2),gte2t(2,2),gte3t(2,2),
5068      &  gte1a(2,2),gtae3(2,2),gtae3e2(2,2), ae3gte2(2,2),
5069      &  gtEpizda1(2,2),gtEpizda2(2,2),gtEpizda3(2,2)
5070       double precision agg(3,4),aggi(3,4),aggi1(3,4),
5071      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
5072       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
5073      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
5074      &    num_conti,j1,j2
5075       j=i+3
5076 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
5077 C
5078 C               Fourth-order contributions
5079 C
5080 C                 (i+3)o----(i+4)
5081 C                     /  |
5082 C               (i+2)o   |
5083 C                     \  |
5084 C                 (i+1)o----i
5085 C
5086 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
5087 cd        call checkint_turn4(i,a_temp,eello_turn4_num)
5088 c        write (iout,*) "eturn4 i",i," j",j," j1",j1," j2",j2
5089 c        write(iout,*)"WCHODZE W PROGRAM"
5090         a_temp(1,1)=a22
5091         a_temp(1,2)=a23
5092         a_temp(2,1)=a32
5093         a_temp(2,2)=a33
5094         iti1=itype2loc(itype(i+1))
5095         iti2=itype2loc(itype(i+2))
5096         iti3=itype2loc(itype(i+3))
5097 c        write(iout,*) "iti1",iti1," iti2",iti2," iti3",iti3
5098         call transpose2(EUg(1,1,i+1),e1t(1,1))
5099         call transpose2(Eug(1,1,i+2),e2t(1,1))
5100         call transpose2(Eug(1,1,i+3),e3t(1,1))
5101 C Ematrix derivative in theta
5102         call transpose2(gtEUg(1,1,i+1),gte1t(1,1))
5103         call transpose2(gtEug(1,1,i+2),gte2t(1,1))
5104         call transpose2(gtEug(1,1,i+3),gte3t(1,1))
5105         call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5106 c       eta1 in derivative theta
5107         call matmat2(gte1t(1,1),a_temp(1,1),gte1a(1,1))
5108         call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5109 c       auxgvec is derivative of Ub2 so i+3 theta
5110         call matvec2(e1a(1,1),gUb2(1,i+3),auxgvec(1))
5111 c       auxalary matrix of E i+1
5112         call matvec2(gte1a(1,1),Ub2(1,i+3),auxgEvec1(1))
5113 c        s1=0.0
5114 c        gs1=0.0
5115         s1=scalar2(b1(1,i+2),auxvec(1))
5116 c derivative of theta i+2 with constant i+3
5117         gs23=scalar2(gtb1(1,i+2),auxvec(1))
5118 c derivative of theta i+2 with constant i+2
5119         gs32=scalar2(b1(1,i+2),auxgvec(1))
5120 c derivative of E matix in theta of i+1
5121         gsE13=scalar2(b1(1,i+2),auxgEvec1(1))
5122
5123         call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5124 c       ea31 in derivative theta
5125         call matmat2(a_temp(1,1),gte3t(1,1),gtae3(1,1))
5126         call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5127 c auxilary matrix auxgvec of Ub2 with constant E matirx
5128         call matvec2(ae3(1,1),gUb2(1,i+2),auxgvec(1))
5129 c auxilary matrix auxgEvec1 of E matix with Ub2 constant
5130         call matvec2(gtae3(1,1),Ub2(1,i+2),auxgEvec3(1))
5131
5132 c        s2=0.0
5133 c        gs2=0.0
5134         s2=scalar2(b1(1,i+1),auxvec(1))
5135 c derivative of theta i+1 with constant i+3
5136         gs13=scalar2(gtb1(1,i+1),auxvec(1))
5137 c derivative of theta i+2 with constant i+1
5138         gs21=scalar2(b1(1,i+1),auxgvec(1))
5139 c derivative of theta i+3 with constant i+1
5140         gsE31=scalar2(b1(1,i+1),auxgEvec3(1))
5141 c        write(iout,*) gs1,gs2,'i=',i,auxgvec(1),gUb2(1,i+2),gtb1(1,i+2),
5142 c     &  gtb1(1,i+1)
5143         call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5144 c two derivatives over diffetent matrices
5145 c gtae3e2 is derivative over i+3
5146         call matmat2(gtae3(1,1),e2t(1,1),gtae3e2(1,1))
5147 c ae3gte2 is derivative over i+2
5148         call matmat2(ae3(1,1),gte2t(1,1),ae3gte2(1,1))
5149         call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5150 c three possible derivative over theta E matices
5151 c i+1
5152         call matmat2(ae3e2(1,1),gte1t(1,1),gtEpizda1(1,1))
5153 c i+2
5154         call matmat2(ae3gte2(1,1),e1t(1,1),gtEpizda2(1,1))
5155 c i+3
5156         call matmat2(gtae3e2(1,1),e1t(1,1),gtEpizda3(1,1))
5157         s3=0.5d0*(pizda(1,1)+pizda(2,2))
5158
5159         gsEE1=0.5d0*(gtEpizda1(1,1)+gtEpizda1(2,2))
5160         gsEE2=0.5d0*(gtEpizda2(1,1)+gtEpizda2(2,2))
5161         gsEE3=0.5d0*(gtEpizda3(1,1)+gtEpizda3(2,2))
5162         if (shield_mode.eq.0) then
5163         fac_shield(i)=1.0
5164         fac_shield(j)=1.0
5165 C        else
5166 C        fac_shield(i)=0.6
5167 C        fac_shield(j)=0.4
5168         endif
5169         eello_turn4=eello_turn4-(s1+s2+s3)
5170      &  *fac_shield(i)*fac_shield(j)
5171         eello_t4=-(s1+s2+s3)
5172      &  *fac_shield(i)*fac_shield(j)
5173 c             write(iout,*)'chujOWO', auxvec(1),b1(1,iti2)
5174         if (energy_dec) write (iout,'(a6,2i5,0pf7.3,3f7.3)')
5175      &      'eturn4',i,j,-(s1+s2+s3),s1,s2,s3
5176 C Now derivative over shield:
5177           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
5178      &  (shield_mode.gt.0)) then
5179 C          print *,i,j
5180
5181           do ilist=1,ishield_list(i)
5182            iresshield=shield_list(ilist,i)
5183            do k=1,3
5184            rlocshield=grad_shield_side(k,ilist,i)*eello_t4/fac_shield(i)
5185 C     &      *2.0
5186            gshieldx_t4(k,iresshield)=gshieldx_t4(k,iresshield)+
5187      &              rlocshield
5188      & +grad_shield_loc(k,ilist,i)*eello_t4/fac_shield(i)
5189             gshieldc_t4(k,iresshield-1)=gshieldc_t4(k,iresshield-1)
5190      &      +rlocshield
5191            enddo
5192           enddo
5193           do ilist=1,ishield_list(j)
5194            iresshield=shield_list(ilist,j)
5195            do k=1,3
5196            rlocshield=grad_shield_side(k,ilist,j)*eello_t4/fac_shield(j)
5197 C     &     *2.0
5198            gshieldx_t4(k,iresshield)=gshieldx_t4(k,iresshield)+
5199      &              rlocshield
5200      & +grad_shield_loc(k,ilist,j)*eello_t4/fac_shield(j)
5201            gshieldc_t4(k,iresshield-1)=gshieldc_t4(k,iresshield-1)
5202      &             +rlocshield
5203
5204            enddo
5205           enddo
5206
5207           do k=1,3
5208             gshieldc_t4(k,i)=gshieldc_t4(k,i)+
5209      &              grad_shield(k,i)*eello_t4/fac_shield(i)
5210             gshieldc_t4(k,j)=gshieldc_t4(k,j)+
5211      &              grad_shield(k,j)*eello_t4/fac_shield(j)
5212             gshieldc_t4(k,i-1)=gshieldc_t4(k,i-1)+
5213      &              grad_shield(k,i)*eello_t4/fac_shield(i)
5214             gshieldc_t4(k,j-1)=gshieldc_t4(k,j-1)+
5215      &              grad_shield(k,j)*eello_t4/fac_shield(j)
5216            enddo
5217            endif
5218
5219
5220
5221
5222
5223
5224 cd        write (2,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
5225 cd     &    ' eello_turn4_num',8*eello_turn4_num
5226 #ifdef NEWCORR
5227         gloc(nphi+i,icg)=gloc(nphi+i,icg)
5228      &                  -(gs13+gsE13+gsEE1)*wturn4
5229      &  *fac_shield(i)*fac_shield(j)
5230         gloc(nphi+i+1,icg)= gloc(nphi+i+1,icg)
5231      &                    -(gs23+gs21+gsEE2)*wturn4
5232      &  *fac_shield(i)*fac_shield(j)
5233
5234         gloc(nphi+i+2,icg)= gloc(nphi+i+2,icg)
5235      &                    -(gs32+gsE31+gsEE3)*wturn4
5236      &  *fac_shield(i)*fac_shield(j)
5237
5238 c         gloc(nphi+i+1,icg)=gloc(nphi+i+1,icg)-
5239 c     &   gs2
5240 #endif
5241         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
5242      &      'eturn4',i,j,-(s1+s2+s3)
5243 c        write (iout,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
5244 c     &    ' eello_turn4_num',8*eello_turn4_num
5245 C Derivatives in gamma(i)
5246         call transpose2(EUgder(1,1,i+1),e1tder(1,1))
5247         call matmat2(e1tder(1,1),a_temp(1,1),auxmat(1,1))
5248         call matvec2(auxmat(1,1),Ub2(1,i+3),auxvec(1))
5249         s1=scalar2(b1(1,i+2),auxvec(1))
5250         call matmat2(ae3e2(1,1),e1tder(1,1),pizda(1,1))
5251         s3=0.5d0*(pizda(1,1)+pizda(2,2))
5252         gel_loc_turn4(i)=gel_loc_turn4(i)-(s1+s3)
5253      &  *fac_shield(i)*fac_shield(j)
5254 C Derivatives in gamma(i+1)
5255         call transpose2(EUgder(1,1,i+2),e2tder(1,1))
5256         call matvec2(ae3(1,1),Ub2der(1,i+2),auxvec(1))
5257         s2=scalar2(b1(1,i+1),auxvec(1))
5258         call matmat2(ae3(1,1),e2tder(1,1),auxmat(1,1))
5259         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
5260         s3=0.5d0*(pizda(1,1)+pizda(2,2))
5261         gel_loc_turn4(i+1)=gel_loc_turn4(i+1)-(s2+s3)
5262      &  *fac_shield(i)*fac_shield(j)
5263 C Derivatives in gamma(i+2)
5264         call transpose2(EUgder(1,1,i+3),e3tder(1,1))
5265         call matvec2(e1a(1,1),Ub2der(1,i+3),auxvec(1))
5266         s1=scalar2(b1(1,i+2),auxvec(1))
5267         call matmat2(a_temp(1,1),e3tder(1,1),auxmat(1,1))
5268         call matvec2(auxmat(1,1),Ub2(1,i+2),auxvec(1))
5269         s2=scalar2(b1(1,i+1),auxvec(1))
5270         call matmat2(auxmat(1,1),e2t(1,1),auxmat3(1,1))
5271         call matmat2(auxmat3(1,1),e1t(1,1),pizda(1,1))
5272         s3=0.5d0*(pizda(1,1)+pizda(2,2))
5273         gel_loc_turn4(i+2)=gel_loc_turn4(i+2)-(s1+s2+s3)
5274      &  *fac_shield(i)*fac_shield(j)
5275 C Cartesian derivatives
5276 C Derivatives of this turn contributions in DC(i+2)
5277         if (j.lt.nres-1) then
5278           do l=1,3
5279             a_temp(1,1)=agg(l,1)
5280             a_temp(1,2)=agg(l,2)
5281             a_temp(2,1)=agg(l,3)
5282             a_temp(2,2)=agg(l,4)
5283             call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5284             call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5285             s1=scalar2(b1(1,i+2),auxvec(1))
5286             call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5287             call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5288             s2=scalar2(b1(1,i+1),auxvec(1))
5289             call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5290             call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5291             s3=0.5d0*(pizda(1,1)+pizda(2,2))
5292             ggg(l)=-(s1+s2+s3)
5293             gcorr4_turn(l,i+2)=gcorr4_turn(l,i+2)-(s1+s2+s3)
5294      &  *fac_shield(i)*fac_shield(j)
5295           enddo
5296         endif
5297 C Remaining derivatives of this turn contribution
5298         do l=1,3
5299           a_temp(1,1)=aggi(l,1)
5300           a_temp(1,2)=aggi(l,2)
5301           a_temp(2,1)=aggi(l,3)
5302           a_temp(2,2)=aggi(l,4)
5303           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5304           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5305           s1=scalar2(b1(1,i+2),auxvec(1))
5306           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5307           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5308           s2=scalar2(b1(1,i+1),auxvec(1))
5309           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5310           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5311           s3=0.5d0*(pizda(1,1)+pizda(2,2))
5312           gcorr4_turn(l,i)=gcorr4_turn(l,i)-(s1+s2+s3)
5313      &  *fac_shield(i)*fac_shield(j)
5314           a_temp(1,1)=aggi1(l,1)
5315           a_temp(1,2)=aggi1(l,2)
5316           a_temp(2,1)=aggi1(l,3)
5317           a_temp(2,2)=aggi1(l,4)
5318           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5319           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5320           s1=scalar2(b1(1,i+2),auxvec(1))
5321           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5322           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5323           s2=scalar2(b1(1,i+1),auxvec(1))
5324           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5325           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5326           s3=0.5d0*(pizda(1,1)+pizda(2,2))
5327           gcorr4_turn(l,i+1)=gcorr4_turn(l,i+1)-(s1+s2+s3)
5328      &  *fac_shield(i)*fac_shield(j)
5329           a_temp(1,1)=aggj(l,1)
5330           a_temp(1,2)=aggj(l,2)
5331           a_temp(2,1)=aggj(l,3)
5332           a_temp(2,2)=aggj(l,4)
5333           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5334           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5335           s1=scalar2(b1(1,i+2),auxvec(1))
5336           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5337           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5338           s2=scalar2(b1(1,i+1),auxvec(1))
5339           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5340           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5341           s3=0.5d0*(pizda(1,1)+pizda(2,2))
5342           gcorr4_turn(l,j)=gcorr4_turn(l,j)-(s1+s2+s3)
5343      &  *fac_shield(i)*fac_shield(j)
5344           a_temp(1,1)=aggj1(l,1)
5345           a_temp(1,2)=aggj1(l,2)
5346           a_temp(2,1)=aggj1(l,3)
5347           a_temp(2,2)=aggj1(l,4)
5348           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5349           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5350           s1=scalar2(b1(1,i+2),auxvec(1))
5351           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5352           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5353           s2=scalar2(b1(1,i+1),auxvec(1))
5354           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5355           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5356           s3=0.5d0*(pizda(1,1)+pizda(2,2))
5357 c          write (iout,*) "s1",s1," s2",s2," s3",s3," s1+s2+s3",s1+s2+s3
5358           gcorr4_turn(l,j1)=gcorr4_turn(l,j1)-(s1+s2+s3)
5359      &  *fac_shield(i)*fac_shield(j)
5360         enddo
5361       return
5362       end
5363 C-----------------------------------------------------------------------------
5364       subroutine vecpr(u,v,w)
5365       implicit real*8(a-h,o-z)
5366       dimension u(3),v(3),w(3)
5367       w(1)=u(2)*v(3)-u(3)*v(2)
5368       w(2)=-u(1)*v(3)+u(3)*v(1)
5369       w(3)=u(1)*v(2)-u(2)*v(1)
5370       return
5371       end
5372 C-----------------------------------------------------------------------------
5373       subroutine unormderiv(u,ugrad,unorm,ungrad)
5374 C This subroutine computes the derivatives of a normalized vector u, given
5375 C the derivatives computed without normalization conditions, ugrad. Returns
5376 C ungrad.
5377       implicit none
5378       double precision u(3),ugrad(3,3),unorm,ungrad(3,3)
5379       double precision vec(3)
5380       double precision scalar
5381       integer i,j
5382 c      write (2,*) 'ugrad',ugrad
5383 c      write (2,*) 'u',u
5384       do i=1,3
5385         vec(i)=scalar(ugrad(1,i),u(1))
5386       enddo
5387 c      write (2,*) 'vec',vec
5388       do i=1,3
5389         do j=1,3
5390           ungrad(j,i)=(ugrad(j,i)-u(j)*vec(i))*unorm
5391         enddo
5392       enddo
5393 c      write (2,*) 'ungrad',ungrad
5394       return
5395       end
5396 C-----------------------------------------------------------------------------
5397       subroutine escp_soft_sphere(evdw2,evdw2_14)
5398 C
5399 C This subroutine calculates the excluded-volume interaction energy between
5400 C peptide-group centers and side chains and its gradient in virtual-bond and
5401 C side-chain vectors.
5402 C
5403       implicit real*8 (a-h,o-z)
5404       include 'DIMENSIONS'
5405       include 'COMMON.GEO'
5406       include 'COMMON.VAR'
5407       include 'COMMON.LOCAL'
5408       include 'COMMON.CHAIN'
5409       include 'COMMON.DERIV'
5410       include 'COMMON.INTERACT'
5411       include 'COMMON.FFIELD'
5412       include 'COMMON.IOUNITS'
5413       include 'COMMON.CONTROL'
5414       dimension ggg(3)
5415       integer xshift,yshift,zshift
5416       evdw2=0.0D0
5417       evdw2_14=0.0d0
5418       r0_scp=4.5d0
5419 cd    print '(a)','Enter ESCP'
5420 cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
5421 C      do xshift=-1,1
5422 C      do yshift=-1,1
5423 C      do zshift=-1,1
5424       do i=iatscp_s,iatscp_e
5425         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
5426         iteli=itel(i)
5427         xi=0.5D0*(c(1,i)+c(1,i+1))
5428         yi=0.5D0*(c(2,i)+c(2,i+1))
5429         zi=0.5D0*(c(3,i)+c(3,i+1))
5430 C Return atom into box, boxxsize is size of box in x dimension
5431 c  134   continue
5432 c        if (xi.gt.((xshift+0.5d0)*boxxsize)) xi=xi-boxxsize
5433 c        if (xi.lt.((xshift-0.5d0)*boxxsize)) xi=xi+boxxsize
5434 C Condition for being inside the proper box
5435 c        if ((xi.gt.((xshift+0.5d0)*boxxsize)).or.
5436 c     &       (xi.lt.((xshift-0.5d0)*boxxsize))) then
5437 c        go to 134
5438 c        endif
5439 c  135   continue
5440 c        if (yi.gt.((yshift+0.5d0)*boxysize)) yi=yi-boxysize
5441 c        if (yi.lt.((yshift-0.5d0)*boxysize)) yi=yi+boxysize
5442 C Condition for being inside the proper box
5443 c        if ((yi.gt.((yshift+0.5d0)*boxysize)).or.
5444 c     &       (yi.lt.((yshift-0.5d0)*boxysize))) then
5445 c        go to 135
5446 c c       endif
5447 c  136   continue
5448 c        if (zi.gt.((zshift+0.5d0)*boxzsize)) zi=zi-boxzsize
5449 c        if (zi.lt.((zshift-0.5d0)*boxzsize)) zi=zi+boxzsize
5450 cC Condition for being inside the proper box
5451 c        if ((zi.gt.((zshift+0.5d0)*boxzsize)).or.
5452 c     &       (zi.lt.((zshift-0.5d0)*boxzsize))) then
5453 c        go to 136
5454 c        endif
5455           xi=mod(xi,boxxsize)
5456           if (xi.lt.0) xi=xi+boxxsize
5457           yi=mod(yi,boxysize)
5458           if (yi.lt.0) yi=yi+boxysize
5459           zi=mod(zi,boxzsize)
5460           if (zi.lt.0) zi=zi+boxzsize
5461 C          xi=xi+xshift*boxxsize
5462 C          yi=yi+yshift*boxysize
5463 C          zi=zi+zshift*boxzsize
5464         do iint=1,nscp_gr(i)
5465
5466         do j=iscpstart(i,iint),iscpend(i,iint)
5467           if (itype(j).eq.ntyp1) cycle
5468           itypj=iabs(itype(j))
5469 C Uncomment following three lines for SC-p interactions
5470 c         xj=c(1,nres+j)-xi
5471 c         yj=c(2,nres+j)-yi
5472 c         zj=c(3,nres+j)-zi
5473 C Uncomment following three lines for Ca-p interactions
5474           xj=c(1,j)
5475           yj=c(2,j)
5476           zj=c(3,j)
5477 c  174   continue
5478 c        if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
5479 c        if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
5480 C Condition for being inside the proper box
5481 c        if ((xj.gt.((0.5d0)*boxxsize)).or.
5482 c     &       (xj.lt.((-0.5d0)*boxxsize))) then
5483 c        go to 174
5484 c        endif
5485 c  175   continue
5486 c        if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
5487 c        if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
5488 cC Condition for being inside the proper box
5489 c        if ((yj.gt.((0.5d0)*boxysize)).or.
5490 c     &       (yj.lt.((-0.5d0)*boxysize))) then
5491 c        go to 175
5492 c        endif
5493 c  176   continue
5494 c        if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
5495 c        if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
5496 C Condition for being inside the proper box
5497 c        if ((zj.gt.((0.5d0)*boxzsize)).or.
5498 c     &       (zj.lt.((-0.5d0)*boxzsize))) then
5499 c        go to 176
5500           xj=mod(xj,boxxsize)
5501           if (xj.lt.0) xj=xj+boxxsize
5502           yj=mod(yj,boxysize)
5503           if (yj.lt.0) yj=yj+boxysize
5504           zj=mod(zj,boxzsize)
5505           if (zj.lt.0) zj=zj+boxzsize
5506       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
5507       xj_safe=xj
5508       yj_safe=yj
5509       zj_safe=zj
5510       subchap=0
5511       do xshift=-1,1
5512       do yshift=-1,1
5513       do zshift=-1,1
5514           xj=xj_safe+xshift*boxxsize
5515           yj=yj_safe+yshift*boxysize
5516           zj=zj_safe+zshift*boxzsize
5517           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
5518           if(dist_temp.lt.dist_init) then
5519             dist_init=dist_temp
5520             xj_temp=xj
5521             yj_temp=yj
5522             zj_temp=zj
5523             subchap=1
5524           endif
5525        enddo
5526        enddo
5527        enddo
5528        if (subchap.eq.1) then
5529           xj=xj_temp-xi
5530           yj=yj_temp-yi
5531           zj=zj_temp-zi
5532        else
5533           xj=xj_safe-xi
5534           yj=yj_safe-yi
5535           zj=zj_safe-zi
5536        endif
5537 c c       endif
5538 C          xj=xj-xi
5539 C          yj=yj-yi
5540 C          zj=zj-zi
5541           rij=xj*xj+yj*yj+zj*zj
5542
5543           r0ij=r0_scp
5544           r0ijsq=r0ij*r0ij
5545           if (rij.lt.r0ijsq) then
5546             evdwij=0.25d0*(rij-r0ijsq)**2
5547             fac=rij-r0ijsq
5548           else
5549             evdwij=0.0d0
5550             fac=0.0d0
5551           endif
5552           evdw2=evdw2+evdwij
5553 C
5554 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
5555 C
5556           ggg(1)=xj*fac
5557           ggg(2)=yj*fac
5558           ggg(3)=zj*fac
5559 cgrad          if (j.lt.i) then
5560 cd          write (iout,*) 'j<i'
5561 C Uncomment following three lines for SC-p interactions
5562 c           do k=1,3
5563 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
5564 c           enddo
5565 cgrad          else
5566 cd          write (iout,*) 'j>i'
5567 cgrad            do k=1,3
5568 cgrad              ggg(k)=-ggg(k)
5569 C Uncomment following line for SC-p interactions
5570 c             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
5571 cgrad            enddo
5572 cgrad          endif
5573 cgrad          do k=1,3
5574 cgrad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
5575 cgrad          enddo
5576 cgrad          kstart=min0(i+1,j)
5577 cgrad          kend=max0(i-1,j-1)
5578 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
5579 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
5580 cgrad          do k=kstart,kend
5581 cgrad            do l=1,3
5582 cgrad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
5583 cgrad            enddo
5584 cgrad          enddo
5585           do k=1,3
5586             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
5587             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
5588           enddo
5589         enddo
5590
5591         enddo ! iint
5592       enddo ! i
5593 C      enddo !zshift
5594 C      enddo !yshift
5595 C      enddo !xshift
5596       return
5597       end
5598 C-----------------------------------------------------------------------------
5599       subroutine escp(evdw2,evdw2_14)
5600 C
5601 C This subroutine calculates the excluded-volume interaction energy between
5602 C peptide-group centers and side chains and its gradient in virtual-bond and
5603 C side-chain vectors.
5604 C
5605       implicit real*8 (a-h,o-z)
5606       include 'DIMENSIONS'
5607       include 'COMMON.GEO'
5608       include 'COMMON.VAR'
5609       include 'COMMON.LOCAL'
5610       include 'COMMON.CHAIN'
5611       include 'COMMON.DERIV'
5612       include 'COMMON.INTERACT'
5613       include 'COMMON.FFIELD'
5614       include 'COMMON.IOUNITS'
5615       include 'COMMON.CONTROL'
5616       include 'COMMON.SPLITELE'
5617       integer xshift,yshift,zshift
5618       dimension ggg(3)
5619       evdw2=0.0D0
5620       evdw2_14=0.0d0
5621 c        print *,boxxsize,boxysize,boxzsize,'wymiary pudla'
5622 cd    print '(a)','Enter ESCP'
5623 cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
5624 C      do xshift=-1,1
5625 C      do yshift=-1,1
5626 C      do zshift=-1,1
5627       if (energy_dec) write (iout,*) "escp:",r_cut,rlamb
5628       do i=iatscp_s,iatscp_e
5629         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
5630         iteli=itel(i)
5631         xi=0.5D0*(c(1,i)+c(1,i+1))
5632         yi=0.5D0*(c(2,i)+c(2,i+1))
5633         zi=0.5D0*(c(3,i)+c(3,i+1))
5634           xi=mod(xi,boxxsize)
5635           if (xi.lt.0) xi=xi+boxxsize
5636           yi=mod(yi,boxysize)
5637           if (yi.lt.0) yi=yi+boxysize
5638           zi=mod(zi,boxzsize)
5639           if (zi.lt.0) zi=zi+boxzsize
5640 c          xi=xi+xshift*boxxsize
5641 c          yi=yi+yshift*boxysize
5642 c          zi=zi+zshift*boxzsize
5643 c        print *,xi,yi,zi,'polozenie i'
5644 C Return atom into box, boxxsize is size of box in x dimension
5645 c  134   continue
5646 c        if (xi.gt.((xshift+0.5d0)*boxxsize)) xi=xi-boxxsize
5647 c        if (xi.lt.((xshift-0.5d0)*boxxsize)) xi=xi+boxxsize
5648 C Condition for being inside the proper box
5649 c        if ((xi.gt.((xshift+0.5d0)*boxxsize)).or.
5650 c     &       (xi.lt.((xshift-0.5d0)*boxxsize))) then
5651 c        go to 134
5652 c        endif
5653 c  135   continue
5654 c          print *,xi,boxxsize,"pierwszy"
5655
5656 c        if (yi.gt.((yshift+0.5d0)*boxysize)) yi=yi-boxysize
5657 c        if (yi.lt.((yshift-0.5d0)*boxysize)) yi=yi+boxysize
5658 C Condition for being inside the proper box
5659 c        if ((yi.gt.((yshift+0.5d0)*boxysize)).or.
5660 c     &       (yi.lt.((yshift-0.5d0)*boxysize))) then
5661 c        go to 135
5662 c        endif
5663 c  136   continue
5664 c        if (zi.gt.((zshift+0.5d0)*boxzsize)) zi=zi-boxzsize
5665 c        if (zi.lt.((zshift-0.5d0)*boxzsize)) zi=zi+boxzsize
5666 C Condition for being inside the proper box
5667 c        if ((zi.gt.((zshift+0.5d0)*boxzsize)).or.
5668 c     &       (zi.lt.((zshift-0.5d0)*boxzsize))) then
5669 c        go to 136
5670 c        endif
5671         do iint=1,nscp_gr(i)
5672
5673         do j=iscpstart(i,iint),iscpend(i,iint)
5674           itypj=iabs(itype(j))
5675           if (itypj.eq.ntyp1) cycle
5676 C Uncomment following three lines for SC-p interactions
5677 c         xj=c(1,nres+j)-xi
5678 c         yj=c(2,nres+j)-yi
5679 c         zj=c(3,nres+j)-zi
5680 C Uncomment following three lines for Ca-p interactions
5681           xj=c(1,j)
5682           yj=c(2,j)
5683           zj=c(3,j)
5684           xj=mod(xj,boxxsize)
5685           if (xj.lt.0) xj=xj+boxxsize
5686           yj=mod(yj,boxysize)
5687           if (yj.lt.0) yj=yj+boxysize
5688           zj=mod(zj,boxzsize)
5689           if (zj.lt.0) zj=zj+boxzsize
5690 c  174   continue
5691 c        if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
5692 c        if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
5693 C Condition for being inside the proper box
5694 c        if ((xj.gt.((0.5d0)*boxxsize)).or.
5695 c     &       (xj.lt.((-0.5d0)*boxxsize))) then
5696 c        go to 174
5697 c        endif
5698 c  175   continue
5699 c        if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
5700 c        if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
5701 cC Condition for being inside the proper box
5702 c        if ((yj.gt.((0.5d0)*boxysize)).or.
5703 c     &       (yj.lt.((-0.5d0)*boxysize))) then
5704 c        go to 175
5705 c        endif
5706 c  176   continue
5707 c        if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
5708 c        if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
5709 C Condition for being inside the proper box
5710 c        if ((zj.gt.((0.5d0)*boxzsize)).or.
5711 c     &       (zj.lt.((-0.5d0)*boxzsize))) then
5712 c        go to 176
5713 c        endif
5714 CHERE IS THE CALCULATION WHICH MIRROR IMAGE IS THE CLOSEST ONE
5715       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
5716       xj_safe=xj
5717       yj_safe=yj
5718       zj_safe=zj
5719       subchap=0
5720       do xshift=-1,1
5721       do yshift=-1,1
5722       do zshift=-1,1
5723           xj=xj_safe+xshift*boxxsize
5724           yj=yj_safe+yshift*boxysize
5725           zj=zj_safe+zshift*boxzsize
5726           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
5727           if(dist_temp.lt.dist_init) then
5728             dist_init=dist_temp
5729             xj_temp=xj
5730             yj_temp=yj
5731             zj_temp=zj
5732             subchap=1
5733           endif
5734        enddo
5735        enddo
5736        enddo
5737        if (subchap.eq.1) then
5738           xj=xj_temp-xi
5739           yj=yj_temp-yi
5740           zj=zj_temp-zi
5741        else
5742           xj=xj_safe-xi
5743           yj=yj_safe-yi
5744           zj=zj_safe-zi
5745        endif
5746 c          print *,xj,yj,zj,'polozenie j'
5747           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
5748 c          print *,rrij
5749           sss=sscale(1.0d0/(dsqrt(rrij)))
5750 c          print *,r_cut,1.0d0/dsqrt(rrij),sss,'tu patrz'
5751 c          if (sss.eq.0) print *,'czasem jest OK'
5752           if (sss.le.0.0d0) cycle
5753           sssgrad=sscagrad(1.0d0/(dsqrt(rrij)))
5754           fac=rrij**expon2
5755           e1=fac*fac*aad(itypj,iteli)
5756           e2=fac*bad(itypj,iteli)
5757           if (iabs(j-i) .le. 2) then
5758             e1=scal14*e1
5759             e2=scal14*e2
5760             evdw2_14=evdw2_14+(e1+e2)*sss
5761           endif
5762           evdwij=e1+e2
5763           evdw2=evdw2+evdwij*sss
5764           if (energy_dec) write (iout,'(a6,2i5,0pf7.3,2i3,3e11.3)')
5765      &        'evdw2',i,j,evdwij,iteli,itypj,fac,aad(itypj,iteli),
5766      &       bad(itypj,iteli)
5767 C
5768 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
5769 C
5770           fac=-(evdwij+e1)*rrij*sss
5771           fac=fac+(evdwij)*sssgrad*dsqrt(rrij)/expon
5772           ggg(1)=xj*fac
5773           ggg(2)=yj*fac
5774           ggg(3)=zj*fac
5775 cgrad          if (j.lt.i) then
5776 cd          write (iout,*) 'j<i'
5777 C Uncomment following three lines for SC-p interactions
5778 c           do k=1,3
5779 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
5780 c           enddo
5781 cgrad          else
5782 cd          write (iout,*) 'j>i'
5783 cgrad            do k=1,3
5784 cgrad              ggg(k)=-ggg(k)
5785 C Uncomment following line for SC-p interactions
5786 ccgrad             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
5787 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
5788 cgrad            enddo
5789 cgrad          endif
5790 cgrad          do k=1,3
5791 cgrad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
5792 cgrad          enddo
5793 cgrad          kstart=min0(i+1,j)
5794 cgrad          kend=max0(i-1,j-1)
5795 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
5796 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
5797 cgrad          do k=kstart,kend
5798 cgrad            do l=1,3
5799 cgrad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
5800 cgrad            enddo
5801 cgrad          enddo
5802           do k=1,3
5803             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
5804             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
5805           enddo
5806 c        endif !endif for sscale cutoff
5807         enddo ! j
5808
5809         enddo ! iint
5810       enddo ! i
5811 c      enddo !zshift
5812 c      enddo !yshift
5813 c      enddo !xshift
5814       do i=1,nct
5815         do j=1,3
5816           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
5817           gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
5818           gradx_scp(j,i)=expon*gradx_scp(j,i)
5819         enddo
5820       enddo
5821 C******************************************************************************
5822 C
5823 C                              N O T E !!!
5824 C
5825 C To save time the factor EXPON has been extracted from ALL components
5826 C of GVDWC and GRADX. Remember to multiply them by this factor before further
5827 C use!
5828 C
5829 C******************************************************************************
5830       return
5831       end
5832 C--------------------------------------------------------------------------
5833       subroutine edis(ehpb)
5834 C
5835 C Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors.
5836 C
5837       implicit real*8 (a-h,o-z)
5838       include 'DIMENSIONS'
5839       include 'COMMON.SBRIDGE'
5840       include 'COMMON.CHAIN'
5841       include 'COMMON.DERIV'
5842       include 'COMMON.VAR'
5843       include 'COMMON.INTERACT'
5844       include 'COMMON.IOUNITS'
5845       include 'COMMON.CONTROL'
5846       dimension ggg(3),ggg_peak(3,1000)
5847       ehpb=0.0D0
5848       do i=1,3
5849        ggg(i)=0.0d0
5850       enddo
5851 c 8/21/18 AL: added explicit restraints on reference coords
5852 c      write (iout,*) "restr_on_coord",restr_on_coord
5853       if (restr_on_coord) then
5854
5855       do i=nnt,nct
5856         ecoor=0.0d0
5857         if (itype(i).eq.ntyp1) cycle
5858         do j=1,3
5859           ecoor=ecoor+(c(j,i)-cref(j,i))**2
5860           ghpbc(j,i)=ghpbc(j,i)+bfac(i)*(c(j,i)-cref(j,i))
5861         enddo
5862         if (itype(i).ne.10) then
5863           do j=1,3
5864             ecoor=ecoor+(c(j,i+nres)-cref(j,i+nres))**2
5865             ghpbx(j,i)=ghpbx(j,i)+bfac(i)*(c(j,i+nres)-cref(j,i+nres))
5866           enddo
5867         endif
5868         if (energy_dec) write (iout,*)
5869      &     "i",i," bfac",bfac(i)," ecoor",ecoor
5870         ehpb=ehpb+0.5d0*bfac(i)*ecoor
5871       enddo
5872
5873       endif
5874 C      write (iout,*) ,"link_end",link_end,constr_dist
5875 cd      write(iout,*)'edis: nhpb=',nhpb,' fbr=',fbr
5876 c      write(iout,*)'link_start=',link_start,' link_end=',link_end,
5877 c     &  " constr_dist",constr_dist," link_start_peak",link_start_peak,
5878 c     &  " link_end_peak",link_end_peak
5879       if (link_end.eq.0.and.link_end_peak.eq.0) return
5880       do i=link_start_peak,link_end_peak
5881         ehpb_peak=0.0d0
5882 c        print *,"i",i," link_end_peak",link_end_peak," ipeak",
5883 c     &   ipeak(1,i),ipeak(2,i)
5884         do ip=ipeak(1,i),ipeak(2,i)
5885           ii=ihpb_peak(ip)
5886           jj=jhpb_peak(ip)
5887           dd=dist(ii,jj)
5888           iip=ip-ipeak(1,i)+1
5889 C iii and jjj point to the residues for which the distance is assigned.
5890 c          if (ii.gt.nres) then
5891 c            iii=ii-nres
5892 c            jjj=jj-nres
5893 c          else
5894 c            iii=ii
5895 c            jjj=jj
5896 c          endif
5897           if (ii.gt.nres) then
5898             iii=ii-nres
5899           else
5900             iii=ii
5901           endif
5902           if (jj.gt.nres) then
5903             jjj=jj-nres
5904           else
5905             jjj=jj
5906           endif
5907           aux=rlornmr1(dd,dhpb_peak(ip),dhpb1_peak(ip),forcon_peak(ip))
5908           aux=dexp(-scal_peak*aux)
5909           ehpb_peak=ehpb_peak+aux
5910           fac=rlornmr1prim(dd,dhpb_peak(ip),dhpb1_peak(ip),
5911      &      forcon_peak(ip))*aux/dd
5912           do j=1,3
5913             ggg_peak(j,iip)=fac*(c(j,jj)-c(j,ii))
5914           enddo
5915           if (energy_dec) write (iout,'(a6,3i5,6f10.3,i5)')
5916      &      "edisL",i,ii,jj,dd,dhpb_peak(ip),dhpb1_peak(ip),
5917      &      forcon_peak(ip),fordepth_peak(ip),ehpb_peak
5918         enddo
5919 c        write (iout,*) "ehpb_peak",ehpb_peak," scal_peak",scal_peak
5920         ehpb=ehpb-fordepth_peak(ipeak(1,i))*dlog(ehpb_peak)/scal_peak
5921         do ip=ipeak(1,i),ipeak(2,i)
5922           iip=ip-ipeak(1,i)+1
5923           do j=1,3
5924             ggg(j)=ggg_peak(j,iip)/ehpb_peak
5925           enddo
5926           ii=ihpb_peak(ip)
5927           jj=jhpb_peak(ip)
5928 C iii and jjj point to the residues for which the distance is assigned.
5929 c          if (ii.gt.nres) then
5930 c            iii=ii-nres
5931 c            jjj=jj-nres
5932 c          else
5933 c            iii=ii
5934 c            jjj=jj
5935 c          endif
5936           if (ii.gt.nres) then
5937             iii=ii-nres
5938           else
5939             iii=ii
5940           endif
5941           if (jj.gt.nres) then
5942             jjj=jj-nres
5943           else
5944             jjj=jj
5945           endif
5946           if (iii.lt.ii) then
5947             do j=1,3
5948               ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
5949             enddo
5950           endif
5951           if (jjj.lt.jj) then
5952             do j=1,3
5953               ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
5954             enddo
5955           endif
5956           do k=1,3
5957             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
5958             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
5959           enddo
5960         enddo
5961       enddo
5962       do i=link_start,link_end
5963 C If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a
5964 C CA-CA distance used in regularization of structure.
5965         ii=ihpb(i)
5966         jj=jhpb(i)
5967 C iii and jjj point to the residues for which the distance is assigned.
5968         if (ii.gt.nres) then
5969           iii=ii-nres
5970         else
5971           iii=ii
5972         endif
5973         if (jj.gt.nres) then
5974           jjj=jj-nres
5975         else
5976           jjj=jj
5977         endif
5978 c        write (iout,*) "i",i," ii",ii," iii",iii," jj",jj," jjj",jjj,
5979 c     &    dhpb(i),dhpb1(i),forcon(i)
5980 C 24/11/03 AL: SS bridges handled separately because of introducing a specific
5981 C    distance and angle dependent SS bond potential.
5982 C        if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and.
5983 C     & iabs(itype(jjj)).eq.1) then
5984 cmc        if (ii.gt.nres .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then
5985 C 18/07/06 MC: Use the convention that the first nss pairs are SS bonds
5986         if (.not.dyn_ss .and. i.le.nss) then
5987 C 15/02/13 CC dynamic SSbond - additional check
5988           if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and.
5989      &        iabs(itype(jjj)).eq.1) then
5990            call ssbond_ene(iii,jjj,eij)
5991            ehpb=ehpb+2*eij
5992          endif
5993 cd          write (iout,*) "eij",eij
5994 cd   &   ' waga=',waga,' fac=',fac
5995 !        else if (ii.gt.nres .and. jj.gt.nres) then
5996         else
5997 C Calculate the distance between the two points and its difference from the
5998 C target distance.
5999           dd=dist(ii,jj)
6000           if (irestr_type(i).eq.11) then
6001             ehpb=ehpb+fordepth(i)!**4.0d0
6002      &           *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i))
6003             fac=fordepth(i)!**4.0d0
6004      &           *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd
6005             if (energy_dec) write (iout,'(a6,2i5,6f10.3,i5)')
6006      &        "edisL",ii,jj,dd,dhpb(i),dhpb1(i),forcon(i),fordepth(i),
6007      &        ehpb,irestr_type(i)
6008           else if (irestr_type(i).eq.10) then
6009 c AL 6//19/2018 cross-link restraints
6010             xdis = 0.5d0*(dd/forcon(i))**2
6011             expdis = dexp(-xdis)
6012 c            aux=(dhpb(i)+dhpb1(i)*xdis)*expdis+fordepth(i)
6013             aux=(dhpb(i)+dhpb1(i)*xdis*xdis)*expdis+fordepth(i)
6014 c            write (iout,*)"HERE: xdis",xdis," expdis",expdis," aux",aux,
6015 c     &          " wboltzd",wboltzd
6016             ehpb=ehpb-wboltzd*xlscore(i)*dlog(aux)
6017 c            fac=-wboltzd*(dhpb1(i)*(1.0d0-xdis)-dhpb(i))
6018             fac=-wboltzd*xlscore(i)*(dhpb1(i)*(2.0d0-xdis)*xdis-dhpb(i))
6019      &           *expdis/(aux*forcon(i)**2)
6020             if (energy_dec) write(iout,'(a6,2i5,6f10.3,i5)')
6021      &        "edisX",ii,jj,dd,dhpb(i),dhpb1(i),forcon(i),fordepth(i),
6022      &        -wboltzd*xlscore(i)*dlog(aux),irestr_type(i)
6023           else if (irestr_type(i).eq.2) then
6024 c Quartic restraints
6025             ehpb=ehpb+forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
6026             if (energy_dec) write(iout,'(a6,2i5,5f10.3,i5)')
6027      &      "edisQ",ii,jj,dd,dhpb(i),dhpb1(i),forcon(i),
6028      &      forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i)),irestr_type(i)
6029             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
6030           else
6031 c Quadratic restraints
6032             rdis=dd-dhpb(i)
6033 C Get the force constant corresponding to this distance.
6034             waga=forcon(i)
6035 C Calculate the contribution to energy.
6036             ehpb=ehpb+0.5d0*waga*rdis*rdis
6037             if (energy_dec) write(iout,'(a6,2i5,5f10.3,i5)')
6038      &      "edisS",ii,jj,dd,dhpb(i),dhpb1(i),forcon(i),
6039      &       0.5d0*waga*rdis*rdis,irestr_type(i)
6040 C
6041 C Evaluate gradient.
6042 C
6043             fac=waga*rdis/dd
6044           endif
6045 c Calculate Cartesian gradient
6046           do j=1,3
6047             ggg(j)=fac*(c(j,jj)-c(j,ii))
6048           enddo
6049 cd      print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
6050 C If this is a SC-SC distance, we need to calculate the contributions to the
6051 C Cartesian gradient in the SC vectors (ghpbx).
6052           if (iii.lt.ii) then
6053             do j=1,3
6054               ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
6055             enddo
6056           endif
6057           if (jjj.lt.jj) then
6058             do j=1,3
6059               ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
6060             enddo
6061           endif
6062           do k=1,3
6063             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
6064             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
6065           enddo
6066         endif
6067       enddo
6068       return
6069       end
6070 C--------------------------------------------------------------------------
6071       subroutine ssbond_ene(i,j,eij)
6072 C
6073 C Calculate the distance and angle dependent SS-bond potential energy
6074 C using a free-energy function derived based on RHF/6-31G** ab initio
6075 C calculations of diethyl disulfide.
6076 C
6077 C A. Liwo and U. Kozlowska, 11/24/03
6078 C
6079       implicit real*8 (a-h,o-z)
6080       include 'DIMENSIONS'
6081       include 'COMMON.SBRIDGE'
6082       include 'COMMON.CHAIN'
6083       include 'COMMON.DERIV'
6084       include 'COMMON.LOCAL'
6085       include 'COMMON.INTERACT'
6086       include 'COMMON.VAR'
6087       include 'COMMON.IOUNITS'
6088       double precision erij(3),dcosom1(3),dcosom2(3),gg(3)
6089       itypi=iabs(itype(i))
6090       xi=c(1,nres+i)
6091       yi=c(2,nres+i)
6092       zi=c(3,nres+i)
6093       dxi=dc_norm(1,nres+i)
6094       dyi=dc_norm(2,nres+i)
6095       dzi=dc_norm(3,nres+i)
6096 c      dsci_inv=dsc_inv(itypi)
6097       dsci_inv=vbld_inv(nres+i)
6098       itypj=iabs(itype(j))
6099 c      dscj_inv=dsc_inv(itypj)
6100       dscj_inv=vbld_inv(nres+j)
6101       xj=c(1,nres+j)-xi
6102       yj=c(2,nres+j)-yi
6103       zj=c(3,nres+j)-zi
6104       dxj=dc_norm(1,nres+j)
6105       dyj=dc_norm(2,nres+j)
6106       dzj=dc_norm(3,nres+j)
6107       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
6108       rij=dsqrt(rrij)
6109       erij(1)=xj*rij
6110       erij(2)=yj*rij
6111       erij(3)=zj*rij
6112       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
6113       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
6114       om12=dxi*dxj+dyi*dyj+dzi*dzj
6115       do k=1,3
6116         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
6117         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
6118       enddo
6119       rij=1.0d0/rij
6120       deltad=rij-d0cm
6121       deltat1=1.0d0-om1
6122       deltat2=1.0d0+om2
6123       deltat12=om2-om1+2.0d0
6124       cosphi=om12-om1*om2
6125       eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2)
6126      &  +akct*deltad*deltat12
6127      &  +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi+ebr
6128 c      write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth,
6129 c     &  " akct",akct," deltad",deltad," deltat",deltat1,deltat2,
6130 c     &  " deltat12",deltat12," eij",eij
6131       ed=2*akcm*deltad+akct*deltat12
6132       pom1=akct*deltad
6133       pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
6134       eom1=-2*akth*deltat1-pom1-om2*pom2
6135       eom2= 2*akth*deltat2+pom1-om1*pom2
6136       eom12=pom2
6137       do k=1,3
6138         ggk=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
6139         ghpbx(k,i)=ghpbx(k,i)-ggk
6140      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
6141      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
6142         ghpbx(k,j)=ghpbx(k,j)+ggk
6143      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
6144      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
6145         ghpbc(k,i)=ghpbc(k,i)-ggk
6146         ghpbc(k,j)=ghpbc(k,j)+ggk
6147       enddo
6148 C
6149 C Calculate the components of the gradient in DC and X
6150 C
6151 cgrad      do k=i,j-1
6152 cgrad        do l=1,3
6153 cgrad          ghpbc(l,k)=ghpbc(l,k)+gg(l)
6154 cgrad        enddo
6155 cgrad      enddo
6156       return
6157       end
6158 C--------------------------------------------------------------------------
6159       subroutine ebond(estr)
6160 c
6161 c Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
6162 c
6163       implicit real*8 (a-h,o-z)
6164       include 'DIMENSIONS'
6165       include 'COMMON.LOCAL'
6166       include 'COMMON.GEO'
6167       include 'COMMON.INTERACT'
6168       include 'COMMON.DERIV'
6169       include 'COMMON.VAR'
6170       include 'COMMON.CHAIN'
6171       include 'COMMON.IOUNITS'
6172       include 'COMMON.NAMES'
6173       include 'COMMON.FFIELD'
6174       include 'COMMON.CONTROL'
6175       include 'COMMON.SETUP'
6176       double precision u(3),ud(3)
6177       estr=0.0d0
6178       estr1=0.0d0
6179       do i=ibondp_start,ibondp_end
6180         if (itype(i-1).eq.ntyp1 .and. itype(i).eq.ntyp1) cycle
6181 c          estr1=estr1+gnmr1(vbld(i),-1.0d0,distchainmax)
6182 c          do j=1,3
6183 c          gradb(j,i-1)=gnmr1prim(vbld(i),-1.0d0,distchainmax)
6184 c     &      *dc(j,i-1)/vbld(i)
6185 c          enddo
6186 c          if (energy_dec) write(iout,*)
6187 c     &       "estr1",i,gnmr1(vbld(i),-1.0d0,distchainmax)
6188 c        else
6189 C       Checking if it involves dummy (NH3+ or COO-) group
6190          if (itype(i-1).eq.ntyp1 .or. itype(i).eq.ntyp1) then
6191 C YES   vbldpDUM is the equlibrium length of spring for Dummy atom
6192         diff = vbld(i)-vbldpDUM
6193         if (energy_dec) write(iout,*) "dum_bond",i,diff
6194          else
6195 C NO    vbldp0 is the equlibrium lenght of spring for peptide group
6196         diff = vbld(i)-vbldp0
6197          endif
6198         if (energy_dec)    write (iout,'(a7,i5,4f7.3)')
6199      &     "estr bb",i,vbld(i),vbldp0,diff,AKP*diff*diff
6200         estr=estr+diff*diff
6201         do j=1,3
6202           gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)
6203         enddo
6204 c        write (iout,'(i5,3f10.5)') i,(gradb(j,i-1),j=1,3)
6205 c        endif
6206       enddo
6207
6208       estr=0.5d0*AKP*estr+estr1
6209 c
6210 c 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included
6211 c
6212       do i=ibond_start,ibond_end
6213         iti=iabs(itype(i))
6214         if (iti.ne.10 .and. iti.ne.ntyp1) then
6215           nbi=nbondterm(iti)
6216           if (nbi.eq.1) then
6217             diff=vbld(i+nres)-vbldsc0(1,iti)
6218             if (energy_dec)  write (iout,*)
6219      &      "estr sc",i,iti,vbld(i+nres),vbldsc0(1,iti),diff,
6220      &      AKSC(1,iti),AKSC(1,iti)*diff*diff
6221             estr=estr+0.5d0*AKSC(1,iti)*diff*diff
6222             do j=1,3
6223               gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
6224             enddo
6225           else
6226             do j=1,nbi
6227               diff=vbld(i+nres)-vbldsc0(j,iti)
6228               ud(j)=aksc(j,iti)*diff
6229               u(j)=abond0(j,iti)+0.5d0*ud(j)*diff
6230             enddo
6231             uprod=u(1)
6232             do j=2,nbi
6233               uprod=uprod*u(j)
6234             enddo
6235             usum=0.0d0
6236             usumsqder=0.0d0
6237             do j=1,nbi
6238               uprod1=1.0d0
6239               uprod2=1.0d0
6240               do k=1,nbi
6241                 if (k.ne.j) then
6242                   uprod1=uprod1*u(k)
6243                   uprod2=uprod2*u(k)*u(k)
6244                 endif
6245               enddo
6246               usum=usum+uprod1
6247               usumsqder=usumsqder+ud(j)*uprod2
6248             enddo
6249             estr=estr+uprod/usum
6250             do j=1,3
6251              gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
6252             enddo
6253           endif
6254         endif
6255       enddo
6256       return
6257       end
6258 #ifdef CRYST_THETA
6259 C--------------------------------------------------------------------------
6260       subroutine ebend(etheta)
6261 C
6262 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
6263 C angles gamma and its derivatives in consecutive thetas and gammas.
6264 C
6265       implicit real*8 (a-h,o-z)
6266       include 'DIMENSIONS'
6267       include 'COMMON.LOCAL'
6268       include 'COMMON.GEO'
6269       include 'COMMON.INTERACT'
6270       include 'COMMON.DERIV'
6271       include 'COMMON.VAR'
6272       include 'COMMON.CHAIN'
6273       include 'COMMON.IOUNITS'
6274       include 'COMMON.NAMES'
6275       include 'COMMON.FFIELD'
6276       include 'COMMON.CONTROL'
6277       include 'COMMON.TORCNSTR'
6278       common /calcthet/ term1,term2,termm,diffak,ratak,
6279      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
6280      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
6281       double precision y(2),z(2)
6282       delta=0.02d0*pi
6283 c      time11=dexp(-2*time)
6284 c      time12=1.0d0
6285       etheta=0.0D0
6286 c     write (*,'(a,i2)') 'EBEND ICG=',icg
6287       do i=ithet_start,ithet_end
6288         if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
6289      &  .or.itype(i).eq.ntyp1) cycle
6290 C Zero the energy function and its derivative at 0 or pi.
6291         call splinthet(theta(i),0.5d0*delta,ss,ssd)
6292         it=itype(i-1)
6293         ichir1=isign(1,itype(i-2))
6294         ichir2=isign(1,itype(i))
6295          if (itype(i-2).eq.10) ichir1=isign(1,itype(i-1))
6296          if (itype(i).eq.10) ichir2=isign(1,itype(i-1))
6297          if (itype(i-1).eq.10) then
6298           itype1=isign(10,itype(i-2))
6299           ichir11=isign(1,itype(i-2))
6300           ichir12=isign(1,itype(i-2))
6301           itype2=isign(10,itype(i))
6302           ichir21=isign(1,itype(i))
6303           ichir22=isign(1,itype(i))
6304          endif
6305
6306         if (i.gt.3 .and. itype(i-3).ne.ntyp1) then
6307 #ifdef OSF
6308           phii=phi(i)
6309           if (phii.ne.phii) phii=150.0
6310 #else
6311           phii=phi(i)
6312 #endif
6313           y(1)=dcos(phii)
6314           y(2)=dsin(phii)
6315         else
6316           y(1)=0.0D0
6317           y(2)=0.0D0
6318         endif
6319         if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
6320 #ifdef OSF
6321           phii1=phi(i+1)
6322           if (phii1.ne.phii1) phii1=150.0
6323           phii1=pinorm(phii1)
6324           z(1)=cos(phii1)
6325 #else
6326           phii1=phi(i+1)
6327 #endif
6328           z(1)=dcos(phii1)
6329           z(2)=dsin(phii1)
6330         else
6331           z(1)=0.0D0
6332           z(2)=0.0D0
6333         endif
6334 C Calculate the "mean" value of theta from the part of the distribution
6335 C dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2).
6336 C In following comments this theta will be referred to as t_c.
6337         thet_pred_mean=0.0d0
6338         do k=1,2
6339             athetk=athet(k,it,ichir1,ichir2)
6340             bthetk=bthet(k,it,ichir1,ichir2)
6341           if (it.eq.10) then
6342              athetk=athet(k,itype1,ichir11,ichir12)
6343              bthetk=bthet(k,itype2,ichir21,ichir22)
6344           endif
6345          thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k)
6346 c         write(iout,*) 'chuj tu', y(k),z(k)
6347         enddo
6348         dthett=thet_pred_mean*ssd
6349         thet_pred_mean=thet_pred_mean*ss+a0thet(it)
6350 C Derivatives of the "mean" values in gamma1 and gamma2.
6351         dthetg1=(-athet(1,it,ichir1,ichir2)*y(2)
6352      &+athet(2,it,ichir1,ichir2)*y(1))*ss
6353          dthetg2=(-bthet(1,it,ichir1,ichir2)*z(2)
6354      &          +bthet(2,it,ichir1,ichir2)*z(1))*ss
6355          if (it.eq.10) then
6356       dthetg1=(-athet(1,itype1,ichir11,ichir12)*y(2)
6357      &+athet(2,itype1,ichir11,ichir12)*y(1))*ss
6358         dthetg2=(-bthet(1,itype2,ichir21,ichir22)*z(2)
6359      &         +bthet(2,itype2,ichir21,ichir22)*z(1))*ss
6360          endif
6361         if (theta(i).gt.pi-delta) then
6362           call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,
6363      &         E_tc0)
6364           call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0)
6365           call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
6366           call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,
6367      &        E_theta)
6368           call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,
6369      &        E_tc)
6370         else if (theta(i).lt.delta) then
6371           call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0)
6372           call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
6373           call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,
6374      &        E_theta)
6375           call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0)
6376           call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,
6377      &        E_tc)
6378         else
6379           call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,
6380      &        E_theta,E_tc)
6381         endif
6382         etheta=etheta+ethetai
6383         if (energy_dec) write (iout,'(a6,i5,0pf7.3,f7.3,i5)')
6384      &      'ebend',i,ethetai,theta(i),itype(i)
6385         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1
6386         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2
6387         gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)+gloc(nphi+i-2,icg)
6388       enddo
6389
6390 C Ufff.... We've done all this!!!
6391       return
6392       end
6393 C---------------------------------------------------------------------------
6394       subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,
6395      &     E_tc)
6396       implicit real*8 (a-h,o-z)
6397       include 'DIMENSIONS'
6398       include 'COMMON.LOCAL'
6399       include 'COMMON.IOUNITS'
6400       common /calcthet/ term1,term2,termm,diffak,ratak,
6401      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
6402      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
6403 C Calculate the contributions to both Gaussian lobes.
6404 C 6/6/97 - Deform the Gaussians using the factor of 1/(1+time)
6405 C The "polynomial part" of the "standard deviation" of this part of
6406 C the distributioni.
6407 ccc        write (iout,*) thetai,thet_pred_mean
6408         sig=polthet(3,it)
6409         do j=2,0,-1
6410           sig=sig*thet_pred_mean+polthet(j,it)
6411         enddo
6412 C Derivative of the "interior part" of the "standard deviation of the"
6413 C gamma-dependent Gaussian lobe in t_c.
6414         sigtc=3*polthet(3,it)
6415         do j=2,1,-1
6416           sigtc=sigtc*thet_pred_mean+j*polthet(j,it)
6417         enddo
6418         sigtc=sig*sigtc
6419 C Set the parameters of both Gaussian lobes of the distribution.
6420 C "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc)
6421         fac=sig*sig+sigc0(it)
6422         sigcsq=fac+fac
6423         sigc=1.0D0/sigcsq
6424 C Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c
6425         sigsqtc=-4.0D0*sigcsq*sigtc
6426 c       print *,i,sig,sigtc,sigsqtc
6427 C Following variable (sigtc) is d[sigma(t_c)]/dt_c
6428         sigtc=-sigtc/(fac*fac)
6429 C Following variable is sigma(t_c)**(-2)
6430         sigcsq=sigcsq*sigcsq
6431         sig0i=sig0(it)
6432         sig0inv=1.0D0/sig0i**2
6433         delthec=thetai-thet_pred_mean
6434         delthe0=thetai-theta0i
6435         term1=-0.5D0*sigcsq*delthec*delthec
6436         term2=-0.5D0*sig0inv*delthe0*delthe0
6437 C        write (iout,*)'term1',term1,term2,sigcsq,delthec,sig0inv,delthe0
6438 C Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and
6439 C NaNs in taking the logarithm. We extract the largest exponent which is added
6440 C to the energy (this being the log of the distribution) at the end of energy
6441 C term evaluation for this virtual-bond angle.
6442         if (term1.gt.term2) then
6443           termm=term1
6444           term2=dexp(term2-termm)
6445           term1=1.0d0
6446         else
6447           termm=term2
6448           term1=dexp(term1-termm)
6449           term2=1.0d0
6450         endif
6451 C The ratio between the gamma-independent and gamma-dependent lobes of
6452 C the distribution is a Gaussian function of thet_pred_mean too.
6453         diffak=gthet(2,it)-thet_pred_mean
6454         ratak=diffak/gthet(3,it)**2
6455         ak=dexp(gthet(1,it)-0.5D0*diffak*ratak)
6456 C Let's differentiate it in thet_pred_mean NOW.
6457         aktc=ak*ratak
6458 C Now put together the distribution terms to make complete distribution.
6459         termexp=term1+ak*term2
6460         termpre=sigc+ak*sig0i
6461 C Contribution of the bending energy from this theta is just the -log of
6462 C the sum of the contributions from the two lobes and the pre-exponential
6463 C factor. Simple enough, isn't it?
6464         ethetai=(-dlog(termexp)-termm+dlog(termpre))
6465 C       write (iout,*) 'termexp',termexp,termm,termpre,i
6466 C NOW the derivatives!!!
6467 C 6/6/97 Take into account the deformation.
6468         E_theta=(delthec*sigcsq*term1
6469      &       +ak*delthe0*sig0inv*term2)/termexp
6470         E_tc=((sigtc+aktc*sig0i)/termpre
6471      &      -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+
6472      &       aktc*term2)/termexp)
6473       return
6474       end
6475 c-----------------------------------------------------------------------------
6476       subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)
6477       implicit real*8 (a-h,o-z)
6478       include 'DIMENSIONS'
6479       include 'COMMON.LOCAL'
6480       include 'COMMON.IOUNITS'
6481       common /calcthet/ term1,term2,termm,diffak,ratak,
6482      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
6483      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
6484       delthec=thetai-thet_pred_mean
6485       delthe0=thetai-theta0i
6486 C "Thank you" to MAPLE (probably spared one day of hand-differentiation).
6487       t3 = thetai-thet_pred_mean
6488       t6 = t3**2
6489       t9 = term1
6490       t12 = t3*sigcsq
6491       t14 = t12+t6*sigsqtc
6492       t16 = 1.0d0
6493       t21 = thetai-theta0i
6494       t23 = t21**2
6495       t26 = term2
6496       t27 = t21*t26
6497       t32 = termexp
6498       t40 = t32**2
6499       E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9
6500      & -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40
6501      & *(-t12*t9-ak*sig0inv*t27)
6502       return
6503       end
6504 #else
6505 C--------------------------------------------------------------------------
6506       subroutine ebend(etheta)
6507 C
6508 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
6509 C angles gamma and its derivatives in consecutive thetas and gammas.
6510 C ab initio-derived potentials from
6511 c Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203
6512 C
6513       implicit real*8 (a-h,o-z)
6514       include 'DIMENSIONS'
6515       include 'COMMON.LOCAL'
6516       include 'COMMON.GEO'
6517       include 'COMMON.INTERACT'
6518       include 'COMMON.DERIV'
6519       include 'COMMON.VAR'
6520       include 'COMMON.CHAIN'
6521       include 'COMMON.IOUNITS'
6522       include 'COMMON.NAMES'
6523       include 'COMMON.FFIELD'
6524       include 'COMMON.CONTROL'
6525       include 'COMMON.TORCNSTR'
6526       double precision coskt(mmaxtheterm),sinkt(mmaxtheterm),
6527      & cosph1(maxsingle),sinph1(maxsingle),cosph2(maxsingle),
6528      & sinph2(maxsingle),cosph1ph2(maxdouble,maxdouble),
6529      & sinph1ph2(maxdouble,maxdouble)
6530       logical lprn /.false./, lprn1 /.false./
6531       etheta=0.0D0
6532       do i=ithet_start,ithet_end
6533 c        print *,i,itype(i-1),itype(i),itype(i-2)
6534         if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
6535      &  .or.itype(i).eq.ntyp1) cycle
6536 C        print *,i,theta(i)
6537         if (iabs(itype(i+1)).eq.20) iblock=2
6538         if (iabs(itype(i+1)).ne.20) iblock=1
6539         dethetai=0.0d0
6540         dephii=0.0d0
6541         dephii1=0.0d0
6542         theti2=0.5d0*theta(i)
6543         ityp2=ithetyp((itype(i-1)))
6544         do k=1,nntheterm
6545           coskt(k)=dcos(k*theti2)
6546           sinkt(k)=dsin(k*theti2)
6547         enddo
6548 C        print *,ethetai
6549         if (i.gt.3 .and. itype(i-3).ne.ntyp1) then
6550 #ifdef OSF
6551           phii=phi(i)
6552           if (phii.ne.phii) phii=150.0
6553 #else
6554           phii=phi(i)
6555 #endif
6556           ityp1=ithetyp((itype(i-2)))
6557 C propagation of chirality for glycine type
6558           do k=1,nsingle
6559             cosph1(k)=dcos(k*phii)
6560             sinph1(k)=dsin(k*phii)
6561           enddo
6562         else
6563           phii=0.0d0
6564           do k=1,nsingle
6565           ityp1=ithetyp((itype(i-2)))
6566             cosph1(k)=0.0d0
6567             sinph1(k)=0.0d0
6568           enddo
6569         endif
6570         if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
6571 #ifdef OSF
6572           phii1=phi(i+1)
6573           if (phii1.ne.phii1) phii1=150.0
6574           phii1=pinorm(phii1)
6575 #else
6576           phii1=phi(i+1)
6577 #endif
6578           ityp3=ithetyp((itype(i)))
6579           do k=1,nsingle
6580             cosph2(k)=dcos(k*phii1)
6581             sinph2(k)=dsin(k*phii1)
6582           enddo
6583         else
6584           phii1=0.0d0
6585           ityp3=ithetyp((itype(i)))
6586           do k=1,nsingle
6587             cosph2(k)=0.0d0
6588             sinph2(k)=0.0d0
6589           enddo
6590         endif
6591         ethetai=aa0thet(ityp1,ityp2,ityp3,iblock)
6592         do k=1,ndouble
6593           do l=1,k-1
6594             ccl=cosph1(l)*cosph2(k-l)
6595             ssl=sinph1(l)*sinph2(k-l)
6596             scl=sinph1(l)*cosph2(k-l)
6597             csl=cosph1(l)*sinph2(k-l)
6598             cosph1ph2(l,k)=ccl-ssl
6599             cosph1ph2(k,l)=ccl+ssl
6600             sinph1ph2(l,k)=scl+csl
6601             sinph1ph2(k,l)=scl-csl
6602           enddo
6603         enddo
6604         if (lprn) then
6605         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,
6606      &    " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
6607         write (iout,*) "coskt and sinkt"
6608         do k=1,nntheterm
6609           write (iout,*) k,coskt(k),sinkt(k)
6610         enddo
6611         endif
6612         do k=1,ntheterm
6613           ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3,iblock)*sinkt(k)
6614           dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3,iblock)
6615      &      *coskt(k)
6616           if (lprn)
6617      &    write (iout,*) "k",k,"
6618      &     aathet",aathet(k,ityp1,ityp2,ityp3,iblock),
6619      &     " ethetai",ethetai
6620         enddo
6621         if (lprn) then
6622         write (iout,*) "cosph and sinph"
6623         do k=1,nsingle
6624           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
6625         enddo
6626         write (iout,*) "cosph1ph2 and sinph2ph2"
6627         do k=2,ndouble
6628           do l=1,k-1
6629             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),
6630      &         sinph1ph2(l,k),sinph1ph2(k,l)
6631           enddo
6632         enddo
6633         write(iout,*) "ethetai",ethetai
6634         endif
6635 C       print *,ethetai
6636         do m=1,ntheterm2
6637           do k=1,nsingle
6638             aux=bbthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)
6639      &         +ccthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k)
6640      &         +ddthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)
6641      &         +eethet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k)
6642             ethetai=ethetai+sinkt(m)*aux
6643             dethetai=dethetai+0.5d0*m*aux*coskt(m)
6644             dephii=dephii+k*sinkt(m)*(
6645      &          ccthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)-
6646      &          bbthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k))
6647             dephii1=dephii1+k*sinkt(m)*(
6648      &          eethet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)-
6649      &          ddthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k))
6650             if (lprn)
6651      &      write (iout,*) "m",m," k",k," bbthet",
6652      &         bbthet(k,m,ityp1,ityp2,ityp3,iblock)," ccthet",
6653      &         ccthet(k,m,ityp1,ityp2,ityp3,iblock)," ddthet",
6654      &         ddthet(k,m,ityp1,ityp2,ityp3,iblock)," eethet",
6655      &         eethet(k,m,ityp1,ityp2,ityp3,iblock)," ethetai",ethetai
6656 C        print *,"tu",cosph1(k),sinph1(k),cosph2(k),sinph2(k)
6657           enddo
6658         enddo
6659 C        print *,"cosph1", (cosph1(k), k=1,nsingle)
6660 C        print *,"cosph2", (cosph2(k), k=1,nsingle)
6661 C        print *,"sinph1", (sinph1(k), k=1,nsingle)
6662 C        print *,"sinph2", (sinph2(k), k=1,nsingle)
6663         if (lprn)
6664      &  write(iout,*) "ethetai",ethetai
6665 C        print *,"tu",cosph1(k),sinph1(k),cosph2(k),sinph2(k)
6666         do m=1,ntheterm3
6667           do k=2,ndouble
6668             do l=1,k-1
6669               aux=ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
6670      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l)+
6671      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
6672      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)
6673               ethetai=ethetai+sinkt(m)*aux
6674               dethetai=dethetai+0.5d0*m*coskt(m)*aux
6675               dephii=dephii+l*sinkt(m)*(
6676      &           -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)-
6677      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
6678      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
6679      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
6680               dephii1=dephii1+(k-l)*sinkt(m)*(
6681      &           -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
6682      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
6683      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)-
6684      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
6685               if (lprn) then
6686               write (iout,*) "m",m," k",k," l",l," ffthet",
6687      &            ffthet(l,k,m,ityp1,ityp2,ityp3,iblock),
6688      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)," ggthet",
6689      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock),
6690      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock),
6691      &            " ethetai",ethetai
6692               write (iout,*) cosph1ph2(l,k)*sinkt(m),
6693      &            cosph1ph2(k,l)*sinkt(m),
6694      &            sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
6695               endif
6696             enddo
6697           enddo
6698         enddo
6699 10      continue
6700 c        lprn1=.true.
6701 C        print *,ethetai
6702         if (lprn1)
6703      &    write (iout,'(i2,3f8.1,9h ethetai ,f10.5)')
6704      &   i,theta(i)*rad2deg,phii*rad2deg,
6705      &   phii1*rad2deg,ethetai
6706 c        lprn1=.false.
6707         etheta=etheta+ethetai
6708         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
6709         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
6710         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)+wang*dethetai
6711       enddo
6712
6713       return
6714       end
6715 #endif
6716 #ifdef CRYST_SC
6717 c-----------------------------------------------------------------------------
6718       subroutine esc(escloc)
6719 C Calculate the local energy of a side chain and its derivatives in the
6720 C corresponding virtual-bond valence angles THETA and the spherical angles
6721 C ALPHA and OMEGA.
6722       implicit real*8 (a-h,o-z)
6723       include 'DIMENSIONS'
6724       include 'COMMON.GEO'
6725       include 'COMMON.LOCAL'
6726       include 'COMMON.VAR'
6727       include 'COMMON.INTERACT'
6728       include 'COMMON.DERIV'
6729       include 'COMMON.CHAIN'
6730       include 'COMMON.IOUNITS'
6731       include 'COMMON.NAMES'
6732       include 'COMMON.FFIELD'
6733       include 'COMMON.CONTROL'
6734       double precision x(3),dersc(3),xemp(3),dersc0(3),dersc1(3),
6735      &     ddersc0(3),ddummy(3),xtemp(3),temp(3)
6736       common /sccalc/ time11,time12,time112,theti,it,nlobit
6737       delta=0.02d0*pi
6738       escloc=0.0D0
6739 c     write (iout,'(a)') 'ESC'
6740       do i=loc_start,loc_end
6741         it=itype(i)
6742         if (it.eq.ntyp1) cycle
6743         if (it.eq.10) goto 1
6744         nlobit=nlob(iabs(it))
6745 c       print *,'i=',i,' it=',it,' nlobit=',nlobit
6746 c       write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
6747         theti=theta(i+1)-pipol
6748         x(1)=dtan(theti)
6749         x(2)=alph(i)
6750         x(3)=omeg(i)
6751
6752         if (x(2).gt.pi-delta) then
6753           xtemp(1)=x(1)
6754           xtemp(2)=pi-delta
6755           xtemp(3)=x(3)
6756           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
6757           xtemp(2)=pi
6758           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
6759           call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),
6760      &        escloci,dersc(2))
6761           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
6762      &        ddersc0(1),dersc(1))
6763           call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),
6764      &        ddersc0(3),dersc(3))
6765           xtemp(2)=pi-delta
6766           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
6767           xtemp(2)=pi
6768           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
6769           call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,
6770      &            dersc0(2),esclocbi,dersc02)
6771           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
6772      &            dersc12,dersc01)
6773           call splinthet(x(2),0.5d0*delta,ss,ssd)
6774           dersc0(1)=dersc01
6775           dersc0(2)=dersc02
6776           dersc0(3)=0.0d0
6777           do k=1,3
6778             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
6779           enddo
6780           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
6781 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
6782 c    &             esclocbi,ss,ssd
6783           escloci=ss*escloci+(1.0d0-ss)*esclocbi
6784 c         escloci=esclocbi
6785 c         write (iout,*) escloci
6786         else if (x(2).lt.delta) then
6787           xtemp(1)=x(1)
6788           xtemp(2)=delta
6789           xtemp(3)=x(3)
6790           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
6791           xtemp(2)=0.0d0
6792           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
6793           call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),
6794      &        escloci,dersc(2))
6795           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
6796      &        ddersc0(1),dersc(1))
6797           call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),
6798      &        ddersc0(3),dersc(3))
6799           xtemp(2)=delta
6800           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
6801           xtemp(2)=0.0d0
6802           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
6803           call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,
6804      &            dersc0(2),esclocbi,dersc02)
6805           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
6806      &            dersc12,dersc01)
6807           dersc0(1)=dersc01
6808           dersc0(2)=dersc02
6809           dersc0(3)=0.0d0
6810           call splinthet(x(2),0.5d0*delta,ss,ssd)
6811           do k=1,3
6812             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
6813           enddo
6814           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
6815 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
6816 c    &             esclocbi,ss,ssd
6817           escloci=ss*escloci+(1.0d0-ss)*esclocbi
6818 c         write (iout,*) escloci
6819         else
6820           call enesc(x,escloci,dersc,ddummy,.false.)
6821         endif
6822
6823         escloc=escloc+escloci
6824         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
6825      &     'escloc',i,escloci
6826 c       write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
6827
6828         gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
6829      &   wscloc*dersc(1)
6830         gloc(ialph(i,1),icg)=wscloc*dersc(2)
6831         gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
6832     1   continue
6833       enddo
6834       return
6835       end
6836 C---------------------------------------------------------------------------
6837       subroutine enesc(x,escloci,dersc,ddersc,mixed)
6838       implicit real*8 (a-h,o-z)
6839       include 'DIMENSIONS'
6840       include 'COMMON.GEO'
6841       include 'COMMON.LOCAL'
6842       include 'COMMON.IOUNITS'
6843       common /sccalc/ time11,time12,time112,theti,it,nlobit
6844       double precision x(3),z(3),Ax(3,maxlob,-1:1),dersc(3),ddersc(3)
6845       double precision contr(maxlob,-1:1)
6846       logical mixed
6847 c       write (iout,*) 'it=',it,' nlobit=',nlobit
6848         escloc_i=0.0D0
6849         do j=1,3
6850           dersc(j)=0.0D0
6851           if (mixed) ddersc(j)=0.0d0
6852         enddo
6853         x3=x(3)
6854
6855 C Because of periodicity of the dependence of the SC energy in omega we have
6856 C to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
6857 C To avoid underflows, first compute & store the exponents.
6858
6859         do iii=-1,1
6860
6861           x(3)=x3+iii*dwapi
6862
6863           do j=1,nlobit
6864             do k=1,3
6865               z(k)=x(k)-censc(k,j,it)
6866             enddo
6867             do k=1,3
6868               Axk=0.0D0
6869               do l=1,3
6870                 Axk=Axk+gaussc(l,k,j,it)*z(l)
6871               enddo
6872               Ax(k,j,iii)=Axk
6873             enddo
6874             expfac=0.0D0
6875             do k=1,3
6876               expfac=expfac+Ax(k,j,iii)*z(k)
6877             enddo
6878             contr(j,iii)=expfac
6879           enddo ! j
6880
6881         enddo ! iii
6882
6883         x(3)=x3
6884 C As in the case of ebend, we want to avoid underflows in exponentiation and
6885 C subsequent NaNs and INFs in energy calculation.
6886 C Find the largest exponent
6887         emin=contr(1,-1)
6888         do iii=-1,1
6889           do j=1,nlobit
6890             if (emin.gt.contr(j,iii)) emin=contr(j,iii)
6891           enddo
6892         enddo
6893         emin=0.5D0*emin
6894 cd      print *,'it=',it,' emin=',emin
6895
6896 C Compute the contribution to SC energy and derivatives
6897         do iii=-1,1
6898
6899           do j=1,nlobit
6900 #ifdef OSF
6901             adexp=bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin
6902             if(adexp.ne.adexp) adexp=1.0
6903             expfac=dexp(adexp)
6904 #else
6905             expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin)
6906 #endif
6907 cd          print *,'j=',j,' expfac=',expfac
6908             escloc_i=escloc_i+expfac
6909             do k=1,3
6910               dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
6911             enddo
6912             if (mixed) then
6913               do k=1,3,2
6914                 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii)
6915      &            +gaussc(k,2,j,it))*expfac
6916               enddo
6917             endif
6918           enddo
6919
6920         enddo ! iii
6921
6922         dersc(1)=dersc(1)/cos(theti)**2
6923         ddersc(1)=ddersc(1)/cos(theti)**2
6924         ddersc(3)=ddersc(3)
6925
6926         escloci=-(dlog(escloc_i)-emin)
6927         do j=1,3
6928           dersc(j)=dersc(j)/escloc_i
6929         enddo
6930         if (mixed) then
6931           do j=1,3,2
6932             ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
6933           enddo
6934         endif
6935       return
6936       end
6937 C------------------------------------------------------------------------------
6938       subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
6939       implicit real*8 (a-h,o-z)
6940       include 'DIMENSIONS'
6941       include 'COMMON.GEO'
6942       include 'COMMON.LOCAL'
6943       include 'COMMON.IOUNITS'
6944       common /sccalc/ time11,time12,time112,theti,it,nlobit
6945       double precision x(3),z(3),Ax(3,maxlob),dersc(3)
6946       double precision contr(maxlob)
6947       logical mixed
6948
6949       escloc_i=0.0D0
6950
6951       do j=1,3
6952         dersc(j)=0.0D0
6953       enddo
6954
6955       do j=1,nlobit
6956         do k=1,2
6957           z(k)=x(k)-censc(k,j,it)
6958         enddo
6959         z(3)=dwapi
6960         do k=1,3
6961           Axk=0.0D0
6962           do l=1,3
6963             Axk=Axk+gaussc(l,k,j,it)*z(l)
6964           enddo
6965           Ax(k,j)=Axk
6966         enddo
6967         expfac=0.0D0
6968         do k=1,3
6969           expfac=expfac+Ax(k,j)*z(k)
6970         enddo
6971         contr(j)=expfac
6972       enddo ! j
6973
6974 C As in the case of ebend, we want to avoid underflows in exponentiation and
6975 C subsequent NaNs and INFs in energy calculation.
6976 C Find the largest exponent
6977       emin=contr(1)
6978       do j=1,nlobit
6979         if (emin.gt.contr(j)) emin=contr(j)
6980       enddo
6981       emin=0.5D0*emin
6982
6983 C Compute the contribution to SC energy and derivatives
6984
6985       dersc12=0.0d0
6986       do j=1,nlobit
6987         expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j)+emin)
6988         escloc_i=escloc_i+expfac
6989         do k=1,2
6990           dersc(k)=dersc(k)+Ax(k,j)*expfac
6991         enddo
6992         if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j)
6993      &            +gaussc(1,2,j,it))*expfac
6994         dersc(3)=0.0d0
6995       enddo
6996
6997       dersc(1)=dersc(1)/cos(theti)**2
6998       dersc12=dersc12/cos(theti)**2
6999       escloci=-(dlog(escloc_i)-emin)
7000       do j=1,2
7001         dersc(j)=dersc(j)/escloc_i
7002       enddo
7003       if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
7004       return
7005       end
7006 #else
7007 c----------------------------------------------------------------------------------
7008       subroutine esc(escloc)
7009 C Calculate the local energy of a side chain and its derivatives in the
7010 C corresponding virtual-bond valence angles THETA and the spherical angles
7011 C ALPHA and OMEGA derived from AM1 all-atom calculations.
7012 C added by Urszula Kozlowska. 07/11/2007
7013 C
7014       implicit real*8 (a-h,o-z)
7015       include 'DIMENSIONS'
7016       include 'COMMON.GEO'
7017       include 'COMMON.LOCAL'
7018       include 'COMMON.VAR'
7019       include 'COMMON.SCROT'
7020       include 'COMMON.INTERACT'
7021       include 'COMMON.DERIV'
7022       include 'COMMON.CHAIN'
7023       include 'COMMON.IOUNITS'
7024       include 'COMMON.NAMES'
7025       include 'COMMON.FFIELD'
7026       include 'COMMON.CONTROL'
7027       include 'COMMON.VECTORS'
7028       double precision x_prime(3),y_prime(3),z_prime(3)
7029      &    , sumene,dsc_i,dp2_i,x(65),
7030      &     xx,yy,zz,sumene1,sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6,
7031      &    de_dxx,de_dyy,de_dzz,de_dt
7032       double precision s1_t,s1_6_t,s2_t,s2_6_t
7033       double precision
7034      & dXX_Ci1(3),dYY_Ci1(3),dZZ_Ci1(3),dXX_Ci(3),
7035      & dYY_Ci(3),dZZ_Ci(3),dXX_XYZ(3),dYY_XYZ(3),dZZ_XYZ(3),
7036      & dt_dCi(3),dt_dCi1(3)
7037       common /sccalc/ time11,time12,time112,theti,it,nlobit
7038       delta=0.02d0*pi
7039       escloc=0.0D0
7040       do i=loc_start,loc_end
7041         if (itype(i).eq.ntyp1) cycle
7042         costtab(i+1) =dcos(theta(i+1))
7043         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
7044         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
7045         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
7046         cosfac2=0.5d0/(1.0d0+costtab(i+1))
7047         cosfac=dsqrt(cosfac2)
7048         sinfac2=0.5d0/(1.0d0-costtab(i+1))
7049         sinfac=dsqrt(sinfac2)
7050         it=iabs(itype(i))
7051         if (it.eq.10) goto 1
7052 c
7053 C  Compute the axes of tghe local cartesian coordinates system; store in
7054 c   x_prime, y_prime and z_prime
7055 c
7056         do j=1,3
7057           x_prime(j) = 0.00
7058           y_prime(j) = 0.00
7059           z_prime(j) = 0.00
7060         enddo
7061 C        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
7062 C     &   dc_norm(3,i+nres)
7063         do j = 1,3
7064           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
7065           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
7066         enddo
7067         do j = 1,3
7068           z_prime(j) = -uz(j,i-1)*dsign(1.0d0,dfloat(itype(i)))
7069         enddo
7070 c       write (2,*) "i",i
7071 c       write (2,*) "x_prime",(x_prime(j),j=1,3)
7072 c       write (2,*) "y_prime",(y_prime(j),j=1,3)
7073 c       write (2,*) "z_prime",(z_prime(j),j=1,3)
7074 c       write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
7075 c      & " xy",scalar(x_prime(1),y_prime(1)),
7076 c      & " xz",scalar(x_prime(1),z_prime(1)),
7077 c      & " yy",scalar(y_prime(1),y_prime(1)),
7078 c      & " yz",scalar(y_prime(1),z_prime(1)),
7079 c      & " zz",scalar(z_prime(1),z_prime(1))
7080 c
7081 C Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
7082 C to local coordinate system. Store in xx, yy, zz.
7083 c
7084         xx=0.0d0
7085         yy=0.0d0
7086         zz=0.0d0
7087         do j = 1,3
7088           xx = xx + x_prime(j)*dc_norm(j,i+nres)
7089           yy = yy + y_prime(j)*dc_norm(j,i+nres)
7090           zz = zz + z_prime(j)*dc_norm(j,i+nres)
7091         enddo
7092
7093         xxtab(i)=xx
7094         yytab(i)=yy
7095         zztab(i)=zz
7096 C
7097 C Compute the energy of the ith side cbain
7098 C
7099 c        write (2,*) "xx",xx," yy",yy," zz",zz
7100         it=iabs(itype(i))
7101         do j = 1,65
7102           x(j) = sc_parmin(j,it)
7103         enddo
7104 #ifdef CHECK_COORD
7105 Cc diagnostics - remove later
7106         xx1 = dcos(alph(2))
7107         yy1 = dsin(alph(2))*dcos(omeg(2))
7108         zz1 = -dsign(1.0,dfloat(itype(i)))*dsin(alph(2))*dsin(omeg(2))
7109         write(2,'(3f8.1,3f9.3,1x,3f9.3)')
7110      &    alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,
7111      &    xx1,yy1,zz1
7112 C,"  --- ", xx_w,yy_w,zz_w
7113 c end diagnostics
7114 #endif
7115         sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
7116      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
7117      &   + x(10)*yy*zz
7118         sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
7119      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
7120      & + x(20)*yy*zz
7121         sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
7122      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
7123      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
7124      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
7125      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
7126      &  +x(40)*xx*yy*zz
7127         sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
7128      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
7129      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
7130      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
7131      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
7132      &  +x(60)*xx*yy*zz
7133         dsc_i   = 0.743d0+x(61)
7134         dp2_i   = 1.9d0+x(62)
7135         dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
7136      &          *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
7137         dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
7138      &          *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
7139         s1=(1+x(63))/(0.1d0 + dscp1)
7140         s1_6=(1+x(64))/(0.1d0 + dscp1**6)
7141         s2=(1+x(65))/(0.1d0 + dscp2)
7142         s2_6=(1+x(65))/(0.1d0 + dscp2**6)
7143         sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6)
7144      & + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
7145 c        write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
7146 c     &   sumene4,
7147 c     &   dscp1,dscp2,sumene
7148 c        sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
7149         escloc = escloc + sumene
7150 c        write (2,*) "i",i," escloc",sumene,escloc,it,itype(i)
7151 c     & ,zz,xx,yy
7152 c#define DEBUG
7153 #ifdef DEBUG
7154 C
7155 C This section to check the numerical derivatives of the energy of ith side
7156 C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
7157 C #define DEBUG in the code to turn it on.
7158 C
7159         write (2,*) "sumene               =",sumene
7160         aincr=1.0d-7
7161         xxsave=xx
7162         xx=xx+aincr
7163         write (2,*) xx,yy,zz
7164         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
7165         de_dxx_num=(sumenep-sumene)/aincr
7166         xx=xxsave
7167         write (2,*) "xx+ sumene from enesc=",sumenep
7168         yysave=yy
7169         yy=yy+aincr
7170         write (2,*) xx,yy,zz
7171         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
7172         de_dyy_num=(sumenep-sumene)/aincr
7173         yy=yysave
7174         write (2,*) "yy+ sumene from enesc=",sumenep
7175         zzsave=zz
7176         zz=zz+aincr
7177         write (2,*) xx,yy,zz
7178         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
7179         de_dzz_num=(sumenep-sumene)/aincr
7180         zz=zzsave
7181         write (2,*) "zz+ sumene from enesc=",sumenep
7182         costsave=cost2tab(i+1)
7183         sintsave=sint2tab(i+1)
7184         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
7185         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
7186         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
7187         de_dt_num=(sumenep-sumene)/aincr
7188         write (2,*) " t+ sumene from enesc=",sumenep
7189         cost2tab(i+1)=costsave
7190         sint2tab(i+1)=sintsave
7191 C End of diagnostics section.
7192 #endif
7193 C
7194 C Compute the gradient of esc
7195 C
7196 c        zz=zz*dsign(1.0,dfloat(itype(i)))
7197         pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
7198         pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
7199         pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
7200         pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
7201         pom_dx=dsc_i*dp2_i*cost2tab(i+1)
7202         pom_dy=dsc_i*dp2_i*sint2tab(i+1)
7203         pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
7204         pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
7205         pom1=(sumene3*sint2tab(i+1)+sumene1)
7206      &     *(pom_s1/dscp1+pom_s16*dscp1**4)
7207         pom2=(sumene4*cost2tab(i+1)+sumene2)
7208      &     *(pom_s2/dscp2+pom_s26*dscp2**4)
7209         sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
7210         sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2
7211      &  +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2)
7212      &  +x(40)*yy*zz
7213         sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
7214         sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2
7215      &  +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2)
7216      &  +x(60)*yy*zz
7217         de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6)
7218      &        +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6)
7219      &        +(pom1+pom2)*pom_dx
7220 #ifdef DEBUG
7221         write(2,*), "de_dxx = ", de_dxx,de_dxx_num,itype(i)
7222 #endif
7223 C
7224         sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
7225         sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2
7226      &  +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2)
7227      &  +x(40)*xx*zz
7228         sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
7229         sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz
7230      &  +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz
7231      &  +x(59)*zz**2 +x(60)*xx*zz
7232         de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6)
7233      &        +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6)
7234      &        +(pom1-pom2)*pom_dy
7235 #ifdef DEBUG
7236         write(2,*), "de_dyy = ", de_dyy,de_dyy_num,itype(i)
7237 #endif
7238 C
7239         de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy
7240      &  +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx
7241      &  +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6)
7242      &  +(x(4) + 2*x(7)*zz+  x(8)*xx + x(10)*yy)*(s1+s1_6)
7243      &  +(x(44)+2*x(47)*zz +x(48)*xx   +x(50)*yy  +3*x(53)*zz**2
7244      &  +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy
7245      &  +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6)
7246      &  + ( x(14) + 2*x(17)*zz+  x(18)*xx + x(20)*yy)*(s2+s2_6)
7247 #ifdef DEBUG
7248         write(2,*), "de_dzz = ", de_dzz,de_dzz_num,itype(i)
7249 #endif
7250 C
7251         de_dt =  0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6)
7252      &  -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6)
7253      &  +pom1*pom_dt1+pom2*pom_dt2
7254 #ifdef DEBUG
7255         write(2,*), "de_dt = ", de_dt,de_dt_num,itype(i)
7256 #endif
7257 c#undef DEBUG
7258 c
7259 C
7260        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
7261        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
7262        cosfac2xx=cosfac2*xx
7263        sinfac2yy=sinfac2*yy
7264        do k = 1,3
7265          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))*
7266      &      vbld_inv(i+1)
7267          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))*
7268      &      vbld_inv(i)
7269          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
7270          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
7271 c         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
7272 c     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
7273 c         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
7274 c     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
7275          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
7276          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
7277          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
7278          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
7279          dZZ_Ci1(k)=0.0d0
7280          dZZ_Ci(k)=0.0d0
7281          do j=1,3
7282            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)
7283      &     *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
7284            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)
7285      &     *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
7286          enddo
7287
7288          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
7289          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
7290          dZZ_XYZ(k)=vbld_inv(i+nres)*
7291      &   (z_prime(k)-zz*dC_norm(k,i+nres))
7292 c
7293          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
7294          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
7295        enddo
7296
7297        do k=1,3
7298          dXX_Ctab(k,i)=dXX_Ci(k)
7299          dXX_C1tab(k,i)=dXX_Ci1(k)
7300          dYY_Ctab(k,i)=dYY_Ci(k)
7301          dYY_C1tab(k,i)=dYY_Ci1(k)
7302          dZZ_Ctab(k,i)=dZZ_Ci(k)
7303          dZZ_C1tab(k,i)=dZZ_Ci1(k)
7304          dXX_XYZtab(k,i)=dXX_XYZ(k)
7305          dYY_XYZtab(k,i)=dYY_XYZ(k)
7306          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
7307        enddo
7308
7309        do k = 1,3
7310 c         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
7311 c     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
7312 c         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
7313 c     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
7314 c         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
7315 c     &    dt_dci(k)
7316 c         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
7317 c     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
7318          gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k)
7319      &    +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
7320          gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k)
7321      &    +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
7322          gsclocx(k,i)=                 de_dxx*dxx_XYZ(k)
7323      &    +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
7324        enddo
7325 c       write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
7326 c     &  (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
7327
7328 C to check gradient call subroutine check_grad
7329
7330     1 continue
7331       enddo
7332       return
7333       end
7334 c------------------------------------------------------------------------------
7335       double precision function enesc(x,xx,yy,zz,cost2,sint2)
7336       implicit none
7337       double precision x(65),xx,yy,zz,cost2,sint2,sumene1,sumene2,
7338      & sumene3,sumene4,sumene,dsc_i,dp2_i,dscp1,dscp2,s1,s1_6,s2,s2_6
7339       sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
7340      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
7341      &   + x(10)*yy*zz
7342       sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
7343      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
7344      & + x(20)*yy*zz
7345       sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
7346      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
7347      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
7348      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
7349      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
7350      &  +x(40)*xx*yy*zz
7351       sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
7352      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
7353      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
7354      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
7355      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
7356      &  +x(60)*xx*yy*zz
7357       dsc_i   = 0.743d0+x(61)
7358       dp2_i   = 1.9d0+x(62)
7359       dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
7360      &          *(xx*cost2+yy*sint2))
7361       dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
7362      &          *(xx*cost2-yy*sint2))
7363       s1=(1+x(63))/(0.1d0 + dscp1)
7364       s1_6=(1+x(64))/(0.1d0 + dscp1**6)
7365       s2=(1+x(65))/(0.1d0 + dscp2)
7366       s2_6=(1+x(65))/(0.1d0 + dscp2**6)
7367       sumene = ( sumene3*sint2 + sumene1)*(s1+s1_6)
7368      & + (sumene4*cost2 +sumene2)*(s2+s2_6)
7369       enesc=sumene
7370       return
7371       end
7372 #endif
7373 c------------------------------------------------------------------------------
7374       subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
7375 C
7376 C This procedure calculates two-body contact function g(rij) and its derivative:
7377 C
7378 C           eps0ij                                     !       x < -1
7379 C g(rij) =  esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5)  ! -1 =< x =< 1
7380 C            0                                         !       x > 1
7381 C
7382 C where x=(rij-r0ij)/delta
7383 C
7384 C rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
7385 C
7386       implicit none
7387       double precision rij,r0ij,eps0ij,fcont,fprimcont
7388       double precision x,x2,x4,delta
7389 c     delta=0.02D0*r0ij
7390 c      delta=0.2D0*r0ij
7391       x=(rij-r0ij)/delta
7392       if (x.lt.-1.0D0) then
7393         fcont=eps0ij
7394         fprimcont=0.0D0
7395       else if (x.le.1.0D0) then
7396         x2=x*x
7397         x4=x2*x2
7398         fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
7399         fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
7400       else
7401         fcont=0.0D0
7402         fprimcont=0.0D0
7403       endif
7404       return
7405       end
7406 c------------------------------------------------------------------------------
7407       subroutine splinthet(theti,delta,ss,ssder)
7408       implicit real*8 (a-h,o-z)
7409       include 'DIMENSIONS'
7410       include 'COMMON.VAR'
7411       include 'COMMON.GEO'
7412       thetup=pi-delta
7413       thetlow=delta
7414       if (theti.gt.pipol) then
7415         call gcont(theti,thetup,1.0d0,delta,ss,ssder)
7416       else
7417         call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
7418         ssder=-ssder
7419       endif
7420       return
7421       end
7422 c------------------------------------------------------------------------------
7423       subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
7424       implicit none
7425       double precision x,x0,delta,f0,f1,fprim0,f,fprim
7426       double precision ksi,ksi2,ksi3,a1,a2,a3
7427       a1=fprim0*delta/(f1-f0)
7428       a2=3.0d0-2.0d0*a1
7429       a3=a1-2.0d0
7430       ksi=(x-x0)/delta
7431       ksi2=ksi*ksi
7432       ksi3=ksi2*ksi
7433       f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
7434       fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
7435       return
7436       end
7437 c------------------------------------------------------------------------------
7438       subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
7439       implicit none
7440       double precision x,x0,delta,f0x,f1x,fprim0x,fx
7441       double precision ksi,ksi2,ksi3,a1,a2,a3
7442       ksi=(x-x0)/delta
7443       ksi2=ksi*ksi
7444       ksi3=ksi2*ksi
7445       a1=fprim0x*delta
7446       a2=3*(f1x-f0x)-2*fprim0x*delta
7447       a3=fprim0x*delta-2*(f1x-f0x)
7448       fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
7449       return
7450       end
7451 C-----------------------------------------------------------------------------
7452 #ifdef CRYST_TOR
7453 C-----------------------------------------------------------------------------
7454       subroutine etor(etors)
7455       implicit real*8 (a-h,o-z)
7456       include 'DIMENSIONS'
7457       include 'COMMON.VAR'
7458       include 'COMMON.GEO'
7459       include 'COMMON.LOCAL'
7460       include 'COMMON.TORSION'
7461       include 'COMMON.INTERACT'
7462       include 'COMMON.DERIV'
7463       include 'COMMON.CHAIN'
7464       include 'COMMON.NAMES'
7465       include 'COMMON.IOUNITS'
7466       include 'COMMON.FFIELD'
7467       include 'COMMON.TORCNSTR'
7468       include 'COMMON.CONTROL'
7469       logical lprn
7470 C Set lprn=.true. for debugging
7471       lprn=.false.
7472 c      lprn=.true.
7473       etors=0.0D0
7474       do i=iphi_start,iphi_end
7475       etors_ii=0.0D0
7476         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
7477      &      .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
7478         itori=itortyp(itype(i-2))
7479         itori1=itortyp(itype(i-1))
7480         phii=phi(i)
7481         gloci=0.0D0
7482 C Proline-Proline pair is a special case...
7483         if (itori.eq.3 .and. itori1.eq.3) then
7484           if (phii.gt.-dwapi3) then
7485             cosphi=dcos(3*phii)
7486             fac=1.0D0/(1.0D0-cosphi)
7487             etorsi=v1(1,3,3)*fac
7488             etorsi=etorsi+etorsi
7489             etors=etors+etorsi-v1(1,3,3)
7490             if (energy_dec) etors_ii=etors_ii+etorsi-v1(1,3,3)
7491             gloci=gloci-3*fac*etorsi*dsin(3*phii)
7492           endif
7493           do j=1,3
7494             v1ij=v1(j+1,itori,itori1)
7495             v2ij=v2(j+1,itori,itori1)
7496             cosphi=dcos(j*phii)
7497             sinphi=dsin(j*phii)
7498             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7499             if (energy_dec) etors_ii=etors_ii+
7500      &                              v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7501             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7502           enddo
7503         else
7504           do j=1,nterm_old
7505             v1ij=v1(j,itori,itori1)
7506             v2ij=v2(j,itori,itori1)
7507             cosphi=dcos(j*phii)
7508             sinphi=dsin(j*phii)
7509             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7510             if (energy_dec) etors_ii=etors_ii+
7511      &                  v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7512             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7513           enddo
7514         endif
7515         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
7516              'etor',i,etors_ii
7517         if (lprn)
7518      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
7519      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
7520      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
7521         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
7522 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
7523       enddo
7524       return
7525       end
7526 c------------------------------------------------------------------------------
7527       subroutine etor_d(etors_d)
7528       etors_d=0.0d0
7529       return
7530       end
7531 c----------------------------------------------------------------------------
7532 c LICZENIE WIEZOW Z ROWNANIA ENERGII MODELLERA
7533       subroutine e_modeller(ehomology_constr)
7534       ehomology_constr=0.0d0
7535       write (iout,*) "!!!!!UWAGA, JESTEM W DZIWNEJ PETLI, TEST!!!!!"
7536       return
7537       end
7538 C !!!!!!!! NIE CZYTANE !!!!!!!!!!!
7539
7540 c------------------------------------------------------------------------------
7541       subroutine etor_d(etors_d)
7542       etors_d=0.0d0
7543       return
7544       end
7545 c----------------------------------------------------------------------------
7546 #else
7547       subroutine etor(etors)
7548       implicit real*8 (a-h,o-z)
7549       include 'DIMENSIONS'
7550       include 'COMMON.VAR'
7551       include 'COMMON.GEO'
7552       include 'COMMON.LOCAL'
7553       include 'COMMON.TORSION'
7554       include 'COMMON.INTERACT'
7555       include 'COMMON.DERIV'
7556       include 'COMMON.CHAIN'
7557       include 'COMMON.NAMES'
7558       include 'COMMON.IOUNITS'
7559       include 'COMMON.FFIELD'
7560       include 'COMMON.TORCNSTR'
7561       include 'COMMON.CONTROL'
7562       logical lprn
7563 C Set lprn=.true. for debugging
7564       lprn=.false.
7565 c     lprn=.true.
7566       etors=0.0D0
7567       do i=iphi_start,iphi_end
7568 C ANY TWO ARE DUMMY ATOMS in row CYCLE
7569 c        if (((itype(i-3).eq.ntyp1).and.(itype(i-2).eq.ntyp1)).or.
7570 c     &      ((itype(i-2).eq.ntyp1).and.(itype(i-1).eq.ntyp1))  .or.
7571 c     &      ((itype(i-1).eq.ntyp1).and.(itype(i).eq.ntyp1))) cycle
7572         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
7573      &      .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
7574 C In current verion the ALL DUMMY ATOM POTENTIALS ARE OFF
7575 C For introducing the NH3+ and COO- group please check the etor_d for reference
7576 C and guidance
7577         etors_ii=0.0D0
7578          if (iabs(itype(i)).eq.20) then
7579          iblock=2
7580          else
7581          iblock=1
7582          endif
7583         itori=itortyp(itype(i-2))
7584         itori1=itortyp(itype(i-1))
7585         phii=phi(i)
7586         gloci=0.0D0
7587 C Regular cosine and sine terms
7588         do j=1,nterm(itori,itori1,iblock)
7589           v1ij=v1(j,itori,itori1,iblock)
7590           v2ij=v2(j,itori,itori1,iblock)
7591           cosphi=dcos(j*phii)
7592           sinphi=dsin(j*phii)
7593           etors=etors+v1ij*cosphi+v2ij*sinphi
7594           if (energy_dec) etors_ii=etors_ii+
7595      &                v1ij*cosphi+v2ij*sinphi
7596           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7597         enddo
7598 C Lorentz terms
7599 C                         v1
7600 C  E = SUM ----------------------------------- - v1
7601 C          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
7602 C
7603         cosphi=dcos(0.5d0*phii)
7604         sinphi=dsin(0.5d0*phii)
7605         do j=1,nlor(itori,itori1,iblock)
7606           vl1ij=vlor1(j,itori,itori1)
7607           vl2ij=vlor2(j,itori,itori1)
7608           vl3ij=vlor3(j,itori,itori1)
7609           pom=vl2ij*cosphi+vl3ij*sinphi
7610           pom1=1.0d0/(pom*pom+1.0d0)
7611           etors=etors+vl1ij*pom1
7612           if (energy_dec) etors_ii=etors_ii+
7613      &                vl1ij*pom1
7614           pom=-pom*pom1*pom1
7615           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
7616         enddo
7617 C Subtract the constant term
7618         etors=etors-v0(itori,itori1,iblock)
7619           if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
7620      &         'etor',i,etors_ii-v0(itori,itori1,iblock)
7621         if (lprn)
7622      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
7623      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
7624      &  (v1(j,itori,itori1,iblock),j=1,6),
7625      &  (v2(j,itori,itori1,iblock),j=1,6)
7626         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
7627 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
7628       enddo
7629       return
7630       end
7631 c----------------------------------------------------------------------------
7632       subroutine etor_d(etors_d)
7633 C 6/23/01 Compute double torsional energy
7634       implicit real*8 (a-h,o-z)
7635       include 'DIMENSIONS'
7636       include 'COMMON.VAR'
7637       include 'COMMON.GEO'
7638       include 'COMMON.LOCAL'
7639       include 'COMMON.TORSION'
7640       include 'COMMON.INTERACT'
7641       include 'COMMON.DERIV'
7642       include 'COMMON.CHAIN'
7643       include 'COMMON.NAMES'
7644       include 'COMMON.IOUNITS'
7645       include 'COMMON.FFIELD'
7646       include 'COMMON.TORCNSTR'
7647       logical lprn
7648 C Set lprn=.true. for debugging
7649       lprn=.false.
7650 c     lprn=.true.
7651       etors_d=0.0D0
7652 c      write(iout,*) "a tu??"
7653       do i=iphid_start,iphid_end
7654 C ANY TWO ARE DUMMY ATOMS in row CYCLE
7655 C        if (((itype(i-3).eq.ntyp1).and.(itype(i-2).eq.ntyp1)).or.
7656 C     &      ((itype(i-2).eq.ntyp1).and.(itype(i-1).eq.ntyp1)).or.
7657 C     &      ((itype(i-1).eq.ntyp1).and.(itype(i).eq.ntyp1))  .or.
7658 C     &      ((itype(i).eq.ntyp1).and.(itype(i+1).eq.ntyp1))) cycle
7659          if ((itype(i-2).eq.ntyp1).or.itype(i-3).eq.ntyp1.or.
7660      &  (itype(i-1).eq.ntyp1).or.(itype(i).eq.ntyp1).or.
7661      &  (itype(i+1).eq.ntyp1)) cycle
7662 C In current verion the ALL DUMMY ATOM POTENTIALS ARE OFF
7663         itori=itortyp(itype(i-2))
7664         itori1=itortyp(itype(i-1))
7665         itori2=itortyp(itype(i))
7666         phii=phi(i)
7667         phii1=phi(i+1)
7668         gloci1=0.0D0
7669         gloci2=0.0D0
7670         iblock=1
7671         if (iabs(itype(i+1)).eq.20) iblock=2
7672 C Iblock=2 Proline type
7673 C ADASKO: WHEN PARAMETERS FOR THIS TYPE OF BLOCKING GROUP IS READY UNCOMMENT
7674 C CHECK WEATHER THERE IS NECCESITY FOR iblock=3 for COO-
7675 C        if (itype(i+1).eq.ntyp1) iblock=3
7676 C The problem of NH3+ group can be resolved by adding new parameters please note if there
7677 C IS or IS NOT need for this
7678 C IF Yes uncomment below and add to parmread.F appropriate changes and to v1cij and so on
7679 C        is (itype(i-3).eq.ntyp1) ntblock=2
7680 C        ntblock is N-terminal blocking group
7681
7682 C Regular cosine and sine terms
7683         do j=1,ntermd_1(itori,itori1,itori2,iblock)
7684 C Example of changes for NH3+ blocking group
7685 C       do j=1,ntermd_1(itori,itori1,itori2,iblock,ntblock)
7686 C          v1cij=v1c(1,j,itori,itori1,itori2,iblock,ntblock)
7687           v1cij=v1c(1,j,itori,itori1,itori2,iblock)
7688           v1sij=v1s(1,j,itori,itori1,itori2,iblock)
7689           v2cij=v1c(2,j,itori,itori1,itori2,iblock)
7690           v2sij=v1s(2,j,itori,itori1,itori2,iblock)
7691           cosphi1=dcos(j*phii)
7692           sinphi1=dsin(j*phii)
7693           cosphi2=dcos(j*phii1)
7694           sinphi2=dsin(j*phii1)
7695           etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+
7696      &     v2cij*cosphi2+v2sij*sinphi2
7697           gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
7698           gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
7699         enddo
7700         do k=2,ntermd_2(itori,itori1,itori2,iblock)
7701           do l=1,k-1
7702             v1cdij = v2c(k,l,itori,itori1,itori2,iblock)
7703             v2cdij = v2c(l,k,itori,itori1,itori2,iblock)
7704             v1sdij = v2s(k,l,itori,itori1,itori2,iblock)
7705             v2sdij = v2s(l,k,itori,itori1,itori2,iblock)
7706             cosphi1p2=dcos(l*phii+(k-l)*phii1)
7707             cosphi1m2=dcos(l*phii-(k-l)*phii1)
7708             sinphi1p2=dsin(l*phii+(k-l)*phii1)
7709             sinphi1m2=dsin(l*phii-(k-l)*phii1)
7710             etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+
7711      &        v1sdij*sinphi1p2+v2sdij*sinphi1m2
7712             gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2
7713      &        -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
7714             gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2
7715      &        -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
7716           enddo
7717         enddo
7718         gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*gloci1
7719         gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*gloci2
7720       enddo
7721       return
7722       end
7723 #endif
7724 C----------------------------------------------------------------------------------
7725 C The rigorous attempt to derive energy function
7726       subroutine etor_kcc(etors)
7727       implicit real*8 (a-h,o-z)
7728       include 'DIMENSIONS'
7729       include 'COMMON.VAR'
7730       include 'COMMON.GEO'
7731       include 'COMMON.LOCAL'
7732       include 'COMMON.TORSION'
7733       include 'COMMON.INTERACT'
7734       include 'COMMON.DERIV'
7735       include 'COMMON.CHAIN'
7736       include 'COMMON.NAMES'
7737       include 'COMMON.IOUNITS'
7738       include 'COMMON.FFIELD'
7739       include 'COMMON.TORCNSTR'
7740       include 'COMMON.CONTROL'
7741       double precision c1(0:maxval_kcc),c2(0:maxval_kcc)
7742       logical lprn
7743 c      double precision thybt1(maxtermkcc),thybt2(maxtermkcc)
7744 C Set lprn=.true. for debugging
7745       lprn=energy_dec
7746 c     lprn=.true.
7747 C      print *,"wchodze kcc"
7748       if (lprn) write (iout,*) "etor_kcc tor_mode",tor_mode
7749       etors=0.0D0
7750       do i=iphi_start,iphi_end
7751 C ANY TWO ARE DUMMY ATOMS in row CYCLE
7752 c        if (((itype(i-3).eq.ntyp1).and.(itype(i-2).eq.ntyp1)).or.
7753 c     &      ((itype(i-2).eq.ntyp1).and.(itype(i-1).eq.ntyp1))  .or.
7754 c     &      ((itype(i-1).eq.ntyp1).and.(itype(i).eq.ntyp1))) cycle
7755         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
7756      &      .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
7757         itori=itortyp(itype(i-2))
7758         itori1=itortyp(itype(i-1))
7759         phii=phi(i)
7760         glocig=0.0D0
7761         glocit1=0.0d0
7762         glocit2=0.0d0
7763 C to avoid multiple devision by 2
7764 c        theti22=0.5d0*theta(i)
7765 C theta 12 is the theta_1 /2
7766 C theta 22 is theta_2 /2
7767 c        theti12=0.5d0*theta(i-1)
7768 C and appropriate sinus function
7769         sinthet1=dsin(theta(i-1))
7770         sinthet2=dsin(theta(i))
7771         costhet1=dcos(theta(i-1))
7772         costhet2=dcos(theta(i))
7773 C to speed up lets store its mutliplication
7774         sint1t2=sinthet2*sinthet1
7775         sint1t2n=1.0d0
7776 C \sum_{i=1}^n (sin(theta_1) * sin(theta_2))^n * (c_n* cos(n*gamma)
7777 C +d_n*sin(n*gamma)) *
7778 C \sum_{i=1}^m (1+a_m*Tb_m(cos(theta_1 /2))+b_m*Tb_m(cos(theta_2 /2)))
7779 C we have two sum 1) Non-Chebyshev which is with n and gamma
7780         nval=nterm_kcc_Tb(itori,itori1)
7781         c1(0)=0.0d0
7782         c2(0)=0.0d0
7783         c1(1)=1.0d0
7784         c2(1)=1.0d0
7785         do j=2,nval
7786           c1(j)=c1(j-1)*costhet1
7787           c2(j)=c2(j-1)*costhet2
7788         enddo
7789         etori=0.0d0
7790         do j=1,nterm_kcc(itori,itori1)
7791           cosphi=dcos(j*phii)
7792           sinphi=dsin(j*phii)
7793           sint1t2n1=sint1t2n
7794           sint1t2n=sint1t2n*sint1t2
7795           sumvalc=0.0d0
7796           gradvalct1=0.0d0
7797           gradvalct2=0.0d0
7798           do k=1,nval
7799             do l=1,nval
7800               sumvalc=sumvalc+v1_kcc(l,k,j,itori1,itori)*c1(k)*c2(l)
7801               gradvalct1=gradvalct1+
7802      &           (k-1)*v1_kcc(l,k,j,itori1,itori)*c1(k-1)*c2(l)
7803               gradvalct2=gradvalct2+
7804      &           (l-1)*v1_kcc(l,k,j,itori1,itori)*c1(k)*c2(l-1)
7805             enddo
7806           enddo
7807           gradvalct1=-gradvalct1*sinthet1
7808           gradvalct2=-gradvalct2*sinthet2
7809           sumvals=0.0d0
7810           gradvalst1=0.0d0
7811           gradvalst2=0.0d0
7812           do k=1,nval
7813             do l=1,nval
7814               sumvals=sumvals+v2_kcc(l,k,j,itori1,itori)*c1(k)*c2(l)
7815               gradvalst1=gradvalst1+
7816      &           (k-1)*v2_kcc(l,k,j,itori1,itori)*c1(k-1)*c2(l)
7817               gradvalst2=gradvalst2+
7818      &           (l-1)*v2_kcc(l,k,j,itori1,itori)*c1(k)*c2(l-1)
7819             enddo
7820           enddo
7821           gradvalst1=-gradvalst1*sinthet1
7822           gradvalst2=-gradvalst2*sinthet2
7823           if (lprn) write (iout,*)j,"sumvalc",sumvalc," sumvals",sumvals
7824           etori=etori+sint1t2n*(sumvalc*cosphi+sumvals*sinphi)
7825 C glocig is the gradient local i site in gamma
7826           glocig=glocig+j*sint1t2n*(sumvals*cosphi-sumvalc*sinphi)
7827 C now gradient over theta_1
7828           glocit1=glocit1+sint1t2n*(gradvalct1*cosphi+gradvalst1*sinphi)
7829      &   +j*sint1t2n1*costhet1*sinthet2*(sumvalc*cosphi+sumvals*sinphi)
7830           glocit2=glocit2+sint1t2n*(gradvalct2*cosphi+gradvalst2*sinphi)
7831      &   +j*sint1t2n1*sinthet1*costhet2*(sumvalc*cosphi+sumvals*sinphi)
7832         enddo ! j
7833         etors=etors+etori
7834 C derivative over gamma
7835         gloc(i-3,icg)=gloc(i-3,icg)+wtor*glocig
7836 C derivative over theta1
7837         gloc(nphi+i-3,icg)=gloc(nphi+i-3,icg)+wtor*glocit1
7838 C now derivative over theta2
7839         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)+wtor*glocit2
7840         if (lprn) then
7841           write (iout,*) i-2,i-1,itype(i-2),itype(i-1),itori,itori1,
7842      &       theta(i-1)*rad2deg,theta(i)*rad2deg,phii*rad2deg,etori
7843           write (iout,*) "c1",(c1(k),k=0,nval),
7844      &    " c2",(c2(k),k=0,nval)
7845         endif
7846       enddo
7847       return
7848       end
7849 c---------------------------------------------------------------------------------------------
7850       subroutine etor_constr(edihcnstr)
7851       implicit real*8 (a-h,o-z)
7852       include 'DIMENSIONS'
7853       include 'COMMON.VAR'
7854       include 'COMMON.GEO'
7855       include 'COMMON.LOCAL'
7856       include 'COMMON.TORSION'
7857       include 'COMMON.INTERACT'
7858       include 'COMMON.DERIV'
7859       include 'COMMON.CHAIN'
7860       include 'COMMON.NAMES'
7861       include 'COMMON.IOUNITS'
7862       include 'COMMON.FFIELD'
7863       include 'COMMON.TORCNSTR'
7864       include 'COMMON.BOUNDS'
7865       include 'COMMON.CONTROL'
7866 ! 6/20/98 - dihedral angle constraints
7867       edihcnstr=0.0d0
7868 c      do i=1,ndih_constr
7869       if (raw_psipred) then
7870         do i=idihconstr_start,idihconstr_end
7871           itori=idih_constr(i)
7872           phii=phi(itori)
7873           gaudih_i=vpsipred(1,i)
7874           gauder_i=0.0d0
7875           do j=1,2
7876             s = sdihed(j,i)
7877             cos_i=(1.0d0-dcos(phii-phibound(j,i)))/s**2
7878             dexpcos_i=dexp(-cos_i*cos_i)
7879             gaudih_i=gaudih_i+vpsipred(j+1,i)*dexpcos_i
7880             gauder_i=gauder_i-2*vpsipred(j+1,i)*dsin(phii-phibound(j,i))
7881      &            *cos_i*dexpcos_i/s**2
7882           enddo
7883           edihcnstr=edihcnstr-wdihc*dlog(gaudih_i)
7884           gloc(itori-3,icg)=gloc(itori-3,icg)-wdihc*gauder_i/gaudih_i
7885           if (energy_dec)
7886      &     write (iout,'(2i5,f8.3,f8.5,2(f8.5,2f8.3),f10.5)')
7887      &     i,itori,phii*rad2deg,vpsipred(1,i),vpsipred(2,i),
7888      &     phibound(1,i)*rad2deg,sdihed(1,i)*rad2deg,vpsipred(3,i),
7889      &     phibound(2,i)*rad2deg,sdihed(2,i)*rad2deg,
7890      &     -wdihc*dlog(gaudih_i)
7891         enddo
7892       else
7893
7894       do i=idihconstr_start,idihconstr_end
7895         itori=idih_constr(i)
7896         phii=phi(itori)
7897         difi=pinorm(phii-phi0(i))
7898         if (difi.gt.drange(i)) then
7899           difi=difi-drange(i)
7900           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
7901           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
7902         else if (difi.lt.-drange(i)) then
7903           difi=difi+drange(i)
7904           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
7905           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
7906         else
7907           difi=0.0
7908         endif
7909       enddo
7910
7911       endif
7912
7913       return
7914       end
7915 c----------------------------------------------------------------------------
7916 c MODELLER restraint function
7917       subroutine e_modeller(ehomology_constr)
7918       implicit real*8 (a-h,o-z)
7919       include 'DIMENSIONS'
7920
7921       integer nnn, i, j, k, ki, irec, l
7922       integer katy, odleglosci, test7
7923       real*8 odleg, odleg2, odleg3, kat, kat2, kat3, gdih(max_template)
7924       real*8 Eval,Erot
7925       real*8 distance(max_template),distancek(max_template),
7926      &    min_odl,godl(max_template),dih_diff(max_template)
7927
7928 c
7929 c     FP - 30/10/2014 Temporary specifications for homology restraints
7930 c
7931       double precision utheta_i,gutheta_i,sum_gtheta,sum_sgtheta,
7932      &                 sgtheta
7933       double precision, dimension (maxres) :: guscdiff,usc_diff
7934       double precision, dimension (max_template) ::
7935      &           gtheta,dscdiff,uscdiffk,guscdiff2,guscdiff3,
7936      &           theta_diff
7937 c
7938
7939       include 'COMMON.SBRIDGE'
7940       include 'COMMON.CHAIN'
7941       include 'COMMON.GEO'
7942       include 'COMMON.DERIV'
7943       include 'COMMON.LOCAL'
7944       include 'COMMON.INTERACT'
7945       include 'COMMON.VAR'
7946       include 'COMMON.IOUNITS'
7947       include 'COMMON.MD'
7948       include 'COMMON.CONTROL'
7949 c
7950 c     From subroutine Econstr_back
7951 c
7952       include 'COMMON.NAMES'
7953       include 'COMMON.TIME1'
7954 c
7955
7956
7957       do i=1,max_template
7958         distancek(i)=9999999.9
7959       enddo
7960
7961
7962       odleg=0.0d0
7963
7964 c Pseudo-energy and gradient from homology restraints (MODELLER-like
7965 c function)
7966 C AL 5/2/14 - Introduce list of restraints
7967 c     write(iout,*) "waga_theta",waga_theta,"waga_d",waga_d
7968 #ifdef DEBUG
7969       write(iout,*) "------- dist restrs start -------"
7970 #endif
7971       do ii = link_start_homo,link_end_homo
7972          i = ires_homo(ii)
7973          j = jres_homo(ii)
7974          dij=dist(i,j)
7975 c        write (iout,*) "dij(",i,j,") =",dij
7976          nexl=0
7977          do k=1,constr_homology
7978 c           write(iout,*) ii,k,i,j,l_homo(k,ii),dij,odl(k,ii)
7979            if(.not.l_homo(k,ii)) then
7980              nexl=nexl+1
7981              cycle
7982            endif
7983            distance(k)=odl(k,ii)-dij
7984 c          write (iout,*) "distance(",k,") =",distance(k)
7985 c
7986 c          For Gaussian-type Urestr
7987 c
7988            distancek(k)=0.5d0*distance(k)**2*sigma_odl(k,ii) ! waga_dist rmvd from Gaussian argument
7989 c          write (iout,*) "sigma_odl(",k,ii,") =",sigma_odl(k,ii)
7990 c          write (iout,*) "distancek(",k,") =",distancek(k)
7991 c          distancek(k)=0.5d0*waga_dist*distance(k)**2*sigma_odl(k,ii)
7992 c
7993 c          For Lorentzian-type Urestr
7994 c
7995            if (waga_dist.lt.0.0d0) then
7996               sigma_odlir(k,ii)=dsqrt(1/sigma_odl(k,ii))
7997               distancek(k)=distance(k)**2/(sigma_odlir(k,ii)*
7998      &                     (distance(k)**2+sigma_odlir(k,ii)**2))
7999            endif
8000          enddo
8001
8002 c         min_odl=minval(distancek)
8003          do kk=1,constr_homology
8004           if(l_homo(kk,ii)) then
8005             min_odl=distancek(kk)
8006             exit
8007           endif
8008          enddo
8009          do kk=1,constr_homology
8010           if(l_homo(kk,ii) .and. distancek(kk).lt.min_odl)
8011      &              min_odl=distancek(kk)
8012          enddo
8013
8014 c        write (iout,* )"min_odl",min_odl
8015 #ifdef DEBUG
8016          write (iout,*) "ij dij",i,j,dij
8017          write (iout,*) "distance",(distance(k),k=1,constr_homology)
8018          write (iout,*) "distancek",(distancek(k),k=1,constr_homology)
8019          write (iout,* )"min_odl",min_odl
8020 #endif
8021 #ifdef OLDRESTR
8022          odleg2=0.0d0
8023 #else
8024          if (waga_dist.ge.0.0d0) then
8025            odleg2=nexl
8026          else
8027            odleg2=0.0d0
8028          endif
8029 #endif
8030          do k=1,constr_homology
8031 c Nie wiem po co to liczycie jeszcze raz!
8032 c            odleg3=-waga_dist(iset)*((distance(i,j,k)**2)/
8033 c     &              (2*(sigma_odl(i,j,k))**2))
8034            if(.not.l_homo(k,ii)) cycle
8035            if (waga_dist.ge.0.0d0) then
8036 c
8037 c          For Gaussian-type Urestr
8038 c
8039             godl(k)=dexp(-distancek(k)+min_odl)
8040             odleg2=odleg2+godl(k)
8041 c
8042 c          For Lorentzian-type Urestr
8043 c
8044            else
8045             odleg2=odleg2+distancek(k)
8046            endif
8047
8048 ccc       write(iout,779) i,j,k, "odleg2=",odleg2, "odleg3=", odleg3,
8049 ccc     & "dEXP(odleg3)=", dEXP(odleg3),"distance(i,j,k)^2=",
8050 ccc     & distance(i,j,k)**2, "dist(i+1,j+1)=", dist(i+1,j+1),
8051 ccc     & "sigma_odl(i,j,k)=", sigma_odl(i,j,k)
8052
8053          enddo
8054 c        write (iout,*) "godl",(godl(k),k=1,constr_homology) ! exponents
8055 c        write (iout,*) "ii i j",ii,i,j," odleg2",odleg2 ! sum of exps
8056 #ifdef DEBUG
8057          write (iout,*) "godl",(godl(k),k=1,constr_homology) ! exponents
8058          write (iout,*) "ii i j",ii,i,j," odleg2",odleg2 ! sum of exps
8059 #endif
8060            if (waga_dist.ge.0.0d0) then
8061 c
8062 c          For Gaussian-type Urestr
8063 c
8064               odleg=odleg-dLOG(odleg2/constr_homology)+min_odl
8065 c
8066 c          For Lorentzian-type Urestr
8067 c
8068            else
8069               odleg=odleg+odleg2/constr_homology
8070            endif
8071 c
8072 c        write (iout,*) "odleg",odleg ! sum of -ln-s
8073 c Gradient
8074 c
8075 c          For Gaussian-type Urestr
8076 c
8077          if (waga_dist.ge.0.0d0) sum_godl=odleg2
8078          sum_sgodl=0.0d0
8079          do k=1,constr_homology
8080 c            godl=dexp(((-(distance(i,j,k)**2)/(2*(sigma_odl(i,j,k))**2))
8081 c     &           *waga_dist)+min_odl
8082 c          sgodl=-godl(k)*distance(k)*sigma_odl(k,ii)*waga_dist
8083 c
8084          if(.not.l_homo(k,ii)) cycle
8085          if (waga_dist.ge.0.0d0) then
8086 c          For Gaussian-type Urestr
8087 c
8088            sgodl=-godl(k)*distance(k)*sigma_odl(k,ii) ! waga_dist rmvd
8089 c
8090 c          For Lorentzian-type Urestr
8091 c
8092          else
8093            sgodl=-2*sigma_odlir(k,ii)*(distance(k)/(distance(k)**2+
8094      &           sigma_odlir(k,ii)**2)**2)
8095          endif
8096            sum_sgodl=sum_sgodl+sgodl
8097
8098 c            sgodl2=sgodl2+sgodl
8099 c      write(iout,*) i, j, k, distance(i,j,k), "W GRADIENCIE1"
8100 c      write(iout,*) "constr_homology=",constr_homology
8101 c      write(iout,*) i, j, k, "TEST K"
8102          enddo
8103          if (waga_dist.ge.0.0d0) then
8104 c
8105 c          For Gaussian-type Urestr
8106 c
8107             grad_odl3=waga_homology(iset)*waga_dist
8108      &                *sum_sgodl/(sum_godl*dij)
8109 c
8110 c          For Lorentzian-type Urestr
8111 c
8112          else
8113 c Original grad expr modified by analogy w Gaussian-type Urestr grad
8114 c           grad_odl3=-waga_homology(iset)*waga_dist*sum_sgodl
8115             grad_odl3=-waga_homology(iset)*waga_dist*
8116      &                sum_sgodl/(constr_homology*dij)
8117          endif
8118 c
8119 c        grad_odl3=sum_sgodl/(sum_godl*dij)
8120
8121
8122 c      write(iout,*) i, j, k, distance(i,j,k), "W GRADIENCIE2"
8123 c      write(iout,*) (distance(i,j,k)**2), (2*(sigma_odl(i,j,k))**2),
8124 c     &              (-(distance(i,j,k)**2)/(2*(sigma_odl(i,j,k))**2))
8125
8126 ccc      write(iout,*) godl, sgodl, grad_odl3
8127
8128 c          grad_odl=grad_odl+grad_odl3
8129
8130          do jik=1,3
8131             ggodl=grad_odl3*(c(jik,i)-c(jik,j))
8132 ccc      write(iout,*) c(jik,i+1), c(jik,j+1), (c(jik,i+1)-c(jik,j+1))
8133 ccc      write(iout,746) "GRAD_ODL_1", i, j, jik, ggodl,
8134 ccc     &              ghpbc(jik,i+1), ghpbc(jik,j+1)
8135             ghpbc(jik,i)=ghpbc(jik,i)+ggodl
8136             ghpbc(jik,j)=ghpbc(jik,j)-ggodl
8137 ccc      write(iout,746) "GRAD_ODL_2", i, j, jik, ggodl,
8138 ccc     &              ghpbc(jik,i+1), ghpbc(jik,j+1)
8139 c         if (i.eq.25.and.j.eq.27) then
8140 c         write(iout,*) "jik",jik,"i",i,"j",j
8141 c         write(iout,*) "sum_sgodl",sum_sgodl,"sgodl",sgodl
8142 c         write(iout,*) "grad_odl3",grad_odl3
8143 c         write(iout,*) "c(",jik,i,")",c(jik,i),"c(",jik,j,")",c(jik,j)
8144 c         write(iout,*) "ggodl",ggodl
8145 c         write(iout,*) "ghpbc(",jik,i,")",
8146 c     &                 ghpbc(jik,i),"ghpbc(",jik,j,")",
8147 c     &                 ghpbc(jik,j)
8148 c         endif
8149          enddo
8150 ccc       write(iout,778)"TEST: odleg2=", odleg2, "DLOG(odleg2)=",
8151 ccc     & dLOG(odleg2),"-odleg=", -odleg
8152
8153       enddo ! ii-loop for dist
8154 #ifdef DEBUG
8155       write(iout,*) "------- dist restrs end -------"
8156 c     if (waga_angle.eq.1.0d0 .or. waga_theta.eq.1.0d0 .or.
8157 c    &     waga_d.eq.1.0d0) call sum_gradient
8158 #endif
8159 c Pseudo-energy and gradient from dihedral-angle restraints from
8160 c homology templates
8161 c      write (iout,*) "End of distance loop"
8162 c      call flush(iout)
8163       kat=0.0d0
8164 c      write (iout,*) idihconstr_start_homo,idihconstr_end_homo
8165 #ifdef DEBUG
8166       write(iout,*) "------- dih restrs start -------"
8167       do i=idihconstr_start_homo,idihconstr_end_homo
8168         write (iout,*) "gloc_init(",i,icg,")",gloc(i,icg)
8169       enddo
8170 #endif
8171       do i=idihconstr_start_homo,idihconstr_end_homo
8172         kat2=0.0d0
8173 c        betai=beta(i,i+1,i+2,i+3)
8174         betai = phi(i)
8175 c       write (iout,*) "betai =",betai
8176         do k=1,constr_homology
8177           dih_diff(k)=pinorm(dih(k,i)-betai)
8178 cd          write (iout,'(a8,2i4,2f15.8)') "dih_diff",i,k,dih_diff(k)
8179 cd     &                  ,sigma_dih(k,i)
8180 c          if (dih_diff(i,k).gt.3.14159) dih_diff(i,k)=
8181 c     &                                   -(6.28318-dih_diff(i,k))
8182 c          if (dih_diff(i,k).lt.-3.14159) dih_diff(i,k)=
8183 c     &                                   6.28318+dih_diff(i,k)
8184 #ifdef OLD_DIHED
8185           kat3=-0.5d0*dih_diff(k)**2*sigma_dih(k,i) ! waga_angle rmvd from Gaussian argument
8186 #else
8187           kat3=(dcos(dih_diff(k))-1)*sigma_dih(k,i) ! waga_angle rmvd from Gaussian argument
8188 #endif
8189 c         kat3=-0.5d0*waga_angle*dih_diff(k)**2*sigma_dih(k,i)
8190           gdih(k)=dexp(kat3)
8191           kat2=kat2+gdih(k)
8192 c          write(iout,*) "kat2=", kat2, "exp(kat3)=", exp(kat3)
8193 c          write(*,*)""
8194         enddo
8195 c       write (iout,*) "gdih",(gdih(k),k=1,constr_homology) ! exps
8196 c       write (iout,*) "i",i," betai",betai," kat2",kat2 ! sum of exps
8197 #ifdef DEBUG
8198         write (iout,*) "i",i," betai",betai," kat2",kat2
8199         write (iout,*) "gdih",(gdih(k),k=1,constr_homology)
8200 #endif
8201         if (kat2.le.1.0d-14) cycle
8202         kat=kat-dLOG(kat2/constr_homology)
8203 c       write (iout,*) "kat",kat ! sum of -ln-s
8204
8205 ccc       write(iout,778)"TEST: kat2=", kat2, "DLOG(kat2)=",
8206 ccc     & dLOG(kat2), "-kat=", -kat
8207
8208 c ----------------------------------------------------------------------
8209 c Gradient
8210 c ----------------------------------------------------------------------
8211
8212         sum_gdih=kat2
8213         sum_sgdih=0.0d0
8214         do k=1,constr_homology
8215 #ifdef OLD_DIHED
8216           sgdih=-gdih(k)*dih_diff(k)*sigma_dih(k,i)  ! waga_angle rmvd
8217 #else
8218           sgdih=-gdih(k)*dsin(dih_diff(k))*sigma_dih(k,i)  ! waga_angle rmvd
8219 #endif
8220 c         sgdih=-gdih(k)*dih_diff(k)*sigma_dih(k,i)*waga_angle
8221           sum_sgdih=sum_sgdih+sgdih
8222         enddo
8223 c       grad_dih3=sum_sgdih/sum_gdih
8224         grad_dih3=waga_homology(iset)*waga_angle*sum_sgdih/sum_gdih
8225
8226 c      write(iout,*)i,k,gdih,sgdih,beta(i+1,i+2,i+3,i+4),grad_dih3
8227 ccc      write(iout,747) "GRAD_KAT_1", i, nphi, icg, grad_dih3,
8228 ccc     & gloc(nphi+i-3,icg)
8229         gloc(i-3,icg)=gloc(i-3,icg)+grad_dih3
8230 c        if (i.eq.25) then
8231 c        write(iout,*) "i",i,"icg",icg,"gloc(",i,icg,")",gloc(i,icg)
8232 c        endif
8233 ccc      write(iout,747) "GRAD_KAT_2", i, nphi, icg, grad_dih3,
8234 ccc     & gloc(nphi+i-3,icg)
8235
8236       enddo ! i-loop for dih
8237 #ifdef DEBUG
8238       write(iout,*) "------- dih restrs end -------"
8239 #endif
8240
8241 c Pseudo-energy and gradient for theta angle restraints from
8242 c homology templates
8243 c FP 01/15 - inserted from econstr_local_test.F, loop structure
8244 c adapted
8245
8246 c
8247 c     For constr_homology reference structures (FP)
8248 c
8249 c     Uconst_back_tot=0.0d0
8250       Eval=0.0d0
8251       Erot=0.0d0
8252 c     Econstr_back legacy
8253       do i=1,nres
8254 c     do i=ithet_start,ithet_end
8255        dutheta(i)=0.0d0
8256 c     enddo
8257 c     do i=loc_start,loc_end
8258         do j=1,3
8259           duscdiff(j,i)=0.0d0
8260           duscdiffx(j,i)=0.0d0
8261         enddo
8262       enddo
8263 c
8264 c     do iref=1,nref
8265 c     write (iout,*) "ithet_start =",ithet_start,"ithet_end =",ithet_end
8266 c     write (iout,*) "waga_theta",waga_theta
8267       if (waga_theta.gt.0.0d0) then
8268 #ifdef DEBUG
8269       write (iout,*) "usampl",usampl
8270       write(iout,*) "------- theta restrs start -------"
8271 c     do i=ithet_start,ithet_end
8272 c       write (iout,*) "gloc_init(",nphi+i,icg,")",gloc(nphi+i,icg)
8273 c     enddo
8274 #endif
8275 c     write (iout,*) "maxres",maxres,"nres",nres
8276
8277       do i=ithet_start,ithet_end
8278 c
8279 c     do i=1,nfrag_back
8280 c       ii = ifrag_back(2,i,iset)-ifrag_back(1,i,iset)
8281 c
8282 c Deviation of theta angles wrt constr_homology ref structures
8283 c
8284         utheta_i=0.0d0 ! argument of Gaussian for single k
8285         gutheta_i=0.0d0 ! Sum of Gaussians over constr_homology ref structures
8286 c       do j=ifrag_back(1,i,iset)+2,ifrag_back(2,i,iset) ! original loop
8287 c       over residues in a fragment
8288 c       write (iout,*) "theta(",i,")=",theta(i)
8289         do k=1,constr_homology
8290 c
8291 c         dtheta_i=theta(j)-thetaref(j,iref)
8292 c         dtheta_i=thetaref(k,i)-theta(i) ! original form without indexing
8293           theta_diff(k)=thetatpl(k,i)-theta(i)
8294 cd          write (iout,'(a8,2i4,2f15.8)') "theta_diff",i,k,theta_diff(k)
8295 cd     &                  ,sigma_theta(k,i)
8296
8297 c
8298           utheta_i=-0.5d0*theta_diff(k)**2*sigma_theta(k,i) ! waga_theta rmvd from Gaussian argument
8299 c         utheta_i=-0.5d0*waga_theta*theta_diff(k)**2*sigma_theta(k,i) ! waga_theta?
8300           gtheta(k)=dexp(utheta_i) ! + min_utheta_i?
8301           gutheta_i=gutheta_i+gtheta(k)  ! Sum of Gaussians (pk)
8302 c         Gradient for single Gaussian restraint in subr Econstr_back
8303 c         dutheta(j-2)=dutheta(j-2)+wfrag_back(1,i,iset)*dtheta_i/(ii-1)
8304 c
8305         enddo
8306 c       write (iout,*) "gtheta",(gtheta(k),k=1,constr_homology) ! exps
8307 c       write (iout,*) "i",i," gutheta_i",gutheta_i ! sum of exps
8308
8309 c
8310 c         Gradient for multiple Gaussian restraint
8311         sum_gtheta=gutheta_i
8312         sum_sgtheta=0.0d0
8313         do k=1,constr_homology
8314 c        New generalized expr for multiple Gaussian from Econstr_back
8315          sgtheta=-gtheta(k)*theta_diff(k)*sigma_theta(k,i) ! waga_theta rmvd
8316 c
8317 c        sgtheta=-gtheta(k)*theta_diff(k)*sigma_theta(k,i)*waga_theta ! right functional form?
8318           sum_sgtheta=sum_sgtheta+sgtheta ! cum variable
8319         enddo
8320 c       Final value of gradient using same var as in Econstr_back
8321         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)
8322      &      +sum_sgtheta/sum_gtheta*waga_theta
8323      &               *waga_homology(iset)
8324 c        dutheta(i-2)=sum_sgtheta/sum_gtheta*waga_theta
8325 c     &               *waga_homology(iset)
8326 c       dutheta(i)=sum_sgtheta/sum_gtheta
8327 c
8328 c       Uconst_back=Uconst_back+waga_theta*utheta(i) ! waga_theta added as weight
8329         Eval=Eval-dLOG(gutheta_i/constr_homology)
8330 c       write (iout,*) "utheta(",i,")=",utheta(i) ! -ln of sum of exps
8331 c       write (iout,*) "Uconst_back",Uconst_back ! sum of -ln-s
8332 c       Uconst_back=Uconst_back+utheta(i)
8333       enddo ! (i-loop for theta)
8334 #ifdef DEBUG
8335       write(iout,*) "------- theta restrs end -------"
8336 #endif
8337       endif
8338 c
8339 c Deviation of local SC geometry
8340 c
8341 c Separation of two i-loops (instructed by AL - 11/3/2014)
8342 c
8343 c     write (iout,*) "loc_start =",loc_start,"loc_end =",loc_end
8344 c     write (iout,*) "waga_d",waga_d
8345
8346 #ifdef DEBUG
8347       write(iout,*) "------- SC restrs start -------"
8348       write (iout,*) "Initial duscdiff,duscdiffx"
8349       do i=loc_start,loc_end
8350         write (iout,*) i,(duscdiff(jik,i),jik=1,3),
8351      &                 (duscdiffx(jik,i),jik=1,3)
8352       enddo
8353 #endif
8354       do i=loc_start,loc_end
8355         usc_diff_i=0.0d0 ! argument of Gaussian for single k
8356         guscdiff(i)=0.0d0 ! Sum of Gaussians over constr_homology ref structures
8357 c       do j=ifrag_back(1,i,iset)+1,ifrag_back(2,i,iset)-1 ! Econstr_back legacy
8358 c       write(iout,*) "xxtab, yytab, zztab"
8359 c       write(iout,'(i5,3f8.2)') i,xxtab(i),yytab(i),zztab(i)
8360         do k=1,constr_homology
8361 c
8362           dxx=-xxtpl(k,i)+xxtab(i) ! Diff b/w x component of ith SC vector in model and kth ref str?
8363 c                                    Original sign inverted for calc of gradients (s. Econstr_back)
8364           dyy=-yytpl(k,i)+yytab(i) ! ibid y
8365           dzz=-zztpl(k,i)+zztab(i) ! ibid z
8366 c         write(iout,*) "dxx, dyy, dzz"
8367 cd          write(iout,'(2i5,4f8.2)') k,i,dxx,dyy,dzz,sigma_d(k,i)
8368 c
8369           usc_diff_i=-0.5d0*(dxx**2+dyy**2+dzz**2)*sigma_d(k,i)  ! waga_d rmvd from Gaussian argument
8370 c         usc_diff(i)=-0.5d0*waga_d*(dxx**2+dyy**2+dzz**2)*sigma_d(k,i) ! waga_d?
8371 c         uscdiffk(k)=usc_diff(i)
8372           guscdiff2(k)=dexp(usc_diff_i) ! without min_scdiff
8373 c          write(iout,*) "i",i," k",k," sigma_d",sigma_d(k,i),
8374 c     &       " guscdiff2",guscdiff2(k)
8375           guscdiff(i)=guscdiff(i)+guscdiff2(k)  !Sum of Gaussians (pk)
8376 c          write (iout,'(i5,6f10.5)') j,xxtab(j),yytab(j),zztab(j),
8377 c     &      xxref(j),yyref(j),zzref(j)
8378         enddo
8379 c
8380 c       Gradient
8381 c
8382 c       Generalized expression for multiple Gaussian acc to that for a single
8383 c       Gaussian in Econstr_back as instructed by AL (FP - 03/11/2014)
8384 c
8385 c       Original implementation
8386 c       sum_guscdiff=guscdiff(i)
8387 c
8388 c       sum_sguscdiff=0.0d0
8389 c       do k=1,constr_homology
8390 c          sguscdiff=-guscdiff2(k)*dscdiff(k)*sigma_d(k,i)*waga_d !waga_d?
8391 c          sguscdiff=-guscdiff3(k)*dscdiff(k)*sigma_d(k,i)*waga_d ! w min_uscdiff
8392 c          sum_sguscdiff=sum_sguscdiff+sguscdiff
8393 c       enddo
8394 c
8395 c       Implementation of new expressions for gradient (Jan. 2015)
8396 c
8397 c       grad_uscdiff=sum_sguscdiff/(sum_guscdiff*dtab) !?
8398         do k=1,constr_homology
8399 c
8400 c       New calculation of dxx, dyy, and dzz corrected by AL (07/11), was missing and wrong
8401 c       before. Now the drivatives should be correct
8402 c
8403           dxx=-xxtpl(k,i)+xxtab(i) ! Diff b/w x component of ith SC vector in model and kth ref str?
8404 c                                  Original sign inverted for calc of gradients (s. Econstr_back)
8405           dyy=-yytpl(k,i)+yytab(i) ! ibid y
8406           dzz=-zztpl(k,i)+zztab(i) ! ibid z
8407 c
8408 c         New implementation
8409 c
8410           sum_guscdiff=guscdiff2(k)*!(dsqrt(dxx*dxx+dyy*dyy+dzz*dzz))* -> wrong!
8411      &                 sigma_d(k,i) ! for the grad wrt r'
8412 c         sum_sguscdiff=sum_sguscdiff+sum_guscdiff
8413 c
8414 c
8415 c        New implementation
8416          sum_guscdiff = waga_homology(iset)*waga_d*sum_guscdiff
8417          do jik=1,3
8418             duscdiff(jik,i-1)=duscdiff(jik,i-1)+
8419      &      sum_guscdiff*(dXX_C1tab(jik,i)*dxx+
8420      &      dYY_C1tab(jik,i)*dyy+dZZ_C1tab(jik,i)*dzz)/guscdiff(i)
8421             duscdiff(jik,i)=duscdiff(jik,i)+
8422      &      sum_guscdiff*(dXX_Ctab(jik,i)*dxx+
8423      &      dYY_Ctab(jik,i)*dyy+dZZ_Ctab(jik,i)*dzz)/guscdiff(i)
8424             duscdiffx(jik,i)=duscdiffx(jik,i)+
8425      &      sum_guscdiff*(dXX_XYZtab(jik,i)*dxx+
8426      &      dYY_XYZtab(jik,i)*dyy+dZZ_XYZtab(jik,i)*dzz)/guscdiff(i)
8427 c
8428 #ifdef DEBUG
8429              write(iout,*) "jik",jik,"i",i
8430              write(iout,*) "dxx, dyy, dzz"
8431              write(iout,'(2i5,3f8.2)') k,i,dxx,dyy,dzz
8432              write(iout,*) "guscdiff2(",k,")",guscdiff2(k)
8433 c            write(iout,*) "sum_sguscdiff",sum_sguscdiff
8434 cc           write(iout,*) "dXX_Ctab(",jik,i,")",dXX_Ctab(jik,i)
8435 c            write(iout,*) "dYY_Ctab(",jik,i,")",dYY_Ctab(jik,i)
8436 c            write(iout,*) "dZZ_Ctab(",jik,i,")",dZZ_Ctab(jik,i)
8437 c            write(iout,*) "dXX_C1tab(",jik,i,")",dXX_C1tab(jik,i)
8438 c            write(iout,*) "dYY_C1tab(",jik,i,")",dYY_C1tab(jik,i)
8439 c            write(iout,*) "dZZ_C1tab(",jik,i,")",dZZ_C1tab(jik,i)
8440 c            write(iout,*) "dXX_XYZtab(",jik,i,")",dXX_XYZtab(jik,i)
8441 c            write(iout,*) "dYY_XYZtab(",jik,i,")",dYY_XYZtab(jik,i)
8442 c            write(iout,*) "dZZ_XYZtab(",jik,i,")",dZZ_XYZtab(jik,i)
8443 c            write(iout,*) "duscdiff(",jik,i-1,")",duscdiff(jik,i-1)
8444 c            write(iout,*) "duscdiff(",jik,i,")",duscdiff(jik,i)
8445 c            write(iout,*) "duscdiffx(",jik,i,")",duscdiffx(jik,i)
8446 c            endif
8447 #endif
8448          enddo
8449         enddo
8450 c
8451 c       uscdiff(i)=-dLOG(guscdiff(i)/(ii-1))      ! Weighting by (ii-1) required?
8452 c        usc_diff(i)=-dLOG(guscdiff(i)/constr_homology) ! + min_uscdiff ?
8453 c
8454 c        write (iout,*) i," uscdiff",uscdiff(i)
8455 c
8456 c Put together deviations from local geometry
8457
8458 c       Uconst_back=Uconst_back+wfrag_back(1,i,iset)*utheta(i)+
8459 c      &            wfrag_back(3,i,iset)*uscdiff(i)
8460         Erot=Erot-dLOG(guscdiff(i)/constr_homology)
8461 c       write (iout,*) "usc_diff(",i,")=",usc_diff(i) ! -ln of sum of exps
8462 c       write (iout,*) "Uconst_back",Uconst_back ! cum sum of -ln-s
8463 c       Uconst_back=Uconst_back+usc_diff(i)
8464 c
8465 c     Gradient of multiple Gaussian restraint (FP - 04/11/2014 - right?)
8466 c
8467 c     New implment: multiplied by sum_sguscdiff
8468 c
8469
8470       enddo ! (i-loop for dscdiff)
8471
8472 c      endif
8473
8474 #ifdef DEBUG
8475       write(iout,*) "------- SC restrs end -------"
8476         write (iout,*) "------ After SC loop in e_modeller ------"
8477         do i=loc_start,loc_end
8478          write (iout,*) "i",i," gradc",(gradc(j,i,icg),j=1,3)
8479          write (iout,*) "i",i," gradx",(gradx(j,i,icg),j=1,3)
8480         enddo
8481       if (waga_theta.eq.1.0d0) then
8482       write (iout,*) "in e_modeller after SC restr end: dutheta"
8483       do i=ithet_start,ithet_end
8484         write (iout,*) i,dutheta(i)
8485       enddo
8486       endif
8487       if (waga_d.eq.1.0d0) then
8488       write (iout,*) "e_modeller after SC loop: duscdiff/x"
8489       do i=1,nres
8490         write (iout,*) i,(duscdiff(j,i),j=1,3)
8491         write (iout,*) i,(duscdiffx(j,i),j=1,3)
8492       enddo
8493       endif
8494 #endif
8495
8496 c Total energy from homology restraints
8497 #ifdef DEBUG
8498       write (iout,*) "odleg",odleg," kat",kat
8499 #endif
8500 c
8501 c Addition of energy of theta angle and SC local geom over constr_homologs ref strs
8502 c
8503 c     ehomology_constr=odleg+kat
8504 c
8505 c     For Lorentzian-type Urestr
8506 c
8507
8508       if (waga_dist.ge.0.0d0) then
8509 c
8510 c          For Gaussian-type Urestr
8511 c
8512         ehomology_constr=(waga_dist*odleg+waga_angle*kat+
8513      &              waga_theta*Eval+waga_d*Erot)*waga_homology(iset)
8514 c     write (iout,*) "ehomology_constr=",ehomology_constr
8515       else
8516 c
8517 c          For Lorentzian-type Urestr
8518 c
8519         ehomology_constr=(-waga_dist*odleg+waga_angle*kat+
8520      &              waga_theta*Eval+waga_d*Erot)*waga_homology(iset)
8521 c     write (iout,*) "ehomology_constr=",ehomology_constr
8522       endif
8523 #ifdef DEBUG
8524       write (iout,*) "odleg",waga_dist,odleg," kat",waga_angle,kat,
8525      & "Eval",waga_theta,eval,
8526      &   "Erot",waga_d,Erot
8527       write (iout,*) "ehomology_constr",ehomology_constr
8528 #endif
8529       return
8530 c
8531 c FP 01/15 end
8532 c
8533   748 format(a8,f12.3,a6,f12.3,a7,f12.3)
8534   747 format(a12,i4,i4,i4,f8.3,f8.3)
8535   746 format(a12,i4,i4,i4,f8.3,f8.3,f8.3)
8536   778 format(a7,1X,f10.3,1X,a4,1X,f10.3,1X,a5,1X,f10.3)
8537   779 format(i3,1X,i3,1X,i2,1X,a7,1X,f7.3,1X,a7,1X,f7.3,1X,a13,1X,
8538      &       f7.3,1X,a17,1X,f9.3,1X,a10,1X,f8.3,1X,a10,1X,f8.3)
8539       end
8540 c----------------------------------------------------------------------------
8541 C The rigorous attempt to derive energy function
8542       subroutine ebend_kcc(etheta)
8543
8544       implicit real*8 (a-h,o-z)
8545       include 'DIMENSIONS'
8546       include 'COMMON.VAR'
8547       include 'COMMON.GEO'
8548       include 'COMMON.LOCAL'
8549       include 'COMMON.TORSION'
8550       include 'COMMON.INTERACT'
8551       include 'COMMON.DERIV'
8552       include 'COMMON.CHAIN'
8553       include 'COMMON.NAMES'
8554       include 'COMMON.IOUNITS'
8555       include 'COMMON.FFIELD'
8556       include 'COMMON.TORCNSTR'
8557       include 'COMMON.CONTROL'
8558       logical lprn
8559       double precision thybt1(maxang_kcc)
8560 C Set lprn=.true. for debugging
8561       lprn=energy_dec
8562 c     lprn=.true.
8563 C      print *,"wchodze kcc"
8564       if (lprn) write (iout,*) "ebend_kcc tor_mode",tor_mode
8565       etheta=0.0D0
8566       do i=ithet_start,ithet_end
8567 c        print *,i,itype(i-1),itype(i),itype(i-2)
8568         if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
8569      &  .or.itype(i).eq.ntyp1) cycle
8570         iti=iabs(itortyp(itype(i-1)))
8571         sinthet=dsin(theta(i))
8572         costhet=dcos(theta(i))
8573         do j=1,nbend_kcc_Tb(iti)
8574           thybt1(j)=v1bend_chyb(j,iti)
8575         enddo
8576         sumth1thyb=v1bend_chyb(0,iti)+
8577      &    tschebyshev(1,nbend_kcc_Tb(iti),thybt1(1),costhet)
8578         if (lprn) write (iout,*) i-1,itype(i-1),iti,theta(i)*rad2deg,
8579      &    sumth1thyb
8580         ihelp=nbend_kcc_Tb(iti)-1
8581         gradthybt1=gradtschebyshev(0,ihelp,thybt1(1),costhet)
8582         etheta=etheta+sumth1thyb
8583 C        print *,sumth1thyb,gradthybt1,sinthet*(-0.5d0)
8584         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)-wang*gradthybt1*sinthet
8585       enddo
8586       return
8587       end
8588 c-------------------------------------------------------------------------------------
8589       subroutine etheta_constr(ethetacnstr)
8590
8591       implicit real*8 (a-h,o-z)
8592       include 'DIMENSIONS'
8593       include 'COMMON.VAR'
8594       include 'COMMON.GEO'
8595       include 'COMMON.LOCAL'
8596       include 'COMMON.TORSION'
8597       include 'COMMON.INTERACT'
8598       include 'COMMON.DERIV'
8599       include 'COMMON.CHAIN'
8600       include 'COMMON.NAMES'
8601       include 'COMMON.IOUNITS'
8602       include 'COMMON.FFIELD'
8603       include 'COMMON.TORCNSTR'
8604       include 'COMMON.CONTROL'
8605       ethetacnstr=0.0d0
8606 C      print *,ithetaconstr_start,ithetaconstr_end,"TU"
8607       do i=ithetaconstr_start,ithetaconstr_end
8608         itheta=itheta_constr(i)
8609         thetiii=theta(itheta)
8610         difi=pinorm(thetiii-theta_constr0(i))
8611         if (difi.gt.theta_drange(i)) then
8612           difi=difi-theta_drange(i)
8613           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
8614           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
8615      &    +for_thet_constr(i)*difi**3
8616         else if (difi.lt.-drange(i)) then
8617           difi=difi+drange(i)
8618           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
8619           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
8620      &    +for_thet_constr(i)*difi**3
8621         else
8622           difi=0.0
8623         endif
8624        if (energy_dec) then
8625         write (iout,'(a6,2i5,4f8.3,2e14.5)') "ethetc",
8626      &    i,itheta,rad2deg*thetiii,
8627      &    rad2deg*theta_constr0(i),  rad2deg*theta_drange(i),
8628      &    rad2deg*difi,0.25d0*for_thet_constr(i)*difi**4,
8629      &    gloc(itheta+nphi-2,icg)
8630         endif
8631       enddo
8632       return
8633       end
8634 c------------------------------------------------------------------------------
8635       subroutine eback_sc_corr(esccor)
8636 c 7/21/2007 Correlations between the backbone-local and side-chain-local
8637 c        conformational states; temporarily implemented as differences
8638 c        between UNRES torsional potentials (dependent on three types of
8639 c        residues) and the torsional potentials dependent on all 20 types
8640 c        of residues computed from AM1  energy surfaces of terminally-blocked
8641 c        amino-acid residues.
8642       implicit real*8 (a-h,o-z)
8643       include 'DIMENSIONS'
8644       include 'COMMON.VAR'
8645       include 'COMMON.GEO'
8646       include 'COMMON.LOCAL'
8647       include 'COMMON.TORSION'
8648       include 'COMMON.SCCOR'
8649       include 'COMMON.INTERACT'
8650       include 'COMMON.DERIV'
8651       include 'COMMON.CHAIN'
8652       include 'COMMON.NAMES'
8653       include 'COMMON.IOUNITS'
8654       include 'COMMON.FFIELD'
8655       include 'COMMON.CONTROL'
8656       logical lprn
8657 C Set lprn=.true. for debugging
8658       lprn=.false.
8659 c      lprn=.true.
8660 c      write (iout,*) "EBACK_SC_COR",itau_start,itau_end
8661       esccor=0.0D0
8662       do i=itau_start,itau_end
8663         if ((itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)) cycle
8664         esccor_ii=0.0D0
8665         isccori=isccortyp(itype(i-2))
8666         isccori1=isccortyp(itype(i-1))
8667 c      write (iout,*) "EBACK_SC_COR",i,nterm_sccor(isccori,isccori1)
8668         phii=phi(i)
8669         do intertyp=1,3 !intertyp
8670 cc Added 09 May 2012 (Adasko)
8671 cc  Intertyp means interaction type of backbone mainchain correlation:
8672 c   1 = SC...Ca...Ca...Ca
8673 c   2 = Ca...Ca...Ca...SC
8674 c   3 = SC...Ca...Ca...SCi
8675         gloci=0.0D0
8676         if (((intertyp.eq.3).and.((itype(i-2).eq.10).or.
8677      &      (itype(i-1).eq.10).or.(itype(i-2).eq.ntyp1).or.
8678      &      (itype(i-1).eq.ntyp1)))
8679      &    .or. ((intertyp.eq.1).and.((itype(i-2).eq.10)
8680      &     .or.(itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)
8681      &     .or.(itype(i).eq.ntyp1)))
8682      &    .or.((intertyp.eq.2).and.((itype(i-1).eq.10).or.
8683      &      (itype(i-1).eq.ntyp1).or.(itype(i-2).eq.ntyp1).or.
8684      &      (itype(i-3).eq.ntyp1)))) cycle
8685         if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1).eq.ntyp1)) cycle
8686         if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres).eq.ntyp1))
8687      & cycle
8688        do j=1,nterm_sccor(isccori,isccori1)
8689           v1ij=v1sccor(j,intertyp,isccori,isccori1)
8690           v2ij=v2sccor(j,intertyp,isccori,isccori1)
8691           cosphi=dcos(j*tauangle(intertyp,i))
8692           sinphi=dsin(j*tauangle(intertyp,i))
8693           esccor=esccor+v1ij*cosphi+v2ij*sinphi
8694           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
8695         enddo
8696 c      write (iout,*) "EBACK_SC_COR",i,v1ij*cosphi+v2ij*sinphi,intertyp
8697         gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci
8698         if (lprn)
8699      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
8700      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,isccori,isccori1,
8701      &  (v1sccor(j,intertyp,isccori,isccori1),j=1,6)
8702      & ,(v2sccor(j,intertyp,isccori,isccori1),j=1,6)
8703         gsccor_loc(i-3)=gsccor_loc(i-3)+gloci
8704        enddo !intertyp
8705       enddo
8706
8707       return
8708       end
8709 c----------------------------------------------------------------------------
8710       subroutine multibody(ecorr)
8711 C This subroutine calculates multi-body contributions to energy following
8712 C the idea of Skolnick et al. If side chains I and J make a contact and
8713 C at the same time side chains I+1 and J+1 make a contact, an extra
8714 C contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
8715       implicit real*8 (a-h,o-z)
8716       include 'DIMENSIONS'
8717       include 'COMMON.IOUNITS'
8718       include 'COMMON.DERIV'
8719       include 'COMMON.INTERACT'
8720       include 'COMMON.CONTACTS'
8721       double precision gx(3),gx1(3)
8722       logical lprn
8723
8724 C Set lprn=.true. for debugging
8725       lprn=.false.
8726
8727       if (lprn) then
8728         write (iout,'(a)') 'Contact function values:'
8729         do i=nnt,nct-2
8730           write (iout,'(i2,20(1x,i2,f10.5))')
8731      &        i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
8732         enddo
8733       endif
8734       ecorr=0.0D0
8735       do i=nnt,nct
8736         do j=1,3
8737           gradcorr(j,i)=0.0D0
8738           gradxorr(j,i)=0.0D0
8739         enddo
8740       enddo
8741       do i=nnt,nct-2
8742
8743         DO ISHIFT = 3,4
8744
8745         i1=i+ishift
8746         num_conti=num_cont(i)
8747         num_conti1=num_cont(i1)
8748         do jj=1,num_conti
8749           j=jcont(jj,i)
8750           do kk=1,num_conti1
8751             j1=jcont(kk,i1)
8752             if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
8753 cd          write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
8754 cd   &                   ' ishift=',ishift
8755 C Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
8756 C The system gains extra energy.
8757               ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
8758             endif   ! j1==j+-ishift
8759           enddo     ! kk
8760         enddo       ! jj
8761
8762         ENDDO ! ISHIFT
8763
8764       enddo         ! i
8765       return
8766       end
8767 c------------------------------------------------------------------------------
8768       double precision function esccorr(i,j,k,l,jj,kk)
8769       implicit real*8 (a-h,o-z)
8770       include 'DIMENSIONS'
8771       include 'COMMON.IOUNITS'
8772       include 'COMMON.DERIV'
8773       include 'COMMON.INTERACT'
8774       include 'COMMON.CONTACTS'
8775       include 'COMMON.SHIELD'
8776       double precision gx(3),gx1(3)
8777       logical lprn
8778       lprn=.false.
8779       eij=facont(jj,i)
8780       ekl=facont(kk,k)
8781 cd    write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
8782 C Calculate the multi-body contribution to energy.
8783 C Calculate multi-body contributions to the gradient.
8784 cd    write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
8785 cd   & k,l,(gacont(m,kk,k),m=1,3)
8786       do m=1,3
8787         gx(m) =ekl*gacont(m,jj,i)
8788         gx1(m)=eij*gacont(m,kk,k)
8789         gradxorr(m,i)=gradxorr(m,i)-gx(m)
8790         gradxorr(m,j)=gradxorr(m,j)+gx(m)
8791         gradxorr(m,k)=gradxorr(m,k)-gx1(m)
8792         gradxorr(m,l)=gradxorr(m,l)+gx1(m)
8793       enddo
8794       do m=i,j-1
8795         do ll=1,3
8796           gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
8797         enddo
8798       enddo
8799       do m=k,l-1
8800         do ll=1,3
8801           gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
8802         enddo
8803       enddo
8804       esccorr=-eij*ekl
8805       return
8806       end
8807 c------------------------------------------------------------------------------
8808       subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
8809 C This subroutine calculates multi-body contributions to hydrogen-bonding
8810       implicit real*8 (a-h,o-z)
8811       include 'DIMENSIONS'
8812       include 'COMMON.IOUNITS'
8813 #ifdef MPI
8814       include "mpif.h"
8815       parameter (max_cont=maxconts)
8816       parameter (max_dim=26)
8817       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
8818       double precision zapas(max_dim,maxconts,max_fg_procs),
8819      &  zapas_recv(max_dim,maxconts,max_fg_procs)
8820       common /przechowalnia/ zapas
8821       integer status(MPI_STATUS_SIZE),req(maxconts*2),
8822      &  status_array(MPI_STATUS_SIZE,maxconts*2)
8823 #endif
8824       include 'COMMON.SETUP'
8825       include 'COMMON.FFIELD'
8826       include 'COMMON.DERIV'
8827       include 'COMMON.INTERACT'
8828       include 'COMMON.CONTACTS'
8829       include 'COMMON.CONTROL'
8830       include 'COMMON.LOCAL'
8831       double precision gx(3),gx1(3),time00
8832       logical lprn,ldone
8833
8834 C Set lprn=.true. for debugging
8835       lprn=.false.
8836 #ifdef MPI
8837       n_corr=0
8838       n_corr1=0
8839       if (nfgtasks.le.1) goto 30
8840       if (lprn) then
8841         write (iout,'(a)') 'Contact function values before RECEIVE:'
8842         do i=nnt,nct-2
8843           write (iout,'(2i3,50(1x,i2,f5.2))')
8844      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
8845      &    j=1,num_cont_hb(i))
8846         enddo
8847         call flush(iout)
8848       endif
8849       do i=1,ntask_cont_from
8850         ncont_recv(i)=0
8851       enddo
8852       do i=1,ntask_cont_to
8853         ncont_sent(i)=0
8854       enddo
8855 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
8856 c     & ntask_cont_to
8857 C Make the list of contacts to send to send to other procesors
8858 c      write (iout,*) "limits",max0(iturn4_end-1,iatel_s),iturn3_end
8859 c      call flush(iout)
8860       do i=iturn3_start,iturn3_end
8861 c        write (iout,*) "make contact list turn3",i," num_cont",
8862 c     &    num_cont_hb(i)
8863         call add_hb_contact(i,i+2,iturn3_sent_local(1,i))
8864       enddo
8865       do i=iturn4_start,iturn4_end
8866 c        write (iout,*) "make contact list turn4",i," num_cont",
8867 c     &   num_cont_hb(i)
8868         call add_hb_contact(i,i+3,iturn4_sent_local(1,i))
8869       enddo
8870       do ii=1,nat_sent
8871         i=iat_sent(ii)
8872 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
8873 c     &    num_cont_hb(i)
8874         do j=1,num_cont_hb(i)
8875         do k=1,4
8876           jjc=jcont_hb(j,i)
8877           iproc=iint_sent_local(k,jjc,ii)
8878 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
8879           if (iproc.gt.0) then
8880             ncont_sent(iproc)=ncont_sent(iproc)+1
8881             nn=ncont_sent(iproc)
8882             zapas(1,nn,iproc)=i
8883             zapas(2,nn,iproc)=jjc
8884             zapas(3,nn,iproc)=facont_hb(j,i)
8885             zapas(4,nn,iproc)=ees0p(j,i)
8886             zapas(5,nn,iproc)=ees0m(j,i)
8887             zapas(6,nn,iproc)=gacont_hbr(1,j,i)
8888             zapas(7,nn,iproc)=gacont_hbr(2,j,i)
8889             zapas(8,nn,iproc)=gacont_hbr(3,j,i)
8890             zapas(9,nn,iproc)=gacontm_hb1(1,j,i)
8891             zapas(10,nn,iproc)=gacontm_hb1(2,j,i)
8892             zapas(11,nn,iproc)=gacontm_hb1(3,j,i)
8893             zapas(12,nn,iproc)=gacontp_hb1(1,j,i)
8894             zapas(13,nn,iproc)=gacontp_hb1(2,j,i)
8895             zapas(14,nn,iproc)=gacontp_hb1(3,j,i)
8896             zapas(15,nn,iproc)=gacontm_hb2(1,j,i)
8897             zapas(16,nn,iproc)=gacontm_hb2(2,j,i)
8898             zapas(17,nn,iproc)=gacontm_hb2(3,j,i)
8899             zapas(18,nn,iproc)=gacontp_hb2(1,j,i)
8900             zapas(19,nn,iproc)=gacontp_hb2(2,j,i)
8901             zapas(20,nn,iproc)=gacontp_hb2(3,j,i)
8902             zapas(21,nn,iproc)=gacontm_hb3(1,j,i)
8903             zapas(22,nn,iproc)=gacontm_hb3(2,j,i)
8904             zapas(23,nn,iproc)=gacontm_hb3(3,j,i)
8905             zapas(24,nn,iproc)=gacontp_hb3(1,j,i)
8906             zapas(25,nn,iproc)=gacontp_hb3(2,j,i)
8907             zapas(26,nn,iproc)=gacontp_hb3(3,j,i)
8908           endif
8909         enddo
8910         enddo
8911       enddo
8912       if (lprn) then
8913       write (iout,*)
8914      &  "Numbers of contacts to be sent to other processors",
8915      &  (ncont_sent(i),i=1,ntask_cont_to)
8916       write (iout,*) "Contacts sent"
8917       do ii=1,ntask_cont_to
8918         nn=ncont_sent(ii)
8919         iproc=itask_cont_to(ii)
8920         write (iout,*) nn," contacts to processor",iproc,
8921      &   " of CONT_TO_COMM group"
8922         do i=1,nn
8923           write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
8924         enddo
8925       enddo
8926       call flush(iout)
8927       endif
8928       CorrelType=477
8929       CorrelID=fg_rank+1
8930       CorrelType1=478
8931       CorrelID1=nfgtasks+fg_rank+1
8932       ireq=0
8933 C Receive the numbers of needed contacts from other processors
8934       do ii=1,ntask_cont_from
8935         iproc=itask_cont_from(ii)
8936         ireq=ireq+1
8937         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
8938      &    FG_COMM,req(ireq),IERR)
8939       enddo
8940 c      write (iout,*) "IRECV ended"
8941 c      call flush(iout)
8942 C Send the number of contacts needed by other processors
8943       do ii=1,ntask_cont_to
8944         iproc=itask_cont_to(ii)
8945         ireq=ireq+1
8946         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
8947      &    FG_COMM,req(ireq),IERR)
8948       enddo
8949 c      write (iout,*) "ISEND ended"
8950 c      write (iout,*) "number of requests (nn)",ireq
8951 c      call flush(iout)
8952       if (ireq.gt.0)
8953      &  call MPI_Waitall(ireq,req,status_array,ierr)
8954 c      write (iout,*)
8955 c     &  "Numbers of contacts to be received from other processors",
8956 c     &  (ncont_recv(i),i=1,ntask_cont_from)
8957 c      call flush(iout)
8958 C Receive contacts
8959       ireq=0
8960       do ii=1,ntask_cont_from
8961         iproc=itask_cont_from(ii)
8962         nn=ncont_recv(ii)
8963 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
8964 c     &   " of CONT_TO_COMM group"
8965 c        call flush(iout)
8966         if (nn.gt.0) then
8967           ireq=ireq+1
8968           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
8969      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
8970 c          write (iout,*) "ireq,req",ireq,req(ireq)
8971         endif
8972       enddo
8973 C Send the contacts to processors that need them
8974       do ii=1,ntask_cont_to
8975         iproc=itask_cont_to(ii)
8976         nn=ncont_sent(ii)
8977 c        write (iout,*) nn," contacts to processor",iproc,
8978 c     &   " of CONT_TO_COMM group"
8979         if (nn.gt.0) then
8980           ireq=ireq+1
8981           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
8982      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
8983 c          write (iout,*) "ireq,req",ireq,req(ireq)
8984 c          do i=1,nn
8985 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
8986 c          enddo
8987         endif
8988       enddo
8989 c      write (iout,*) "number of requests (contacts)",ireq
8990 c      write (iout,*) "req",(req(i),i=1,4)
8991 c      call flush(iout)
8992       if (ireq.gt.0)
8993      & call MPI_Waitall(ireq,req,status_array,ierr)
8994       do iii=1,ntask_cont_from
8995         iproc=itask_cont_from(iii)
8996         nn=ncont_recv(iii)
8997         if (lprn) then
8998         write (iout,*) "Received",nn," contacts from processor",iproc,
8999      &   " of CONT_FROM_COMM group"
9000         call flush(iout)
9001         do i=1,nn
9002           write(iout,'(2f5.0,4f10.5)')(zapas_recv(j,i,iii),j=1,5)
9003         enddo
9004         call flush(iout)
9005         endif
9006         do i=1,nn
9007           ii=zapas_recv(1,i,iii)
9008 c Flag the received contacts to prevent double-counting
9009           jj=-zapas_recv(2,i,iii)
9010 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
9011 c          call flush(iout)
9012           nnn=num_cont_hb(ii)+1
9013           num_cont_hb(ii)=nnn
9014           jcont_hb(nnn,ii)=jj
9015           facont_hb(nnn,ii)=zapas_recv(3,i,iii)
9016           ees0p(nnn,ii)=zapas_recv(4,i,iii)
9017           ees0m(nnn,ii)=zapas_recv(5,i,iii)
9018           gacont_hbr(1,nnn,ii)=zapas_recv(6,i,iii)
9019           gacont_hbr(2,nnn,ii)=zapas_recv(7,i,iii)
9020           gacont_hbr(3,nnn,ii)=zapas_recv(8,i,iii)
9021           gacontm_hb1(1,nnn,ii)=zapas_recv(9,i,iii)
9022           gacontm_hb1(2,nnn,ii)=zapas_recv(10,i,iii)
9023           gacontm_hb1(3,nnn,ii)=zapas_recv(11,i,iii)
9024           gacontp_hb1(1,nnn,ii)=zapas_recv(12,i,iii)
9025           gacontp_hb1(2,nnn,ii)=zapas_recv(13,i,iii)
9026           gacontp_hb1(3,nnn,ii)=zapas_recv(14,i,iii)
9027           gacontm_hb2(1,nnn,ii)=zapas_recv(15,i,iii)
9028           gacontm_hb2(2,nnn,ii)=zapas_recv(16,i,iii)
9029           gacontm_hb2(3,nnn,ii)=zapas_recv(17,i,iii)
9030           gacontp_hb2(1,nnn,ii)=zapas_recv(18,i,iii)
9031           gacontp_hb2(2,nnn,ii)=zapas_recv(19,i,iii)
9032           gacontp_hb2(3,nnn,ii)=zapas_recv(20,i,iii)
9033           gacontm_hb3(1,nnn,ii)=zapas_recv(21,i,iii)
9034           gacontm_hb3(2,nnn,ii)=zapas_recv(22,i,iii)
9035           gacontm_hb3(3,nnn,ii)=zapas_recv(23,i,iii)
9036           gacontp_hb3(1,nnn,ii)=zapas_recv(24,i,iii)
9037           gacontp_hb3(2,nnn,ii)=zapas_recv(25,i,iii)
9038           gacontp_hb3(3,nnn,ii)=zapas_recv(26,i,iii)
9039         enddo
9040       enddo
9041       if (lprn) then
9042         write (iout,'(a)') 'Contact function values after receive:'
9043         do i=nnt,nct-2
9044           write (iout,'(2i3,50(1x,i3,f5.2))')
9045      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
9046      &    j=1,num_cont_hb(i))
9047         enddo
9048         call flush(iout)
9049       endif
9050    30 continue
9051 #endif
9052       if (lprn) then
9053         write (iout,'(a)') 'Contact function values:'
9054         do i=nnt,nct-2
9055           write (iout,'(2i3,50(1x,i3,f5.2))')
9056      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
9057      &    j=1,num_cont_hb(i))
9058         enddo
9059         call flush(iout)
9060       endif
9061       ecorr=0.0D0
9062 C Remove the loop below after debugging !!!
9063       do i=nnt,nct
9064         do j=1,3
9065           gradcorr(j,i)=0.0D0
9066           gradxorr(j,i)=0.0D0
9067         enddo
9068       enddo
9069 C Calculate the local-electrostatic correlation terms
9070       do i=min0(iatel_s,iturn4_start),max0(iatel_e,iturn3_end)
9071         i1=i+1
9072         num_conti=num_cont_hb(i)
9073         num_conti1=num_cont_hb(i+1)
9074         do jj=1,num_conti
9075           j=jcont_hb(jj,i)
9076           jp=iabs(j)
9077           do kk=1,num_conti1
9078             j1=jcont_hb(kk,i1)
9079             jp1=iabs(j1)
9080 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
9081 c     &         ' jj=',jj,' kk=',kk
9082 c            call flush(iout)
9083             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
9084      &          .or. j.lt.0 .and. j1.gt.0) .and.
9085      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
9086 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
9087 C The system gains extra energy.
9088               ecorr=ecorr+ehbcorr(i,jp,i+1,jp1,jj,kk,0.72D0,0.32D0)
9089               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
9090      &            'ecorrh',i,j,ehbcorr(i,j,i+1,j1,jj,kk,0.72D0,0.32D0)
9091               n_corr=n_corr+1
9092             else if (j1.eq.j) then
9093 C Contacts I-J and I-(J+1) occur simultaneously.
9094 C The system loses extra energy.
9095 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
9096             endif
9097           enddo ! kk
9098           do kk=1,num_conti
9099             j1=jcont_hb(kk,i)
9100 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
9101 c    &         ' jj=',jj,' kk=',kk
9102             if (j1.eq.j+1) then
9103 C Contacts I-J and (I+1)-J occur simultaneously.
9104 C The system loses extra energy.
9105 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
9106             endif ! j1==j+1
9107           enddo ! kk
9108         enddo ! jj
9109       enddo ! i
9110       return
9111       end
9112 c------------------------------------------------------------------------------
9113       subroutine add_hb_contact(ii,jj,itask)
9114       implicit real*8 (a-h,o-z)
9115       include "DIMENSIONS"
9116       include "COMMON.IOUNITS"
9117       integer max_cont
9118       integer max_dim
9119       parameter (max_cont=maxconts)
9120       parameter (max_dim=26)
9121       include "COMMON.CONTACTS"
9122       double precision zapas(max_dim,maxconts,max_fg_procs),
9123      &  zapas_recv(max_dim,maxconts,max_fg_procs)
9124       common /przechowalnia/ zapas
9125       integer i,j,ii,jj,iproc,itask(4),nn
9126 c      write (iout,*) "itask",itask
9127       do i=1,2
9128         iproc=itask(i)
9129         if (iproc.gt.0) then
9130           do j=1,num_cont_hb(ii)
9131             jjc=jcont_hb(j,ii)
9132 c            write (iout,*) "i",ii," j",jj," jjc",jjc
9133             if (jjc.eq.jj) then
9134               ncont_sent(iproc)=ncont_sent(iproc)+1
9135               nn=ncont_sent(iproc)
9136               zapas(1,nn,iproc)=ii
9137               zapas(2,nn,iproc)=jjc
9138               zapas(3,nn,iproc)=facont_hb(j,ii)
9139               zapas(4,nn,iproc)=ees0p(j,ii)
9140               zapas(5,nn,iproc)=ees0m(j,ii)
9141               zapas(6,nn,iproc)=gacont_hbr(1,j,ii)
9142               zapas(7,nn,iproc)=gacont_hbr(2,j,ii)
9143               zapas(8,nn,iproc)=gacont_hbr(3,j,ii)
9144               zapas(9,nn,iproc)=gacontm_hb1(1,j,ii)
9145               zapas(10,nn,iproc)=gacontm_hb1(2,j,ii)
9146               zapas(11,nn,iproc)=gacontm_hb1(3,j,ii)
9147               zapas(12,nn,iproc)=gacontp_hb1(1,j,ii)
9148               zapas(13,nn,iproc)=gacontp_hb1(2,j,ii)
9149               zapas(14,nn,iproc)=gacontp_hb1(3,j,ii)
9150               zapas(15,nn,iproc)=gacontm_hb2(1,j,ii)
9151               zapas(16,nn,iproc)=gacontm_hb2(2,j,ii)
9152               zapas(17,nn,iproc)=gacontm_hb2(3,j,ii)
9153               zapas(18,nn,iproc)=gacontp_hb2(1,j,ii)
9154               zapas(19,nn,iproc)=gacontp_hb2(2,j,ii)
9155               zapas(20,nn,iproc)=gacontp_hb2(3,j,ii)
9156               zapas(21,nn,iproc)=gacontm_hb3(1,j,ii)
9157               zapas(22,nn,iproc)=gacontm_hb3(2,j,ii)
9158               zapas(23,nn,iproc)=gacontm_hb3(3,j,ii)
9159               zapas(24,nn,iproc)=gacontp_hb3(1,j,ii)
9160               zapas(25,nn,iproc)=gacontp_hb3(2,j,ii)
9161               zapas(26,nn,iproc)=gacontp_hb3(3,j,ii)
9162               exit
9163             endif
9164           enddo
9165         endif
9166       enddo
9167       return
9168       end
9169 c------------------------------------------------------------------------------
9170       subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,
9171      &  n_corr1)
9172 C This subroutine calculates multi-body contributions to hydrogen-bonding
9173       implicit real*8 (a-h,o-z)
9174       include 'DIMENSIONS'
9175       include 'COMMON.IOUNITS'
9176 #ifdef MPI
9177       include "mpif.h"
9178       parameter (max_cont=maxconts)
9179       parameter (max_dim=70)
9180       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
9181       double precision zapas(max_dim,maxconts,max_fg_procs),
9182      &  zapas_recv(max_dim,maxconts,max_fg_procs)
9183       common /przechowalnia/ zapas
9184       integer status(MPI_STATUS_SIZE),req(maxconts*2),
9185      &  status_array(MPI_STATUS_SIZE,maxconts*2)
9186 #endif
9187       include 'COMMON.SETUP'
9188       include 'COMMON.FFIELD'
9189       include 'COMMON.DERIV'
9190       include 'COMMON.LOCAL'
9191       include 'COMMON.INTERACT'
9192       include 'COMMON.CONTACTS'
9193       include 'COMMON.CHAIN'
9194       include 'COMMON.CONTROL'
9195       include 'COMMON.SHIELD'
9196       double precision gx(3),gx1(3)
9197       integer num_cont_hb_old(maxres)
9198       logical lprn,ldone
9199       double precision eello4,eello5,eelo6,eello_turn6
9200       external eello4,eello5,eello6,eello_turn6
9201 C Set lprn=.true. for debugging
9202       lprn=.false.
9203       eturn6=0.0d0
9204 #ifdef MPI
9205       do i=1,nres
9206         num_cont_hb_old(i)=num_cont_hb(i)
9207       enddo
9208       n_corr=0
9209       n_corr1=0
9210       if (nfgtasks.le.1) goto 30
9211       if (lprn) then
9212         write (iout,'(a)') 'Contact function values before RECEIVE:'
9213         do i=nnt,nct-2
9214           write (iout,'(2i3,50(1x,i2,f5.2))')
9215      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
9216      &    j=1,num_cont_hb(i))
9217         enddo
9218       endif
9219       do i=1,ntask_cont_from
9220         ncont_recv(i)=0
9221       enddo
9222       do i=1,ntask_cont_to
9223         ncont_sent(i)=0
9224       enddo
9225 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
9226 c     & ntask_cont_to
9227 C Make the list of contacts to send to send to other procesors
9228       do i=iturn3_start,iturn3_end
9229 c        write (iout,*) "make contact list turn3",i," num_cont",
9230 c     &    num_cont_hb(i)
9231         call add_hb_contact_eello(i,i+2,iturn3_sent_local(1,i))
9232       enddo
9233       do i=iturn4_start,iturn4_end
9234 c        write (iout,*) "make contact list turn4",i," num_cont",
9235 c     &   num_cont_hb(i)
9236         call add_hb_contact_eello(i,i+3,iturn4_sent_local(1,i))
9237       enddo
9238       do ii=1,nat_sent
9239         i=iat_sent(ii)
9240 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
9241 c     &    num_cont_hb(i)
9242         do j=1,num_cont_hb(i)
9243         do k=1,4
9244           jjc=jcont_hb(j,i)
9245           iproc=iint_sent_local(k,jjc,ii)
9246 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
9247           if (iproc.ne.0) then
9248             ncont_sent(iproc)=ncont_sent(iproc)+1
9249             nn=ncont_sent(iproc)
9250             zapas(1,nn,iproc)=i
9251             zapas(2,nn,iproc)=jjc
9252             zapas(3,nn,iproc)=d_cont(j,i)
9253             ind=3
9254             do kk=1,3
9255               ind=ind+1
9256               zapas(ind,nn,iproc)=grij_hb_cont(kk,j,i)
9257             enddo
9258             do kk=1,2
9259               do ll=1,2
9260                 ind=ind+1
9261                 zapas(ind,nn,iproc)=a_chuj(ll,kk,j,i)
9262               enddo
9263             enddo
9264             do jj=1,5
9265               do kk=1,3
9266                 do ll=1,2
9267                   do mm=1,2
9268                     ind=ind+1
9269                     zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,i)
9270                   enddo
9271                 enddo
9272               enddo
9273             enddo
9274           endif
9275         enddo
9276         enddo
9277       enddo
9278       if (lprn) then
9279       write (iout,*)
9280      &  "Numbers of contacts to be sent to other processors",
9281      &  (ncont_sent(i),i=1,ntask_cont_to)
9282       write (iout,*) "Contacts sent"
9283       do ii=1,ntask_cont_to
9284         nn=ncont_sent(ii)
9285         iproc=itask_cont_to(ii)
9286         write (iout,*) nn," contacts to processor",iproc,
9287      &   " of CONT_TO_COMM group"
9288         do i=1,nn
9289           write(iout,'(2f5.0,10f10.5)')(zapas(j,i,ii),j=1,10)
9290         enddo
9291       enddo
9292       call flush(iout)
9293       endif
9294       CorrelType=477
9295       CorrelID=fg_rank+1
9296       CorrelType1=478
9297       CorrelID1=nfgtasks+fg_rank+1
9298       ireq=0
9299 C Receive the numbers of needed contacts from other processors
9300       do ii=1,ntask_cont_from
9301         iproc=itask_cont_from(ii)
9302         ireq=ireq+1
9303         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
9304      &    FG_COMM,req(ireq),IERR)
9305       enddo
9306 c      write (iout,*) "IRECV ended"
9307 c      call flush(iout)
9308 C Send the number of contacts needed by other processors
9309       do ii=1,ntask_cont_to
9310         iproc=itask_cont_to(ii)
9311         ireq=ireq+1
9312         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
9313      &    FG_COMM,req(ireq),IERR)
9314       enddo
9315 c      write (iout,*) "ISEND ended"
9316 c      write (iout,*) "number of requests (nn)",ireq
9317 c      call flush(iout)
9318       if (ireq.gt.0)
9319      &  call MPI_Waitall(ireq,req,status_array,ierr)
9320 c      write (iout,*)
9321 c     &  "Numbers of contacts to be received from other processors",
9322 c     &  (ncont_recv(i),i=1,ntask_cont_from)
9323 c      call flush(iout)
9324 C Receive contacts
9325       ireq=0
9326       do ii=1,ntask_cont_from
9327         iproc=itask_cont_from(ii)
9328         nn=ncont_recv(ii)
9329 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
9330 c     &   " of CONT_TO_COMM group"
9331 c        call flush(iout)
9332         if (nn.gt.0) then
9333           ireq=ireq+1
9334           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
9335      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
9336 c          write (iout,*) "ireq,req",ireq,req(ireq)
9337         endif
9338       enddo
9339 C Send the contacts to processors that need them
9340       do ii=1,ntask_cont_to
9341         iproc=itask_cont_to(ii)
9342         nn=ncont_sent(ii)
9343 c        write (iout,*) nn," contacts to processor",iproc,
9344 c     &   " of CONT_TO_COMM group"
9345         if (nn.gt.0) then
9346           ireq=ireq+1
9347           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
9348      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
9349 c          write (iout,*) "ireq,req",ireq,req(ireq)
9350 c          do i=1,nn
9351 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
9352 c          enddo
9353         endif
9354       enddo
9355 c      write (iout,*) "number of requests (contacts)",ireq
9356 c      write (iout,*) "req",(req(i),i=1,4)
9357 c      call flush(iout)
9358       if (ireq.gt.0)
9359      & call MPI_Waitall(ireq,req,status_array,ierr)
9360       do iii=1,ntask_cont_from
9361         iproc=itask_cont_from(iii)
9362         nn=ncont_recv(iii)
9363         if (lprn) then
9364         write (iout,*) "Received",nn," contacts from processor",iproc,
9365      &   " of CONT_FROM_COMM group"
9366         call flush(iout)
9367         do i=1,nn
9368           write(iout,'(2f5.0,10f10.5)')(zapas_recv(j,i,iii),j=1,10)
9369         enddo
9370         call flush(iout)
9371         endif
9372         do i=1,nn
9373           ii=zapas_recv(1,i,iii)
9374 c Flag the received contacts to prevent double-counting
9375           jj=-zapas_recv(2,i,iii)
9376 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
9377 c          call flush(iout)
9378           nnn=num_cont_hb(ii)+1
9379           num_cont_hb(ii)=nnn
9380           jcont_hb(nnn,ii)=jj
9381           d_cont(nnn,ii)=zapas_recv(3,i,iii)
9382           ind=3
9383           do kk=1,3
9384             ind=ind+1
9385             grij_hb_cont(kk,nnn,ii)=zapas_recv(ind,i,iii)
9386           enddo
9387           do kk=1,2
9388             do ll=1,2
9389               ind=ind+1
9390               a_chuj(ll,kk,nnn,ii)=zapas_recv(ind,i,iii)
9391             enddo
9392           enddo
9393           do jj=1,5
9394             do kk=1,3
9395               do ll=1,2
9396                 do mm=1,2
9397                   ind=ind+1
9398                   a_chuj_der(mm,ll,kk,jj,nnn,ii)=zapas_recv(ind,i,iii)
9399                 enddo
9400               enddo
9401             enddo
9402           enddo
9403         enddo
9404       enddo
9405       if (lprn) then
9406         write (iout,'(a)') 'Contact function values after receive:'
9407         do i=nnt,nct-2
9408           write (iout,'(2i3,50(1x,i3,5f6.3))')
9409      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
9410      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
9411         enddo
9412         call flush(iout)
9413       endif
9414    30 continue
9415 #endif
9416       if (lprn) then
9417         write (iout,'(a)') 'Contact function values:'
9418         do i=nnt,nct-2
9419           write (iout,'(2i3,50(1x,i2,5f6.3))')
9420      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
9421      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
9422         enddo
9423       endif
9424       ecorr=0.0D0
9425       ecorr5=0.0d0
9426       ecorr6=0.0d0
9427 C Remove the loop below after debugging !!!
9428       do i=nnt,nct
9429         do j=1,3
9430           gradcorr(j,i)=0.0D0
9431           gradxorr(j,i)=0.0D0
9432         enddo
9433       enddo
9434 C Calculate the dipole-dipole interaction energies
9435       if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
9436       do i=iatel_s,iatel_e+1
9437         num_conti=num_cont_hb(i)
9438         do jj=1,num_conti
9439           j=jcont_hb(jj,i)
9440 #ifdef MOMENT
9441           call dipole(i,j,jj)
9442 #endif
9443         enddo
9444       enddo
9445       endif
9446 C Calculate the local-electrostatic correlation terms
9447 c                write (iout,*) "gradcorr5 in eello5 before loop"
9448 c                do iii=1,nres
9449 c                  write (iout,'(i5,3f10.5)')
9450 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
9451 c                enddo
9452       do i=min0(iatel_s,iturn4_start),max0(iatel_e+1,iturn3_end+1)
9453 c        write (iout,*) "corr loop i",i
9454         i1=i+1
9455         num_conti=num_cont_hb(i)
9456         num_conti1=num_cont_hb(i+1)
9457         do jj=1,num_conti
9458           j=jcont_hb(jj,i)
9459           jp=iabs(j)
9460           do kk=1,num_conti1
9461             j1=jcont_hb(kk,i1)
9462             jp1=iabs(j1)
9463 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
9464 c     &         ' jj=',jj,' kk=',kk
9465 c            if (j1.eq.j+1 .or. j1.eq.j-1) then
9466             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
9467      &          .or. j.lt.0 .and. j1.gt.0) .and.
9468      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
9469 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
9470 C The system gains extra energy.
9471               n_corr=n_corr+1
9472               sqd1=dsqrt(d_cont(jj,i))
9473               sqd2=dsqrt(d_cont(kk,i1))
9474               sred_geom = sqd1*sqd2
9475               IF (sred_geom.lt.cutoff_corr) THEN
9476                 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,
9477      &            ekont,fprimcont)
9478 cd               write (iout,*) 'i=',i,' j=',jp,' i1=',i1,' j1=',jp1,
9479 cd     &         ' jj=',jj,' kk=',kk
9480                 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
9481                 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
9482                 do l=1,3
9483                   g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
9484                   g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
9485                 enddo
9486                 n_corr1=n_corr1+1
9487 cd               write (iout,*) 'sred_geom=',sred_geom,
9488 cd     &          ' ekont=',ekont,' fprim=',fprimcont,
9489 cd     &          ' fac_prim1',fac_prim1,' fac_prim2',fac_prim2
9490 cd               write (iout,*) "g_contij",g_contij
9491 cd               write (iout,*) "grij_hb_cont i",grij_hb_cont(:,jj,i)
9492 cd               write (iout,*) "grij_hb_cont i1",grij_hb_cont(:,jj,i1)
9493                 call calc_eello(i,jp,i+1,jp1,jj,kk)
9494                 if (wcorr4.gt.0.0d0)
9495      &            ecorr=ecorr+eello4(i,jp,i+1,jp1,jj,kk)
9496 CC     &            *fac_shield(i)**2*fac_shield(j)**2
9497                   if (energy_dec.and.wcorr4.gt.0.0d0)
9498      1                 write (iout,'(a6,4i5,0pf7.3)')
9499      2                'ecorr4',i,j,i+1,j1,eello4(i,jp,i+1,jp1,jj,kk)
9500 c                write (iout,*) "gradcorr5 before eello5"
9501 c                do iii=1,nres
9502 c                  write (iout,'(i5,3f10.5)')
9503 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
9504 c                enddo
9505                 if (wcorr5.gt.0.0d0)
9506      &            ecorr5=ecorr5+eello5(i,jp,i+1,jp1,jj,kk)
9507 c                write (iout,*) "gradcorr5 after eello5"
9508 c                do iii=1,nres
9509 c                  write (iout,'(i5,3f10.5)')
9510 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
9511 c                enddo
9512                   if (energy_dec.and.wcorr5.gt.0.0d0)
9513      1                 write (iout,'(a6,4i5,0pf7.3)')
9514      2                'ecorr5',i,j,i+1,j1,eello5(i,jp,i+1,jp1,jj,kk)
9515 cd                write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
9516 cd                write(2,*)'ijkl',i,jp,i+1,jp1
9517                 if (wcorr6.gt.0.0d0 .and. (jp.ne.i+4 .or. jp1.ne.i+3
9518      &               .or. wturn6.eq.0.0d0))then
9519 cd                  write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
9520                   ecorr6=ecorr6+eello6(i,jp,i+1,jp1,jj,kk)
9521                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
9522      1                'ecorr6',i,j,i+1,j1,eello6(i,jp,i+1,jp1,jj,kk)
9523 cd                write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
9524 cd     &            'ecorr6=',ecorr6
9525 cd                write (iout,'(4e15.5)') sred_geom,
9526 cd     &          dabs(eello4(i,jp,i+1,jp1,jj,kk)),
9527 cd     &          dabs(eello5(i,jp,i+1,jp1,jj,kk)),
9528 cd     &          dabs(eello6(i,jp,i+1,jp1,jj,kk))
9529                 else if (wturn6.gt.0.0d0
9530      &            .and. (jp.eq.i+4 .and. jp1.eq.i+3)) then
9531 cd                  write (iout,*) '******eturn6: i,j,i+1,j1',i,jip,i+1,jp1
9532                   eturn6=eturn6+eello_turn6(i,jj,kk)
9533                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
9534      1                 'eturn6',i,j,i+1,j1,eello_turn6(i,jj,kk)
9535 cd                  write (2,*) 'multibody_eello:eturn6',eturn6
9536                 endif
9537               ENDIF
9538 1111          continue
9539             endif
9540           enddo ! kk
9541         enddo ! jj
9542       enddo ! i
9543       do i=1,nres
9544         num_cont_hb(i)=num_cont_hb_old(i)
9545       enddo
9546 c                write (iout,*) "gradcorr5 in eello5"
9547 c                do iii=1,nres
9548 c                  write (iout,'(i5,3f10.5)')
9549 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
9550 c                enddo
9551       return
9552       end
9553 c------------------------------------------------------------------------------
9554       subroutine add_hb_contact_eello(ii,jj,itask)
9555       implicit real*8 (a-h,o-z)
9556       include "DIMENSIONS"
9557       include "COMMON.IOUNITS"
9558       integer max_cont
9559       integer max_dim
9560       parameter (max_cont=maxconts)
9561       parameter (max_dim=70)
9562       include "COMMON.CONTACTS"
9563       double precision zapas(max_dim,maxconts,max_fg_procs),
9564      &  zapas_recv(max_dim,maxconts,max_fg_procs)
9565       common /przechowalnia/ zapas
9566       integer i,j,ii,jj,iproc,itask(4),nn
9567 c      write (iout,*) "itask",itask
9568       do i=1,2
9569         iproc=itask(i)
9570         if (iproc.gt.0) then
9571           do j=1,num_cont_hb(ii)
9572             jjc=jcont_hb(j,ii)
9573 c            write (iout,*) "send turns i",ii," j",jj," jjc",jjc
9574             if (jjc.eq.jj) then
9575               ncont_sent(iproc)=ncont_sent(iproc)+1
9576               nn=ncont_sent(iproc)
9577               zapas(1,nn,iproc)=ii
9578               zapas(2,nn,iproc)=jjc
9579               zapas(3,nn,iproc)=d_cont(j,ii)
9580               ind=3
9581               do kk=1,3
9582                 ind=ind+1
9583                 zapas(ind,nn,iproc)=grij_hb_cont(kk,j,ii)
9584               enddo
9585               do kk=1,2
9586                 do ll=1,2
9587                   ind=ind+1
9588                   zapas(ind,nn,iproc)=a_chuj(ll,kk,j,ii)
9589                 enddo
9590               enddo
9591               do jj=1,5
9592                 do kk=1,3
9593                   do ll=1,2
9594                     do mm=1,2
9595                       ind=ind+1
9596                       zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,ii)
9597                     enddo
9598                   enddo
9599                 enddo
9600               enddo
9601               exit
9602             endif
9603           enddo
9604         endif
9605       enddo
9606       return
9607       end
9608 c------------------------------------------------------------------------------
9609       double precision function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
9610       implicit real*8 (a-h,o-z)
9611       include 'DIMENSIONS'
9612       include 'COMMON.IOUNITS'
9613       include 'COMMON.DERIV'
9614       include 'COMMON.INTERACT'
9615       include 'COMMON.CONTACTS'
9616       include 'COMMON.SHIELD'
9617       include 'COMMON.CONTROL'
9618       double precision gx(3),gx1(3)
9619       logical lprn
9620       lprn=.false.
9621 C      print *,"wchodze",fac_shield(i),shield_mode
9622       eij=facont_hb(jj,i)
9623       ekl=facont_hb(kk,k)
9624       ees0pij=ees0p(jj,i)
9625       ees0pkl=ees0p(kk,k)
9626       ees0mij=ees0m(jj,i)
9627       ees0mkl=ees0m(kk,k)
9628       ekont=eij*ekl
9629       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
9630 C*
9631 C     & fac_shield(i)**2*fac_shield(j)**2
9632 cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
9633 C Following 4 lines for diagnostics.
9634 cd    ees0pkl=0.0D0
9635 cd    ees0pij=1.0D0
9636 cd    ees0mkl=0.0D0
9637 cd    ees0mij=1.0D0
9638 c      write (iout,'(2(a,2i3,a,f10.5,a,2f10.5),a,f10.5,a,$)')
9639 c     & 'Contacts ',i,j,
9640 c     & ' eij',eij,' eesij',ees0pij,ees0mij,' and ',k,l
9641 c     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' energy=',ekont*ees,
9642 c     & 'gradcorr_long'
9643 C Calculate the multi-body contribution to energy.
9644 C      ecorr=ecorr+ekont*ees
9645 C Calculate multi-body contributions to the gradient.
9646       coeffpees0pij=coeffp*ees0pij
9647       coeffmees0mij=coeffm*ees0mij
9648       coeffpees0pkl=coeffp*ees0pkl
9649       coeffmees0mkl=coeffm*ees0mkl
9650       do ll=1,3
9651 cgrad        ghalfi=ees*ekl*gacont_hbr(ll,jj,i)
9652         gradcorr(ll,i)=gradcorr(ll,i)!+0.5d0*ghalfi
9653      &  -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+
9654      &  coeffmees0mkl*gacontm_hb1(ll,jj,i))
9655         gradcorr(ll,j)=gradcorr(ll,j)!+0.5d0*ghalfi
9656      &  -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+
9657      &  coeffmees0mkl*gacontm_hb2(ll,jj,i))
9658 cgrad        ghalfk=ees*eij*gacont_hbr(ll,kk,k)
9659         gradcorr(ll,k)=gradcorr(ll,k)!+0.5d0*ghalfk
9660      &  -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+
9661      &  coeffmees0mij*gacontm_hb1(ll,kk,k))
9662         gradcorr(ll,l)=gradcorr(ll,l)!+0.5d0*ghalfk
9663      &  -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+
9664      &  coeffmees0mij*gacontm_hb2(ll,kk,k))
9665         gradlongij=ees*ekl*gacont_hbr(ll,jj,i)-
9666      &     ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+
9667      &     coeffmees0mkl*gacontm_hb3(ll,jj,i))
9668         gradcorr_long(ll,j)=gradcorr_long(ll,j)+gradlongij
9669         gradcorr_long(ll,i)=gradcorr_long(ll,i)-gradlongij
9670         gradlongkl=ees*eij*gacont_hbr(ll,kk,k)-
9671      &     ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+
9672      &     coeffmees0mij*gacontm_hb3(ll,kk,k))
9673         gradcorr_long(ll,l)=gradcorr_long(ll,l)+gradlongkl
9674         gradcorr_long(ll,k)=gradcorr_long(ll,k)-gradlongkl
9675 c        write (iout,'(2f10.5,2x,$)') gradlongij,gradlongkl
9676       enddo
9677 c      write (iout,*)
9678 cgrad      do m=i+1,j-1
9679 cgrad        do ll=1,3
9680 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
9681 cgrad     &     ees*ekl*gacont_hbr(ll,jj,i)-
9682 cgrad     &     ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
9683 cgrad     &     coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
9684 cgrad        enddo
9685 cgrad      enddo
9686 cgrad      do m=k+1,l-1
9687 cgrad        do ll=1,3
9688 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
9689 cgrad     &     ees*eij*gacont_hbr(ll,kk,k)-
9690 cgrad     &     ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
9691 cgrad     &     coeffm*ees0mij*gacontm_hb3(ll,kk,k))
9692 cgrad        enddo
9693 cgrad      enddo
9694 c      write (iout,*) "ehbcorr",ekont*ees
9695 C      print *,ekont,ees,i,k
9696       ehbcorr=ekont*ees
9697 C now gradient over shielding
9698 C      return
9699       if (shield_mode.gt.0) then
9700        j=ees0plist(jj,i)
9701        l=ees0plist(kk,k)
9702 C        print *,i,j,fac_shield(i),fac_shield(j),
9703 C     &fac_shield(k),fac_shield(l)
9704         if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
9705      &      (fac_shield(k).gt.0).and.(fac_shield(l).gt.0)) then
9706           do ilist=1,ishield_list(i)
9707            iresshield=shield_list(ilist,i)
9708            do m=1,3
9709            rlocshield=grad_shield_side(m,ilist,i)*ehbcorr/fac_shield(i)
9710 C     &      *2.0
9711            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
9712      &              rlocshield
9713      & +grad_shield_loc(m,ilist,i)*ehbcorr/fac_shield(i)
9714             gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
9715      &+rlocshield
9716            enddo
9717           enddo
9718           do ilist=1,ishield_list(j)
9719            iresshield=shield_list(ilist,j)
9720            do m=1,3
9721            rlocshield=grad_shield_side(m,ilist,j)*ehbcorr/fac_shield(j)
9722 C     &     *2.0
9723            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
9724      &              rlocshield
9725      & +grad_shield_loc(m,ilist,j)*ehbcorr/fac_shield(j)
9726            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
9727      &     +rlocshield
9728            enddo
9729           enddo
9730
9731           do ilist=1,ishield_list(k)
9732            iresshield=shield_list(ilist,k)
9733            do m=1,3
9734            rlocshield=grad_shield_side(m,ilist,k)*ehbcorr/fac_shield(k)
9735 C     &     *2.0
9736            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
9737      &              rlocshield
9738      & +grad_shield_loc(m,ilist,k)*ehbcorr/fac_shield(k)
9739            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
9740      &     +rlocshield
9741            enddo
9742           enddo
9743           do ilist=1,ishield_list(l)
9744            iresshield=shield_list(ilist,l)
9745            do m=1,3
9746            rlocshield=grad_shield_side(m,ilist,l)*ehbcorr/fac_shield(l)
9747 C     &     *2.0
9748            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
9749      &              rlocshield
9750      & +grad_shield_loc(m,ilist,l)*ehbcorr/fac_shield(l)
9751            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
9752      &     +rlocshield
9753            enddo
9754           enddo
9755 C          print *,gshieldx(m,iresshield)
9756           do m=1,3
9757             gshieldc_ec(m,i)=gshieldc_ec(m,i)+
9758      &              grad_shield(m,i)*ehbcorr/fac_shield(i)
9759             gshieldc_ec(m,j)=gshieldc_ec(m,j)+
9760      &              grad_shield(m,j)*ehbcorr/fac_shield(j)
9761             gshieldc_ec(m,i-1)=gshieldc_ec(m,i-1)+
9762      &              grad_shield(m,i)*ehbcorr/fac_shield(i)
9763             gshieldc_ec(m,j-1)=gshieldc_ec(m,j-1)+
9764      &              grad_shield(m,j)*ehbcorr/fac_shield(j)
9765
9766             gshieldc_ec(m,k)=gshieldc_ec(m,k)+
9767      &              grad_shield(m,k)*ehbcorr/fac_shield(k)
9768             gshieldc_ec(m,l)=gshieldc_ec(m,l)+
9769      &              grad_shield(m,l)*ehbcorr/fac_shield(l)
9770             gshieldc_ec(m,k-1)=gshieldc_ec(m,k-1)+
9771      &              grad_shield(m,k)*ehbcorr/fac_shield(k)
9772             gshieldc_ec(m,l-1)=gshieldc_ec(m,l-1)+
9773      &              grad_shield(m,l)*ehbcorr/fac_shield(l)
9774
9775            enddo
9776       endif
9777       endif
9778       return
9779       end
9780 #ifdef MOMENT
9781 C---------------------------------------------------------------------------
9782       subroutine dipole(i,j,jj)
9783       implicit real*8 (a-h,o-z)
9784       include 'DIMENSIONS'
9785       include 'COMMON.IOUNITS'
9786       include 'COMMON.CHAIN'
9787       include 'COMMON.FFIELD'
9788       include 'COMMON.DERIV'
9789       include 'COMMON.INTERACT'
9790       include 'COMMON.CONTACTS'
9791       include 'COMMON.TORSION'
9792       include 'COMMON.VAR'
9793       include 'COMMON.GEO'
9794       dimension dipi(2,2),dipj(2,2),dipderi(2),dipderj(2),auxvec(2),
9795      &  auxmat(2,2)
9796       iti1 = itortyp(itype(i+1))
9797       if (j.lt.nres-1) then
9798         itj1 = itype2loc(itype(j+1))
9799       else
9800         itj1=nloctyp
9801       endif
9802       do iii=1,2
9803         dipi(iii,1)=Ub2(iii,i)
9804         dipderi(iii)=Ub2der(iii,i)
9805         dipi(iii,2)=b1(iii,i+1)
9806         dipj(iii,1)=Ub2(iii,j)
9807         dipderj(iii)=Ub2der(iii,j)
9808         dipj(iii,2)=b1(iii,j+1)
9809       enddo
9810       kkk=0
9811       do iii=1,2
9812         call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
9813         do jjj=1,2
9814           kkk=kkk+1
9815           dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
9816         enddo
9817       enddo
9818       do kkk=1,5
9819         do lll=1,3
9820           mmm=0
9821           do iii=1,2
9822             call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),
9823      &        auxvec(1))
9824             do jjj=1,2
9825               mmm=mmm+1
9826               dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
9827             enddo
9828           enddo
9829         enddo
9830       enddo
9831       call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
9832       call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
9833       do iii=1,2
9834         dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
9835       enddo
9836       call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
9837       do iii=1,2
9838         dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
9839       enddo
9840       return
9841       end
9842 #endif
9843 C---------------------------------------------------------------------------
9844       subroutine calc_eello(i,j,k,l,jj,kk)
9845 C
9846 C This subroutine computes matrices and vectors needed to calculate
9847 C the fourth-, fifth-, and sixth-order local-electrostatic terms.
9848 C
9849       implicit real*8 (a-h,o-z)
9850       include 'DIMENSIONS'
9851       include 'COMMON.IOUNITS'
9852       include 'COMMON.CHAIN'
9853       include 'COMMON.DERIV'
9854       include 'COMMON.INTERACT'
9855       include 'COMMON.CONTACTS'
9856       include 'COMMON.TORSION'
9857       include 'COMMON.VAR'
9858       include 'COMMON.GEO'
9859       include 'COMMON.FFIELD'
9860       double precision aa1(2,2),aa2(2,2),aa1t(2,2),aa2t(2,2),
9861      &  aa1tder(2,2,3,5),aa2tder(2,2,3,5),auxmat(2,2)
9862       logical lprn
9863       common /kutas/ lprn
9864 cd      write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
9865 cd     & ' jj=',jj,' kk=',kk
9866 cd      if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
9867 cd      write (iout,*) "a_chujij",((a_chuj(iii,jjj,jj,i),iii=1,2),jjj=1,2)
9868 cd      write (iout,*) "a_chujkl",((a_chuj(iii,jjj,kk,k),iii=1,2),jjj=1,2)
9869       do iii=1,2
9870         do jjj=1,2
9871           aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
9872           aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
9873         enddo
9874       enddo
9875       call transpose2(aa1(1,1),aa1t(1,1))
9876       call transpose2(aa2(1,1),aa2t(1,1))
9877       do kkk=1,5
9878         do lll=1,3
9879           call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),
9880      &      aa1tder(1,1,lll,kkk))
9881           call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),
9882      &      aa2tder(1,1,lll,kkk))
9883         enddo
9884       enddo
9885       if (l.eq.j+1) then
9886 C parallel orientation of the two CA-CA-CA frames.
9887         if (i.gt.1) then
9888           iti=itype2loc(itype(i))
9889         else
9890           iti=nloctyp
9891         endif
9892         itk1=itype2loc(itype(k+1))
9893         itj=itype2loc(itype(j))
9894         if (l.lt.nres-1) then
9895           itl1=itype2loc(itype(l+1))
9896         else
9897           itl1=nloctyp
9898         endif
9899 C A1 kernel(j+1) A2T
9900 cd        do iii=1,2
9901 cd          write (iout,'(3f10.5,5x,3f10.5)')
9902 cd     &     (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
9903 cd        enddo
9904         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9905      &   aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),
9906      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
9907 C Following matrices are needed only for 6-th order cumulants
9908         IF (wcorr6.gt.0.0d0) THEN
9909         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9910      &   aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),
9911      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
9912         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9913      &   aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),
9914      &   Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
9915      &   ADtEAderx(1,1,1,1,1,1))
9916         lprn=.false.
9917         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9918      &   aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),
9919      &   DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
9920      &   ADtEA1derx(1,1,1,1,1,1))
9921         ENDIF
9922 C End 6-th order cumulants
9923 cd        lprn=.false.
9924 cd        if (lprn) then
9925 cd        write (2,*) 'In calc_eello6'
9926 cd        do iii=1,2
9927 cd          write (2,*) 'iii=',iii
9928 cd          do kkk=1,5
9929 cd            write (2,*) 'kkk=',kkk
9930 cd            do jjj=1,2
9931 cd              write (2,'(3(2f10.5),5x)')
9932 cd     &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
9933 cd            enddo
9934 cd          enddo
9935 cd        enddo
9936 cd        endif
9937         call transpose2(EUgder(1,1,k),auxmat(1,1))
9938         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
9939         call transpose2(EUg(1,1,k),auxmat(1,1))
9940         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
9941         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
9942 C AL 4/16/16: Derivatives of the quantitied related to matrices C, D, and E
9943 c    in theta; to be sriten later.
9944 c#ifdef NEWCORR
9945 c        call transpose2(gtEE(1,1,k),auxmat(1,1))
9946 c        call matmat2(auxmat(1,1),AEA(1,1,1),EAEAdert(1,1,1,1))
9947 c        call transpose2(EUg(1,1,k),auxmat(1,1))
9948 c        call matmat2(auxmat(1,1),AEAdert(1,1,1),EAEAdert(1,1,2,1))
9949 c#endif
9950         do iii=1,2
9951           do kkk=1,5
9952             do lll=1,3
9953               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
9954      &          EAEAderx(1,1,lll,kkk,iii,1))
9955             enddo
9956           enddo
9957         enddo
9958 C A1T kernel(i+1) A2
9959         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
9960      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),
9961      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
9962 C Following matrices are needed only for 6-th order cumulants
9963         IF (wcorr6.gt.0.0d0) THEN
9964         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
9965      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),
9966      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
9967         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
9968      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),
9969      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
9970      &   ADtEAderx(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.,DtUg2EUg(1,1,k),
9973      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
9974      &   ADtEA1derx(1,1,1,1,1,2))
9975         ENDIF
9976 C End 6-th order cumulants
9977         call transpose2(EUgder(1,1,l),auxmat(1,1))
9978         call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
9979         call transpose2(EUg(1,1,l),auxmat(1,1))
9980         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
9981         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
9982         do iii=1,2
9983           do kkk=1,5
9984             do lll=1,3
9985               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
9986      &          EAEAderx(1,1,lll,kkk,iii,2))
9987             enddo
9988           enddo
9989         enddo
9990 C AEAb1 and AEAb2
9991 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
9992 C They are needed only when the fifth- or the sixth-order cumulants are
9993 C indluded.
9994         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
9995         call transpose2(AEA(1,1,1),auxmat(1,1))
9996         call matvec2(auxmat(1,1),b1(1,i),AEAb1(1,1,1))
9997         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
9998         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
9999         call transpose2(AEAderg(1,1,1),auxmat(1,1))
10000         call matvec2(auxmat(1,1),b1(1,i),AEAb1derg(1,1,1))
10001         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
10002         call matvec2(AEA(1,1,1),b1(1,k+1),AEAb1(1,2,1))
10003         call matvec2(AEAderg(1,1,1),b1(1,k+1),AEAb1derg(1,2,1))
10004         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
10005         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
10006         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
10007         call transpose2(AEA(1,1,2),auxmat(1,1))
10008         call matvec2(auxmat(1,1),b1(1,j),AEAb1(1,1,2))
10009         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
10010         call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
10011         call transpose2(AEAderg(1,1,2),auxmat(1,1))
10012         call matvec2(auxmat(1,1),b1(1,j),AEAb1derg(1,1,2))
10013         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
10014         call matvec2(AEA(1,1,2),b1(1,l+1),AEAb1(1,2,2))
10015         call matvec2(AEAderg(1,1,2),b1(1,l+1),AEAb1derg(1,2,2))
10016         call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
10017         call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
10018         call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
10019 C Calculate the Cartesian derivatives of the vectors.
10020         do iii=1,2
10021           do kkk=1,5
10022             do lll=1,3
10023               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
10024               call matvec2(auxmat(1,1),b1(1,i),
10025      &          AEAb1derx(1,lll,kkk,iii,1,1))
10026               call matvec2(auxmat(1,1),Ub2(1,i),
10027      &          AEAb2derx(1,lll,kkk,iii,1,1))
10028               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
10029      &          AEAb1derx(1,lll,kkk,iii,2,1))
10030               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
10031      &          AEAb2derx(1,lll,kkk,iii,2,1))
10032               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
10033               call matvec2(auxmat(1,1),b1(1,j),
10034      &          AEAb1derx(1,lll,kkk,iii,1,2))
10035               call matvec2(auxmat(1,1),Ub2(1,j),
10036      &          AEAb2derx(1,lll,kkk,iii,1,2))
10037               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,l+1),
10038      &          AEAb1derx(1,lll,kkk,iii,2,2))
10039               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),
10040      &          AEAb2derx(1,lll,kkk,iii,2,2))
10041             enddo
10042           enddo
10043         enddo
10044         ENDIF
10045 C End vectors
10046       else
10047 C Antiparallel orientation of the two CA-CA-CA frames.
10048         if (i.gt.1) then
10049           iti=itype2loc(itype(i))
10050         else
10051           iti=nloctyp
10052         endif
10053         itk1=itype2loc(itype(k+1))
10054         itl=itype2loc(itype(l))
10055         itj=itype2loc(itype(j))
10056         if (j.lt.nres-1) then
10057           itj1=itype2loc(itype(j+1))
10058         else
10059           itj1=nloctyp
10060         endif
10061 C A2 kernel(j-1)T A1T
10062         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
10063      &   aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),
10064      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
10065 C Following matrices are needed only for 6-th order cumulants
10066         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
10067      &     j.eq.i+4 .and. l.eq.i+3)) THEN
10068         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
10069      &   aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),
10070      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
10071         call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
10072      &   aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),
10073      &   Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
10074      &   ADtEAderx(1,1,1,1,1,1))
10075         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
10076      &   aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),
10077      &   DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
10078      &   ADtEA1derx(1,1,1,1,1,1))
10079         ENDIF
10080 C End 6-th order cumulants
10081         call transpose2(EUgder(1,1,k),auxmat(1,1))
10082         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
10083         call transpose2(EUg(1,1,k),auxmat(1,1))
10084         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
10085         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
10086         do iii=1,2
10087           do kkk=1,5
10088             do lll=1,3
10089               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
10090      &          EAEAderx(1,1,lll,kkk,iii,1))
10091             enddo
10092           enddo
10093         enddo
10094 C A2T kernel(i+1)T A1
10095         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
10096      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),
10097      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
10098 C Following matrices are needed only for 6-th order cumulants
10099         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
10100      &     j.eq.i+4 .and. l.eq.i+3)) THEN
10101         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
10102      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),
10103      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
10104         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
10105      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),
10106      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
10107      &   ADtEAderx(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.,DtUg2EUg(1,1,k),
10110      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
10111      &   ADtEA1derx(1,1,1,1,1,2))
10112         ENDIF
10113 C End 6-th order cumulants
10114         call transpose2(EUgder(1,1,j),auxmat(1,1))
10115         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
10116         call transpose2(EUg(1,1,j),auxmat(1,1))
10117         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
10118         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
10119         do iii=1,2
10120           do kkk=1,5
10121             do lll=1,3
10122               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
10123      &          EAEAderx(1,1,lll,kkk,iii,2))
10124             enddo
10125           enddo
10126         enddo
10127 C AEAb1 and AEAb2
10128 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
10129 C They are needed only when the fifth- or the sixth-order cumulants are
10130 C indluded.
10131         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or.
10132      &    (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
10133         call transpose2(AEA(1,1,1),auxmat(1,1))
10134         call matvec2(auxmat(1,1),b1(1,i),AEAb1(1,1,1))
10135         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
10136         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
10137         call transpose2(AEAderg(1,1,1),auxmat(1,1))
10138         call matvec2(auxmat(1,1),b1(1,i),AEAb1derg(1,1,1))
10139         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
10140         call matvec2(AEA(1,1,1),b1(1,k+1),AEAb1(1,2,1))
10141         call matvec2(AEAderg(1,1,1),b1(1,k+1),AEAb1derg(1,2,1))
10142         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
10143         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
10144         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
10145         call transpose2(AEA(1,1,2),auxmat(1,1))
10146         call matvec2(auxmat(1,1),b1(1,j+1),AEAb1(1,1,2))
10147         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
10148         call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
10149         call transpose2(AEAderg(1,1,2),auxmat(1,1))
10150         call matvec2(auxmat(1,1),b1(1,l),AEAb1(1,1,2))
10151         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
10152         call matvec2(AEA(1,1,2),b1(1,j+1),AEAb1(1,2,2))
10153         call matvec2(AEAderg(1,1,2),b1(1,j+1),AEAb1derg(1,2,2))
10154         call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
10155         call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
10156         call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
10157 C Calculate the Cartesian derivatives of the vectors.
10158         do iii=1,2
10159           do kkk=1,5
10160             do lll=1,3
10161               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
10162               call matvec2(auxmat(1,1),b1(1,i),
10163      &          AEAb1derx(1,lll,kkk,iii,1,1))
10164               call matvec2(auxmat(1,1),Ub2(1,i),
10165      &          AEAb2derx(1,lll,kkk,iii,1,1))
10166               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
10167      &          AEAb1derx(1,lll,kkk,iii,2,1))
10168               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
10169      &          AEAb2derx(1,lll,kkk,iii,2,1))
10170               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
10171               call matvec2(auxmat(1,1),b1(1,l),
10172      &          AEAb1derx(1,lll,kkk,iii,1,2))
10173               call matvec2(auxmat(1,1),Ub2(1,l),
10174      &          AEAb2derx(1,lll,kkk,iii,1,2))
10175               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,j+1),
10176      &          AEAb1derx(1,lll,kkk,iii,2,2))
10177               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),
10178      &          AEAb2derx(1,lll,kkk,iii,2,2))
10179             enddo
10180           enddo
10181         enddo
10182         ENDIF
10183 C End vectors
10184       endif
10185       return
10186       end
10187 C---------------------------------------------------------------------------
10188       subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,
10189      &  KK,KKderg,AKA,AKAderg,AKAderx)
10190       implicit none
10191       integer nderg
10192       logical transp
10193       double precision aa1(2,2),aa2t(2,2),aa1derx(2,2,3,5),
10194      &  aa2tderx(2,2,3,5),KK(2,2),KKderg(2,2,nderg),AKA(2,2),
10195      &  AKAderg(2,2,nderg),AKAderx(2,2,3,5,2)
10196       integer iii,kkk,lll
10197       integer jjj,mmm
10198       logical lprn
10199       common /kutas/ lprn
10200       call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
10201       do iii=1,nderg
10202         call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,
10203      &    AKAderg(1,1,iii))
10204       enddo
10205 cd      if (lprn) write (2,*) 'In kernel'
10206       do kkk=1,5
10207 cd        if (lprn) write (2,*) 'kkk=',kkk
10208         do lll=1,3
10209           call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),
10210      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
10211 cd          if (lprn) then
10212 cd            write (2,*) 'lll=',lll
10213 cd            write (2,*) 'iii=1'
10214 cd            do jjj=1,2
10215 cd              write (2,'(3(2f10.5),5x)')
10216 cd     &        (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
10217 cd            enddo
10218 cd          endif
10219           call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),
10220      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
10221 cd          if (lprn) then
10222 cd            write (2,*) 'lll=',lll
10223 cd            write (2,*) 'iii=2'
10224 cd            do jjj=1,2
10225 cd              write (2,'(3(2f10.5),5x)')
10226 cd     &        (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
10227 cd            enddo
10228 cd          endif
10229         enddo
10230       enddo
10231       return
10232       end
10233 C---------------------------------------------------------------------------
10234       double precision function eello4(i,j,k,l,jj,kk)
10235       implicit real*8 (a-h,o-z)
10236       include 'DIMENSIONS'
10237       include 'COMMON.IOUNITS'
10238       include 'COMMON.CHAIN'
10239       include 'COMMON.DERIV'
10240       include 'COMMON.INTERACT'
10241       include 'COMMON.CONTACTS'
10242       include 'COMMON.TORSION'
10243       include 'COMMON.VAR'
10244       include 'COMMON.GEO'
10245       double precision pizda(2,2),ggg1(3),ggg2(3)
10246 cd      if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
10247 cd        eello4=0.0d0
10248 cd        return
10249 cd      endif
10250 cd      print *,'eello4:',i,j,k,l,jj,kk
10251 cd      write (2,*) 'i',i,' j',j,' k',k,' l',l
10252 cd      call checkint4(i,j,k,l,jj,kk,eel4_num)
10253 cold      eij=facont_hb(jj,i)
10254 cold      ekl=facont_hb(kk,k)
10255 cold      ekont=eij*ekl
10256       eel4=-EAEA(1,1,1)-EAEA(2,2,1)
10257 cd      eel41=-EAEA(1,1,2)-EAEA(2,2,2)
10258       gcorr_loc(k-1)=gcorr_loc(k-1)
10259      &   -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
10260       if (l.eq.j+1) then
10261         gcorr_loc(l-1)=gcorr_loc(l-1)
10262      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
10263 C Al 4/16/16: Derivatives in theta, to be added later.
10264 c#ifdef NEWCORR
10265 c        gcorr_loc(nphi+l-1)=gcorr_loc(nphi+l-1)
10266 c     &     -ekont*(EAEAdert(1,1,2,1)+EAEAdert(2,2,2,1))
10267 c#endif
10268       else
10269         gcorr_loc(j-1)=gcorr_loc(j-1)
10270      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
10271 c#ifdef NEWCORR
10272 c        gcorr_loc(nphi+j-1)=gcorr_loc(nphi+j-1)
10273 c     &     -ekont*(EAEAdert(1,1,2,1)+EAEAdert(2,2,2,1))
10274 c#endif
10275       endif
10276       do iii=1,2
10277         do kkk=1,5
10278           do lll=1,3
10279             derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1)
10280      &                        -EAEAderx(2,2,lll,kkk,iii,1)
10281 cd            derx(lll,kkk,iii)=0.0d0
10282           enddo
10283         enddo
10284       enddo
10285 cd      gcorr_loc(l-1)=0.0d0
10286 cd      gcorr_loc(j-1)=0.0d0
10287 cd      gcorr_loc(k-1)=0.0d0
10288 cd      eel4=1.0d0
10289 cd      write (iout,*)'Contacts have occurred for peptide groups',
10290 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l,
10291 cd     &  ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
10292       if (j.lt.nres-1) then
10293         j1=j+1
10294         j2=j-1
10295       else
10296         j1=j-1
10297         j2=j-2
10298       endif
10299       if (l.lt.nres-1) then
10300         l1=l+1
10301         l2=l-1
10302       else
10303         l1=l-1
10304         l2=l-2
10305       endif
10306       do ll=1,3
10307 cgrad        ggg1(ll)=eel4*g_contij(ll,1)
10308 cgrad        ggg2(ll)=eel4*g_contij(ll,2)
10309         glongij=eel4*g_contij(ll,1)+ekont*derx(ll,1,1)
10310         glongkl=eel4*g_contij(ll,2)+ekont*derx(ll,1,2)
10311 cgrad        ghalf=0.5d0*ggg1(ll)
10312         gradcorr(ll,i)=gradcorr(ll,i)+ekont*derx(ll,2,1)
10313         gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
10314         gradcorr(ll,j)=gradcorr(ll,j)+ekont*derx(ll,4,1)
10315         gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
10316         gradcorr_long(ll,j)=gradcorr_long(ll,j)+glongij
10317         gradcorr_long(ll,i)=gradcorr_long(ll,i)-glongij
10318 cgrad        ghalf=0.5d0*ggg2(ll)
10319         gradcorr(ll,k)=gradcorr(ll,k)+ekont*derx(ll,2,2)
10320         gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
10321         gradcorr(ll,l)=gradcorr(ll,l)+ekont*derx(ll,4,2)
10322         gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
10323         gradcorr_long(ll,l)=gradcorr_long(ll,l)+glongkl
10324         gradcorr_long(ll,k)=gradcorr_long(ll,k)-glongkl
10325       enddo
10326 cgrad      do m=i+1,j-1
10327 cgrad        do ll=1,3
10328 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
10329 cgrad        enddo
10330 cgrad      enddo
10331 cgrad      do m=k+1,l-1
10332 cgrad        do ll=1,3
10333 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
10334 cgrad        enddo
10335 cgrad      enddo
10336 cgrad      do m=i+2,j2
10337 cgrad        do ll=1,3
10338 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
10339 cgrad        enddo
10340 cgrad      enddo
10341 cgrad      do m=k+2,l2
10342 cgrad        do ll=1,3
10343 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
10344 cgrad        enddo
10345 cgrad      enddo
10346 cd      do iii=1,nres-3
10347 cd        write (2,*) iii,gcorr_loc(iii)
10348 cd      enddo
10349       eello4=ekont*eel4
10350 cd      write (2,*) 'ekont',ekont
10351 cd      write (iout,*) 'eello4',ekont*eel4
10352       return
10353       end
10354 C---------------------------------------------------------------------------
10355       double precision function eello5(i,j,k,l,jj,kk)
10356       implicit real*8 (a-h,o-z)
10357       include 'DIMENSIONS'
10358       include 'COMMON.IOUNITS'
10359       include 'COMMON.CHAIN'
10360       include 'COMMON.DERIV'
10361       include 'COMMON.INTERACT'
10362       include 'COMMON.CONTACTS'
10363       include 'COMMON.TORSION'
10364       include 'COMMON.VAR'
10365       include 'COMMON.GEO'
10366       double precision pizda(2,2),auxmat(2,2),auxmat1(2,2),vv(2)
10367       double precision ggg1(3),ggg2(3)
10368 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10369 C                                                                              C
10370 C                            Parallel chains                                   C
10371 C                                                                              C
10372 C          o             o                   o             o                   C
10373 C         /l\           / \             \   / \           / \   /              C
10374 C        /   \         /   \             \ /   \         /   \ /               C
10375 C       j| o |l1       | o |              o| o |         | o |o                C
10376 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
10377 C      \i/   \         /   \ /             /   \         /   \                 C
10378 C       o    k1             o                                                  C
10379 C         (I)          (II)                (III)          (IV)                 C
10380 C                                                                              C
10381 C      eello5_1        eello5_2            eello5_3       eello5_4             C
10382 C                                                                              C
10383 C                            Antiparallel chains                               C
10384 C                                                                              C
10385 C          o             o                   o             o                   C
10386 C         /j\           / \             \   / \           / \   /              C
10387 C        /   \         /   \             \ /   \         /   \ /               C
10388 C      j1| o |l        | o |              o| o |         | o |o                C
10389 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
10390 C      \i/   \         /   \ /             /   \         /   \                 C
10391 C       o     k1            o                                                  C
10392 C         (I)          (II)                (III)          (IV)                 C
10393 C                                                                              C
10394 C      eello5_1        eello5_2            eello5_3       eello5_4             C
10395 C                                                                              C
10396 C o denotes a local interaction, vertical lines an electrostatic interaction.  C
10397 C                                                                              C
10398 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10399 cd      if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
10400 cd        eello5=0.0d0
10401 cd        return
10402 cd      endif
10403 cd      write (iout,*)
10404 cd     &   'EELLO5: Contacts have occurred for peptide groups',i,j,
10405 cd     &   ' and',k,l
10406       itk=itype2loc(itype(k))
10407       itl=itype2loc(itype(l))
10408       itj=itype2loc(itype(j))
10409       eello5_1=0.0d0
10410       eello5_2=0.0d0
10411       eello5_3=0.0d0
10412       eello5_4=0.0d0
10413 cd      call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
10414 cd     &   eel5_3_num,eel5_4_num)
10415       do iii=1,2
10416         do kkk=1,5
10417           do lll=1,3
10418             derx(lll,kkk,iii)=0.0d0
10419           enddo
10420         enddo
10421       enddo
10422 cd      eij=facont_hb(jj,i)
10423 cd      ekl=facont_hb(kk,k)
10424 cd      ekont=eij*ekl
10425 cd      write (iout,*)'Contacts have occurred for peptide groups',
10426 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l
10427 cd      goto 1111
10428 C Contribution from the graph I.
10429 cd      write (2,*) 'AEA  ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
10430 cd      write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
10431       call transpose2(EUg(1,1,k),auxmat(1,1))
10432       call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
10433       vv(1)=pizda(1,1)-pizda(2,2)
10434       vv(2)=pizda(1,2)+pizda(2,1)
10435       eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k))
10436      & +0.5d0*scalar2(vv(1),Dtobr2(1,i))
10437 C Explicit gradient in virtual-dihedral angles.
10438       if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1)
10439      & +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k))
10440      & +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
10441       call transpose2(EUgder(1,1,k),auxmat1(1,1))
10442       call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
10443       vv(1)=pizda(1,1)-pizda(2,2)
10444       vv(2)=pizda(1,2)+pizda(2,1)
10445       g_corr5_loc(k-1)=g_corr5_loc(k-1)
10446      & +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k))
10447      & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
10448       call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
10449       vv(1)=pizda(1,1)-pizda(2,2)
10450       vv(2)=pizda(1,2)+pizda(2,1)
10451       if (l.eq.j+1) then
10452         if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1)
10453      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
10454      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
10455       else
10456         if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1)
10457      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
10458      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
10459       endif
10460 C Cartesian gradient
10461       do iii=1,2
10462         do kkk=1,5
10463           do lll=1,3
10464             call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),
10465      &        pizda(1,1))
10466             vv(1)=pizda(1,1)-pizda(2,2)
10467             vv(2)=pizda(1,2)+pizda(2,1)
10468             derx(lll,kkk,iii)=derx(lll,kkk,iii)
10469      &       +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k))
10470      &       +0.5d0*scalar2(vv(1),Dtobr2(1,i))
10471           enddo
10472         enddo
10473       enddo
10474 c      goto 1112
10475 c1111  continue
10476 C Contribution from graph II
10477       call transpose2(EE(1,1,k),auxmat(1,1))
10478       call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
10479       vv(1)=pizda(1,1)+pizda(2,2)
10480       vv(2)=pizda(2,1)-pizda(1,2)
10481       eello5_2=scalar2(AEAb1(1,2,1),b1(1,k))
10482      & -0.5d0*scalar2(vv(1),Ctobr(1,k))
10483 C Explicit gradient in virtual-dihedral angles.
10484       g_corr5_loc(k-1)=g_corr5_loc(k-1)
10485      & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
10486       call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
10487       vv(1)=pizda(1,1)+pizda(2,2)
10488       vv(2)=pizda(2,1)-pizda(1,2)
10489       if (l.eq.j+1) then
10490         g_corr5_loc(l-1)=g_corr5_loc(l-1)
10491      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,k))
10492      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
10493       else
10494         g_corr5_loc(j-1)=g_corr5_loc(j-1)
10495      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,k))
10496      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
10497       endif
10498 C Cartesian gradient
10499       do iii=1,2
10500         do kkk=1,5
10501           do lll=1,3
10502             call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
10503      &        pizda(1,1))
10504             vv(1)=pizda(1,1)+pizda(2,2)
10505             vv(2)=pizda(2,1)-pizda(1,2)
10506             derx(lll,kkk,iii)=derx(lll,kkk,iii)
10507      &       +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,k))
10508      &       -0.5d0*scalar2(vv(1),Ctobr(1,k))
10509           enddo
10510         enddo
10511       enddo
10512 cd      goto 1112
10513 cd1111  continue
10514       if (l.eq.j+1) then
10515 cd        goto 1110
10516 C Parallel orientation
10517 C Contribution from graph III
10518         call transpose2(EUg(1,1,l),auxmat(1,1))
10519         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
10520         vv(1)=pizda(1,1)-pizda(2,2)
10521         vv(2)=pizda(1,2)+pizda(2,1)
10522         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l))
10523      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j))
10524 C Explicit gradient in virtual-dihedral angles.
10525         g_corr5_loc(j-1)=g_corr5_loc(j-1)
10526      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l))
10527      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
10528         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
10529         vv(1)=pizda(1,1)-pizda(2,2)
10530         vv(2)=pizda(1,2)+pizda(2,1)
10531         g_corr5_loc(k-1)=g_corr5_loc(k-1)
10532      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l))
10533      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
10534         call transpose2(EUgder(1,1,l),auxmat1(1,1))
10535         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
10536         vv(1)=pizda(1,1)-pizda(2,2)
10537         vv(2)=pizda(1,2)+pizda(2,1)
10538         g_corr5_loc(l-1)=g_corr5_loc(l-1)
10539      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l))
10540      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
10541 C Cartesian gradient
10542         do iii=1,2
10543           do kkk=1,5
10544             do lll=1,3
10545               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
10546      &          pizda(1,1))
10547               vv(1)=pizda(1,1)-pizda(2,2)
10548               vv(2)=pizda(1,2)+pizda(2,1)
10549               derx(lll,kkk,iii)=derx(lll,kkk,iii)
10550      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l))
10551      &         +0.5d0*scalar2(vv(1),Dtobr2(1,j))
10552             enddo
10553           enddo
10554         enddo
10555 cd        goto 1112
10556 C Contribution from graph IV
10557 cd1110    continue
10558         call transpose2(EE(1,1,l),auxmat(1,1))
10559         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
10560         vv(1)=pizda(1,1)+pizda(2,2)
10561         vv(2)=pizda(2,1)-pizda(1,2)
10562         eello5_4=scalar2(AEAb1(1,2,2),b1(1,l))
10563      &   -0.5d0*scalar2(vv(1),Ctobr(1,l))
10564 C Explicit gradient in virtual-dihedral angles.
10565         g_corr5_loc(l-1)=g_corr5_loc(l-1)
10566      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
10567         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
10568         vv(1)=pizda(1,1)+pizda(2,2)
10569         vv(2)=pizda(2,1)-pizda(1,2)
10570         g_corr5_loc(k-1)=g_corr5_loc(k-1)
10571      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,l))
10572      &   -0.5d0*scalar2(vv(1),Ctobr(1,l)))
10573 C Cartesian gradient
10574         do iii=1,2
10575           do kkk=1,5
10576             do lll=1,3
10577               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
10578      &          pizda(1,1))
10579               vv(1)=pizda(1,1)+pizda(2,2)
10580               vv(2)=pizda(2,1)-pizda(1,2)
10581               derx(lll,kkk,iii)=derx(lll,kkk,iii)
10582      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,l))
10583      &         -0.5d0*scalar2(vv(1),Ctobr(1,l))
10584             enddo
10585           enddo
10586         enddo
10587       else
10588 C Antiparallel orientation
10589 C Contribution from graph III
10590 c        goto 1110
10591         call transpose2(EUg(1,1,j),auxmat(1,1))
10592         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
10593         vv(1)=pizda(1,1)-pizda(2,2)
10594         vv(2)=pizda(1,2)+pizda(2,1)
10595         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j))
10596      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l))
10597 C Explicit gradient in virtual-dihedral angles.
10598         g_corr5_loc(l-1)=g_corr5_loc(l-1)
10599      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j))
10600      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
10601         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
10602         vv(1)=pizda(1,1)-pizda(2,2)
10603         vv(2)=pizda(1,2)+pizda(2,1)
10604         g_corr5_loc(k-1)=g_corr5_loc(k-1)
10605      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j))
10606      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
10607         call transpose2(EUgder(1,1,j),auxmat1(1,1))
10608         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
10609         vv(1)=pizda(1,1)-pizda(2,2)
10610         vv(2)=pizda(1,2)+pizda(2,1)
10611         g_corr5_loc(j-1)=g_corr5_loc(j-1)
10612      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j))
10613      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
10614 C Cartesian gradient
10615         do iii=1,2
10616           do kkk=1,5
10617             do lll=1,3
10618               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
10619      &          pizda(1,1))
10620               vv(1)=pizda(1,1)-pizda(2,2)
10621               vv(2)=pizda(1,2)+pizda(2,1)
10622               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
10623      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j))
10624      &         +0.5d0*scalar2(vv(1),Dtobr2(1,l))
10625             enddo
10626           enddo
10627         enddo
10628 cd        goto 1112
10629 C Contribution from graph IV
10630 1110    continue
10631         call transpose2(EE(1,1,j),auxmat(1,1))
10632         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
10633         vv(1)=pizda(1,1)+pizda(2,2)
10634         vv(2)=pizda(2,1)-pizda(1,2)
10635         eello5_4=scalar2(AEAb1(1,2,2),b1(1,j))
10636      &   -0.5d0*scalar2(vv(1),Ctobr(1,j))
10637 C Explicit gradient in virtual-dihedral angles.
10638         g_corr5_loc(j-1)=g_corr5_loc(j-1)
10639      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
10640         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
10641         vv(1)=pizda(1,1)+pizda(2,2)
10642         vv(2)=pizda(2,1)-pizda(1,2)
10643         g_corr5_loc(k-1)=g_corr5_loc(k-1)
10644      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,j))
10645      &   -0.5d0*scalar2(vv(1),Ctobr(1,j)))
10646 C Cartesian gradient
10647         do iii=1,2
10648           do kkk=1,5
10649             do lll=1,3
10650               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
10651      &          pizda(1,1))
10652               vv(1)=pizda(1,1)+pizda(2,2)
10653               vv(2)=pizda(2,1)-pizda(1,2)
10654               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
10655      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,j))
10656      &         -0.5d0*scalar2(vv(1),Ctobr(1,j))
10657             enddo
10658           enddo
10659         enddo
10660       endif
10661 1112  continue
10662       eel5=eello5_1+eello5_2+eello5_3+eello5_4
10663 cd      if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
10664 cd        write (2,*) 'ijkl',i,j,k,l
10665 cd        write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
10666 cd     &     ' eello5_3',eello5_3,' eello5_4',eello5_4
10667 cd      endif
10668 cd      write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
10669 cd      write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
10670 cd      write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
10671 cd      write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
10672       if (j.lt.nres-1) then
10673         j1=j+1
10674         j2=j-1
10675       else
10676         j1=j-1
10677         j2=j-2
10678       endif
10679       if (l.lt.nres-1) then
10680         l1=l+1
10681         l2=l-1
10682       else
10683         l1=l-1
10684         l2=l-2
10685       endif
10686 cd      eij=1.0d0
10687 cd      ekl=1.0d0
10688 cd      ekont=1.0d0
10689 cd      write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
10690 C 2/11/08 AL Gradients over DC's connecting interacting sites will be
10691 C        summed up outside the subrouine as for the other subroutines
10692 C        handling long-range interactions. The old code is commented out
10693 C        with "cgrad" to keep track of changes.
10694       do ll=1,3
10695 cgrad        ggg1(ll)=eel5*g_contij(ll,1)
10696 cgrad        ggg2(ll)=eel5*g_contij(ll,2)
10697         gradcorr5ij=eel5*g_contij(ll,1)+ekont*derx(ll,1,1)
10698         gradcorr5kl=eel5*g_contij(ll,2)+ekont*derx(ll,1,2)
10699 c        write (iout,'(a,3i3,a,5f8.3,2i3,a,5f8.3,a,f8.3)')
10700 c     &   "ecorr5",ll,i,j," derx",derx(ll,2,1),derx(ll,3,1),derx(ll,4,1),
10701 c     &   derx(ll,5,1),k,l," derx",derx(ll,2,2),derx(ll,3,2),
10702 c     &   derx(ll,4,2),derx(ll,5,2)," ekont",ekont
10703 c        write (iout,'(a,3i3,a,3f8.3,2i3,a,3f8.3)')
10704 c     &   "ecorr5",ll,i,j," gradcorr5",g_contij(ll,1),derx(ll,1,1),
10705 c     &   gradcorr5ij,
10706 c     &   k,l," gradcorr5",g_contij(ll,2),derx(ll,1,2),gradcorr5kl
10707 cold        ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
10708 cgrad        ghalf=0.5d0*ggg1(ll)
10709 cd        ghalf=0.0d0
10710         gradcorr5(ll,i)=gradcorr5(ll,i)+ekont*derx(ll,2,1)
10711         gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
10712         gradcorr5(ll,j)=gradcorr5(ll,j)+ekont*derx(ll,4,1)
10713         gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
10714         gradcorr5_long(ll,j)=gradcorr5_long(ll,j)+gradcorr5ij
10715         gradcorr5_long(ll,i)=gradcorr5_long(ll,i)-gradcorr5ij
10716 cold        ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
10717 cgrad        ghalf=0.5d0*ggg2(ll)
10718 cd        ghalf=0.0d0
10719         gradcorr5(ll,k)=gradcorr5(ll,k)+ekont*derx(ll,2,2)
10720         gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
10721         gradcorr5(ll,l)=gradcorr5(ll,l)+ekont*derx(ll,4,2)
10722         gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
10723         gradcorr5_long(ll,l)=gradcorr5_long(ll,l)+gradcorr5kl
10724         gradcorr5_long(ll,k)=gradcorr5_long(ll,k)-gradcorr5kl
10725       enddo
10726 cd      goto 1112
10727 cgrad      do m=i+1,j-1
10728 cgrad        do ll=1,3
10729 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
10730 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
10731 cgrad        enddo
10732 cgrad      enddo
10733 cgrad      do m=k+1,l-1
10734 cgrad        do ll=1,3
10735 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
10736 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
10737 cgrad        enddo
10738 cgrad      enddo
10739 c1112  continue
10740 cgrad      do m=i+2,j2
10741 cgrad        do ll=1,3
10742 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
10743 cgrad        enddo
10744 cgrad      enddo
10745 cgrad      do m=k+2,l2
10746 cgrad        do ll=1,3
10747 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
10748 cgrad        enddo
10749 cgrad      enddo
10750 cd      do iii=1,nres-3
10751 cd        write (2,*) iii,g_corr5_loc(iii)
10752 cd      enddo
10753       eello5=ekont*eel5
10754 cd      write (2,*) 'ekont',ekont
10755 cd      write (iout,*) 'eello5',ekont*eel5
10756       return
10757       end
10758 c--------------------------------------------------------------------------
10759       double precision function eello6(i,j,k,l,jj,kk)
10760       implicit real*8 (a-h,o-z)
10761       include 'DIMENSIONS'
10762       include 'COMMON.IOUNITS'
10763       include 'COMMON.CHAIN'
10764       include 'COMMON.DERIV'
10765       include 'COMMON.INTERACT'
10766       include 'COMMON.CONTACTS'
10767       include 'COMMON.TORSION'
10768       include 'COMMON.VAR'
10769       include 'COMMON.GEO'
10770       include 'COMMON.FFIELD'
10771       double precision ggg1(3),ggg2(3)
10772 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
10773 cd        eello6=0.0d0
10774 cd        return
10775 cd      endif
10776 cd      write (iout,*)
10777 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
10778 cd     &   ' and',k,l
10779       eello6_1=0.0d0
10780       eello6_2=0.0d0
10781       eello6_3=0.0d0
10782       eello6_4=0.0d0
10783       eello6_5=0.0d0
10784       eello6_6=0.0d0
10785 cd      call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
10786 cd     &   eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
10787       do iii=1,2
10788         do kkk=1,5
10789           do lll=1,3
10790             derx(lll,kkk,iii)=0.0d0
10791           enddo
10792         enddo
10793       enddo
10794 cd      eij=facont_hb(jj,i)
10795 cd      ekl=facont_hb(kk,k)
10796 cd      ekont=eij*ekl
10797 cd      eij=1.0d0
10798 cd      ekl=1.0d0
10799 cd      ekont=1.0d0
10800       if (l.eq.j+1) then
10801         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
10802         eello6_2=eello6_graph1(j,i,l,k,2,.false.)
10803         eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
10804         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
10805         eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
10806         eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
10807       else
10808         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
10809         eello6_2=eello6_graph1(l,k,j,i,2,.true.)
10810         eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
10811         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
10812         if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
10813           eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
10814         else
10815           eello6_5=0.0d0
10816         endif
10817         eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
10818       endif
10819 C If turn contributions are considered, they will be handled separately.
10820       eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
10821 cd      write(iout,*) 'eello6_1',eello6_1!,' eel6_1_num',16*eel6_1_num
10822 cd      write(iout,*) 'eello6_2',eello6_2!,' eel6_2_num',16*eel6_2_num
10823 cd      write(iout,*) 'eello6_3',eello6_3!,' eel6_3_num',16*eel6_3_num
10824 cd      write(iout,*) 'eello6_4',eello6_4!,' eel6_4_num',16*eel6_4_num
10825 cd      write(iout,*) 'eello6_5',eello6_5!,' eel6_5_num',16*eel6_5_num
10826 cd      write(iout,*) 'eello6_6',eello6_6!,' eel6_6_num',16*eel6_6_num
10827 cd      goto 1112
10828       if (j.lt.nres-1) then
10829         j1=j+1
10830         j2=j-1
10831       else
10832         j1=j-1
10833         j2=j-2
10834       endif
10835       if (l.lt.nres-1) then
10836         l1=l+1
10837         l2=l-1
10838       else
10839         l1=l-1
10840         l2=l-2
10841       endif
10842       do ll=1,3
10843 cgrad        ggg1(ll)=eel6*g_contij(ll,1)
10844 cgrad        ggg2(ll)=eel6*g_contij(ll,2)
10845 cold        ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
10846 cgrad        ghalf=0.5d0*ggg1(ll)
10847 cd        ghalf=0.0d0
10848         gradcorr6ij=eel6*g_contij(ll,1)+ekont*derx(ll,1,1)
10849         gradcorr6kl=eel6*g_contij(ll,2)+ekont*derx(ll,1,2)
10850         gradcorr6(ll,i)=gradcorr6(ll,i)+ekont*derx(ll,2,1)
10851         gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
10852         gradcorr6(ll,j)=gradcorr6(ll,j)+ekont*derx(ll,4,1)
10853         gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
10854         gradcorr6_long(ll,j)=gradcorr6_long(ll,j)+gradcorr6ij
10855         gradcorr6_long(ll,i)=gradcorr6_long(ll,i)-gradcorr6ij
10856 cgrad        ghalf=0.5d0*ggg2(ll)
10857 cold        ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
10858 cd        ghalf=0.0d0
10859         gradcorr6(ll,k)=gradcorr6(ll,k)+ekont*derx(ll,2,2)
10860         gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
10861         gradcorr6(ll,l)=gradcorr6(ll,l)+ekont*derx(ll,4,2)
10862         gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
10863         gradcorr6_long(ll,l)=gradcorr6_long(ll,l)+gradcorr6kl
10864         gradcorr6_long(ll,k)=gradcorr6_long(ll,k)-gradcorr6kl
10865       enddo
10866 cd      goto 1112
10867 cgrad      do m=i+1,j-1
10868 cgrad        do ll=1,3
10869 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
10870 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
10871 cgrad        enddo
10872 cgrad      enddo
10873 cgrad      do m=k+1,l-1
10874 cgrad        do ll=1,3
10875 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
10876 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
10877 cgrad        enddo
10878 cgrad      enddo
10879 cgrad1112  continue
10880 cgrad      do m=i+2,j2
10881 cgrad        do ll=1,3
10882 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
10883 cgrad        enddo
10884 cgrad      enddo
10885 cgrad      do m=k+2,l2
10886 cgrad        do ll=1,3
10887 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
10888 cgrad        enddo
10889 cgrad      enddo
10890 cd      do iii=1,nres-3
10891 cd        write (2,*) iii,g_corr6_loc(iii)
10892 cd      enddo
10893       eello6=ekont*eel6
10894 cd      write (2,*) 'ekont',ekont
10895 cd      write (iout,*) 'eello6',ekont*eel6
10896       return
10897       end
10898 c--------------------------------------------------------------------------
10899       double precision function eello6_graph1(i,j,k,l,imat,swap)
10900       implicit real*8 (a-h,o-z)
10901       include 'DIMENSIONS'
10902       include 'COMMON.IOUNITS'
10903       include 'COMMON.CHAIN'
10904       include 'COMMON.DERIV'
10905       include 'COMMON.INTERACT'
10906       include 'COMMON.CONTACTS'
10907       include 'COMMON.TORSION'
10908       include 'COMMON.VAR'
10909       include 'COMMON.GEO'
10910       double precision vv(2),vv1(2),pizda(2,2),auxmat(2,2),pizda1(2,2)
10911       logical swap
10912       logical lprn
10913       common /kutas/ lprn
10914 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10915 C                                                                              C
10916 C      Parallel       Antiparallel                                             C
10917 C                                                                              C
10918 C          o             o                                                     C
10919 C         /l\           /j\                                                    C
10920 C        /   \         /   \                                                   C
10921 C       /| o |         | o |\                                                  C
10922 C     \ j|/k\|  /   \  |/k\|l /                                                C
10923 C      \ /   \ /     \ /   \ /                                                 C
10924 C       o     o       o     o                                                  C
10925 C       i             i                                                        C
10926 C                                                                              C
10927 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10928       itk=itype2loc(itype(k))
10929       s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
10930       s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
10931       s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
10932       call transpose2(EUgC(1,1,k),auxmat(1,1))
10933       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
10934       vv1(1)=pizda1(1,1)-pizda1(2,2)
10935       vv1(2)=pizda1(1,2)+pizda1(2,1)
10936       s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
10937       vv(1)=AEAb1(1,2,imat)*b1(1,k)-AEAb1(2,2,imat)*b1(2,k)
10938       vv(2)=AEAb1(1,2,imat)*b1(2,k)+AEAb1(2,2,imat)*b1(1,k)
10939       s5=scalar2(vv(1),Dtobr2(1,i))
10940 cd      write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
10941       eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
10942       if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1)
10943      & -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i))
10944      & -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k))
10945      & +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k))
10946      & +0.5d0*scalar2(vv1(1),Dtobr2der(1,i))
10947      & +scalar2(vv(1),Dtobr2der(1,i)))
10948       call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
10949       vv1(1)=pizda1(1,1)-pizda1(2,2)
10950       vv1(2)=pizda1(1,2)+pizda1(2,1)
10951       vv(1)=AEAb1derg(1,2,imat)*b1(1,k)-AEAb1derg(2,2,imat)*b1(2,k)
10952       vv(2)=AEAb1derg(1,2,imat)*b1(2,k)+AEAb1derg(2,2,imat)*b1(1,k)
10953       if (l.eq.j+1) then
10954         g_corr6_loc(l-1)=g_corr6_loc(l-1)
10955      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
10956      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
10957      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
10958      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
10959       else
10960         g_corr6_loc(j-1)=g_corr6_loc(j-1)
10961      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
10962      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
10963      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
10964      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
10965       endif
10966       call transpose2(EUgCder(1,1,k),auxmat(1,1))
10967       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
10968       vv1(1)=pizda1(1,1)-pizda1(2,2)
10969       vv1(2)=pizda1(1,2)+pizda1(2,1)
10970       if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1)
10971      & +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k))
10972      & +scalar2(AEAb2(1,1,imat),CUgb2der(1,k))
10973      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
10974       do iii=1,2
10975         if (swap) then
10976           ind=3-iii
10977         else
10978           ind=iii
10979         endif
10980         do kkk=1,5
10981           do lll=1,3
10982             s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
10983             s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
10984             s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
10985             call transpose2(EUgC(1,1,k),auxmat(1,1))
10986             call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
10987      &        pizda1(1,1))
10988             vv1(1)=pizda1(1,1)-pizda1(2,2)
10989             vv1(2)=pizda1(1,2)+pizda1(2,1)
10990             s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
10991             vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,k)
10992      &       -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,k)
10993             vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,k)
10994      &       +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,k)
10995             s5=scalar2(vv(1),Dtobr2(1,i))
10996             derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
10997           enddo
10998         enddo
10999       enddo
11000       return
11001       end
11002 c----------------------------------------------------------------------------
11003       double precision function eello6_graph2(i,j,k,l,jj,kk,swap)
11004       implicit real*8 (a-h,o-z)
11005       include 'DIMENSIONS'
11006       include 'COMMON.IOUNITS'
11007       include 'COMMON.CHAIN'
11008       include 'COMMON.DERIV'
11009       include 'COMMON.INTERACT'
11010       include 'COMMON.CONTACTS'
11011       include 'COMMON.TORSION'
11012       include 'COMMON.VAR'
11013       include 'COMMON.GEO'
11014       logical swap
11015       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
11016      & auxvec1(2),auxvec2(2),auxmat1(2,2)
11017       logical lprn
11018       common /kutas/ lprn
11019 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
11020 C                                                                              C
11021 C      Parallel       Antiparallel                                             C
11022 C                                                                              C
11023 C          o             o                                                     C
11024 C     \   /l\           /j\   /                                                C
11025 C      \ /   \         /   \ /                                                 C
11026 C       o| o |         | o |o                                                  C
11027 C     \ j|/k\|      \  |/k\|l                                                  C
11028 C      \ /   \       \ /   \                                                   C
11029 C       o             o                                                        C
11030 C       i             i                                                        C
11031 C                                                                              C
11032 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
11033 cd      write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
11034 C AL 7/4/01 s1 would occur in the sixth-order moment,
11035 C           but not in a cluster cumulant
11036 #ifdef MOMENT
11037       s1=dip(1,jj,i)*dip(1,kk,k)
11038 #endif
11039       call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
11040       s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
11041       call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
11042       s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
11043       call transpose2(EUg(1,1,k),auxmat(1,1))
11044       call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
11045       vv(1)=pizda(1,1)-pizda(2,2)
11046       vv(2)=pizda(1,2)+pizda(2,1)
11047       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
11048 cd      write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
11049 #ifdef MOMENT
11050       eello6_graph2=-(s1+s2+s3+s4)
11051 #else
11052       eello6_graph2=-(s2+s3+s4)
11053 #endif
11054 c      eello6_graph2=-s3
11055 C Derivatives in gamma(i-1)
11056       if (i.gt.1) then
11057 #ifdef MOMENT
11058         s1=dipderg(1,jj,i)*dip(1,kk,k)
11059 #endif
11060         s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
11061         call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
11062         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
11063         s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
11064 #ifdef MOMENT
11065         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
11066 #else
11067         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
11068 #endif
11069 c        g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
11070       endif
11071 C Derivatives in gamma(k-1)
11072 #ifdef MOMENT
11073       s1=dip(1,jj,i)*dipderg(1,kk,k)
11074 #endif
11075       call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
11076       s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
11077       call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
11078       s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
11079       call transpose2(EUgder(1,1,k),auxmat1(1,1))
11080       call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
11081       vv(1)=pizda(1,1)-pizda(2,2)
11082       vv(2)=pizda(1,2)+pizda(2,1)
11083       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
11084 #ifdef MOMENT
11085       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
11086 #else
11087       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
11088 #endif
11089 c      g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
11090 C Derivatives in gamma(j-1) or gamma(l-1)
11091       if (j.gt.1) then
11092 #ifdef MOMENT
11093         s1=dipderg(3,jj,i)*dip(1,kk,k)
11094 #endif
11095         call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
11096         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
11097         s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
11098         call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
11099         vv(1)=pizda(1,1)-pizda(2,2)
11100         vv(2)=pizda(1,2)+pizda(2,1)
11101         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
11102 #ifdef MOMENT
11103         if (swap) then
11104           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
11105         else
11106           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
11107         endif
11108 #endif
11109         g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
11110 c        g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
11111       endif
11112 C Derivatives in gamma(l-1) or gamma(j-1)
11113       if (l.gt.1) then
11114 #ifdef MOMENT
11115         s1=dip(1,jj,i)*dipderg(3,kk,k)
11116 #endif
11117         call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
11118         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
11119         call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
11120         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
11121         call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
11122         vv(1)=pizda(1,1)-pizda(2,2)
11123         vv(2)=pizda(1,2)+pizda(2,1)
11124         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
11125 #ifdef MOMENT
11126         if (swap) then
11127           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
11128         else
11129           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
11130         endif
11131 #endif
11132         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
11133 c        g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
11134       endif
11135 C Cartesian derivatives.
11136       if (lprn) then
11137         write (2,*) 'In eello6_graph2'
11138         do iii=1,2
11139           write (2,*) 'iii=',iii
11140           do kkk=1,5
11141             write (2,*) 'kkk=',kkk
11142             do jjj=1,2
11143               write (2,'(3(2f10.5),5x)')
11144      &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
11145             enddo
11146           enddo
11147         enddo
11148       endif
11149       do iii=1,2
11150         do kkk=1,5
11151           do lll=1,3
11152 #ifdef MOMENT
11153             if (iii.eq.1) then
11154               s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
11155             else
11156               s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
11157             endif
11158 #endif
11159             call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),
11160      &        auxvec(1))
11161             s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
11162             call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),
11163      &        auxvec(1))
11164             s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
11165             call transpose2(EUg(1,1,k),auxmat(1,1))
11166             call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),
11167      &        pizda(1,1))
11168             vv(1)=pizda(1,1)-pizda(2,2)
11169             vv(2)=pizda(1,2)+pizda(2,1)
11170             s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
11171 cd            write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
11172 #ifdef MOMENT
11173             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
11174 #else
11175             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
11176 #endif
11177             if (swap) then
11178               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
11179             else
11180               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
11181             endif
11182           enddo
11183         enddo
11184       enddo
11185       return
11186       end
11187 c----------------------------------------------------------------------------
11188       double precision function eello6_graph3(i,j,k,l,jj,kk,swap)
11189       implicit real*8 (a-h,o-z)
11190       include 'DIMENSIONS'
11191       include 'COMMON.IOUNITS'
11192       include 'COMMON.CHAIN'
11193       include 'COMMON.DERIV'
11194       include 'COMMON.INTERACT'
11195       include 'COMMON.CONTACTS'
11196       include 'COMMON.TORSION'
11197       include 'COMMON.VAR'
11198       include 'COMMON.GEO'
11199       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2)
11200       logical swap
11201 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
11202 C                                                                              C
11203 C      Parallel       Antiparallel                                             C
11204 C                                                                              C
11205 C          o             o                                                     C
11206 C         /l\   /   \   /j\                                                    C
11207 C        /   \ /     \ /   \                                                   C
11208 C       /| o |o       o| o |\                                                  C
11209 C       j|/k\|  /      |/k\|l /                                                C
11210 C        /   \ /       /   \ /                                                 C
11211 C       /     o       /     o                                                  C
11212 C       i             i                                                        C
11213 C                                                                              C
11214 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
11215 C
11216 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
11217 C           energy moment and not to the cluster cumulant.
11218       iti=itortyp(itype(i))
11219       if (j.lt.nres-1) then
11220         itj1=itype2loc(itype(j+1))
11221       else
11222         itj1=nloctyp
11223       endif
11224       itk=itype2loc(itype(k))
11225       itk1=itype2loc(itype(k+1))
11226       if (l.lt.nres-1) then
11227         itl1=itype2loc(itype(l+1))
11228       else
11229         itl1=nloctyp
11230       endif
11231 #ifdef MOMENT
11232       s1=dip(4,jj,i)*dip(4,kk,k)
11233 #endif
11234       call matvec2(AECA(1,1,1),b1(1,k+1),auxvec(1))
11235       s2=0.5d0*scalar2(b1(1,k),auxvec(1))
11236       call matvec2(AECA(1,1,2),b1(1,l+1),auxvec(1))
11237       s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
11238       call transpose2(EE(1,1,k),auxmat(1,1))
11239       call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
11240       vv(1)=pizda(1,1)+pizda(2,2)
11241       vv(2)=pizda(2,1)-pizda(1,2)
11242       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
11243 cd      write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4,
11244 cd     & "sum",-(s2+s3+s4)
11245 #ifdef MOMENT
11246       eello6_graph3=-(s1+s2+s3+s4)
11247 #else
11248       eello6_graph3=-(s2+s3+s4)
11249 #endif
11250 c      eello6_graph3=-s4
11251 C Derivatives in gamma(k-1)
11252       call matvec2(AECAderg(1,1,2),b1(1,l+1),auxvec(1))
11253       s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
11254       s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
11255       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
11256 C Derivatives in gamma(l-1)
11257       call matvec2(AECAderg(1,1,1),b1(1,k+1),auxvec(1))
11258       s2=0.5d0*scalar2(b1(1,k),auxvec(1))
11259       call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
11260       vv(1)=pizda(1,1)+pizda(2,2)
11261       vv(2)=pizda(2,1)-pizda(1,2)
11262       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
11263       g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
11264 C Cartesian derivatives.
11265       do iii=1,2
11266         do kkk=1,5
11267           do lll=1,3
11268 #ifdef MOMENT
11269             if (iii.eq.1) then
11270               s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
11271             else
11272               s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
11273             endif
11274 #endif
11275             call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
11276      &        auxvec(1))
11277             s2=0.5d0*scalar2(b1(1,k),auxvec(1))
11278             call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,l+1),
11279      &        auxvec(1))
11280             s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
11281             call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),
11282      &        pizda(1,1))
11283             vv(1)=pizda(1,1)+pizda(2,2)
11284             vv(2)=pizda(2,1)-pizda(1,2)
11285             s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
11286 #ifdef MOMENT
11287             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
11288 #else
11289             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
11290 #endif
11291             if (swap) then
11292               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
11293             else
11294               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
11295             endif
11296 c            derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
11297           enddo
11298         enddo
11299       enddo
11300       return
11301       end
11302 c----------------------------------------------------------------------------
11303       double precision function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
11304       implicit real*8 (a-h,o-z)
11305       include 'DIMENSIONS'
11306       include 'COMMON.IOUNITS'
11307       include 'COMMON.CHAIN'
11308       include 'COMMON.DERIV'
11309       include 'COMMON.INTERACT'
11310       include 'COMMON.CONTACTS'
11311       include 'COMMON.TORSION'
11312       include 'COMMON.VAR'
11313       include 'COMMON.GEO'
11314       include 'COMMON.FFIELD'
11315       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
11316      & auxvec1(2),auxmat1(2,2)
11317       logical swap
11318 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
11319 C                                                                              C
11320 C      Parallel       Antiparallel                                             C
11321 C                                                                              C
11322 C          o             o                                                     C
11323 C         /l\   /   \   /j\                                                    C
11324 C        /   \ /     \ /   \                                                   C
11325 C       /| o |o       o| o |\                                                  C
11326 C     \ j|/k\|      \  |/k\|l                                                  C
11327 C      \ /   \       \ /   \                                                   C
11328 C       o     \       o     \                                                  C
11329 C       i             i                                                        C
11330 C                                                                              C
11331 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
11332 C
11333 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
11334 C           energy moment and not to the cluster cumulant.
11335 cd      write (2,*) 'eello_graph4: wturn6',wturn6
11336       iti=itype2loc(itype(i))
11337       itj=itype2loc(itype(j))
11338       if (j.lt.nres-1) then
11339         itj1=itype2loc(itype(j+1))
11340       else
11341         itj1=nloctyp
11342       endif
11343       itk=itype2loc(itype(k))
11344       if (k.lt.nres-1) then
11345         itk1=itype2loc(itype(k+1))
11346       else
11347         itk1=nloctyp
11348       endif
11349       itl=itype2loc(itype(l))
11350       if (l.lt.nres-1) then
11351         itl1=itype2loc(itype(l+1))
11352       else
11353         itl1=nloctyp
11354       endif
11355 cd      write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
11356 cd      write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
11357 cd     & ' itl',itl,' itl1',itl1
11358 #ifdef MOMENT
11359       if (imat.eq.1) then
11360         s1=dip(3,jj,i)*dip(3,kk,k)
11361       else
11362         s1=dip(2,jj,j)*dip(2,kk,l)
11363       endif
11364 #endif
11365       call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
11366       s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
11367       if (j.eq.l+1) then
11368         call matvec2(ADtEA1(1,1,3-imat),b1(1,j+1),auxvec1(1))
11369         s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
11370       else
11371         call matvec2(ADtEA1(1,1,3-imat),b1(1,l+1),auxvec1(1))
11372         s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
11373       endif
11374       call transpose2(EUg(1,1,k),auxmat(1,1))
11375       call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
11376       vv(1)=pizda(1,1)-pizda(2,2)
11377       vv(2)=pizda(2,1)+pizda(1,2)
11378       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
11379 cd      write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
11380 #ifdef MOMENT
11381       eello6_graph4=-(s1+s2+s3+s4)
11382 #else
11383       eello6_graph4=-(s2+s3+s4)
11384 #endif
11385 C Derivatives in gamma(i-1)
11386       if (i.gt.1) then
11387 #ifdef MOMENT
11388         if (imat.eq.1) then
11389           s1=dipderg(2,jj,i)*dip(3,kk,k)
11390         else
11391           s1=dipderg(4,jj,j)*dip(2,kk,l)
11392         endif
11393 #endif
11394         s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
11395         if (j.eq.l+1) then
11396           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,j+1),auxvec1(1))
11397           s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
11398         else
11399           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,l+1),auxvec1(1))
11400           s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
11401         endif
11402         s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
11403         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
11404 cd          write (2,*) 'turn6 derivatives'
11405 #ifdef MOMENT
11406           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
11407 #else
11408           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
11409 #endif
11410         else
11411 #ifdef MOMENT
11412           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
11413 #else
11414           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
11415 #endif
11416         endif
11417       endif
11418 C Derivatives in gamma(k-1)
11419 #ifdef MOMENT
11420       if (imat.eq.1) then
11421         s1=dip(3,jj,i)*dipderg(2,kk,k)
11422       else
11423         s1=dip(2,jj,j)*dipderg(4,kk,l)
11424       endif
11425 #endif
11426       call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
11427       s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
11428       if (j.eq.l+1) then
11429         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,j+1),auxvec1(1))
11430         s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
11431       else
11432         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,l+1),auxvec1(1))
11433         s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
11434       endif
11435       call transpose2(EUgder(1,1,k),auxmat1(1,1))
11436       call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
11437       vv(1)=pizda(1,1)-pizda(2,2)
11438       vv(2)=pizda(2,1)+pizda(1,2)
11439       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
11440       if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
11441 #ifdef MOMENT
11442         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
11443 #else
11444         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
11445 #endif
11446       else
11447 #ifdef MOMENT
11448         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
11449 #else
11450         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
11451 #endif
11452       endif
11453 C Derivatives in gamma(j-1) or gamma(l-1)
11454       if (l.eq.j+1 .and. l.gt.1) then
11455         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
11456         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
11457         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
11458         vv(1)=pizda(1,1)-pizda(2,2)
11459         vv(2)=pizda(2,1)+pizda(1,2)
11460         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
11461         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
11462       else if (j.gt.1) then
11463         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
11464         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
11465         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
11466         vv(1)=pizda(1,1)-pizda(2,2)
11467         vv(2)=pizda(2,1)+pizda(1,2)
11468         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
11469         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
11470           gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
11471         else
11472           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
11473         endif
11474       endif
11475 C Cartesian derivatives.
11476       do iii=1,2
11477         do kkk=1,5
11478           do lll=1,3
11479 #ifdef MOMENT
11480             if (iii.eq.1) then
11481               if (imat.eq.1) then
11482                 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
11483               else
11484                 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
11485               endif
11486             else
11487               if (imat.eq.1) then
11488                 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
11489               else
11490                 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
11491               endif
11492             endif
11493 #endif
11494             call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),
11495      &        auxvec(1))
11496             s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
11497             if (j.eq.l+1) then
11498               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
11499      &          b1(1,j+1),auxvec(1))
11500               s3=-0.5d0*scalar2(b1(1,j),auxvec(1))
11501             else
11502               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
11503      &          b1(1,l+1),auxvec(1))
11504               s3=-0.5d0*scalar2(b1(1,l),auxvec(1))
11505             endif
11506             call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
11507      &        pizda(1,1))
11508             vv(1)=pizda(1,1)-pizda(2,2)
11509             vv(2)=pizda(2,1)+pizda(1,2)
11510             s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
11511             if (swap) then
11512               if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
11513 #ifdef MOMENT
11514                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
11515      &             -(s1+s2+s4)
11516 #else
11517                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
11518      &             -(s2+s4)
11519 #endif
11520                 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
11521               else
11522 #ifdef MOMENT
11523                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
11524 #else
11525                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
11526 #endif
11527                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
11528               endif
11529             else
11530 #ifdef MOMENT
11531               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
11532 #else
11533               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
11534 #endif
11535               if (l.eq.j+1) then
11536                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
11537               else
11538                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
11539               endif
11540             endif
11541           enddo
11542         enddo
11543       enddo
11544       return
11545       end
11546 c----------------------------------------------------------------------------
11547       double precision function eello_turn6(i,jj,kk)
11548       implicit real*8 (a-h,o-z)
11549       include 'DIMENSIONS'
11550       include 'COMMON.IOUNITS'
11551       include 'COMMON.CHAIN'
11552       include 'COMMON.DERIV'
11553       include 'COMMON.INTERACT'
11554       include 'COMMON.CONTACTS'
11555       include 'COMMON.TORSION'
11556       include 'COMMON.VAR'
11557       include 'COMMON.GEO'
11558       double precision vtemp1(2),vtemp2(2),vtemp3(2),vtemp4(2),
11559      &  atemp(2,2),auxmat(2,2),achuj_temp(2,2),gtemp(2,2),gvec(2),
11560      &  ggg1(3),ggg2(3)
11561       double precision vtemp1d(2),vtemp2d(2),vtemp3d(2),vtemp4d(2),
11562      &  atempd(2,2),auxmatd(2,2),achuj_tempd(2,2),gtempd(2,2),gvecd(2)
11563 C 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
11564 C           the respective energy moment and not to the cluster cumulant.
11565       s1=0.0d0
11566       s8=0.0d0
11567       s13=0.0d0
11568 c
11569       eello_turn6=0.0d0
11570       j=i+4
11571       k=i+1
11572       l=i+3
11573       iti=itype2loc(itype(i))
11574       itk=itype2loc(itype(k))
11575       itk1=itype2loc(itype(k+1))
11576       itl=itype2loc(itype(l))
11577       itj=itype2loc(itype(j))
11578 cd      write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
11579 cd      write (2,*) 'i',i,' k',k,' j',j,' l',l
11580 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
11581 cd        eello6=0.0d0
11582 cd        return
11583 cd      endif
11584 cd      write (iout,*)
11585 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
11586 cd     &   ' and',k,l
11587 cd      call checkint_turn6(i,jj,kk,eel_turn6_num)
11588       do iii=1,2
11589         do kkk=1,5
11590           do lll=1,3
11591             derx_turn(lll,kkk,iii)=0.0d0
11592           enddo
11593         enddo
11594       enddo
11595 cd      eij=1.0d0
11596 cd      ekl=1.0d0
11597 cd      ekont=1.0d0
11598       eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
11599 cd      eello6_5=0.0d0
11600 cd      write (2,*) 'eello6_5',eello6_5
11601 #ifdef MOMENT
11602       call transpose2(AEA(1,1,1),auxmat(1,1))
11603       call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
11604       ss1=scalar2(Ub2(1,i+2),b1(1,l))
11605       s1 = (auxmat(1,1)+auxmat(2,2))*ss1
11606 #endif
11607       call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1(1))
11608       call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
11609       s2 = scalar2(b1(1,k),vtemp1(1))
11610 #ifdef MOMENT
11611       call transpose2(AEA(1,1,2),atemp(1,1))
11612       call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
11613       call matvec2(Ug2(1,1,i+2),dd(1,1,k+1),vtemp2(1))
11614       s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,l),vtemp2(1))
11615 #endif
11616       call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
11617       call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
11618       s12 = scalar2(Ub2(1,i+2),vtemp3(1))
11619 #ifdef MOMENT
11620       call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
11621       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
11622       call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
11623       call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
11624       ss13 = scalar2(b1(1,k),vtemp4(1))
11625       s13 = (gtemp(1,1)+gtemp(2,2))*ss13
11626 #endif
11627 c      write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
11628 c      s1=0.0d0
11629 c      s2=0.0d0
11630 c      s8=0.0d0
11631 c      s12=0.0d0
11632 c      s13=0.0d0
11633       eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
11634 C Derivatives in gamma(i+2)
11635       s1d =0.0d0
11636       s8d =0.0d0
11637 #ifdef MOMENT
11638       call transpose2(AEA(1,1,1),auxmatd(1,1))
11639       call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
11640       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
11641       call transpose2(AEAderg(1,1,2),atempd(1,1))
11642       call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
11643       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,l),vtemp2(1))
11644 #endif
11645       call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
11646       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
11647       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
11648 c      s1d=0.0d0
11649 c      s2d=0.0d0
11650 c      s8d=0.0d0
11651 c      s12d=0.0d0
11652 c      s13d=0.0d0
11653       gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
11654 C Derivatives in gamma(i+3)
11655 #ifdef MOMENT
11656       call transpose2(AEA(1,1,1),auxmatd(1,1))
11657       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
11658       ss1d=scalar2(Ub2der(1,i+2),b1(1,l))
11659       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
11660 #endif
11661       call matvec2(EUgder(1,1,i+2),b1(1,l),vtemp1d(1))
11662       call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
11663       s2d = scalar2(b1(1,k),vtemp1d(1))
11664 #ifdef MOMENT
11665       call matvec2(Ug2der(1,1,i+2),dd(1,1,k+1),vtemp2d(1))
11666       s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,l),vtemp2d(1))
11667 #endif
11668       s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
11669 #ifdef MOMENT
11670       call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
11671       call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
11672       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
11673 #endif
11674 c      s1d=0.0d0
11675 c      s2d=0.0d0
11676 c      s8d=0.0d0
11677 c      s12d=0.0d0
11678 c      s13d=0.0d0
11679 #ifdef MOMENT
11680       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
11681      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
11682 #else
11683       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
11684      &               -0.5d0*ekont*(s2d+s12d)
11685 #endif
11686 C Derivatives in gamma(i+4)
11687       call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
11688       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
11689       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
11690 #ifdef MOMENT
11691       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
11692       call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
11693       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
11694 #endif
11695 c      s1d=0.0d0
11696 c      s2d=0.0d0
11697 c      s8d=0.0d0
11698 C      s12d=0.0d0
11699 c      s13d=0.0d0
11700 #ifdef MOMENT
11701       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
11702 #else
11703       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
11704 #endif
11705 C Derivatives in gamma(i+5)
11706 #ifdef MOMENT
11707       call transpose2(AEAderg(1,1,1),auxmatd(1,1))
11708       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
11709       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
11710 #endif
11711       call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1d(1))
11712       call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
11713       s2d = scalar2(b1(1,k),vtemp1d(1))
11714 #ifdef MOMENT
11715       call transpose2(AEA(1,1,2),atempd(1,1))
11716       call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
11717       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,l),vtemp2(1))
11718 #endif
11719       call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
11720       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
11721 #ifdef MOMENT
11722       call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
11723       ss13d = scalar2(b1(1,k),vtemp4d(1))
11724       s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
11725 #endif
11726 c      s1d=0.0d0
11727 c      s2d=0.0d0
11728 c      s8d=0.0d0
11729 c      s12d=0.0d0
11730 c      s13d=0.0d0
11731 #ifdef MOMENT
11732       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
11733      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
11734 #else
11735       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
11736      &               -0.5d0*ekont*(s2d+s12d)
11737 #endif
11738 C Cartesian derivatives
11739       do iii=1,2
11740         do kkk=1,5
11741           do lll=1,3
11742 #ifdef MOMENT
11743             call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
11744             call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
11745             s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
11746 #endif
11747             call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1(1))
11748             call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),
11749      &          vtemp1d(1))
11750             s2d = scalar2(b1(1,k),vtemp1d(1))
11751 #ifdef MOMENT
11752             call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
11753             call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
11754             s8d = -(atempd(1,1)+atempd(2,2))*
11755      &           scalar2(cc(1,1,l),vtemp2(1))
11756 #endif
11757             call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),
11758      &           auxmatd(1,1))
11759             call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
11760             s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
11761 c      s1d=0.0d0
11762 c      s2d=0.0d0
11763 c      s8d=0.0d0
11764 c      s12d=0.0d0
11765 c      s13d=0.0d0
11766 #ifdef MOMENT
11767             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
11768      &        - 0.5d0*(s1d+s2d)
11769 #else
11770             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
11771      &        - 0.5d0*s2d
11772 #endif
11773 #ifdef MOMENT
11774             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
11775      &        - 0.5d0*(s8d+s12d)
11776 #else
11777             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
11778      &        - 0.5d0*s12d
11779 #endif
11780           enddo
11781         enddo
11782       enddo
11783 #ifdef MOMENT
11784       do kkk=1,5
11785         do lll=1,3
11786           call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),
11787      &      achuj_tempd(1,1))
11788           call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
11789           call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
11790           s13d=(gtempd(1,1)+gtempd(2,2))*ss13
11791           derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
11792           call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),
11793      &      vtemp4d(1))
11794           ss13d = scalar2(b1(1,k),vtemp4d(1))
11795           s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
11796           derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
11797         enddo
11798       enddo
11799 #endif
11800 cd      write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
11801 cd     &  16*eel_turn6_num
11802 cd      goto 1112
11803       if (j.lt.nres-1) then
11804         j1=j+1
11805         j2=j-1
11806       else
11807         j1=j-1
11808         j2=j-2
11809       endif
11810       if (l.lt.nres-1) then
11811         l1=l+1
11812         l2=l-1
11813       else
11814         l1=l-1
11815         l2=l-2
11816       endif
11817       do ll=1,3
11818 cgrad        ggg1(ll)=eel_turn6*g_contij(ll,1)
11819 cgrad        ggg2(ll)=eel_turn6*g_contij(ll,2)
11820 cgrad        ghalf=0.5d0*ggg1(ll)
11821 cd        ghalf=0.0d0
11822         gturn6ij=eel_turn6*g_contij(ll,1)+ekont*derx_turn(ll,1,1)
11823         gturn6kl=eel_turn6*g_contij(ll,2)+ekont*derx_turn(ll,1,2)
11824         gcorr6_turn(ll,i)=gcorr6_turn(ll,i)!+ghalf
11825      &    +ekont*derx_turn(ll,2,1)
11826         gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
11827         gcorr6_turn(ll,j)=gcorr6_turn(ll,j)!+ghalf
11828      &    +ekont*derx_turn(ll,4,1)
11829         gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
11830         gcorr6_turn_long(ll,j)=gcorr6_turn_long(ll,j)+gturn6ij
11831         gcorr6_turn_long(ll,i)=gcorr6_turn_long(ll,i)-gturn6ij
11832 cgrad        ghalf=0.5d0*ggg2(ll)
11833 cd        ghalf=0.0d0
11834         gcorr6_turn(ll,k)=gcorr6_turn(ll,k)!+ghalf
11835      &    +ekont*derx_turn(ll,2,2)
11836         gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
11837         gcorr6_turn(ll,l)=gcorr6_turn(ll,l)!+ghalf
11838      &    +ekont*derx_turn(ll,4,2)
11839         gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
11840         gcorr6_turn_long(ll,l)=gcorr6_turn_long(ll,l)+gturn6kl
11841         gcorr6_turn_long(ll,k)=gcorr6_turn_long(ll,k)-gturn6kl
11842       enddo
11843 cd      goto 1112
11844 cgrad      do m=i+1,j-1
11845 cgrad        do ll=1,3
11846 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
11847 cgrad        enddo
11848 cgrad      enddo
11849 cgrad      do m=k+1,l-1
11850 cgrad        do ll=1,3
11851 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
11852 cgrad        enddo
11853 cgrad      enddo
11854 cgrad1112  continue
11855 cgrad      do m=i+2,j2
11856 cgrad        do ll=1,3
11857 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
11858 cgrad        enddo
11859 cgrad      enddo
11860 cgrad      do m=k+2,l2
11861 cgrad        do ll=1,3
11862 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
11863 cgrad        enddo
11864 cgrad      enddo
11865 cd      do iii=1,nres-3
11866 cd        write (2,*) iii,g_corr6_loc(iii)
11867 cd      enddo
11868       eello_turn6=ekont*eel_turn6
11869 cd      write (2,*) 'ekont',ekont
11870 cd      write (2,*) 'eel_turn6',ekont*eel_turn6
11871       return
11872       end
11873
11874 C-----------------------------------------------------------------------------
11875       double precision function scalar(u,v)
11876 !DIR$ INLINEALWAYS scalar
11877 #ifndef OSF
11878 cDEC$ ATTRIBUTES FORCEINLINE::scalar
11879 #endif
11880       implicit none
11881       double precision u(3),v(3)
11882 cd      double precision sc
11883 cd      integer i
11884 cd      sc=0.0d0
11885 cd      do i=1,3
11886 cd        sc=sc+u(i)*v(i)
11887 cd      enddo
11888 cd      scalar=sc
11889
11890       scalar=u(1)*v(1)+u(2)*v(2)+u(3)*v(3)
11891       return
11892       end
11893 crc-------------------------------------------------
11894       SUBROUTINE MATVEC2(A1,V1,V2)
11895 !DIR$ INLINEALWAYS MATVEC2
11896 #ifndef OSF
11897 cDEC$ ATTRIBUTES FORCEINLINE::MATVEC2
11898 #endif
11899       implicit real*8 (a-h,o-z)
11900       include 'DIMENSIONS'
11901       DIMENSION A1(2,2),V1(2),V2(2)
11902 c      DO 1 I=1,2
11903 c        VI=0.0
11904 c        DO 3 K=1,2
11905 c    3     VI=VI+A1(I,K)*V1(K)
11906 c        Vaux(I)=VI
11907 c    1 CONTINUE
11908
11909       vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
11910       vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
11911
11912       v2(1)=vaux1
11913       v2(2)=vaux2
11914       END
11915 C---------------------------------------
11916       SUBROUTINE MATMAT2(A1,A2,A3)
11917 #ifndef OSF
11918 cDEC$ ATTRIBUTES FORCEINLINE::MATMAT2
11919 #endif
11920       implicit real*8 (a-h,o-z)
11921       include 'DIMENSIONS'
11922       DIMENSION A1(2,2),A2(2,2),A3(2,2)
11923 c      DIMENSION AI3(2,2)
11924 c        DO  J=1,2
11925 c          A3IJ=0.0
11926 c          DO K=1,2
11927 c           A3IJ=A3IJ+A1(I,K)*A2(K,J)
11928 c          enddo
11929 c          A3(I,J)=A3IJ
11930 c       enddo
11931 c      enddo
11932
11933       ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
11934       ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
11935       ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
11936       ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
11937
11938       A3(1,1)=AI3_11
11939       A3(2,1)=AI3_21
11940       A3(1,2)=AI3_12
11941       A3(2,2)=AI3_22
11942       END
11943
11944 c-------------------------------------------------------------------------
11945       double precision function scalar2(u,v)
11946 !DIR$ INLINEALWAYS scalar2
11947       implicit none
11948       double precision u(2),v(2)
11949       double precision sc
11950       integer i
11951       scalar2=u(1)*v(1)+u(2)*v(2)
11952       return
11953       end
11954
11955 C-----------------------------------------------------------------------------
11956
11957       subroutine transpose2(a,at)
11958 !DIR$ INLINEALWAYS transpose2
11959 #ifndef OSF
11960 cDEC$ ATTRIBUTES FORCEINLINE::transpose2
11961 #endif
11962       implicit none
11963       double precision a(2,2),at(2,2)
11964       at(1,1)=a(1,1)
11965       at(1,2)=a(2,1)
11966       at(2,1)=a(1,2)
11967       at(2,2)=a(2,2)
11968       return
11969       end
11970 c--------------------------------------------------------------------------
11971       subroutine transpose(n,a,at)
11972       implicit none
11973       integer n,i,j
11974       double precision a(n,n),at(n,n)
11975       do i=1,n
11976         do j=1,n
11977           at(j,i)=a(i,j)
11978         enddo
11979       enddo
11980       return
11981       end
11982 C---------------------------------------------------------------------------
11983       subroutine prodmat3(a1,a2,kk,transp,prod)
11984 !DIR$ INLINEALWAYS prodmat3
11985 #ifndef OSF
11986 cDEC$ ATTRIBUTES FORCEINLINE::prodmat3
11987 #endif
11988       implicit none
11989       integer i,j
11990       double precision a1(2,2),a2(2,2),a2t(2,2),kk(2,2),prod(2,2)
11991       logical transp
11992 crc      double precision auxmat(2,2),prod_(2,2)
11993
11994       if (transp) then
11995 crc        call transpose2(kk(1,1),auxmat(1,1))
11996 crc        call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
11997 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
11998
11999            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1)
12000      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
12001            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2)
12002      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
12003            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1)
12004      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
12005            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2)
12006      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
12007
12008       else
12009 crc        call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
12010 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
12011
12012            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1)
12013      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
12014            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2)
12015      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
12016            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1)
12017      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
12018            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2)
12019      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
12020
12021       endif
12022 c      call transpose2(a2(1,1),a2t(1,1))
12023
12024 crc      print *,transp
12025 crc      print *,((prod_(i,j),i=1,2),j=1,2)
12026 crc      print *,((prod(i,j),i=1,2),j=1,2)
12027
12028       return
12029       end
12030 CCC----------------------------------------------
12031       subroutine Eliptransfer(eliptran)
12032       implicit real*8 (a-h,o-z)
12033       include 'DIMENSIONS'
12034       include 'COMMON.GEO'
12035       include 'COMMON.VAR'
12036       include 'COMMON.LOCAL'
12037       include 'COMMON.CHAIN'
12038       include 'COMMON.DERIV'
12039       include 'COMMON.NAMES'
12040       include 'COMMON.INTERACT'
12041       include 'COMMON.IOUNITS'
12042       include 'COMMON.CALC'
12043       include 'COMMON.CONTROL'
12044       include 'COMMON.SPLITELE'
12045       include 'COMMON.SBRIDGE'
12046 C this is done by Adasko
12047 C      print *,"wchodze"
12048 C structure of box:
12049 C      water
12050 C--bordliptop-- buffore starts
12051 C--bufliptop--- here true lipid starts
12052 C      lipid
12053 C--buflipbot--- lipid ends buffore starts
12054 C--bordlipbot--buffore ends
12055       eliptran=0.0
12056       do i=ilip_start,ilip_end
12057 C       do i=1,1
12058         if (itype(i).eq.ntyp1) cycle
12059
12060         positi=(mod(((c(3,i)+c(3,i+1))/2.0d0),boxzsize))
12061         if (positi.le.0.0) positi=positi+boxzsize
12062 C        print *,i
12063 C first for peptide groups
12064 c for each residue check if it is in lipid or lipid water border area
12065        if ((positi.gt.bordlipbot)
12066      &.and.(positi.lt.bordliptop)) then
12067 C the energy transfer exist
12068         if (positi.lt.buflipbot) then
12069 C what fraction I am in
12070          fracinbuf=1.0d0-
12071      &        ((positi-bordlipbot)/lipbufthick)
12072 C lipbufthick is thickenes of lipid buffore
12073          sslip=sscalelip(fracinbuf)
12074          ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
12075          eliptran=eliptran+sslip*pepliptran
12076          gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
12077          gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
12078 C         gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
12079
12080 C        print *,"doing sccale for lower part"
12081 C         print *,i,sslip,fracinbuf,ssgradlip
12082         elseif (positi.gt.bufliptop) then
12083          fracinbuf=1.0d0-((bordliptop-positi)/lipbufthick)
12084          sslip=sscalelip(fracinbuf)
12085          ssgradlip=sscagradlip(fracinbuf)/lipbufthick
12086          eliptran=eliptran+sslip*pepliptran
12087          gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
12088          gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
12089 C         gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
12090 C          print *, "doing sscalefor top part"
12091 C         print *,i,sslip,fracinbuf,ssgradlip
12092         else
12093          eliptran=eliptran+pepliptran
12094 C         print *,"I am in true lipid"
12095         endif
12096 C       else
12097 C       eliptran=elpitran+0.0 ! I am in water
12098        endif
12099        enddo
12100 C       print *, "nic nie bylo w lipidzie?"
12101 C now multiply all by the peptide group transfer factor
12102 C       eliptran=eliptran*pepliptran
12103 C now the same for side chains
12104 CV       do i=1,1
12105        do i=ilip_start,ilip_end
12106         if (itype(i).eq.ntyp1) cycle
12107         positi=(mod(c(3,i+nres),boxzsize))
12108         if (positi.le.0) positi=positi+boxzsize
12109 C       print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop
12110 c for each residue check if it is in lipid or lipid water border area
12111 C       respos=mod(c(3,i+nres),boxzsize)
12112 C       print *,positi,bordlipbot,buflipbot
12113        if ((positi.gt.bordlipbot)
12114      & .and.(positi.lt.bordliptop)) then
12115 C the energy transfer exist
12116         if (positi.lt.buflipbot) then
12117          fracinbuf=1.0d0-
12118      &     ((positi-bordlipbot)/lipbufthick)
12119 C lipbufthick is thickenes of lipid buffore
12120          sslip=sscalelip(fracinbuf)
12121          ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
12122          eliptran=eliptran+sslip*liptranene(itype(i))
12123          gliptranx(3,i)=gliptranx(3,i)
12124      &+ssgradlip*liptranene(itype(i))
12125          gliptranc(3,i-1)= gliptranc(3,i-1)
12126      &+ssgradlip*liptranene(itype(i))
12127 C         print *,"doing sccale for lower part"
12128         elseif (positi.gt.bufliptop) then
12129          fracinbuf=1.0d0-
12130      &((bordliptop-positi)/lipbufthick)
12131          sslip=sscalelip(fracinbuf)
12132          ssgradlip=sscagradlip(fracinbuf)/lipbufthick
12133          eliptran=eliptran+sslip*liptranene(itype(i))
12134          gliptranx(3,i)=gliptranx(3,i)
12135      &+ssgradlip*liptranene(itype(i))
12136          gliptranc(3,i-1)= gliptranc(3,i-1)
12137      &+ssgradlip*liptranene(itype(i))
12138 C          print *, "doing sscalefor top part",sslip,fracinbuf
12139         else
12140          eliptran=eliptran+liptranene(itype(i))
12141 C         print *,"I am in true lipid"
12142         endif
12143         endif ! if in lipid or buffor
12144 C       else
12145 C       eliptran=elpitran+0.0 ! I am in water
12146        enddo
12147        return
12148        end
12149 C---------------------------------------------------------
12150 C AFM soubroutine for constant force
12151        subroutine AFMforce(Eafmforce)
12152        implicit real*8 (a-h,o-z)
12153       include 'DIMENSIONS'
12154       include 'COMMON.GEO'
12155       include 'COMMON.VAR'
12156       include 'COMMON.LOCAL'
12157       include 'COMMON.CHAIN'
12158       include 'COMMON.DERIV'
12159       include 'COMMON.NAMES'
12160       include 'COMMON.INTERACT'
12161       include 'COMMON.IOUNITS'
12162       include 'COMMON.CALC'
12163       include 'COMMON.CONTROL'
12164       include 'COMMON.SPLITELE'
12165       include 'COMMON.SBRIDGE'
12166       real*8 diffafm(3)
12167       dist=0.0d0
12168       Eafmforce=0.0d0
12169       do i=1,3
12170       diffafm(i)=c(i,afmend)-c(i,afmbeg)
12171       dist=dist+diffafm(i)**2
12172       enddo
12173       dist=dsqrt(dist)
12174       Eafmforce=-forceAFMconst*(dist-distafminit)
12175       do i=1,3
12176       gradafm(i,afmend-1)=-forceAFMconst*diffafm(i)/dist
12177       gradafm(i,afmbeg-1)=forceAFMconst*diffafm(i)/dist
12178       enddo
12179 C      print *,'AFM',Eafmforce
12180       return
12181       end
12182 C---------------------------------------------------------
12183 C AFM subroutine with pseudoconstant velocity
12184        subroutine AFMvel(Eafmforce)
12185        implicit real*8 (a-h,o-z)
12186       include 'DIMENSIONS'
12187       include 'COMMON.GEO'
12188       include 'COMMON.VAR'
12189       include 'COMMON.LOCAL'
12190       include 'COMMON.CHAIN'
12191       include 'COMMON.DERIV'
12192       include 'COMMON.NAMES'
12193       include 'COMMON.INTERACT'
12194       include 'COMMON.IOUNITS'
12195       include 'COMMON.CALC'
12196       include 'COMMON.CONTROL'
12197       include 'COMMON.SPLITELE'
12198       include 'COMMON.SBRIDGE'
12199       real*8 diffafm(3)
12200 C Only for check grad COMMENT if not used for checkgrad
12201 C      totT=3.0d0
12202 C--------------------------------------------------------
12203 C      print *,"wchodze"
12204       dist=0.0d0
12205       Eafmforce=0.0d0
12206       do i=1,3
12207       diffafm(i)=c(i,afmend)-c(i,afmbeg)
12208       dist=dist+diffafm(i)**2
12209       enddo
12210       dist=dsqrt(dist)
12211       Eafmforce=0.5d0*forceAFMconst
12212      & *(distafminit+totTafm*velAFMconst-dist)**2
12213 C      Eafmforce=-forceAFMconst*(dist-distafminit)
12214       do i=1,3
12215       gradafm(i,afmend-1)=-forceAFMconst*
12216      &(distafminit+totTafm*velAFMconst-dist)
12217      &*diffafm(i)/dist
12218       gradafm(i,afmbeg-1)=forceAFMconst*
12219      &(distafminit+totTafm*velAFMconst-dist)
12220      &*diffafm(i)/dist
12221       enddo
12222 C      print *,'AFM',Eafmforce,totTafm*velAFMconst,dist
12223       return
12224       end
12225 C-----------------------------------------------------------
12226 C first for shielding is setting of function of side-chains
12227        subroutine set_shield_fac
12228       implicit real*8 (a-h,o-z)
12229       include 'DIMENSIONS'
12230       include 'COMMON.CHAIN'
12231       include 'COMMON.DERIV'
12232       include 'COMMON.IOUNITS'
12233       include 'COMMON.SHIELD'
12234       include 'COMMON.INTERACT'
12235 C this is the squar root 77 devided by 81 the epislion in lipid (in protein)
12236       double precision div77_81/0.974996043d0/,
12237      &div4_81/0.2222222222d0/,sh_frac_dist_grad(3)
12238
12239 C the vector between center of side_chain and peptide group
12240        double precision pep_side(3),long,side_calf(3),
12241      &pept_group(3),costhet_grad(3),cosphi_grad_long(3),
12242      &cosphi_grad_loc(3),pep_side_norm(3),side_calf_norm(3)
12243 C the line belowe needs to be changed for FGPROC>1
12244       do i=1,nres-1
12245       if ((itype(i).eq.ntyp1).and.itype(i+1).eq.ntyp1) cycle
12246       ishield_list(i)=0
12247 Cif there two consequtive dummy atoms there is no peptide group between them
12248 C the line below has to be changed for FGPROC>1
12249       VolumeTotal=0.0
12250       do k=1,nres
12251        if ((itype(k).eq.ntyp1).or.(itype(k).eq.10)) cycle
12252        dist_pep_side=0.0
12253        dist_side_calf=0.0
12254        do j=1,3
12255 C first lets set vector conecting the ithe side-chain with kth side-chain
12256       pep_side(j)=c(j,k+nres)-(c(j,i)+c(j,i+1))/2.0d0
12257 C      pep_side(j)=2.0d0
12258 C and vector conecting the side-chain with its proper calfa
12259       side_calf(j)=c(j,k+nres)-c(j,k)
12260 C      side_calf(j)=2.0d0
12261       pept_group(j)=c(j,i)-c(j,i+1)
12262 C lets have their lenght
12263       dist_pep_side=pep_side(j)**2+dist_pep_side
12264       dist_side_calf=dist_side_calf+side_calf(j)**2
12265       dist_pept_group=dist_pept_group+pept_group(j)**2
12266       enddo
12267        dist_pep_side=dsqrt(dist_pep_side)
12268        dist_pept_group=dsqrt(dist_pept_group)
12269        dist_side_calf=dsqrt(dist_side_calf)
12270       do j=1,3
12271         pep_side_norm(j)=pep_side(j)/dist_pep_side
12272         side_calf_norm(j)=dist_side_calf
12273       enddo
12274 C now sscale fraction
12275        sh_frac_dist=-(dist_pep_side-rpp(1,1)-buff_shield)/buff_shield
12276 C       print *,buff_shield,"buff"
12277 C now sscale
12278         if (sh_frac_dist.le.0.0) cycle
12279 C If we reach here it means that this side chain reaches the shielding sphere
12280 C Lets add him to the list for gradient
12281         ishield_list(i)=ishield_list(i)+1
12282 C ishield_list is a list of non 0 side-chain that contribute to factor gradient
12283 C this list is essential otherwise problem would be O3
12284         shield_list(ishield_list(i),i)=k
12285 C Lets have the sscale value
12286         if (sh_frac_dist.gt.1.0) then
12287          scale_fac_dist=1.0d0
12288          do j=1,3
12289          sh_frac_dist_grad(j)=0.0d0
12290          enddo
12291         else
12292          scale_fac_dist=-sh_frac_dist*sh_frac_dist
12293      &                   *(2.0*sh_frac_dist-3.0d0)
12294          fac_help_scale=6.0*(sh_frac_dist-sh_frac_dist**2)
12295      &                  /dist_pep_side/buff_shield*0.5
12296 C remember for the final gradient multiply sh_frac_dist_grad(j)
12297 C for side_chain by factor -2 !
12298          do j=1,3
12299          sh_frac_dist_grad(j)=fac_help_scale*pep_side(j)
12300 C         print *,"jestem",scale_fac_dist,fac_help_scale,
12301 C     &                    sh_frac_dist_grad(j)
12302          enddo
12303         endif
12304 C        if ((i.eq.3).and.(k.eq.2)) then
12305 C        print *,i,sh_frac_dist,dist_pep,fac_help_scale,scale_fac_dist
12306 C     & ,"TU"
12307 C        endif
12308
12309 C this is what is now we have the distance scaling now volume...
12310       short=short_r_sidechain(itype(k))
12311       long=long_r_sidechain(itype(k))
12312       costhet=1.0d0/dsqrt(1.0+short**2/dist_pep_side**2)
12313 C now costhet_grad
12314 C       costhet=0.0d0
12315        costhet_fac=costhet**3*short**2*(-0.5)/dist_pep_side**4
12316 C       costhet_fac=0.0d0
12317        do j=1,3
12318          costhet_grad(j)=costhet_fac*pep_side(j)
12319        enddo
12320 C remember for the final gradient multiply costhet_grad(j)
12321 C for side_chain by factor -2 !
12322 C fac alfa is angle between CB_k,CA_k, CA_i,CA_i+1
12323 C pep_side0pept_group is vector multiplication
12324       pep_side0pept_group=0.0
12325       do j=1,3
12326       pep_side0pept_group=pep_side0pept_group+pep_side(j)*side_calf(j)
12327       enddo
12328       cosalfa=(pep_side0pept_group/
12329      & (dist_pep_side*dist_side_calf))
12330       fac_alfa_sin=1.0-cosalfa**2
12331       fac_alfa_sin=dsqrt(fac_alfa_sin)
12332       rkprim=fac_alfa_sin*(long-short)+short
12333 C now costhet_grad
12334        cosphi=1.0d0/dsqrt(1.0+rkprim**2/dist_pep_side**2)
12335        cosphi_fac=cosphi**3*rkprim**2*(-0.5)/dist_pep_side**4
12336
12337        do j=1,3
12338          cosphi_grad_long(j)=cosphi_fac*pep_side(j)
12339      &+cosphi**3*0.5/dist_pep_side**2*(-rkprim)
12340      &*(long-short)/fac_alfa_sin*cosalfa/
12341      &((dist_pep_side*dist_side_calf))*
12342      &((side_calf(j))-cosalfa*
12343      &((pep_side(j)/dist_pep_side)*dist_side_calf))
12344
12345         cosphi_grad_loc(j)=cosphi**3*0.5/dist_pep_side**2*(-rkprim)
12346      &*(long-short)/fac_alfa_sin*cosalfa
12347      &/((dist_pep_side*dist_side_calf))*
12348      &(pep_side(j)-
12349      &cosalfa*side_calf(j)/dist_side_calf*dist_pep_side)
12350        enddo
12351
12352       VofOverlap=VSolvSphere/2.0d0*(1.0-costhet)*(1.0-cosphi)
12353      &                    /VSolvSphere_div
12354      &                    *wshield
12355 C now the gradient...
12356 C grad_shield is gradient of Calfa for peptide groups
12357 C      write(iout,*) "shield_compon",i,k,VSolvSphere,scale_fac_dist,
12358 C     &               costhet,cosphi
12359 C       write(iout,*) "cosphi_compon",i,k,pep_side0pept_group,
12360 C     & dist_pep_side,dist_side_calf,c(1,k+nres),c(1,k),itype(k)
12361       do j=1,3
12362       grad_shield(j,i)=grad_shield(j,i)
12363 C gradient po skalowaniu
12364      &                +(sh_frac_dist_grad(j)
12365 C  gradient po costhet
12366      &-scale_fac_dist*costhet_grad(j)/(1.0-costhet)
12367      &-scale_fac_dist*(cosphi_grad_long(j))
12368      &/(1.0-cosphi) )*div77_81
12369      &*VofOverlap
12370 C grad_shield_side is Cbeta sidechain gradient
12371       grad_shield_side(j,ishield_list(i),i)=
12372      &        (sh_frac_dist_grad(j)*(-2.0d0)
12373      &       +scale_fac_dist*costhet_grad(j)*2.0d0/(1.0-costhet)
12374      &       +scale_fac_dist*(cosphi_grad_long(j))
12375      &        *2.0d0/(1.0-cosphi))
12376      &        *div77_81*VofOverlap
12377
12378        grad_shield_loc(j,ishield_list(i),i)=
12379      &   scale_fac_dist*cosphi_grad_loc(j)
12380      &        *2.0d0/(1.0-cosphi)
12381      &        *div77_81*VofOverlap
12382       enddo
12383       VolumeTotal=VolumeTotal+VofOverlap*scale_fac_dist
12384       enddo
12385       fac_shield(i)=VolumeTotal*div77_81+div4_81
12386 c      write(2,*) "TOTAL VOLUME",i,VolumeTotal,fac_shield(i)
12387       enddo
12388       return
12389       end
12390 C--------------------------------------------------------------------------
12391       double precision function tschebyshev(m,n,x,y)
12392       implicit none
12393       include "DIMENSIONS"
12394       integer i,m,n
12395       double precision x(n),y,yy(0:maxvar),aux
12396 c Tschebyshev polynomial. Note that the first term is omitted
12397 c m=0: the constant term is included
12398 c m=1: the constant term is not included
12399       yy(0)=1.0d0
12400       yy(1)=y
12401       do i=2,n
12402         yy(i)=2*yy(1)*yy(i-1)-yy(i-2)
12403       enddo
12404       aux=0.0d0
12405       do i=m,n
12406         aux=aux+x(i)*yy(i)
12407       enddo
12408       tschebyshev=aux
12409       return
12410       end
12411 C--------------------------------------------------------------------------
12412       double precision function gradtschebyshev(m,n,x,y)
12413       implicit none
12414       include "DIMENSIONS"
12415       integer i,m,n
12416       double precision x(n+1),y,yy(0:maxvar),aux
12417 c Tschebyshev polynomial. Note that the first term is omitted
12418 c m=0: the constant term is included
12419 c m=1: the constant term is not included
12420       yy(0)=1.0d0
12421       yy(1)=2.0d0*y
12422       do i=2,n
12423         yy(i)=2*y*yy(i-1)-yy(i-2)
12424       enddo
12425       aux=0.0d0
12426       do i=m,n
12427         aux=aux+x(i+1)*yy(i)*(i+1)
12428 C        print *, x(i+1),yy(i),i
12429       enddo
12430       gradtschebyshev=aux
12431       return
12432       end
12433 C------------------------------------------------------------------------
12434 C first for shielding is setting of function of side-chains
12435        subroutine set_shield_fac2
12436       implicit real*8 (a-h,o-z)
12437       include 'DIMENSIONS'
12438       include 'COMMON.CHAIN'
12439       include 'COMMON.DERIV'
12440       include 'COMMON.IOUNITS'
12441       include 'COMMON.SHIELD'
12442       include 'COMMON.INTERACT'
12443 C this is the squar root 77 devided by 81 the epislion in lipid (in protein)
12444       double precision div77_81/0.974996043d0/,
12445      &div4_81/0.2222222222d0/,sh_frac_dist_grad(3)
12446
12447 C the vector between center of side_chain and peptide group
12448        double precision pep_side(3),long,side_calf(3),
12449      &pept_group(3),costhet_grad(3),cosphi_grad_long(3),
12450      &cosphi_grad_loc(3),pep_side_norm(3),side_calf_norm(3)
12451 C the line belowe needs to be changed for FGPROC>1
12452       do i=1,nres-1
12453       if ((itype(i).eq.ntyp1).and.itype(i+1).eq.ntyp1) cycle
12454       ishield_list(i)=0
12455 Cif there two consequtive dummy atoms there is no peptide group between them
12456 C the line below has to be changed for FGPROC>1
12457       VolumeTotal=0.0
12458       do k=1,nres
12459        if ((itype(k).eq.ntyp1).or.(itype(k).eq.10)) cycle
12460        dist_pep_side=0.0
12461        dist_side_calf=0.0
12462        do j=1,3
12463 C first lets set vector conecting the ithe side-chain with kth side-chain
12464       pep_side(j)=c(j,k+nres)-(c(j,i)+c(j,i+1))/2.0d0
12465 C      pep_side(j)=2.0d0
12466 C and vector conecting the side-chain with its proper calfa
12467       side_calf(j)=c(j,k+nres)-c(j,k)
12468 C      side_calf(j)=2.0d0
12469       pept_group(j)=c(j,i)-c(j,i+1)
12470 C lets have their lenght
12471       dist_pep_side=pep_side(j)**2+dist_pep_side
12472       dist_side_calf=dist_side_calf+side_calf(j)**2
12473       dist_pept_group=dist_pept_group+pept_group(j)**2
12474       enddo
12475        dist_pep_side=dsqrt(dist_pep_side)
12476        dist_pept_group=dsqrt(dist_pept_group)
12477        dist_side_calf=dsqrt(dist_side_calf)
12478       do j=1,3
12479         pep_side_norm(j)=pep_side(j)/dist_pep_side
12480         side_calf_norm(j)=dist_side_calf
12481       enddo
12482 C now sscale fraction
12483        sh_frac_dist=-(dist_pep_side-rpp(1,1)-buff_shield)/buff_shield
12484 C       print *,buff_shield,"buff"
12485 C now sscale
12486         if (sh_frac_dist.le.0.0) cycle
12487 C If we reach here it means that this side chain reaches the shielding sphere
12488 C Lets add him to the list for gradient
12489         ishield_list(i)=ishield_list(i)+1
12490 C ishield_list is a list of non 0 side-chain that contribute to factor gradient
12491 C this list is essential otherwise problem would be O3
12492         shield_list(ishield_list(i),i)=k
12493 C Lets have the sscale value
12494         if (sh_frac_dist.gt.1.0) then
12495          scale_fac_dist=1.0d0
12496          do j=1,3
12497          sh_frac_dist_grad(j)=0.0d0
12498          enddo
12499         else
12500          scale_fac_dist=-sh_frac_dist*sh_frac_dist
12501      &                   *(2.0d0*sh_frac_dist-3.0d0)
12502          fac_help_scale=6.0d0*(sh_frac_dist-sh_frac_dist**2)
12503      &                  /dist_pep_side/buff_shield*0.5d0
12504 C remember for the final gradient multiply sh_frac_dist_grad(j)
12505 C for side_chain by factor -2 !
12506          do j=1,3
12507          sh_frac_dist_grad(j)=fac_help_scale*pep_side(j)
12508 C         sh_frac_dist_grad(j)=0.0d0
12509 C         scale_fac_dist=1.0d0
12510 C         print *,"jestem",scale_fac_dist,fac_help_scale,
12511 C     &                    sh_frac_dist_grad(j)
12512          enddo
12513         endif
12514 C this is what is now we have the distance scaling now volume...
12515       short=short_r_sidechain(itype(k))
12516       long=long_r_sidechain(itype(k))
12517       costhet=1.0d0/dsqrt(1.0d0+short**2/dist_pep_side**2)
12518       sinthet=short/dist_pep_side*costhet
12519 C now costhet_grad
12520 C       costhet=0.6d0
12521 C       sinthet=0.8
12522        costhet_fac=costhet**3*short**2*(-0.5d0)/dist_pep_side**4
12523 C       sinthet_fac=costhet**2*0.5d0*(short**3/dist_pep_side**4*costhet
12524 C     &             -short/dist_pep_side**2/costhet)
12525 C       costhet_fac=0.0d0
12526        do j=1,3
12527          costhet_grad(j)=costhet_fac*pep_side(j)
12528        enddo
12529 C remember for the final gradient multiply costhet_grad(j)
12530 C for side_chain by factor -2 !
12531 C fac alfa is angle between CB_k,CA_k, CA_i,CA_i+1
12532 C pep_side0pept_group is vector multiplication
12533       pep_side0pept_group=0.0d0
12534       do j=1,3
12535       pep_side0pept_group=pep_side0pept_group+pep_side(j)*side_calf(j)
12536       enddo
12537       cosalfa=(pep_side0pept_group/
12538      & (dist_pep_side*dist_side_calf))
12539       fac_alfa_sin=1.0d0-cosalfa**2
12540       fac_alfa_sin=dsqrt(fac_alfa_sin)
12541       rkprim=fac_alfa_sin*(long-short)+short
12542 C      rkprim=short
12543
12544 C now costhet_grad
12545        cosphi=1.0d0/dsqrt(1.0d0+rkprim**2/dist_pep_side**2)
12546 C       cosphi=0.6
12547        cosphi_fac=cosphi**3*rkprim**2*(-0.5d0)/dist_pep_side**4
12548        sinphi=rkprim/dist_pep_side/dsqrt(1.0d0+rkprim**2/
12549      &      dist_pep_side**2)
12550 C       sinphi=0.8
12551        do j=1,3
12552          cosphi_grad_long(j)=cosphi_fac*pep_side(j)
12553      &+cosphi**3*0.5d0/dist_pep_side**2*(-rkprim)
12554      &*(long-short)/fac_alfa_sin*cosalfa/
12555      &((dist_pep_side*dist_side_calf))*
12556      &((side_calf(j))-cosalfa*
12557      &((pep_side(j)/dist_pep_side)*dist_side_calf))
12558 C       cosphi_grad_long(j)=0.0d0
12559         cosphi_grad_loc(j)=cosphi**3*0.5d0/dist_pep_side**2*(-rkprim)
12560      &*(long-short)/fac_alfa_sin*cosalfa
12561      &/((dist_pep_side*dist_side_calf))*
12562      &(pep_side(j)-
12563      &cosalfa*side_calf(j)/dist_side_calf*dist_pep_side)
12564 C       cosphi_grad_loc(j)=0.0d0
12565        enddo
12566 C      print *,sinphi,sinthet
12567 c      write (iout,*) "VSolvSphere",VSolvSphere," VSolvSphere_div",
12568 c     &  VSolvSphere_div," sinphi",sinphi," sinthet",sinthet
12569       VofOverlap=VSolvSphere/2.0d0*(1.0d0-dsqrt(1.0d0-sinphi*sinthet))
12570      &                    /VSolvSphere_div
12571 C     &                    *wshield
12572 C now the gradient...
12573       do j=1,3
12574       grad_shield(j,i)=grad_shield(j,i)
12575 C gradient po skalowaniu
12576      &                +(sh_frac_dist_grad(j)*VofOverlap
12577 C  gradient po costhet
12578      &       +scale_fac_dist*VSolvSphere/VSolvSphere_div/4.0d0*
12579      &(1.0d0/(-dsqrt(1.0d0-sinphi*sinthet))*(
12580      &       sinphi/sinthet*costhet*costhet_grad(j)
12581      &      +sinthet/sinphi*cosphi*cosphi_grad_long(j)))
12582      & )*wshield
12583 C grad_shield_side is Cbeta sidechain gradient
12584       grad_shield_side(j,ishield_list(i),i)=
12585      &        (sh_frac_dist_grad(j)*(-2.0d0)
12586      &        *VofOverlap
12587      &       -scale_fac_dist*VSolvSphere/VSolvSphere_div/2.0d0*
12588      &(1.0d0/(-dsqrt(1.0d0-sinphi*sinthet))*(
12589      &       sinphi/sinthet*costhet*costhet_grad(j)
12590      &      +sinthet/sinphi*cosphi*cosphi_grad_long(j)))
12591      &       )*wshield
12592
12593        grad_shield_loc(j,ishield_list(i),i)=
12594      &       scale_fac_dist*VSolvSphere/VSolvSphere_div/2.0d0*
12595      &(1.0d0/(dsqrt(1.0d0-sinphi*sinthet))*(
12596      &       sinthet/sinphi*cosphi*cosphi_grad_loc(j)
12597      &        ))
12598      &        *wshield
12599       enddo
12600 c      write (iout,*) "VofOverlap",VofOverlap," scale_fac_dist",
12601 c     & scale_fac_dist
12602       VolumeTotal=VolumeTotal+VofOverlap*scale_fac_dist
12603       enddo
12604       fac_shield(i)=VolumeTotal*wshield+(1.0d0-wshield)
12605 c      write(2,*) "TOTAL VOLUME",i,VolumeTotal,fac_shield(i),
12606 c     &  " wshield",wshield
12607 c      write(2,*) "TU",rpp(1,1),short,long,buff_shield
12608       enddo
12609       return
12610       end
12611 C-----------------------------------------------------------------------
12612 C-----------------------------------------------------------
12613 C This subroutine is to mimic the histone like structure but as well can be
12614 C utilizet to nanostructures (infinit) small modification has to be used to
12615 C make it finite (z gradient at the ends has to be changes as well as the x,y
12616 C gradient has to be modified at the ends
12617 C The energy function is Kihara potential
12618 C E=4esp*((sigma/(r-r0))^12 - (sigma/(r-r0))^6)
12619 C 4eps is depth of well sigma is r_minimum r is distance from center of tube
12620 C and r0 is the excluded size of nanotube (can be set to 0 if we want just a
12621 C simple Kihara potential
12622       subroutine calctube(Etube)
12623        implicit real*8 (a-h,o-z)
12624       include 'DIMENSIONS'
12625       include 'COMMON.GEO'
12626       include 'COMMON.VAR'
12627       include 'COMMON.LOCAL'
12628       include 'COMMON.CHAIN'
12629       include 'COMMON.DERIV'
12630       include 'COMMON.NAMES'
12631       include 'COMMON.INTERACT'
12632       include 'COMMON.IOUNITS'
12633       include 'COMMON.CALC'
12634       include 'COMMON.CONTROL'
12635       include 'COMMON.SPLITELE'
12636       include 'COMMON.SBRIDGE'
12637       double precision tub_r,vectube(3),enetube(maxres*2)
12638       Etube=0.0d0
12639       do i=1,2*nres
12640         enetube(i)=0.0d0
12641       enddo
12642 C first we calculate the distance from tube center
12643 C first sugare-phosphate group for NARES this would be peptide group
12644 C for UNRES
12645       do i=1,nres
12646 C lets ommit dummy atoms for now
12647        if ((itype(i).eq.ntyp1).or.(itype(i+1).eq.ntyp1)) cycle
12648 C now calculate distance from center of tube and direction vectors
12649       vectube(1)=mod((c(1,i)+c(1,i+1))/2.0d0,boxxsize)
12650           if (vectube(1).lt.0) vectube(1)=vectube(1)+boxxsize
12651       vectube(2)=mod((c(2,i)+c(2,i+1))/2.0d0,boxxsize)
12652           if (vectube(2).lt.0) vectube(2)=vectube(2)+boxxsize
12653       vectube(1)=vectube(1)-tubecenter(1)
12654       vectube(2)=vectube(2)-tubecenter(2)
12655
12656 C      print *,"x",(c(1,i)+c(1,i+1))/2.0d0,tubecenter(1)
12657 C      print *,"y",(c(2,i)+c(2,i+1))/2.0d0,tubecenter(2)
12658
12659 C as the tube is infinity we do not calculate the Z-vector use of Z
12660 C as chosen axis
12661       vectube(3)=0.0d0
12662 C now calculte the distance
12663        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
12664 C now normalize vector
12665       vectube(1)=vectube(1)/tub_r
12666       vectube(2)=vectube(2)/tub_r
12667 C calculte rdiffrence between r and r0
12668       rdiff=tub_r-tubeR0
12669 C and its 6 power
12670       rdiff6=rdiff**6.0d0
12671 C for vectorization reasons we will sumup at the end to avoid depenence of previous
12672        enetube(i)=pep_aa_tube/rdiff6**2.0d0-pep_bb_tube/rdiff6
12673 C       write(iout,*) "TU13",i,rdiff6,enetube(i)
12674 C       print *,rdiff,rdiff6,pep_aa_tube
12675 C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
12676 C now we calculate gradient
12677        fac=(-12.0d0*pep_aa_tube/rdiff6+
12678      &       6.0d0*pep_bb_tube)/rdiff6/rdiff
12679 C       write(iout,'(a5,i4,f12.1,3f12.5)') "TU13",i,rdiff6,enetube(i),
12680 C     &rdiff,fac
12681
12682 C now direction of gg_tube vector
12683         do j=1,3
12684         gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac/2.0d0
12685         gg_tube(j,i)=gg_tube(j,i)+vectube(j)*fac/2.0d0
12686         enddo
12687         enddo
12688 C basically thats all code now we split for side-chains (REMEMBER to sum up at the END)
12689         do i=1,nres
12690 C Lets not jump over memory as we use many times iti
12691          iti=itype(i)
12692 C lets ommit dummy atoms for now
12693          if ((iti.eq.ntyp1)
12694 C in UNRES uncomment the line below as GLY has no side-chain...
12695 C      .or.(iti.eq.10)
12696      &   ) cycle
12697           vectube(1)=c(1,i+nres)
12698           vectube(1)=mod(vectube(1),boxxsize)
12699           if (vectube(1).lt.0) vectube(1)=vectube(1)+boxxsize
12700           vectube(2)=c(2,i+nres)
12701           vectube(2)=mod(vectube(2),boxxsize)
12702           if (vectube(2).lt.0) vectube(2)=vectube(2)+boxxsize
12703
12704       vectube(1)=vectube(1)-tubecenter(1)
12705       vectube(2)=vectube(2)-tubecenter(2)
12706
12707 C as the tube is infinity we do not calculate the Z-vector use of Z
12708 C as chosen axis
12709       vectube(3)=0.0d0
12710 C now calculte the distance
12711        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
12712 C now normalize vector
12713       vectube(1)=vectube(1)/tub_r
12714       vectube(2)=vectube(2)/tub_r
12715 C calculte rdiffrence between r and r0
12716       rdiff=tub_r-tubeR0
12717 C and its 6 power
12718       rdiff6=rdiff**6.0d0
12719 C for vectorization reasons we will sumup at the end to avoid depenence of previous
12720        sc_aa_tube=sc_aa_tube_par(iti)
12721        sc_bb_tube=sc_bb_tube_par(iti)
12722        enetube(i+nres)=sc_aa_tube/rdiff6**2.0d0-sc_bb_tube/rdiff6
12723 C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
12724 C now we calculate gradient
12725        fac=-12.0d0*sc_aa_tube/rdiff6**2.0d0/rdiff+
12726      &       6.0d0*sc_bb_tube/rdiff6/rdiff
12727 C now direction of gg_tube vector
12728          do j=1,3
12729           gg_tube_SC(j,i)=gg_tube_SC(j,i)+vectube(j)*fac
12730           gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac
12731          enddo
12732         enddo
12733         do i=1,2*nres
12734           Etube=Etube+enetube(i)
12735         enddo
12736 C        print *,"ETUBE", etube
12737         return
12738         end
12739 C TO DO 1) add to total energy
12740 C       2) add to gradient summation
12741 C       3) add reading parameters (AND of course oppening of PARAM file)
12742 C       4) add reading the center of tube
12743 C       5) add COMMONs
12744 C       6) add to zerograd
12745
12746 C-----------------------------------------------------------------------
12747 C-----------------------------------------------------------
12748 C This subroutine is to mimic the histone like structure but as well can be
12749 C utilizet to nanostructures (infinit) small modification has to be used to
12750 C make it finite (z gradient at the ends has to be changes as well as the x,y
12751 C gradient has to be modified at the ends
12752 C The energy function is Kihara potential
12753 C E=4esp*((sigma/(r-r0))^12 - (sigma/(r-r0))^6)
12754 C 4eps is depth of well sigma is r_minimum r is distance from center of tube
12755 C and r0 is the excluded size of nanotube (can be set to 0 if we want just a
12756 C simple Kihara potential
12757       subroutine calctube2(Etube)
12758        implicit real*8 (a-h,o-z)
12759       include 'DIMENSIONS'
12760       include 'COMMON.GEO'
12761       include 'COMMON.VAR'
12762       include 'COMMON.LOCAL'
12763       include 'COMMON.CHAIN'
12764       include 'COMMON.DERIV'
12765       include 'COMMON.NAMES'
12766       include 'COMMON.INTERACT'
12767       include 'COMMON.IOUNITS'
12768       include 'COMMON.CALC'
12769       include 'COMMON.CONTROL'
12770       include 'COMMON.SPLITELE'
12771       include 'COMMON.SBRIDGE'
12772       double precision tub_r,vectube(3),enetube(maxres*2)
12773       Etube=0.0d0
12774       do i=1,2*nres
12775         enetube(i)=0.0d0
12776       enddo
12777 C first we calculate the distance from tube center
12778 C first sugare-phosphate group for NARES this would be peptide group
12779 C for UNRES
12780       do i=1,nres
12781 C lets ommit dummy atoms for now
12782        if ((itype(i).eq.ntyp1).or.(itype(i+1).eq.ntyp1)) cycle
12783 C now calculate distance from center of tube and direction vectors
12784       vectube(1)=mod((c(1,i)+c(1,i+1))/2.0d0,boxxsize)
12785           if (vectube(1).lt.0) vectube(1)=vectube(1)+boxxsize
12786       vectube(2)=mod((c(2,i)+c(2,i+1))/2.0d0,boxxsize)
12787           if (vectube(2).lt.0) vectube(2)=vectube(2)+boxxsize
12788       vectube(1)=vectube(1)-tubecenter(1)
12789       vectube(2)=vectube(2)-tubecenter(2)
12790
12791 C      print *,"x",(c(1,i)+c(1,i+1))/2.0d0,tubecenter(1)
12792 C      print *,"y",(c(2,i)+c(2,i+1))/2.0d0,tubecenter(2)
12793
12794 C as the tube is infinity we do not calculate the Z-vector use of Z
12795 C as chosen axis
12796       vectube(3)=0.0d0
12797 C now calculte the distance
12798        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
12799 C now normalize vector
12800       vectube(1)=vectube(1)/tub_r
12801       vectube(2)=vectube(2)/tub_r
12802 C calculte rdiffrence between r and r0
12803       rdiff=tub_r-tubeR0
12804 C and its 6 power
12805       rdiff6=rdiff**6.0d0
12806 C for vectorization reasons we will sumup at the end to avoid depenence of previous
12807        enetube(i)=pep_aa_tube/rdiff6**2.0d0-pep_bb_tube/rdiff6
12808 C       write(iout,*) "TU13",i,rdiff6,enetube(i)
12809 C       print *,rdiff,rdiff6,pep_aa_tube
12810 C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
12811 C now we calculate gradient
12812        fac=(-12.0d0*pep_aa_tube/rdiff6+
12813      &       6.0d0*pep_bb_tube)/rdiff6/rdiff
12814 C       write(iout,'(a5,i4,f12.1,3f12.5)') "TU13",i,rdiff6,enetube(i),
12815 C     &rdiff,fac
12816
12817 C now direction of gg_tube vector
12818         do j=1,3
12819         gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac/2.0d0
12820         gg_tube(j,i)=gg_tube(j,i)+vectube(j)*fac/2.0d0
12821         enddo
12822         enddo
12823 C basically thats all code now we split for side-chains (REMEMBER to sum up at the END)
12824         do i=1,nres
12825 C Lets not jump over memory as we use many times iti
12826          iti=itype(i)
12827 C lets ommit dummy atoms for now
12828          if ((iti.eq.ntyp1)
12829 C in UNRES uncomment the line below as GLY has no side-chain...
12830      &      .or.(iti.eq.10)
12831      &   ) cycle
12832           vectube(1)=c(1,i+nres)
12833           vectube(1)=mod(vectube(1),boxxsize)
12834           if (vectube(1).lt.0) vectube(1)=vectube(1)+boxxsize
12835           vectube(2)=c(2,i+nres)
12836           vectube(2)=mod(vectube(2),boxxsize)
12837           if (vectube(2).lt.0) vectube(2)=vectube(2)+boxxsize
12838
12839       vectube(1)=vectube(1)-tubecenter(1)
12840       vectube(2)=vectube(2)-tubecenter(2)
12841 C THIS FRAGMENT MAKES TUBE FINITE
12842         positi=(mod(c(3,i+nres),boxzsize))
12843         if (positi.le.0) positi=positi+boxzsize
12844 C       print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop
12845 c for each residue check if it is in lipid or lipid water border area
12846 C       respos=mod(c(3,i+nres),boxzsize)
12847        print *,positi,bordtubebot,buftubebot,bordtubetop
12848        if ((positi.gt.bordtubebot)
12849      & .and.(positi.lt.bordtubetop)) then
12850 C the energy transfer exist
12851         if (positi.lt.buftubebot) then
12852          fracinbuf=1.0d0-
12853      &     ((positi-bordtubebot)/tubebufthick)
12854 C lipbufthick is thickenes of lipid buffore
12855          sstube=sscalelip(fracinbuf)
12856          ssgradtube=-sscagradlip(fracinbuf)/tubebufthick
12857          print *,ssgradtube, sstube,tubetranene(itype(i))
12858          enetube(i+nres)=enetube(i+nres)+sstube*tubetranene(itype(i))
12859          gg_tube_SC(3,i)=gg_tube_SC(3,i)
12860      &+ssgradtube*tubetranene(itype(i))
12861          gg_tube(3,i-1)= gg_tube(3,i-1)
12862      &+ssgradtube*tubetranene(itype(i))
12863 C         print *,"doing sccale for lower part"
12864         elseif (positi.gt.buftubetop) then
12865          fracinbuf=1.0d0-
12866      &((bordtubetop-positi)/tubebufthick)
12867          sstube=sscalelip(fracinbuf)
12868          ssgradtube=sscagradlip(fracinbuf)/tubebufthick
12869          enetube(i+nres)=enetube(i+nres)+sstube*tubetranene(itype(i))
12870 C         gg_tube_SC(3,i)=gg_tube_SC(3,i)
12871 C     &+ssgradtube*tubetranene(itype(i))
12872 C         gg_tube(3,i-1)= gg_tube(3,i-1)
12873 C     &+ssgradtube*tubetranene(itype(i))
12874 C          print *, "doing sscalefor top part",sslip,fracinbuf
12875         else
12876          sstube=1.0d0
12877          ssgradtube=0.0d0
12878          enetube(i+nres)=enetube(i+nres)+sstube*tubetranene(itype(i))
12879 C         print *,"I am in true lipid"
12880         endif
12881         else
12882 C          sstube=0.0d0
12883 C          ssgradtube=0.0d0
12884         cycle
12885         endif ! if in lipid or buffor
12886 CEND OF FINITE FRAGMENT
12887 C as the tube is infinity we do not calculate the Z-vector use of Z
12888 C as chosen axis
12889       vectube(3)=0.0d0
12890 C now calculte the distance
12891        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
12892 C now normalize vector
12893       vectube(1)=vectube(1)/tub_r
12894       vectube(2)=vectube(2)/tub_r
12895 C calculte rdiffrence between r and r0
12896       rdiff=tub_r-tubeR0
12897 C and its 6 power
12898       rdiff6=rdiff**6.0d0
12899 C for vectorization reasons we will sumup at the end to avoid depenence of previous
12900        sc_aa_tube=sc_aa_tube_par(iti)
12901        sc_bb_tube=sc_bb_tube_par(iti)
12902        enetube(i+nres)=(sc_aa_tube/rdiff6**2.0d0-sc_bb_tube/rdiff6)
12903      &                 *sstube+enetube(i+nres)
12904 C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
12905 C now we calculate gradient
12906        fac=(-12.0d0*sc_aa_tube/rdiff6**2.0d0/rdiff+
12907      &       6.0d0*sc_bb_tube/rdiff6/rdiff)*sstube
12908 C now direction of gg_tube vector
12909          do j=1,3
12910           gg_tube_SC(j,i)=gg_tube_SC(j,i)+vectube(j)*fac
12911           gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac
12912          enddo
12913          gg_tube_SC(3,i)=gg_tube_SC(3,i)
12914      &+ssgradtube*enetube(i+nres)/sstube
12915          gg_tube(3,i-1)= gg_tube(3,i-1)
12916      &+ssgradtube*enetube(i+nres)/sstube
12917
12918         enddo
12919         do i=1,2*nres
12920           Etube=Etube+enetube(i)
12921         enddo
12922 C        print *,"ETUBE", etube
12923         return
12924         end
12925 C TO DO 1) add to total energy
12926 C       2) add to gradient summation
12927 C       3) add reading parameters (AND of course oppening of PARAM file)
12928 C       4) add reading the center of tube
12929 C       5) add COMMONs
12930 C       6) add to zerograd
12931 c----------------------------------------------------------------------------
12932       subroutine e_saxs(Esaxs_constr)
12933       implicit none
12934       include 'DIMENSIONS'
12935 #ifdef MPI
12936       include "mpif.h"
12937       include "COMMON.SETUP"
12938       integer IERR
12939 #endif
12940       include 'COMMON.SBRIDGE'
12941       include 'COMMON.CHAIN'
12942       include 'COMMON.GEO'
12943       include 'COMMON.DERIV'
12944       include 'COMMON.LOCAL'
12945       include 'COMMON.INTERACT'
12946       include 'COMMON.VAR'
12947       include 'COMMON.IOUNITS'
12948       include 'COMMON.MD'
12949       include 'COMMON.CONTROL'
12950       include 'COMMON.NAMES'
12951       include 'COMMON.TIME1'
12952       include 'COMMON.FFIELD'
12953 c
12954       double precision Esaxs_constr
12955       integer i,iint,j,k,l
12956       double precision PgradC(maxSAXS,3,maxres),
12957      &  PgradX(maxSAXS,3,maxres),Pcalc(maxSAXS)
12958 #ifdef MPI
12959       double precision PgradC_(maxSAXS,3,maxres),
12960      &  PgradX_(maxSAXS,3,maxres),Pcalc_(maxSAXS)
12961 #endif
12962       double precision dk,dijCACA,dijCASC,dijSCCA,dijSCSC,
12963      & sigma2CACA,sigma2CASC,sigma2SCCA,sigma2SCSC,expCACA,expCASC,
12964      & expSCCA,expSCSC,CASCgrad,SCCAgrad,SCSCgrad,aux,auxC,auxC1,
12965      & auxX,auxX1,CACAgrad,Cnorm,sigmaCACA,threesig
12966       double precision sss2,ssgrad2,rrr,sscalgrad2,sscale2
12967       double precision dist,mygauss,mygaussder
12968       external dist
12969       integer llicz,lllicz
12970       double precision time01
12971 c  SAXS restraint penalty function
12972 #ifdef DEBUG
12973       write(iout,*) "------- SAXS penalty function start -------"
12974       write (iout,*) "nsaxs",nsaxs
12975       write (iout,*) "Esaxs: iatsc_s",iatsc_s," iatsc_e",iatsc_e
12976       write (iout,*) "Psaxs"
12977       do i=1,nsaxs
12978         write (iout,'(i5,e15.5)') i, Psaxs(i)
12979       enddo
12980 #endif
12981 #ifdef TIMING
12982       time01=MPI_Wtime()
12983 #endif
12984       Esaxs_constr = 0.0d0
12985       do k=1,nsaxs
12986         Pcalc(k)=0.0d0
12987         do j=1,nres
12988           do l=1,3
12989             PgradC(k,l,j)=0.0d0
12990             PgradX(k,l,j)=0.0d0
12991           enddo
12992         enddo
12993       enddo
12994 c      lllicz=0
12995       do i=iatsc_s,iatsc_e
12996        if (itype(i).eq.ntyp1) cycle
12997        do iint=1,nint_gr(i)
12998          do j=istart(i,iint),iend(i,iint)
12999            if (itype(j).eq.ntyp1) cycle
13000 #ifdef ALLSAXS
13001            dijCACA=dist(i,j)
13002            dijCASC=dist(i,j+nres)
13003            dijSCCA=dist(i+nres,j)
13004            dijSCSC=dist(i+nres,j+nres)
13005            sigma2CACA=2.0d0/(pstok**2)
13006            sigma2CASC=4.0d0/(pstok**2+restok(itype(j))**2)
13007            sigma2SCCA=4.0d0/(pstok**2+restok(itype(i))**2)
13008            sigma2SCSC=4.0d0/(restok(itype(j))**2+restok(itype(i))**2)
13009            do k=1,nsaxs
13010              dk = distsaxs(k)
13011              expCACA = dexp(-0.5d0*sigma2CACA*(dijCACA-dk)**2)
13012              if (itype(j).ne.10) then
13013              expCASC = dexp(-0.5d0*sigma2CASC*(dijCASC-dk)**2)
13014              else
13015              endif
13016              expCASC = 0.0d0
13017              if (itype(i).ne.10) then
13018              expSCCA = dexp(-0.5d0*sigma2SCCA*(dijSCCA-dk)**2)
13019              else
13020              expSCCA = 0.0d0
13021              endif
13022              if (itype(i).ne.10 .and. itype(j).ne.10) then
13023              expSCSC = dexp(-0.5d0*sigma2SCSC*(dijSCSC-dk)**2)
13024              else
13025              expSCSC = 0.0d0
13026              endif
13027              Pcalc(k) = Pcalc(k)+expCACA+expCASC+expSCCA+expSCSC
13028 #ifdef DEBUG
13029              write(iout,*) "i j k Pcalc",i,j,Pcalc(k)
13030 #endif
13031              CACAgrad = sigma2CACA*(dijCACA-dk)*expCACA
13032              CASCgrad = sigma2CASC*(dijCASC-dk)*expCASC
13033              SCCAgrad = sigma2SCCA*(dijSCCA-dk)*expSCCA
13034              SCSCgrad = sigma2SCSC*(dijSCSC-dk)*expSCSC
13035              do l=1,3
13036 c CA CA
13037                aux = CACAgrad*(C(l,j)-C(l,i))/dijCACA
13038                PgradC(k,l,i) = PgradC(k,l,i)-aux
13039                PgradC(k,l,j) = PgradC(k,l,j)+aux
13040 c CA SC
13041                if (itype(j).ne.10) then
13042                aux = CASCgrad*(C(l,j+nres)-C(l,i))/dijCASC
13043                PgradC(k,l,i) = PgradC(k,l,i)-aux
13044                PgradC(k,l,j) = PgradC(k,l,j)+aux
13045                PgradX(k,l,j) = PgradX(k,l,j)+aux
13046                endif
13047 c SC CA
13048                if (itype(i).ne.10) then
13049                aux = SCCAgrad*(C(l,j)-C(l,i+nres))/dijSCCA
13050                PgradX(k,l,i) = PgradX(k,l,i)-aux
13051                PgradC(k,l,i) = PgradC(k,l,i)-aux
13052                PgradC(k,l,j) = PgradC(k,l,j)+aux
13053                endif
13054 c SC SC
13055                if (itype(i).ne.10 .and. itype(j).ne.10) then
13056                aux = SCSCgrad*(C(l,j+nres)-C(l,i+nres))/dijSCSC
13057                PgradC(k,l,i) = PgradC(k,l,i)-aux
13058                PgradC(k,l,j) = PgradC(k,l,j)+aux
13059                PgradX(k,l,i) = PgradX(k,l,i)-aux
13060                PgradX(k,l,j) = PgradX(k,l,j)+aux
13061                endif
13062              enddo ! l
13063            enddo ! k
13064 #else
13065            dijCACA=dist(i,j)
13066            sigma2CACA=scal_rad**2*0.25d0/
13067      &        (restok(itype(j))**2+restok(itype(i))**2)
13068 c           write (iout,*) "scal_rad",scal_rad," restok",restok(itype(j))
13069 c     &       ,restok(itype(i)),"sigma",1.0d0/dsqrt(sigma2CACA)
13070 #ifdef MYGAUSS
13071            sigmaCACA=dsqrt(sigma2CACA)
13072            threesig=3.0d0/sigmaCACA
13073 c           llicz=0
13074            do k=1,nsaxs
13075              dk = distsaxs(k)
13076              if (dabs(dijCACA-dk).ge.threesig) cycle
13077 c             llicz=llicz+1
13078 c             lllicz=lllicz+1
13079              aux = sigmaCACA*(dijCACA-dk)
13080              expCACA = mygauss(aux)
13081 c             if (expcaca.eq.0.0d0) cycle
13082              Pcalc(k) = Pcalc(k)+expCACA
13083              CACAgrad = -sigmaCACA*mygaussder(aux)
13084 c             write (iout,*) "i,j,k,aux",i,j,k,CACAgrad
13085              do l=1,3
13086                aux = CACAgrad*(C(l,j)-C(l,i))/dijCACA
13087                PgradC(k,l,i) = PgradC(k,l,i)-aux
13088                PgradC(k,l,j) = PgradC(k,l,j)+aux
13089              enddo ! l
13090            enddo ! k
13091 c           write (iout,*) "i",i," j",j," llicz",llicz
13092 #else
13093            IF (saxs_cutoff.eq.0) THEN
13094            do k=1,nsaxs
13095              dk = distsaxs(k)
13096              expCACA = dexp(-0.5d0*sigma2CACA*(dijCACA-dk)**2)
13097              Pcalc(k) = Pcalc(k)+expCACA
13098              CACAgrad = sigma2CACA*(dijCACA-dk)*expCACA
13099              do l=1,3
13100                aux = CACAgrad*(C(l,j)-C(l,i))/dijCACA
13101                PgradC(k,l,i) = PgradC(k,l,i)-aux
13102                PgradC(k,l,j) = PgradC(k,l,j)+aux
13103              enddo ! l
13104            enddo ! k
13105            ELSE
13106            rrr = saxs_cutoff*2.0d0/dsqrt(sigma2CACA)
13107            do k=1,nsaxs
13108              dk = distsaxs(k)
13109 c             write (2,*) "ijk",i,j,k
13110              sss2 = sscale2(dijCACA,rrr,dk,0.3d0)
13111              if (sss2.eq.0.0d0) cycle
13112              ssgrad2 = sscalgrad2(dijCACA,rrr,dk,0.3d0)
13113              if (energy_dec) write(iout,'(a4,3i5,8f10.4)')
13114      &          'saxs',i,j,k,dijCACA,restok(itype(i)),restok(itype(j)),
13115      &          1.0d0/dsqrt(sigma2CACA),rrr,dk,
13116      &           sss2,ssgrad2
13117              expCACA = dexp(-0.5d0*sigma2CACA*(dijCACA-dk)**2)*sss2
13118              Pcalc(k) = Pcalc(k)+expCACA
13119 #ifdef DEBUG
13120              write(iout,*) "i j k Pcalc",i,j,Pcalc(k)
13121 #endif
13122              CACAgrad = -sigma2CACA*(dijCACA-dk)*expCACA+
13123      &             ssgrad2*expCACA/sss2
13124              do l=1,3
13125 c CA CA
13126                aux = CACAgrad*(C(l,j)-C(l,i))/dijCACA
13127                PgradC(k,l,i) = PgradC(k,l,i)+aux
13128                PgradC(k,l,j) = PgradC(k,l,j)-aux
13129              enddo ! l
13130            enddo ! k
13131            ENDIF
13132 #endif
13133 #endif
13134          enddo ! j
13135        enddo ! iint
13136       enddo ! i
13137 c#ifdef TIMING
13138 c      time_SAXS=time_SAXS+MPI_Wtime()-time01
13139 c#endif
13140 c      write (iout,*) "lllicz",lllicz
13141 c#ifdef TIMING
13142 c      time01=MPI_Wtime()
13143 c#endif
13144 #ifdef MPI
13145       if (nfgtasks.gt.1) then
13146        call MPI_AllReduce(Pcalc(1),Pcalc_(1),nsaxs,MPI_DOUBLE_PRECISION,
13147      &    MPI_SUM,FG_COMM,IERR)
13148 c        if (fg_rank.eq.king) then
13149           do k=1,nsaxs
13150             Pcalc(k) = Pcalc_(k)
13151           enddo
13152 c        endif
13153 c        call MPI_AllReduce(PgradC(k,1,1),PgradC_(k,1,1),3*maxsaxs*nres,
13154 c     &    MPI_DOUBLE_PRECISION,MPI_SUM,FG_COMM,IERR)
13155 c        if (fg_rank.eq.king) then
13156 c          do i=1,nres
13157 c            do l=1,3
13158 c              do k=1,nsaxs
13159 c                PgradC(k,l,i) = PgradC_(k,l,i)
13160 c              enddo
13161 c            enddo
13162 c          enddo
13163 c        endif
13164 #ifdef ALLSAXS
13165 c        call MPI_AllReduce(PgradX(k,1,1),PgradX_(k,1,1),3*maxsaxs*nres,
13166 c     &    MPI_DOUBLE_PRECISION,MPI_SUM,FG_COMM,IERR)
13167 c        if (fg_rank.eq.king) then
13168 c          do i=1,nres
13169 c            do l=1,3
13170 c              do k=1,nsaxs
13171 c                PgradX(k,l,i) = PgradX_(k,l,i)
13172 c              enddo
13173 c            enddo
13174 c          enddo
13175 c        endif
13176 #endif
13177       endif
13178 #endif
13179       Cnorm = 0.0d0
13180       do k=1,nsaxs
13181         Cnorm = Cnorm + Pcalc(k)
13182       enddo
13183 #ifdef MPI
13184       if (fg_rank.eq.king) then
13185 #endif
13186       Esaxs_constr = dlog(Cnorm)-wsaxs0
13187       do k=1,nsaxs
13188         if (Pcalc(k).gt.0.0d0)
13189      &  Esaxs_constr = Esaxs_constr - Psaxs(k)*dlog(Pcalc(k))
13190 #ifdef DEBUG
13191         write (iout,*) "k",k," Esaxs_constr",Esaxs_constr
13192 #endif
13193       enddo
13194 #ifdef DEBUG
13195       write (iout,*) "Cnorm",Cnorm," Esaxs_constr",Esaxs_constr
13196 #endif
13197 #ifdef MPI
13198       endif
13199 #endif
13200       gsaxsC=0.0d0
13201       gsaxsX=0.0d0
13202       do i=nnt,nct
13203         do l=1,3
13204           auxC=0.0d0
13205           auxC1=0.0d0
13206           auxX=0.0d0
13207           auxX1=0.d0
13208           do k=1,nsaxs
13209             if (Pcalc(k).gt.0)
13210      &      auxC  = auxC +Psaxs(k)*PgradC(k,l,i)/Pcalc(k)
13211             auxC1 = auxC1+PgradC(k,l,i)
13212 #ifdef ALLSAXS
13213             auxX  = auxX +Psaxs(k)*PgradX(k,l,i)/Pcalc(k)
13214             auxX1 = auxX1+PgradX(k,l,i)
13215 #endif
13216           enddo
13217           gsaxsC(l,i) = auxC - auxC1/Cnorm
13218 #ifdef ALLSAXS
13219           gsaxsX(l,i) = auxX - auxX1/Cnorm
13220 #endif
13221 c          write (iout,*) "l i",l,i," gradC",wsaxs*(auxC - auxC1/Cnorm),
13222 c     *     " gradX",wsaxs*(auxX - auxX1/Cnorm)
13223 c          write (iout,*) "l i",l,i," gradC",wsaxs*gsaxsC(l,i),
13224 c     *     " gradX",wsaxs*gsaxsX(l,i)
13225         enddo
13226       enddo
13227 #ifdef TIMING
13228       time_SAXS=time_SAXS+MPI_Wtime()-time01
13229 #endif
13230 #ifdef DEBUG
13231       write (iout,*) "gsaxsc"
13232       do i=nnt,nct
13233         write (iout,'(i5,3e15.5)') i,(gsaxsc(j,i),j=1,3)
13234       enddo
13235 #endif
13236 #ifdef MPI
13237 c      endif
13238 #endif
13239       return
13240       end
13241 c----------------------------------------------------------------------------
13242       subroutine e_saxsC(Esaxs_constr)
13243       implicit none
13244       include 'DIMENSIONS'
13245 #ifdef MPI
13246       include "mpif.h"
13247       include "COMMON.SETUP"
13248       integer IERR
13249 #endif
13250       include 'COMMON.SBRIDGE'
13251       include 'COMMON.CHAIN'
13252       include 'COMMON.GEO'
13253       include 'COMMON.DERIV'
13254       include 'COMMON.LOCAL'
13255       include 'COMMON.INTERACT'
13256       include 'COMMON.VAR'
13257       include 'COMMON.IOUNITS'
13258       include 'COMMON.MD'
13259       include 'COMMON.CONTROL'
13260       include 'COMMON.NAMES'
13261       include 'COMMON.TIME1'
13262       include 'COMMON.FFIELD'
13263 c
13264       double precision Esaxs_constr
13265       integer i,iint,j,k,l
13266       double precision PgradC(3,maxres),PgradX(3,maxres),Pcalc,logPtot
13267 #ifdef MPI
13268       double precision gsaxsc_(3,maxres),gsaxsx_(3,maxres),logPtot_
13269 #endif
13270       double precision dk,dijCASPH,dijSCSPH,
13271      & sigma2CA,sigma2SC,expCASPH,expSCSPH,
13272      & CASPHgrad,SCSPHgrad,aux,auxC,auxC1,
13273      & auxX,auxX1,Cnorm
13274 c  SAXS restraint penalty function
13275 #ifdef DEBUG
13276       write(iout,*) "------- SAXS penalty function start -------"
13277       write (iout,*) "nsaxs",nsaxs
13278
13279       do i=nnt,nct
13280         print *,MyRank,"C",i,(C(j,i),j=1,3)
13281       enddo
13282       do i=nnt,nct
13283         print *,MyRank,"CSaxs",i,(Csaxs(j,i),j=1,3)
13284       enddo
13285 #endif
13286       Esaxs_constr = 0.0d0
13287       logPtot=0.0d0
13288       do j=isaxs_start,isaxs_end
13289         Pcalc=0.0d0
13290         do i=1,nres
13291           do l=1,3
13292             PgradC(l,i)=0.0d0
13293             PgradX(l,i)=0.0d0
13294           enddo
13295         enddo
13296         do i=nnt,nct
13297           if (itype(i).eq.ntyp1) cycle
13298           dijCASPH=0.0d0
13299           dijSCSPH=0.0d0
13300           do l=1,3
13301             dijCASPH=dijCASPH+(C(l,i)-Csaxs(l,j))**2
13302           enddo
13303           if (itype(i).ne.10) then
13304           do l=1,3
13305             dijSCSPH=dijSCSPH+(C(l,i+nres)-Csaxs(l,j))**2
13306           enddo
13307           endif
13308           sigma2CA=2.0d0/pstok**2
13309           sigma2SC=4.0d0/restok(itype(i))**2
13310           expCASPH = dexp(-0.5d0*sigma2CA*dijCASPH)
13311           expSCSPH = dexp(-0.5d0*sigma2SC*dijSCSPH)
13312           Pcalc = Pcalc+expCASPH+expSCSPH
13313 #ifdef DEBUG
13314           write(*,*) "processor i j Pcalc",
13315      &       MyRank,i,j,dijCASPH,dijSCSPH, Pcalc
13316 #endif
13317           CASPHgrad = sigma2CA*expCASPH
13318           SCSPHgrad = sigma2SC*expSCSPH
13319           do l=1,3
13320             aux = (C(l,i+nres)-Csaxs(l,j))*SCSPHgrad
13321             PgradX(l,i) = PgradX(l,i) + aux
13322             PgradC(l,i) = PgradC(l,i)+(C(l,i)-Csaxs(l,j))*CASPHgrad+aux
13323           enddo ! l
13324         enddo ! i
13325         do i=nnt,nct
13326           do l=1,3
13327             gsaxsc(l,i)=gsaxsc(l,i)+PgradC(l,i)/Pcalc
13328             gsaxsx(l,i)=gsaxsx(l,i)+PgradX(l,i)/Pcalc
13329           enddo
13330         enddo
13331         logPtot = logPtot - dlog(Pcalc)
13332 c        print *,"me",me,MyRank," j",j," logPcalc",-dlog(Pcalc),
13333 c     &    " logPtot",logPtot
13334       enddo ! j
13335 #ifdef MPI
13336       if (nfgtasks.gt.1) then
13337 c        write (iout,*) "logPtot before reduction",logPtot
13338         call MPI_Reduce(logPtot,logPtot_,1,MPI_DOUBLE_PRECISION,
13339      &    MPI_SUM,king,FG_COMM,IERR)
13340         logPtot = logPtot_
13341 c        write (iout,*) "logPtot after reduction",logPtot
13342         call MPI_Reduce(gsaxsC(1,1),gsaxsC_(1,1),3*nres,
13343      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
13344         if (fg_rank.eq.king) then
13345           do i=1,nres
13346             do l=1,3
13347               gsaxsC(l,i) = gsaxsC_(l,i)
13348             enddo
13349           enddo
13350         endif
13351         call MPI_Reduce(gsaxsX(1,1),gsaxsX_(1,1),3*nres,
13352      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
13353         if (fg_rank.eq.king) then
13354           do i=1,nres
13355             do l=1,3
13356               gsaxsX(l,i) = gsaxsX_(l,i)
13357             enddo
13358           enddo
13359         endif
13360       endif
13361 #endif
13362       Esaxs_constr = logPtot
13363       return
13364       end
13365 c----------------------------------------------------------------------------
13366       double precision function sscale2(r,r_cut,r0,rlamb)
13367       implicit none
13368       double precision r,gamm,r_cut,r0,rlamb,rr
13369       rr = dabs(r-r0)
13370 c      write (2,*) "r",r," r_cut",r_cut," r0",r0," rlamb",rlamb
13371 c      write (2,*) "rr",rr
13372       if(rr.lt.r_cut-rlamb) then
13373         sscale2=1.0d0
13374       else if(rr.le.r_cut.and.rr.ge.r_cut-rlamb) then
13375         gamm=(rr-(r_cut-rlamb))/rlamb
13376         sscale2=1.0d0+gamm*gamm*(2*gamm-3.0d0)
13377       else
13378         sscale2=0d0
13379       endif
13380       return
13381       end
13382 C-----------------------------------------------------------------------
13383       double precision function sscalgrad2(r,r_cut,r0,rlamb)
13384       implicit none
13385       double precision r,gamm,r_cut,r0,rlamb,rr
13386       rr = dabs(r-r0)
13387       if(rr.lt.r_cut-rlamb) then
13388         sscalgrad2=0.0d0
13389       else if(rr.le.r_cut.and.rr.ge.r_cut-rlamb) then
13390         gamm=(rr-(r_cut-rlamb))/rlamb
13391         if (r.ge.r0) then
13392           sscalgrad2=gamm*(6*gamm-6.0d0)/rlamb
13393         else
13394           sscalgrad2=-gamm*(6*gamm-6.0d0)/rlamb
13395         endif
13396       else
13397         sscalgrad2=0.0d0
13398       endif
13399       return
13400       end