source/unres/src-HCD-5D/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           weights_(28)=wdfa_dist
  62           weights_(29)=wdfa_tor
  63           weights_(30)=wdfa_nei
  64           weights_(31)=wdfa_beta
  65 C FG Master broadcasts the WEIGHTS_ array
  66           call MPI_Bcast(weights_(1),n_ene,
  67      &        MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
  68         else
  69 C FG slaves receive the WEIGHTS array
  70           call MPI_Bcast(weights(1),n_ene,
  71      &        MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
  72           wsc=weights(1)
  73           wscp=weights(2)
  74           welec=weights(3)
  75           wcorr=weights(4)
  76           wcorr5=weights(5)
  77           wcorr6=weights(6)
  78           wel_loc=weights(7)
  79           wturn3=weights(8)
  80           wturn4=weights(9)
  81           wturn6=weights(10)
  82           wang=weights(11)
  83           wscloc=weights(12)
  84           wtor=weights(13)
  85           wtor_d=weights(14)
  86           wstrain=weights(15)
  87           wvdwpp=weights(16)
  88           wbond=weights(17)
  89           scal14=weights(18)
  90           wsccor=weights(21)
  91           wtube=weights(22)
  92           wsaxs=weights(26)
  93           wdfa_dist=weights_(28)
  94           wdfa_tor=weights_(29)
  95           wdfa_nei=weights_(30)
  96           wdfa_beta=weights_(31)
  97         endif
  98         time_Bcast=time_Bcast+MPI_Wtime()-time00
  99         time_Bcastw=time_Bcastw+MPI_Wtime()-time00
 100 c        call chainbuild_cart
 101       endif
 102 #ifndef DFA
 103       edfadis=0.0d0
 104       edfator=0.0d0
 105       edfanei=0.0d0
 106       edfabet=0.0d0
 107 #endif
 108 c      print *,'Processor',myrank,' calling etotal ipot=',ipot
 109 c      print *,'Processor',myrank,' nnt=',nnt,' nct=',nct
 110 #else
 111 c      if (modecalc.eq.12.or.modecalc.eq.14) then
 112 c        call int_from_cart1(.false.)
 113 c      endif
 114 #endif
 115 #ifdef TIMING
 116       time00=MPI_Wtime()
 117 #endif
 118 C
 119 C Compute the side-chain and electrostatic interaction energy
 120 C
 121 C      print *,ipot
 122       goto (101,102,103,104,105,106) ipot
 123 C Lennard-Jones potential.
 124   101 call elj(evdw)
 125 cd    print '(a)','Exit ELJ'
 126       goto 107
 127 C Lennard-Jones-Kihara potential (shifted).
 128   102 call eljk(evdw)
 129       goto 107
 130 C Berne-Pechukas potential (dilated LJ, angular dependence).
 131   103 call ebp(evdw)
 132       goto 107
 133 C Gay-Berne potential (shifted LJ, angular dependence).
 134   104 call egb(evdw)
 135 C      print *,"bylem w egb"
 136       goto 107
 137 C Gay-Berne-Vorobjev potential (shifted LJ, angular dependence).
 138   105 call egbv(evdw)
 139       goto 107
 140 C Soft-sphere potential
 141   106 call e_softsphere(evdw)
 142 C
 143 C Calculate electrostatic (H-bonding) energy of the main chain.
 144 C
 145   107 continue
 146 #ifdef DFA
 147 C     BARTEK for dfa test!
 148       if (wdfa_dist.gt.0) then
 149         call edfad(edfadis)
 150       else
 151         edfadis=0
 152       endif
 153 c      print*, 'edfad is finished!', edfadis
 154       if (wdfa_tor.gt.0) then
 155         call edfat(edfator)
 156       else
 157         edfator=0
 158       endif
 159 c      print*, 'edfat is finished!', edfator
 160       if (wdfa_nei.gt.0) then
 161         call edfan(edfanei)
 162       else
 163         edfanei=0
 164       endif
 165 c      print*, 'edfan is finished!', edfanei
 166       if (wdfa_beta.gt.0) then
 167         call edfab(edfabet)
 168       else
 169         edfabet=0
 170       endif
 171 #endif
 172 cmc
 173 cmc Sep-06: egb takes care of dynamic ss bonds too
 174 cmc
 175 c      if (dyn_ss) call dyn_set_nss
 176
 177 c      print *,"Processor",myrank," computed USCSC"
 178 #ifdef TIMING
 179       time01=MPI_Wtime()
 180 #endif
 181       call vec_and_deriv
 182 #ifdef TIMING
 183       time_vec=time_vec+MPI_Wtime()-time01
 184 #endif
 185 C Introduction of shielding effect first for each peptide group
 186 C the shielding factor is set this factor is describing how each
 187 C peptide group is shielded by side-chains
 188 C the matrix - shield_fac(i) the i index describe the ith between i and i+1
 189 C      write (iout,*) "shield_mode",shield_mode
 190       if (shield_mode.eq.1) then
 191        call set_shield_fac
 192       else if  (shield_mode.eq.2) then
 193        call set_shield_fac2
 194       endif
 195 c      print *,"Processor",myrank," left VEC_AND_DERIV"
 196       if (ipot.lt.6) then
 197 #ifdef SPLITELE
 198          if (welec.gt.0d0.or.wvdwpp.gt.0d0.or.wel_loc.gt.0d0.or.
 199      &       wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0
 200      &       .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0
 201      &       .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
 202 #else
 203          if (welec.gt.0d0.or.wel_loc.gt.0d0.or.
 204      &       wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0
 205      &       .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0
 206      &       .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
 207 #endif
 208             call eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
 209          else
 210             ees=0.0d0
 211             evdw1=0.0d0
 212             eel_loc=0.0d0
 213             eello_turn3=0.0d0
 214             eello_turn4=0.0d0
 215          endif
 216       else
 217         write (iout,*) "Soft-spheer ELEC potential"
 218 c        call eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,
 219 c     &   eello_turn4)
 220       endif
 221 c#ifdef TIMING
 222 c      time_enecalc=time_enecalc+MPI_Wtime()-time00
 223 c#endif
 224 c      print *,"Processor",myrank," computed UELEC"
 225 C
 226 C Calculate excluded-volume interaction energy between peptide groups
 227 C and side chains.
 228 C
 229       if (ipot.lt.6) then
 230        if(wscp.gt.0d0) then
 231         call escp(evdw2,evdw2_14)
 232        else
 233         evdw2=0
 234         evdw2_14=0
 235        endif
 236       else
 237 c        write (iout,*) "Soft-sphere SCP potential"
 238         call escp_soft_sphere(evdw2,evdw2_14)
 239       endif
 240 c
 241 c Calculate the bond-stretching energy
 242 c
 243       call ebond(estr)
 244 C
 245 C Calculate the disulfide-bridge and other energy and the contributions
 246 C from other distance constraints.
 247 cd      write (iout,*) 'Calling EHPB'
 248       call edis(ehpb)
 249 cd    print *,'EHPB exitted succesfully.'
 250 C
 251 C Calculate the virtual-bond-angle energy.
 252 C
 253       if (wang.gt.0d0) then
 254        if (tor_mode.eq.0) then
 255          call ebend(ebe)
 256        else
 257 C ebend kcc is Kubo cumulant clustered rigorous attemp to derive the
 258 C energy function
 259          call ebend_kcc(ebe)
 260        endif
 261       else
 262         ebe=0.0d0
 263       endif
 264       ethetacnstr=0.0d0
 265       if (with_theta_constr) call etheta_constr(ethetacnstr)
 266 c      print *,"Processor",myrank," computed UB"
 267 C
 268 C Calculate the SC local energy.
 269 C
 270 C      print *,"TU DOCHODZE?"
 271       call esc(escloc)
 272 c      print *,"Processor",myrank," computed USC"
 273 C
 274 C Calculate the virtual-bond torsional energy.
 275 C
 276 cd    print *,'nterm=',nterm
 277 C      print *,"tor",tor_mode
 278       if (wtor.gt.0.0d0) then
 279          if (tor_mode.eq.0) then
 280            call etor(etors)
 281          else
 282 C etor kcc is Kubo cumulant clustered rigorous attemp to derive the
 283 C energy function
 284            call etor_kcc(etors)
 285          endif
 286       else
 287         etors=0.0d0
 288       endif
 289       edihcnstr=0.0d0
 290       if (ndih_constr.gt.0) call etor_constr(edihcnstr)
 291 c      print *,"Processor",myrank," computed Utor"
 292       if (constr_homology.ge.1) then
 293         call e_modeller(ehomology_constr)
 294 c        print *,'iset=',iset,'me=',me,ehomology_constr,
 295 c     &  'Processor',fg_rank,' CG group',kolor,
 296 c     &  ' absolute rank',MyRank
 297       else
 298         ehomology_constr=0.0d0
 299       endif
 300 C
 301 C 6/23/01 Calculate double-torsional energy
 302 C
 303       if ((wtor_d.gt.0.0d0).and.(tor_mode.eq.0)) then
 304         call etor_d(etors_d)
 305       else
 306         etors_d=0
 307       endif
 308 c      print *,"Processor",myrank," computed Utord"
 309 C
 310 C 21/5/07 Calculate local sicdechain correlation energy
 311 C
 312       if (wsccor.gt.0.0d0) then
 313         call eback_sc_corr(esccor)
 314       else
 315         esccor=0.0d0
 316       endif
 317 C      print *,"PRZED MULIt"
 318 c      print *,"Processor",myrank," computed Usccorr"
 319 C
 320 C 12/1/95 Multi-body terms
 321 C
 322       n_corr=0
 323       n_corr1=0
 324       if ((wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0
 325      &    .or. wturn6.gt.0.0d0) .and. ipot.lt.6) then
 326          call multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1)
 327 c         write(2,*)'MULTIBODY_EELLO n_corr=',n_corr,' n_corr1=',n_corr1,
 328 c     &" ecorr",ecorr," ecorr5",ecorr5," ecorr6",ecorr6," eturn6",eturn6
 329 c        call flush(iout)
 330       else
 331          ecorr=0.0d0
 332          ecorr5=0.0d0
 333          ecorr6=0.0d0
 334          eturn6=0.0d0
 335       endif
 336       if ((wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) .and. ipot.lt.6) then
 337 c         write (iout,*) "Before MULTIBODY_HB ecorr",ecorr,ecorr5,ecorr6,
 338 c     &     n_corr,n_corr1
 339 c         call flush(iout)
 340          call multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
 341 c         write (iout,*) "MULTIBODY_HB ecorr",ecorr,ecorr5,ecorr6,n_corr,
 342 c     &     n_corr1
 343 c         call flush(iout)
 344       endif
 345 c      print *,"Processor",myrank," computed Ucorr"
 346 c      write (iout,*) "nsaxs",nsaxs," saxs_mode",saxs_mode
 347       if (nsaxs.gt.0 .and. saxs_mode.eq.0) then
 348         call e_saxs(Esaxs_constr)
 349 c        write (iout,*) "From Esaxs: Esaxs_constr",Esaxs_constr
 350       else if (nsaxs.gt.0 .and. saxs_mode.gt.0) then
 351         call e_saxsC(Esaxs_constr)
 352 c        write (iout,*) "From EsaxsC: Esaxs_constr",Esaxs_constr
 353       else
 354         Esaxs_constr = 0.0d0
 355       endif
 356 C
 357 C If performing constraint dynamics, call the constraint energy
 358 C  after the equilibration time
 359 c      if(usampl.and.totT.gt.eq_time) then
 360 c      write (iout,*) "usampl",usampl
 361       if(usampl) then
 362          call EconstrQ
 363          if (loc_qlike) then
 364            call Econstr_back_qlike
 365          else
 366            call Econstr_back
 367          endif
 368       else
 369          Uconst=0.0d0
 370          Uconst_back=0.0d0
 371       endif
 372 C 01/27/2015 added by adasko
 373 C the energy component below is energy transfer into lipid environment
 374 C based on partition function
 375 C      print *,"przed lipidami"
 376       if (wliptran.gt.0) then
 377         call Eliptransfer(eliptran)
 378       endif
 379 C      print *,"za lipidami"
 380       if (AFMlog.gt.0) then
 381         call AFMforce(Eafmforce)
 382       else if (selfguide.gt.0) then
 383         call AFMvel(Eafmforce)
 384       endif
 385       if (TUBElog.eq.1) then
 386 C      print *,"just before call"
 387         call calctube(Etube)
 388        elseif (TUBElog.eq.2) then
 389         call calctube2(Etube)
 390        else
 391        Etube=0.0d0
 392        endif
 393
 394 #ifdef TIMING
 395       time_enecalc=time_enecalc+MPI_Wtime()-time00
 396 #endif
 397 c      print *,"Processor",myrank," computed Uconstr"
 398 #ifdef TIMING
 399       time00=MPI_Wtime()
 400 #endif
 401 c
 402 C Sum the energies
 403 C
 404       energia(1)=evdw
 405 #ifdef SCP14
 406       energia(2)=evdw2-evdw2_14
 407       energia(18)=evdw2_14
 408 #else
 409       energia(2)=evdw2
 410       energia(18)=0.0d0
 411 #endif
 412 #ifdef SPLITELE
 413       energia(3)=ees
 414       energia(16)=evdw1
 415 #else
 416       energia(3)=ees+evdw1
 417       energia(16)=0.0d0
 418 #endif
 419       energia(4)=ecorr
 420       energia(5)=ecorr5
 421       energia(6)=ecorr6
 422       energia(7)=eel_loc
 423       energia(8)=eello_turn3
 424       energia(9)=eello_turn4
 425       energia(10)=eturn6
 426       energia(11)=ebe
 427       energia(12)=escloc
 428       energia(13)=etors
 429       energia(14)=etors_d
 430       energia(15)=ehpb
 431       energia(19)=edihcnstr
 432       energia(17)=estr
 433       energia(20)=Uconst+Uconst_back
 434       energia(21)=esccor
 435       energia(22)=eliptran
 436       energia(23)=Eafmforce
 437       energia(24)=ethetacnstr
 438       energia(25)=Etube
 439       energia(26)=Esaxs_constr
 440       energia(27)=ehomology_constr
 441       energia(28)=edfadis
 442       energia(29)=edfator
 443       energia(30)=edfanei
 444       energia(31)=edfabet
 445 c      write (iout,*) "esaxs_constr",energia(26)
 446 c    Here are the energies showed per procesor if the are more processors
 447 c    per molecule then we sum it up in sum_energy subroutine
 448 c      print *," Processor",myrank," calls SUM_ENERGY"
 449       call sum_energy(energia,.true.)
 450 c      write (iout,*) "After sum_energy: esaxs_constr",energia(26)
 451       if (dyn_ss) call dyn_set_nss
 452 c      print *," Processor",myrank," left SUM_ENERGY"
 453 #ifdef TIMING
 454       time_sumene=time_sumene+MPI_Wtime()-time00
 455 #endif
 456       return
 457       end
 458 c-------------------------------------------------------------------------------
 459       subroutine sum_energy(energia,reduce)
 460       implicit real*8 (a-h,o-z)
 461       include 'DIMENSIONS'
 462 #ifndef ISNAN
 463       external proc_proc
 464 #ifdef WINPGI
 465 cMS$ATTRIBUTES C ::  proc_proc
 466 #endif
 467 #endif
 468 #ifdef MPI
 469       include "mpif.h"
 470 #endif
 471       include 'COMMON.SETUP'
 472       include 'COMMON.IOUNITS'
 473       double precision energia(0:n_ene),enebuff(0:n_ene+1)
 474       include 'COMMON.FFIELD'
 475       include 'COMMON.DERIV'
 476       include 'COMMON.INTERACT'
 477       include 'COMMON.SBRIDGE'
 478       include 'COMMON.CHAIN'
 479       include 'COMMON.VAR'
 480       include 'COMMON.CONTROL'
 481       include 'COMMON.TIME1'
 482       logical reduce
 483 #ifdef MPI
 484       if (nfgtasks.gt.1 .and. reduce) then
 485 #ifdef DEBUG
 486         write (iout,*) "energies before REDUCE"
 487         call enerprint(energia)
 488         call flush(iout)
 489 #endif
 490         do i=0,n_ene
 491           enebuff(i)=energia(i)
 492         enddo
 493         time00=MPI_Wtime()
 494         call MPI_Barrier(FG_COMM,IERR)
 495         time_barrier_e=time_barrier_e+MPI_Wtime()-time00
 496         time00=MPI_Wtime()
 497         call MPI_Reduce(enebuff(0),energia(0),n_ene+1,
 498      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 499 #ifdef DEBUG
 500         write (iout,*) "energies after REDUCE"
 501         call enerprint(energia)
 502         call flush(iout)
 503 #endif
 504         time_Reduce=time_Reduce+MPI_Wtime()-time00
 505       endif
 506       if (fg_rank.eq.0) then
 507 #endif
 508       evdw=energia(1)
 509 #ifdef SCP14
 510       evdw2=energia(2)+energia(18)
 511       evdw2_14=energia(18)
 512 #else
 513       evdw2=energia(2)
 514 #endif
 515 #ifdef SPLITELE
 516       ees=energia(3)
 517       evdw1=energia(16)
 518 #else
 519       ees=energia(3)
 520       evdw1=0.0d0
 521 #endif
 522       ecorr=energia(4)
 523       ecorr5=energia(5)
 524       ecorr6=energia(6)
 525       eel_loc=energia(7)
 526       eello_turn3=energia(8)
 527       eello_turn4=energia(9)
 528       eturn6=energia(10)
 529       ebe=energia(11)
 530       escloc=energia(12)
 531       etors=energia(13)
 532       etors_d=energia(14)
 533       ehpb=energia(15)
 534       edihcnstr=energia(19)
 535       estr=energia(17)
 536       Uconst=energia(20)
 537       esccor=energia(21)
 538       eliptran=energia(22)
 539       Eafmforce=energia(23)
 540       ethetacnstr=energia(24)
 541       Etube=energia(25)
 542       esaxs_constr=energia(26)
 543       ehomology_constr=energia(27)
 544       edfadis=energia(28)
 545       edfator=energia(29)
 546       edfanei=energia(30)
 547       edfabet=energia(31)
 548 #ifdef SPLITELE
 549       etot=wsc*evdw+wscp*evdw2+welec*ees+wvdwpp*evdw1
 550      & +wang*ebe+wtor*etors+wscloc*escloc
 551      & +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5
 552      & +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3
 553      & +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d
 554      & +wbond*estr+wumb*Uconst+wsccor*esccor+wliptran*eliptran+Eafmforce
 555      & +ethetacnstr+wtube*Etube+wsaxs*esaxs_constr+ehomology_constr
 556      & +wdfa_dist*edfadis+wdfa_tor*edfator+wdfa_nei*edfanei
 557      & +wdfa_beta*edfabet
 558 #else
 559       etot=wsc*evdw+wscp*evdw2+welec*(ees+evdw1)
 560      & +wang*ebe+wtor*etors+wscloc*escloc
 561      & +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5
 562      & +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3
 563      & +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d
 564      & +wbond*estr+wumb*Uconst+wsccor*esccor+wliptran*eliptran
 565      & +Eafmforce
 566      & +ethetacnstr+wtube*Etube+wsaxs*esaxs_constr+ehomology_constr
 567      & +wdfa_dist*edfadis+wdfa_tor*edfator+wdfa_nei*edfanei
 568      & +wdfa_beta*edfabet
 569 #endif
 570       energia(0)=etot
 571 c detecting NaNQ
 572 #ifdef ISNAN
 573 #ifdef AIX
 574       if (isnan(etot).ne.0) energia(0)=1.0d+99
 575 #else
 576       if (isnan(etot)) energia(0)=1.0d+99
 577 #endif
 578 #else
 579       i=0
 580 #ifdef WINPGI
 581       idumm=proc_proc(etot,i)
 582 #else
 583       call proc_proc(etot,i)
 584 #endif
 585       if(i.eq.1)energia(0)=1.0d+99
 586 #endif
 587 #ifdef MPI
 588       endif
 589 #endif
 590       return
 591       end
 592 c-------------------------------------------------------------------------------
 593       subroutine sum_gradient
 594       implicit real*8 (a-h,o-z)
 595       include 'DIMENSIONS'
 596 #ifndef ISNAN
 597       external proc_proc
 598 #ifdef WINPGI
 599 cMS$ATTRIBUTES C ::  proc_proc
 600 #endif
 601 #endif
 602 #ifdef MPI
 603       include 'mpif.h'
 604 #endif
 605       double precision gradbufc(3,-1:maxres),gradbufx(3,-1:maxres),
 606      & glocbuf(4*maxres),gradbufc_sum(3,-1:maxres)
 607      & ,gloc_scbuf(3,-1:maxres)
 608       include 'COMMON.SETUP'
 609       include 'COMMON.IOUNITS'
 610       include 'COMMON.FFIELD'
 611       include 'COMMON.DERIV'
 612       include 'COMMON.INTERACT'
 613       include 'COMMON.SBRIDGE'
 614       include 'COMMON.CHAIN'
 615       include 'COMMON.VAR'
 616       include 'COMMON.CONTROL'
 617       include 'COMMON.TIME1'
 618       include 'COMMON.MAXGRAD'
 619       include 'COMMON.SCCOR'
 620       include 'COMMON.MD'
 621 #ifdef TIMING
 622       time01=MPI_Wtime()
 623 #endif
 624 #ifdef DEBUG
 625       write (iout,*) "sum_gradient gvdwc, gvdwx"
 626       do i=1,nres
 627         write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)')
 628      &   i,(gvdwx(j,i),j=1,3),(gvdwc(j,i),j=1,3)
 629       enddo
 630       call flush(iout)
 631 #endif
 632 #ifdef DEBUG
 633       write (iout,*) "sum_gradient gsaxsc, gsaxsx"
 634       do i=0,nres
 635         write (iout,'(i3,3e15.5,5x,3e15.5)')
 636      &   i,(gsaxsc(j,i),j=1,3),(gsaxsx(j,i),j=1,3)
 637       enddo
 638       call flush(iout)
 639 #endif
 640 #ifdef MPI
 641 C FG slaves call the following matching MPI_Bcast in ERGASTULUM
 642         if (nfgtasks.gt.1 .and. fg_rank.eq.0)
 643      &    call MPI_Bcast(1,1,MPI_INTEGER,king,FG_COMM,IERROR)
 644 #endif
 645 C
 646 C 9/29/08 AL Transform parts of gradients in site coordinates to the gradient
 647 C            in virtual-bond-vector coordinates
 648 C
 649 #ifdef DEBUG
 650 c      write (iout,*) "gel_loc gel_loc_long and gel_loc_loc"
 651 c      do i=1,nres-1
 652 c        write (iout,'(i5,3f10.5,2x,3f10.5,2x,f10.5)')
 653 c     &   i,(gel_loc(j,i),j=1,3),(gel_loc_long(j,i),j=1,3),gel_loc_loc(i)
 654 c      enddo
 655 c      write (iout,*) "gel_loc_tur3 gel_loc_turn4"
 656 c      do i=1,nres-1
 657 c        write (iout,'(i5,3f10.5,2x,f10.5)')
 658 c     &  i,(gcorr4_turn(j,i),j=1,3),gel_loc_turn4(i)
 659 c      enddo
 660       write (iout,*) "gradcorr5 gradcorr5_long gradcorr5_loc"
 661       do i=1,nres
 662         write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)')
 663      &   i,(gradcorr5(j,i),j=1,3),(gradcorr5_long(j,i),j=1,3),
 664      &   g_corr5_loc(i)
 665       enddo
 666       call flush(iout)
 667 #endif
 668 #ifdef DEBUG
 669       write (iout,*) "gsaxsc"
 670       do i=1,nres
 671         write (iout,'(i3,3f10.5)') i,(wsaxs*gsaxsc(j,i),j=1,3)
 672       enddo
 673       call flush(iout)
 674 #endif
 675 #ifdef SPLITELE
 676       do i=0,nct
 677         do j=1,3
 678           gradbufc(j,i)=wsc*gvdwc(j,i)+
 679      &                wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+
 680      &                welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+
 681      &                wel_loc*gel_loc_long(j,i)+
 682      &                wcorr*gradcorr_long(j,i)+
 683      &                wcorr5*gradcorr5_long(j,i)+
 684      &                wcorr6*gradcorr6_long(j,i)+
 685      &                wturn6*gcorr6_turn_long(j,i)+
 686      &                wstrain*ghpbc(j,i)
 687      &                +wliptran*gliptranc(j,i)
 688      &                +gradafm(j,i)
 689      &                +welec*gshieldc(j,i)
 690      &                +wcorr*gshieldc_ec(j,i)
 691      &                +wturn3*gshieldc_t3(j,i)
 692      &                +wturn4*gshieldc_t4(j,i)
 693      &                +wel_loc*gshieldc_ll(j,i)
 694      &                +wtube*gg_tube(j,i)
 695      &                +wsaxs*gsaxsc(j,i)
 696         enddo
 697       enddo
 698 #else
 699       do i=0,nct
 700         do j=1,3
 701           gradbufc(j,i)=wsc*gvdwc(j,i)+
 702      &                wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+
 703      &                welec*gelc_long(j,i)+
 704      &                wbond*gradb(j,i)+
 705      &                wel_loc*gel_loc_long(j,i)+
 706      &                wcorr*gradcorr_long(j,i)+
 707      &                wcorr5*gradcorr5_long(j,i)+
 708      &                wcorr6*gradcorr6_long(j,i)+
 709      &                wturn6*gcorr6_turn_long(j,i)+
 710      &                wstrain*ghpbc(j,i)
 711      &                +wliptran*gliptranc(j,i)
 712      &                +gradafm(j,i)
 713      &                 +welec*gshieldc(j,i)
 714      &                 +wcorr*gshieldc_ec(j,i)
 715      &                 +wturn4*gshieldc_t4(j,i)
 716      &                 +wel_loc*gshieldc_ll(j,i)
 717      &                +wtube*gg_tube(j,i)
 718      &                +wsaxs*gsaxsc(j,i)
 719         enddo
 720       enddo
 721 #endif
 722       do i=1,nct
 723         do j=1,3
 724           gradbufc(j,i)=gradbufc(j,i)+
 725      &                wdfa_dist*gdfad(j,i)+
 726      &                wdfa_tor*gdfat(j,i)+
 727      &                wdfa_nei*gdfan(j,i)+
 728      &                wdfa_beta*gdfab(j,i)
 729         enddo
 730       enddo
 731 #ifdef DEBUG
 732       write (iout,*) "gradc from gradbufc"
 733       do i=1,nres
 734         write (iout,'(i3,3f10.5)') i,(gradc(j,i,icg),j=1,3)
 735       enddo
 736       call flush(iout)
 737 #endif
 738 #ifdef MPI
 739       if (nfgtasks.gt.1) then
 740       time00=MPI_Wtime()
 741 #ifdef DEBUG
 742       write (iout,*) "gradbufc before allreduce"
 743       do i=1,nres
 744         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 745       enddo
 746       call flush(iout)
 747 #endif
 748       do i=0,nres
 749         do j=1,3
 750           gradbufc_sum(j,i)=gradbufc(j,i)
 751         enddo
 752       enddo
 753 c      call MPI_AllReduce(gradbufc(1,1),gradbufc_sum(1,1),3*nres,
 754 c     &    MPI_DOUBLE_PRECISION,MPI_SUM,FG_COMM,IERR)
 755 c      time_reduce=time_reduce+MPI_Wtime()-time00
 756 #ifdef DEBUG
 757 c      write (iout,*) "gradbufc_sum after allreduce"
 758 c      do i=1,nres
 759 c        write (iout,'(i3,3f10.5)') i,(gradbufc_sum(j,i),j=1,3)
 760 c      enddo
 761 c      call flush(iout)
 762 #endif
 763 #ifdef TIMING
 764 c      time_allreduce=time_allreduce+MPI_Wtime()-time00
 765 #endif
 766       do i=nnt,nres
 767         do k=1,3
 768           gradbufc(k,i)=0.0d0
 769         enddo
 770       enddo
 771 #ifdef DEBUG
 772       write (iout,*) "igrad_start",igrad_start," igrad_end",igrad_end
 773       write (iout,*) (i," jgrad_start",jgrad_start(i),
 774      &                  " jgrad_end  ",jgrad_end(i),
 775      &                  i=igrad_start,igrad_end)
 776 #endif
 777 c
 778 c Obsolete and inefficient code; we can make the effort O(n) and, therefore,
 779 c do not parallelize this part.
 780 c
 781 c      do i=igrad_start,igrad_end
 782 c        do j=jgrad_start(i),jgrad_end(i)
 783 c          do k=1,3
 784 c            gradbufc(k,i)=gradbufc(k,i)+gradbufc_sum(k,j)
 785 c          enddo
 786 c        enddo
 787 c      enddo
 788       do j=1,3
 789         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
 790       enddo
 791       do i=nres-2,-1,-1
 792         do j=1,3
 793           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
 794         enddo
 795       enddo
 796 #ifdef DEBUG
 797       write (iout,*) "gradbufc after summing"
 798       do i=1,nres
 799         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 800       enddo
 801       call flush(iout)
 802 #endif
 803       else
 804 #endif
 805 #ifdef DEBUG
 806       write (iout,*) "gradbufc"
 807       do i=1,nres
 808         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 809       enddo
 810       call flush(iout)
 811 #endif
 812       do i=-1,nres
 813         do j=1,3
 814           gradbufc_sum(j,i)=gradbufc(j,i)
 815           gradbufc(j,i)=0.0d0
 816         enddo
 817       enddo
 818       do j=1,3
 819         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
 820       enddo
 821       do i=nres-2,-1,-1
 822         do j=1,3
 823           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
 824         enddo
 825       enddo
 826 c      do i=nnt,nres-1
 827 c        do k=1,3
 828 c          gradbufc(k,i)=0.0d0
 829 c        enddo
 830 c        do j=i+1,nres
 831 c          do k=1,3
 832 c            gradbufc(k,i)=gradbufc(k,i)+gradbufc(k,j)
 833 c          enddo
 834 c        enddo
 835 c      enddo
 836 #ifdef DEBUG
 837       write (iout,*) "gradbufc after summing"
 838       do i=1,nres
 839         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 840       enddo
 841       call flush(iout)
 842 #endif
 843 #ifdef MPI
 844       endif
 845 #endif
 846       do k=1,3
 847         gradbufc(k,nres)=0.0d0
 848       enddo
 849       do i=-1,nct
 850         do j=1,3
 851 #ifdef SPLITELE
 852 C          print *,gradbufc(1,13)
 853 C          print *,welec*gelc(1,13)
 854 C          print *,wel_loc*gel_loc(1,13)
 855 C          print *,0.5d0*(wscp*gvdwc_scpp(1,13))
 856 C          print *,welec*gelc_long(1,13)+wvdwpp*gvdwpp(1,13)
 857 C          print *,wel_loc*gel_loc_long(1,13)
 858 C          print *,gradafm(1,13),"AFM"
 859           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+
 860      &                wel_loc*gel_loc(j,i)+
 861      &                0.5d0*(wscp*gvdwc_scpp(j,i)+
 862      &                welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+
 863      &                wel_loc*gel_loc_long(j,i)+
 864      &                wcorr*gradcorr_long(j,i)+
 865      &                wcorr5*gradcorr5_long(j,i)+
 866      &                wcorr6*gradcorr6_long(j,i)+
 867      &                wturn6*gcorr6_turn_long(j,i))+
 868      &                wbond*gradb(j,i)+
 869      &                wcorr*gradcorr(j,i)+
 870      &                wturn3*gcorr3_turn(j,i)+
 871      &                wturn4*gcorr4_turn(j,i)+
 872      &                wcorr5*gradcorr5(j,i)+
 873      &                wcorr6*gradcorr6(j,i)+
 874      &                wturn6*gcorr6_turn(j,i)+
 875      &                wsccor*gsccorc(j,i)
 876      &               +wscloc*gscloc(j,i)
 877      &               +wliptran*gliptranc(j,i)
 878      &                +gradafm(j,i)
 879      &                 +welec*gshieldc(j,i)
 880      &                 +welec*gshieldc_loc(j,i)
 881      &                 +wcorr*gshieldc_ec(j,i)
 882      &                 +wcorr*gshieldc_loc_ec(j,i)
 883      &                 +wturn3*gshieldc_t3(j,i)
 884      &                 +wturn3*gshieldc_loc_t3(j,i)
 885      &                 +wturn4*gshieldc_t4(j,i)
 886      &                 +wturn4*gshieldc_loc_t4(j,i)
 887      &                 +wel_loc*gshieldc_ll(j,i)
 888      &                 +wel_loc*gshieldc_loc_ll(j,i)
 889      &                +wtube*gg_tube(j,i)
 890
 891 #else
 892           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+
 893      &                wel_loc*gel_loc(j,i)+
 894      &                0.5d0*(wscp*gvdwc_scpp(j,i)+
 895      &                welec*gelc_long(j,i)+
 896      &                wel_loc*gel_loc_long(j,i)+
 897      &                wcorr*gcorr_long(j,i)+
 898      &                wcorr5*gradcorr5_long(j,i)+
 899      &                wcorr6*gradcorr6_long(j,i)+
 900      &                wturn6*gcorr6_turn_long(j,i))+
 901      &                wbond*gradb(j,i)+
 902      &                wcorr*gradcorr(j,i)+
 903      &                wturn3*gcorr3_turn(j,i)+
 904      &                wturn4*gcorr4_turn(j,i)+
 905      &                wcorr5*gradcorr5(j,i)+
 906      &                wcorr6*gradcorr6(j,i)+
 907      &                wturn6*gcorr6_turn(j,i)+
 908      &                wsccor*gsccorc(j,i)
 909      &               +wscloc*gscloc(j,i)
 910      &               +wliptran*gliptranc(j,i)
 911      &                +gradafm(j,i)
 912      &                 +welec*gshieldc(j,i)
 913      &                 +welec*gshieldc_loc(j,i)
 914      &                 +wcorr*gshieldc_ec(j,i)
 915      &                 +wcorr*gshieldc_loc_ec(j,i)
 916      &                 +wturn3*gshieldc_t3(j,i)
 917      &                 +wturn3*gshieldc_loc_t3(j,i)
 918      &                 +wturn4*gshieldc_t4(j,i)
 919      &                 +wturn4*gshieldc_loc_t4(j,i)
 920      &                 +wel_loc*gshieldc_ll(j,i)
 921      &                 +wel_loc*gshieldc_loc_ll(j,i)
 922      &                +wtube*gg_tube(j,i)
 923
 924
 925 #endif
 926           gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+
 927      &                  wbond*gradbx(j,i)+
 928      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
 929      &                  wsccor*gsccorx(j,i)
 930      &                 +wscloc*gsclocx(j,i)
 931      &                 +wliptran*gliptranx(j,i)
 932      &                 +welec*gshieldx(j,i)
 933      &                 +wcorr*gshieldx_ec(j,i)
 934      &                 +wturn3*gshieldx_t3(j,i)
 935      &                 +wturn4*gshieldx_t4(j,i)
 936      &                 +wel_loc*gshieldx_ll(j,i)
 937      &                 +wtube*gg_tube_sc(j,i)
 938      &                 +wsaxs*gsaxsx(j,i)
 939
 940
 941
 942         enddo
 943       enddo
 944       if (constr_homology.gt.0) then
 945         do i=1,nct
 946           do j=1,3
 947             gradc(j,i,icg)=gradc(j,i,icg)+duscdiff(j,i)
 948             gradx(j,i,icg)=gradx(j,i,icg)+duscdiffx(j,i)
 949           enddo
 950         enddo
 951       endif
 952 #ifdef DEBUG
 953       write (iout,*) "gradc gradx gloc after adding"
 954       do i=1,nres
 955         write (iout,'(i5,3f10.5,5x,3f10.5,5x,f10.5)')
 956      &   i,(gradc(j,i,icg),j=1,3),(gradx(j,i,icg),j=1,3),gloc(i,icg)
 957       enddo
 958 #endif
 959 #ifdef DEBUG
 960       write (iout,*) "gloc before adding corr"
 961       do i=1,4*nres
 962         write (iout,*) i,gloc(i,icg)
 963       enddo
 964 #endif
 965       do i=1,nres-3
 966         gloc(i,icg)=gloc(i,icg)+wcorr*gcorr_loc(i)
 967      &   +wcorr5*g_corr5_loc(i)
 968      &   +wcorr6*g_corr6_loc(i)
 969      &   +wturn4*gel_loc_turn4(i)
 970      &   +wturn3*gel_loc_turn3(i)
 971      &   +wturn6*gel_loc_turn6(i)
 972      &   +wel_loc*gel_loc_loc(i)
 973       enddo
 974 #ifdef DEBUG
 975       write (iout,*) "gloc after adding corr"
 976       do i=1,4*nres
 977         write (iout,*) i,gloc(i,icg)
 978       enddo
 979 #endif
 980 #ifdef MPI
 981       if (nfgtasks.gt.1) then
 982         do j=1,3
 983           do i=1,nres
 984             gradbufc(j,i)=gradc(j,i,icg)
 985             gradbufx(j,i)=gradx(j,i,icg)
 986           enddo
 987         enddo
 988         do i=1,4*nres
 989           glocbuf(i)=gloc(i,icg)
 990         enddo
 991 c#define DEBUG
 992 #ifdef DEBUG
 993       write (iout,*) "gloc_sc before reduce"
 994       do i=1,nres
 995        do j=1,1
 996         write (iout,*) i,j,gloc_sc(j,i,icg)
 997        enddo
 998       enddo
 999 #endif
1000 c#undef DEBUG
1001         do i=1,nres
1002          do j=1,3
1003           gloc_scbuf(j,i)=gloc_sc(j,i,icg)
1004          enddo
1005         enddo
1006         time00=MPI_Wtime()
1007         call MPI_Barrier(FG_COMM,IERR)
1008         time_barrier_g=time_barrier_g+MPI_Wtime()-time00
1009         time00=MPI_Wtime()
1010         call MPI_Reduce(gradbufc(1,1),gradc(1,1,icg),3*nres,
1011      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
1012         call MPI_Reduce(gradbufx(1,1),gradx(1,1,icg),3*nres,
1013      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
1014         call MPI_Reduce(glocbuf(1),gloc(1,icg),4*nres,
1015      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
1016         time_reduce=time_reduce+MPI_Wtime()-time00
1017         call MPI_Reduce(gloc_scbuf(1,1),gloc_sc(1,1,icg),3*nres,
1018      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
1019         time_reduce=time_reduce+MPI_Wtime()-time00
1020 #ifdef DEBUG
1021       write (iout,*) "gradc after reduce"
1022       do i=1,nres
1023        do j=1,3
1024         write (iout,*) i,j,gradc(j,i,icg)
1025        enddo
1026       enddo
1027 #endif
1028 #ifdef DEBUG
1029       write (iout,*) "gloc_sc after reduce"
1030       do i=1,nres
1031        do j=1,1
1032         write (iout,*) i,j,gloc_sc(j,i,icg)
1033        enddo
1034       enddo
1035 #endif
1036 #ifdef DEBUG
1037       write (iout,*) "gloc after reduce"
1038       do i=1,4*nres
1039         write (iout,*) i,gloc(i,icg)
1040       enddo
1041 #endif
1042       endif
1043 #endif
1044       if (gnorm_check) then
1045 c
1046 c Compute the maximum elements of the gradient
1047 c
1048       gvdwc_max=0.0d0
1049       gvdwc_scp_max=0.0d0
1050       gelc_max=0.0d0
1051       gvdwpp_max=0.0d0
1052       gradb_max=0.0d0
1053       ghpbc_max=0.0d0
1054       gradcorr_max=0.0d0
1055       gel_loc_max=0.0d0
1056       gcorr3_turn_max=0.0d0
1057       gcorr4_turn_max=0.0d0
1058       gradcorr5_max=0.0d0
1059       gradcorr6_max=0.0d0
1060       gcorr6_turn_max=0.0d0
1061       gsccorc_max=0.0d0
1062       gscloc_max=0.0d0
1063       gvdwx_max=0.0d0
1064       gradx_scp_max=0.0d0
1065       ghpbx_max=0.0d0
1066       gradxorr_max=0.0d0
1067       gsccorx_max=0.0d0
1068       gsclocx_max=0.0d0
1069       do i=1,nct
1070         gvdwc_norm=dsqrt(scalar(gvdwc(1,i),gvdwc(1,i)))
1071         if (gvdwc_norm.gt.gvdwc_max) gvdwc_max=gvdwc_norm
1072         gvdwc_scp_norm=dsqrt(scalar(gvdwc_scp(1,i),gvdwc_scp(1,i)))
1073         if (gvdwc_scp_norm.gt.gvdwc_scp_max)
1074      &   gvdwc_scp_max=gvdwc_scp_norm
1075         gelc_norm=dsqrt(scalar(gelc(1,i),gelc(1,i)))
1076         if (gelc_norm.gt.gelc_max) gelc_max=gelc_norm
1077         gvdwpp_norm=dsqrt(scalar(gvdwpp(1,i),gvdwpp(1,i)))
1078         if (gvdwpp_norm.gt.gvdwpp_max) gvdwpp_max=gvdwpp_norm
1079         gradb_norm=dsqrt(scalar(gradb(1,i),gradb(1,i)))
1080         if (gradb_norm.gt.gradb_max) gradb_max=gradb_norm
1081         ghpbc_norm=dsqrt(scalar(ghpbc(1,i),ghpbc(1,i)))
1082         if (ghpbc_norm.gt.ghpbc_max) ghpbc_max=ghpbc_norm
1083         gradcorr_norm=dsqrt(scalar(gradcorr(1,i),gradcorr(1,i)))
1084         if (gradcorr_norm.gt.gradcorr_max) gradcorr_max=gradcorr_norm
1085         gel_loc_norm=dsqrt(scalar(gel_loc(1,i),gel_loc(1,i)))
1086         if (gel_loc_norm.gt.gel_loc_max) gel_loc_max=gel_loc_norm
1087         gcorr3_turn_norm=dsqrt(scalar(gcorr3_turn(1,i),
1088      &    gcorr3_turn(1,i)))
1089         if (gcorr3_turn_norm.gt.gcorr3_turn_max)
1090      &    gcorr3_turn_max=gcorr3_turn_norm
1091         gcorr4_turn_norm=dsqrt(scalar(gcorr4_turn(1,i),
1092      &    gcorr4_turn(1,i)))
1093         if (gcorr4_turn_norm.gt.gcorr4_turn_max)
1094      &    gcorr4_turn_max=gcorr4_turn_norm
1095         gradcorr5_norm=dsqrt(scalar(gradcorr5(1,i),gradcorr5(1,i)))
1096         if (gradcorr5_norm.gt.gradcorr5_max)
1097      &    gradcorr5_max=gradcorr5_norm
1098         gradcorr6_norm=dsqrt(scalar(gradcorr6(1,i),gradcorr6(1,i)))
1099         if (gradcorr6_norm.gt.gradcorr6_max) gcorr6_max=gradcorr6_norm
1100         gcorr6_turn_norm=dsqrt(scalar(gcorr6_turn(1,i),
1101      &    gcorr6_turn(1,i)))
1102         if (gcorr6_turn_norm.gt.gcorr6_turn_max)
1103      &    gcorr6_turn_max=gcorr6_turn_norm
1104         gsccorr_norm=dsqrt(scalar(gsccorc(1,i),gsccorc(1,i)))
1105         if (gsccorr_norm.gt.gsccorr_max) gsccorr_max=gsccorr_norm
1106         gscloc_norm=dsqrt(scalar(gscloc(1,i),gscloc(1,i)))
1107         if (gscloc_norm.gt.gscloc_max) gscloc_max=gscloc_norm
1108         gvdwx_norm=dsqrt(scalar(gvdwx(1,i),gvdwx(1,i)))
1109         if (gvdwx_norm.gt.gvdwx_max) gvdwx_max=gvdwx_norm
1110         gradx_scp_norm=dsqrt(scalar(gradx_scp(1,i),gradx_scp(1,i)))
1111         if (gradx_scp_norm.gt.gradx_scp_max)
1112      &    gradx_scp_max=gradx_scp_norm
1113         ghpbx_norm=dsqrt(scalar(ghpbx(1,i),ghpbx(1,i)))
1114         if (ghpbx_norm.gt.ghpbx_max) ghpbx_max=ghpbx_norm
1115         gradxorr_norm=dsqrt(scalar(gradxorr(1,i),gradxorr(1,i)))
1116         if (gradxorr_norm.gt.gradxorr_max) gradxorr_max=gradxorr_norm
1117         gsccorrx_norm=dsqrt(scalar(gsccorx(1,i),gsccorx(1,i)))
1118         if (gsccorrx_norm.gt.gsccorrx_max) gsccorrx_max=gsccorrx_norm
1119         gsclocx_norm=dsqrt(scalar(gsclocx(1,i),gsclocx(1,i)))
1120         if (gsclocx_norm.gt.gsclocx_max) gsclocx_max=gsclocx_norm
1121       enddo
1122       if (gradout) then
1123 #if (defined AIX || defined CRAY)
1124         open(istat,file=statname,position="append")
1125 #else
1126         open(istat,file=statname,access="append")
1127 #endif
1128         write (istat,'(1h#,21f10.2)') gvdwc_max,gvdwc_scp_max,
1129      &     gelc_max,gvdwpp_max,gradb_max,ghpbc_max,
1130      &     gradcorr_max,gel_loc_max,gcorr3_turn_max,gcorr4_turn_max,
1131      &     gradcorr5_max,gradcorr6_max,gcorr6_turn_max,gsccorc_max,
1132      &     gscloc_max,gvdwx_max,gradx_scp_max,ghpbx_max,gradxorr_max,
1133      &     gsccorx_max,gsclocx_max
1134         close(istat)
1135         if (gvdwc_max.gt.1.0d4) then
1136           write (iout,*) "gvdwc gvdwx gradb gradbx"
1137           do i=nnt,nct
1138             write(iout,'(i5,4(3f10.2,5x))') i,(gvdwc(j,i),gvdwx(j,i),
1139      &        gradb(j,i),gradbx(j,i),j=1,3)
1140           enddo
1141           call pdbout(0.0d0,'cipiszcze',iout)
1142           call flush(iout)
1143         endif
1144       endif
1145       endif
1146 #ifdef DEBUG
1147       write (iout,*) "gradc gradx gloc"
1148       do i=1,nres
1149         write (iout,'(i5,3f10.5,5x,3f10.5,5x,f10.5)')
1150      &   i,(gradc(j,i,icg),j=1,3),(gradx(j,i,icg),j=1,3),gloc(i,icg)
1151       enddo
1152 #endif
1153 #ifdef TIMING
1154       time_sumgradient=time_sumgradient+MPI_Wtime()-time01
1155 #endif
1156       return
1157       end
1158 c-------------------------------------------------------------------------------
1159       subroutine rescale_weights(t_bath)
1160       implicit real*8 (a-h,o-z)
1161       include 'DIMENSIONS'
1162       include 'COMMON.IOUNITS'
1163       include 'COMMON.FFIELD'
1164       include 'COMMON.SBRIDGE'
1165       include 'COMMON.CONTROL'
1166       double precision kfac /2.4d0/
1167       double precision x,x2,x3,x4,x5,licznik /1.12692801104297249644/
1168 c      facT=temp0/t_bath
1169 c      facT=2*temp0/(t_bath+temp0)
1170       if (rescale_mode.eq.0) then
1171         facT=1.0d0
1172         facT2=1.0d0
1173         facT3=1.0d0
1174         facT4=1.0d0
1175         facT5=1.0d0
1176       else if (rescale_mode.eq.1) then
1177         facT=kfac/(kfac-1.0d0+t_bath/temp0)
1178         facT2=kfac**2/(kfac**2-1.0d0+(t_bath/temp0)**2)
1179         facT3=kfac**3/(kfac**3-1.0d0+(t_bath/temp0)**3)
1180         facT4=kfac**4/(kfac**4-1.0d0+(t_bath/temp0)**4)
1181         facT5=kfac**5/(kfac**5-1.0d0+(t_bath/temp0)**5)
1182       else if (rescale_mode.eq.2) then
1183         x=t_bath/temp0
1184         x2=x*x
1185         x3=x2*x
1186         x4=x3*x
1187         x5=x4*x
1188         facT=licznik/dlog(dexp(x)+dexp(-x))
1189         facT2=licznik/dlog(dexp(x2)+dexp(-x2))
1190         facT3=licznik/dlog(dexp(x3)+dexp(-x3))
1191         facT4=licznik/dlog(dexp(x4)+dexp(-x4))
1192         facT5=licznik/dlog(dexp(x5)+dexp(-x5))
1193       else
1194         write (iout,*) "Wrong RESCALE_MODE",rescale_mode
1195         write (*,*) "Wrong RESCALE_MODE",rescale_mode
1196 #ifdef MPI
1197        call MPI_Finalize(MPI_COMM_WORLD,IERROR)
1198 #endif
1199        stop 555
1200       endif
1201       if (shield_mode.gt.0) then
1202        wscp=weights(2)*fact
1203        wsc=weights(1)*fact
1204        wvdwpp=weights(16)*fact
1205       endif
1206       welec=weights(3)*fact
1207       wcorr=weights(4)*fact3
1208       wcorr5=weights(5)*fact4
1209       wcorr6=weights(6)*fact5
1210       wel_loc=weights(7)*fact2
1211       wturn3=weights(8)*fact2
1212       wturn4=weights(9)*fact3
1213       wturn6=weights(10)*fact5
1214       wtor=weights(13)*fact
1215       wtor_d=weights(14)*fact2
1216       wsccor=weights(21)*fact
1217       if (scale_umb) wumb=t_bath/temp0
1218 c      write (iout,*) "scale_umb",scale_umb
1219 c      write (iout,*) "t_bath",t_bath," temp0",temp0," wumb",wumb
1220
1221       return
1222       end
1223 C------------------------------------------------------------------------
1224       subroutine enerprint(energia)
1225       implicit real*8 (a-h,o-z)
1226       include 'DIMENSIONS'
1227       include 'COMMON.IOUNITS'
1228       include 'COMMON.FFIELD'
1229       include 'COMMON.SBRIDGE'
1230       include 'COMMON.MD'
1231       double precision energia(0:n_ene)
1232       etot=energia(0)
1233       evdw=energia(1)
1234       evdw2=energia(2)
1235 #ifdef SCP14
1236       evdw2=energia(2)+energia(18)
1237 #else
1238       evdw2=energia(2)
1239 #endif
1240       ees=energia(3)
1241 #ifdef SPLITELE
1242       evdw1=energia(16)
1243 #endif
1244       ecorr=energia(4)
1245       ecorr5=energia(5)
1246       ecorr6=energia(6)
1247       eel_loc=energia(7)
1248       eello_turn3=energia(8)
1249       eello_turn4=energia(9)
1250       eello_turn6=energia(10)
1251       ebe=energia(11)
1252       escloc=energia(12)
1253       etors=energia(13)
1254       etors_d=energia(14)
1255       ehpb=energia(15)
1256       edihcnstr=energia(19)
1257       estr=energia(17)
1258       Uconst=energia(20)
1259       esccor=energia(21)
1260       eliptran=energia(22)
1261       Eafmforce=energia(23)
1262       ethetacnstr=energia(24)
1263       etube=energia(25)
1264       esaxs=energia(26)
1265       ehomology_constr=energia(27)
1266 C     Bartek
1267       edfadis = energia(28)
1268       edfator = energia(29)
1269       edfanei = energia(30)
1270       edfabet = energia(31)
1271 #ifdef SPLITELE
1272       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,evdw1,wvdwpp,
1273      &  estr,wbond,ebe,wang,
1274      &  escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,
1275      &  ecorr,wcorr,
1276      &  ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,
1277      &  eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccor,edihcnstr,
1278      &  ethetacnstr,ebr*nss,Uconst,wumb,eliptran,wliptran,Eafmforc,
1279      &  etube,wtube,esaxs,wsaxs,ehomology_constr,
1280      &  edfadis,wdfa_dist,edfator,wdfa_tor,edfanei,wdfa_nei,
1281      &  edfabet,wdfa_beta,
1282      &  etot
1283    10 format (/'Virtual-chain energies:'//
1284      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pE16.6,' (SC-SC)'/
1285      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pE16.6,' (SC-p)'/
1286      & 'EES=   ',1pE16.6,' WEIGHT=',1pE16.6,' (p-p)'/
1287      & 'EVDWPP=',1pE16.6,' WEIGHT=',1pE16.6,' (p-p VDW)'/
1288      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pE16.6,' (stretching)'/
1289      & 'EBE=   ',1pE16.6,' WEIGHT=',1pE16.6,' (bending)'/
1290      & 'ESC=   ',1pE16.6,' WEIGHT=',1pE16.6,' (SC local)'/
1291      & 'ETORS= ',1pE16.6,' WEIGHT=',1pE16.6,' (torsional)'/
1292      & 'ETORSD=',1pE16.6,' WEIGHT=',1pE16.6,' (double torsional)'/
1293      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pE16.6,
1294      & ' (SS bridges & dist. cnstr.)'/
1295      & 'ECORR4=',1pE16.6,' WEIGHT=',1pE16.6,' (multi-body)'/
1296      & 'ECORR5=',1pE16.6,' WEIGHT=',1pE16.6,' (multi-body)'/
1297      & 'ECORR6=',1pE16.6,' WEIGHT=',1pE16.6,' (multi-body)'/
1298      & 'EELLO= ',1pE16.6,' WEIGHT=',1pE16.6,' (electrostatic-local)'/
1299      & 'ETURN3=',1pE16.6,' WEIGHT=',1pE16.6,' (turns, 3rd order)'/
1300      & 'ETURN4=',1pE16.6,' WEIGHT=',1pE16.6,' (turns, 4th order)'/
1301      & 'ETURN6=',1pE16.6,' WEIGHT=',1pE16.6,' (turns, 6th order)'/
1302      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pE16.6,' (backbone-rotamer corr)'/
1303      & 'EDIHC= ',1pE16.6,' (virtual-bond dihedral angle restraints)'/
1304      & 'ETHETC=',1pE16.6,' (virtual-bond angle restraints)'/
1305      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
1306      & 'UCONST=',1pE16.6,' WEIGHT=',1pE16.6' (umbrella restraints)'/
1307      & 'ELT=   ',1pE16.6,' WEIGHT=',1pE16.6,' (Lipid transfer)'/
1308      & 'EAFM=  ',1pE16.6,' (atomic-force microscopy)'/
1309      & 'ETUBE= ',1pE16.6,' WEIGHT=',1pE16.6,' (tube confinment)'/
1310      & 'E_SAXS=',1pE16.6,' WEIGHT=',1pE16.6,' (SAXS restraints)'/
1311      & 'H_CONS=',1pE16.6,' (Homology model constraints energy)'/
1312      & 'EDFAD= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA distance energy)'/
1313      & 'EDFAT= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA torsion energy)'/
1314      & 'EDFAN= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA NCa energy)'/
1315      & 'EDFAB= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA Beta energy)'/
1316      & 'ETOT=  ',1pE16.6,' (total)')
1317
1318 #else
1319       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,
1320      &  estr,wbond,ebe,wang,
1321      &  escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,
1322      &  ecorr,wcorr,
1323      &  ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,
1324      &  eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccor,edihcnstr,
1325      &  ethetacnstr,ebr*nss,Uconst,wumb,eliptran,wliptran,Eafmforc,
1326      &  etube,wtube,esaxs,wsaxs,ehomology_constr,
1327      &  edfadis,wdfa_dist,edfator,wdfa_tor,edfanei,wdfa_nei,
1328      &  edfabet,wdfa_beta,
1329      &  etot
1330    10 format (/'Virtual-chain energies:'//
1331      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pE16.6,' (SC-SC)'/
1332      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pE16.6,' (SC-p)'/
1333      & 'EES=   ',1pE16.6,' WEIGHT=',1pE16.6,' (p-p)'/
1334      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pE16.6,' (stretching)'/
1335      & 'EBE=   ',1pE16.6,' WEIGHT=',1pE16.6,' (bending)'/
1336      & 'ESC=   ',1pE16.6,' WEIGHT=',1pE16.6,' (SC local)'/
1337      & 'ETORS= ',1pE16.6,' WEIGHT=',1pE16.6,' (torsional)'/
1338      & 'ETORSD=',1pE16.6,' WEIGHT=',1pE16.6,' (double torsional)'/
1339      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pE16.6,
1340      & ' (SS bridges & dist. restr.)'/
1341      & 'ECORR4=',1pE16.6,' WEIGHT=',1pE16.6,' (multi-body)'/
1342      & 'ECORR5=',1pE16.6,' WEIGHT=',1pE16.6,' (multi-body)'/
1343      & 'ECORR6=',1pE16.6,' WEIGHT=',1pE16.6,' (multi-body)'/
1344      & 'EELLO= ',1pE16.6,' WEIGHT=',1pE16.6,' (electrostatic-local)'/
1345      & 'ETURN3=',1pE16.6,' WEIGHT=',1pE16.6,' (turns, 3rd order)'/
1346      & 'ETURN4=',1pE16.6,' WEIGHT=',1pE16.6,' (turns, 4th order)'/
1347      & 'ETURN6=',1pE16.6,' WEIGHT=',1pE16.6,' (turns, 6th order)'/
1348      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pE16.6,' (backbone-rotamer corr)'/
1349      & 'EDIHC= ',1pE16.6,' (virtual-bond dihedral angle restraints)'/
1350      & 'ETHETC=',1pE16.6,' (virtual-bond angle restraints)'/
1351      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
1352      & 'UCONST=',1pE16.6,' WEIGHT=',1pE16.6' (umbrella restraints)'/
1353      & 'ELT=   ',1pE16.6,' WEIGHT=',1pE16.6,' (Lipid transfer)'/
1354      & 'EAFM=  ',1pE16.6,' (atomic-force microscopy)'/
1355      & 'ETUBE= ',1pE16.6,' WEIGHT=',1pE16.6,' (tube confinment)'/
1356      & 'E_SAXS=',1pE16.6,' WEIGHT=',1pE16.6,' (SAXS restraints)'/
1357      & 'H_CONS=',1pE16.6,' (Homology model constraints energy)'/
1358      & 'EDFAD= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA distance energy)'/
1359      & 'EDFAT= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA torsion energy)'/
1360      & 'EDFAN= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA NCa energy)'/
1361      & 'EDFAB= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA Beta energy)'/
1362      & 'ETOT=  ',1pE16.6,' (total)')
1363 #endif
1364       return
1365       end
1366 C-----------------------------------------------------------------------
1367       subroutine elj(evdw)
1368 C
1369 C This subroutine calculates the interaction energy of nonbonded side chains
1370 C assuming the LJ potential of interaction.
1371 C
1372       implicit real*8 (a-h,o-z)
1373       include 'DIMENSIONS'
1374       parameter (accur=1.0d-10)
1375       include 'COMMON.GEO'
1376       include 'COMMON.VAR'
1377       include 'COMMON.LOCAL'
1378       include 'COMMON.CHAIN'
1379       include 'COMMON.DERIV'
1380       include 'COMMON.INTERACT'
1381       include 'COMMON.TORSION'
1382       include 'COMMON.SBRIDGE'
1383       include 'COMMON.NAMES'
1384       include 'COMMON.IOUNITS'
1385       include 'COMMON.CONTACTS'
1386       dimension gg(3)
1387 c      write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
1388       evdw=0.0D0
1389       do i=iatsc_s,iatsc_e
1390         itypi=iabs(itype(i))
1391         if (itypi.eq.ntyp1) cycle
1392         itypi1=iabs(itype(i+1))
1393         xi=c(1,nres+i)
1394         yi=c(2,nres+i)
1395         zi=c(3,nres+i)
1396 C Change 12/1/95
1397         num_conti=0
1398 C
1399 C Calculate SC interaction energy.
1400 C
1401         do iint=1,nint_gr(i)
1402 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
1403 cd   &                  'iend=',iend(i,iint)
1404           do j=istart(i,iint),iend(i,iint)
1405             itypj=iabs(itype(j))
1406             if (itypj.eq.ntyp1) cycle
1407             xj=c(1,nres+j)-xi
1408             yj=c(2,nres+j)-yi
1409             zj=c(3,nres+j)-zi
1410 C Change 12/1/95 to calculate four-body interactions
1411             rij=xj*xj+yj*yj+zj*zj
1412             rrij=1.0D0/rij
1413 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
1414             eps0ij=eps(itypi,itypj)
1415             fac=rrij**expon2
1416 C have you changed here?
1417             e1=fac*fac*aa
1418             e2=fac*bb
1419             evdwij=e1+e2
1420 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1421 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1422 cd          write (iout,'(2(a3,i3,2x),6(1pd12.4)/2(3(1pd12.4),5x)/)')
1423 cd   &        restyp(itypi),i,restyp(itypj),j,a(itypi,itypj),
1424 cd   &        bb(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,epsi,sigm,
1425 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1426             evdw=evdw+evdwij
1427 C
1428 C Calculate the components of the gradient in DC and X
1429 C
1430             fac=-rrij*(e1+evdwij)
1431             gg(1)=xj*fac
1432             gg(2)=yj*fac
1433             gg(3)=zj*fac
1434             do k=1,3
1435               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1436               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1437               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1438               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1439             enddo
1440 cgrad            do k=i,j-1
1441 cgrad              do l=1,3
1442 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1443 cgrad              enddo
1444 cgrad            enddo
1445 C
1446 C 12/1/95, revised on 5/20/97
1447 C
1448 C Calculate the contact function. The ith column of the array JCONT will
1449 C contain the numbers of atoms that make contacts with the atom I (of numbers
1450 C greater than I). The arrays FACONT and GACONT will contain the values of
1451 C the contact function and its derivative.
1452 C
1453 C Uncomment next line, if the correlation interactions include EVDW explicitly.
1454 c           if (j.gt.i+1 .and. evdwij.le.0.0D0) then
1455 C Uncomment next line, if the correlation interactions are contact function only
1456             if (j.gt.i+1.and. eps0ij.gt.0.0D0) then
1457               rij=dsqrt(rij)
1458               sigij=sigma(itypi,itypj)
1459               r0ij=rs0(itypi,itypj)
1460 C
1461 C Check whether the SC's are not too far to make a contact.
1462 C
1463               rcut=1.5d0*r0ij
1464               call gcont(rij,rcut,1.0d0,0.2d0*rcut,fcont,fprimcont)
1465 C Add a new contact, if the SC's are close enough, but not too close (r<sigma).
1466 C
1467               if (fcont.gt.0.0D0) then
1468 C If the SC-SC distance if close to sigma, apply spline.
1469 cAdam           call gcont(-rij,-1.03d0*sigij,2.0d0*sigij,1.0d0,
1470 cAdam &             fcont1,fprimcont1)
1471 cAdam           fcont1=1.0d0-fcont1
1472 cAdam           if (fcont1.gt.0.0d0) then
1473 cAdam             fprimcont=fprimcont*fcont1+fcont*fprimcont1
1474 cAdam             fcont=fcont*fcont1
1475 cAdam           endif
1476 C Uncomment following 4 lines to have the geometric average of the epsilon0's
1477 cga             eps0ij=1.0d0/dsqrt(eps0ij)
1478 cga             do k=1,3
1479 cga               gg(k)=gg(k)*eps0ij
1480 cga             enddo
1481 cga             eps0ij=-evdwij*eps0ij
1482 C Uncomment for AL's type of SC correlation interactions.
1483 cadam           eps0ij=-evdwij
1484                 num_conti=num_conti+1
1485                 jcont(num_conti,i)=j
1486                 facont(num_conti,i)=fcont*eps0ij
1487                 fprimcont=eps0ij*fprimcont/rij
1488                 fcont=expon*fcont
1489 cAdam           gacont(1,num_conti,i)=-fprimcont*xj+fcont*gg(1)
1490 cAdam           gacont(2,num_conti,i)=-fprimcont*yj+fcont*gg(2)
1491 cAdam           gacont(3,num_conti,i)=-fprimcont*zj+fcont*gg(3)
1492 C Uncomment following 3 lines for Skolnick's type of SC correlation.
1493                 gacont(1,num_conti,i)=-fprimcont*xj
1494                 gacont(2,num_conti,i)=-fprimcont*yj
1495                 gacont(3,num_conti,i)=-fprimcont*zj
1496 cd              write (iout,'(2i5,2f10.5)') i,j,rij,facont(num_conti,i)
1497 cd              write (iout,'(2i3,3f10.5)')
1498 cd   &           i,j,(gacont(kk,num_conti,i),kk=1,3)
1499               endif
1500             endif
1501           enddo      ! j
1502         enddo        ! iint
1503 C Change 12/1/95
1504         num_cont(i)=num_conti
1505       enddo          ! i
1506       do i=1,nct
1507         do j=1,3
1508           gvdwc(j,i)=expon*gvdwc(j,i)
1509           gvdwx(j,i)=expon*gvdwx(j,i)
1510         enddo
1511       enddo
1512 C******************************************************************************
1513 C
1514 C                              N O T E !!!
1515 C
1516 C To save time, the factor of EXPON has been extracted from ALL components
1517 C of GVDWC and GRADX. Remember to multiply them by this factor before further
1518 C use!
1519 C
1520 C******************************************************************************
1521       return
1522       end
1523 C-----------------------------------------------------------------------------
1524       subroutine eljk(evdw)
1525 C
1526 C This subroutine calculates the interaction energy of nonbonded side chains
1527 C assuming the LJK potential of interaction.
1528 C
1529       implicit real*8 (a-h,o-z)
1530       include 'DIMENSIONS'
1531       include 'COMMON.GEO'
1532       include 'COMMON.VAR'
1533       include 'COMMON.LOCAL'
1534       include 'COMMON.CHAIN'
1535       include 'COMMON.DERIV'
1536       include 'COMMON.INTERACT'
1537       include 'COMMON.IOUNITS'
1538       include 'COMMON.NAMES'
1539       dimension gg(3)
1540       logical scheck
1541 c     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
1542       evdw=0.0D0
1543       do i=iatsc_s,iatsc_e
1544         itypi=iabs(itype(i))
1545         if (itypi.eq.ntyp1) cycle
1546         itypi1=iabs(itype(i+1))
1547         xi=c(1,nres+i)
1548         yi=c(2,nres+i)
1549         zi=c(3,nres+i)
1550 C
1551 C Calculate SC interaction energy.
1552 C
1553         do iint=1,nint_gr(i)
1554           do j=istart(i,iint),iend(i,iint)
1555             itypj=iabs(itype(j))
1556             if (itypj.eq.ntyp1) cycle
1557             xj=c(1,nres+j)-xi
1558             yj=c(2,nres+j)-yi
1559             zj=c(3,nres+j)-zi
1560             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1561             fac_augm=rrij**expon
1562             e_augm=augm(itypi,itypj)*fac_augm
1563             r_inv_ij=dsqrt(rrij)
1564             rij=1.0D0/r_inv_ij
1565             r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
1566             fac=r_shift_inv**expon
1567 C have you changed here?
1568             e1=fac*fac*aa
1569             e2=fac*bb
1570             evdwij=e_augm+e1+e2
1571 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1572 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1573 cd          write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
1574 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
1575 cd   &        bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
1576 cd   &        sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
1577 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1578             evdw=evdw+evdwij
1579 C
1580 C Calculate the components of the gradient in DC and X
1581 C
1582             fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
1583             gg(1)=xj*fac
1584             gg(2)=yj*fac
1585             gg(3)=zj*fac
1586             do k=1,3
1587               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1588               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1589               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1590               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1591             enddo
1592 cgrad            do k=i,j-1
1593 cgrad              do l=1,3
1594 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1595 cgrad              enddo
1596 cgrad            enddo
1597           enddo      ! j
1598         enddo        ! iint
1599       enddo          ! i
1600       do i=1,nct
1601         do j=1,3
1602           gvdwc(j,i)=expon*gvdwc(j,i)
1603           gvdwx(j,i)=expon*gvdwx(j,i)
1604         enddo
1605       enddo
1606       return
1607       end
1608 C-----------------------------------------------------------------------------
1609       subroutine ebp(evdw)
1610 C
1611 C This subroutine calculates the interaction energy of nonbonded side chains
1612 C assuming the Berne-Pechukas potential of interaction.
1613 C
1614       implicit real*8 (a-h,o-z)
1615       include 'DIMENSIONS'
1616       include 'COMMON.GEO'
1617       include 'COMMON.VAR'
1618       include 'COMMON.LOCAL'
1619       include 'COMMON.CHAIN'
1620       include 'COMMON.DERIV'
1621       include 'COMMON.NAMES'
1622       include 'COMMON.INTERACT'
1623       include 'COMMON.IOUNITS'
1624       include 'COMMON.CALC'
1625       common /srutu/ icall
1626 c     double precision rrsave(maxdim)
1627       logical lprn
1628       evdw=0.0D0
1629 c     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
1630       evdw=0.0D0
1631 c     if (icall.eq.0) then
1632 c       lprn=.true.
1633 c     else
1634         lprn=.false.
1635 c     endif
1636       ind=0
1637       do i=iatsc_s,iatsc_e
1638         itypi=iabs(itype(i))
1639         if (itypi.eq.ntyp1) cycle
1640         itypi1=iabs(itype(i+1))
1641         xi=c(1,nres+i)
1642         yi=c(2,nres+i)
1643         zi=c(3,nres+i)
1644         dxi=dc_norm(1,nres+i)
1645         dyi=dc_norm(2,nres+i)
1646         dzi=dc_norm(3,nres+i)
1647 c        dsci_inv=dsc_inv(itypi)
1648         dsci_inv=vbld_inv(i+nres)
1649 C
1650 C Calculate SC interaction energy.
1651 C
1652         do iint=1,nint_gr(i)
1653           do j=istart(i,iint),iend(i,iint)
1654             ind=ind+1
1655             itypj=iabs(itype(j))
1656             if (itypj.eq.ntyp1) cycle
1657 c            dscj_inv=dsc_inv(itypj)
1658             dscj_inv=vbld_inv(j+nres)
1659             chi1=chi(itypi,itypj)
1660             chi2=chi(itypj,itypi)
1661             chi12=chi1*chi2
1662             chip1=chip(itypi)
1663             chip2=chip(itypj)
1664             chip12=chip1*chip2
1665             alf1=alp(itypi)
1666             alf2=alp(itypj)
1667             alf12=0.5D0*(alf1+alf2)
1668 C For diagnostics only!!!
1669 c           chi1=0.0D0
1670 c           chi2=0.0D0
1671 c           chi12=0.0D0
1672 c           chip1=0.0D0
1673 c           chip2=0.0D0
1674 c           chip12=0.0D0
1675 c           alf1=0.0D0
1676 c           alf2=0.0D0
1677 c           alf12=0.0D0
1678             xj=c(1,nres+j)-xi
1679             yj=c(2,nres+j)-yi
1680             zj=c(3,nres+j)-zi
1681             dxj=dc_norm(1,nres+j)
1682             dyj=dc_norm(2,nres+j)
1683             dzj=dc_norm(3,nres+j)
1684             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1685 cd          if (icall.eq.0) then
1686 cd            rrsave(ind)=rrij
1687 cd          else
1688 cd            rrij=rrsave(ind)
1689 cd          endif
1690             rij=dsqrt(rrij)
1691 C Calculate the angle-dependent terms of energy & contributions to derivatives.
1692             call sc_angular
1693 C Calculate whole angle-dependent part of epsilon and contributions
1694 C to its derivatives
1695 C have you changed here?
1696             fac=(rrij*sigsq)**expon2
1697             e1=fac*fac*aa
1698             e2=fac*bb
1699             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1700             eps2der=evdwij*eps3rt
1701             eps3der=evdwij*eps2rt
1702             evdwij=evdwij*eps2rt*eps3rt
1703             evdw=evdw+evdwij
1704             if (lprn) then
1705             sigm=dabs(aa/bb)**(1.0D0/6.0D0)
1706             epsi=bb**2/aa
1707 cd            write (iout,'(2(a3,i3,2x),15(0pf7.3))')
1708 cd     &        restyp(itypi),i,restyp(itypj),j,
1709 cd     &        epsi,sigm,chi1,chi2,chip1,chip2,
1710 cd     &        eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
1711 cd     &        om1,om2,om12,1.0D0/dsqrt(rrij),
1712 cd     &        evdwij
1713             endif
1714 C Calculate gradient components.
1715             e1=e1*eps1*eps2rt**2*eps3rt**2
1716             fac=-expon*(e1+evdwij)
1717             sigder=fac/sigsq
1718             fac=rrij*fac
1719 C Calculate radial part of the gradient
1720             gg(1)=xj*fac
1721             gg(2)=yj*fac
1722             gg(3)=zj*fac
1723 C Calculate the angular part of the gradient and sum add the contributions
1724 C to the appropriate components of the Cartesian gradient.
1725             call sc_grad
1726           enddo      ! j
1727         enddo        ! iint
1728       enddo          ! i
1729 c     stop
1730       return
1731       end
1732 C-----------------------------------------------------------------------------
1733       subroutine egb(evdw)
1734 C
1735 C This subroutine calculates the interaction energy of nonbonded side chains
1736 C assuming the Gay-Berne potential of interaction.
1737 C
1738       implicit real*8 (a-h,o-z)
1739       include 'DIMENSIONS'
1740       include 'COMMON.GEO'
1741       include 'COMMON.VAR'
1742       include 'COMMON.LOCAL'
1743       include 'COMMON.CHAIN'
1744       include 'COMMON.DERIV'
1745       include 'COMMON.NAMES'
1746       include 'COMMON.INTERACT'
1747       include 'COMMON.IOUNITS'
1748       include 'COMMON.CALC'
1749       include 'COMMON.CONTROL'
1750       include 'COMMON.SPLITELE'
1751       include 'COMMON.SBRIDGE'
1752       logical lprn
1753       integer xshift,yshift,zshift
1754
1755       evdw=0.0D0
1756 ccccc      energy_dec=.false.
1757 C      print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1758       evdw=0.0D0
1759       lprn=.false.
1760 c     if (icall.eq.0) lprn=.false.
1761       ind=0
1762 C the loop over all 27 posible neigbours (for xshift=0,yshift=0,zshift=0
1763 C we have the original box)
1764 C      do xshift=-1,1
1765 C      do yshift=-1,1
1766 C      do zshift=-1,1
1767       do i=iatsc_s,iatsc_e
1768         itypi=iabs(itype(i))
1769         if (itypi.eq.ntyp1) cycle
1770         itypi1=iabs(itype(i+1))
1771         xi=c(1,nres+i)
1772         yi=c(2,nres+i)
1773         zi=c(3,nres+i)
1774 C Return atom into box, boxxsize is size of box in x dimension
1775 c  134   continue
1776 c        if (xi.gt.((xshift+0.5d0)*boxxsize)) xi=xi-boxxsize
1777 c        if (xi.lt.((xshift-0.5d0)*boxxsize)) xi=xi+boxxsize
1778 C Condition for being inside the proper box
1779 c        if ((xi.gt.((xshift+0.5d0)*boxxsize)).or.
1780 c     &       (xi.lt.((xshift-0.5d0)*boxxsize))) then
1781 c        go to 134
1782 c        endif
1783 c  135   continue
1784 c        if (yi.gt.((yshift+0.5d0)*boxysize)) yi=yi-boxysize
1785 c        if (yi.lt.((yshift-0.5d0)*boxysize)) yi=yi+boxysize
1786 C Condition for being inside the proper box
1787 c        if ((yi.gt.((yshift+0.5d0)*boxysize)).or.
1788 c     &       (yi.lt.((yshift-0.5d0)*boxysize))) then
1789 c        go to 135
1790 c        endif
1791 c  136   continue
1792 c        if (zi.gt.((zshift+0.5d0)*boxzsize)) zi=zi-boxzsize
1793 c        if (zi.lt.((zshift-0.5d0)*boxzsize)) zi=zi+boxzsize
1794 C Condition for being inside the proper box
1795 c        if ((zi.gt.((zshift+0.5d0)*boxzsize)).or.
1796 c     &       (zi.lt.((zshift-0.5d0)*boxzsize))) then
1797 c        go to 136
1798 c        endif
1799           xi=mod(xi,boxxsize)
1800           if (xi.lt.0) xi=xi+boxxsize
1801           yi=mod(yi,boxysize)
1802           if (yi.lt.0) yi=yi+boxysize
1803           zi=mod(zi,boxzsize)
1804           if (zi.lt.0) zi=zi+boxzsize
1805 C define scaling factor for lipids
1806
1807 C        if (positi.le.0) positi=positi+boxzsize
1808 C        print *,i
1809 C first for peptide groups
1810 c for each residue check if it is in lipid or lipid water border area
1811        if ((zi.gt.bordlipbot)
1812      &.and.(zi.lt.bordliptop)) then
1813 C the energy transfer exist
1814         if (zi.lt.buflipbot) then
1815 C what fraction I am in
1816          fracinbuf=1.0d0-
1817      &        ((zi-bordlipbot)/lipbufthick)
1818 C lipbufthick is thickenes of lipid buffore
1819          sslipi=sscalelip(fracinbuf)
1820          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
1821         elseif (zi.gt.bufliptop) then
1822          fracinbuf=1.0d0-((bordliptop-zi)/lipbufthick)
1823          sslipi=sscalelip(fracinbuf)
1824          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
1825         else
1826          sslipi=1.0d0
1827          ssgradlipi=0.0
1828         endif
1829        else
1830          sslipi=0.0d0
1831          ssgradlipi=0.0
1832        endif
1833
1834 C          xi=xi+xshift*boxxsize
1835 C          yi=yi+yshift*boxysize
1836 C          zi=zi+zshift*boxzsize
1837
1838         dxi=dc_norm(1,nres+i)
1839         dyi=dc_norm(2,nres+i)
1840         dzi=dc_norm(3,nres+i)
1841 c        dsci_inv=dsc_inv(itypi)
1842         dsci_inv=vbld_inv(i+nres)
1843 c        write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)
1844 c        write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi
1845 C
1846 C Calculate SC interaction energy.
1847 C
1848         do iint=1,nint_gr(i)
1849           do j=istart(i,iint),iend(i,iint)
1850             IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN
1851
1852 c              write(iout,*) "PRZED ZWYKLE", evdwij
1853               call dyn_ssbond_ene(i,j,evdwij)
1854 c              write(iout,*) "PO ZWYKLE", evdwij
1855
1856               evdw=evdw+evdwij
1857               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)')
1858      &                        'evdw',i,j,evdwij,' ss'
1859 C triple bond artifac removal
1860              do k=j+1,iend(i,iint)
1861 C search over all next residues
1862               if (dyn_ss_mask(k)) then
1863 C check if they are cysteins
1864 C              write(iout,*) 'k=',k
1865
1866 c              write(iout,*) "PRZED TRI", evdwij
1867                evdwij_przed_tri=evdwij
1868               call triple_ssbond_ene(i,j,k,evdwij)
1869 c               if(evdwij_przed_tri.ne.evdwij) then
1870 c                 write (iout,*) "TRI:", evdwij, evdwij_przed_tri
1871 c               endif
1872
1873 c              write(iout,*) "PO TRI", evdwij
1874 C call the energy function that removes the artifical triple disulfide
1875 C bond the soubroutine is located in ssMD.F
1876               evdw=evdw+evdwij
1877               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)')
1878      &                        'evdw',i,j,evdwij,'tss'
1879               endif!dyn_ss_mask(k)
1880              enddo! k
1881             ELSE
1882             ind=ind+1
1883             itypj=iabs(itype(j))
1884             if (itypj.eq.ntyp1) cycle
1885 c            dscj_inv=dsc_inv(itypj)
1886             dscj_inv=vbld_inv(j+nres)
1887 c            write (iout,*) "j",j,dsc_inv(itypj),dscj_inv,
1888 c     &       1.0d0/vbld(j+nres)
1889 c            write (iout,*) "i",i," j", j," itype",itype(i),itype(j)
1890             sig0ij=sigma(itypi,itypj)
1891             chi1=chi(itypi,itypj)
1892             chi2=chi(itypj,itypi)
1893             chi12=chi1*chi2
1894             chip1=chip(itypi)
1895             chip2=chip(itypj)
1896             chip12=chip1*chip2
1897             alf1=alp(itypi)
1898             alf2=alp(itypj)
1899             alf12=0.5D0*(alf1+alf2)
1900 C For diagnostics only!!!
1901 c           chi1=0.0D0
1902 c           chi2=0.0D0
1903 c           chi12=0.0D0
1904 c           chip1=0.0D0
1905 c           chip2=0.0D0
1906 c           chip12=0.0D0
1907 c           alf1=0.0D0
1908 c           alf2=0.0D0
1909 c           alf12=0.0D0
1910             xj=c(1,nres+j)
1911             yj=c(2,nres+j)
1912             zj=c(3,nres+j)
1913 C Return atom J into box the original box
1914 c  137   continue
1915 c        if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
1916 c        if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
1917 C Condition for being inside the proper box
1918 c        if ((xj.gt.((0.5d0)*boxxsize)).or.
1919 c     &       (xj.lt.((-0.5d0)*boxxsize))) then
1920 c        go to 137
1921 c        endif
1922 c  138   continue
1923 c        if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
1924 c        if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
1925 C Condition for being inside the proper box
1926 c        if ((yj.gt.((0.5d0)*boxysize)).or.
1927 c     &       (yj.lt.((-0.5d0)*boxysize))) then
1928 c        go to 138
1929 c        endif
1930 c  139   continue
1931 c        if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
1932 c        if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
1933 C Condition for being inside the proper box
1934 c        if ((zj.gt.((0.5d0)*boxzsize)).or.
1935 c     &       (zj.lt.((-0.5d0)*boxzsize))) then
1936 c        go to 139
1937 c        endif
1938           xj=mod(xj,boxxsize)
1939           if (xj.lt.0) xj=xj+boxxsize
1940           yj=mod(yj,boxysize)
1941           if (yj.lt.0) yj=yj+boxysize
1942           zj=mod(zj,boxzsize)
1943           if (zj.lt.0) zj=zj+boxzsize
1944        if ((zj.gt.bordlipbot)
1945      &.and.(zj.lt.bordliptop)) then
1946 C the energy transfer exist
1947         if (zj.lt.buflipbot) then
1948 C what fraction I am in
1949          fracinbuf=1.0d0-
1950      &        ((zj-bordlipbot)/lipbufthick)
1951 C lipbufthick is thickenes of lipid buffore
1952          sslipj=sscalelip(fracinbuf)
1953          ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
1954         elseif (zj.gt.bufliptop) then
1955          fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
1956          sslipj=sscalelip(fracinbuf)
1957          ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
1958         else
1959          sslipj=1.0d0
1960          ssgradlipj=0.0
1961         endif
1962        else
1963          sslipj=0.0d0
1964          ssgradlipj=0.0
1965        endif
1966       aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
1967      &  +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1968       bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
1969      &  +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1970 C      write(iout,*) "tu,", i,j,aa_lip(itypi,itypj),bb_lip(itypi,itypj)
1971 C      if (aa.ne.aa_aq(itypi,itypj)) write(63,'(2e10.5)')
1972 C     &(aa-aa_aq(itypi,itypj)),(bb-bb_aq(itypi,itypj))
1973 C      if (ssgradlipj.gt.0.0d0) print *,"??WTF??"
1974 C      print *,sslipi,sslipj,bordlipbot,zi,zj
1975       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
1976       xj_safe=xj
1977       yj_safe=yj
1978       zj_safe=zj
1979       subchap=0
1980       do xshift=-1,1
1981       do yshift=-1,1
1982       do zshift=-1,1
1983           xj=xj_safe+xshift*boxxsize
1984           yj=yj_safe+yshift*boxysize
1985           zj=zj_safe+zshift*boxzsize
1986           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
1987           if(dist_temp.lt.dist_init) then
1988             dist_init=dist_temp
1989             xj_temp=xj
1990             yj_temp=yj
1991             zj_temp=zj
1992             subchap=1
1993           endif
1994        enddo
1995        enddo
1996        enddo
1997        if (subchap.eq.1) then
1998           xj=xj_temp-xi
1999           yj=yj_temp-yi
2000           zj=zj_temp-zi
2001        else
2002           xj=xj_safe-xi
2003           yj=yj_safe-yi
2004           zj=zj_safe-zi
2005        endif
2006             dxj=dc_norm(1,nres+j)
2007             dyj=dc_norm(2,nres+j)
2008             dzj=dc_norm(3,nres+j)
2009 C            xj=xj-xi
2010 C            yj=yj-yi
2011 C            zj=zj-zi
2012 c            write (iout,*) "dcnorj",dxi*dxi+dyi*dyi+dzi*dzi
2013 c            write (iout,*) "j",j," dc_norm",
2014 c     &       dc_norm(1,nres+j),dc_norm(2,nres+j),dc_norm(3,nres+j)
2015             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
2016             rij=dsqrt(rrij)
2017             sss=sscale((1.0d0/rij)/sigma(itypi,itypj))
2018             sssgrad=sscagrad((1.0d0/rij)/sigma(itypi,itypj))
2019
2020 c            write (iout,'(a7,4f8.3)')
2021 c    &      "ssscale",sss,((1.0d0/rij)/sigma(itypi,itypj)),r_cut,rlamb
2022             if (sss.gt.0.0d0) then
2023 C Calculate angle-dependent terms of energy and contributions to their
2024 C derivatives.
2025             call sc_angular
2026             sigsq=1.0D0/sigsq
2027             sig=sig0ij*dsqrt(sigsq)
2028             rij_shift=1.0D0/rij-sig+sig0ij
2029 c for diagnostics; uncomment
2030 c            rij_shift=1.2*sig0ij
2031 C I hate to put IF's in the loops, but here don't have another choice!!!!
2032             if (rij_shift.le.0.0D0) then
2033               evdw=1.0D20
2034 cd              write (iout,'(2(a3,i3,2x),17(0pf7.3))')
2035 cd     &        restyp(itypi),i,restyp(itypj),j,
2036 cd     &        rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq)
2037               return
2038             endif
2039             sigder=-sig*sigsq
2040 c---------------------------------------------------------------
2041             rij_shift=1.0D0/rij_shift
2042             fac=rij_shift**expon
2043 C here to start with
2044 C            if (c(i,3).gt.
2045             faclip=fac
2046             e1=fac*fac*aa
2047             e2=fac*bb
2048             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
2049             eps2der=evdwij*eps3rt
2050             eps3der=evdwij*eps2rt
2051 C       write(63,'(2i3,2e10.3,2f10.5)') i,j,aa,bb, evdwij,
2052 C     &((sslipi+sslipj)/2.0d0+
2053 C     &(2.0d0-sslipi-sslipj)/2.0d0)
2054 c            write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt,
2055 c     &        " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2
2056             evdwij=evdwij*eps2rt*eps3rt
2057             evdw=evdw+evdwij*sss
2058             if (lprn) then
2059             sigm=dabs(aa/bb)**(1.0D0/6.0D0)
2060             epsi=bb**2/aa
2061             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
2062      &        restyp(itypi),i,restyp(itypj),j,
2063      &        epsi,sigm,chi1,chi2,chip1,chip2,
2064      &        eps1,eps2rt**2,eps3rt**2,sig,sig0ij,
2065      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
2066      &        evdwij
2067             endif
2068
2069             if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
2070      &                        'evdw',i,j,evdwij
2071
2072 C Calculate gradient components.
2073             e1=e1*eps1*eps2rt**2*eps3rt**2
2074             fac=-expon*(e1+evdwij)*rij_shift
2075             sigder=fac*sigder
2076             fac=rij*fac
2077 c            print '(2i4,6f8.4)',i,j,sss,sssgrad*
2078 c     &      evdwij,fac,sigma(itypi,itypj),expon
2079             fac=fac+evdwij/sss*sssgrad/sigma(itypi,itypj)*rij
2080 c            fac=0.0d0
2081 C Calculate the radial part of the gradient
2082             gg_lipi(3)=eps1*(eps2rt*eps2rt)
2083      &*(eps3rt*eps3rt)*sss/2.0d0*(faclip*faclip*
2084      & (aa_lip(itypi,itypj)-aa_aq(itypi,itypj))
2085      &+faclip*(bb_lip(itypi,itypj)-bb_aq(itypi,itypj)))
2086             gg_lipj(3)=ssgradlipj*gg_lipi(3)
2087             gg_lipi(3)=gg_lipi(3)*ssgradlipi
2088 C            gg_lipi(3)=0.0d0
2089 C            gg_lipj(3)=0.0d0
2090             gg(1)=xj*fac
2091             gg(2)=yj*fac
2092             gg(3)=zj*fac
2093 C Calculate angular part of the gradient.
2094             call sc_grad
2095             endif
2096             ENDIF    ! dyn_ss
2097           enddo      ! j
2098         enddo        ! iint
2099       enddo          ! i
2100 C      enddo          ! zshift
2101 C      enddo          ! yshift
2102 C      enddo          ! xshift
2103 c      write (iout,*) "Number of loop steps in EGB:",ind
2104 cccc      energy_dec=.false.
2105       return
2106       end
2107 C-----------------------------------------------------------------------------
2108       subroutine egbv(evdw)
2109 C
2110 C This subroutine calculates the interaction energy of nonbonded side chains
2111 C assuming the Gay-Berne-Vorobjev potential of interaction.
2112 C
2113       implicit real*8 (a-h,o-z)
2114       include 'DIMENSIONS'
2115       include 'COMMON.GEO'
2116       include 'COMMON.VAR'
2117       include 'COMMON.LOCAL'
2118       include 'COMMON.CHAIN'
2119       include 'COMMON.DERIV'
2120       include 'COMMON.NAMES'
2121       include 'COMMON.INTERACT'
2122       include 'COMMON.IOUNITS'
2123       include 'COMMON.CALC'
2124       integer xshift,yshift,zshift
2125       common /srutu/ icall
2126       logical lprn
2127       evdw=0.0D0
2128 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
2129       evdw=0.0D0
2130       lprn=.false.
2131 c     if (icall.eq.0) lprn=.true.
2132       ind=0
2133       do i=iatsc_s,iatsc_e
2134         itypi=iabs(itype(i))
2135         if (itypi.eq.ntyp1) cycle
2136         itypi1=iabs(itype(i+1))
2137         xi=c(1,nres+i)
2138         yi=c(2,nres+i)
2139         zi=c(3,nres+i)
2140           xi=mod(xi,boxxsize)
2141           if (xi.lt.0) xi=xi+boxxsize
2142           yi=mod(yi,boxysize)
2143           if (yi.lt.0) yi=yi+boxysize
2144           zi=mod(zi,boxzsize)
2145           if (zi.lt.0) zi=zi+boxzsize
2146 C define scaling factor for lipids
2147
2148 C        if (positi.le.0) positi=positi+boxzsize
2149 C        print *,i
2150 C first for peptide groups
2151 c for each residue check if it is in lipid or lipid water border area
2152        if ((zi.gt.bordlipbot)
2153      &.and.(zi.lt.bordliptop)) then
2154 C the energy transfer exist
2155         if (zi.lt.buflipbot) then
2156 C what fraction I am in
2157          fracinbuf=1.0d0-
2158      &        ((zi-bordlipbot)/lipbufthick)
2159 C lipbufthick is thickenes of lipid buffore
2160          sslipi=sscalelip(fracinbuf)
2161          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
2162         elseif (zi.gt.bufliptop) then
2163          fracinbuf=1.0d0-((bordliptop-zi)/lipbufthick)
2164          sslipi=sscalelip(fracinbuf)
2165          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
2166         else
2167          sslipi=1.0d0
2168          ssgradlipi=0.0
2169         endif
2170        else
2171          sslipi=0.0d0
2172          ssgradlipi=0.0
2173        endif
2174
2175         dxi=dc_norm(1,nres+i)
2176         dyi=dc_norm(2,nres+i)
2177         dzi=dc_norm(3,nres+i)
2178 c        dsci_inv=dsc_inv(itypi)
2179         dsci_inv=vbld_inv(i+nres)
2180 C
2181 C Calculate SC interaction energy.
2182 C
2183         do iint=1,nint_gr(i)
2184           do j=istart(i,iint),iend(i,iint)
2185             ind=ind+1
2186             itypj=iabs(itype(j))
2187             if (itypj.eq.ntyp1) cycle
2188 c            dscj_inv=dsc_inv(itypj)
2189             dscj_inv=vbld_inv(j+nres)
2190             sig0ij=sigma(itypi,itypj)
2191             r0ij=r0(itypi,itypj)
2192             chi1=chi(itypi,itypj)
2193             chi2=chi(itypj,itypi)
2194             chi12=chi1*chi2
2195             chip1=chip(itypi)
2196             chip2=chip(itypj)
2197             chip12=chip1*chip2
2198             alf1=alp(itypi)
2199             alf2=alp(itypj)
2200             alf12=0.5D0*(alf1+alf2)
2201 C For diagnostics only!!!
2202 c           chi1=0.0D0
2203 c           chi2=0.0D0
2204 c           chi12=0.0D0
2205 c           chip1=0.0D0
2206 c           chip2=0.0D0
2207 c           chip12=0.0D0
2208 c           alf1=0.0D0
2209 c           alf2=0.0D0
2210 c           alf12=0.0D0
2211 C            xj=c(1,nres+j)-xi
2212 C            yj=c(2,nres+j)-yi
2213 C            zj=c(3,nres+j)-zi
2214           xj=mod(xj,boxxsize)
2215           if (xj.lt.0) xj=xj+boxxsize
2216           yj=mod(yj,boxysize)
2217           if (yj.lt.0) yj=yj+boxysize
2218           zj=mod(zj,boxzsize)
2219           if (zj.lt.0) zj=zj+boxzsize
2220        if ((zj.gt.bordlipbot)
2221      &.and.(zj.lt.bordliptop)) then
2222 C the energy transfer exist
2223         if (zj.lt.buflipbot) then
2224 C what fraction I am in
2225          fracinbuf=1.0d0-
2226      &        ((zj-bordlipbot)/lipbufthick)
2227 C lipbufthick is thickenes of lipid buffore
2228          sslipj=sscalelip(fracinbuf)
2229          ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
2230         elseif (zj.gt.bufliptop) then
2231          fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
2232          sslipj=sscalelip(fracinbuf)
2233          ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
2234         else
2235          sslipj=1.0d0
2236          ssgradlipj=0.0
2237         endif
2238        else
2239          sslipj=0.0d0
2240          ssgradlipj=0.0
2241        endif
2242       aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
2243      &  +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
2244       bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
2245      &  +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
2246 C      if (aa.ne.aa_aq(itypi,itypj)) write(63,'2e10.5')
2247 C     &(aa-aa_aq(itypi,itypj)),(bb-bb_aq(itypi,itypj))
2248 C      write(iout,*) "tu,", i,j,aa,bb,aa_lip(itypi,itypj),sslipi,sslipj
2249       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
2250       xj_safe=xj
2251       yj_safe=yj
2252       zj_safe=zj
2253       subchap=0
2254       do xshift=-1,1
2255       do yshift=-1,1
2256       do zshift=-1,1
2257           xj=xj_safe+xshift*boxxsize
2258           yj=yj_safe+yshift*boxysize
2259           zj=zj_safe+zshift*boxzsize
2260           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
2261           if(dist_temp.lt.dist_init) then
2262             dist_init=dist_temp
2263             xj_temp=xj
2264             yj_temp=yj
2265             zj_temp=zj
2266             subchap=1
2267           endif
2268        enddo
2269        enddo
2270        enddo
2271        if (subchap.eq.1) then
2272           xj=xj_temp-xi
2273           yj=yj_temp-yi
2274           zj=zj_temp-zi
2275        else
2276           xj=xj_safe-xi
2277           yj=yj_safe-yi
2278           zj=zj_safe-zi
2279        endif
2280             dxj=dc_norm(1,nres+j)
2281             dyj=dc_norm(2,nres+j)
2282             dzj=dc_norm(3,nres+j)
2283             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
2284             rij=dsqrt(rrij)
2285 C Calculate angle-dependent terms of energy and contributions to their
2286 C derivatives.
2287             call sc_angular
2288             sigsq=1.0D0/sigsq
2289             sig=sig0ij*dsqrt(sigsq)
2290             rij_shift=1.0D0/rij-sig+r0ij
2291 C I hate to put IF's in the loops, but here don't have another choice!!!!
2292             if (rij_shift.le.0.0D0) then
2293               evdw=1.0D20
2294               return
2295             endif
2296             sigder=-sig*sigsq
2297 c---------------------------------------------------------------
2298             rij_shift=1.0D0/rij_shift
2299             fac=rij_shift**expon
2300             e1=fac*fac*aa
2301             e2=fac*bb
2302             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
2303             eps2der=evdwij*eps3rt
2304             eps3der=evdwij*eps2rt
2305             fac_augm=rrij**expon
2306             e_augm=augm(itypi,itypj)*fac_augm
2307             evdwij=evdwij*eps2rt*eps3rt
2308             evdw=evdw+evdwij+e_augm
2309             if (lprn) then
2310             sigm=dabs(aa/bb)**(1.0D0/6.0D0)
2311             epsi=bb**2/aa
2312             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
2313      &        restyp(itypi),i,restyp(itypj),j,
2314      &        epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),
2315      &        chi1,chi2,chip1,chip2,
2316      &        eps1,eps2rt**2,eps3rt**2,
2317      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
2318      &        evdwij+e_augm
2319             endif
2320 C Calculate gradient components.
2321             e1=e1*eps1*eps2rt**2*eps3rt**2
2322             fac=-expon*(e1+evdwij)*rij_shift
2323             sigder=fac*sigder
2324             fac=rij*fac-2*expon*rrij*e_augm
2325             fac=fac+evdwij/sss*sssgrad/sigma(itypi,itypj)*rij
2326 C Calculate the radial part of the gradient
2327             gg(1)=xj*fac
2328             gg(2)=yj*fac
2329             gg(3)=zj*fac
2330 C Calculate angular part of the gradient.
2331             call sc_grad
2332           enddo      ! j
2333         enddo        ! iint
2334       enddo          ! i
2335       end
2336 C-----------------------------------------------------------------------------
2337       subroutine sc_angular
2338 C Calculate eps1,eps2,eps3,sigma, and parts of their derivatives in om1,om2,
2339 C om12. Called by ebp, egb, and egbv.
2340       implicit none
2341       include 'COMMON.CALC'
2342       include 'COMMON.IOUNITS'
2343       erij(1)=xj*rij
2344       erij(2)=yj*rij
2345       erij(3)=zj*rij
2346       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
2347       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
2348       om12=dxi*dxj+dyi*dyj+dzi*dzj
2349       chiom12=chi12*om12
2350 C Calculate eps1(om12) and its derivative in om12
2351       faceps1=1.0D0-om12*chiom12
2352       faceps1_inv=1.0D0/faceps1
2353       eps1=dsqrt(faceps1_inv)
2354 C Following variable is eps1*deps1/dom12
2355       eps1_om12=faceps1_inv*chiom12
2356 c diagnostics only
2357 c      faceps1_inv=om12
2358 c      eps1=om12
2359 c      eps1_om12=1.0d0
2360 c      write (iout,*) "om12",om12," eps1",eps1
2361 C Calculate sigma(om1,om2,om12) and the derivatives of sigma**2 in om1,om2,
2362 C and om12.
2363       om1om2=om1*om2
2364       chiom1=chi1*om1
2365       chiom2=chi2*om2
2366       facsig=om1*chiom1+om2*chiom2-2.0D0*om1om2*chiom12
2367       sigsq=1.0D0-facsig*faceps1_inv
2368       sigsq_om1=(chiom1-chiom12*om2)*faceps1_inv
2369       sigsq_om2=(chiom2-chiom12*om1)*faceps1_inv
2370       sigsq_om12=-chi12*(om1om2*faceps1-om12*facsig)*faceps1_inv**2
2371 c diagnostics only
2372 c      sigsq=1.0d0
2373 c      sigsq_om1=0.0d0
2374 c      sigsq_om2=0.0d0
2375 c      sigsq_om12=0.0d0
2376 c      write (iout,*) "chiom1",chiom1," chiom2",chiom2," chiom12",chiom12
2377 c      write (iout,*) "faceps1",faceps1," faceps1_inv",faceps1_inv,
2378 c     &    " eps1",eps1
2379 C Calculate eps2 and its derivatives in om1, om2, and om12.
2380       chipom1=chip1*om1
2381       chipom2=chip2*om2
2382       chipom12=chip12*om12
2383       facp=1.0D0-om12*chipom12
2384       facp_inv=1.0D0/facp
2385       facp1=om1*chipom1+om2*chipom2-2.0D0*om1om2*chipom12
2386 c      write (iout,*) "chipom1",chipom1," chipom2",chipom2,
2387 c     &  " chipom12",chipom12," facp",facp," facp_inv",facp_inv
2388 C Following variable is the square root of eps2
2389       eps2rt=1.0D0-facp1*facp_inv
2390 C Following three variables are the derivatives of the square root of eps
2391 C in om1, om2, and om12.
2392       eps2rt_om1=-4.0D0*(chipom1-chipom12*om2)*facp_inv
2393       eps2rt_om2=-4.0D0*(chipom2-chipom12*om1)*facp_inv
2394       eps2rt_om12=4.0D0*chip12*(om1om2*facp-om12*facp1)*facp_inv**2
2395 C Evaluate the "asymmetric" factor in the VDW constant, eps3
2396       eps3rt=1.0D0-alf1*om1+alf2*om2-alf12*om12
2397 c      write (iout,*) "eps2rt",eps2rt," eps3rt",eps3rt
2398 c      write (iout,*) "eps2rt_om1",eps2rt_om1," eps2rt_om2",eps2rt_om2,
2399 c     &  " eps2rt_om12",eps2rt_om12
2400 C Calculate whole angle-dependent part of epsilon and contributions
2401 C to its derivatives
2402       return
2403       end
2404 C----------------------------------------------------------------------------
2405       subroutine sc_grad
2406       implicit real*8 (a-h,o-z)
2407       include 'DIMENSIONS'
2408       include 'COMMON.CHAIN'
2409       include 'COMMON.DERIV'
2410       include 'COMMON.CALC'
2411       include 'COMMON.IOUNITS'
2412       double precision dcosom1(3),dcosom2(3)
2413 cc      print *,'sss=',sss
2414       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
2415       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
2416       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12
2417      &     -2.0D0*alf12*eps3der+sigder*sigsq_om12
2418 c diagnostics only
2419 c      eom1=0.0d0
2420 c      eom2=0.0d0
2421 c      eom12=evdwij*eps1_om12
2422 c end diagnostics
2423 c      write (iout,*) "eps2der",eps2der," eps3der",eps3der,
2424 c     &  " sigder",sigder
2425 c      write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12
2426 c      write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12
2427       do k=1,3
2428         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
2429         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
2430       enddo
2431       do k=1,3
2432         gg(k)=(gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k))*sss
2433       enddo
2434 c      write (iout,*) "gg",(gg(k),k=1,3)
2435       do k=1,3
2436         gvdwx(k,i)=gvdwx(k,i)-gg(k)+gg_lipi(k)
2437      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
2438      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv*sss
2439         gvdwx(k,j)=gvdwx(k,j)+gg(k)+gg_lipj(k)
2440      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
2441      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv*sss
2442 c        write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
2443 c     &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
2444 c        write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
2445 c     &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
2446       enddo
2447 C
2448 C Calculate the components of the gradient in DC and X
2449 C
2450 cgrad      do k=i,j-1
2451 cgrad        do l=1,3
2452 cgrad          gvdwc(l,k)=gvdwc(l,k)+gg(l)
2453 cgrad        enddo
2454 cgrad      enddo
2455       do l=1,3
2456         gvdwc(l,i)=gvdwc(l,i)-gg(l)+gg_lipi(l)
2457         gvdwc(l,j)=gvdwc(l,j)+gg(l)+gg_lipj(l)
2458       enddo
2459       return
2460       end
2461 C-----------------------------------------------------------------------
2462       subroutine e_softsphere(evdw)
2463 C
2464 C This subroutine calculates the interaction energy of nonbonded side chains
2465 C assuming the LJ potential of interaction.
2466 C
2467       implicit real*8 (a-h,o-z)
2468       include 'DIMENSIONS'
2469       parameter (accur=1.0d-10)
2470       include 'COMMON.GEO'
2471       include 'COMMON.VAR'
2472       include 'COMMON.LOCAL'
2473       include 'COMMON.CHAIN'
2474       include 'COMMON.DERIV'
2475       include 'COMMON.INTERACT'
2476       include 'COMMON.TORSION'
2477       include 'COMMON.SBRIDGE'
2478       include 'COMMON.NAMES'
2479       include 'COMMON.IOUNITS'
2480       include 'COMMON.CONTACTS'
2481       dimension gg(3)
2482 cd    print *,'Entering Esoft_sphere nnt=',nnt,' nct=',nct
2483       evdw=0.0D0
2484       do i=iatsc_s,iatsc_e
2485         itypi=iabs(itype(i))
2486         if (itypi.eq.ntyp1) cycle
2487         itypi1=iabs(itype(i+1))
2488         xi=c(1,nres+i)
2489         yi=c(2,nres+i)
2490         zi=c(3,nres+i)
2491 C
2492 C Calculate SC interaction energy.
2493 C
2494         do iint=1,nint_gr(i)
2495 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
2496 cd   &                  'iend=',iend(i,iint)
2497           do j=istart(i,iint),iend(i,iint)
2498             itypj=iabs(itype(j))
2499             if (itypj.eq.ntyp1) cycle
2500             xj=c(1,nres+j)-xi
2501             yj=c(2,nres+j)-yi
2502             zj=c(3,nres+j)-zi
2503             rij=xj*xj+yj*yj+zj*zj
2504 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
2505             r0ij=r0(itypi,itypj)
2506             r0ijsq=r0ij*r0ij
2507 c            print *,i,j,r0ij,dsqrt(rij)
2508             if (rij.lt.r0ijsq) then
2509               evdwij=0.25d0*(rij-r0ijsq)**2
2510               fac=rij-r0ijsq
2511             else
2512               evdwij=0.0d0
2513               fac=0.0d0
2514             endif
2515             evdw=evdw+evdwij
2516 C
2517 C Calculate the components of the gradient in DC and X
2518 C
2519             gg(1)=xj*fac
2520             gg(2)=yj*fac
2521             gg(3)=zj*fac
2522             do k=1,3
2523               gvdwx(k,i)=gvdwx(k,i)-gg(k)
2524               gvdwx(k,j)=gvdwx(k,j)+gg(k)
2525               gvdwc(k,i)=gvdwc(k,i)-gg(k)
2526               gvdwc(k,j)=gvdwc(k,j)+gg(k)
2527             enddo
2528 cgrad            do k=i,j-1
2529 cgrad              do l=1,3
2530 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
2531 cgrad              enddo
2532 cgrad            enddo
2533           enddo ! j
2534         enddo ! iint
2535       enddo ! i
2536       return
2537       end
2538 C--------------------------------------------------------------------------
2539       subroutine eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,
2540      &              eello_turn4)
2541 C
2542 C Soft-sphere potential of p-p interaction
2543 C
2544       implicit real*8 (a-h,o-z)
2545       include 'DIMENSIONS'
2546       include 'COMMON.CONTROL'
2547       include 'COMMON.IOUNITS'
2548       include 'COMMON.GEO'
2549       include 'COMMON.VAR'
2550       include 'COMMON.LOCAL'
2551       include 'COMMON.CHAIN'
2552       include 'COMMON.DERIV'
2553       include 'COMMON.INTERACT'
2554       include 'COMMON.CONTACTS'
2555       include 'COMMON.TORSION'
2556       include 'COMMON.VECTORS'
2557       include 'COMMON.FFIELD'
2558       dimension ggg(3)
2559       integer xshift,yshift,zshift
2560 C      write(iout,*) 'In EELEC_soft_sphere'
2561       ees=0.0D0
2562       evdw1=0.0D0
2563       eel_loc=0.0d0
2564       eello_turn3=0.0d0
2565       eello_turn4=0.0d0
2566       ind=0
2567       do i=iatel_s,iatel_e
2568         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
2569         dxi=dc(1,i)
2570         dyi=dc(2,i)
2571         dzi=dc(3,i)
2572         xmedi=c(1,i)+0.5d0*dxi
2573         ymedi=c(2,i)+0.5d0*dyi
2574         zmedi=c(3,i)+0.5d0*dzi
2575           xmedi=mod(xmedi,boxxsize)
2576           if (xmedi.lt.0) xmedi=xmedi+boxxsize
2577           ymedi=mod(ymedi,boxysize)
2578           if (ymedi.lt.0) ymedi=ymedi+boxysize
2579           zmedi=mod(zmedi,boxzsize)
2580           if (zmedi.lt.0) zmedi=zmedi+boxzsize
2581         num_conti=0
2582 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
2583         do j=ielstart(i),ielend(i)
2584           if (itype(j).eq.ntyp1 .or. itype(j+1).eq.ntyp1) cycle
2585           ind=ind+1
2586           iteli=itel(i)
2587           itelj=itel(j)
2588           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
2589           r0ij=rpp(iteli,itelj)
2590           r0ijsq=r0ij*r0ij
2591           dxj=dc(1,j)
2592           dyj=dc(2,j)
2593           dzj=dc(3,j)
2594           xj=c(1,j)+0.5D0*dxj
2595           yj=c(2,j)+0.5D0*dyj
2596           zj=c(3,j)+0.5D0*dzj
2597           xj=mod(xj,boxxsize)
2598           if (xj.lt.0) xj=xj+boxxsize
2599           yj=mod(yj,boxysize)
2600           if (yj.lt.0) yj=yj+boxysize
2601           zj=mod(zj,boxzsize)
2602           if (zj.lt.0) zj=zj+boxzsize
2603       dist_init=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
2604       xj_safe=xj
2605       yj_safe=yj
2606       zj_safe=zj
2607       isubchap=0
2608       do xshift=-1,1
2609       do yshift=-1,1
2610       do zshift=-1,1
2611           xj=xj_safe+xshift*boxxsize
2612           yj=yj_safe+yshift*boxysize
2613           zj=zj_safe+zshift*boxzsize
2614           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
2615           if(dist_temp.lt.dist_init) then
2616             dist_init=dist_temp
2617             xj_temp=xj
2618             yj_temp=yj
2619             zj_temp=zj
2620             isubchap=1
2621           endif
2622        enddo
2623        enddo
2624        enddo
2625        if (isubchap.eq.1) then
2626           xj=xj_temp-xmedi
2627           yj=yj_temp-ymedi
2628           zj=zj_temp-zmedi
2629        else
2630           xj=xj_safe-xmedi
2631           yj=yj_safe-ymedi
2632           zj=zj_safe-zmedi
2633        endif
2634           rij=xj*xj+yj*yj+zj*zj
2635             sss=sscale(sqrt(rij))
2636             sssgrad=sscagrad(sqrt(rij))
2637           if (rij.lt.r0ijsq) then
2638             evdw1ij=0.25d0*(rij-r0ijsq)**2
2639             fac=rij-r0ijsq
2640           else
2641             evdw1ij=0.0d0
2642             fac=0.0d0
2643           endif
2644           evdw1=evdw1+evdw1ij*sss
2645 C
2646 C Calculate contributions to the Cartesian gradient.
2647 C
2648           ggg(1)=fac*xj*sssgrad
2649           ggg(2)=fac*yj*sssgrad
2650           ggg(3)=fac*zj*sssgrad
2651           do k=1,3
2652             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
2653             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
2654           enddo
2655 *
2656 * Loop over residues i+1 thru j-1.
2657 *
2658 cgrad          do k=i+1,j-1
2659 cgrad            do l=1,3
2660 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
2661 cgrad            enddo
2662 cgrad          enddo
2663         enddo ! j
2664       enddo   ! i
2665 cgrad      do i=nnt,nct-1
2666 cgrad        do k=1,3
2667 cgrad          gelc(k,i)=gelc(k,i)+0.5d0*gelc(k,i)
2668 cgrad        enddo
2669 cgrad        do j=i+1,nct-1
2670 cgrad          do k=1,3
2671 cgrad            gelc(k,i)=gelc(k,i)+gelc(k,j)
2672 cgrad          enddo
2673 cgrad        enddo
2674 cgrad      enddo
2675       return
2676       end
2677 c------------------------------------------------------------------------------
2678       subroutine vec_and_deriv
2679       implicit real*8 (a-h,o-z)
2680       include 'DIMENSIONS'
2681 #ifdef MPI
2682       include 'mpif.h'
2683 #endif
2684       include 'COMMON.IOUNITS'
2685       include 'COMMON.GEO'
2686       include 'COMMON.VAR'
2687       include 'COMMON.LOCAL'
2688       include 'COMMON.CHAIN'
2689       include 'COMMON.VECTORS'
2690       include 'COMMON.SETUP'
2691       include 'COMMON.TIME1'
2692       dimension uyder(3,3,2),uzder(3,3,2),vbld_inv_temp(2)
2693 C Compute the local reference systems. For reference system (i), the
2694 C X-axis points from CA(i) to CA(i+1), the Y axis is in the
2695 C CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
2696 #ifdef PARVEC
2697       do i=ivec_start,ivec_end
2698 #else
2699       do i=1,nres-1
2700 #endif
2701           if (i.eq.nres-1) then
2702 C Case of the last full residue
2703 C Compute the Z-axis
2704             call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
2705             costh=dcos(pi-theta(nres))
2706             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2707             do k=1,3
2708               uz(k,i)=fac*uz(k,i)
2709             enddo
2710 C Compute the derivatives of uz
2711             uzder(1,1,1)= 0.0d0
2712             uzder(2,1,1)=-dc_norm(3,i-1)
2713             uzder(3,1,1)= dc_norm(2,i-1)
2714             uzder(1,2,1)= dc_norm(3,i-1)
2715             uzder(2,2,1)= 0.0d0
2716             uzder(3,2,1)=-dc_norm(1,i-1)
2717             uzder(1,3,1)=-dc_norm(2,i-1)
2718             uzder(2,3,1)= dc_norm(1,i-1)
2719             uzder(3,3,1)= 0.0d0
2720             uzder(1,1,2)= 0.0d0
2721             uzder(2,1,2)= dc_norm(3,i)
2722             uzder(3,1,2)=-dc_norm(2,i)
2723             uzder(1,2,2)=-dc_norm(3,i)
2724             uzder(2,2,2)= 0.0d0
2725             uzder(3,2,2)= dc_norm(1,i)
2726             uzder(1,3,2)= dc_norm(2,i)
2727             uzder(2,3,2)=-dc_norm(1,i)
2728             uzder(3,3,2)= 0.0d0
2729 C Compute the Y-axis
2730             facy=fac
2731             do k=1,3
2732               uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
2733             enddo
2734 C Compute the derivatives of uy
2735             do j=1,3
2736               do k=1,3
2737                 uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i)
2738      &                        -dc_norm(k,i)*dc_norm(j,i-1)
2739                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2740               enddo
2741               uyder(j,j,1)=uyder(j,j,1)-costh
2742               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2743             enddo
2744             do j=1,2
2745               do k=1,3
2746                 do l=1,3
2747                   uygrad(l,k,j,i)=uyder(l,k,j)
2748                   uzgrad(l,k,j,i)=uzder(l,k,j)
2749                 enddo
2750               enddo
2751             enddo
2752             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2753             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2754             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2755             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2756           else
2757 C Other residues
2758 C Compute the Z-axis
2759             call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
2760             costh=dcos(pi-theta(i+2))
2761             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2762             do k=1,3
2763               uz(k,i)=fac*uz(k,i)
2764             enddo
2765 C Compute the derivatives of uz
2766             uzder(1,1,1)= 0.0d0
2767             uzder(2,1,1)=-dc_norm(3,i+1)
2768             uzder(3,1,1)= dc_norm(2,i+1)
2769             uzder(1,2,1)= dc_norm(3,i+1)
2770             uzder(2,2,1)= 0.0d0
2771             uzder(3,2,1)=-dc_norm(1,i+1)
2772             uzder(1,3,1)=-dc_norm(2,i+1)
2773             uzder(2,3,1)= dc_norm(1,i+1)
2774             uzder(3,3,1)= 0.0d0
2775             uzder(1,1,2)= 0.0d0
2776             uzder(2,1,2)= dc_norm(3,i)
2777             uzder(3,1,2)=-dc_norm(2,i)
2778             uzder(1,2,2)=-dc_norm(3,i)
2779             uzder(2,2,2)= 0.0d0
2780             uzder(3,2,2)= dc_norm(1,i)
2781             uzder(1,3,2)= dc_norm(2,i)
2782             uzder(2,3,2)=-dc_norm(1,i)
2783             uzder(3,3,2)= 0.0d0
2784 C Compute the Y-axis
2785             facy=fac
2786             do k=1,3
2787               uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
2788             enddo
2789 C Compute the derivatives of uy
2790             do j=1,3
2791               do k=1,3
2792                 uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i)
2793      &                        -dc_norm(k,i)*dc_norm(j,i+1)
2794                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2795               enddo
2796               uyder(j,j,1)=uyder(j,j,1)-costh
2797               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2798             enddo
2799             do j=1,2
2800               do k=1,3
2801                 do l=1,3
2802                   uygrad(l,k,j,i)=uyder(l,k,j)
2803                   uzgrad(l,k,j,i)=uzder(l,k,j)
2804                 enddo
2805               enddo
2806             enddo
2807             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2808             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2809             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2810             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2811           endif
2812       enddo
2813       do i=1,nres-1
2814         vbld_inv_temp(1)=vbld_inv(i+1)
2815         if (i.lt.nres-1) then
2816           vbld_inv_temp(2)=vbld_inv(i+2)
2817           else
2818           vbld_inv_temp(2)=vbld_inv(i)
2819           endif
2820         do j=1,2
2821           do k=1,3
2822             do l=1,3
2823               uygrad(l,k,j,i)=vbld_inv_temp(j)*uygrad(l,k,j,i)
2824               uzgrad(l,k,j,i)=vbld_inv_temp(j)*uzgrad(l,k,j,i)
2825             enddo
2826           enddo
2827         enddo
2828       enddo
2829 #if defined(PARVEC) && defined(MPI)
2830       if (nfgtasks1.gt.1) then
2831         time00=MPI_Wtime()
2832 c        print *,"Processor",fg_rank1,kolor1," ivec_start",ivec_start,
2833 c     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks1-1),
2834 c     &   " ivec_count",(ivec_count(i),i=0,nfgtasks1-1)
2835         call MPI_Allgatherv(uy(1,ivec_start),ivec_count(fg_rank1),
2836      &   MPI_UYZ,uy(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
2837      &   FG_COMM1,IERR)
2838         call MPI_Allgatherv(uz(1,ivec_start),ivec_count(fg_rank1),
2839      &   MPI_UYZ,uz(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
2840      &   FG_COMM1,IERR)
2841         call MPI_Allgatherv(uygrad(1,1,1,ivec_start),
2842      &   ivec_count(fg_rank1),MPI_UYZGRAD,uygrad(1,1,1,1),ivec_count(0),
2843      &   ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2844         call MPI_Allgatherv(uzgrad(1,1,1,ivec_start),
2845      &   ivec_count(fg_rank1),MPI_UYZGRAD,uzgrad(1,1,1,1),ivec_count(0),
2846      &   ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2847         time_gather=time_gather+MPI_Wtime()-time00
2848       endif
2849 #endif
2850 #ifdef DEBUG
2851       if (fg_rank.eq.0) then
2852         write (iout,*) "Arrays UY and UZ"
2853         do i=1,nres-1
2854           write (iout,'(i5,3f10.5,5x,3f10.5)') i,(uy(k,i),k=1,3),
2855      &     (uz(k,i),k=1,3)
2856         enddo
2857       endif
2858 #endif
2859       return
2860       end
2861 C-----------------------------------------------------------------------------
2862       subroutine check_vecgrad
2863       implicit real*8 (a-h,o-z)
2864       include 'DIMENSIONS'
2865       include 'COMMON.IOUNITS'
2866       include 'COMMON.GEO'
2867       include 'COMMON.VAR'
2868       include 'COMMON.LOCAL'
2869       include 'COMMON.CHAIN'
2870       include 'COMMON.VECTORS'
2871       dimension uygradt(3,3,2,maxres),uzgradt(3,3,2,maxres)
2872       dimension uyt(3,maxres),uzt(3,maxres)
2873       dimension uygradn(3,3,2),uzgradn(3,3,2),erij(3)
2874       double precision delta /1.0d-7/
2875       call vec_and_deriv
2876 cd      do i=1,nres
2877 crc          write(iout,'(2i5,2(3f10.5,5x))') i,1,dc_norm(:,i)
2878 crc          write(iout,'(2i5,2(3f10.5,5x))') i,2,uy(:,i)
2879 crc          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,uz(:,i)
2880 cd          write(iout,'(2i5,2(3f10.5,5x))') i,1,
2881 cd     &     (dc_norm(if90,i),if90=1,3)
2882 cd          write(iout,'(2i5,2(3f10.5,5x))') i,2,(uy(if90,i),if90=1,3)
2883 cd          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,(uz(if90,i),if90=1,3)
2884 cd          write(iout,'(a)')
2885 cd      enddo
2886       do i=1,nres
2887         do j=1,2
2888           do k=1,3
2889             do l=1,3
2890               uygradt(l,k,j,i)=uygrad(l,k,j,i)
2891               uzgradt(l,k,j,i)=uzgrad(l,k,j,i)
2892             enddo
2893           enddo
2894         enddo
2895       enddo
2896       call vec_and_deriv
2897       do i=1,nres
2898         do j=1,3
2899           uyt(j,i)=uy(j,i)
2900           uzt(j,i)=uz(j,i)
2901         enddo
2902       enddo
2903       do i=1,nres
2904 cd        write (iout,*) 'i=',i
2905         do k=1,3
2906           erij(k)=dc_norm(k,i)
2907         enddo
2908         do j=1,3
2909           do k=1,3
2910             dc_norm(k,i)=erij(k)
2911           enddo
2912           dc_norm(j,i)=dc_norm(j,i)+delta
2913 c          fac=dsqrt(scalar(dc_norm(1,i),dc_norm(1,i)))
2914 c          do k=1,3
2915 c            dc_norm(k,i)=dc_norm(k,i)/fac
2916 c          enddo
2917 c          write (iout,*) (dc_norm(k,i),k=1,3)
2918 c          write (iout,*) (erij(k),k=1,3)
2919           call vec_and_deriv
2920           do k=1,3
2921             uygradn(k,j,1)=(uy(k,i)-uyt(k,i))/delta
2922             uygradn(k,j,2)=(uy(k,i-1)-uyt(k,i-1))/delta
2923             uzgradn(k,j,1)=(uz(k,i)-uzt(k,i))/delta
2924             uzgradn(k,j,2)=(uz(k,i-1)-uzt(k,i-1))/delta
2925           enddo
2926 c          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2927 c     &      j,(uzgradt(k,j,1,i),k=1,3),(uzgradn(k,j,1),k=1,3),
2928 c     &      (uzgradt(k,j,2,i-1),k=1,3),(uzgradn(k,j,2),k=1,3)
2929         enddo
2930         do k=1,3
2931           dc_norm(k,i)=erij(k)
2932         enddo
2933 cd        do k=1,3
2934 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2935 cd     &      k,(uygradt(k,l,1,i),l=1,3),(uygradn(k,l,1),l=1,3),
2936 cd     &      (uygradt(k,l,2,i-1),l=1,3),(uygradn(k,l,2),l=1,3)
2937 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2938 cd     &      k,(uzgradt(k,l,1,i),l=1,3),(uzgradn(k,l,1),l=1,3),
2939 cd     &      (uzgradt(k,l,2,i-1),l=1,3),(uzgradn(k,l,2),l=1,3)
2940 cd          write (iout,'(a)')
2941 cd        enddo
2942       enddo
2943       return
2944       end
2945 C--------------------------------------------------------------------------
2946       subroutine set_matrices
2947       implicit real*8 (a-h,o-z)
2948       include 'DIMENSIONS'
2949 #ifdef MPI
2950       include "mpif.h"
2951       include "COMMON.SETUP"
2952       integer IERR
2953       integer status(MPI_STATUS_SIZE)
2954 #endif
2955       include 'COMMON.IOUNITS'
2956       include 'COMMON.GEO'
2957       include 'COMMON.VAR'
2958       include 'COMMON.LOCAL'
2959       include 'COMMON.CHAIN'
2960       include 'COMMON.DERIV'
2961       include 'COMMON.INTERACT'
2962       include 'COMMON.CONTACTS'
2963       include 'COMMON.TORSION'
2964       include 'COMMON.VECTORS'
2965       include 'COMMON.FFIELD'
2966       double precision auxvec(2),auxmat(2,2)
2967 C
2968 C Compute the virtual-bond-torsional-angle dependent quantities needed
2969 C to calculate the el-loc multibody terms of various order.
2970 C
2971 c      write(iout,*) 'nphi=',nphi,nres
2972 c      write(iout,*) "itype2loc",itype2loc
2973 #ifdef PARMAT
2974       do i=ivec_start+2,ivec_end+2
2975 #else
2976       do i=3,nres+1
2977 #endif
2978         if (i.gt. nnt+2 .and. i.lt.nct+2) then
2979           iti = itype2loc(itype(i-2))
2980         else
2981           iti=nloctyp
2982         endif
2983 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2984         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2985           iti1 = itype2loc(itype(i-1))
2986         else
2987           iti1=nloctyp
2988         endif
2989 c        write(iout,*),i
2990 #ifdef NEWCORR
2991         cost1=dcos(theta(i-1))
2992         sint1=dsin(theta(i-1))
2993         sint1sq=sint1*sint1
2994         sint1cub=sint1sq*sint1
2995         sint1cost1=2*sint1*cost1
2996 c        write (iout,*) "bnew1",i,iti
2997 c        write (iout,*) (bnew1(k,1,iti),k=1,3)
2998 c        write (iout,*) (bnew1(k,2,iti),k=1,3)
2999 c        write (iout,*) "bnew2",i,iti
3000 c        write (iout,*) (bnew2(k,1,iti),k=1,3)
3001 c        write (iout,*) (bnew2(k,2,iti),k=1,3)
3002         do k=1,2
3003           b1k=bnew1(1,k,iti)+(bnew1(2,k,iti)+bnew1(3,k,iti)*cost1)*cost1
3004           b1(k,i-2)=sint1*b1k
3005           gtb1(k,i-2)=cost1*b1k-sint1sq*
3006      &              (bnew1(2,k,iti)+2*bnew1(3,k,iti)*cost1)
3007           b2k=bnew2(1,k,iti)+(bnew2(2,k,iti)+bnew2(3,k,iti)*cost1)*cost1
3008           b2(k,i-2)=sint1*b2k
3009           gtb2(k,i-2)=cost1*b2k-sint1sq*
3010      &              (bnew2(2,k,iti)+2*bnew2(3,k,iti)*cost1)
3011         enddo
3012         do k=1,2
3013           aux=ccnew(1,k,iti)+(ccnew(2,k,iti)+ccnew(3,k,iti)*cost1)*cost1
3014           cc(1,k,i-2)=sint1sq*aux
3015           gtcc(1,k,i-2)=sint1cost1*aux-sint1cub*
3016      &              (ccnew(2,k,iti)+2*ccnew(3,k,iti)*cost1)
3017           aux=ddnew(1,k,iti)+(ddnew(2,k,iti)+ddnew(3,k,iti)*cost1)*cost1
3018           dd(1,k,i-2)=sint1sq*aux
3019           gtdd(1,k,i-2)=sint1cost1*aux-sint1cub*
3020      &              (ddnew(2,k,iti)+2*ddnew(3,k,iti)*cost1)
3021         enddo
3022         cc(2,1,i-2)=cc(1,2,i-2)
3023         cc(2,2,i-2)=-cc(1,1,i-2)
3024         gtcc(2,1,i-2)=gtcc(1,2,i-2)
3025         gtcc(2,2,i-2)=-gtcc(1,1,i-2)
3026         dd(2,1,i-2)=dd(1,2,i-2)
3027         dd(2,2,i-2)=-dd(1,1,i-2)
3028         gtdd(2,1,i-2)=gtdd(1,2,i-2)
3029         gtdd(2,2,i-2)=-gtdd(1,1,i-2)
3030         do k=1,2
3031           do l=1,2
3032             aux=eenew(1,l,k,iti)+eenew(2,l,k,iti)*cost1
3033             EE(l,k,i-2)=sint1sq*aux
3034             gtEE(l,k,i-2)=sint1cost1*aux-sint1cub*eenew(2,l,k,iti)
3035           enddo
3036         enddo
3037         EE(1,1,i-2)=EE(1,1,i-2)+e0new(1,iti)*cost1
3038         EE(1,2,i-2)=EE(1,2,i-2)+e0new(2,iti)+e0new(3,iti)*cost1
3039         EE(2,1,i-2)=EE(2,1,i-2)+e0new(2,iti)*cost1+e0new(3,iti)
3040         EE(2,2,i-2)=EE(2,2,i-2)-e0new(1,iti)
3041         gtEE(1,1,i-2)=gtEE(1,1,i-2)-e0new(1,iti)*sint1
3042         gtEE(1,2,i-2)=gtEE(1,2,i-2)-e0new(3,iti)*sint1
3043         gtEE(2,1,i-2)=gtEE(2,1,i-2)-e0new(2,iti)*sint1
3044 c        b1tilde(1,i-2)=b1(1,i-2)
3045 c        b1tilde(2,i-2)=-b1(2,i-2)
3046 c        b2tilde(1,i-2)=b2(1,i-2)
3047 c        b2tilde(2,i-2)=-b2(2,i-2)
3048 #ifdef DEBUG
3049         write (iout,*) 'i=',i-2,gtb1(2,i-2),gtb1(1,i-2)
3050         write(iout,*)  'b1=',(b1(k,i-2),k=1,2)
3051         write(iout,*)  'b2=',(b2(k,i-2),k=1,2)
3052         write (iout,*) 'theta=', theta(i-1)
3053 #endif
3054 #else
3055         if (i.gt. nnt+2 .and. i.lt.nct+2) then
3056           iti = itype2loc(itype(i-2))
3057         else
3058           iti=nloctyp
3059         endif
3060 c        write (iout,*) "i",i-1," itype",itype(i-2)," iti",iti
3061 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
3062         if (i.gt. nnt+1 .and. i.lt.nct+1) then
3063           iti1 = itype2loc(itype(i-1))
3064         else
3065           iti1=nloctyp
3066         endif
3067         b1(1,i-2)=b(3,iti)
3068         b1(2,i-2)=b(5,iti)
3069         b2(1,i-2)=b(2,iti)
3070         b2(2,i-2)=b(4,iti)
3071         do k=1,2
3072           do l=1,2
3073            CC(k,l,i-2)=ccold(k,l,iti)
3074            DD(k,l,i-2)=ddold(k,l,iti)
3075            EE(k,l,i-2)=eeold(k,l,iti)
3076            gtEE(k,l,i-2)=0.0d0
3077           enddo
3078         enddo
3079 #endif
3080         b1tilde(1,i-2)= b1(1,i-2)
3081         b1tilde(2,i-2)=-b1(2,i-2)
3082         b2tilde(1,i-2)= b2(1,i-2)
3083         b2tilde(2,i-2)=-b2(2,i-2)
3084 c
3085         Ctilde(1,1,i-2)= CC(1,1,i-2)
3086         Ctilde(1,2,i-2)= CC(1,2,i-2)
3087         Ctilde(2,1,i-2)=-CC(2,1,i-2)
3088         Ctilde(2,2,i-2)=-CC(2,2,i-2)
3089 c
3090         Dtilde(1,1,i-2)= DD(1,1,i-2)
3091         Dtilde(1,2,i-2)= DD(1,2,i-2)
3092         Dtilde(2,1,i-2)=-DD(2,1,i-2)
3093         Dtilde(2,2,i-2)=-DD(2,2,i-2)
3094 #ifdef DEBUG
3095         write(iout,*) "i",i," iti",iti
3096         write(iout,*)  'b1=',(b1(k,i-2),k=1,2)
3097         write(iout,*)  'b2=',(b2(k,i-2),k=1,2)
3098 #endif
3099       enddo
3100 #ifdef PARMAT
3101       do i=ivec_start+2,ivec_end+2
3102 #else
3103       do i=3,nres+1
3104 #endif
3105         if (i .lt. nres+1) then
3106           sin1=dsin(phi(i))
3107           cos1=dcos(phi(i))
3108           sintab(i-2)=sin1
3109           costab(i-2)=cos1
3110           obrot(1,i-2)=cos1
3111           obrot(2,i-2)=sin1
3112           sin2=dsin(2*phi(i))
3113           cos2=dcos(2*phi(i))
3114           sintab2(i-2)=sin2
3115           costab2(i-2)=cos2
3116           obrot2(1,i-2)=cos2
3117           obrot2(2,i-2)=sin2
3118           Ug(1,1,i-2)=-cos1
3119           Ug(1,2,i-2)=-sin1
3120           Ug(2,1,i-2)=-sin1
3121           Ug(2,2,i-2)= cos1
3122           Ug2(1,1,i-2)=-cos2
3123           Ug2(1,2,i-2)=-sin2
3124           Ug2(2,1,i-2)=-sin2
3125           Ug2(2,2,i-2)= cos2
3126         else
3127           costab(i-2)=1.0d0
3128           sintab(i-2)=0.0d0
3129           obrot(1,i-2)=1.0d0
3130           obrot(2,i-2)=0.0d0
3131           obrot2(1,i-2)=0.0d0
3132           obrot2(2,i-2)=0.0d0
3133           Ug(1,1,i-2)=1.0d0
3134           Ug(1,2,i-2)=0.0d0
3135           Ug(2,1,i-2)=0.0d0
3136           Ug(2,2,i-2)=1.0d0
3137           Ug2(1,1,i-2)=0.0d0
3138           Ug2(1,2,i-2)=0.0d0
3139           Ug2(2,1,i-2)=0.0d0
3140           Ug2(2,2,i-2)=0.0d0
3141         endif
3142         if (i .gt. 3 .and. i .lt. nres+1) then
3143           obrot_der(1,i-2)=-sin1
3144           obrot_der(2,i-2)= cos1
3145           Ugder(1,1,i-2)= sin1
3146           Ugder(1,2,i-2)=-cos1
3147           Ugder(2,1,i-2)=-cos1
3148           Ugder(2,2,i-2)=-sin1
3149           dwacos2=cos2+cos2
3150           dwasin2=sin2+sin2
3151           obrot2_der(1,i-2)=-dwasin2
3152           obrot2_der(2,i-2)= dwacos2
3153           Ug2der(1,1,i-2)= dwasin2
3154           Ug2der(1,2,i-2)=-dwacos2
3155           Ug2der(2,1,i-2)=-dwacos2
3156           Ug2der(2,2,i-2)=-dwasin2
3157         else
3158           obrot_der(1,i-2)=0.0d0
3159           obrot_der(2,i-2)=0.0d0
3160           Ugder(1,1,i-2)=0.0d0
3161           Ugder(1,2,i-2)=0.0d0
3162           Ugder(2,1,i-2)=0.0d0
3163           Ugder(2,2,i-2)=0.0d0
3164           obrot2_der(1,i-2)=0.0d0
3165           obrot2_der(2,i-2)=0.0d0
3166           Ug2der(1,1,i-2)=0.0d0
3167           Ug2der(1,2,i-2)=0.0d0
3168           Ug2der(2,1,i-2)=0.0d0
3169           Ug2der(2,2,i-2)=0.0d0
3170         endif
3171 c        if (i.gt. iatel_s+2 .and. i.lt.iatel_e+5) then
3172         if (i.gt. nnt+2 .and. i.lt.nct+2) then
3173           iti = itype2loc(itype(i-2))
3174         else
3175           iti=nloctyp
3176         endif
3177 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
3178         if (i.gt. nnt+1 .and. i.lt.nct+1) then
3179           iti1 = itype2loc(itype(i-1))
3180         else
3181           iti1=nloctyp
3182         endif
3183 cd        write (iout,*) '*******i',i,' iti1',iti
3184 cd        write (iout,*) 'b1',b1(:,iti)
3185 cd        write (iout,*) 'b2',b2(:,iti)
3186 cd        write (iout,*) 'Ug',Ug(:,:,i-2)
3187 c        if (i .gt. iatel_s+2) then
3188         if (i .gt. nnt+2) then
3189           call matvec2(Ug(1,1,i-2),b2(1,i-2),Ub2(1,i-2))
3190 #ifdef NEWCORR
3191           call matvec2(Ug(1,1,i-2),gtb2(1,i-2),gUb2(1,i-2))
3192 c          write (iout,*) Ug(1,1,i-2),gtb2(1,i-2),gUb2(1,i-2),"chuj"
3193 #endif
3194 c          write(iout,*) "co jest kurwa", iti, EE(1,1,i),EE(2,1,i),
3195 c     &    EE(1,2,iti),EE(2,2,i)
3196           call matmat2(EE(1,1,i-2),Ug(1,1,i-2),EUg(1,1,i-2))
3197           call matmat2(gtEE(1,1,i-2),Ug(1,1,i-2),gtEUg(1,1,i-2))
3198 c          write(iout,*) "Macierz EUG",
3199 c     &    eug(1,1,i-2),eug(1,2,i-2),eug(2,1,i-2),
3200 c     &    eug(2,2,i-2)
3201           if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
3202      &    then
3203           call matmat2(CC(1,1,i-2),Ug(1,1,i-2),CUg(1,1,i-2))
3204           call matmat2(DD(1,1,i-2),Ug(1,1,i-2),DUg(1,1,i-2))
3205           call matmat2(Dtilde(1,1,i-2),Ug2(1,1,i-2),DtUg2(1,1,i-2))
3206           call matvec2(Ctilde(1,1,i-1),obrot(1,i-2),Ctobr(1,i-2))
3207           call matvec2(Dtilde(1,1,i-2),obrot2(1,i-2),Dtobr2(1,i-2))
3208           endif
3209         else
3210           do k=1,2
3211             Ub2(k,i-2)=0.0d0
3212             Ctobr(k,i-2)=0.0d0
3213             Dtobr2(k,i-2)=0.0d0
3214             do l=1,2
3215               EUg(l,k,i-2)=0.0d0
3216               CUg(l,k,i-2)=0.0d0
3217               DUg(l,k,i-2)=0.0d0
3218               DtUg2(l,k,i-2)=0.0d0
3219             enddo
3220           enddo
3221         endif
3222         call matvec2(Ugder(1,1,i-2),b2(1,i-2),Ub2der(1,i-2))
3223         call matmat2(EE(1,1,i-2),Ugder(1,1,i-2),EUgder(1,1,i-2))
3224         do k=1,2
3225           muder(k,i-2)=Ub2der(k,i-2)
3226         enddo
3227 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
3228         if (i.gt. nnt+1 .and. i.lt.nct+1) then
3229           if (itype(i-1).le.ntyp) then
3230             iti1 = itype2loc(itype(i-1))
3231           else
3232             iti1=nloctyp
3233           endif
3234         else
3235           iti1=nloctyp
3236         endif
3237         do k=1,2
3238           mu(k,i-2)=Ub2(k,i-2)+b1(k,i-1)
3239 c          mu(k,i-2)=b1(k,i-1)
3240 c          mu(k,i-2)=Ub2(k,i-2)
3241         enddo
3242 #ifdef MUOUT
3243         write (iout,'(2hmu,i3,3f8.1,12f10.5)') i-2,rad2deg*theta(i-1),
3244      &     rad2deg*theta(i),rad2deg*phi(i),mu(1,i-2),mu(2,i-2),
3245      &       -b2(1,i-2),b2(2,i-2),b1(1,i-2),b1(2,i-2),
3246      &       dsqrt(b2(1,i-1)**2+b2(2,i-1)**2)
3247      &      +dsqrt(b1(1,i-1)**2+b1(2,i-1)**2),
3248      &      ((ee(l,k,i-2),l=1,2),k=1,2)
3249 #endif
3250 cd        write (iout,*) 'mu1',mu1(:,i-2)
3251 cd        write (iout,*) 'mu2',mu2(:,i-2)
3252 cd        write (iout,*) 'mu',i-2,mu(:,i-2)
3253         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
3254      &  then
3255         call matmat2(CC(1,1,i-1),Ugder(1,1,i-2),CUgder(1,1,i-2))
3256         call matmat2(DD(1,1,i-2),Ugder(1,1,i-2),DUgder(1,1,i-2))
3257         call matmat2(Dtilde(1,1,i-2),Ug2der(1,1,i-2),DtUg2der(1,1,i-2))
3258         call matvec2(Ctilde(1,1,i-1),obrot_der(1,i-2),Ctobrder(1,i-2))
3259         call matvec2(Dtilde(1,1,i-2),obrot2_der(1,i-2),Dtobr2der(1,i-2))
3260 C Vectors and matrices dependent on a single virtual-bond dihedral.
3261         call matvec2(DD(1,1,i-2),b1tilde(1,i-1),auxvec(1))
3262         call matvec2(Ug2(1,1,i-2),auxvec(1),Ug2Db1t(1,i-2))
3263         call matvec2(Ug2der(1,1,i-2),auxvec(1),Ug2Db1tder(1,i-2))
3264         call matvec2(CC(1,1,i-1),Ub2(1,i-2),CUgb2(1,i-2))
3265         call matvec2(CC(1,1,i-1),Ub2der(1,i-2),CUgb2der(1,i-2))
3266         call matmat2(EUg(1,1,i-2),CC(1,1,i-1),EUgC(1,1,i-2))
3267         call matmat2(EUgder(1,1,i-2),CC(1,1,i-1),EUgCder(1,1,i-2))
3268         call matmat2(EUg(1,1,i-2),DD(1,1,i-1),EUgD(1,1,i-2))
3269         call matmat2(EUgder(1,1,i-2),DD(1,1,i-1),EUgDder(1,1,i-2))
3270         endif
3271       enddo
3272 C Matrices dependent on two consecutive virtual-bond dihedrals.
3273 C The order of matrices is from left to right.
3274       if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
3275      &then
3276 c      do i=max0(ivec_start,2),ivec_end
3277       do i=2,nres-1
3278         call matmat2(DtUg2(1,1,i-1),EUg(1,1,i),DtUg2EUg(1,1,i))
3279         call matmat2(DtUg2der(1,1,i-1),EUg(1,1,i),DtUg2EUgder(1,1,1,i))
3280         call matmat2(DtUg2(1,1,i-1),EUgder(1,1,i),DtUg2EUgder(1,1,2,i))
3281         call transpose2(DtUg2(1,1,i-1),auxmat(1,1))
3282         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUg(1,1,i))
3283         call matmat2(auxmat(1,1),EUgder(1,1,i),Ug2DtEUgder(1,1,2,i))
3284         call transpose2(DtUg2der(1,1,i-1),auxmat(1,1))
3285         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUgder(1,1,1,i))
3286       enddo
3287       endif
3288 #if defined(MPI) && defined(PARMAT)
3289 #ifdef DEBUG
3290 c      if (fg_rank.eq.0) then
3291         write (iout,*) "Arrays UG and UGDER before GATHER"
3292         do i=1,nres-1
3293           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3294      &     ((ug(l,k,i),l=1,2),k=1,2),
3295      &     ((ugder(l,k,i),l=1,2),k=1,2)
3296         enddo
3297         write (iout,*) "Arrays UG2 and UG2DER"
3298         do i=1,nres-1
3299           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3300      &     ((ug2(l,k,i),l=1,2),k=1,2),
3301      &     ((ug2der(l,k,i),l=1,2),k=1,2)
3302         enddo
3303         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
3304         do i=1,nres-1
3305           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3306      &     (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
3307      &     (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
3308         enddo
3309         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
3310         do i=1,nres-1
3311           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3312      &     costab(i),sintab(i),costab2(i),sintab2(i)
3313         enddo
3314         write (iout,*) "Array MUDER"
3315         do i=1,nres-1
3316           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
3317         enddo
3318 c      endif
3319 #endif
3320       if (nfgtasks.gt.1) then
3321         time00=MPI_Wtime()
3322 c        write(iout,*)"Processor",fg_rank,kolor," ivec_start",ivec_start,
3323 c     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks-1),
3324 c     &   " ivec_count",(ivec_count(i),i=0,nfgtasks-1)
3325 #ifdef MATGATHER
3326         call MPI_Allgatherv(Ub2(1,ivec_start),ivec_count(fg_rank1),
3327      &   MPI_MU,Ub2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3328      &   FG_COMM1,IERR)
3329         call MPI_Allgatherv(Ub2der(1,ivec_start),ivec_count(fg_rank1),
3330      &   MPI_MU,Ub2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3331      &   FG_COMM1,IERR)
3332         call MPI_Allgatherv(mu(1,ivec_start),ivec_count(fg_rank1),
3333      &   MPI_MU,mu(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3334      &   FG_COMM1,IERR)
3335         call MPI_Allgatherv(muder(1,ivec_start),ivec_count(fg_rank1),
3336      &   MPI_MU,muder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3337      &   FG_COMM1,IERR)
3338         call MPI_Allgatherv(Eug(1,1,ivec_start),ivec_count(fg_rank1),
3339      &   MPI_MAT1,Eug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3340      &   FG_COMM1,IERR)
3341         call MPI_Allgatherv(Eugder(1,1,ivec_start),ivec_count(fg_rank1),
3342      &   MPI_MAT1,Eugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3343      &   FG_COMM1,IERR)
3344         call MPI_Allgatherv(costab(ivec_start),ivec_count(fg_rank1),
3345      &   MPI_DOUBLE_PRECISION,costab(1),ivec_count(0),ivec_displ(0),
3346      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3347         call MPI_Allgatherv(sintab(ivec_start),ivec_count(fg_rank1),
3348      &   MPI_DOUBLE_PRECISION,sintab(1),ivec_count(0),ivec_displ(0),
3349      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3350         call MPI_Allgatherv(costab2(ivec_start),ivec_count(fg_rank1),
3351      &   MPI_DOUBLE_PRECISION,costab2(1),ivec_count(0),ivec_displ(0),
3352      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3353         call MPI_Allgatherv(sintab2(ivec_start),ivec_count(fg_rank1),
3354      &   MPI_DOUBLE_PRECISION,sintab2(1),ivec_count(0),ivec_displ(0),
3355      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3356         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
3357      &  then
3358         call MPI_Allgatherv(Ctobr(1,ivec_start),ivec_count(fg_rank1),
3359      &   MPI_MU,Ctobr(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3360      &   FG_COMM1,IERR)
3361         call MPI_Allgatherv(Ctobrder(1,ivec_start),ivec_count(fg_rank1),
3362      &   MPI_MU,Ctobrder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3363      &   FG_COMM1,IERR)
3364         call MPI_Allgatherv(Dtobr2(1,ivec_start),ivec_count(fg_rank1),
3365      &   MPI_MU,Dtobr2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3366      &   FG_COMM1,IERR)
3367        call MPI_Allgatherv(Dtobr2der(1,ivec_start),ivec_count(fg_rank1),
3368      &   MPI_MU,Dtobr2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3369      &   FG_COMM1,IERR)
3370         call MPI_Allgatherv(Ug2Db1t(1,ivec_start),ivec_count(fg_rank1),
3371      &   MPI_MU,Ug2Db1t(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3372      &   FG_COMM1,IERR)
3373         call MPI_Allgatherv(Ug2Db1tder(1,ivec_start),
3374      &   ivec_count(fg_rank1),
3375      &   MPI_MU,Ug2Db1tder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3376      &   FG_COMM1,IERR)
3377         call MPI_Allgatherv(CUgb2(1,ivec_start),ivec_count(fg_rank1),
3378      &   MPI_MU,CUgb2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3379      &   FG_COMM1,IERR)
3380         call MPI_Allgatherv(CUgb2der(1,ivec_start),ivec_count(fg_rank1),
3381      &   MPI_MU,CUgb2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3382      &   FG_COMM1,IERR)
3383         call MPI_Allgatherv(Cug(1,1,ivec_start),ivec_count(fg_rank1),
3384      &   MPI_MAT1,Cug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3385      &   FG_COMM1,IERR)
3386         call MPI_Allgatherv(Cugder(1,1,ivec_start),ivec_count(fg_rank1),
3387      &   MPI_MAT1,Cugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3388      &   FG_COMM1,IERR)
3389         call MPI_Allgatherv(Dug(1,1,ivec_start),ivec_count(fg_rank1),
3390      &   MPI_MAT1,Dug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3391      &   FG_COMM1,IERR)
3392         call MPI_Allgatherv(Dugder(1,1,ivec_start),ivec_count(fg_rank1),
3393      &   MPI_MAT1,Dugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3394      &   FG_COMM1,IERR)
3395         call MPI_Allgatherv(Dtug2(1,1,ivec_start),ivec_count(fg_rank1),
3396      &   MPI_MAT1,Dtug2(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3397      &   FG_COMM1,IERR)
3398         call MPI_Allgatherv(Dtug2der(1,1,ivec_start),
3399      &   ivec_count(fg_rank1),
3400      &   MPI_MAT1,Dtug2der(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3401      &   FG_COMM1,IERR)
3402         call MPI_Allgatherv(EugC(1,1,ivec_start),ivec_count(fg_rank1),
3403      &   MPI_MAT1,EugC(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3404      &   FG_COMM1,IERR)
3405        call MPI_Allgatherv(EugCder(1,1,ivec_start),ivec_count(fg_rank1),
3406      &   MPI_MAT1,EugCder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3407      &   FG_COMM1,IERR)
3408         call MPI_Allgatherv(EugD(1,1,ivec_start),ivec_count(fg_rank1),
3409      &   MPI_MAT1,EugD(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3410      &   FG_COMM1,IERR)
3411        call MPI_Allgatherv(EugDder(1,1,ivec_start),ivec_count(fg_rank1),
3412      &   MPI_MAT1,EugDder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3413      &   FG_COMM1,IERR)
3414         call MPI_Allgatherv(DtUg2EUg(1,1,ivec_start),
3415      &   ivec_count(fg_rank1),
3416      &   MPI_MAT1,DtUg2EUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3417      &   FG_COMM1,IERR)
3418         call MPI_Allgatherv(Ug2DtEUg(1,1,ivec_start),
3419      &   ivec_count(fg_rank1),
3420      &   MPI_MAT1,Ug2DtEUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3421      &   FG_COMM1,IERR)
3422         call MPI_Allgatherv(DtUg2EUgder(1,1,1,ivec_start),
3423      &   ivec_count(fg_rank1),
3424      &   MPI_MAT2,DtUg2EUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
3425      &   MPI_MAT2,FG_COMM1,IERR)
3426         call MPI_Allgatherv(Ug2DtEUgder(1,1,1,ivec_start),
3427      &   ivec_count(fg_rank1),
3428      &   MPI_MAT2,Ug2DtEUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
3429      &   MPI_MAT2,FG_COMM1,IERR)
3430         endif
3431 #else
3432 c Passes matrix info through the ring
3433       isend=fg_rank1
3434       irecv=fg_rank1-1
3435       if (irecv.lt.0) irecv=nfgtasks1-1
3436       iprev=irecv
3437       inext=fg_rank1+1
3438       if (inext.ge.nfgtasks1) inext=0
3439       do i=1,nfgtasks1-1
3440 c        write (iout,*) "isend",isend," irecv",irecv
3441 c        call flush(iout)
3442         lensend=lentyp(isend)
3443         lenrecv=lentyp(irecv)
3444 c        write (iout,*) "lensend",lensend," lenrecv",lenrecv
3445 c        call MPI_SENDRECV(ug(1,1,ivec_displ(isend)+1),1,
3446 c     &   MPI_ROTAT1(lensend),inext,2200+isend,
3447 c     &   ug(1,1,ivec_displ(irecv)+1),1,MPI_ROTAT1(lenrecv),
3448 c     &   iprev,2200+irecv,FG_COMM,status,IERR)
3449 c        write (iout,*) "Gather ROTAT1"
3450 c        call flush(iout)
3451 c        call MPI_SENDRECV(obrot(1,ivec_displ(isend)+1),1,
3452 c     &   MPI_ROTAT2(lensend),inext,3300+isend,
3453 c     &   obrot(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
3454 c     &   iprev,3300+irecv,FG_COMM,status,IERR)
3455 c        write (iout,*) "Gather ROTAT2"
3456 c        call flush(iout)
3457         call MPI_SENDRECV(costab(ivec_displ(isend)+1),1,
3458      &   MPI_ROTAT_OLD(lensend),inext,4400+isend,
3459      &   costab(ivec_displ(irecv)+1),1,MPI_ROTAT_OLD(lenrecv),
3460      &   iprev,4400+irecv,FG_COMM,status,IERR)
3461 c        write (iout,*) "Gather ROTAT_OLD"
3462 c        call flush(iout)
3463         call MPI_SENDRECV(mu(1,ivec_displ(isend)+1),1,
3464      &   MPI_PRECOMP11(lensend),inext,5500+isend,
3465      &   mu(1,ivec_displ(irecv)+1),1,MPI_PRECOMP11(lenrecv),
3466      &   iprev,5500+irecv,FG_COMM,status,IERR)
3467 c        write (iout,*) "Gather PRECOMP11"
3468 c        call flush(iout)
3469         call MPI_SENDRECV(Eug(1,1,ivec_displ(isend)+1),1,
3470      &   MPI_PRECOMP12(lensend),inext,6600+isend,
3471      &   Eug(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP12(lenrecv),
3472      &   iprev,6600+irecv,FG_COMM,status,IERR)
3473 c        write (iout,*) "Gather PRECOMP12"
3474 c        call flush(iout)
3475         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
3476      &  then
3477         call MPI_SENDRECV(ug2db1t(1,ivec_displ(isend)+1),1,
3478      &   MPI_ROTAT2(lensend),inext,7700+isend,
3479      &   ug2db1t(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
3480      &   iprev,7700+irecv,FG_COMM,status,IERR)
3481 c        write (iout,*) "Gather PRECOMP21"
3482 c        call flush(iout)
3483         call MPI_SENDRECV(EUgC(1,1,ivec_displ(isend)+1),1,
3484      &   MPI_PRECOMP22(lensend),inext,8800+isend,
3485      &   EUgC(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP22(lenrecv),
3486      &   iprev,8800+irecv,FG_COMM,status,IERR)
3487 c        write (iout,*) "Gather PRECOMP22"
3488 c        call flush(iout)
3489         call MPI_SENDRECV(Ug2DtEUgder(1,1,1,ivec_displ(isend)+1),1,
3490      &   MPI_PRECOMP23(lensend),inext,9900+isend,
3491      &   Ug2DtEUgder(1,1,1,ivec_displ(irecv)+1),1,
3492      &   MPI_PRECOMP23(lenrecv),
3493      &   iprev,9900+irecv,FG_COMM,status,IERR)
3494 c        write (iout,*) "Gather PRECOMP23"
3495 c        call flush(iout)
3496         endif
3497         isend=irecv
3498         irecv=irecv-1
3499         if (irecv.lt.0) irecv=nfgtasks1-1
3500       enddo
3501 #endif
3502         time_gather=time_gather+MPI_Wtime()-time00
3503       endif
3504 #ifdef DEBUG
3505 c      if (fg_rank.eq.0) then
3506         write (iout,*) "Arrays UG and UGDER"
3507         do i=1,nres-1
3508           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3509      &     ((ug(l,k,i),l=1,2),k=1,2),
3510      &     ((ugder(l,k,i),l=1,2),k=1,2)
3511         enddo
3512         write (iout,*) "Arrays UG2 and UG2DER"
3513         do i=1,nres-1
3514           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3515      &     ((ug2(l,k,i),l=1,2),k=1,2),
3516      &     ((ug2der(l,k,i),l=1,2),k=1,2)
3517         enddo
3518         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
3519         do i=1,nres-1
3520           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3521      &     (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
3522      &     (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
3523         enddo
3524         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
3525         do i=1,nres-1
3526           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3527      &     costab(i),sintab(i),costab2(i),sintab2(i)
3528         enddo
3529         write (iout,*) "Array MUDER"
3530         do i=1,nres-1
3531           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
3532         enddo
3533 c      endif
3534 #endif
3535 #endif
3536 cd      do i=1,nres
3537 cd        iti = itype2loc(itype(i))
3538 cd        write (iout,*) i
3539 cd        do j=1,2
3540 cd        write (iout,'(2f10.5,5x,2f10.5,5x,2f10.5)')
3541 cd     &  (EE(j,k,i),k=1,2),(Ug(j,k,i),k=1,2),(EUg(j,k,i),k=1,2)
3542 cd        enddo
3543 cd      enddo
3544       return
3545       end
3546 C--------------------------------------------------------------------------
3547       subroutine eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
3548 C
3549 C This subroutine calculates the average interaction energy and its gradient
3550 C in the virtual-bond vectors between non-adjacent peptide groups, based on
3551 C the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
3552 C The potential depends both on the distance of peptide-group centers and on
3553 C the orientation of the CA-CA virtual bonds.
3554 C
3555       implicit real*8 (a-h,o-z)
3556 #ifdef MPI
3557       include 'mpif.h'
3558 #endif
3559       include 'DIMENSIONS'
3560       include 'COMMON.CONTROL'
3561       include 'COMMON.SETUP'
3562       include 'COMMON.IOUNITS'
3563       include 'COMMON.GEO'
3564       include 'COMMON.VAR'
3565       include 'COMMON.LOCAL'
3566       include 'COMMON.CHAIN'
3567       include 'COMMON.DERIV'
3568       include 'COMMON.INTERACT'
3569       include 'COMMON.CONTACTS'
3570       include 'COMMON.TORSION'
3571       include 'COMMON.VECTORS'
3572       include 'COMMON.FFIELD'
3573       include 'COMMON.TIME1'
3574       include 'COMMON.SPLITELE'
3575       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
3576      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
3577       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
3578      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4),gmuij(4)
3579       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3580      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3581      &    num_conti,j1,j2
3582 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
3583 #ifdef MOMENT
3584       double precision scal_el /1.0d0/
3585 #else
3586       double precision scal_el /0.5d0/
3587 #endif
3588 C 12/13/98
3589 C 13-go grudnia roku pamietnego...
3590       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
3591      &                   0.0d0,1.0d0,0.0d0,
3592      &                   0.0d0,0.0d0,1.0d0/
3593 cd      write(iout,*) 'In EELEC'
3594 cd      do i=1,nloctyp
3595 cd        write(iout,*) 'Type',i
3596 cd        write(iout,*) 'B1',B1(:,i)
3597 cd        write(iout,*) 'B2',B2(:,i)
3598 cd        write(iout,*) 'CC',CC(:,:,i)
3599 cd        write(iout,*) 'DD',DD(:,:,i)
3600 cd        write(iout,*) 'EE',EE(:,:,i)
3601 cd      enddo
3602 cd      call check_vecgrad
3603 cd      stop
3604       if (icheckgrad.eq.1) then
3605         do i=1,nres-1
3606           fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
3607           do k=1,3
3608             dc_norm(k,i)=dc(k,i)*fac
3609           enddo
3610 c          write (iout,*) 'i',i,' fac',fac
3611         enddo
3612       endif
3613       if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
3614      &    .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or.
3615      &    wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
3616 c        call vec_and_deriv
3617 #ifdef TIMING
3618         time01=MPI_Wtime()
3619 #endif
3620         call set_matrices
3621 #ifdef TIMING
3622         time_mat=time_mat+MPI_Wtime()-time01
3623 #endif
3624       endif
3625 cd      do i=1,nres-1
3626 cd        write (iout,*) 'i=',i
3627 cd        do k=1,3
3628 cd        write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
3629 cd        enddo
3630 cd        do k=1,3
3631 cd          write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
3632 cd     &     uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
3633 cd        enddo
3634 cd      enddo
3635       t_eelecij=0.0d0
3636       ees=0.0D0
3637       evdw1=0.0D0
3638       eel_loc=0.0d0
3639       eello_turn3=0.0d0
3640       eello_turn4=0.0d0
3641       ind=0
3642       do i=1,nres
3643         num_cont_hb(i)=0
3644       enddo
3645 cd      print '(a)','Enter EELEC'
3646 cd      write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
3647       do i=1,nres
3648         gel_loc_loc(i)=0.0d0
3649         gcorr_loc(i)=0.0d0
3650       enddo
3651 c
3652 c
3653 c 9/27/08 AL Split the interaction loop to ensure load balancing of turn terms
3654 C
3655 C Loop over i,i+2 and i,i+3 pairs of the peptide groups
3656 C
3657 C 14/01/2014 TURN3,TUNR4 does no go under periodic boundry condition
3658       do i=iturn3_start,iturn3_end
3659 c        if (i.le.1) cycle
3660 C        write(iout,*) "tu jest i",i
3661         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
3662 C changes suggested by Ana to avoid out of bounds
3663 C Adam: Unnecessary: handled by iturn3_end and iturn3_start
3664 c     & .or.((i+4).gt.nres)
3665 c     & .or.((i-1).le.0)
3666 C end of changes by Ana
3667      &  .or. itype(i+2).eq.ntyp1
3668      &  .or. itype(i+3).eq.ntyp1) cycle
3669 C Adam: Instructions below will switch off existing interactions
3670 c        if(i.gt.1)then
3671 c          if(itype(i-1).eq.ntyp1)cycle
3672 c        end if
3673 c        if(i.LT.nres-3)then
3674 c          if (itype(i+4).eq.ntyp1) cycle
3675 c        end if
3676         dxi=dc(1,i)
3677         dyi=dc(2,i)
3678         dzi=dc(3,i)
3679         dx_normi=dc_norm(1,i)
3680         dy_normi=dc_norm(2,i)
3681         dz_normi=dc_norm(3,i)
3682         xmedi=c(1,i)+0.5d0*dxi
3683         ymedi=c(2,i)+0.5d0*dyi
3684         zmedi=c(3,i)+0.5d0*dzi
3685           xmedi=mod(xmedi,boxxsize)
3686           if (xmedi.lt.0) xmedi=xmedi+boxxsize
3687           ymedi=mod(ymedi,boxysize)
3688           if (ymedi.lt.0) ymedi=ymedi+boxysize
3689           zmedi=mod(zmedi,boxzsize)
3690           if (zmedi.lt.0) zmedi=zmedi+boxzsize
3691         num_conti=0
3692         call eelecij(i,i+2,ees,evdw1,eel_loc)
3693         if (wturn3.gt.0.0d0) call eturn3(i,eello_turn3)
3694         num_cont_hb(i)=num_conti
3695       enddo
3696       do i=iturn4_start,iturn4_end
3697         if (i.lt.1) cycle
3698         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
3699 C changes suggested by Ana to avoid out of bounds
3700 c     & .or.((i+5).gt.nres)
3701 c     & .or.((i-1).le.0)
3702 C end of changes suggested by Ana
3703      &    .or. itype(i+3).eq.ntyp1
3704      &    .or. itype(i+4).eq.ntyp1
3705 c     &    .or. itype(i+5).eq.ntyp1
3706 c     &    .or. itype(i).eq.ntyp1
3707 c     &    .or. itype(i-1).eq.ntyp1
3708      &                             ) cycle
3709         dxi=dc(1,i)
3710         dyi=dc(2,i)
3711         dzi=dc(3,i)
3712         dx_normi=dc_norm(1,i)
3713         dy_normi=dc_norm(2,i)
3714         dz_normi=dc_norm(3,i)
3715         xmedi=c(1,i)+0.5d0*dxi
3716         ymedi=c(2,i)+0.5d0*dyi
3717         zmedi=c(3,i)+0.5d0*dzi
3718 C Return atom into box, boxxsize is size of box in x dimension
3719 c  194   continue
3720 c        if (xmedi.gt.((0.5d0)*boxxsize)) xmedi=xmedi-boxxsize
3721 c        if (xmedi.lt.((-0.5d0)*boxxsize)) xmedi=xmedi+boxxsize
3722 C Condition for being inside the proper box
3723 c        if ((xmedi.gt.((0.5d0)*boxxsize)).or.
3724 c     &       (xmedi.lt.((-0.5d0)*boxxsize))) then
3725 c        go to 194
3726 c        endif
3727 c  195   continue
3728 c        if (ymedi.gt.((0.5d0)*boxysize)) ymedi=ymedi-boxysize
3729 c        if (ymedi.lt.((-0.5d0)*boxysize)) ymedi=ymedi+boxysize
3730 C Condition for being inside the proper box
3731 c        if ((ymedi.gt.((0.5d0)*boxysize)).or.
3732 c     &       (ymedi.lt.((-0.5d0)*boxysize))) then
3733 c        go to 195
3734 c        endif
3735 c  196   continue
3736 c        if (zmedi.gt.((0.5d0)*boxzsize)) zmedi=zmedi-boxzsize
3737 c        if (zmedi.lt.((-0.5d0)*boxzsize)) zmedi=zmedi+boxzsize
3738 C Condition for being inside the proper box
3739 c        if ((zmedi.gt.((0.5d0)*boxzsize)).or.
3740 c     &       (zmedi.lt.((-0.5d0)*boxzsize))) then
3741 c        go to 196
3742 c        endif
3743           xmedi=mod(xmedi,boxxsize)
3744           if (xmedi.lt.0) xmedi=xmedi+boxxsize
3745           ymedi=mod(ymedi,boxysize)
3746           if (ymedi.lt.0) ymedi=ymedi+boxysize
3747           zmedi=mod(zmedi,boxzsize)
3748           if (zmedi.lt.0) zmedi=zmedi+boxzsize
3749
3750         num_conti=num_cont_hb(i)
3751 c        write(iout,*) "JESTEM W PETLI"
3752         call eelecij(i,i+3,ees,evdw1,eel_loc)
3753         if (wturn4.gt.0.0d0 .and. itype(i+2).ne.ntyp1)
3754      &   call eturn4(i,eello_turn4)
3755         num_cont_hb(i)=num_conti
3756       enddo   ! i
3757 C Loop over all neighbouring boxes
3758 C      do xshift=-1,1
3759 C      do yshift=-1,1
3760 C      do zshift=-1,1
3761 c
3762 c Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
3763 c
3764 CTU KURWA
3765       do i=iatel_s,iatel_e
3766 C        do i=75,75
3767 c        if (i.le.1) cycle
3768         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
3769 C changes suggested by Ana to avoid out of bounds
3770 c     & .or.((i+2).gt.nres)
3771 c     & .or.((i-1).le.0)
3772 C end of changes by Ana
3773 c     &  .or. itype(i+2).eq.ntyp1
3774 c     &  .or. itype(i-1).eq.ntyp1
3775      &                ) cycle
3776         dxi=dc(1,i)
3777         dyi=dc(2,i)
3778         dzi=dc(3,i)
3779         dx_normi=dc_norm(1,i)
3780         dy_normi=dc_norm(2,i)
3781         dz_normi=dc_norm(3,i)
3782         xmedi=c(1,i)+0.5d0*dxi
3783         ymedi=c(2,i)+0.5d0*dyi
3784         zmedi=c(3,i)+0.5d0*dzi
3785           xmedi=mod(xmedi,boxxsize)
3786           if (xmedi.lt.0) xmedi=xmedi+boxxsize
3787           ymedi=mod(ymedi,boxysize)
3788           if (ymedi.lt.0) ymedi=ymedi+boxysize
3789           zmedi=mod(zmedi,boxzsize)
3790           if (zmedi.lt.0) zmedi=zmedi+boxzsize
3791 C          xmedi=xmedi+xshift*boxxsize
3792 C          ymedi=ymedi+yshift*boxysize
3793 C          zmedi=zmedi+zshift*boxzsize
3794
3795 C Return tom into box, boxxsize is size of box in x dimension
3796 c  164   continue
3797 c        if (xmedi.gt.((xshift+0.5d0)*boxxsize)) xmedi=xmedi-boxxsize
3798 c        if (xmedi.lt.((xshift-0.5d0)*boxxsize)) xmedi=xmedi+boxxsize
3799 C Condition for being inside the proper box
3800 c        if ((xmedi.gt.((xshift+0.5d0)*boxxsize)).or.
3801 c     &       (xmedi.lt.((xshift-0.5d0)*boxxsize))) then
3802 c        go to 164
3803 c        endif
3804 c  165   continue
3805 c        if (ymedi.gt.((yshift+0.5d0)*boxysize)) ymedi=ymedi-boxysize
3806 c        if (ymedi.lt.((yshift-0.5d0)*boxysize)) ymedi=ymedi+boxysize
3807 C Condition for being inside the proper box
3808 c        if ((ymedi.gt.((yshift+0.5d0)*boxysize)).or.
3809 c     &       (ymedi.lt.((yshift-0.5d0)*boxysize))) then
3810 c        go to 165
3811 c        endif
3812 c  166   continue
3813 c        if (zmedi.gt.((zshift+0.5d0)*boxzsize)) zmedi=zmedi-boxzsize
3814 c        if (zmedi.lt.((zshift-0.5d0)*boxzsize)) zmedi=zmedi+boxzsize
3815 cC Condition for being inside the proper box
3816 c        if ((zmedi.gt.((zshift+0.5d0)*boxzsize)).or.
3817 c     &       (zmedi.lt.((zshift-0.5d0)*boxzsize))) then
3818 c        go to 166
3819 c        endif
3820
3821 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
3822         num_conti=num_cont_hb(i)
3823 C I TU KURWA
3824         do j=ielstart(i),ielend(i)
3825 C          do j=16,17
3826 C          write (iout,*) i,j
3827 C         if (j.le.1) cycle
3828           if (itype(j).eq.ntyp1.or. itype(j+1).eq.ntyp1
3829 C changes suggested by Ana to avoid out of bounds
3830 c     & .or.((j+2).gt.nres)
3831 c     & .or.((j-1).le.0)
3832 C end of changes by Ana
3833 c     & .or.itype(j+2).eq.ntyp1
3834 c     & .or.itype(j-1).eq.ntyp1
3835      &) cycle
3836           call eelecij(i,j,ees,evdw1,eel_loc)
3837         enddo ! j
3838         num_cont_hb(i)=num_conti
3839       enddo   ! i
3840 C     enddo   ! zshift
3841 C      enddo   ! yshift
3842 C      enddo   ! xshift
3843
3844 c      write (iout,*) "Number of loop steps in EELEC:",ind
3845 cd      do i=1,nres
3846 cd        write (iout,'(i3,3f10.5,5x,3f10.5)')
3847 cd     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
3848 cd      enddo
3849 c 12/7/99 Adam eello_turn3 will be considered as a separate energy term
3850 ccc      eel_loc=eel_loc+eello_turn3
3851 cd      print *,"Processor",fg_rank," t_eelecij",t_eelecij
3852       return
3853       end
3854 C-------------------------------------------------------------------------------
3855       subroutine eelecij(i,j,ees,evdw1,eel_loc)
3856       implicit real*8 (a-h,o-z)
3857       include 'DIMENSIONS'
3858 #ifdef MPI
3859       include "mpif.h"
3860 #endif
3861       include 'COMMON.CONTROL'
3862       include 'COMMON.IOUNITS'
3863       include 'COMMON.GEO'
3864       include 'COMMON.VAR'
3865       include 'COMMON.LOCAL'
3866       include 'COMMON.CHAIN'
3867       include 'COMMON.DERIV'
3868       include 'COMMON.INTERACT'
3869       include 'COMMON.CONTACTS'
3870       include 'COMMON.TORSION'
3871       include 'COMMON.VECTORS'
3872       include 'COMMON.FFIELD'
3873       include 'COMMON.TIME1'
3874       include 'COMMON.SPLITELE'
3875       include 'COMMON.SHIELD'
3876       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
3877      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
3878       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
3879      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4),gmuij1(4),gmuji1(4),
3880      &    gmuij2(4),gmuji2(4)
3881       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3882      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3883      &    num_conti,j1,j2
3884 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
3885 #ifdef MOMENT
3886       double precision scal_el /1.0d0/
3887 #else
3888       double precision scal_el /0.5d0/
3889 #endif
3890 C 12/13/98
3891 C 13-go grudnia roku pamietnego...
3892       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
3893      &                   0.0d0,1.0d0,0.0d0,
3894      &                   0.0d0,0.0d0,1.0d0/
3895        integer xshift,yshift,zshift
3896 c          time00=MPI_Wtime()
3897 cd      write (iout,*) "eelecij",i,j
3898 c          ind=ind+1
3899           iteli=itel(i)
3900           itelj=itel(j)
3901           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
3902           aaa=app(iteli,itelj)
3903           bbb=bpp(iteli,itelj)
3904           ael6i=ael6(iteli,itelj)
3905           ael3i=ael3(iteli,itelj)
3906           dxj=dc(1,j)
3907           dyj=dc(2,j)
3908           dzj=dc(3,j)
3909           dx_normj=dc_norm(1,j)
3910           dy_normj=dc_norm(2,j)
3911           dz_normj=dc_norm(3,j)
3912 C          xj=c(1,j)+0.5D0*dxj-xmedi
3913 C          yj=c(2,j)+0.5D0*dyj-ymedi
3914 C          zj=c(3,j)+0.5D0*dzj-zmedi
3915           xj=c(1,j)+0.5D0*dxj
3916           yj=c(2,j)+0.5D0*dyj
3917           zj=c(3,j)+0.5D0*dzj
3918           xj=mod(xj,boxxsize)
3919           if (xj.lt.0) xj=xj+boxxsize
3920           yj=mod(yj,boxysize)
3921           if (yj.lt.0) yj=yj+boxysize
3922           zj=mod(zj,boxzsize)
3923           if (zj.lt.0) zj=zj+boxzsize
3924           if ((zj.lt.0).or.(xj.lt.0).or.(yj.lt.0)) write (*,*) "CHUJ"
3925       dist_init=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
3926       xj_safe=xj
3927       yj_safe=yj
3928       zj_safe=zj
3929       isubchap=0
3930       do xshift=-1,1
3931       do yshift=-1,1
3932       do zshift=-1,1
3933           xj=xj_safe+xshift*boxxsize
3934           yj=yj_safe+yshift*boxysize
3935           zj=zj_safe+zshift*boxzsize
3936           dist_temp=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
3937           if(dist_temp.lt.dist_init) then
3938             dist_init=dist_temp
3939             xj_temp=xj
3940             yj_temp=yj
3941             zj_temp=zj
3942             isubchap=1
3943           endif
3944        enddo
3945        enddo
3946        enddo
3947        if (isubchap.eq.1) then
3948           xj=xj_temp-xmedi
3949           yj=yj_temp-ymedi
3950           zj=zj_temp-zmedi
3951        else
3952           xj=xj_safe-xmedi
3953           yj=yj_safe-ymedi
3954           zj=zj_safe-zmedi
3955        endif
3956 C        if ((i+3).lt.j) then !this condition keeps for turn3 and turn4 not subject to PBC
3957 c  174   continue
3958 c        if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
3959 c        if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
3960 C Condition for being inside the proper box
3961 c        if ((xj.gt.((0.5d0)*boxxsize)).or.
3962 c     &       (xj.lt.((-0.5d0)*boxxsize))) then
3963 c        go to 174
3964 c        endif
3965 c  175   continue
3966 c        if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
3967 c        if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
3968 C Condition for being inside the proper box
3969 c        if ((yj.gt.((0.5d0)*boxysize)).or.
3970 c     &       (yj.lt.((-0.5d0)*boxysize))) then
3971 c        go to 175
3972 c        endif
3973 c  176   continue
3974 c        if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
3975 c        if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
3976 C Condition for being inside the proper box
3977 c        if ((zj.gt.((0.5d0)*boxzsize)).or.
3978 c     &       (zj.lt.((-0.5d0)*boxzsize))) then
3979 c        go to 176
3980 c        endif
3981 C        endif !endPBC condintion
3982 C        xj=xj-xmedi
3983 C        yj=yj-ymedi
3984 C        zj=zj-zmedi
3985           rij=xj*xj+yj*yj+zj*zj
3986
3987             sss=sscale(sqrt(rij))
3988             sssgrad=sscagrad(sqrt(rij))
3989 c            if (sss.gt.0.0d0) then
3990           rrmij=1.0D0/rij
3991           rij=dsqrt(rij)
3992           rmij=1.0D0/rij
3993           r3ij=rrmij*rmij
3994           r6ij=r3ij*r3ij
3995           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
3996           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
3997           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
3998           fac=cosa-3.0D0*cosb*cosg
3999           ev1=aaa*r6ij*r6ij
4000 c 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
4001           if (j.eq.i+2) ev1=scal_el*ev1
4002           ev2=bbb*r6ij
4003           fac3=ael6i*r6ij
4004           fac4=ael3i*r3ij
4005           evdwij=(ev1+ev2)
4006           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
4007           el2=fac4*fac
4008 C MARYSIA
4009 C          eesij=(el1+el2)
4010 C 12/26/95 - for the evaluation of multi-body H-bonding interactions
4011           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
4012           if (shield_mode.gt.0) then
4013 C          fac_shield(i)=0.4
4014 C          fac_shield(j)=0.6
4015           el1=el1*fac_shield(i)**2*fac_shield(j)**2
4016           el2=el2*fac_shield(i)**2*fac_shield(j)**2
4017           eesij=(el1+el2)
4018           ees=ees+eesij
4019           else
4020           fac_shield(i)=1.0
4021           fac_shield(j)=1.0
4022           eesij=(el1+el2)
4023           ees=ees+eesij
4024           endif
4025           evdw1=evdw1+evdwij*sss
4026 cd          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
4027 cd     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
4028 cd     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
4029 cd     &      xmedi,ymedi,zmedi,xj,yj,zj
4030
4031           if (energy_dec) then
4032               write (iout,'(a6,2i5,0pf7.3,2i5,3e11.3)')
4033      &'evdw1',i,j,evdwij
4034      &,iteli,itelj,aaa,evdw1,sss
4035               write (iout,'(a6,2i5,0pf7.3,2f8.3)') 'ees',i,j,eesij,
4036      &fac_shield(i),fac_shield(j)
4037           endif
4038
4039 C
4040 C Calculate contributions to the Cartesian gradient.
4041 C
4042 #ifdef SPLITELE
4043           facvdw=-6*rrmij*(ev1+evdwij)*sss
4044           facel=-3*rrmij*(el1+eesij)
4045           fac1=fac
4046           erij(1)=xj*rmij
4047           erij(2)=yj*rmij
4048           erij(3)=zj*rmij
4049
4050 *
4051 * Radial derivatives. First process both termini of the fragment (i,j)
4052 *
4053           ggg(1)=facel*xj
4054           ggg(2)=facel*yj
4055           ggg(3)=facel*zj
4056           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
4057      &  (shield_mode.gt.0)) then
4058 C          print *,i,j
4059           do ilist=1,ishield_list(i)
4060            iresshield=shield_list(ilist,i)
4061            do k=1,3
4062            rlocshield=grad_shield_side(k,ilist,i)*eesij/fac_shield(i)
4063      &      *2.0
4064            gshieldx(k,iresshield)=gshieldx(k,iresshield)+
4065      &              rlocshield
4066      & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)*2.0
4067             gshieldc(k,iresshield-1)=gshieldc(k,iresshield-1)+rlocshield
4068 C           gshieldc_loc(k,iresshield)=gshieldc_loc(k,iresshield)
4069 C     & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)
4070 C             if (iresshield.gt.i) then
4071 C               do ishi=i+1,iresshield-1
4072 C                gshieldc(k,ishi)=gshieldc(k,ishi)+rlocshield
4073 C     & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)
4074 C
4075 C              enddo
4076 C             else
4077 C               do ishi=iresshield,i
4078 C                gshieldc(k,ishi)=gshieldc(k,ishi)-rlocshield
4079 C     & -grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)
4080 C
4081 C               enddo
4082 C              endif
4083            enddo
4084           enddo
4085           do ilist=1,ishield_list(j)
4086            iresshield=shield_list(ilist,j)
4087            do k=1,3
4088            rlocshield=grad_shield_side(k,ilist,j)*eesij/fac_shield(j)
4089      &     *2.0
4090            gshieldx(k,iresshield)=gshieldx(k,iresshield)+
4091      &              rlocshield
4092      & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)*2.0
4093            gshieldc(k,iresshield-1)=gshieldc(k,iresshield-1)+rlocshield
4094
4095 C     & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
4096 C           gshieldc_loc(k,iresshield)=gshieldc_loc(k,iresshield)
4097 C     & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
4098 C             if (iresshield.gt.j) then
4099 C               do ishi=j+1,iresshield-1
4100 C                gshieldc(k,ishi)=gshieldc(k,ishi)+rlocshield
4101 C     & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
4102 C
4103 C               enddo
4104 C            else
4105 C               do ishi=iresshield,j
4106 C                gshieldc(k,ishi)=gshieldc(k,ishi)-rlocshield
4107 C     & -grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
4108 C               enddo
4109 C              endif
4110            enddo
4111           enddo
4112
4113           do k=1,3
4114             gshieldc(k,i)=gshieldc(k,i)+
4115      &              grad_shield(k,i)*eesij/fac_shield(i)*2.0
4116             gshieldc(k,j)=gshieldc(k,j)+
4117      &              grad_shield(k,j)*eesij/fac_shield(j)*2.0
4118             gshieldc(k,i-1)=gshieldc(k,i-1)+
4119      &              grad_shield(k,i)*eesij/fac_shield(i)*2.0
4120             gshieldc(k,j-1)=gshieldc(k,j-1)+
4121      &              grad_shield(k,j)*eesij/fac_shield(j)*2.0
4122
4123            enddo
4124            endif
4125 c          do k=1,3
4126 c            ghalf=0.5D0*ggg(k)
4127 c            gelc(k,i)=gelc(k,i)+ghalf
4128 c            gelc(k,j)=gelc(k,j)+ghalf
4129 c          enddo
4130 c 9/28/08 AL Gradient compotents will be summed only at the end
4131 C           print *,"before", gelc_long(1,i), gelc_long(1,j)
4132           do k=1,3
4133             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
4134 C     &                    +grad_shield(k,j)*eesij/fac_shield(j)
4135             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
4136 C     &                    +grad_shield(k,i)*eesij/fac_shield(i)
4137 C            gelc_long(k,i-1)=gelc_long(k,i-1)
4138 C     &                    +grad_shield(k,i)*eesij/fac_shield(i)
4139 C            gelc_long(k,j-1)=gelc_long(k,j-1)
4140 C     &                    +grad_shield(k,j)*eesij/fac_shield(j)
4141           enddo
4142 C           print *,"bafter", gelc_long(1,i), gelc_long(1,j)
4143
4144 *
4145 * Loop over residues i+1 thru j-1.
4146 *
4147 cgrad          do k=i+1,j-1
4148 cgrad            do l=1,3
4149 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
4150 cgrad            enddo
4151 cgrad          enddo
4152           if (sss.gt.0.0) then
4153           ggg(1)=facvdw*xj+sssgrad*rmij*evdwij*xj
4154           ggg(2)=facvdw*yj+sssgrad*rmij*evdwij*yj
4155           ggg(3)=facvdw*zj+sssgrad*rmij*evdwij*zj
4156           else
4157           ggg(1)=0.0
4158           ggg(2)=0.0
4159           ggg(3)=0.0
4160           endif
4161 c          do k=1,3
4162 c            ghalf=0.5D0*ggg(k)
4163 c            gvdwpp(k,i)=gvdwpp(k,i)+ghalf
4164 c            gvdwpp(k,j)=gvdwpp(k,j)+ghalf
4165 c          enddo
4166 c 9/28/08 AL Gradient compotents will be summed only at the end
4167           do k=1,3
4168             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
4169             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
4170           enddo
4171 *
4172 * Loop over residues i+1 thru j-1.
4173 *
4174 cgrad          do k=i+1,j-1
4175 cgrad            do l=1,3
4176 cgrad              gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
4177 cgrad            enddo
4178 cgrad          enddo
4179 #else
4180 C MARYSIA
4181           facvdw=(ev1+evdwij)*sss
4182           facel=(el1+eesij)
4183           fac1=fac
4184           fac=-3*rrmij*(facvdw+facvdw+facel)
4185           erij(1)=xj*rmij
4186           erij(2)=yj*rmij
4187           erij(3)=zj*rmij
4188 *
4189 * Radial derivatives. First process both termini of the fragment (i,j)
4190 *
4191           ggg(1)=fac*xj
4192 C+eesij*grad_shield(1,i)+eesij*grad_shield(1,j)
4193           ggg(2)=fac*yj
4194 C+eesij*grad_shield(2,i)+eesij*grad_shield(2,j)
4195           ggg(3)=fac*zj
4196 C+eesij*grad_shield(3,i)+eesij*grad_shield(3,j)
4197 c          do k=1,3
4198 c            ghalf=0.5D0*ggg(k)
4199 c            gelc(k,i)=gelc(k,i)+ghalf
4200 c            gelc(k,j)=gelc(k,j)+ghalf
4201 c          enddo
4202 c 9/28/08 AL Gradient compotents will be summed only at the end
4203           do k=1,3
4204             gelc_long(k,j)=gelc(k,j)+ggg(k)
4205             gelc_long(k,i)=gelc(k,i)-ggg(k)
4206           enddo
4207 *
4208 * Loop over residues i+1 thru j-1.
4209 *
4210 cgrad          do k=i+1,j-1
4211 cgrad            do l=1,3
4212 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
4213 cgrad            enddo
4214 cgrad          enddo
4215 c 9/28/08 AL Gradient compotents will be summed only at the end
4216           ggg(1)=facvdw*xj+sssgrad*rmij*evdwij*xj
4217           ggg(2)=facvdw*yj+sssgrad*rmij*evdwij*yj
4218           ggg(3)=facvdw*zj+sssgrad*rmij*evdwij*zj
4219           do k=1,3
4220             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
4221             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
4222           enddo
4223 #endif
4224 *
4225 * Angular part
4226 *
4227           ecosa=2.0D0*fac3*fac1+fac4
4228           fac4=-3.0D0*fac4
4229           fac3=-6.0D0*fac3
4230           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
4231           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
4232           do k=1,3
4233             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
4234             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
4235           enddo
4236 cd        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
4237 cd   &          (dcosg(k),k=1,3)
4238           do k=1,3
4239             ggg(k)=(ecosb*dcosb(k)+ecosg*dcosg(k))*
4240      &      fac_shield(i)**2*fac_shield(j)**2
4241           enddo
4242 c          do k=1,3
4243 c            ghalf=0.5D0*ggg(k)
4244 c            gelc(k,i)=gelc(k,i)+ghalf
4245 c     &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
4246 c     &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
4247 c            gelc(k,j)=gelc(k,j)+ghalf
4248 c     &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
4249 c     &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
4250 c          enddo
4251 cgrad          do k=i+1,j-1
4252 cgrad            do l=1,3
4253 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
4254 cgrad            enddo
4255 cgrad          enddo
4256 C                     print *,"before22", gelc_long(1,i), gelc_long(1,j)
4257           do k=1,3
4258             gelc(k,i)=gelc(k,i)
4259      &           +((ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
4260      &           + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1))
4261      &           *fac_shield(i)**2*fac_shield(j)**2
4262             gelc(k,j)=gelc(k,j)
4263      &           +((ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
4264      &           + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1))
4265      &           *fac_shield(i)**2*fac_shield(j)**2
4266             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
4267             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
4268           enddo
4269 C           print *,"before33", gelc_long(1,i), gelc_long(1,j)
4270
4271 C MARYSIA
4272 c          endif !sscale
4273           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
4274      &        .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0
4275      &        .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
4276 C
4277 C 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
4278 C   energy of a peptide unit is assumed in the form of a second-order
4279 C   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
4280 C   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
4281 C   are computed for EVERY pair of non-contiguous peptide groups.
4282 C
4283
4284           if (j.lt.nres-1) then
4285             j1=j+1
4286             j2=j-1
4287           else
4288             j1=j-1
4289             j2=j-2
4290           endif
4291           kkk=0
4292           lll=0
4293           do k=1,2
4294             do l=1,2
4295               kkk=kkk+1
4296               muij(kkk)=mu(k,i)*mu(l,j)
4297 c              write(iout,*) 'mumu=', mu(k,i),mu(l,j),i,j,k,l
4298 #ifdef NEWCORR
4299              gmuij1(kkk)=gtb1(k,i+1)*mu(l,j)
4300 c             write(iout,*) 'k=',k,i,gtb1(k,i+1),gtb1(k,i+1)*mu(l,j)
4301              gmuij2(kkk)=gUb2(k,i)*mu(l,j)
4302              gmuji1(kkk)=mu(k,i)*gtb1(l,j+1)
4303 c             write(iout,*) 'l=',l,j,gtb1(l,j+1),gtb1(l,j+1)*mu(k,i)
4304              gmuji2(kkk)=mu(k,i)*gUb2(l,j)
4305 #endif
4306             enddo
4307           enddo
4308 #ifdef DEBUG
4309           write (iout,*) 'EELEC: i',i,' j',j
4310           write (iout,*) 'j',j,' j1',j1,' j2',j2
4311           write(iout,*) 'muij',muij
4312 #endif
4313           ury=scalar(uy(1,i),erij)
4314           urz=scalar(uz(1,i),erij)
4315           vry=scalar(uy(1,j),erij)
4316           vrz=scalar(uz(1,j),erij)
4317           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
4318           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
4319           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
4320           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
4321           fac=dsqrt(-ael6i)*r3ij
4322 #ifdef DEBUG
4323           write (iout,*) "ury",ury," urz",urz," vry",vry," vrz",vrz
4324           write (iout,*) "uyvy",scalar(uy(1,i),uy(1,j)),
4325      &      "uyvz",scalar(uy(1,i),uz(1,j)),
4326      &      "uzvy",scalar(uz(1,i),uy(1,j)),
4327      &      "uzvz",scalar(uz(1,i),uz(1,j))
4328           write (iout,*) "a22",a22," a23",a23," a32",a32," a33",a33
4329           write (iout,*) "fac",fac
4330 #endif
4331           a22=a22*fac
4332           a23=a23*fac
4333           a32=a32*fac
4334           a33=a33*fac
4335 #ifdef DEBUG
4336           write (iout,*) "a22",a22," a23",a23," a32",a32," a33",a33
4337 #endif
4338 #undef DEBUG
4339 cd          write (iout,'(4i5,4f10.5)')
4340 cd     &     i,itortyp(itype(i)),j,itortyp(itype(j)),a22,a23,a32,a33
4341 cd          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
4342 cd          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') uy(:,i),uz(:,i),
4343 cd     &      uy(:,j),uz(:,j)
4344 cd          write (iout,'(4f10.5)')
4345 cd     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
4346 cd     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
4347 cd          write (iout,'(4f10.5)') ury,urz,vry,vrz
4348 cd           write (iout,'(9f10.5/)')
4349 cd     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
4350 C Derivatives of the elements of A in virtual-bond vectors
4351           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
4352           do k=1,3
4353             uryg(k,1)=scalar(erder(1,k),uy(1,i))
4354             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
4355             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
4356             urzg(k,1)=scalar(erder(1,k),uz(1,i))
4357             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
4358             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
4359             vryg(k,1)=scalar(erder(1,k),uy(1,j))
4360             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
4361             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
4362             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
4363             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
4364             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
4365           enddo
4366 C Compute radial contributions to the gradient
4367           facr=-3.0d0*rrmij
4368           a22der=a22*facr
4369           a23der=a23*facr
4370           a32der=a32*facr
4371           a33der=a33*facr
4372           agg(1,1)=a22der*xj
4373           agg(2,1)=a22der*yj
4374           agg(3,1)=a22der*zj
4375           agg(1,2)=a23der*xj
4376           agg(2,2)=a23der*yj
4377           agg(3,2)=a23der*zj
4378           agg(1,3)=a32der*xj
4379           agg(2,3)=a32der*yj
4380           agg(3,3)=a32der*zj
4381           agg(1,4)=a33der*xj
4382           agg(2,4)=a33der*yj
4383           agg(3,4)=a33der*zj
4384 C Add the contributions coming from er
4385           fac3=-3.0d0*fac
4386           do k=1,3
4387             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
4388             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
4389             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
4390             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
4391           enddo
4392           do k=1,3
4393 C Derivatives in DC(i)
4394 cgrad            ghalf1=0.5d0*agg(k,1)
4395 cgrad            ghalf2=0.5d0*agg(k,2)
4396 cgrad            ghalf3=0.5d0*agg(k,3)
4397 cgrad            ghalf4=0.5d0*agg(k,4)
4398             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j))
4399      &      -3.0d0*uryg(k,2)*vry)!+ghalf1
4400             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j))
4401      &      -3.0d0*uryg(k,2)*vrz)!+ghalf2
4402             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j))
4403      &      -3.0d0*urzg(k,2)*vry)!+ghalf3
4404             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j))
4405      &      -3.0d0*urzg(k,2)*vrz)!+ghalf4
4406 C Derivatives in DC(i+1)
4407             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j))
4408      &      -3.0d0*uryg(k,3)*vry)!+agg(k,1)
4409             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j))
4410      &      -3.0d0*uryg(k,3)*vrz)!+agg(k,2)
4411             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j))
4412      &      -3.0d0*urzg(k,3)*vry)!+agg(k,3)
4413             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j))
4414      &      -3.0d0*urzg(k,3)*vrz)!+agg(k,4)
4415 C Derivatives in DC(j)
4416             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i))
4417      &      -3.0d0*vryg(k,2)*ury)!+ghalf1
4418             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i))
4419      &      -3.0d0*vrzg(k,2)*ury)!+ghalf2
4420             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i))
4421      &      -3.0d0*vryg(k,2)*urz)!+ghalf3
4422             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i))
4423      &      -3.0d0*vrzg(k,2)*urz)!+ghalf4
4424 C Derivatives in DC(j+1) or DC(nres-1)
4425             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i))
4426      &      -3.0d0*vryg(k,3)*ury)
4427             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i))
4428      &      -3.0d0*vrzg(k,3)*ury)
4429             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i))
4430      &      -3.0d0*vryg(k,3)*urz)
4431             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i))
4432      &      -3.0d0*vrzg(k,3)*urz)
4433 cgrad            if (j.eq.nres-1 .and. i.lt.j-2) then
4434 cgrad              do l=1,4
4435 cgrad                aggj1(k,l)=aggj1(k,l)+agg(k,l)
4436 cgrad              enddo
4437 cgrad            endif
4438           enddo
4439           acipa(1,1)=a22
4440           acipa(1,2)=a23
4441           acipa(2,1)=a32
4442           acipa(2,2)=a33
4443           a22=-a22
4444           a23=-a23
4445           do l=1,2
4446             do k=1,3
4447               agg(k,l)=-agg(k,l)
4448               aggi(k,l)=-aggi(k,l)
4449               aggi1(k,l)=-aggi1(k,l)
4450               aggj(k,l)=-aggj(k,l)
4451               aggj1(k,l)=-aggj1(k,l)
4452             enddo
4453           enddo
4454           if (j.lt.nres-1) then
4455             a22=-a22
4456             a32=-a32
4457             do l=1,3,2
4458               do k=1,3
4459                 agg(k,l)=-agg(k,l)
4460                 aggi(k,l)=-aggi(k,l)
4461                 aggi1(k,l)=-aggi1(k,l)
4462                 aggj(k,l)=-aggj(k,l)
4463                 aggj1(k,l)=-aggj1(k,l)
4464               enddo
4465             enddo
4466           else
4467             a22=-a22
4468             a23=-a23
4469             a32=-a32
4470             a33=-a33
4471             do l=1,4
4472               do k=1,3
4473                 agg(k,l)=-agg(k,l)
4474                 aggi(k,l)=-aggi(k,l)
4475                 aggi1(k,l)=-aggi1(k,l)
4476                 aggj(k,l)=-aggj(k,l)
4477                 aggj1(k,l)=-aggj1(k,l)
4478               enddo
4479             enddo
4480           endif
4481           ENDIF ! WCORR
4482           IF (wel_loc.gt.0.0d0) THEN
4483 C Contribution to the local-electrostatic energy coming from the i-j pair
4484           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3)
4485      &     +a33*muij(4)
4486 #ifdef DEBUG
4487           write (iout,*) "muij",muij," a22",a22," a23",a23," a32",a32,
4488      &     " a33",a33
4489           write (iout,*) "ij",i,j," eel_loc_ij",eel_loc_ij,
4490      &     " wel_loc",wel_loc
4491 #endif
4492           if (shield_mode.eq.0) then
4493            fac_shield(i)=1.0
4494            fac_shield(j)=1.0
4495 C          else
4496 C           fac_shield(i)=0.4
4497 C           fac_shield(j)=0.6
4498           endif
4499           eel_loc_ij=eel_loc_ij
4500      &    *fac_shield(i)*fac_shield(j)
4501 c          if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
4502 c     &            'eelloc',i,j,eel_loc_ij
4503 C Now derivative over eel_loc
4504           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
4505      &  (shield_mode.gt.0)) then
4506 C          print *,i,j
4507
4508           do ilist=1,ishield_list(i)
4509            iresshield=shield_list(ilist,i)
4510            do k=1,3
4511            rlocshield=grad_shield_side(k,ilist,i)*eel_loc_ij
4512      &                                          /fac_shield(i)
4513 C     &      *2.0
4514            gshieldx_ll(k,iresshield)=gshieldx_ll(k,iresshield)+
4515      &              rlocshield
4516      & +grad_shield_loc(k,ilist,i)*eel_loc_ij/fac_shield(i)
4517             gshieldc_ll(k,iresshield-1)=gshieldc_ll(k,iresshield-1)
4518      &      +rlocshield
4519            enddo
4520           enddo
4521           do ilist=1,ishield_list(j)
4522            iresshield=shield_list(ilist,j)
4523            do k=1,3
4524            rlocshield=grad_shield_side(k,ilist,j)*eel_loc_ij
4525      &                                       /fac_shield(j)
4526 C     &     *2.0
4527            gshieldx_ll(k,iresshield)=gshieldx_ll(k,iresshield)+
4528      &              rlocshield
4529      & +grad_shield_loc(k,ilist,j)*eel_loc_ij/fac_shield(j)
4530            gshieldc_ll(k,iresshield-1)=gshieldc_ll(k,iresshield-1)
4531      &             +rlocshield
4532
4533            enddo
4534           enddo
4535
4536           do k=1,3
4537             gshieldc_ll(k,i)=gshieldc_ll(k,i)+
4538      &              grad_shield(k,i)*eel_loc_ij/fac_shield(i)
4539             gshieldc_ll(k,j)=gshieldc_ll(k,j)+
4540      &              grad_shield(k,j)*eel_loc_ij/fac_shield(j)
4541             gshieldc_ll(k,i-1)=gshieldc_ll(k,i-1)+
4542      &              grad_shield(k,i)*eel_loc_ij/fac_shield(i)
4543             gshieldc_ll(k,j-1)=gshieldc_ll(k,j-1)+
4544      &              grad_shield(k,j)*eel_loc_ij/fac_shield(j)
4545            enddo
4546            endif
4547
4548
4549 c          write (iout,*) 'i',i,' j',j,itype(i),itype(j),
4550 c     &                     ' eel_loc_ij',eel_loc_ij
4551 C          write(iout,*) 'muije=',i,j,muij(1),muij(2),muij(3),muij(4)
4552 C Calculate patrial derivative for theta angle
4553 #ifdef NEWCORR
4554          geel_loc_ij=(a22*gmuij1(1)
4555      &     +a23*gmuij1(2)
4556      &     +a32*gmuij1(3)
4557      &     +a33*gmuij1(4))
4558      &    *fac_shield(i)*fac_shield(j)
4559 c         write(iout,*) "derivative over thatai"
4560 c         write(iout,*) a22*gmuij1(1), a23*gmuij1(2) ,a32*gmuij1(3),
4561 c     &   a33*gmuij1(4)
4562          gloc(nphi+i,icg)=gloc(nphi+i,icg)+
4563      &      geel_loc_ij*wel_loc
4564 c         write(iout,*) "derivative over thatai-1"
4565 c         write(iout,*) a22*gmuij2(1), a23*gmuij2(2) ,a32*gmuij2(3),
4566 c     &   a33*gmuij2(4)
4567          geel_loc_ij=
4568      &     a22*gmuij2(1)
4569      &     +a23*gmuij2(2)
4570      &     +a32*gmuij2(3)
4571      &     +a33*gmuij2(4)
4572          gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
4573      &      geel_loc_ij*wel_loc
4574      &    *fac_shield(i)*fac_shield(j)
4575
4576 c  Derivative over j residue
4577          geel_loc_ji=a22*gmuji1(1)
4578      &     +a23*gmuji1(2)
4579      &     +a32*gmuji1(3)
4580      &     +a33*gmuji1(4)
4581 c         write(iout,*) "derivative over thataj"
4582 c         write(iout,*) a22*gmuji1(1), a23*gmuji1(2) ,a32*gmuji1(3),
4583 c     &   a33*gmuji1(4)
4584
4585         gloc(nphi+j,icg)=gloc(nphi+j,icg)+
4586      &      geel_loc_ji*wel_loc
4587      &    *fac_shield(i)*fac_shield(j)
4588
4589          geel_loc_ji=
4590      &     +a22*gmuji2(1)
4591      &     +a23*gmuji2(2)
4592      &     +a32*gmuji2(3)
4593      &     +a33*gmuji2(4)
4594 c         write(iout,*) "derivative over thataj-1"
4595 c         write(iout,*) a22*gmuji2(1), a23*gmuji2(2) ,a32*gmuji2(3),
4596 c     &   a33*gmuji2(4)
4597          gloc(nphi+j-1,icg)=gloc(nphi+j-1,icg)+
4598      &      geel_loc_ji*wel_loc
4599      &    *fac_shield(i)*fac_shield(j)
4600 #endif
4601 cd          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
4602
4603           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
4604      &            'eelloc',i,j,eel_loc_ij
4605 c           if (eel_loc_ij.ne.0)
4606 c     &      write (iout,'(a4,2i4,8f9.5)')'chuj',
4607 c     &     i,j,a22,muij(1),a23,muij(2),a32,muij(3),a33,muij(4)
4608
4609           eel_loc=eel_loc+eel_loc_ij
4610 C Partial derivatives in virtual-bond dihedral angles gamma
4611           if (i.gt.1)
4612      &    gel_loc_loc(i-1)=gel_loc_loc(i-1)+
4613      &            (a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j)
4614      &           +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j))
4615      &    *fac_shield(i)*fac_shield(j)
4616
4617           gel_loc_loc(j-1)=gel_loc_loc(j-1)+
4618      &           (a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j)
4619      &           +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j))
4620      &    *fac_shield(i)*fac_shield(j)
4621 C Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
4622           do l=1,3
4623             ggg(l)=(agg(l,1)*muij(1)+
4624      &          agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4))
4625      &    *fac_shield(i)*fac_shield(j)
4626             gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l)
4627             gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l)
4628 cgrad            ghalf=0.5d0*ggg(l)
4629 cgrad            gel_loc(l,i)=gel_loc(l,i)+ghalf
4630 cgrad            gel_loc(l,j)=gel_loc(l,j)+ghalf
4631           enddo
4632 cgrad          do k=i+1,j2
4633 cgrad            do l=1,3
4634 cgrad              gel_loc(l,k)=gel_loc(l,k)+ggg(l)
4635 cgrad            enddo
4636 cgrad          enddo
4637 C Remaining derivatives of eello
4638           do l=1,3
4639             gel_loc(l,i)=gel_loc(l,i)+(aggi(l,1)*muij(1)+
4640      &        aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4))
4641      &    *fac_shield(i)*fac_shield(j)
4642
4643             gel_loc(l,i+1)=gel_loc(l,i+1)+(aggi1(l,1)*muij(1)+
4644      &     aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4))
4645      &    *fac_shield(i)*fac_shield(j)
4646
4647             gel_loc(l,j)=gel_loc(l,j)+(aggj(l,1)*muij(1)+
4648      &       aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4))
4649      &    *fac_shield(i)*fac_shield(j)
4650
4651             gel_loc(l,j1)=gel_loc(l,j1)+(aggj1(l,1)*muij(1)+
4652      &     aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4))
4653      &    *fac_shield(i)*fac_shield(j)
4654
4655           enddo
4656           ENDIF
4657 C Change 12/26/95 to calculate four-body contributions to H-bonding energy
4658 c          if (j.gt.i+1 .and. num_conti.le.maxconts) then
4659           if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0
4660      &       .and. num_conti.le.maxconts) then
4661 c            write (iout,*) i,j," entered corr"
4662 C
4663 C Calculate the contact function. The ith column of the array JCONT will
4664 C contain the numbers of atoms that make contacts with the atom I (of numbers
4665 C greater than I). The arrays FACONT and GACONT will contain the values of
4666 C the contact function and its derivative.
4667 c           r0ij=1.02D0*rpp(iteli,itelj)
4668 c           r0ij=1.11D0*rpp(iteli,itelj)
4669             r0ij=2.20D0*rpp(iteli,itelj)
4670 c           r0ij=1.55D0*rpp(iteli,itelj)
4671             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
4672             if (fcont.gt.0.0D0) then
4673               num_conti=num_conti+1
4674               if (num_conti.gt.maxconts) then
4675                 write (iout,*) 'WARNING - max. # of contacts exceeded;',
4676      &                         ' will skip next contacts for this conf.'
4677               else
4678                 jcont_hb(num_conti,i)=j
4679 cd                write (iout,*) "i",i," j",j," num_conti",num_conti,
4680 cd     &           " jcont_hb",jcont_hb(num_conti,i)
4681                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.
4682      &          wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
4683 C 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
4684 C  terms.
4685                 d_cont(num_conti,i)=rij
4686 cd                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
4687 C     --- Electrostatic-interaction matrix ---
4688                 a_chuj(1,1,num_conti,i)=a22
4689                 a_chuj(1,2,num_conti,i)=a23
4690                 a_chuj(2,1,num_conti,i)=a32
4691                 a_chuj(2,2,num_conti,i)=a33
4692 C     --- Gradient of rij
4693                 do kkk=1,3
4694                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
4695                 enddo
4696                 kkll=0
4697                 do k=1,2
4698                   do l=1,2
4699                     kkll=kkll+1
4700                     do m=1,3
4701                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
4702                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
4703                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
4704                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
4705                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
4706                     enddo
4707                   enddo
4708                 enddo
4709                 ENDIF
4710                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
4711 C Calculate contact energies
4712                 cosa4=4.0D0*cosa
4713                 wij=cosa-3.0D0*cosb*cosg
4714                 cosbg1=cosb+cosg
4715                 cosbg2=cosb-cosg
4716 c               fac3=dsqrt(-ael6i)/r0ij**3
4717                 fac3=dsqrt(-ael6i)*r3ij
4718 c                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
4719                 ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
4720                 if (ees0tmp.gt.0) then
4721                   ees0pij=dsqrt(ees0tmp)
4722                 else
4723                   ees0pij=0
4724                 endif
4725 c                ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
4726                 ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
4727                 if (ees0tmp.gt.0) then
4728                   ees0mij=dsqrt(ees0tmp)
4729                 else
4730                   ees0mij=0
4731                 endif
4732 c               ees0mij=0.0D0
4733                 if (shield_mode.eq.0) then
4734                 fac_shield(i)=1.0d0
4735                 fac_shield(j)=1.0d0
4736                 else
4737                 ees0plist(num_conti,i)=j
4738 C                fac_shield(i)=0.4d0
4739 C                fac_shield(j)=0.6d0
4740                 endif
4741                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij)
4742      &          *fac_shield(i)*fac_shield(j)
4743                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij)
4744      &          *fac_shield(i)*fac_shield(j)
4745 C Diagnostics. Comment out or remove after debugging!
4746 c               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
4747 c               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
4748 c               ees0m(num_conti,i)=0.0D0
4749 C End diagnostics.
4750 c               write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
4751 c    & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
4752 C Angular derivatives of the contact function
4753                 ees0pij1=fac3/ees0pij
4754                 ees0mij1=fac3/ees0mij
4755                 fac3p=-3.0D0*fac3*rrmij
4756                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
4757                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
4758 c               ees0mij1=0.0D0
4759                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
4760                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
4761                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
4762                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
4763                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
4764                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
4765                 ecosap=ecosa1+ecosa2
4766                 ecosbp=ecosb1+ecosb2
4767                 ecosgp=ecosg1+ecosg2
4768                 ecosam=ecosa1-ecosa2
4769                 ecosbm=ecosb1-ecosb2
4770                 ecosgm=ecosg1-ecosg2
4771 C Diagnostics
4772 c               ecosap=ecosa1
4773 c               ecosbp=ecosb1
4774 c               ecosgp=ecosg1
4775 c               ecosam=0.0D0
4776 c               ecosbm=0.0D0
4777 c               ecosgm=0.0D0
4778 C End diagnostics
4779                 facont_hb(num_conti,i)=fcont
4780                 fprimcont=fprimcont/rij
4781 cd              facont_hb(num_conti,i)=1.0D0
4782 C Following line is for diagnostics.
4783 cd              fprimcont=0.0D0
4784                 do k=1,3
4785                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
4786                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
4787                 enddo
4788                 do k=1,3
4789                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
4790                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
4791                 enddo
4792                 gggp(1)=gggp(1)+ees0pijp*xj
4793                 gggp(2)=gggp(2)+ees0pijp*yj
4794                 gggp(3)=gggp(3)+ees0pijp*zj
4795                 gggm(1)=gggm(1)+ees0mijp*xj
4796                 gggm(2)=gggm(2)+ees0mijp*yj
4797                 gggm(3)=gggm(3)+ees0mijp*zj
4798 C Derivatives due to the contact function
4799                 gacont_hbr(1,num_conti,i)=fprimcont*xj
4800                 gacont_hbr(2,num_conti,i)=fprimcont*yj
4801                 gacont_hbr(3,num_conti,i)=fprimcont*zj
4802                 do k=1,3
4803 c
4804 c 10/24/08 cgrad and ! comments indicate the parts of the code removed
4805 c          following the change of gradient-summation algorithm.
4806 c
4807 cgrad                  ghalfp=0.5D0*gggp(k)
4808 cgrad                  ghalfm=0.5D0*gggm(k)
4809                   gacontp_hb1(k,num_conti,i)=!ghalfp
4810      &              +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i))
4811      &              + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
4812      &          *fac_shield(i)*fac_shield(j)
4813
4814                   gacontp_hb2(k,num_conti,i)=!ghalfp
4815      &              +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j))
4816      &              + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
4817      &          *fac_shield(i)*fac_shield(j)
4818
4819                   gacontp_hb3(k,num_conti,i)=gggp(k)
4820      &          *fac_shield(i)*fac_shield(j)
4821
4822                   gacontm_hb1(k,num_conti,i)=!ghalfm
4823      &              +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i))
4824      &              + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
4825      &          *fac_shield(i)*fac_shield(j)
4826
4827                   gacontm_hb2(k,num_conti,i)=!ghalfm
4828      &              +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j))
4829      &              + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
4830      &          *fac_shield(i)*fac_shield(j)
4831
4832                   gacontm_hb3(k,num_conti,i)=gggm(k)
4833      &          *fac_shield(i)*fac_shield(j)
4834
4835                 enddo
4836 C Diagnostics. Comment out or remove after debugging!
4837 cdiag           do k=1,3
4838 cdiag             gacontp_hb1(k,num_conti,i)=0.0D0
4839 cdiag             gacontp_hb2(k,num_conti,i)=0.0D0
4840 cdiag             gacontp_hb3(k,num_conti,i)=0.0D0
4841 cdiag             gacontm_hb1(k,num_conti,i)=0.0D0
4842 cdiag             gacontm_hb2(k,num_conti,i)=0.0D0
4843 cdiag             gacontm_hb3(k,num_conti,i)=0.0D0
4844 cdiag           enddo
4845               ENDIF ! wcorr
4846               endif  ! num_conti.le.maxconts
4847             endif  ! fcont.gt.0
4848           endif    ! j.gt.i+1
4849           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
4850             do k=1,4
4851               do l=1,3
4852                 ghalf=0.5d0*agg(l,k)
4853                 aggi(l,k)=aggi(l,k)+ghalf
4854                 aggi1(l,k)=aggi1(l,k)+agg(l,k)
4855                 aggj(l,k)=aggj(l,k)+ghalf
4856               enddo
4857             enddo
4858             if (j.eq.nres-1 .and. i.lt.j-2) then
4859               do k=1,4
4860                 do l=1,3
4861                   aggj1(l,k)=aggj1(l,k)+agg(l,k)
4862                 enddo
4863               enddo
4864             endif
4865           endif
4866 c          t_eelecij=t_eelecij+MPI_Wtime()-time00
4867       return
4868       end
4869 C-----------------------------------------------------------------------------
4870       subroutine eturn3(i,eello_turn3)
4871 C Third- and fourth-order contributions from turns
4872       implicit real*8 (a-h,o-z)
4873       include 'DIMENSIONS'
4874       include 'COMMON.IOUNITS'
4875       include 'COMMON.GEO'
4876       include 'COMMON.VAR'
4877       include 'COMMON.LOCAL'
4878       include 'COMMON.CHAIN'
4879       include 'COMMON.DERIV'
4880       include 'COMMON.INTERACT'
4881       include 'COMMON.CONTACTS'
4882       include 'COMMON.TORSION'
4883       include 'COMMON.VECTORS'
4884       include 'COMMON.FFIELD'
4885       include 'COMMON.CONTROL'
4886       include 'COMMON.SHIELD'
4887       dimension ggg(3)
4888       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
4889      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
4890      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2),gpizda1(2,2),
4891      &  gpizda2(2,2),auxgmat1(2,2),auxgmatt1(2,2),
4892      &  auxgmat2(2,2),auxgmatt2(2,2)
4893       double precision agg(3,4),aggi(3,4),aggi1(3,4),
4894      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
4895       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
4896      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
4897      &    num_conti,j1,j2
4898       j=i+2
4899 c      write (iout,*) "eturn3",i,j,j1,j2
4900       a_temp(1,1)=a22
4901       a_temp(1,2)=a23
4902       a_temp(2,1)=a32
4903       a_temp(2,2)=a33
4904 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4905 C
4906 C               Third-order contributions
4907 C
4908 C                 (i+2)o----(i+3)
4909 C                      | |
4910 C                      | |
4911 C                 (i+1)o----i
4912 C
4913 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4914 cd        call checkint_turn3(i,a_temp,eello_turn3_num)
4915         call matmat2(EUg(1,1,i+1),EUg(1,1,i+2),auxmat(1,1))
4916 c auxalary matices for theta gradient
4917 c auxalary matrix for i+1 and constant i+2
4918         call matmat2(gtEUg(1,1,i+1),EUg(1,1,i+2),auxgmat1(1,1))
4919 c auxalary matrix for i+2 and constant i+1
4920         call matmat2(EUg(1,1,i+1),gtEUg(1,1,i+2),auxgmat2(1,1))
4921         call transpose2(auxmat(1,1),auxmat1(1,1))
4922         call transpose2(auxgmat1(1,1),auxgmatt1(1,1))
4923         call transpose2(auxgmat2(1,1),auxgmatt2(1,1))
4924         call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4925         call matmat2(a_temp(1,1),auxgmatt1(1,1),gpizda1(1,1))
4926         call matmat2(a_temp(1,1),auxgmatt2(1,1),gpizda2(1,1))
4927         if (shield_mode.eq.0) then
4928         fac_shield(i)=1.0
4929         fac_shield(j)=1.0
4930 C        else
4931 C        fac_shield(i)=0.4
4932 C        fac_shield(j)=0.6
4933         endif
4934         eello_turn3=eello_turn3+0.5d0*(pizda(1,1)+pizda(2,2))
4935      &  *fac_shield(i)*fac_shield(j)
4936         eello_t3=0.5d0*(pizda(1,1)+pizda(2,2))
4937      &  *fac_shield(i)*fac_shield(j)
4938         if (energy_dec) write (iout,'(6heturn3,2i5,0pf7.3)') i,i+2,
4939      &    eello_t3
4940 C#ifdef NEWCORR
4941 C Derivatives in theta
4942         gloc(nphi+i,icg)=gloc(nphi+i,icg)
4943      &  +0.5d0*(gpizda1(1,1)+gpizda1(2,2))*wturn3
4944      &   *fac_shield(i)*fac_shield(j)
4945         gloc(nphi+i+1,icg)=gloc(nphi+i+1,icg)
4946      &  +0.5d0*(gpizda2(1,1)+gpizda2(2,2))*wturn3
4947      &   *fac_shield(i)*fac_shield(j)
4948 C#endif
4949
4950 C Derivatives in shield mode
4951           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
4952      &  (shield_mode.gt.0)) then
4953 C          print *,i,j
4954
4955           do ilist=1,ishield_list(i)
4956            iresshield=shield_list(ilist,i)
4957            do k=1,3
4958            rlocshield=grad_shield_side(k,ilist,i)*eello_t3/fac_shield(i)
4959 C     &      *2.0
4960            gshieldx_t3(k,iresshield)=gshieldx_t3(k,iresshield)+
4961      &              rlocshield
4962      & +grad_shield_loc(k,ilist,i)*eello_t3/fac_shield(i)
4963             gshieldc_t3(k,iresshield-1)=gshieldc_t3(k,iresshield-1)
4964      &      +rlocshield
4965            enddo
4966           enddo
4967           do ilist=1,ishield_list(j)
4968            iresshield=shield_list(ilist,j)
4969            do k=1,3
4970            rlocshield=grad_shield_side(k,ilist,j)*eello_t3/fac_shield(j)
4971 C     &     *2.0
4972            gshieldx_t3(k,iresshield)=gshieldx_t3(k,iresshield)+
4973      &              rlocshield
4974      & +grad_shield_loc(k,ilist,j)*eello_t3/fac_shield(j)
4975            gshieldc_t3(k,iresshield-1)=gshieldc_t3(k,iresshield-1)
4976      &             +rlocshield
4977
4978            enddo
4979           enddo
4980
4981           do k=1,3
4982             gshieldc_t3(k,i)=gshieldc_t3(k,i)+
4983      &              grad_shield(k,i)*eello_t3/fac_shield(i)
4984             gshieldc_t3(k,j)=gshieldc_t3(k,j)+
4985      &              grad_shield(k,j)*eello_t3/fac_shield(j)
4986             gshieldc_t3(k,i-1)=gshieldc_t3(k,i-1)+
4987      &              grad_shield(k,i)*eello_t3/fac_shield(i)
4988             gshieldc_t3(k,j-1)=gshieldc_t3(k,j-1)+
4989      &              grad_shield(k,j)*eello_t3/fac_shield(j)
4990            enddo
4991            endif
4992
4993 C        if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
4994 cd        write (2,*) 'i,',i,' j',j,'eello_turn3',
4995 cd     &    0.5d0*(pizda(1,1)+pizda(2,2)),
4996 cd     &    ' eello_turn3_num',4*eello_turn3_num
4997 C Derivatives in gamma(i)
4998         call matmat2(EUgder(1,1,i+1),EUg(1,1,i+2),auxmat2(1,1))
4999         call transpose2(auxmat2(1,1),auxmat3(1,1))
5000         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
5001         gel_loc_turn3(i)=gel_loc_turn3(i)+0.5d0*(pizda(1,1)+pizda(2,2))
5002      &   *fac_shield(i)*fac_shield(j)
5003 C Derivatives in gamma(i+1)
5004         call matmat2(EUg(1,1,i+1),EUgder(1,1,i+2),auxmat2(1,1))
5005         call transpose2(auxmat2(1,1),auxmat3(1,1))
5006         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
5007         gel_loc_turn3(i+1)=gel_loc_turn3(i+1)
5008      &    +0.5d0*(pizda(1,1)+pizda(2,2))
5009      &   *fac_shield(i)*fac_shield(j)
5010 C Cartesian derivatives
5011         do l=1,3
5012 c            ghalf1=0.5d0*agg(l,1)
5013 c            ghalf2=0.5d0*agg(l,2)
5014 c            ghalf3=0.5d0*agg(l,3)
5015 c            ghalf4=0.5d0*agg(l,4)
5016           a_temp(1,1)=aggi(l,1)!+ghalf1
5017           a_temp(1,2)=aggi(l,2)!+ghalf2
5018           a_temp(2,1)=aggi(l,3)!+ghalf3
5019           a_temp(2,2)=aggi(l,4)!+ghalf4
5020           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
5021           gcorr3_turn(l,i)=gcorr3_turn(l,i)
5022      &      +0.5d0*(pizda(1,1)+pizda(2,2))
5023      &   *fac_shield(i)*fac_shield(j)
5024
5025           a_temp(1,1)=aggi1(l,1)!+agg(l,1)
5026           a_temp(1,2)=aggi1(l,2)!+agg(l,2)
5027           a_temp(2,1)=aggi1(l,3)!+agg(l,3)
5028           a_temp(2,2)=aggi1(l,4)!+agg(l,4)
5029           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
5030           gcorr3_turn(l,i+1)=gcorr3_turn(l,i+1)
5031      &      +0.5d0*(pizda(1,1)+pizda(2,2))
5032      &   *fac_shield(i)*fac_shield(j)
5033           a_temp(1,1)=aggj(l,1)!+ghalf1
5034           a_temp(1,2)=aggj(l,2)!+ghalf2
5035           a_temp(2,1)=aggj(l,3)!+ghalf3
5036           a_temp(2,2)=aggj(l,4)!+ghalf4
5037           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
5038           gcorr3_turn(l,j)=gcorr3_turn(l,j)
5039      &      +0.5d0*(pizda(1,1)+pizda(2,2))
5040      &   *fac_shield(i)*fac_shield(j)
5041           a_temp(1,1)=aggj1(l,1)
5042           a_temp(1,2)=aggj1(l,2)
5043           a_temp(2,1)=aggj1(l,3)
5044           a_temp(2,2)=aggj1(l,4)
5045           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
5046           gcorr3_turn(l,j1)=gcorr3_turn(l,j1)
5047      &      +0.5d0*(pizda(1,1)+pizda(2,2))
5048      &   *fac_shield(i)*fac_shield(j)
5049         enddo
5050       return
5051       end
5052 C-------------------------------------------------------------------------------
5053       subroutine eturn4(i,eello_turn4)
5054 C Third- and fourth-order contributions from turns
5055       implicit real*8 (a-h,o-z)
5056       include 'DIMENSIONS'
5057       include 'COMMON.IOUNITS'
5058       include 'COMMON.GEO'
5059       include 'COMMON.VAR'
5060       include 'COMMON.LOCAL'
5061       include 'COMMON.CHAIN'
5062       include 'COMMON.DERIV'
5063       include 'COMMON.INTERACT'
5064       include 'COMMON.CONTACTS'
5065       include 'COMMON.TORSION'
5066       include 'COMMON.VECTORS'
5067       include 'COMMON.FFIELD'
5068       include 'COMMON.CONTROL'
5069       include 'COMMON.SHIELD'
5070       dimension ggg(3)
5071       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
5072      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
5073      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2),auxgvec(2),
5074      &  auxgEvec1(2),auxgEvec2(2),auxgEvec3(2),
5075      &  gte1t(2,2),gte2t(2,2),gte3t(2,2),
5076      &  gte1a(2,2),gtae3(2,2),gtae3e2(2,2), ae3gte2(2,2),
5077      &  gtEpizda1(2,2),gtEpizda2(2,2),gtEpizda3(2,2)
5078       double precision agg(3,4),aggi(3,4),aggi1(3,4),
5079      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
5080       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
5081      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
5082      &    num_conti,j1,j2
5083       j=i+3
5084 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
5085 C
5086 C               Fourth-order contributions
5087 C
5088 C                 (i+3)o----(i+4)
5089 C                     /  |
5090 C               (i+2)o   |
5091 C                     \  |
5092 C                 (i+1)o----i
5093 C
5094 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
5095 cd        call checkint_turn4(i,a_temp,eello_turn4_num)
5096 c        write (iout,*) "eturn4 i",i," j",j," j1",j1," j2",j2
5097 c        write(iout,*)"WCHODZE W PROGRAM"
5098         a_temp(1,1)=a22
5099         a_temp(1,2)=a23
5100         a_temp(2,1)=a32
5101         a_temp(2,2)=a33
5102         iti1=itype2loc(itype(i+1))
5103         iti2=itype2loc(itype(i+2))
5104         iti3=itype2loc(itype(i+3))
5105 c        write(iout,*) "iti1",iti1," iti2",iti2," iti3",iti3
5106         call transpose2(EUg(1,1,i+1),e1t(1,1))
5107         call transpose2(Eug(1,1,i+2),e2t(1,1))
5108         call transpose2(Eug(1,1,i+3),e3t(1,1))
5109 C Ematrix derivative in theta
5110         call transpose2(gtEUg(1,1,i+1),gte1t(1,1))
5111         call transpose2(gtEug(1,1,i+2),gte2t(1,1))
5112         call transpose2(gtEug(1,1,i+3),gte3t(1,1))
5113         call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5114 c       eta1 in derivative theta
5115         call matmat2(gte1t(1,1),a_temp(1,1),gte1a(1,1))
5116         call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5117 c       auxgvec is derivative of Ub2 so i+3 theta
5118         call matvec2(e1a(1,1),gUb2(1,i+3),auxgvec(1))
5119 c       auxalary matrix of E i+1
5120         call matvec2(gte1a(1,1),Ub2(1,i+3),auxgEvec1(1))
5121 c        s1=0.0
5122 c        gs1=0.0
5123         s1=scalar2(b1(1,i+2),auxvec(1))
5124 c derivative of theta i+2 with constant i+3
5125         gs23=scalar2(gtb1(1,i+2),auxvec(1))
5126 c derivative of theta i+2 with constant i+2
5127         gs32=scalar2(b1(1,i+2),auxgvec(1))
5128 c derivative of E matix in theta of i+1
5129         gsE13=scalar2(b1(1,i+2),auxgEvec1(1))
5130
5131         call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5132 c       ea31 in derivative theta
5133         call matmat2(a_temp(1,1),gte3t(1,1),gtae3(1,1))
5134         call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5135 c auxilary matrix auxgvec of Ub2 with constant E matirx
5136         call matvec2(ae3(1,1),gUb2(1,i+2),auxgvec(1))
5137 c auxilary matrix auxgEvec1 of E matix with Ub2 constant
5138         call matvec2(gtae3(1,1),Ub2(1,i+2),auxgEvec3(1))
5139
5140 c        s2=0.0
5141 c        gs2=0.0
5142         s2=scalar2(b1(1,i+1),auxvec(1))
5143 c derivative of theta i+1 with constant i+3
5144         gs13=scalar2(gtb1(1,i+1),auxvec(1))
5145 c derivative of theta i+2 with constant i+1
5146         gs21=scalar2(b1(1,i+1),auxgvec(1))
5147 c derivative of theta i+3 with constant i+1
5148         gsE31=scalar2(b1(1,i+1),auxgEvec3(1))
5149 c        write(iout,*) gs1,gs2,'i=',i,auxgvec(1),gUb2(1,i+2),gtb1(1,i+2),
5150 c     &  gtb1(1,i+1)
5151         call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5152 c two derivatives over diffetent matrices
5153 c gtae3e2 is derivative over i+3
5154         call matmat2(gtae3(1,1),e2t(1,1),gtae3e2(1,1))
5155 c ae3gte2 is derivative over i+2
5156         call matmat2(ae3(1,1),gte2t(1,1),ae3gte2(1,1))
5157         call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5158 c three possible derivative over theta E matices
5159 c i+1
5160         call matmat2(ae3e2(1,1),gte1t(1,1),gtEpizda1(1,1))
5161 c i+2
5162         call matmat2(ae3gte2(1,1),e1t(1,1),gtEpizda2(1,1))
5163 c i+3
5164         call matmat2(gtae3e2(1,1),e1t(1,1),gtEpizda3(1,1))
5165         s3=0.5d0*(pizda(1,1)+pizda(2,2))
5166
5167         gsEE1=0.5d0*(gtEpizda1(1,1)+gtEpizda1(2,2))
5168         gsEE2=0.5d0*(gtEpizda2(1,1)+gtEpizda2(2,2))
5169         gsEE3=0.5d0*(gtEpizda3(1,1)+gtEpizda3(2,2))
5170         if (shield_mode.eq.0) then
5171         fac_shield(i)=1.0
5172         fac_shield(j)=1.0
5173 C        else
5174 C        fac_shield(i)=0.6
5175 C        fac_shield(j)=0.4
5176         endif
5177         eello_turn4=eello_turn4-(s1+s2+s3)
5178      &  *fac_shield(i)*fac_shield(j)
5179         eello_t4=-(s1+s2+s3)
5180      &  *fac_shield(i)*fac_shield(j)
5181 c             write(iout,*)'chujOWO', auxvec(1),b1(1,iti2)
5182         if (energy_dec) write (iout,'(a6,2i5,0pf7.3,3f7.3)')
5183      &      'eturn4',i,j,-(s1+s2+s3),s1,s2,s3
5184 C Now derivative over shield:
5185           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
5186      &  (shield_mode.gt.0)) then
5187 C          print *,i,j
5188
5189           do ilist=1,ishield_list(i)
5190            iresshield=shield_list(ilist,i)
5191            do k=1,3
5192            rlocshield=grad_shield_side(k,ilist,i)*eello_t4/fac_shield(i)
5193 C     &      *2.0
5194            gshieldx_t4(k,iresshield)=gshieldx_t4(k,iresshield)+
5195      &              rlocshield
5196      & +grad_shield_loc(k,ilist,i)*eello_t4/fac_shield(i)
5197             gshieldc_t4(k,iresshield-1)=gshieldc_t4(k,iresshield-1)
5198      &      +rlocshield
5199            enddo
5200           enddo
5201           do ilist=1,ishield_list(j)
5202            iresshield=shield_list(ilist,j)
5203            do k=1,3
5204            rlocshield=grad_shield_side(k,ilist,j)*eello_t4/fac_shield(j)
5205 C     &     *2.0
5206            gshieldx_t4(k,iresshield)=gshieldx_t4(k,iresshield)+
5207      &              rlocshield
5208      & +grad_shield_loc(k,ilist,j)*eello_t4/fac_shield(j)
5209            gshieldc_t4(k,iresshield-1)=gshieldc_t4(k,iresshield-1)
5210      &             +rlocshield
5211
5212            enddo
5213           enddo
5214
5215           do k=1,3
5216             gshieldc_t4(k,i)=gshieldc_t4(k,i)+
5217      &              grad_shield(k,i)*eello_t4/fac_shield(i)
5218             gshieldc_t4(k,j)=gshieldc_t4(k,j)+
5219      &              grad_shield(k,j)*eello_t4/fac_shield(j)
5220             gshieldc_t4(k,i-1)=gshieldc_t4(k,i-1)+
5221      &              grad_shield(k,i)*eello_t4/fac_shield(i)
5222             gshieldc_t4(k,j-1)=gshieldc_t4(k,j-1)+
5223      &              grad_shield(k,j)*eello_t4/fac_shield(j)
5224            enddo
5225            endif
5226
5227
5228
5229
5230
5231
5232 cd        write (2,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
5233 cd     &    ' eello_turn4_num',8*eello_turn4_num
5234 #ifdef NEWCORR
5235         gloc(nphi+i,icg)=gloc(nphi+i,icg)
5236      &                  -(gs13+gsE13+gsEE1)*wturn4
5237      &  *fac_shield(i)*fac_shield(j)
5238         gloc(nphi+i+1,icg)= gloc(nphi+i+1,icg)
5239      &                    -(gs23+gs21+gsEE2)*wturn4
5240      &  *fac_shield(i)*fac_shield(j)
5241
5242         gloc(nphi+i+2,icg)= gloc(nphi+i+2,icg)
5243      &                    -(gs32+gsE31+gsEE3)*wturn4
5244      &  *fac_shield(i)*fac_shield(j)
5245
5246 c         gloc(nphi+i+1,icg)=gloc(nphi+i+1,icg)-
5247 c     &   gs2
5248 #endif
5249         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
5250      &      'eturn4',i,j,-(s1+s2+s3)
5251 c        write (iout,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
5252 c     &    ' eello_turn4_num',8*eello_turn4_num
5253 C Derivatives in gamma(i)
5254         call transpose2(EUgder(1,1,i+1),e1tder(1,1))
5255         call matmat2(e1tder(1,1),a_temp(1,1),auxmat(1,1))
5256         call matvec2(auxmat(1,1),Ub2(1,i+3),auxvec(1))
5257         s1=scalar2(b1(1,i+2),auxvec(1))
5258         call matmat2(ae3e2(1,1),e1tder(1,1),pizda(1,1))
5259         s3=0.5d0*(pizda(1,1)+pizda(2,2))
5260         gel_loc_turn4(i)=gel_loc_turn4(i)-(s1+s3)
5261      &  *fac_shield(i)*fac_shield(j)
5262 C Derivatives in gamma(i+1)
5263         call transpose2(EUgder(1,1,i+2),e2tder(1,1))
5264         call matvec2(ae3(1,1),Ub2der(1,i+2),auxvec(1))
5265         s2=scalar2(b1(1,i+1),auxvec(1))
5266         call matmat2(ae3(1,1),e2tder(1,1),auxmat(1,1))
5267         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
5268         s3=0.5d0*(pizda(1,1)+pizda(2,2))
5269         gel_loc_turn4(i+1)=gel_loc_turn4(i+1)-(s2+s3)
5270      &  *fac_shield(i)*fac_shield(j)
5271 C Derivatives in gamma(i+2)
5272         call transpose2(EUgder(1,1,i+3),e3tder(1,1))
5273         call matvec2(e1a(1,1),Ub2der(1,i+3),auxvec(1))
5274         s1=scalar2(b1(1,i+2),auxvec(1))
5275         call matmat2(a_temp(1,1),e3tder(1,1),auxmat(1,1))
5276         call matvec2(auxmat(1,1),Ub2(1,i+2),auxvec(1))
5277         s2=scalar2(b1(1,i+1),auxvec(1))
5278         call matmat2(auxmat(1,1),e2t(1,1),auxmat3(1,1))
5279         call matmat2(auxmat3(1,1),e1t(1,1),pizda(1,1))
5280         s3=0.5d0*(pizda(1,1)+pizda(2,2))
5281         gel_loc_turn4(i+2)=gel_loc_turn4(i+2)-(s1+s2+s3)
5282      &  *fac_shield(i)*fac_shield(j)
5283 C Cartesian derivatives
5284 C Derivatives of this turn contributions in DC(i+2)
5285         if (j.lt.nres-1) then
5286           do l=1,3
5287             a_temp(1,1)=agg(l,1)
5288             a_temp(1,2)=agg(l,2)
5289             a_temp(2,1)=agg(l,3)
5290             a_temp(2,2)=agg(l,4)
5291             call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5292             call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5293             s1=scalar2(b1(1,i+2),auxvec(1))
5294             call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5295             call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5296             s2=scalar2(b1(1,i+1),auxvec(1))
5297             call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5298             call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5299             s3=0.5d0*(pizda(1,1)+pizda(2,2))
5300             ggg(l)=-(s1+s2+s3)
5301             gcorr4_turn(l,i+2)=gcorr4_turn(l,i+2)-(s1+s2+s3)
5302      &  *fac_shield(i)*fac_shield(j)
5303           enddo
5304         endif
5305 C Remaining derivatives of this turn contribution
5306         do l=1,3
5307           a_temp(1,1)=aggi(l,1)
5308           a_temp(1,2)=aggi(l,2)
5309           a_temp(2,1)=aggi(l,3)
5310           a_temp(2,2)=aggi(l,4)
5311           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5312           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5313           s1=scalar2(b1(1,i+2),auxvec(1))
5314           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5315           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5316           s2=scalar2(b1(1,i+1),auxvec(1))
5317           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5318           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5319           s3=0.5d0*(pizda(1,1)+pizda(2,2))
5320           gcorr4_turn(l,i)=gcorr4_turn(l,i)-(s1+s2+s3)
5321      &  *fac_shield(i)*fac_shield(j)
5322           a_temp(1,1)=aggi1(l,1)
5323           a_temp(1,2)=aggi1(l,2)
5324           a_temp(2,1)=aggi1(l,3)
5325           a_temp(2,2)=aggi1(l,4)
5326           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5327           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5328           s1=scalar2(b1(1,i+2),auxvec(1))
5329           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5330           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5331           s2=scalar2(b1(1,i+1),auxvec(1))
5332           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5333           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5334           s3=0.5d0*(pizda(1,1)+pizda(2,2))
5335           gcorr4_turn(l,i+1)=gcorr4_turn(l,i+1)-(s1+s2+s3)
5336      &  *fac_shield(i)*fac_shield(j)
5337           a_temp(1,1)=aggj(l,1)
5338           a_temp(1,2)=aggj(l,2)
5339           a_temp(2,1)=aggj(l,3)
5340           a_temp(2,2)=aggj(l,4)
5341           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5342           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5343           s1=scalar2(b1(1,i+2),auxvec(1))
5344           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5345           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5346           s2=scalar2(b1(1,i+1),auxvec(1))
5347           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5348           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5349           s3=0.5d0*(pizda(1,1)+pizda(2,2))
5350           gcorr4_turn(l,j)=gcorr4_turn(l,j)-(s1+s2+s3)
5351      &  *fac_shield(i)*fac_shield(j)
5352           a_temp(1,1)=aggj1(l,1)
5353           a_temp(1,2)=aggj1(l,2)
5354           a_temp(2,1)=aggj1(l,3)
5355           a_temp(2,2)=aggj1(l,4)
5356           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5357           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5358           s1=scalar2(b1(1,i+2),auxvec(1))
5359           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5360           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5361           s2=scalar2(b1(1,i+1),auxvec(1))
5362           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5363           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5364           s3=0.5d0*(pizda(1,1)+pizda(2,2))
5365 c          write (iout,*) "s1",s1," s2",s2," s3",s3," s1+s2+s3",s1+s2+s3
5366           gcorr4_turn(l,j1)=gcorr4_turn(l,j1)-(s1+s2+s3)
5367      &  *fac_shield(i)*fac_shield(j)
5368         enddo
5369       return
5370       end
5371 C-----------------------------------------------------------------------------
5372       subroutine vecpr(u,v,w)
5373       implicit real*8(a-h,o-z)
5374       dimension u(3),v(3),w(3)
5375       w(1)=u(2)*v(3)-u(3)*v(2)
5376       w(2)=-u(1)*v(3)+u(3)*v(1)
5377       w(3)=u(1)*v(2)-u(2)*v(1)
5378       return
5379       end
5380 C-----------------------------------------------------------------------------
5381       subroutine unormderiv(u,ugrad,unorm,ungrad)
5382 C This subroutine computes the derivatives of a normalized vector u, given
5383 C the derivatives computed without normalization conditions, ugrad. Returns
5384 C ungrad.
5385       implicit none
5386       double precision u(3),ugrad(3,3),unorm,ungrad(3,3)
5387       double precision vec(3)
5388       double precision scalar
5389       integer i,j
5390 c      write (2,*) 'ugrad',ugrad
5391 c      write (2,*) 'u',u
5392       do i=1,3
5393         vec(i)=scalar(ugrad(1,i),u(1))
5394       enddo
5395 c      write (2,*) 'vec',vec
5396       do i=1,3
5397         do j=1,3
5398           ungrad(j,i)=(ugrad(j,i)-u(j)*vec(i))*unorm
5399         enddo
5400       enddo
5401 c      write (2,*) 'ungrad',ungrad
5402       return
5403       end
5404 C-----------------------------------------------------------------------------
5405       subroutine escp_soft_sphere(evdw2,evdw2_14)
5406 C
5407 C This subroutine calculates the excluded-volume interaction energy between
5408 C peptide-group centers and side chains and its gradient in virtual-bond and
5409 C side-chain vectors.
5410 C
5411       implicit real*8 (a-h,o-z)
5412       include 'DIMENSIONS'
5413       include 'COMMON.GEO'
5414       include 'COMMON.VAR'
5415       include 'COMMON.LOCAL'
5416       include 'COMMON.CHAIN'
5417       include 'COMMON.DERIV'
5418       include 'COMMON.INTERACT'
5419       include 'COMMON.FFIELD'
5420       include 'COMMON.IOUNITS'
5421       include 'COMMON.CONTROL'
5422       dimension ggg(3)
5423       integer xshift,yshift,zshift
5424       evdw2=0.0D0
5425       evdw2_14=0.0d0
5426       r0_scp=4.5d0
5427 cd    print '(a)','Enter ESCP'
5428 cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
5429 C      do xshift=-1,1
5430 C      do yshift=-1,1
5431 C      do zshift=-1,1
5432       do i=iatscp_s,iatscp_e
5433         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
5434         iteli=itel(i)
5435         xi=0.5D0*(c(1,i)+c(1,i+1))
5436         yi=0.5D0*(c(2,i)+c(2,i+1))
5437         zi=0.5D0*(c(3,i)+c(3,i+1))
5438 C Return atom into box, boxxsize is size of box in x dimension
5439 c  134   continue
5440 c        if (xi.gt.((xshift+0.5d0)*boxxsize)) xi=xi-boxxsize
5441 c        if (xi.lt.((xshift-0.5d0)*boxxsize)) xi=xi+boxxsize
5442 C Condition for being inside the proper box
5443 c        if ((xi.gt.((xshift+0.5d0)*boxxsize)).or.
5444 c     &       (xi.lt.((xshift-0.5d0)*boxxsize))) then
5445 c        go to 134
5446 c        endif
5447 c  135   continue
5448 c        if (yi.gt.((yshift+0.5d0)*boxysize)) yi=yi-boxysize
5449 c        if (yi.lt.((yshift-0.5d0)*boxysize)) yi=yi+boxysize
5450 C Condition for being inside the proper box
5451 c        if ((yi.gt.((yshift+0.5d0)*boxysize)).or.
5452 c     &       (yi.lt.((yshift-0.5d0)*boxysize))) then
5453 c        go to 135
5454 c c       endif
5455 c  136   continue
5456 c        if (zi.gt.((zshift+0.5d0)*boxzsize)) zi=zi-boxzsize
5457 c        if (zi.lt.((zshift-0.5d0)*boxzsize)) zi=zi+boxzsize
5458 cC Condition for being inside the proper box
5459 c        if ((zi.gt.((zshift+0.5d0)*boxzsize)).or.
5460 c     &       (zi.lt.((zshift-0.5d0)*boxzsize))) then
5461 c        go to 136
5462 c        endif
5463           xi=mod(xi,boxxsize)
5464           if (xi.lt.0) xi=xi+boxxsize
5465           yi=mod(yi,boxysize)
5466           if (yi.lt.0) yi=yi+boxysize
5467           zi=mod(zi,boxzsize)
5468           if (zi.lt.0) zi=zi+boxzsize
5469 C          xi=xi+xshift*boxxsize
5470 C          yi=yi+yshift*boxysize
5471 C          zi=zi+zshift*boxzsize
5472         do iint=1,nscp_gr(i)
5473
5474         do j=iscpstart(i,iint),iscpend(i,iint)
5475           if (itype(j).eq.ntyp1) cycle
5476           itypj=iabs(itype(j))
5477 C Uncomment following three lines for SC-p interactions
5478 c         xj=c(1,nres+j)-xi
5479 c         yj=c(2,nres+j)-yi
5480 c         zj=c(3,nres+j)-zi
5481 C Uncomment following three lines for Ca-p interactions
5482           xj=c(1,j)
5483           yj=c(2,j)
5484           zj=c(3,j)
5485 c  174   continue
5486 c        if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
5487 c        if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
5488 C Condition for being inside the proper box
5489 c        if ((xj.gt.((0.5d0)*boxxsize)).or.
5490 c     &       (xj.lt.((-0.5d0)*boxxsize))) then
5491 c        go to 174
5492 c        endif
5493 c  175   continue
5494 c        if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
5495 c        if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
5496 cC Condition for being inside the proper box
5497 c        if ((yj.gt.((0.5d0)*boxysize)).or.
5498 c     &       (yj.lt.((-0.5d0)*boxysize))) then
5499 c        go to 175
5500 c        endif
5501 c  176   continue
5502 c        if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
5503 c        if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
5504 C Condition for being inside the proper box
5505 c        if ((zj.gt.((0.5d0)*boxzsize)).or.
5506 c     &       (zj.lt.((-0.5d0)*boxzsize))) then
5507 c        go to 176
5508           xj=mod(xj,boxxsize)
5509           if (xj.lt.0) xj=xj+boxxsize
5510           yj=mod(yj,boxysize)
5511           if (yj.lt.0) yj=yj+boxysize
5512           zj=mod(zj,boxzsize)
5513           if (zj.lt.0) zj=zj+boxzsize
5514       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
5515       xj_safe=xj
5516       yj_safe=yj
5517       zj_safe=zj
5518       subchap=0
5519       do xshift=-1,1
5520       do yshift=-1,1
5521       do zshift=-1,1
5522           xj=xj_safe+xshift*boxxsize
5523           yj=yj_safe+yshift*boxysize
5524           zj=zj_safe+zshift*boxzsize
5525           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
5526           if(dist_temp.lt.dist_init) then
5527             dist_init=dist_temp
5528             xj_temp=xj
5529             yj_temp=yj
5530             zj_temp=zj
5531             subchap=1
5532           endif
5533        enddo
5534        enddo
5535        enddo
5536        if (subchap.eq.1) then
5537           xj=xj_temp-xi
5538           yj=yj_temp-yi
5539           zj=zj_temp-zi
5540        else
5541           xj=xj_safe-xi
5542           yj=yj_safe-yi
5543           zj=zj_safe-zi
5544        endif
5545 c c       endif
5546 C          xj=xj-xi
5547 C          yj=yj-yi
5548 C          zj=zj-zi
5549           rij=xj*xj+yj*yj+zj*zj
5550
5551           r0ij=r0_scp
5552           r0ijsq=r0ij*r0ij
5553           if (rij.lt.r0ijsq) then
5554             evdwij=0.25d0*(rij-r0ijsq)**2
5555             fac=rij-r0ijsq
5556           else
5557             evdwij=0.0d0
5558             fac=0.0d0
5559           endif
5560           evdw2=evdw2+evdwij
5561 C
5562 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
5563 C
5564           ggg(1)=xj*fac
5565           ggg(2)=yj*fac
5566           ggg(3)=zj*fac
5567 cgrad          if (j.lt.i) then
5568 cd          write (iout,*) 'j<i'
5569 C Uncomment following three lines for SC-p interactions
5570 c           do k=1,3
5571 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
5572 c           enddo
5573 cgrad          else
5574 cd          write (iout,*) 'j>i'
5575 cgrad            do k=1,3
5576 cgrad              ggg(k)=-ggg(k)
5577 C Uncomment following line for SC-p interactions
5578 c             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
5579 cgrad            enddo
5580 cgrad          endif
5581 cgrad          do k=1,3
5582 cgrad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
5583 cgrad          enddo
5584 cgrad          kstart=min0(i+1,j)
5585 cgrad          kend=max0(i-1,j-1)
5586 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
5587 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
5588 cgrad          do k=kstart,kend
5589 cgrad            do l=1,3
5590 cgrad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
5591 cgrad            enddo
5592 cgrad          enddo
5593           do k=1,3
5594             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
5595             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
5596           enddo
5597         enddo
5598
5599         enddo ! iint
5600       enddo ! i
5601 C      enddo !zshift
5602 C      enddo !yshift
5603 C      enddo !xshift
5604       return
5605       end
5606 C-----------------------------------------------------------------------------
5607       subroutine escp(evdw2,evdw2_14)
5608 C
5609 C This subroutine calculates the excluded-volume interaction energy between
5610 C peptide-group centers and side chains and its gradient in virtual-bond and
5611 C side-chain vectors.
5612 C
5613       implicit real*8 (a-h,o-z)
5614       include 'DIMENSIONS'
5615       include 'COMMON.GEO'
5616       include 'COMMON.VAR'
5617       include 'COMMON.LOCAL'
5618       include 'COMMON.CHAIN'
5619       include 'COMMON.DERIV'
5620       include 'COMMON.INTERACT'
5621       include 'COMMON.FFIELD'
5622       include 'COMMON.IOUNITS'
5623       include 'COMMON.CONTROL'
5624       include 'COMMON.SPLITELE'
5625       integer xshift,yshift,zshift
5626       dimension ggg(3)
5627       evdw2=0.0D0
5628       evdw2_14=0.0d0
5629 c        print *,boxxsize,boxysize,boxzsize,'wymiary pudla'
5630 cd    print '(a)','Enter ESCP'
5631 cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
5632 C      do xshift=-1,1
5633 C      do yshift=-1,1
5634 C      do zshift=-1,1
5635       if (energy_dec) write (iout,*) "escp:",r_cut,rlamb
5636       do i=iatscp_s,iatscp_e
5637         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
5638         iteli=itel(i)
5639         xi=0.5D0*(c(1,i)+c(1,i+1))
5640         yi=0.5D0*(c(2,i)+c(2,i+1))
5641         zi=0.5D0*(c(3,i)+c(3,i+1))
5642           xi=mod(xi,boxxsize)
5643           if (xi.lt.0) xi=xi+boxxsize
5644           yi=mod(yi,boxysize)
5645           if (yi.lt.0) yi=yi+boxysize
5646           zi=mod(zi,boxzsize)
5647           if (zi.lt.0) zi=zi+boxzsize
5648 c          xi=xi+xshift*boxxsize
5649 c          yi=yi+yshift*boxysize
5650 c          zi=zi+zshift*boxzsize
5651 c        print *,xi,yi,zi,'polozenie i'
5652 C Return atom into box, boxxsize is size of box in x dimension
5653 c  134   continue
5654 c        if (xi.gt.((xshift+0.5d0)*boxxsize)) xi=xi-boxxsize
5655 c        if (xi.lt.((xshift-0.5d0)*boxxsize)) xi=xi+boxxsize
5656 C Condition for being inside the proper box
5657 c        if ((xi.gt.((xshift+0.5d0)*boxxsize)).or.
5658 c     &       (xi.lt.((xshift-0.5d0)*boxxsize))) then
5659 c        go to 134
5660 c        endif
5661 c  135   continue
5662 c          print *,xi,boxxsize,"pierwszy"
5663
5664 c        if (yi.gt.((yshift+0.5d0)*boxysize)) yi=yi-boxysize
5665 c        if (yi.lt.((yshift-0.5d0)*boxysize)) yi=yi+boxysize
5666 C Condition for being inside the proper box
5667 c        if ((yi.gt.((yshift+0.5d0)*boxysize)).or.
5668 c     &       (yi.lt.((yshift-0.5d0)*boxysize))) then
5669 c        go to 135
5670 c        endif
5671 c  136   continue
5672 c        if (zi.gt.((zshift+0.5d0)*boxzsize)) zi=zi-boxzsize
5673 c        if (zi.lt.((zshift-0.5d0)*boxzsize)) zi=zi+boxzsize
5674 C Condition for being inside the proper box
5675 c        if ((zi.gt.((zshift+0.5d0)*boxzsize)).or.
5676 c     &       (zi.lt.((zshift-0.5d0)*boxzsize))) then
5677 c        go to 136
5678 c        endif
5679         do iint=1,nscp_gr(i)
5680
5681         do j=iscpstart(i,iint),iscpend(i,iint)
5682           itypj=iabs(itype(j))
5683           if (itypj.eq.ntyp1) cycle
5684 C Uncomment following three lines for SC-p interactions
5685 c         xj=c(1,nres+j)-xi
5686 c         yj=c(2,nres+j)-yi
5687 c         zj=c(3,nres+j)-zi
5688 C Uncomment following three lines for Ca-p interactions
5689           xj=c(1,j)
5690           yj=c(2,j)
5691           zj=c(3,j)
5692           xj=mod(xj,boxxsize)
5693           if (xj.lt.0) xj=xj+boxxsize
5694           yj=mod(yj,boxysize)
5695           if (yj.lt.0) yj=yj+boxysize
5696           zj=mod(zj,boxzsize)
5697           if (zj.lt.0) zj=zj+boxzsize
5698 c  174   continue
5699 c        if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
5700 c        if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
5701 C Condition for being inside the proper box
5702 c        if ((xj.gt.((0.5d0)*boxxsize)).or.
5703 c     &       (xj.lt.((-0.5d0)*boxxsize))) then
5704 c        go to 174
5705 c        endif
5706 c  175   continue
5707 c        if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
5708 c        if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
5709 cC Condition for being inside the proper box
5710 c        if ((yj.gt.((0.5d0)*boxysize)).or.
5711 c     &       (yj.lt.((-0.5d0)*boxysize))) then
5712 c        go to 175
5713 c        endif
5714 c  176   continue
5715 c        if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
5716 c        if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
5717 C Condition for being inside the proper box
5718 c        if ((zj.gt.((0.5d0)*boxzsize)).or.
5719 c     &       (zj.lt.((-0.5d0)*boxzsize))) then
5720 c        go to 176
5721 c        endif
5722 CHERE IS THE CALCULATION WHICH MIRROR IMAGE IS THE CLOSEST ONE
5723       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
5724       xj_safe=xj
5725       yj_safe=yj
5726       zj_safe=zj
5727       subchap=0
5728       do xshift=-1,1
5729       do yshift=-1,1
5730       do zshift=-1,1
5731           xj=xj_safe+xshift*boxxsize
5732           yj=yj_safe+yshift*boxysize
5733           zj=zj_safe+zshift*boxzsize
5734           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
5735           if(dist_temp.lt.dist_init) then
5736             dist_init=dist_temp
5737             xj_temp=xj
5738             yj_temp=yj
5739             zj_temp=zj
5740             subchap=1
5741           endif
5742        enddo
5743        enddo
5744        enddo
5745        if (subchap.eq.1) then
5746           xj=xj_temp-xi
5747           yj=yj_temp-yi
5748           zj=zj_temp-zi
5749        else
5750           xj=xj_safe-xi
5751           yj=yj_safe-yi
5752           zj=zj_safe-zi
5753        endif
5754 c          print *,xj,yj,zj,'polozenie j'
5755           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
5756 c          print *,rrij
5757           sss=sscale(1.0d0/(dsqrt(rrij)))
5758 c          print *,r_cut,1.0d0/dsqrt(rrij),sss,'tu patrz'
5759 c          if (sss.eq.0) print *,'czasem jest OK'
5760           if (sss.le.0.0d0) cycle
5761           sssgrad=sscagrad(1.0d0/(dsqrt(rrij)))
5762           fac=rrij**expon2
5763           e1=fac*fac*aad(itypj,iteli)
5764           e2=fac*bad(itypj,iteli)
5765           if (iabs(j-i) .le. 2) then
5766             e1=scal14*e1
5767             e2=scal14*e2
5768             evdw2_14=evdw2_14+(e1+e2)*sss
5769           endif
5770           evdwij=e1+e2
5771           evdw2=evdw2+evdwij*sss
5772           if (energy_dec) write (iout,'(a6,2i5,0pf7.3,2i3,3e11.3)')
5773      &        'evdw2',i,j,evdwij,iteli,itypj,fac,aad(itypj,iteli),
5774      &       bad(itypj,iteli)
5775 C
5776 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
5777 C
5778           fac=-(evdwij+e1)*rrij*sss
5779           fac=fac+(evdwij)*sssgrad*dsqrt(rrij)/expon
5780           ggg(1)=xj*fac
5781           ggg(2)=yj*fac
5782           ggg(3)=zj*fac
5783 cgrad          if (j.lt.i) then
5784 cd          write (iout,*) 'j<i'
5785 C Uncomment following three lines for SC-p interactions
5786 c           do k=1,3
5787 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
5788 c           enddo
5789 cgrad          else
5790 cd          write (iout,*) 'j>i'
5791 cgrad            do k=1,3
5792 cgrad              ggg(k)=-ggg(k)
5793 C Uncomment following line for SC-p interactions
5794 ccgrad             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
5795 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
5796 cgrad            enddo
5797 cgrad          endif
5798 cgrad          do k=1,3
5799 cgrad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
5800 cgrad          enddo
5801 cgrad          kstart=min0(i+1,j)
5802 cgrad          kend=max0(i-1,j-1)
5803 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
5804 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
5805 cgrad          do k=kstart,kend
5806 cgrad            do l=1,3
5807 cgrad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
5808 cgrad            enddo
5809 cgrad          enddo
5810           do k=1,3
5811             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
5812             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
5813           enddo
5814 c        endif !endif for sscale cutoff
5815         enddo ! j
5816
5817         enddo ! iint
5818       enddo ! i
5819 c      enddo !zshift
5820 c      enddo !yshift
5821 c      enddo !xshift
5822       do i=1,nct
5823         do j=1,3
5824           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
5825           gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
5826           gradx_scp(j,i)=expon*gradx_scp(j,i)
5827         enddo
5828       enddo
5829 C******************************************************************************
5830 C
5831 C                              N O T E !!!
5832 C
5833 C To save time the factor EXPON has been extracted from ALL components
5834 C of GVDWC and GRADX. Remember to multiply them by this factor before further
5835 C use!
5836 C
5837 C******************************************************************************
5838       return
5839       end
5840 C--------------------------------------------------------------------------
5841       subroutine edis(ehpb)
5842 C
5843 C Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors.
5844 C
5845       implicit real*8 (a-h,o-z)
5846       include 'DIMENSIONS'
5847       include 'COMMON.SBRIDGE'
5848       include 'COMMON.CHAIN'
5849       include 'COMMON.DERIV'
5850       include 'COMMON.VAR'
5851       include 'COMMON.INTERACT'
5852       include 'COMMON.IOUNITS'
5853       include 'COMMON.CONTROL'
5854       dimension ggg(3),ggg_peak(3,1000)
5855       ehpb=0.0D0
5856       do i=1,3
5857        ggg(i)=0.0d0
5858       enddo
5859 c 8/21/18 AL: added explicit restraints on reference coords
5860 c      write (iout,*) "restr_on_coord",restr_on_coord
5861       if (restr_on_coord) then
5862
5863       do i=nnt,nct
5864         ecoor=0.0d0
5865         if (itype(i).eq.ntyp1) cycle
5866         do j=1,3
5867           ecoor=ecoor+(c(j,i)-cref(j,i))**2
5868           ghpbc(j,i)=ghpbc(j,i)+bfac(i)*(c(j,i)-cref(j,i))
5869         enddo
5870         if (itype(i).ne.10) then
5871           do j=1,3
5872             ecoor=ecoor+(c(j,i+nres)-cref(j,i+nres))**2
5873             ghpbx(j,i)=ghpbx(j,i)+bfac(i)*(c(j,i+nres)-cref(j,i+nres))
5874           enddo
5875         endif
5876         if (energy_dec) write (iout,*)
5877      &     "i",i," bfac",bfac(i)," ecoor",ecoor
5878         ehpb=ehpb+0.5d0*bfac(i)*ecoor
5879       enddo
5880
5881       endif
5882 C      write (iout,*) ,"link_end",link_end,constr_dist
5883 cd      write(iout,*)'edis: nhpb=',nhpb,' fbr=',fbr
5884 c      write(iout,*)'link_start=',link_start,' link_end=',link_end,
5885 c     &  " constr_dist",constr_dist," link_start_peak",link_start_peak,
5886 c     &  " link_end_peak",link_end_peak
5887       if (link_end.eq.0.and.link_end_peak.eq.0) return
5888       do i=link_start_peak,link_end_peak
5889         ehpb_peak=0.0d0
5890 c        print *,"i",i," link_end_peak",link_end_peak," ipeak",
5891 c     &   ipeak(1,i),ipeak(2,i)
5892         do ip=ipeak(1,i),ipeak(2,i)
5893           ii=ihpb_peak(ip)
5894           jj=jhpb_peak(ip)
5895           dd=dist(ii,jj)
5896           iip=ip-ipeak(1,i)+1
5897 C iii and jjj point to the residues for which the distance is assigned.
5898 c          if (ii.gt.nres) then
5899 c            iii=ii-nres
5900 c            jjj=jj-nres
5901 c          else
5902 c            iii=ii
5903 c            jjj=jj
5904 c          endif
5905           if (ii.gt.nres) then
5906             iii=ii-nres
5907           else
5908             iii=ii
5909           endif
5910           if (jj.gt.nres) then
5911             jjj=jj-nres
5912           else
5913             jjj=jj
5914           endif
5915           aux=rlornmr1(dd,dhpb_peak(ip),dhpb1_peak(ip),forcon_peak(ip))
5916           aux=dexp(-scal_peak*aux)
5917           ehpb_peak=ehpb_peak+aux
5918           fac=rlornmr1prim(dd,dhpb_peak(ip),dhpb1_peak(ip),
5919      &      forcon_peak(ip))*aux/dd
5920           do j=1,3
5921             ggg_peak(j,iip)=fac*(c(j,jj)-c(j,ii))
5922           enddo
5923           if (energy_dec) write (iout,'(a6,3i5,6f10.3,i5)')
5924      &      "edisL",i,ii,jj,dd,dhpb_peak(ip),dhpb1_peak(ip),
5925      &      forcon_peak(ip),fordepth_peak(ip),ehpb_peak
5926         enddo
5927 c        write (iout,*) "ehpb_peak",ehpb_peak," scal_peak",scal_peak
5928         ehpb=ehpb-fordepth_peak(ipeak(1,i))*dlog(ehpb_peak)/scal_peak
5929         do ip=ipeak(1,i),ipeak(2,i)
5930           iip=ip-ipeak(1,i)+1
5931           do j=1,3
5932             ggg(j)=ggg_peak(j,iip)/ehpb_peak
5933           enddo
5934           ii=ihpb_peak(ip)
5935           jj=jhpb_peak(ip)
5936 C iii and jjj point to the residues for which the distance is assigned.
5937 c          if (ii.gt.nres) then
5938 c            iii=ii-nres
5939 c            jjj=jj-nres
5940 c          else
5941 c            iii=ii
5942 c            jjj=jj
5943 c          endif
5944           if (ii.gt.nres) then
5945             iii=ii-nres
5946           else
5947             iii=ii
5948           endif
5949           if (jj.gt.nres) then
5950             jjj=jj-nres
5951           else
5952             jjj=jj
5953           endif
5954           if (iii.lt.ii) then
5955             do j=1,3
5956               ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
5957             enddo
5958           endif
5959           if (jjj.lt.jj) then
5960             do j=1,3
5961               ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
5962             enddo
5963           endif
5964           do k=1,3
5965             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
5966             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
5967           enddo
5968         enddo
5969       enddo
5970       do i=link_start,link_end
5971 C If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a
5972 C CA-CA distance used in regularization of structure.
5973         ii=ihpb(i)
5974         jj=jhpb(i)
5975 C iii and jjj point to the residues for which the distance is assigned.
5976         if (ii.gt.nres) then
5977           iii=ii-nres
5978         else
5979           iii=ii
5980         endif
5981         if (jj.gt.nres) then
5982           jjj=jj-nres
5983         else
5984           jjj=jj
5985         endif
5986 c        write (iout,*) "i",i," ii",ii," iii",iii," jj",jj," jjj",jjj,
5987 c     &    dhpb(i),dhpb1(i),forcon(i)
5988 C 24/11/03 AL: SS bridges handled separately because of introducing a specific
5989 C    distance and angle dependent SS bond potential.
5990 C        if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and.
5991 C     & iabs(itype(jjj)).eq.1) then
5992 cmc        if (ii.gt.nres .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then
5993 C 18/07/06 MC: Use the convention that the first nss pairs are SS bonds
5994         if (.not.dyn_ss .and. i.le.nss) then
5995 C 15/02/13 CC dynamic SSbond - additional check
5996           if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and.
5997      &        iabs(itype(jjj)).eq.1) then
5998            call ssbond_ene(iii,jjj,eij)
5999            ehpb=ehpb+2*eij
6000          endif
6001 cd          write (iout,*) "eij",eij
6002 cd   &   ' waga=',waga,' fac=',fac
6003 !        else if (ii.gt.nres .and. jj.gt.nres) then
6004         else
6005 C Calculate the distance between the two points and its difference from the
6006 C target distance.
6007           dd=dist(ii,jj)
6008           if (irestr_type(i).eq.11) then
6009             ehpb=ehpb+fordepth(i)!**4.0d0
6010      &           *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i))
6011             fac=fordepth(i)!**4.0d0
6012      &           *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd
6013             if (energy_dec) write (iout,'(a6,2i5,6f10.3,i5)')
6014      &        "edisL",ii,jj,dd,dhpb(i),dhpb1(i),forcon(i),fordepth(i),
6015      &        ehpb,irestr_type(i)
6016           else if (irestr_type(i).eq.10) then
6017 c AL 6//19/2018 cross-link restraints
6018             xdis = 0.5d0*(dd/forcon(i))**2
6019             expdis = dexp(-xdis)
6020 c            aux=(dhpb(i)+dhpb1(i)*xdis)*expdis+fordepth(i)
6021             aux=(dhpb(i)+dhpb1(i)*xdis*xdis)*expdis+fordepth(i)
6022 c            write (iout,*)"HERE: xdis",xdis," expdis",expdis," aux",aux,
6023 c     &          " wboltzd",wboltzd
6024             ehpb=ehpb-wboltzd*xlscore(i)*dlog(aux)
6025 c            fac=-wboltzd*(dhpb1(i)*(1.0d0-xdis)-dhpb(i))
6026             fac=-wboltzd*xlscore(i)*(dhpb1(i)*(2.0d0-xdis)*xdis-dhpb(i))
6027      &           *expdis/(aux*forcon(i)**2)
6028             if (energy_dec) write(iout,'(a6,2i5,6f10.3,i5)')
6029      &        "edisX",ii,jj,dd,dhpb(i),dhpb1(i),forcon(i),fordepth(i),
6030      &        -wboltzd*xlscore(i)*dlog(aux),irestr_type(i)
6031           else if (irestr_type(i).eq.2) then
6032 c Quartic restraints
6033             ehpb=ehpb+forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
6034             if (energy_dec) write(iout,'(a6,2i5,5f10.3,i5)')
6035      &      "edisQ",ii,jj,dd,dhpb(i),dhpb1(i),forcon(i),
6036      &      forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i)),irestr_type(i)
6037             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
6038           else
6039 c Quadratic restraints
6040             rdis=dd-dhpb(i)
6041 C Get the force constant corresponding to this distance.
6042             waga=forcon(i)
6043 C Calculate the contribution to energy.
6044             ehpb=ehpb+0.5d0*waga*rdis*rdis
6045             if (energy_dec) write(iout,'(a6,2i5,5f10.3,i5)')
6046      &      "edisS",ii,jj,dd,dhpb(i),dhpb1(i),forcon(i),
6047      &       0.5d0*waga*rdis*rdis,irestr_type(i)
6048 C
6049 C Evaluate gradient.
6050 C
6051             fac=waga*rdis/dd
6052           endif
6053 c Calculate Cartesian gradient
6054           do j=1,3
6055             ggg(j)=fac*(c(j,jj)-c(j,ii))
6056           enddo
6057 cd      print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
6058 C If this is a SC-SC distance, we need to calculate the contributions to the
6059 C Cartesian gradient in the SC vectors (ghpbx).
6060           if (iii.lt.ii) then
6061             do j=1,3
6062               ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
6063             enddo
6064           endif
6065           if (jjj.lt.jj) then
6066             do j=1,3
6067               ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
6068             enddo
6069           endif
6070           do k=1,3
6071             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
6072             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
6073           enddo
6074         endif
6075       enddo
6076       return
6077       end
6078 C--------------------------------------------------------------------------
6079       subroutine ssbond_ene(i,j,eij)
6080 C
6081 C Calculate the distance and angle dependent SS-bond potential energy
6082 C using a free-energy function derived based on RHF/6-31G** ab initio
6083 C calculations of diethyl disulfide.
6084 C
6085 C A. Liwo and U. Kozlowska, 11/24/03
6086 C
6087       implicit real*8 (a-h,o-z)
6088       include 'DIMENSIONS'
6089       include 'COMMON.SBRIDGE'
6090       include 'COMMON.CHAIN'
6091       include 'COMMON.DERIV'
6092       include 'COMMON.LOCAL'
6093       include 'COMMON.INTERACT'
6094       include 'COMMON.VAR'
6095       include 'COMMON.IOUNITS'
6096       double precision erij(3),dcosom1(3),dcosom2(3),gg(3)
6097       itypi=iabs(itype(i))
6098       xi=c(1,nres+i)
6099       yi=c(2,nres+i)
6100       zi=c(3,nres+i)
6101       dxi=dc_norm(1,nres+i)
6102       dyi=dc_norm(2,nres+i)
6103       dzi=dc_norm(3,nres+i)
6104 c      dsci_inv=dsc_inv(itypi)
6105       dsci_inv=vbld_inv(nres+i)
6106       itypj=iabs(itype(j))
6107 c      dscj_inv=dsc_inv(itypj)
6108       dscj_inv=vbld_inv(nres+j)
6109       xj=c(1,nres+j)-xi
6110       yj=c(2,nres+j)-yi
6111       zj=c(3,nres+j)-zi
6112       dxj=dc_norm(1,nres+j)
6113       dyj=dc_norm(2,nres+j)
6114       dzj=dc_norm(3,nres+j)
6115       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
6116       rij=dsqrt(rrij)
6117       erij(1)=xj*rij
6118       erij(2)=yj*rij
6119       erij(3)=zj*rij
6120       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
6121       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
6122       om12=dxi*dxj+dyi*dyj+dzi*dzj
6123       do k=1,3
6124         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
6125         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
6126       enddo
6127       rij=1.0d0/rij
6128       deltad=rij-d0cm
6129       deltat1=1.0d0-om1
6130       deltat2=1.0d0+om2
6131       deltat12=om2-om1+2.0d0
6132       cosphi=om12-om1*om2
6133       eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2)
6134      &  +akct*deltad*deltat12
6135      &  +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi+ebr
6136 c      write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth,
6137 c     &  " akct",akct," deltad",deltad," deltat",deltat1,deltat2,
6138 c     &  " deltat12",deltat12," eij",eij
6139       ed=2*akcm*deltad+akct*deltat12
6140       pom1=akct*deltad
6141       pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
6142       eom1=-2*akth*deltat1-pom1-om2*pom2
6143       eom2= 2*akth*deltat2+pom1-om1*pom2
6144       eom12=pom2
6145       do k=1,3
6146         ggk=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
6147         ghpbx(k,i)=ghpbx(k,i)-ggk
6148      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
6149      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
6150         ghpbx(k,j)=ghpbx(k,j)+ggk
6151      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
6152      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
6153         ghpbc(k,i)=ghpbc(k,i)-ggk
6154         ghpbc(k,j)=ghpbc(k,j)+ggk
6155       enddo
6156 C
6157 C Calculate the components of the gradient in DC and X
6158 C
6159 cgrad      do k=i,j-1
6160 cgrad        do l=1,3
6161 cgrad          ghpbc(l,k)=ghpbc(l,k)+gg(l)
6162 cgrad        enddo
6163 cgrad      enddo
6164       return
6165       end
6166 C--------------------------------------------------------------------------
6167       subroutine ebond(estr)
6168 c
6169 c Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
6170 c
6171       implicit real*8 (a-h,o-z)
6172       include 'DIMENSIONS'
6173       include 'COMMON.LOCAL'
6174       include 'COMMON.GEO'
6175       include 'COMMON.INTERACT'
6176       include 'COMMON.DERIV'
6177       include 'COMMON.VAR'
6178       include 'COMMON.CHAIN'
6179       include 'COMMON.IOUNITS'
6180       include 'COMMON.NAMES'
6181       include 'COMMON.FFIELD'
6182       include 'COMMON.CONTROL'
6183       include 'COMMON.SETUP'
6184       double precision u(3),ud(3)
6185       estr=0.0d0
6186       estr1=0.0d0
6187       do i=ibondp_start,ibondp_end
6188         if (itype(i-1).eq.ntyp1 .and. itype(i).eq.ntyp1) cycle
6189 c          estr1=estr1+gnmr1(vbld(i),-1.0d0,distchainmax)
6190 c          do j=1,3
6191 c          gradb(j,i-1)=gnmr1prim(vbld(i),-1.0d0,distchainmax)
6192 c     &      *dc(j,i-1)/vbld(i)
6193 c          enddo
6194 c          if (energy_dec) write(iout,*)
6195 c     &       "estr1",i,gnmr1(vbld(i),-1.0d0,distchainmax)
6196 c        else
6197 C       Checking if it involves dummy (NH3+ or COO-) group
6198          if (itype(i-1).eq.ntyp1 .or. itype(i).eq.ntyp1) then
6199 C YES   vbldpDUM is the equlibrium length of spring for Dummy atom
6200         diff = vbld(i)-vbldpDUM
6201         if (energy_dec) write(iout,*) "dum_bond",i,diff
6202          else
6203 C NO    vbldp0 is the equlibrium lenght of spring for peptide group
6204         diff = vbld(i)-vbldp0
6205          endif
6206         if (energy_dec)    write (iout,'(a7,i5,4f7.3)')
6207      &     "estr bb",i,vbld(i),vbldp0,diff,AKP*diff*diff
6208         estr=estr+diff*diff
6209         do j=1,3
6210           gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)
6211         enddo
6212 c        write (iout,'(i5,3f10.5)') i,(gradb(j,i-1),j=1,3)
6213 c        endif
6214       enddo
6215
6216       estr=0.5d0*AKP*estr+estr1
6217 c
6218 c 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included
6219 c
6220       do i=ibond_start,ibond_end
6221         iti=iabs(itype(i))
6222         if (iti.ne.10 .and. iti.ne.ntyp1) then
6223           nbi=nbondterm(iti)
6224           if (nbi.eq.1) then
6225             diff=vbld(i+nres)-vbldsc0(1,iti)
6226             if (energy_dec)  write (iout,*)
6227      &      "estr sc",i,iti,vbld(i+nres),vbldsc0(1,iti),diff,
6228      &      AKSC(1,iti),AKSC(1,iti)*diff*diff
6229             estr=estr+0.5d0*AKSC(1,iti)*diff*diff
6230             do j=1,3
6231               gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
6232             enddo
6233           else
6234             do j=1,nbi
6235               diff=vbld(i+nres)-vbldsc0(j,iti)
6236               ud(j)=aksc(j,iti)*diff
6237               u(j)=abond0(j,iti)+0.5d0*ud(j)*diff
6238             enddo
6239             uprod=u(1)
6240             do j=2,nbi
6241               uprod=uprod*u(j)
6242             enddo
6243             usum=0.0d0
6244             usumsqder=0.0d0
6245             do j=1,nbi
6246               uprod1=1.0d0
6247               uprod2=1.0d0
6248               do k=1,nbi
6249                 if (k.ne.j) then
6250                   uprod1=uprod1*u(k)
6251                   uprod2=uprod2*u(k)*u(k)
6252                 endif
6253               enddo
6254               usum=usum+uprod1
6255               usumsqder=usumsqder+ud(j)*uprod2
6256             enddo
6257             estr=estr+uprod/usum
6258             do j=1,3
6259              gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
6260             enddo
6261           endif
6262         endif
6263       enddo
6264       return
6265       end
6266 #ifdef CRYST_THETA
6267 C--------------------------------------------------------------------------
6268       subroutine ebend(etheta)
6269 C
6270 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
6271 C angles gamma and its derivatives in consecutive thetas and gammas.
6272 C
6273       implicit real*8 (a-h,o-z)
6274       include 'DIMENSIONS'
6275       include 'COMMON.LOCAL'
6276       include 'COMMON.GEO'
6277       include 'COMMON.INTERACT'
6278       include 'COMMON.DERIV'
6279       include 'COMMON.VAR'
6280       include 'COMMON.CHAIN'
6281       include 'COMMON.IOUNITS'
6282       include 'COMMON.NAMES'
6283       include 'COMMON.FFIELD'
6284       include 'COMMON.CONTROL'
6285       include 'COMMON.TORCNSTR'
6286       common /calcthet/ term1,term2,termm,diffak,ratak,
6287      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
6288      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
6289       double precision y(2),z(2)
6290       delta=0.02d0*pi
6291 c      time11=dexp(-2*time)
6292 c      time12=1.0d0
6293       etheta=0.0D0
6294 c     write (*,'(a,i2)') 'EBEND ICG=',icg
6295       do i=ithet_start,ithet_end
6296         if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
6297      &  .or.itype(i).eq.ntyp1) cycle
6298 C Zero the energy function and its derivative at 0 or pi.
6299         call splinthet(theta(i),0.5d0*delta,ss,ssd)
6300         it=itype(i-1)
6301         ichir1=isign(1,itype(i-2))
6302         ichir2=isign(1,itype(i))
6303          if (itype(i-2).eq.10) ichir1=isign(1,itype(i-1))
6304          if (itype(i).eq.10) ichir2=isign(1,itype(i-1))
6305          if (itype(i-1).eq.10) then
6306           itype1=isign(10,itype(i-2))
6307           ichir11=isign(1,itype(i-2))
6308           ichir12=isign(1,itype(i-2))
6309           itype2=isign(10,itype(i))
6310           ichir21=isign(1,itype(i))
6311           ichir22=isign(1,itype(i))
6312          endif
6313
6314         if (i.gt.3 .and. itype(i-3).ne.ntyp1) then
6315 #ifdef OSF
6316           phii=phi(i)
6317           if (phii.ne.phii) phii=150.0
6318 #else
6319           phii=phi(i)
6320 #endif
6321           y(1)=dcos(phii)
6322           y(2)=dsin(phii)
6323         else
6324           y(1)=0.0D0
6325           y(2)=0.0D0
6326         endif
6327         if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
6328 #ifdef OSF
6329           phii1=phi(i+1)
6330           if (phii1.ne.phii1) phii1=150.0
6331           phii1=pinorm(phii1)
6332           z(1)=cos(phii1)
6333 #else
6334           phii1=phi(i+1)
6335 #endif
6336           z(1)=dcos(phii1)
6337           z(2)=dsin(phii1)
6338         else
6339           z(1)=0.0D0
6340           z(2)=0.0D0
6341         endif
6342 C Calculate the "mean" value of theta from the part of the distribution
6343 C dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2).
6344 C In following comments this theta will be referred to as t_c.
6345         thet_pred_mean=0.0d0
6346         do k=1,2
6347             athetk=athet(k,it,ichir1,ichir2)
6348             bthetk=bthet(k,it,ichir1,ichir2)
6349           if (it.eq.10) then
6350              athetk=athet(k,itype1,ichir11,ichir12)
6351              bthetk=bthet(k,itype2,ichir21,ichir22)
6352           endif
6353          thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k)
6354 c         write(iout,*) 'chuj tu', y(k),z(k)
6355         enddo
6356         dthett=thet_pred_mean*ssd
6357         thet_pred_mean=thet_pred_mean*ss+a0thet(it)
6358 C Derivatives of the "mean" values in gamma1 and gamma2.
6359         dthetg1=(-athet(1,it,ichir1,ichir2)*y(2)
6360      &+athet(2,it,ichir1,ichir2)*y(1))*ss
6361          dthetg2=(-bthet(1,it,ichir1,ichir2)*z(2)
6362      &          +bthet(2,it,ichir1,ichir2)*z(1))*ss
6363          if (it.eq.10) then
6364       dthetg1=(-athet(1,itype1,ichir11,ichir12)*y(2)
6365      &+athet(2,itype1,ichir11,ichir12)*y(1))*ss
6366         dthetg2=(-bthet(1,itype2,ichir21,ichir22)*z(2)
6367      &         +bthet(2,itype2,ichir21,ichir22)*z(1))*ss
6368          endif
6369         if (theta(i).gt.pi-delta) then
6370           call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,
6371      &         E_tc0)
6372           call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0)
6373           call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
6374           call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,
6375      &        E_theta)
6376           call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,
6377      &        E_tc)
6378         else if (theta(i).lt.delta) then
6379           call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0)
6380           call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
6381           call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,
6382      &        E_theta)
6383           call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0)
6384           call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,
6385      &        E_tc)
6386         else
6387           call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,
6388      &        E_theta,E_tc)
6389         endif
6390         etheta=etheta+ethetai
6391         if (energy_dec) write (iout,'(a6,i5,0pf7.3,f7.3,i5)')
6392      &      'ebend',i,ethetai,theta(i),itype(i)
6393         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1
6394         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2
6395         gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)+gloc(nphi+i-2,icg)
6396       enddo
6397
6398 C Ufff.... We've done all this!!!
6399       return
6400       end
6401 C---------------------------------------------------------------------------
6402       subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,
6403      &     E_tc)
6404       implicit real*8 (a-h,o-z)
6405       include 'DIMENSIONS'
6406       include 'COMMON.LOCAL'
6407       include 'COMMON.IOUNITS'
6408       common /calcthet/ term1,term2,termm,diffak,ratak,
6409      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
6410      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
6411 C Calculate the contributions to both Gaussian lobes.
6412 C 6/6/97 - Deform the Gaussians using the factor of 1/(1+time)
6413 C The "polynomial part" of the "standard deviation" of this part of
6414 C the distributioni.
6415 ccc        write (iout,*) thetai,thet_pred_mean
6416         sig=polthet(3,it)
6417         do j=2,0,-1
6418           sig=sig*thet_pred_mean+polthet(j,it)
6419         enddo
6420 C Derivative of the "interior part" of the "standard deviation of the"
6421 C gamma-dependent Gaussian lobe in t_c.
6422         sigtc=3*polthet(3,it)
6423         do j=2,1,-1
6424           sigtc=sigtc*thet_pred_mean+j*polthet(j,it)
6425         enddo
6426         sigtc=sig*sigtc
6427 C Set the parameters of both Gaussian lobes of the distribution.
6428 C "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc)
6429         fac=sig*sig+sigc0(it)
6430         sigcsq=fac+fac
6431         sigc=1.0D0/sigcsq
6432 C Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c
6433         sigsqtc=-4.0D0*sigcsq*sigtc
6434 c       print *,i,sig,sigtc,sigsqtc
6435 C Following variable (sigtc) is d[sigma(t_c)]/dt_c
6436         sigtc=-sigtc/(fac*fac)
6437 C Following variable is sigma(t_c)**(-2)
6438         sigcsq=sigcsq*sigcsq
6439         sig0i=sig0(it)
6440         sig0inv=1.0D0/sig0i**2
6441         delthec=thetai-thet_pred_mean
6442         delthe0=thetai-theta0i
6443         term1=-0.5D0*sigcsq*delthec*delthec
6444         term2=-0.5D0*sig0inv*delthe0*delthe0
6445 C        write (iout,*)'term1',term1,term2,sigcsq,delthec,sig0inv,delthe0
6446 C Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and
6447 C NaNs in taking the logarithm. We extract the largest exponent which is added
6448 C to the energy (this being the log of the distribution) at the end of energy
6449 C term evaluation for this virtual-bond angle.
6450         if (term1.gt.term2) then
6451           termm=term1
6452           term2=dexp(term2-termm)
6453           term1=1.0d0
6454         else
6455           termm=term2
6456           term1=dexp(term1-termm)
6457           term2=1.0d0
6458         endif
6459 C The ratio between the gamma-independent and gamma-dependent lobes of
6460 C the distribution is a Gaussian function of thet_pred_mean too.
6461         diffak=gthet(2,it)-thet_pred_mean
6462         ratak=diffak/gthet(3,it)**2
6463         ak=dexp(gthet(1,it)-0.5D0*diffak*ratak)
6464 C Let's differentiate it in thet_pred_mean NOW.
6465         aktc=ak*ratak
6466 C Now put together the distribution terms to make complete distribution.
6467         termexp=term1+ak*term2
6468         termpre=sigc+ak*sig0i
6469 C Contribution of the bending energy from this theta is just the -log of
6470 C the sum of the contributions from the two lobes and the pre-exponential
6471 C factor. Simple enough, isn't it?
6472         ethetai=(-dlog(termexp)-termm+dlog(termpre))
6473 C       write (iout,*) 'termexp',termexp,termm,termpre,i
6474 C NOW the derivatives!!!
6475 C 6/6/97 Take into account the deformation.
6476         E_theta=(delthec*sigcsq*term1
6477      &       +ak*delthe0*sig0inv*term2)/termexp
6478         E_tc=((sigtc+aktc*sig0i)/termpre
6479      &      -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+
6480      &       aktc*term2)/termexp)
6481       return
6482       end
6483 c-----------------------------------------------------------------------------
6484       subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)
6485       implicit real*8 (a-h,o-z)
6486       include 'DIMENSIONS'
6487       include 'COMMON.LOCAL'
6488       include 'COMMON.IOUNITS'
6489       common /calcthet/ term1,term2,termm,diffak,ratak,
6490      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
6491      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
6492       delthec=thetai-thet_pred_mean
6493       delthe0=thetai-theta0i
6494 C "Thank you" to MAPLE (probably spared one day of hand-differentiation).
6495       t3 = thetai-thet_pred_mean
6496       t6 = t3**2
6497       t9 = term1
6498       t12 = t3*sigcsq
6499       t14 = t12+t6*sigsqtc
6500       t16 = 1.0d0
6501       t21 = thetai-theta0i
6502       t23 = t21**2
6503       t26 = term2
6504       t27 = t21*t26
6505       t32 = termexp
6506       t40 = t32**2
6507       E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9
6508      & -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40
6509      & *(-t12*t9-ak*sig0inv*t27)
6510       return
6511       end
6512 #else
6513 C--------------------------------------------------------------------------
6514       subroutine ebend(etheta)
6515 C
6516 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
6517 C angles gamma and its derivatives in consecutive thetas and gammas.
6518 C ab initio-derived potentials from
6519 c Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203
6520 C
6521       implicit real*8 (a-h,o-z)
6522       include 'DIMENSIONS'
6523       include 'COMMON.LOCAL'
6524       include 'COMMON.GEO'
6525       include 'COMMON.INTERACT'
6526       include 'COMMON.DERIV'
6527       include 'COMMON.VAR'
6528       include 'COMMON.CHAIN'
6529       include 'COMMON.IOUNITS'
6530       include 'COMMON.NAMES'
6531       include 'COMMON.FFIELD'
6532       include 'COMMON.CONTROL'
6533       include 'COMMON.TORCNSTR'
6534       double precision coskt(mmaxtheterm),sinkt(mmaxtheterm),
6535      & cosph1(maxsingle),sinph1(maxsingle),cosph2(maxsingle),
6536      & sinph2(maxsingle),cosph1ph2(maxdouble,maxdouble),
6537      & sinph1ph2(maxdouble,maxdouble)
6538       logical lprn /.false./, lprn1 /.false./
6539       etheta=0.0D0
6540       do i=ithet_start,ithet_end
6541 c        print *,i,itype(i-1),itype(i),itype(i-2)
6542         if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
6543      &  .or.itype(i).eq.ntyp1) cycle
6544 C        print *,i,theta(i)
6545         if (iabs(itype(i+1)).eq.20) iblock=2
6546         if (iabs(itype(i+1)).ne.20) iblock=1
6547         dethetai=0.0d0
6548         dephii=0.0d0
6549         dephii1=0.0d0
6550         theti2=0.5d0*theta(i)
6551         ityp2=ithetyp((itype(i-1)))
6552         do k=1,nntheterm
6553           coskt(k)=dcos(k*theti2)
6554           sinkt(k)=dsin(k*theti2)
6555         enddo
6556 C        print *,ethetai
6557         if (i.gt.3 .and. itype(i-3).ne.ntyp1) then
6558 #ifdef OSF
6559           phii=phi(i)
6560           if (phii.ne.phii) phii=150.0
6561 #else
6562           phii=phi(i)
6563 #endif
6564           ityp1=ithetyp((itype(i-2)))
6565 C propagation of chirality for glycine type
6566           do k=1,nsingle
6567             cosph1(k)=dcos(k*phii)
6568             sinph1(k)=dsin(k*phii)
6569           enddo
6570         else
6571           phii=0.0d0
6572           do k=1,nsingle
6573           ityp1=ithetyp((itype(i-2)))
6574             cosph1(k)=0.0d0
6575             sinph1(k)=0.0d0
6576           enddo
6577         endif
6578         if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
6579 #ifdef OSF
6580           phii1=phi(i+1)
6581           if (phii1.ne.phii1) phii1=150.0
6582           phii1=pinorm(phii1)
6583 #else
6584           phii1=phi(i+1)
6585 #endif
6586           ityp3=ithetyp((itype(i)))
6587           do k=1,nsingle
6588             cosph2(k)=dcos(k*phii1)
6589             sinph2(k)=dsin(k*phii1)
6590           enddo
6591         else
6592           phii1=0.0d0
6593           ityp3=ithetyp((itype(i)))
6594           do k=1,nsingle
6595             cosph2(k)=0.0d0
6596             sinph2(k)=0.0d0
6597           enddo
6598         endif
6599         ethetai=aa0thet(ityp1,ityp2,ityp3,iblock)
6600         do k=1,ndouble
6601           do l=1,k-1
6602             ccl=cosph1(l)*cosph2(k-l)
6603             ssl=sinph1(l)*sinph2(k-l)
6604             scl=sinph1(l)*cosph2(k-l)
6605             csl=cosph1(l)*sinph2(k-l)
6606             cosph1ph2(l,k)=ccl-ssl
6607             cosph1ph2(k,l)=ccl+ssl
6608             sinph1ph2(l,k)=scl+csl
6609             sinph1ph2(k,l)=scl-csl
6610           enddo
6611         enddo
6612         if (lprn) then
6613         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,
6614      &    " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
6615         write (iout,*) "coskt and sinkt"
6616         do k=1,nntheterm
6617           write (iout,*) k,coskt(k),sinkt(k)
6618         enddo
6619         endif
6620         do k=1,ntheterm
6621           ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3,iblock)*sinkt(k)
6622           dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3,iblock)
6623      &      *coskt(k)
6624           if (lprn)
6625      &    write (iout,*) "k",k,"
6626      &     aathet",aathet(k,ityp1,ityp2,ityp3,iblock),
6627      &     " ethetai",ethetai
6628         enddo
6629         if (lprn) then
6630         write (iout,*) "cosph and sinph"
6631         do k=1,nsingle
6632           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
6633         enddo
6634         write (iout,*) "cosph1ph2 and sinph2ph2"
6635         do k=2,ndouble
6636           do l=1,k-1
6637             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),
6638      &         sinph1ph2(l,k),sinph1ph2(k,l)
6639           enddo
6640         enddo
6641         write(iout,*) "ethetai",ethetai
6642         endif
6643 C       print *,ethetai
6644         do m=1,ntheterm2
6645           do k=1,nsingle
6646             aux=bbthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)
6647      &         +ccthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k)
6648      &         +ddthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)
6649      &         +eethet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k)
6650             ethetai=ethetai+sinkt(m)*aux
6651             dethetai=dethetai+0.5d0*m*aux*coskt(m)
6652             dephii=dephii+k*sinkt(m)*(
6653      &          ccthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)-
6654      &          bbthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k))
6655             dephii1=dephii1+k*sinkt(m)*(
6656      &          eethet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)-
6657      &          ddthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k))
6658             if (lprn)
6659      &      write (iout,*) "m",m," k",k," bbthet",
6660      &         bbthet(k,m,ityp1,ityp2,ityp3,iblock)," ccthet",
6661      &         ccthet(k,m,ityp1,ityp2,ityp3,iblock)," ddthet",
6662      &         ddthet(k,m,ityp1,ityp2,ityp3,iblock)," eethet",
6663      &         eethet(k,m,ityp1,ityp2,ityp3,iblock)," ethetai",ethetai
6664 C        print *,"tu",cosph1(k),sinph1(k),cosph2(k),sinph2(k)
6665           enddo
6666         enddo
6667 C        print *,"cosph1", (cosph1(k), k=1,nsingle)
6668 C        print *,"cosph2", (cosph2(k), k=1,nsingle)
6669 C        print *,"sinph1", (sinph1(k), k=1,nsingle)
6670 C        print *,"sinph2", (sinph2(k), k=1,nsingle)
6671         if (lprn)
6672      &  write(iout,*) "ethetai",ethetai
6673 C        print *,"tu",cosph1(k),sinph1(k),cosph2(k),sinph2(k)
6674         do m=1,ntheterm3
6675           do k=2,ndouble
6676             do l=1,k-1
6677               aux=ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
6678      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l)+
6679      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
6680      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)
6681               ethetai=ethetai+sinkt(m)*aux
6682               dethetai=dethetai+0.5d0*m*coskt(m)*aux
6683               dephii=dephii+l*sinkt(m)*(
6684      &           -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)-
6685      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
6686      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
6687      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
6688               dephii1=dephii1+(k-l)*sinkt(m)*(
6689      &           -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
6690      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
6691      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)-
6692      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
6693               if (lprn) then
6694               write (iout,*) "m",m," k",k," l",l," ffthet",
6695      &            ffthet(l,k,m,ityp1,ityp2,ityp3,iblock),
6696      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)," ggthet",
6697      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock),
6698      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock),
6699      &            " ethetai",ethetai
6700               write (iout,*) cosph1ph2(l,k)*sinkt(m),
6701      &            cosph1ph2(k,l)*sinkt(m),
6702      &            sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
6703               endif
6704             enddo
6705           enddo
6706         enddo
6707 10      continue
6708 c        lprn1=.true.
6709 C        print *,ethetai
6710         if (lprn1)
6711      &    write (iout,'(i2,3f8.1,9h ethetai ,f10.5)')
6712      &   i,theta(i)*rad2deg,phii*rad2deg,
6713      &   phii1*rad2deg,ethetai
6714 c        lprn1=.false.
6715         etheta=etheta+ethetai
6716         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
6717      &      'ebend',i,ethetai
6718         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
6719         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
6720         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)+wang*dethetai
6721       enddo
6722
6723       return
6724       end
6725 #endif
6726 #ifdef CRYST_SC
6727 c-----------------------------------------------------------------------------
6728       subroutine esc(escloc)
6729 C Calculate the local energy of a side chain and its derivatives in the
6730 C corresponding virtual-bond valence angles THETA and the spherical angles
6731 C ALPHA and OMEGA.
6732       implicit real*8 (a-h,o-z)
6733       include 'DIMENSIONS'
6734       include 'COMMON.GEO'
6735       include 'COMMON.LOCAL'
6736       include 'COMMON.VAR'
6737       include 'COMMON.INTERACT'
6738       include 'COMMON.DERIV'
6739       include 'COMMON.CHAIN'
6740       include 'COMMON.IOUNITS'
6741       include 'COMMON.NAMES'
6742       include 'COMMON.FFIELD'
6743       include 'COMMON.CONTROL'
6744       double precision x(3),dersc(3),xemp(3),dersc0(3),dersc1(3),
6745      &     ddersc0(3),ddummy(3),xtemp(3),temp(3)
6746       common /sccalc/ time11,time12,time112,theti,it,nlobit
6747       delta=0.02d0*pi
6748       escloc=0.0D0
6749 c     write (iout,'(a)') 'ESC'
6750       do i=loc_start,loc_end
6751         it=itype(i)
6752         if (it.eq.ntyp1) cycle
6753         if (it.eq.10) goto 1
6754         nlobit=nlob(iabs(it))
6755 c       print *,'i=',i,' it=',it,' nlobit=',nlobit
6756 c       write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
6757         theti=theta(i+1)-pipol
6758         x(1)=dtan(theti)
6759         x(2)=alph(i)
6760         x(3)=omeg(i)
6761
6762         if (x(2).gt.pi-delta) then
6763           xtemp(1)=x(1)
6764           xtemp(2)=pi-delta
6765           xtemp(3)=x(3)
6766           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
6767           xtemp(2)=pi
6768           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
6769           call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),
6770      &        escloci,dersc(2))
6771           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
6772      &        ddersc0(1),dersc(1))
6773           call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),
6774      &        ddersc0(3),dersc(3))
6775           xtemp(2)=pi-delta
6776           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
6777           xtemp(2)=pi
6778           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
6779           call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,
6780      &            dersc0(2),esclocbi,dersc02)
6781           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
6782      &            dersc12,dersc01)
6783           call splinthet(x(2),0.5d0*delta,ss,ssd)
6784           dersc0(1)=dersc01
6785           dersc0(2)=dersc02
6786           dersc0(3)=0.0d0
6787           do k=1,3
6788             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
6789           enddo
6790           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
6791 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
6792 c    &             esclocbi,ss,ssd
6793           escloci=ss*escloci+(1.0d0-ss)*esclocbi
6794 c         escloci=esclocbi
6795 c         write (iout,*) escloci
6796         else if (x(2).lt.delta) then
6797           xtemp(1)=x(1)
6798           xtemp(2)=delta
6799           xtemp(3)=x(3)
6800           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
6801           xtemp(2)=0.0d0
6802           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
6803           call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),
6804      &        escloci,dersc(2))
6805           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
6806      &        ddersc0(1),dersc(1))
6807           call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),
6808      &        ddersc0(3),dersc(3))
6809           xtemp(2)=delta
6810           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
6811           xtemp(2)=0.0d0
6812           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
6813           call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,
6814      &            dersc0(2),esclocbi,dersc02)
6815           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
6816      &            dersc12,dersc01)
6817           dersc0(1)=dersc01
6818           dersc0(2)=dersc02
6819           dersc0(3)=0.0d0
6820           call splinthet(x(2),0.5d0*delta,ss,ssd)
6821           do k=1,3
6822             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
6823           enddo
6824           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
6825 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
6826 c    &             esclocbi,ss,ssd
6827           escloci=ss*escloci+(1.0d0-ss)*esclocbi
6828 c         write (iout,*) escloci
6829         else
6830           call enesc(x,escloci,dersc,ddummy,.false.)
6831         endif
6832
6833         escloc=escloc+escloci
6834         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
6835      &     'escloc',i,escloci
6836 c       write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
6837
6838         gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
6839      &   wscloc*dersc(1)
6840         gloc(ialph(i,1),icg)=wscloc*dersc(2)
6841         gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
6842     1   continue
6843       enddo
6844       return
6845       end
6846 C---------------------------------------------------------------------------
6847       subroutine enesc(x,escloci,dersc,ddersc,mixed)
6848       implicit real*8 (a-h,o-z)
6849       include 'DIMENSIONS'
6850       include 'COMMON.GEO'
6851       include 'COMMON.LOCAL'
6852       include 'COMMON.IOUNITS'
6853       common /sccalc/ time11,time12,time112,theti,it,nlobit
6854       double precision x(3),z(3),Ax(3,maxlob,-1:1),dersc(3),ddersc(3)
6855       double precision contr(maxlob,-1:1)
6856       logical mixed
6857 c       write (iout,*) 'it=',it,' nlobit=',nlobit
6858         escloc_i=0.0D0
6859         do j=1,3
6860           dersc(j)=0.0D0
6861           if (mixed) ddersc(j)=0.0d0
6862         enddo
6863         x3=x(3)
6864
6865 C Because of periodicity of the dependence of the SC energy in omega we have
6866 C to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
6867 C To avoid underflows, first compute & store the exponents.
6868
6869         do iii=-1,1
6870
6871           x(3)=x3+iii*dwapi
6872
6873           do j=1,nlobit
6874             do k=1,3
6875               z(k)=x(k)-censc(k,j,it)
6876             enddo
6877             do k=1,3
6878               Axk=0.0D0
6879               do l=1,3
6880                 Axk=Axk+gaussc(l,k,j,it)*z(l)
6881               enddo
6882               Ax(k,j,iii)=Axk
6883             enddo
6884             expfac=0.0D0
6885             do k=1,3
6886               expfac=expfac+Ax(k,j,iii)*z(k)
6887             enddo
6888             contr(j,iii)=expfac
6889           enddo ! j
6890
6891         enddo ! iii
6892
6893         x(3)=x3
6894 C As in the case of ebend, we want to avoid underflows in exponentiation and
6895 C subsequent NaNs and INFs in energy calculation.
6896 C Find the largest exponent
6897         emin=contr(1,-1)
6898         do iii=-1,1
6899           do j=1,nlobit
6900             if (emin.gt.contr(j,iii)) emin=contr(j,iii)
6901           enddo
6902         enddo
6903         emin=0.5D0*emin
6904 cd      print *,'it=',it,' emin=',emin
6905
6906 C Compute the contribution to SC energy and derivatives
6907         do iii=-1,1
6908
6909           do j=1,nlobit
6910 #ifdef OSF
6911             adexp=bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin
6912             if(adexp.ne.adexp) adexp=1.0
6913             expfac=dexp(adexp)
6914 #else
6915             expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin)
6916 #endif
6917 cd          print *,'j=',j,' expfac=',expfac
6918             escloc_i=escloc_i+expfac
6919             do k=1,3
6920               dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
6921             enddo
6922             if (mixed) then
6923               do k=1,3,2
6924                 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii)
6925      &            +gaussc(k,2,j,it))*expfac
6926               enddo
6927             endif
6928           enddo
6929
6930         enddo ! iii
6931
6932         dersc(1)=dersc(1)/cos(theti)**2
6933         ddersc(1)=ddersc(1)/cos(theti)**2
6934         ddersc(3)=ddersc(3)
6935
6936         escloci=-(dlog(escloc_i)-emin)
6937         do j=1,3
6938           dersc(j)=dersc(j)/escloc_i
6939         enddo
6940         if (mixed) then
6941           do j=1,3,2
6942             ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
6943           enddo
6944         endif
6945       return
6946       end
6947 C------------------------------------------------------------------------------
6948       subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
6949       implicit real*8 (a-h,o-z)
6950       include 'DIMENSIONS'
6951       include 'COMMON.GEO'
6952       include 'COMMON.LOCAL'
6953       include 'COMMON.IOUNITS'
6954       common /sccalc/ time11,time12,time112,theti,it,nlobit
6955       double precision x(3),z(3),Ax(3,maxlob),dersc(3)
6956       double precision contr(maxlob)
6957       logical mixed
6958
6959       escloc_i=0.0D0
6960
6961       do j=1,3
6962         dersc(j)=0.0D0
6963       enddo
6964
6965       do j=1,nlobit
6966         do k=1,2
6967           z(k)=x(k)-censc(k,j,it)
6968         enddo
6969         z(3)=dwapi
6970         do k=1,3
6971           Axk=0.0D0
6972           do l=1,3
6973             Axk=Axk+gaussc(l,k,j,it)*z(l)
6974           enddo
6975           Ax(k,j)=Axk
6976         enddo
6977         expfac=0.0D0
6978         do k=1,3
6979           expfac=expfac+Ax(k,j)*z(k)
6980         enddo
6981         contr(j)=expfac
6982       enddo ! j
6983
6984 C As in the case of ebend, we want to avoid underflows in exponentiation and
6985 C subsequent NaNs and INFs in energy calculation.
6986 C Find the largest exponent
6987       emin=contr(1)
6988       do j=1,nlobit
6989         if (emin.gt.contr(j)) emin=contr(j)
6990       enddo
6991       emin=0.5D0*emin
6992
6993 C Compute the contribution to SC energy and derivatives
6994
6995       dersc12=0.0d0
6996       do j=1,nlobit
6997         expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j)+emin)
6998         escloc_i=escloc_i+expfac
6999         do k=1,2
7000           dersc(k)=dersc(k)+Ax(k,j)*expfac
7001         enddo
7002         if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j)
7003      &            +gaussc(1,2,j,it))*expfac
7004         dersc(3)=0.0d0
7005       enddo
7006
7007       dersc(1)=dersc(1)/cos(theti)**2
7008       dersc12=dersc12/cos(theti)**2
7009       escloci=-(dlog(escloc_i)-emin)
7010       do j=1,2
7011         dersc(j)=dersc(j)/escloc_i
7012       enddo
7013       if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
7014       return
7015       end
7016 #else
7017 c----------------------------------------------------------------------------------
7018       subroutine esc(escloc)
7019 C Calculate the local energy of a side chain and its derivatives in the
7020 C corresponding virtual-bond valence angles THETA and the spherical angles
7021 C ALPHA and OMEGA derived from AM1 all-atom calculations.
7022 C added by Urszula Kozlowska. 07/11/2007
7023 C
7024       implicit real*8 (a-h,o-z)
7025       include 'DIMENSIONS'
7026       include 'COMMON.GEO'
7027       include 'COMMON.LOCAL'
7028       include 'COMMON.VAR'
7029       include 'COMMON.SCROT'
7030       include 'COMMON.INTERACT'
7031       include 'COMMON.DERIV'
7032       include 'COMMON.CHAIN'
7033       include 'COMMON.IOUNITS'
7034       include 'COMMON.NAMES'
7035       include 'COMMON.FFIELD'
7036       include 'COMMON.CONTROL'
7037       include 'COMMON.VECTORS'
7038       double precision x_prime(3),y_prime(3),z_prime(3)
7039      &    , sumene,dsc_i,dp2_i,x(65),
7040      &     xx,yy,zz,sumene1,sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6,
7041      &    de_dxx,de_dyy,de_dzz,de_dt
7042       double precision s1_t,s1_6_t,s2_t,s2_6_t
7043       double precision
7044      & dXX_Ci1(3),dYY_Ci1(3),dZZ_Ci1(3),dXX_Ci(3),
7045      & dYY_Ci(3),dZZ_Ci(3),dXX_XYZ(3),dYY_XYZ(3),dZZ_XYZ(3),
7046      & dt_dCi(3),dt_dCi1(3)
7047       common /sccalc/ time11,time12,time112,theti,it,nlobit
7048       delta=0.02d0*pi
7049       escloc=0.0D0
7050       do i=loc_start,loc_end
7051         if (itype(i).eq.ntyp1) cycle
7052         costtab(i+1) =dcos(theta(i+1))
7053         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
7054         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
7055         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
7056         cosfac2=0.5d0/(1.0d0+costtab(i+1))
7057         cosfac=dsqrt(cosfac2)
7058         sinfac2=0.5d0/(1.0d0-costtab(i+1))
7059         sinfac=dsqrt(sinfac2)
7060         it=iabs(itype(i))
7061         if (it.eq.10) goto 1
7062 c
7063 C  Compute the axes of tghe local cartesian coordinates system; store in
7064 c   x_prime, y_prime and z_prime
7065 c
7066         do j=1,3
7067           x_prime(j) = 0.00
7068           y_prime(j) = 0.00
7069           z_prime(j) = 0.00
7070         enddo
7071 C        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
7072 C     &   dc_norm(3,i+nres)
7073         do j = 1,3
7074           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
7075           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
7076         enddo
7077         do j = 1,3
7078           z_prime(j) = -uz(j,i-1)*dsign(1.0d0,dfloat(itype(i)))
7079         enddo
7080 c       write (2,*) "i",i
7081 c       write (2,*) "x_prime",(x_prime(j),j=1,3)
7082 c       write (2,*) "y_prime",(y_prime(j),j=1,3)
7083 c       write (2,*) "z_prime",(z_prime(j),j=1,3)
7084 c       write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
7085 c      & " xy",scalar(x_prime(1),y_prime(1)),
7086 c      & " xz",scalar(x_prime(1),z_prime(1)),
7087 c      & " yy",scalar(y_prime(1),y_prime(1)),
7088 c      & " yz",scalar(y_prime(1),z_prime(1)),
7089 c      & " zz",scalar(z_prime(1),z_prime(1))
7090 c
7091 C Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
7092 C to local coordinate system. Store in xx, yy, zz.
7093 c
7094         xx=0.0d0
7095         yy=0.0d0
7096         zz=0.0d0
7097         do j = 1,3
7098           xx = xx + x_prime(j)*dc_norm(j,i+nres)
7099           yy = yy + y_prime(j)*dc_norm(j,i+nres)
7100           zz = zz + z_prime(j)*dc_norm(j,i+nres)
7101         enddo
7102
7103         xxtab(i)=xx
7104         yytab(i)=yy
7105         zztab(i)=zz
7106 C
7107 C Compute the energy of the ith side cbain
7108 C
7109 c        write (2,*) "xx",xx," yy",yy," zz",zz
7110         it=iabs(itype(i))
7111         do j = 1,65
7112           x(j) = sc_parmin(j,it)
7113         enddo
7114 #ifdef CHECK_COORD
7115 Cc diagnostics - remove later
7116         xx1 = dcos(alph(2))
7117         yy1 = dsin(alph(2))*dcos(omeg(2))
7118         zz1 = -dsign(1.0,dfloat(itype(i)))*dsin(alph(2))*dsin(omeg(2))
7119         write(2,'(3f8.1,3f9.3,1x,3f9.3)')
7120      &    alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,
7121      &    xx1,yy1,zz1
7122 C,"  --- ", xx_w,yy_w,zz_w
7123 c end diagnostics
7124 #endif
7125         sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
7126      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
7127      &   + x(10)*yy*zz
7128         sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
7129      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
7130      & + x(20)*yy*zz
7131         sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
7132      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
7133      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
7134      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
7135      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
7136      &  +x(40)*xx*yy*zz
7137         sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
7138      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
7139      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
7140      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
7141      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
7142      &  +x(60)*xx*yy*zz
7143         dsc_i   = 0.743d0+x(61)
7144         dp2_i   = 1.9d0+x(62)
7145         dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
7146      &          *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
7147         dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
7148      &          *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
7149         s1=(1+x(63))/(0.1d0 + dscp1)
7150         s1_6=(1+x(64))/(0.1d0 + dscp1**6)
7151         s2=(1+x(65))/(0.1d0 + dscp2)
7152         s2_6=(1+x(65))/(0.1d0 + dscp2**6)
7153         sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6)
7154      & + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
7155 c        write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
7156 c     &   sumene4,
7157 c     &   dscp1,dscp2,sumene
7158 c        sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
7159         escloc = escloc + sumene
7160         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
7161      &     'escloc',i,sumene
7162 c        write (2,*) "i",i," escloc",sumene,escloc,it,itype(i)
7163 c     & ,zz,xx,yy
7164 c#define DEBUG
7165 #ifdef DEBUG
7166 C
7167 C This section to check the numerical derivatives of the energy of ith side
7168 C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
7169 C #define DEBUG in the code to turn it on.
7170 C
7171         write (2,*) "sumene               =",sumene
7172         aincr=1.0d-7
7173         xxsave=xx
7174         xx=xx+aincr
7175         write (2,*) xx,yy,zz
7176         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
7177         de_dxx_num=(sumenep-sumene)/aincr
7178         xx=xxsave
7179         write (2,*) "xx+ sumene from enesc=",sumenep
7180         yysave=yy
7181         yy=yy+aincr
7182         write (2,*) xx,yy,zz
7183         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
7184         de_dyy_num=(sumenep-sumene)/aincr
7185         yy=yysave
7186         write (2,*) "yy+ sumene from enesc=",sumenep
7187         zzsave=zz
7188         zz=zz+aincr
7189         write (2,*) xx,yy,zz
7190         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
7191         de_dzz_num=(sumenep-sumene)/aincr
7192         zz=zzsave
7193         write (2,*) "zz+ sumene from enesc=",sumenep
7194         costsave=cost2tab(i+1)
7195         sintsave=sint2tab(i+1)
7196         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
7197         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
7198         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
7199         de_dt_num=(sumenep-sumene)/aincr
7200         write (2,*) " t+ sumene from enesc=",sumenep
7201         cost2tab(i+1)=costsave
7202         sint2tab(i+1)=sintsave
7203 C End of diagnostics section.
7204 #endif
7205 C
7206 C Compute the gradient of esc
7207 C
7208 c        zz=zz*dsign(1.0,dfloat(itype(i)))
7209         pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
7210         pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
7211         pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
7212         pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
7213         pom_dx=dsc_i*dp2_i*cost2tab(i+1)
7214         pom_dy=dsc_i*dp2_i*sint2tab(i+1)
7215         pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
7216         pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
7217         pom1=(sumene3*sint2tab(i+1)+sumene1)
7218      &     *(pom_s1/dscp1+pom_s16*dscp1**4)
7219         pom2=(sumene4*cost2tab(i+1)+sumene2)
7220      &     *(pom_s2/dscp2+pom_s26*dscp2**4)
7221         sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
7222         sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2
7223      &  +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2)
7224      &  +x(40)*yy*zz
7225         sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
7226         sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2
7227      &  +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2)
7228      &  +x(60)*yy*zz
7229         de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6)
7230      &        +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6)
7231      &        +(pom1+pom2)*pom_dx
7232 #ifdef DEBUG
7233         write(2,*), "de_dxx = ", de_dxx,de_dxx_num,itype(i)
7234 #endif
7235 C
7236         sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
7237         sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2
7238      &  +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2)
7239      &  +x(40)*xx*zz
7240         sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
7241         sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz
7242      &  +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz
7243      &  +x(59)*zz**2 +x(60)*xx*zz
7244         de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6)
7245      &        +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6)
7246      &        +(pom1-pom2)*pom_dy
7247 #ifdef DEBUG
7248         write(2,*), "de_dyy = ", de_dyy,de_dyy_num,itype(i)
7249 #endif
7250 C
7251         de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy
7252      &  +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx
7253      &  +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6)
7254      &  +(x(4) + 2*x(7)*zz+  x(8)*xx + x(10)*yy)*(s1+s1_6)
7255      &  +(x(44)+2*x(47)*zz +x(48)*xx   +x(50)*yy  +3*x(53)*zz**2
7256      &  +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy
7257      &  +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6)
7258      &  + ( x(14) + 2*x(17)*zz+  x(18)*xx + x(20)*yy)*(s2+s2_6)
7259 #ifdef DEBUG
7260         write(2,*), "de_dzz = ", de_dzz,de_dzz_num,itype(i)
7261 #endif
7262 C
7263         de_dt =  0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6)
7264      &  -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6)
7265      &  +pom1*pom_dt1+pom2*pom_dt2
7266 #ifdef DEBUG
7267         write(2,*), "de_dt = ", de_dt,de_dt_num,itype(i)
7268 #endif
7269 c#undef DEBUG
7270 c
7271 C
7272        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
7273        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
7274        cosfac2xx=cosfac2*xx
7275        sinfac2yy=sinfac2*yy
7276        do k = 1,3
7277          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))*
7278      &      vbld_inv(i+1)
7279          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))*
7280      &      vbld_inv(i)
7281          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
7282          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
7283 c         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
7284 c     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
7285 c         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
7286 c     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
7287          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
7288          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
7289          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
7290          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
7291          dZZ_Ci1(k)=0.0d0
7292          dZZ_Ci(k)=0.0d0
7293          do j=1,3
7294            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)
7295      &     *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
7296            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)
7297      &     *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
7298          enddo
7299
7300          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
7301          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
7302          dZZ_XYZ(k)=vbld_inv(i+nres)*
7303      &   (z_prime(k)-zz*dC_norm(k,i+nres))
7304 c
7305          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
7306          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
7307        enddo
7308
7309        do k=1,3
7310          dXX_Ctab(k,i)=dXX_Ci(k)
7311          dXX_C1tab(k,i)=dXX_Ci1(k)
7312          dYY_Ctab(k,i)=dYY_Ci(k)
7313          dYY_C1tab(k,i)=dYY_Ci1(k)
7314          dZZ_Ctab(k,i)=dZZ_Ci(k)
7315          dZZ_C1tab(k,i)=dZZ_Ci1(k)
7316          dXX_XYZtab(k,i)=dXX_XYZ(k)
7317          dYY_XYZtab(k,i)=dYY_XYZ(k)
7318          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
7319        enddo
7320
7321        do k = 1,3
7322 c         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
7323 c     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
7324 c         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
7325 c     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
7326 c         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
7327 c     &    dt_dci(k)
7328 c         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
7329 c     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
7330          gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k)
7331      &    +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
7332          gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k)
7333      &    +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
7334          gsclocx(k,i)=                 de_dxx*dxx_XYZ(k)
7335      &    +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
7336        enddo
7337 c       write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
7338 c     &  (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
7339
7340 C to check gradient call subroutine check_grad
7341
7342     1 continue
7343       enddo
7344       return
7345       end
7346 c------------------------------------------------------------------------------
7347       double precision function enesc(x,xx,yy,zz,cost2,sint2)
7348       implicit none
7349       double precision x(65),xx,yy,zz,cost2,sint2,sumene1,sumene2,
7350      & sumene3,sumene4,sumene,dsc_i,dp2_i,dscp1,dscp2,s1,s1_6,s2,s2_6
7351       sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
7352      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
7353      &   + x(10)*yy*zz
7354       sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
7355      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
7356      & + x(20)*yy*zz
7357       sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
7358      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
7359      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
7360      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
7361      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
7362      &  +x(40)*xx*yy*zz
7363       sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
7364      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
7365      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
7366      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
7367      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
7368      &  +x(60)*xx*yy*zz
7369       dsc_i   = 0.743d0+x(61)
7370       dp2_i   = 1.9d0+x(62)
7371       dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
7372      &          *(xx*cost2+yy*sint2))
7373       dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
7374      &          *(xx*cost2-yy*sint2))
7375       s1=(1+x(63))/(0.1d0 + dscp1)
7376       s1_6=(1+x(64))/(0.1d0 + dscp1**6)
7377       s2=(1+x(65))/(0.1d0 + dscp2)
7378       s2_6=(1+x(65))/(0.1d0 + dscp2**6)
7379       sumene = ( sumene3*sint2 + sumene1)*(s1+s1_6)
7380      & + (sumene4*cost2 +sumene2)*(s2+s2_6)
7381       enesc=sumene
7382       return
7383       end
7384 #endif
7385 c------------------------------------------------------------------------------
7386       subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
7387 C
7388 C This procedure calculates two-body contact function g(rij) and its derivative:
7389 C
7390 C           eps0ij                                     !       x < -1
7391 C g(rij) =  esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5)  ! -1 =< x =< 1
7392 C            0                                         !       x > 1
7393 C
7394 C where x=(rij-r0ij)/delta
7395 C
7396 C rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
7397 C
7398       implicit none
7399       double precision rij,r0ij,eps0ij,fcont,fprimcont
7400       double precision x,x2,x4,delta
7401 c     delta=0.02D0*r0ij
7402 c      delta=0.2D0*r0ij
7403       x=(rij-r0ij)/delta
7404       if (x.lt.-1.0D0) then
7405         fcont=eps0ij
7406         fprimcont=0.0D0
7407       else if (x.le.1.0D0) then
7408         x2=x*x
7409         x4=x2*x2
7410         fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
7411         fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
7412       else
7413         fcont=0.0D0
7414         fprimcont=0.0D0
7415       endif
7416       return
7417       end
7418 c------------------------------------------------------------------------------
7419       subroutine splinthet(theti,delta,ss,ssder)
7420       implicit real*8 (a-h,o-z)
7421       include 'DIMENSIONS'
7422       include 'COMMON.VAR'
7423       include 'COMMON.GEO'
7424       thetup=pi-delta
7425       thetlow=delta
7426       if (theti.gt.pipol) then
7427         call gcont(theti,thetup,1.0d0,delta,ss,ssder)
7428       else
7429         call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
7430         ssder=-ssder
7431       endif
7432       return
7433       end
7434 c------------------------------------------------------------------------------
7435       subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
7436       implicit none
7437       double precision x,x0,delta,f0,f1,fprim0,f,fprim
7438       double precision ksi,ksi2,ksi3,a1,a2,a3
7439       a1=fprim0*delta/(f1-f0)
7440       a2=3.0d0-2.0d0*a1
7441       a3=a1-2.0d0
7442       ksi=(x-x0)/delta
7443       ksi2=ksi*ksi
7444       ksi3=ksi2*ksi
7445       f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
7446       fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
7447       return
7448       end
7449 c------------------------------------------------------------------------------
7450       subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
7451       implicit none
7452       double precision x,x0,delta,f0x,f1x,fprim0x,fx
7453       double precision ksi,ksi2,ksi3,a1,a2,a3
7454       ksi=(x-x0)/delta
7455       ksi2=ksi*ksi
7456       ksi3=ksi2*ksi
7457       a1=fprim0x*delta
7458       a2=3*(f1x-f0x)-2*fprim0x*delta
7459       a3=fprim0x*delta-2*(f1x-f0x)
7460       fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
7461       return
7462       end
7463 C-----------------------------------------------------------------------------
7464 #ifdef CRYST_TOR
7465 C-----------------------------------------------------------------------------
7466       subroutine etor(etors)
7467       implicit real*8 (a-h,o-z)
7468       include 'DIMENSIONS'
7469       include 'COMMON.VAR'
7470       include 'COMMON.GEO'
7471       include 'COMMON.LOCAL'
7472       include 'COMMON.TORSION'
7473       include 'COMMON.INTERACT'
7474       include 'COMMON.DERIV'
7475       include 'COMMON.CHAIN'
7476       include 'COMMON.NAMES'
7477       include 'COMMON.IOUNITS'
7478       include 'COMMON.FFIELD'
7479       include 'COMMON.TORCNSTR'
7480       include 'COMMON.CONTROL'
7481       logical lprn
7482 C Set lprn=.true. for debugging
7483       lprn=.false.
7484 c      lprn=.true.
7485       etors=0.0D0
7486       do i=iphi_start,iphi_end
7487       etors_ii=0.0D0
7488         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
7489      &      .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
7490         itori=itortyp(itype(i-2))
7491         itori1=itortyp(itype(i-1))
7492         phii=phi(i)
7493         gloci=0.0D0
7494 C Proline-Proline pair is a special case...
7495         if (itori.eq.3 .and. itori1.eq.3) then
7496           if (phii.gt.-dwapi3) then
7497             cosphi=dcos(3*phii)
7498             fac=1.0D0/(1.0D0-cosphi)
7499             etorsi=v1(1,3,3)*fac
7500             etorsi=etorsi+etorsi
7501             etors=etors+etorsi-v1(1,3,3)
7502             if (energy_dec) etors_ii=etors_ii+etorsi-v1(1,3,3)
7503             gloci=gloci-3*fac*etorsi*dsin(3*phii)
7504           endif
7505           do j=1,3
7506             v1ij=v1(j+1,itori,itori1)
7507             v2ij=v2(j+1,itori,itori1)
7508             cosphi=dcos(j*phii)
7509             sinphi=dsin(j*phii)
7510             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7511             if (energy_dec) etors_ii=etors_ii+
7512      &                              v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7513             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7514           enddo
7515         else
7516           do j=1,nterm_old
7517             v1ij=v1(j,itori,itori1)
7518             v2ij=v2(j,itori,itori1)
7519             cosphi=dcos(j*phii)
7520             sinphi=dsin(j*phii)
7521             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7522             if (energy_dec) etors_ii=etors_ii+
7523      &                  v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7524             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7525           enddo
7526         endif
7527         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
7528              'etor',i,etors_ii
7529         if (lprn)
7530      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
7531      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
7532      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
7533         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
7534 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
7535       enddo
7536       return
7537       end
7538 c------------------------------------------------------------------------------
7539       subroutine etor_d(etors_d)
7540       etors_d=0.0d0
7541       return
7542       end
7543 c----------------------------------------------------------------------------
7544 c LICZENIE WIEZOW Z ROWNANIA ENERGII MODELLERA
7545       subroutine e_modeller(ehomology_constr)
7546       ehomology_constr=0.0d0
7547       write (iout,*) "!!!!!UWAGA, JESTEM W DZIWNEJ PETLI, TEST!!!!!"
7548       return
7549       end
7550 C !!!!!!!! NIE CZYTANE !!!!!!!!!!!
7551
7552 c------------------------------------------------------------------------------
7553       subroutine etor_d(etors_d)
7554       etors_d=0.0d0
7555       return
7556       end
7557 c----------------------------------------------------------------------------
7558 #else
7559       subroutine etor(etors)
7560       implicit real*8 (a-h,o-z)
7561       include 'DIMENSIONS'
7562       include 'COMMON.VAR'
7563       include 'COMMON.GEO'
7564       include 'COMMON.LOCAL'
7565       include 'COMMON.TORSION'
7566       include 'COMMON.INTERACT'
7567       include 'COMMON.DERIV'
7568       include 'COMMON.CHAIN'
7569       include 'COMMON.NAMES'
7570       include 'COMMON.IOUNITS'
7571       include 'COMMON.FFIELD'
7572       include 'COMMON.TORCNSTR'
7573       include 'COMMON.CONTROL'
7574       logical lprn
7575 C Set lprn=.true. for debugging
7576       lprn=.false.
7577 c     lprn=.true.
7578       etors=0.0D0
7579       do i=iphi_start,iphi_end
7580 C ANY TWO ARE DUMMY ATOMS in row CYCLE
7581 c        if (((itype(i-3).eq.ntyp1).and.(itype(i-2).eq.ntyp1)).or.
7582 c     &      ((itype(i-2).eq.ntyp1).and.(itype(i-1).eq.ntyp1))  .or.
7583 c     &      ((itype(i-1).eq.ntyp1).and.(itype(i).eq.ntyp1))) cycle
7584         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
7585      &      .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
7586 C In current verion the ALL DUMMY ATOM POTENTIALS ARE OFF
7587 C For introducing the NH3+ and COO- group please check the etor_d for reference
7588 C and guidance
7589         etors_ii=0.0D0
7590          if (iabs(itype(i)).eq.20) then
7591          iblock=2
7592          else
7593          iblock=1
7594          endif
7595         itori=itortyp(itype(i-2))
7596         itori1=itortyp(itype(i-1))
7597         phii=phi(i)
7598         gloci=0.0D0
7599 C Regular cosine and sine terms
7600         do j=1,nterm(itori,itori1,iblock)
7601           v1ij=v1(j,itori,itori1,iblock)
7602           v2ij=v2(j,itori,itori1,iblock)
7603           cosphi=dcos(j*phii)
7604           sinphi=dsin(j*phii)
7605           etors=etors+v1ij*cosphi+v2ij*sinphi
7606           if (energy_dec) etors_ii=etors_ii+
7607      &                v1ij*cosphi+v2ij*sinphi
7608           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7609         enddo
7610 C Lorentz terms
7611 C                         v1
7612 C  E = SUM ----------------------------------- - v1
7613 C          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
7614 C
7615         cosphi=dcos(0.5d0*phii)
7616         sinphi=dsin(0.5d0*phii)
7617         do j=1,nlor(itori,itori1,iblock)
7618           vl1ij=vlor1(j,itori,itori1)
7619           vl2ij=vlor2(j,itori,itori1)
7620           vl3ij=vlor3(j,itori,itori1)
7621           pom=vl2ij*cosphi+vl3ij*sinphi
7622           pom1=1.0d0/(pom*pom+1.0d0)
7623           etors=etors+vl1ij*pom1
7624           if (energy_dec) etors_ii=etors_ii+
7625      &                vl1ij*pom1
7626           pom=-pom*pom1*pom1
7627           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
7628         enddo
7629 C Subtract the constant term
7630         etors=etors-v0(itori,itori1,iblock)
7631           if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
7632      &         'etor',i,etors_ii-v0(itori,itori1,iblock)
7633         if (lprn)
7634      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
7635      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
7636      &  (v1(j,itori,itori1,iblock),j=1,6),
7637      &  (v2(j,itori,itori1,iblock),j=1,6)
7638         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
7639 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
7640       enddo
7641       return
7642       end
7643 c----------------------------------------------------------------------------
7644       subroutine etor_d(etors_d)
7645 C 6/23/01 Compute double torsional energy
7646       implicit real*8 (a-h,o-z)
7647       include 'DIMENSIONS'
7648       include 'COMMON.VAR'
7649       include 'COMMON.GEO'
7650       include 'COMMON.LOCAL'
7651       include 'COMMON.TORSION'
7652       include 'COMMON.INTERACT'
7653       include 'COMMON.DERIV'
7654       include 'COMMON.CHAIN'
7655       include 'COMMON.NAMES'
7656       include 'COMMON.IOUNITS'
7657       include 'COMMON.FFIELD'
7658       include 'COMMON.TORCNSTR'
7659       include 'COMMON.CONTROL'
7660       logical lprn
7661 C Set lprn=.true. for debugging
7662       lprn=.false.
7663 c     lprn=.true.
7664       etors_d=0.0D0
7665 c      write(iout,*) "a tu??"
7666       do i=iphid_start,iphid_end
7667 C ANY TWO ARE DUMMY ATOMS in row CYCLE
7668 C        if (((itype(i-3).eq.ntyp1).and.(itype(i-2).eq.ntyp1)).or.
7669 C     &      ((itype(i-2).eq.ntyp1).and.(itype(i-1).eq.ntyp1)).or.
7670 C     &      ((itype(i-1).eq.ntyp1).and.(itype(i).eq.ntyp1))  .or.
7671 C     &      ((itype(i).eq.ntyp1).and.(itype(i+1).eq.ntyp1))) cycle
7672          if ((itype(i-2).eq.ntyp1).or.itype(i-3).eq.ntyp1.or.
7673      &  (itype(i-1).eq.ntyp1).or.(itype(i).eq.ntyp1).or.
7674      &  (itype(i+1).eq.ntyp1)) cycle
7675 C In current verion the ALL DUMMY ATOM POTENTIALS ARE OFF
7676         etors_d_ii=0.0D0
7677         itori=itortyp(itype(i-2))
7678         itori1=itortyp(itype(i-1))
7679         itori2=itortyp(itype(i))
7680         phii=phi(i)
7681         phii1=phi(i+1)
7682         gloci1=0.0D0
7683         gloci2=0.0D0
7684         iblock=1
7685         if (iabs(itype(i+1)).eq.20) iblock=2
7686 C Iblock=2 Proline type
7687 C ADASKO: WHEN PARAMETERS FOR THIS TYPE OF BLOCKING GROUP IS READY UNCOMMENT
7688 C CHECK WEATHER THERE IS NECCESITY FOR iblock=3 for COO-
7689 C        if (itype(i+1).eq.ntyp1) iblock=3
7690 C The problem of NH3+ group can be resolved by adding new parameters please note if there
7691 C IS or IS NOT need for this
7692 C IF Yes uncomment below and add to parmread.F appropriate changes and to v1cij and so on
7693 C        is (itype(i-3).eq.ntyp1) ntblock=2
7694 C        ntblock is N-terminal blocking group
7695
7696 C Regular cosine and sine terms
7697         do j=1,ntermd_1(itori,itori1,itori2,iblock)
7698 C Example of changes for NH3+ blocking group
7699 C       do j=1,ntermd_1(itori,itori1,itori2,iblock,ntblock)
7700 C          v1cij=v1c(1,j,itori,itori1,itori2,iblock,ntblock)
7701           v1cij=v1c(1,j,itori,itori1,itori2,iblock)
7702           v1sij=v1s(1,j,itori,itori1,itori2,iblock)
7703           v2cij=v1c(2,j,itori,itori1,itori2,iblock)
7704           v2sij=v1s(2,j,itori,itori1,itori2,iblock)
7705           cosphi1=dcos(j*phii)
7706           sinphi1=dsin(j*phii)
7707           cosphi2=dcos(j*phii1)
7708           sinphi2=dsin(j*phii1)
7709           etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+
7710      &     v2cij*cosphi2+v2sij*sinphi2
7711           if (energy_dec) etors_d_ii=etors_d_ii+
7712      &     v1cij*cosphi1+v1sij*sinphi1+v2cij*cosphi2+v2sij*sinphi2
7713           gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
7714           gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
7715         enddo
7716         do k=2,ntermd_2(itori,itori1,itori2,iblock)
7717           do l=1,k-1
7718             v1cdij = v2c(k,l,itori,itori1,itori2,iblock)
7719             v2cdij = v2c(l,k,itori,itori1,itori2,iblock)
7720             v1sdij = v2s(k,l,itori,itori1,itori2,iblock)
7721             v2sdij = v2s(l,k,itori,itori1,itori2,iblock)
7722             cosphi1p2=dcos(l*phii+(k-l)*phii1)
7723             cosphi1m2=dcos(l*phii-(k-l)*phii1)
7724             sinphi1p2=dsin(l*phii+(k-l)*phii1)
7725             sinphi1m2=dsin(l*phii-(k-l)*phii1)
7726             etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+
7727      &        v1sdij*sinphi1p2+v2sdij*sinphi1m2
7728             if (energy_dec) etors_d_ii=etors_d_ii+
7729      &        v1cdij*cosphi1p2+v2cdij*cosphi1m2+
7730      &        v1sdij*sinphi1p2+v2sdij*sinphi1m2
7731             gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2
7732      &        -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
7733             gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2
7734      &        -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
7735           enddo
7736         enddo
7737           if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
7738      &         'etor_d',i,etors_d_ii
7739         gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*gloci1
7740         gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*gloci2
7741       enddo
7742       return
7743       end
7744 #endif
7745 C----------------------------------------------------------------------------------
7746 C The rigorous attempt to derive energy function
7747       subroutine etor_kcc(etors)
7748       implicit real*8 (a-h,o-z)
7749       include 'DIMENSIONS'
7750       include 'COMMON.VAR'
7751       include 'COMMON.GEO'
7752       include 'COMMON.LOCAL'
7753       include 'COMMON.TORSION'
7754       include 'COMMON.INTERACT'
7755       include 'COMMON.DERIV'
7756       include 'COMMON.CHAIN'
7757       include 'COMMON.NAMES'
7758       include 'COMMON.IOUNITS'
7759       include 'COMMON.FFIELD'
7760       include 'COMMON.TORCNSTR'
7761       include 'COMMON.CONTROL'
7762       double precision c1(0:maxval_kcc),c2(0:maxval_kcc)
7763       logical lprn
7764 c      double precision thybt1(maxtermkcc),thybt2(maxtermkcc)
7765 C Set lprn=.true. for debugging
7766       lprn=energy_dec
7767 c     lprn=.true.
7768 C      print *,"wchodze kcc"
7769       if (lprn) write (iout,*) "etor_kcc tor_mode",tor_mode
7770       etors=0.0D0
7771       do i=iphi_start,iphi_end
7772 C ANY TWO ARE DUMMY ATOMS in row CYCLE
7773 c        if (((itype(i-3).eq.ntyp1).and.(itype(i-2).eq.ntyp1)).or.
7774 c     &      ((itype(i-2).eq.ntyp1).and.(itype(i-1).eq.ntyp1))  .or.
7775 c     &      ((itype(i-1).eq.ntyp1).and.(itype(i).eq.ntyp1))) cycle
7776         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
7777      &      .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
7778         itori=itortyp(itype(i-2))
7779         itori1=itortyp(itype(i-1))
7780         phii=phi(i)
7781         glocig=0.0D0
7782         glocit1=0.0d0
7783         glocit2=0.0d0
7784 C to avoid multiple devision by 2
7785 c        theti22=0.5d0*theta(i)
7786 C theta 12 is the theta_1 /2
7787 C theta 22 is theta_2 /2
7788 c        theti12=0.5d0*theta(i-1)
7789 C and appropriate sinus function
7790         sinthet1=dsin(theta(i-1))
7791         sinthet2=dsin(theta(i))
7792         costhet1=dcos(theta(i-1))
7793         costhet2=dcos(theta(i))
7794 C to speed up lets store its mutliplication
7795         sint1t2=sinthet2*sinthet1
7796         sint1t2n=1.0d0
7797 C \sum_{i=1}^n (sin(theta_1) * sin(theta_2))^n * (c_n* cos(n*gamma)
7798 C +d_n*sin(n*gamma)) *
7799 C \sum_{i=1}^m (1+a_m*Tb_m(cos(theta_1 /2))+b_m*Tb_m(cos(theta_2 /2)))
7800 C we have two sum 1) Non-Chebyshev which is with n and gamma
7801         nval=nterm_kcc_Tb(itori,itori1)
7802         c1(0)=0.0d0
7803         c2(0)=0.0d0
7804         c1(1)=1.0d0
7805         c2(1)=1.0d0
7806         do j=2,nval
7807           c1(j)=c1(j-1)*costhet1
7808           c2(j)=c2(j-1)*costhet2
7809         enddo
7810         etori=0.0d0
7811         do j=1,nterm_kcc(itori,itori1)
7812           cosphi=dcos(j*phii)
7813           sinphi=dsin(j*phii)
7814           sint1t2n1=sint1t2n
7815           sint1t2n=sint1t2n*sint1t2
7816           sumvalc=0.0d0
7817           gradvalct1=0.0d0
7818           gradvalct2=0.0d0
7819           do k=1,nval
7820             do l=1,nval
7821               sumvalc=sumvalc+v1_kcc(l,k,j,itori1,itori)*c1(k)*c2(l)
7822               gradvalct1=gradvalct1+
7823      &           (k-1)*v1_kcc(l,k,j,itori1,itori)*c1(k-1)*c2(l)
7824               gradvalct2=gradvalct2+
7825      &           (l-1)*v1_kcc(l,k,j,itori1,itori)*c1(k)*c2(l-1)
7826             enddo
7827           enddo
7828           gradvalct1=-gradvalct1*sinthet1
7829           gradvalct2=-gradvalct2*sinthet2
7830           sumvals=0.0d0
7831           gradvalst1=0.0d0
7832           gradvalst2=0.0d0
7833           do k=1,nval
7834             do l=1,nval
7835               sumvals=sumvals+v2_kcc(l,k,j,itori1,itori)*c1(k)*c2(l)
7836               gradvalst1=gradvalst1+
7837      &           (k-1)*v2_kcc(l,k,j,itori1,itori)*c1(k-1)*c2(l)
7838               gradvalst2=gradvalst2+
7839      &           (l-1)*v2_kcc(l,k,j,itori1,itori)*c1(k)*c2(l-1)
7840             enddo
7841           enddo
7842           gradvalst1=-gradvalst1*sinthet1
7843           gradvalst2=-gradvalst2*sinthet2
7844           if (lprn) write (iout,*)j,"sumvalc",sumvalc," sumvals",sumvals
7845           etori=etori+sint1t2n*(sumvalc*cosphi+sumvals*sinphi)
7846 C glocig is the gradient local i site in gamma
7847           glocig=glocig+j*sint1t2n*(sumvals*cosphi-sumvalc*sinphi)
7848 C now gradient over theta_1
7849           glocit1=glocit1+sint1t2n*(gradvalct1*cosphi+gradvalst1*sinphi)
7850      &   +j*sint1t2n1*costhet1*sinthet2*(sumvalc*cosphi+sumvals*sinphi)
7851           glocit2=glocit2+sint1t2n*(gradvalct2*cosphi+gradvalst2*sinphi)
7852      &   +j*sint1t2n1*sinthet1*costhet2*(sumvalc*cosphi+sumvals*sinphi)
7853         enddo ! j
7854         etors=etors+etori
7855 C derivative over gamma
7856         gloc(i-3,icg)=gloc(i-3,icg)+wtor*glocig
7857 C derivative over theta1
7858         gloc(nphi+i-3,icg)=gloc(nphi+i-3,icg)+wtor*glocit1
7859 C now derivative over theta2
7860         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)+wtor*glocit2
7861         if (lprn) then
7862           write (iout,*) i-2,i-1,itype(i-2),itype(i-1),itori,itori1,
7863      &       theta(i-1)*rad2deg,theta(i)*rad2deg,phii*rad2deg,etori
7864           write (iout,*) "c1",(c1(k),k=0,nval),
7865      &    " c2",(c2(k),k=0,nval)
7866         endif
7867       enddo
7868       return
7869       end
7870 c---------------------------------------------------------------------------------------------
7871       subroutine etor_constr(edihcnstr)
7872       implicit real*8 (a-h,o-z)
7873       include 'DIMENSIONS'
7874       include 'COMMON.VAR'
7875       include 'COMMON.GEO'
7876       include 'COMMON.LOCAL'
7877       include 'COMMON.TORSION'
7878       include 'COMMON.INTERACT'
7879       include 'COMMON.DERIV'
7880       include 'COMMON.CHAIN'
7881       include 'COMMON.NAMES'
7882       include 'COMMON.IOUNITS'
7883       include 'COMMON.FFIELD'
7884       include 'COMMON.TORCNSTR'
7885       include 'COMMON.BOUNDS'
7886       include 'COMMON.CONTROL'
7887 ! 6/20/98 - dihedral angle constraints
7888       edihcnstr=0.0d0
7889 c      do i=1,ndih_constr
7890       if (raw_psipred) then
7891         do i=idihconstr_start,idihconstr_end
7892           itori=idih_constr(i)
7893           phii=phi(itori)
7894           gaudih_i=vpsipred(1,i)
7895           gauder_i=0.0d0
7896           do j=1,2
7897             s = sdihed(j,i)
7898             cos_i=(1.0d0-dcos(phii-phibound(j,i)))/s**2
7899             dexpcos_i=dexp(-cos_i*cos_i)
7900             gaudih_i=gaudih_i+vpsipred(j+1,i)*dexpcos_i
7901             gauder_i=gauder_i-2*vpsipred(j+1,i)*dsin(phii-phibound(j,i))
7902      &            *cos_i*dexpcos_i/s**2
7903           enddo
7904           edihcnstr=edihcnstr-wdihc*dlog(gaudih_i)
7905           gloc(itori-3,icg)=gloc(itori-3,icg)-wdihc*gauder_i/gaudih_i
7906           if (energy_dec)
7907      &     write (iout,'(2i5,f8.3,f8.5,2(f8.5,2f8.3),f10.5)')
7908      &     i,itori,phii*rad2deg,vpsipred(1,i),vpsipred(2,i),
7909      &     phibound(1,i)*rad2deg,sdihed(1,i)*rad2deg,vpsipred(3,i),
7910      &     phibound(2,i)*rad2deg,sdihed(2,i)*rad2deg,
7911      &     -wdihc*dlog(gaudih_i)
7912         enddo
7913       else
7914
7915       do i=idihconstr_start,idihconstr_end
7916         itori=idih_constr(i)
7917         phii=phi(itori)
7918         difi=pinorm(phii-phi0(i))
7919         if (difi.gt.drange(i)) then
7920           difi=difi-drange(i)
7921           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
7922           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
7923         else if (difi.lt.-drange(i)) then
7924           difi=difi+drange(i)
7925           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
7926           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
7927         else
7928           difi=0.0
7929         endif
7930       enddo
7931
7932       endif
7933
7934       return
7935       end
7936 c----------------------------------------------------------------------------
7937 c MODELLER restraint function
7938       subroutine e_modeller(ehomology_constr)
7939       implicit real*8 (a-h,o-z)
7940       include 'DIMENSIONS'
7941
7942       integer nnn, i, j, k, ki, irec, l
7943       integer katy, odleglosci, test7
7944       real*8 odleg, odleg2, odleg3, kat, kat2, kat3, gdih(max_template)
7945       real*8 Eval,Erot
7946       real*8 distance(max_template),distancek(max_template),
7947      &    min_odl,godl(max_template),dih_diff(max_template)
7948
7949 c
7950 c     FP - 30/10/2014 Temporary specifications for homology restraints
7951 c
7952       double precision utheta_i,gutheta_i,sum_gtheta,sum_sgtheta,
7953      &                 sgtheta
7954       double precision, dimension (maxres) :: guscdiff,usc_diff
7955       double precision, dimension (max_template) ::
7956      &           gtheta,dscdiff,uscdiffk,guscdiff2,guscdiff3,
7957      &           theta_diff
7958 c
7959
7960       include 'COMMON.SBRIDGE'
7961       include 'COMMON.CHAIN'
7962       include 'COMMON.GEO'
7963       include 'COMMON.DERIV'
7964       include 'COMMON.LOCAL'
7965       include 'COMMON.INTERACT'
7966       include 'COMMON.VAR'
7967       include 'COMMON.IOUNITS'
7968       include 'COMMON.MD'
7969       include 'COMMON.CONTROL'
7970 c
7971 c     From subroutine Econstr_back
7972 c
7973       include 'COMMON.NAMES'
7974       include 'COMMON.TIME1'
7975 c
7976
7977
7978       do i=1,max_template
7979         distancek(i)=9999999.9
7980       enddo
7981
7982
7983       odleg=0.0d0
7984
7985 c Pseudo-energy and gradient from homology restraints (MODELLER-like
7986 c function)
7987 C AL 5/2/14 - Introduce list of restraints
7988 c     write(iout,*) "waga_theta",waga_theta,"waga_d",waga_d
7989 #ifdef DEBUG
7990       write(iout,*) "------- dist restrs start -------"
7991 #endif
7992       do ii = link_start_homo,link_end_homo
7993          i = ires_homo(ii)
7994          j = jres_homo(ii)
7995          dij=dist(i,j)
7996 c        write (iout,*) "dij(",i,j,") =",dij
7997          nexl=0
7998          do k=1,constr_homology
7999 c           write(iout,*) ii,k,i,j,l_homo(k,ii),dij,odl(k,ii)
8000            if(.not.l_homo(k,ii)) then
8001              nexl=nexl+1
8002              cycle
8003            endif
8004            distance(k)=odl(k,ii)-dij
8005 c          write (iout,*) "distance(",k,") =",distance(k)
8006 c
8007 c          For Gaussian-type Urestr
8008 c
8009            distancek(k)=0.5d0*distance(k)**2*sigma_odl(k,ii) ! waga_dist rmvd from Gaussian argument
8010 c          write (iout,*) "sigma_odl(",k,ii,") =",sigma_odl(k,ii)
8011 c          write (iout,*) "distancek(",k,") =",distancek(k)
8012 c          distancek(k)=0.5d0*waga_dist*distance(k)**2*sigma_odl(k,ii)
8013 c
8014 c          For Lorentzian-type Urestr
8015 c
8016            if (waga_dist.lt.0.0d0) then
8017               sigma_odlir(k,ii)=dsqrt(1/sigma_odl(k,ii))
8018               distancek(k)=distance(k)**2/(sigma_odlir(k,ii)*
8019      &                     (distance(k)**2+sigma_odlir(k,ii)**2))
8020            endif
8021          enddo
8022
8023 c         min_odl=minval(distancek)
8024          do kk=1,constr_homology
8025           if(l_homo(kk,ii)) then
8026             min_odl=distancek(kk)
8027             exit
8028           endif
8029          enddo
8030          do kk=1,constr_homology
8031           if(l_homo(kk,ii) .and. distancek(kk).lt.min_odl)
8032      &              min_odl=distancek(kk)
8033          enddo
8034
8035 c        write (iout,* )"min_odl",min_odl
8036 #ifdef DEBUG
8037          write (iout,*) "ij dij",i,j,dij
8038          write (iout,*) "distance",(distance(k),k=1,constr_homology)
8039          write (iout,*) "distancek",(distancek(k),k=1,constr_homology)
8040          write (iout,* )"min_odl",min_odl
8041 #endif
8042 #ifdef OLDRESTR
8043          odleg2=0.0d0
8044 #else
8045          if (waga_dist.ge.0.0d0) then
8046            odleg2=nexl
8047          else
8048            odleg2=0.0d0
8049          endif
8050 #endif
8051          do k=1,constr_homology
8052 c Nie wiem po co to liczycie jeszcze raz!
8053 c            odleg3=-waga_dist(iset)*((distance(i,j,k)**2)/
8054 c     &              (2*(sigma_odl(i,j,k))**2))
8055            if(.not.l_homo(k,ii)) cycle
8056            if (waga_dist.ge.0.0d0) then
8057 c
8058 c          For Gaussian-type Urestr
8059 c
8060             godl(k)=dexp(-distancek(k)+min_odl)
8061             odleg2=odleg2+godl(k)
8062 c
8063 c          For Lorentzian-type Urestr
8064 c
8065            else
8066             odleg2=odleg2+distancek(k)
8067            endif
8068
8069 ccc       write(iout,779) i,j,k, "odleg2=",odleg2, "odleg3=", odleg3,
8070 ccc     & "dEXP(odleg3)=", dEXP(odleg3),"distance(i,j,k)^2=",
8071 ccc     & distance(i,j,k)**2, "dist(i+1,j+1)=", dist(i+1,j+1),
8072 ccc     & "sigma_odl(i,j,k)=", sigma_odl(i,j,k)
8073
8074          enddo
8075 c        write (iout,*) "godl",(godl(k),k=1,constr_homology) ! exponents
8076 c        write (iout,*) "ii i j",ii,i,j," odleg2",odleg2 ! sum of exps
8077 #ifdef DEBUG
8078          write (iout,*) "godl",(godl(k),k=1,constr_homology) ! exponents
8079          write (iout,*) "ii i j",ii,i,j," odleg2",odleg2 ! sum of exps
8080 #endif
8081            if (waga_dist.ge.0.0d0) then
8082 c
8083 c          For Gaussian-type Urestr
8084 c
8085               odleg=odleg-dLOG(odleg2/constr_homology)+min_odl
8086 c
8087 c          For Lorentzian-type Urestr
8088 c
8089            else
8090               odleg=odleg+odleg2/constr_homology
8091            endif
8092 c
8093 c        write (iout,*) "odleg",odleg ! sum of -ln-s
8094 c Gradient
8095 c
8096 c          For Gaussian-type Urestr
8097 c
8098          if (waga_dist.ge.0.0d0) sum_godl=odleg2
8099          sum_sgodl=0.0d0
8100          do k=1,constr_homology
8101 c            godl=dexp(((-(distance(i,j,k)**2)/(2*(sigma_odl(i,j,k))**2))
8102 c     &           *waga_dist)+min_odl
8103 c          sgodl=-godl(k)*distance(k)*sigma_odl(k,ii)*waga_dist
8104 c
8105          if(.not.l_homo(k,ii)) cycle
8106          if (waga_dist.ge.0.0d0) then
8107 c          For Gaussian-type Urestr
8108 c
8109            sgodl=-godl(k)*distance(k)*sigma_odl(k,ii) ! waga_dist rmvd
8110 c
8111 c          For Lorentzian-type Urestr
8112 c
8113          else
8114            sgodl=-2*sigma_odlir(k,ii)*(distance(k)/(distance(k)**2+
8115      &           sigma_odlir(k,ii)**2)**2)
8116          endif
8117            sum_sgodl=sum_sgodl+sgodl
8118
8119 c            sgodl2=sgodl2+sgodl
8120 c      write(iout,*) i, j, k, distance(i,j,k), "W GRADIENCIE1"
8121 c      write(iout,*) "constr_homology=",constr_homology
8122 c      write(iout,*) i, j, k, "TEST K"
8123          enddo
8124          if (waga_dist.ge.0.0d0) then
8125 c
8126 c          For Gaussian-type Urestr
8127 c
8128             grad_odl3=waga_homology(iset)*waga_dist
8129      &                *sum_sgodl/(sum_godl*dij)
8130 c
8131 c          For Lorentzian-type Urestr
8132 c
8133          else
8134 c Original grad expr modified by analogy w Gaussian-type Urestr grad
8135 c           grad_odl3=-waga_homology(iset)*waga_dist*sum_sgodl
8136             grad_odl3=-waga_homology(iset)*waga_dist*
8137      &                sum_sgodl/(constr_homology*dij)
8138          endif
8139 c
8140 c        grad_odl3=sum_sgodl/(sum_godl*dij)
8141
8142
8143 c      write(iout,*) i, j, k, distance(i,j,k), "W GRADIENCIE2"
8144 c      write(iout,*) (distance(i,j,k)**2), (2*(sigma_odl(i,j,k))**2),
8145 c     &              (-(distance(i,j,k)**2)/(2*(sigma_odl(i,j,k))**2))
8146
8147 ccc      write(iout,*) godl, sgodl, grad_odl3
8148
8149 c          grad_odl=grad_odl+grad_odl3
8150
8151          do jik=1,3
8152             ggodl=grad_odl3*(c(jik,i)-c(jik,j))
8153 ccc      write(iout,*) c(jik,i+1), c(jik,j+1), (c(jik,i+1)-c(jik,j+1))
8154 ccc      write(iout,746) "GRAD_ODL_1", i, j, jik, ggodl,
8155 ccc     &              ghpbc(jik,i+1), ghpbc(jik,j+1)
8156             ghpbc(jik,i)=ghpbc(jik,i)+ggodl
8157             ghpbc(jik,j)=ghpbc(jik,j)-ggodl
8158 ccc      write(iout,746) "GRAD_ODL_2", i, j, jik, ggodl,
8159 ccc     &              ghpbc(jik,i+1), ghpbc(jik,j+1)
8160 c         if (i.eq.25.and.j.eq.27) then
8161 c         write(iout,*) "jik",jik,"i",i,"j",j
8162 c         write(iout,*) "sum_sgodl",sum_sgodl,"sgodl",sgodl
8163 c         write(iout,*) "grad_odl3",grad_odl3
8164 c         write(iout,*) "c(",jik,i,")",c(jik,i),"c(",jik,j,")",c(jik,j)
8165 c         write(iout,*) "ggodl",ggodl
8166 c         write(iout,*) "ghpbc(",jik,i,")",
8167 c     &                 ghpbc(jik,i),"ghpbc(",jik,j,")",
8168 c     &                 ghpbc(jik,j)
8169 c         endif
8170          enddo
8171 ccc       write(iout,778)"TEST: odleg2=", odleg2, "DLOG(odleg2)=",
8172 ccc     & dLOG(odleg2),"-odleg=", -odleg
8173
8174       enddo ! ii-loop for dist
8175 #ifdef DEBUG
8176       write(iout,*) "------- dist restrs end -------"
8177 c     if (waga_angle.eq.1.0d0 .or. waga_theta.eq.1.0d0 .or.
8178 c    &     waga_d.eq.1.0d0) call sum_gradient
8179 #endif
8180 c Pseudo-energy and gradient from dihedral-angle restraints from
8181 c homology templates
8182 c      write (iout,*) "End of distance loop"
8183 c      call flush(iout)
8184       kat=0.0d0
8185 c      write (iout,*) idihconstr_start_homo,idihconstr_end_homo
8186 #ifdef DEBUG
8187       write(iout,*) "------- dih restrs start -------"
8188       do i=idihconstr_start_homo,idihconstr_end_homo
8189         write (iout,*) "gloc_init(",i,icg,")",gloc(i,icg)
8190       enddo
8191 #endif
8192       do i=idihconstr_start_homo,idihconstr_end_homo
8193         kat2=0.0d0
8194 c        betai=beta(i,i+1,i+2,i+3)
8195         betai = phi(i)
8196 c       write (iout,*) "betai =",betai
8197         do k=1,constr_homology
8198           dih_diff(k)=pinorm(dih(k,i)-betai)
8199 cd          write (iout,'(a8,2i4,2f15.8)') "dih_diff",i,k,dih_diff(k)
8200 cd     &                  ,sigma_dih(k,i)
8201 c          if (dih_diff(i,k).gt.3.14159) dih_diff(i,k)=
8202 c     &                                   -(6.28318-dih_diff(i,k))
8203 c          if (dih_diff(i,k).lt.-3.14159) dih_diff(i,k)=
8204 c     &                                   6.28318+dih_diff(i,k)
8205 #ifdef OLD_DIHED
8206           kat3=-0.5d0*dih_diff(k)**2*sigma_dih(k,i) ! waga_angle rmvd from Gaussian argument
8207 #else
8208           kat3=(dcos(dih_diff(k))-1)*sigma_dih(k,i) ! waga_angle rmvd from Gaussian argument
8209 #endif
8210 c         kat3=-0.5d0*waga_angle*dih_diff(k)**2*sigma_dih(k,i)
8211           gdih(k)=dexp(kat3)
8212           kat2=kat2+gdih(k)
8213 c          write(iout,*) "kat2=", kat2, "exp(kat3)=", exp(kat3)
8214 c          write(*,*)""
8215         enddo
8216 c       write (iout,*) "gdih",(gdih(k),k=1,constr_homology) ! exps
8217 c       write (iout,*) "i",i," betai",betai," kat2",kat2 ! sum of exps
8218 #ifdef DEBUG
8219         write (iout,*) "i",i," betai",betai," kat2",kat2
8220         write (iout,*) "gdih",(gdih(k),k=1,constr_homology)
8221 #endif
8222         if (kat2.le.1.0d-14) cycle
8223         kat=kat-dLOG(kat2/constr_homology)
8224 c       write (iout,*) "kat",kat ! sum of -ln-s
8225
8226 ccc       write(iout,778)"TEST: kat2=", kat2, "DLOG(kat2)=",
8227 ccc     & dLOG(kat2), "-kat=", -kat
8228
8229 c ----------------------------------------------------------------------
8230 c Gradient
8231 c ----------------------------------------------------------------------
8232
8233         sum_gdih=kat2
8234         sum_sgdih=0.0d0
8235         do k=1,constr_homology
8236 #ifdef OLD_DIHED
8237           sgdih=-gdih(k)*dih_diff(k)*sigma_dih(k,i)  ! waga_angle rmvd
8238 #else
8239           sgdih=-gdih(k)*dsin(dih_diff(k))*sigma_dih(k,i)  ! waga_angle rmvd
8240 #endif
8241 c         sgdih=-gdih(k)*dih_diff(k)*sigma_dih(k,i)*waga_angle
8242           sum_sgdih=sum_sgdih+sgdih
8243         enddo
8244 c       grad_dih3=sum_sgdih/sum_gdih
8245         grad_dih3=waga_homology(iset)*waga_angle*sum_sgdih/sum_gdih
8246
8247 c      write(iout,*)i,k,gdih,sgdih,beta(i+1,i+2,i+3,i+4),grad_dih3
8248 ccc      write(iout,747) "GRAD_KAT_1", i, nphi, icg, grad_dih3,
8249 ccc     & gloc(nphi+i-3,icg)
8250         gloc(i-3,icg)=gloc(i-3,icg)+grad_dih3
8251 c        if (i.eq.25) then
8252 c        write(iout,*) "i",i,"icg",icg,"gloc(",i,icg,")",gloc(i,icg)
8253 c        endif
8254 ccc      write(iout,747) "GRAD_KAT_2", i, nphi, icg, grad_dih3,
8255 ccc     & gloc(nphi+i-3,icg)
8256
8257       enddo ! i-loop for dih
8258 #ifdef DEBUG
8259       write(iout,*) "------- dih restrs end -------"
8260 #endif
8261
8262 c Pseudo-energy and gradient for theta angle restraints from
8263 c homology templates
8264 c FP 01/15 - inserted from econstr_local_test.F, loop structure
8265 c adapted
8266
8267 c
8268 c     For constr_homology reference structures (FP)
8269 c
8270 c     Uconst_back_tot=0.0d0
8271       Eval=0.0d0
8272       Erot=0.0d0
8273 c     Econstr_back legacy
8274       do i=1,nres
8275 c     do i=ithet_start,ithet_end
8276        dutheta(i)=0.0d0
8277 c     enddo
8278 c     do i=loc_start,loc_end
8279         do j=1,3
8280           duscdiff(j,i)=0.0d0
8281           duscdiffx(j,i)=0.0d0
8282         enddo
8283       enddo
8284 c
8285 c     do iref=1,nref
8286 c     write (iout,*) "ithet_start =",ithet_start,"ithet_end =",ithet_end
8287 c     write (iout,*) "waga_theta",waga_theta
8288       if (waga_theta.gt.0.0d0) then
8289 #ifdef DEBUG
8290       write (iout,*) "usampl",usampl
8291       write(iout,*) "------- theta restrs start -------"
8292 c     do i=ithet_start,ithet_end
8293 c       write (iout,*) "gloc_init(",nphi+i,icg,")",gloc(nphi+i,icg)
8294 c     enddo
8295 #endif
8296 c     write (iout,*) "maxres",maxres,"nres",nres
8297
8298       do i=ithet_start,ithet_end
8299 c
8300 c     do i=1,nfrag_back
8301 c       ii = ifrag_back(2,i,iset)-ifrag_back(1,i,iset)
8302 c
8303 c Deviation of theta angles wrt constr_homology ref structures
8304 c
8305         utheta_i=0.0d0 ! argument of Gaussian for single k
8306         gutheta_i=0.0d0 ! Sum of Gaussians over constr_homology ref structures
8307 c       do j=ifrag_back(1,i,iset)+2,ifrag_back(2,i,iset) ! original loop
8308 c       over residues in a fragment
8309 c       write (iout,*) "theta(",i,")=",theta(i)
8310         do k=1,constr_homology
8311 c
8312 c         dtheta_i=theta(j)-thetaref(j,iref)
8313 c         dtheta_i=thetaref(k,i)-theta(i) ! original form without indexing
8314           theta_diff(k)=thetatpl(k,i)-theta(i)
8315 cd          write (iout,'(a8,2i4,2f15.8)') "theta_diff",i,k,theta_diff(k)
8316 cd     &                  ,sigma_theta(k,i)
8317
8318 c
8319           utheta_i=-0.5d0*theta_diff(k)**2*sigma_theta(k,i) ! waga_theta rmvd from Gaussian argument
8320 c         utheta_i=-0.5d0*waga_theta*theta_diff(k)**2*sigma_theta(k,i) ! waga_theta?
8321           gtheta(k)=dexp(utheta_i) ! + min_utheta_i?
8322           gutheta_i=gutheta_i+gtheta(k)  ! Sum of Gaussians (pk)
8323 c         Gradient for single Gaussian restraint in subr Econstr_back
8324 c         dutheta(j-2)=dutheta(j-2)+wfrag_back(1,i,iset)*dtheta_i/(ii-1)
8325 c
8326         enddo
8327 c       write (iout,*) "gtheta",(gtheta(k),k=1,constr_homology) ! exps
8328 c       write (iout,*) "i",i," gutheta_i",gutheta_i ! sum of exps
8329
8330 c
8331 c         Gradient for multiple Gaussian restraint
8332         sum_gtheta=gutheta_i
8333         sum_sgtheta=0.0d0
8334         do k=1,constr_homology
8335 c        New generalized expr for multiple Gaussian from Econstr_back
8336          sgtheta=-gtheta(k)*theta_diff(k)*sigma_theta(k,i) ! waga_theta rmvd
8337 c
8338 c        sgtheta=-gtheta(k)*theta_diff(k)*sigma_theta(k,i)*waga_theta ! right functional form?
8339           sum_sgtheta=sum_sgtheta+sgtheta ! cum variable
8340         enddo
8341 c       Final value of gradient using same var as in Econstr_back
8342         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)
8343      &      +sum_sgtheta/sum_gtheta*waga_theta
8344      &               *waga_homology(iset)
8345 c        dutheta(i-2)=sum_sgtheta/sum_gtheta*waga_theta
8346 c     &               *waga_homology(iset)
8347 c       dutheta(i)=sum_sgtheta/sum_gtheta
8348 c
8349 c       Uconst_back=Uconst_back+waga_theta*utheta(i) ! waga_theta added as weight
8350         Eval=Eval-dLOG(gutheta_i/constr_homology)
8351 c       write (iout,*) "utheta(",i,")=",utheta(i) ! -ln of sum of exps
8352 c       write (iout,*) "Uconst_back",Uconst_back ! sum of -ln-s
8353 c       Uconst_back=Uconst_back+utheta(i)
8354       enddo ! (i-loop for theta)
8355 #ifdef DEBUG
8356       write(iout,*) "------- theta restrs end -------"
8357 #endif
8358       endif
8359 c
8360 c Deviation of local SC geometry
8361 c
8362 c Separation of two i-loops (instructed by AL - 11/3/2014)
8363 c
8364 c     write (iout,*) "loc_start =",loc_start,"loc_end =",loc_end
8365 c     write (iout,*) "waga_d",waga_d
8366
8367 #ifdef DEBUG
8368       write(iout,*) "------- SC restrs start -------"
8369       write (iout,*) "Initial duscdiff,duscdiffx"
8370       do i=loc_start,loc_end
8371         write (iout,*) i,(duscdiff(jik,i),jik=1,3),
8372      &                 (duscdiffx(jik,i),jik=1,3)
8373       enddo
8374 #endif
8375       do i=loc_start,loc_end
8376         usc_diff_i=0.0d0 ! argument of Gaussian for single k
8377         guscdiff(i)=0.0d0 ! Sum of Gaussians over constr_homology ref structures
8378 c       do j=ifrag_back(1,i,iset)+1,ifrag_back(2,i,iset)-1 ! Econstr_back legacy
8379 c       write(iout,*) "xxtab, yytab, zztab"
8380 c       write(iout,'(i5,3f8.2)') i,xxtab(i),yytab(i),zztab(i)
8381         do k=1,constr_homology
8382 c
8383           dxx=-xxtpl(k,i)+xxtab(i) ! Diff b/w x component of ith SC vector in model and kth ref str?
8384 c                                    Original sign inverted for calc of gradients (s. Econstr_back)
8385           dyy=-yytpl(k,i)+yytab(i) ! ibid y
8386           dzz=-zztpl(k,i)+zztab(i) ! ibid z
8387 c         write(iout,*) "dxx, dyy, dzz"
8388 cd          write(iout,'(2i5,4f8.2)') k,i,dxx,dyy,dzz,sigma_d(k,i)
8389 c
8390           usc_diff_i=-0.5d0*(dxx**2+dyy**2+dzz**2)*sigma_d(k,i)  ! waga_d rmvd from Gaussian argument
8391 c         usc_diff(i)=-0.5d0*waga_d*(dxx**2+dyy**2+dzz**2)*sigma_d(k,i) ! waga_d?
8392 c         uscdiffk(k)=usc_diff(i)
8393           guscdiff2(k)=dexp(usc_diff_i) ! without min_scdiff
8394 c          write(iout,*) "i",i," k",k," sigma_d",sigma_d(k,i),
8395 c     &       " guscdiff2",guscdiff2(k)
8396           guscdiff(i)=guscdiff(i)+guscdiff2(k)  !Sum of Gaussians (pk)
8397 c          write (iout,'(i5,6f10.5)') j,xxtab(j),yytab(j),zztab(j),
8398 c     &      xxref(j),yyref(j),zzref(j)
8399         enddo
8400 c
8401 c       Gradient
8402 c
8403 c       Generalized expression for multiple Gaussian acc to that for a single
8404 c       Gaussian in Econstr_back as instructed by AL (FP - 03/11/2014)
8405 c
8406 c       Original implementation
8407 c       sum_guscdiff=guscdiff(i)
8408 c
8409 c       sum_sguscdiff=0.0d0
8410 c       do k=1,constr_homology
8411 c          sguscdiff=-guscdiff2(k)*dscdiff(k)*sigma_d(k,i)*waga_d !waga_d?
8412 c          sguscdiff=-guscdiff3(k)*dscdiff(k)*sigma_d(k,i)*waga_d ! w min_uscdiff
8413 c          sum_sguscdiff=sum_sguscdiff+sguscdiff
8414 c       enddo
8415 c
8416 c       Implementation of new expressions for gradient (Jan. 2015)
8417 c
8418 c       grad_uscdiff=sum_sguscdiff/(sum_guscdiff*dtab) !?
8419         do k=1,constr_homology
8420 c
8421 c       New calculation of dxx, dyy, and dzz corrected by AL (07/11), was missing and wrong
8422 c       before. Now the drivatives should be correct
8423 c
8424           dxx=-xxtpl(k,i)+xxtab(i) ! Diff b/w x component of ith SC vector in model and kth ref str?
8425 c                                  Original sign inverted for calc of gradients (s. Econstr_back)
8426           dyy=-yytpl(k,i)+yytab(i) ! ibid y
8427           dzz=-zztpl(k,i)+zztab(i) ! ibid z
8428 c
8429 c         New implementation
8430 c
8431           sum_guscdiff=guscdiff2(k)*!(dsqrt(dxx*dxx+dyy*dyy+dzz*dzz))* -> wrong!
8432      &                 sigma_d(k,i) ! for the grad wrt r'
8433 c         sum_sguscdiff=sum_sguscdiff+sum_guscdiff
8434 c
8435 c
8436 c        New implementation
8437          sum_guscdiff = waga_homology(iset)*waga_d*sum_guscdiff
8438          do jik=1,3
8439             duscdiff(jik,i-1)=duscdiff(jik,i-1)+
8440      &      sum_guscdiff*(dXX_C1tab(jik,i)*dxx+
8441      &      dYY_C1tab(jik,i)*dyy+dZZ_C1tab(jik,i)*dzz)/guscdiff(i)
8442             duscdiff(jik,i)=duscdiff(jik,i)+
8443      &      sum_guscdiff*(dXX_Ctab(jik,i)*dxx+
8444      &      dYY_Ctab(jik,i)*dyy+dZZ_Ctab(jik,i)*dzz)/guscdiff(i)
8445             duscdiffx(jik,i)=duscdiffx(jik,i)+
8446      &      sum_guscdiff*(dXX_XYZtab(jik,i)*dxx+
8447      &      dYY_XYZtab(jik,i)*dyy+dZZ_XYZtab(jik,i)*dzz)/guscdiff(i)
8448 c
8449 #ifdef DEBUG
8450              write(iout,*) "jik",jik,"i",i
8451              write(iout,*) "dxx, dyy, dzz"
8452              write(iout,'(2i5,3f8.2)') k,i,dxx,dyy,dzz
8453              write(iout,*) "guscdiff2(",k,")",guscdiff2(k)
8454 c            write(iout,*) "sum_sguscdiff",sum_sguscdiff
8455 cc           write(iout,*) "dXX_Ctab(",jik,i,")",dXX_Ctab(jik,i)
8456 c            write(iout,*) "dYY_Ctab(",jik,i,")",dYY_Ctab(jik,i)
8457 c            write(iout,*) "dZZ_Ctab(",jik,i,")",dZZ_Ctab(jik,i)
8458 c            write(iout,*) "dXX_C1tab(",jik,i,")",dXX_C1tab(jik,i)
8459 c            write(iout,*) "dYY_C1tab(",jik,i,")",dYY_C1tab(jik,i)
8460 c            write(iout,*) "dZZ_C1tab(",jik,i,")",dZZ_C1tab(jik,i)
8461 c            write(iout,*) "dXX_XYZtab(",jik,i,")",dXX_XYZtab(jik,i)
8462 c            write(iout,*) "dYY_XYZtab(",jik,i,")",dYY_XYZtab(jik,i)
8463 c            write(iout,*) "dZZ_XYZtab(",jik,i,")",dZZ_XYZtab(jik,i)
8464 c            write(iout,*) "duscdiff(",jik,i-1,")",duscdiff(jik,i-1)
8465 c            write(iout,*) "duscdiff(",jik,i,")",duscdiff(jik,i)
8466 c            write(iout,*) "duscdiffx(",jik,i,")",duscdiffx(jik,i)
8467 c            endif
8468 #endif
8469          enddo
8470         enddo
8471 c
8472 c       uscdiff(i)=-dLOG(guscdiff(i)/(ii-1))      ! Weighting by (ii-1) required?
8473 c        usc_diff(i)=-dLOG(guscdiff(i)/constr_homology) ! + min_uscdiff ?
8474 c
8475 c        write (iout,*) i," uscdiff",uscdiff(i)
8476 c
8477 c Put together deviations from local geometry
8478
8479 c       Uconst_back=Uconst_back+wfrag_back(1,i,iset)*utheta(i)+
8480 c      &            wfrag_back(3,i,iset)*uscdiff(i)
8481         Erot=Erot-dLOG(guscdiff(i)/constr_homology)
8482 c       write (iout,*) "usc_diff(",i,")=",usc_diff(i) ! -ln of sum of exps
8483 c       write (iout,*) "Uconst_back",Uconst_back ! cum sum of -ln-s
8484 c       Uconst_back=Uconst_back+usc_diff(i)
8485 c
8486 c     Gradient of multiple Gaussian restraint (FP - 04/11/2014 - right?)
8487 c
8488 c     New implment: multiplied by sum_sguscdiff
8489 c
8490
8491       enddo ! (i-loop for dscdiff)
8492
8493 c      endif
8494
8495 #ifdef DEBUG
8496       write(iout,*) "------- SC restrs end -------"
8497         write (iout,*) "------ After SC loop in e_modeller ------"
8498         do i=loc_start,loc_end
8499          write (iout,*) "i",i," gradc",(gradc(j,i,icg),j=1,3)
8500          write (iout,*) "i",i," gradx",(gradx(j,i,icg),j=1,3)
8501         enddo
8502       if (waga_theta.eq.1.0d0) then
8503       write (iout,*) "in e_modeller after SC restr end: dutheta"
8504       do i=ithet_start,ithet_end
8505         write (iout,*) i,dutheta(i)
8506       enddo
8507       endif
8508       if (waga_d.eq.1.0d0) then
8509       write (iout,*) "e_modeller after SC loop: duscdiff/x"
8510       do i=1,nres
8511         write (iout,*) i,(duscdiff(j,i),j=1,3)
8512         write (iout,*) i,(duscdiffx(j,i),j=1,3)
8513       enddo
8514       endif
8515 #endif
8516
8517 c Total energy from homology restraints
8518 #ifdef DEBUG
8519       write (iout,*) "odleg",odleg," kat",kat
8520 #endif
8521 c
8522 c Addition of energy of theta angle and SC local geom over constr_homologs ref strs
8523 c
8524 c     ehomology_constr=odleg+kat
8525 c
8526 c     For Lorentzian-type Urestr
8527 c
8528
8529       if (waga_dist.ge.0.0d0) then
8530 c
8531 c          For Gaussian-type Urestr
8532 c
8533         ehomology_constr=(waga_dist*odleg+waga_angle*kat+
8534      &              waga_theta*Eval+waga_d*Erot)*waga_homology(iset)
8535 c     write (iout,*) "ehomology_constr=",ehomology_constr
8536       else
8537 c
8538 c          For Lorentzian-type Urestr
8539 c
8540         ehomology_constr=(-waga_dist*odleg+waga_angle*kat+
8541      &              waga_theta*Eval+waga_d*Erot)*waga_homology(iset)
8542 c     write (iout,*) "ehomology_constr=",ehomology_constr
8543       endif
8544 #ifdef DEBUG
8545       write (iout,*) "odleg",waga_dist,odleg," kat",waga_angle,kat,
8546      & "Eval",waga_theta,eval,
8547      &   "Erot",waga_d,Erot
8548       write (iout,*) "ehomology_constr",ehomology_constr
8549 #endif
8550       return
8551 c
8552 c FP 01/15 end
8553 c
8554   748 format(a8,f12.3,a6,f12.3,a7,f12.3)
8555   747 format(a12,i4,i4,i4,f8.3,f8.3)
8556   746 format(a12,i4,i4,i4,f8.3,f8.3,f8.3)
8557   778 format(a7,1X,f10.3,1X,a4,1X,f10.3,1X,a5,1X,f10.3)
8558   779 format(i3,1X,i3,1X,i2,1X,a7,1X,f7.3,1X,a7,1X,f7.3,1X,a13,1X,
8559      &       f7.3,1X,a17,1X,f9.3,1X,a10,1X,f8.3,1X,a10,1X,f8.3)
8560       end
8561 c----------------------------------------------------------------------------
8562 C The rigorous attempt to derive energy function
8563       subroutine ebend_kcc(etheta)
8564
8565       implicit real*8 (a-h,o-z)
8566       include 'DIMENSIONS'
8567       include 'COMMON.VAR'
8568       include 'COMMON.GEO'
8569       include 'COMMON.LOCAL'
8570       include 'COMMON.TORSION'
8571       include 'COMMON.INTERACT'
8572       include 'COMMON.DERIV'
8573       include 'COMMON.CHAIN'
8574       include 'COMMON.NAMES'
8575       include 'COMMON.IOUNITS'
8576       include 'COMMON.FFIELD'
8577       include 'COMMON.TORCNSTR'
8578       include 'COMMON.CONTROL'
8579       logical lprn
8580       double precision thybt1(maxang_kcc)
8581 C Set lprn=.true. for debugging
8582       lprn=energy_dec
8583 c     lprn=.true.
8584 C      print *,"wchodze kcc"
8585       if (lprn) write (iout,*) "ebend_kcc tor_mode",tor_mode
8586       etheta=0.0D0
8587       do i=ithet_start,ithet_end
8588 c        print *,i,itype(i-1),itype(i),itype(i-2)
8589         if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
8590      &  .or.itype(i).eq.ntyp1) cycle
8591         iti=iabs(itortyp(itype(i-1)))
8592         sinthet=dsin(theta(i))
8593         costhet=dcos(theta(i))
8594         do j=1,nbend_kcc_Tb(iti)
8595           thybt1(j)=v1bend_chyb(j,iti)
8596         enddo
8597         sumth1thyb=v1bend_chyb(0,iti)+
8598      &    tschebyshev(1,nbend_kcc_Tb(iti),thybt1(1),costhet)
8599         if (lprn) write (iout,*) i-1,itype(i-1),iti,theta(i)*rad2deg,
8600      &    sumth1thyb
8601         ihelp=nbend_kcc_Tb(iti)-1
8602         gradthybt1=gradtschebyshev(0,ihelp,thybt1(1),costhet)
8603         etheta=etheta+sumth1thyb
8604 C        print *,sumth1thyb,gradthybt1,sinthet*(-0.5d0)
8605         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)-wang*gradthybt1*sinthet
8606       enddo
8607       return
8608       end
8609 c-------------------------------------------------------------------------------------
8610       subroutine etheta_constr(ethetacnstr)
8611
8612       implicit real*8 (a-h,o-z)
8613       include 'DIMENSIONS'
8614       include 'COMMON.VAR'
8615       include 'COMMON.GEO'
8616       include 'COMMON.LOCAL'
8617       include 'COMMON.TORSION'
8618       include 'COMMON.INTERACT'
8619       include 'COMMON.DERIV'
8620       include 'COMMON.CHAIN'
8621       include 'COMMON.NAMES'
8622       include 'COMMON.IOUNITS'
8623       include 'COMMON.FFIELD'
8624       include 'COMMON.TORCNSTR'
8625       include 'COMMON.CONTROL'
8626       ethetacnstr=0.0d0
8627 C      print *,ithetaconstr_start,ithetaconstr_end,"TU"
8628       do i=ithetaconstr_start,ithetaconstr_end
8629         itheta=itheta_constr(i)
8630         thetiii=theta(itheta)
8631         difi=pinorm(thetiii-theta_constr0(i))
8632         if (difi.gt.theta_drange(i)) then
8633           difi=difi-theta_drange(i)
8634           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
8635           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
8636      &    +for_thet_constr(i)*difi**3
8637         else if (difi.lt.-drange(i)) then
8638           difi=difi+drange(i)
8639           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
8640           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
8641      &    +for_thet_constr(i)*difi**3
8642         else
8643           difi=0.0
8644         endif
8645        if (energy_dec) then
8646         write (iout,'(a6,2i5,4f8.3,2e14.5)') "ethetc",
8647      &    i,itheta,rad2deg*thetiii,
8648      &    rad2deg*theta_constr0(i),  rad2deg*theta_drange(i),
8649      &    rad2deg*difi,0.25d0*for_thet_constr(i)*difi**4,
8650      &    gloc(itheta+nphi-2,icg)
8651         endif
8652       enddo
8653       return
8654       end
8655 c------------------------------------------------------------------------------
8656       subroutine eback_sc_corr(esccor)
8657 c 7/21/2007 Correlations between the backbone-local and side-chain-local
8658 c        conformational states; temporarily implemented as differences
8659 c        between UNRES torsional potentials (dependent on three types of
8660 c        residues) and the torsional potentials dependent on all 20 types
8661 c        of residues computed from AM1  energy surfaces of terminally-blocked
8662 c        amino-acid residues.
8663       implicit real*8 (a-h,o-z)
8664       include 'DIMENSIONS'
8665       include 'COMMON.VAR'
8666       include 'COMMON.GEO'
8667       include 'COMMON.LOCAL'
8668       include 'COMMON.TORSION'
8669       include 'COMMON.SCCOR'
8670       include 'COMMON.INTERACT'
8671       include 'COMMON.DERIV'
8672       include 'COMMON.CHAIN'
8673       include 'COMMON.NAMES'
8674       include 'COMMON.IOUNITS'
8675       include 'COMMON.FFIELD'
8676       include 'COMMON.CONTROL'
8677       logical lprn
8678 C Set lprn=.true. for debugging
8679       lprn=.false.
8680 c      lprn=.true.
8681 c      write (iout,*) "EBACK_SC_COR",itau_start,itau_end
8682       esccor=0.0D0
8683       do i=itau_start,itau_end
8684         if ((itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)) cycle
8685         isccori=isccortyp(itype(i-2))
8686         isccori1=isccortyp(itype(i-1))
8687 c      write (iout,*) "EBACK_SC_COR",i,nterm_sccor(isccori,isccori1)
8688         phii=phi(i)
8689         do intertyp=1,3 !intertyp
8690          esccor_ii=0.0D0
8691 cc Added 09 May 2012 (Adasko)
8692 cc  Intertyp means interaction type of backbone mainchain correlation:
8693 c   1 = SC...Ca...Ca...Ca
8694 c   2 = Ca...Ca...Ca...SC
8695 c   3 = SC...Ca...Ca...SCi
8696         gloci=0.0D0
8697         if (((intertyp.eq.3).and.((itype(i-2).eq.10).or.
8698      &      (itype(i-1).eq.10).or.(itype(i-2).eq.ntyp1).or.
8699      &      (itype(i-1).eq.ntyp1)))
8700      &    .or. ((intertyp.eq.1).and.((itype(i-2).eq.10)
8701      &     .or.(itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)
8702      &     .or.(itype(i).eq.ntyp1)))
8703      &    .or.((intertyp.eq.2).and.((itype(i-1).eq.10).or.
8704      &      (itype(i-1).eq.ntyp1).or.(itype(i-2).eq.ntyp1).or.
8705      &      (itype(i-3).eq.ntyp1)))) cycle
8706         if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1).eq.ntyp1)) cycle
8707         if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres).eq.ntyp1))
8708      & cycle
8709        do j=1,nterm_sccor(isccori,isccori1)
8710           v1ij=v1sccor(j,intertyp,isccori,isccori1)
8711           v2ij=v2sccor(j,intertyp,isccori,isccori1)
8712           cosphi=dcos(j*tauangle(intertyp,i))
8713           sinphi=dsin(j*tauangle(intertyp,i))
8714           if (energy_dec) esccor_ii=esccor_ii+v1ij*cosphi+v2ij*sinphi
8715           esccor=esccor+v1ij*cosphi+v2ij*sinphi
8716           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
8717         enddo
8718          if (energy_dec) write (iout,'(a6,i5,i2,0pf7.3)')
8719      &         'esccor',i,intertyp,esccor_ii
8720 c      write (iout,*) "EBACK_SC_COR",i,v1ij*cosphi+v2ij*sinphi,intertyp
8721         gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci
8722         if (lprn)
8723      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
8724      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,isccori,isccori1,
8725      &  (v1sccor(j,intertyp,isccori,isccori1),j=1,6)
8726      & ,(v2sccor(j,intertyp,isccori,isccori1),j=1,6)
8727         gsccor_loc(i-3)=gsccor_loc(i-3)+gloci
8728        enddo !intertyp
8729       enddo
8730
8731       return
8732       end
8733 c----------------------------------------------------------------------------
8734       subroutine multibody(ecorr)
8735 C This subroutine calculates multi-body contributions to energy following
8736 C the idea of Skolnick et al. If side chains I and J make a contact and
8737 C at the same time side chains I+1 and J+1 make a contact, an extra
8738 C contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
8739       implicit real*8 (a-h,o-z)
8740       include 'DIMENSIONS'
8741       include 'COMMON.IOUNITS'
8742       include 'COMMON.DERIV'
8743       include 'COMMON.INTERACT'
8744       include 'COMMON.CONTACTS'
8745       double precision gx(3),gx1(3)
8746       logical lprn
8747
8748 C Set lprn=.true. for debugging
8749       lprn=.false.
8750
8751       if (lprn) then
8752         write (iout,'(a)') 'Contact function values:'
8753         do i=nnt,nct-2
8754           write (iout,'(i2,20(1x,i2,f10.5))')
8755      &        i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
8756         enddo
8757       endif
8758       ecorr=0.0D0
8759       do i=nnt,nct
8760         do j=1,3
8761           gradcorr(j,i)=0.0D0
8762           gradxorr(j,i)=0.0D0
8763         enddo
8764       enddo
8765       do i=nnt,nct-2
8766
8767         DO ISHIFT = 3,4
8768
8769         i1=i+ishift
8770         num_conti=num_cont(i)
8771         num_conti1=num_cont(i1)
8772         do jj=1,num_conti
8773           j=jcont(jj,i)
8774           do kk=1,num_conti1
8775             j1=jcont(kk,i1)
8776             if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
8777 cd          write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
8778 cd   &                   ' ishift=',ishift
8779 C Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
8780 C The system gains extra energy.
8781               ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
8782             endif   ! j1==j+-ishift
8783           enddo     ! kk
8784         enddo       ! jj
8785
8786         ENDDO ! ISHIFT
8787
8788       enddo         ! i
8789       return
8790       end
8791 c------------------------------------------------------------------------------
8792       double precision function esccorr(i,j,k,l,jj,kk)
8793       implicit real*8 (a-h,o-z)
8794       include 'DIMENSIONS'
8795       include 'COMMON.IOUNITS'
8796       include 'COMMON.DERIV'
8797       include 'COMMON.INTERACT'
8798       include 'COMMON.CONTACTS'
8799       include 'COMMON.SHIELD'
8800       double precision gx(3),gx1(3)
8801       logical lprn
8802       lprn=.false.
8803       eij=facont(jj,i)
8804       ekl=facont(kk,k)
8805 cd    write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
8806 C Calculate the multi-body contribution to energy.
8807 C Calculate multi-body contributions to the gradient.
8808 cd    write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
8809 cd   & k,l,(gacont(m,kk,k),m=1,3)
8810       do m=1,3
8811         gx(m) =ekl*gacont(m,jj,i)
8812         gx1(m)=eij*gacont(m,kk,k)
8813         gradxorr(m,i)=gradxorr(m,i)-gx(m)
8814         gradxorr(m,j)=gradxorr(m,j)+gx(m)
8815         gradxorr(m,k)=gradxorr(m,k)-gx1(m)
8816         gradxorr(m,l)=gradxorr(m,l)+gx1(m)
8817       enddo
8818       do m=i,j-1
8819         do ll=1,3
8820           gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
8821         enddo
8822       enddo
8823       do m=k,l-1
8824         do ll=1,3
8825           gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
8826         enddo
8827       enddo
8828       esccorr=-eij*ekl
8829       return
8830       end
8831 c------------------------------------------------------------------------------
8832       subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
8833 C This subroutine calculates multi-body contributions to hydrogen-bonding
8834       implicit real*8 (a-h,o-z)
8835       include 'DIMENSIONS'
8836       include 'COMMON.IOUNITS'
8837 #ifdef MPI
8838       include "mpif.h"
8839       parameter (max_cont=maxconts)
8840       parameter (max_dim=26)
8841       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
8842       double precision zapas(max_dim,maxconts,max_fg_procs),
8843      &  zapas_recv(max_dim,maxconts,max_fg_procs)
8844       common /przechowalnia/ zapas
8845       integer status(MPI_STATUS_SIZE),req(maxconts*2),
8846      &  status_array(MPI_STATUS_SIZE,maxconts*2)
8847 #endif
8848       include 'COMMON.SETUP'
8849       include 'COMMON.FFIELD'
8850       include 'COMMON.DERIV'
8851       include 'COMMON.INTERACT'
8852       include 'COMMON.CONTACTS'
8853       include 'COMMON.CONTROL'
8854       include 'COMMON.LOCAL'
8855       double precision gx(3),gx1(3),time00
8856       logical lprn,ldone
8857
8858 C Set lprn=.true. for debugging
8859       lprn=.false.
8860 #ifdef MPI
8861       n_corr=0
8862       n_corr1=0
8863       if (nfgtasks.le.1) goto 30
8864       if (lprn) then
8865         write (iout,'(a)') 'Contact function values before RECEIVE:'
8866         do i=nnt,nct-2
8867           write (iout,'(2i3,50(1x,i2,f5.2))')
8868      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
8869      &    j=1,num_cont_hb(i))
8870         enddo
8871         call flush(iout)
8872       endif
8873       do i=1,ntask_cont_from
8874         ncont_recv(i)=0
8875       enddo
8876       do i=1,ntask_cont_to
8877         ncont_sent(i)=0
8878       enddo
8879 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
8880 c     & ntask_cont_to
8881 C Make the list of contacts to send to send to other procesors
8882 c      write (iout,*) "limits",max0(iturn4_end-1,iatel_s),iturn3_end
8883 c      call flush(iout)
8884       do i=iturn3_start,iturn3_end
8885 c        write (iout,*) "make contact list turn3",i," num_cont",
8886 c     &    num_cont_hb(i)
8887         call add_hb_contact(i,i+2,iturn3_sent_local(1,i))
8888       enddo
8889       do i=iturn4_start,iturn4_end
8890 c        write (iout,*) "make contact list turn4",i," num_cont",
8891 c     &   num_cont_hb(i)
8892         call add_hb_contact(i,i+3,iturn4_sent_local(1,i))
8893       enddo
8894       do ii=1,nat_sent
8895         i=iat_sent(ii)
8896 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
8897 c     &    num_cont_hb(i)
8898         do j=1,num_cont_hb(i)
8899         do k=1,4
8900           jjc=jcont_hb(j,i)
8901           iproc=iint_sent_local(k,jjc,ii)
8902 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
8903           if (iproc.gt.0) then
8904             ncont_sent(iproc)=ncont_sent(iproc)+1
8905             nn=ncont_sent(iproc)
8906             zapas(1,nn,iproc)=i
8907             zapas(2,nn,iproc)=jjc
8908             zapas(3,nn,iproc)=facont_hb(j,i)
8909             zapas(4,nn,iproc)=ees0p(j,i)
8910             zapas(5,nn,iproc)=ees0m(j,i)
8911             zapas(6,nn,iproc)=gacont_hbr(1,j,i)
8912             zapas(7,nn,iproc)=gacont_hbr(2,j,i)
8913             zapas(8,nn,iproc)=gacont_hbr(3,j,i)
8914             zapas(9,nn,iproc)=gacontm_hb1(1,j,i)
8915             zapas(10,nn,iproc)=gacontm_hb1(2,j,i)
8916             zapas(11,nn,iproc)=gacontm_hb1(3,j,i)
8917             zapas(12,nn,iproc)=gacontp_hb1(1,j,i)
8918             zapas(13,nn,iproc)=gacontp_hb1(2,j,i)
8919             zapas(14,nn,iproc)=gacontp_hb1(3,j,i)
8920             zapas(15,nn,iproc)=gacontm_hb2(1,j,i)
8921             zapas(16,nn,iproc)=gacontm_hb2(2,j,i)
8922             zapas(17,nn,iproc)=gacontm_hb2(3,j,i)
8923             zapas(18,nn,iproc)=gacontp_hb2(1,j,i)
8924             zapas(19,nn,iproc)=gacontp_hb2(2,j,i)
8925             zapas(20,nn,iproc)=gacontp_hb2(3,j,i)
8926             zapas(21,nn,iproc)=gacontm_hb3(1,j,i)
8927             zapas(22,nn,iproc)=gacontm_hb3(2,j,i)
8928             zapas(23,nn,iproc)=gacontm_hb3(3,j,i)
8929             zapas(24,nn,iproc)=gacontp_hb3(1,j,i)
8930             zapas(25,nn,iproc)=gacontp_hb3(2,j,i)
8931             zapas(26,nn,iproc)=gacontp_hb3(3,j,i)
8932           endif
8933         enddo
8934         enddo
8935       enddo
8936       if (lprn) then
8937       write (iout,*)
8938      &  "Numbers of contacts to be sent to other processors",
8939      &  (ncont_sent(i),i=1,ntask_cont_to)
8940       write (iout,*) "Contacts sent"
8941       do ii=1,ntask_cont_to
8942         nn=ncont_sent(ii)
8943         iproc=itask_cont_to(ii)
8944         write (iout,*) nn," contacts to processor",iproc,
8945      &   " of CONT_TO_COMM group"
8946         do i=1,nn
8947           write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
8948         enddo
8949       enddo
8950       call flush(iout)
8951       endif
8952       CorrelType=477
8953       CorrelID=fg_rank+1
8954       CorrelType1=478
8955       CorrelID1=nfgtasks+fg_rank+1
8956       ireq=0
8957 C Receive the numbers of needed contacts from other processors
8958       do ii=1,ntask_cont_from
8959         iproc=itask_cont_from(ii)
8960         ireq=ireq+1
8961         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
8962      &    FG_COMM,req(ireq),IERR)
8963       enddo
8964 c      write (iout,*) "IRECV ended"
8965 c      call flush(iout)
8966 C Send the number of contacts needed by other processors
8967       do ii=1,ntask_cont_to
8968         iproc=itask_cont_to(ii)
8969         ireq=ireq+1
8970         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
8971      &    FG_COMM,req(ireq),IERR)
8972       enddo
8973 c      write (iout,*) "ISEND ended"
8974 c      write (iout,*) "number of requests (nn)",ireq
8975 c      call flush(iout)
8976       if (ireq.gt.0)
8977      &  call MPI_Waitall(ireq,req,status_array,ierr)
8978 c      write (iout,*)
8979 c     &  "Numbers of contacts to be received from other processors",
8980 c     &  (ncont_recv(i),i=1,ntask_cont_from)
8981 c      call flush(iout)
8982 C Receive contacts
8983       ireq=0
8984       do ii=1,ntask_cont_from
8985         iproc=itask_cont_from(ii)
8986         nn=ncont_recv(ii)
8987 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
8988 c     &   " of CONT_TO_COMM group"
8989 c        call flush(iout)
8990         if (nn.gt.0) then
8991           ireq=ireq+1
8992           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
8993      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
8994 c          write (iout,*) "ireq,req",ireq,req(ireq)
8995         endif
8996       enddo
8997 C Send the contacts to processors that need them
8998       do ii=1,ntask_cont_to
8999         iproc=itask_cont_to(ii)
9000         nn=ncont_sent(ii)
9001 c        write (iout,*) nn," contacts to processor",iproc,
9002 c     &   " of CONT_TO_COMM group"
9003         if (nn.gt.0) then
9004           ireq=ireq+1
9005           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
9006      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
9007 c          write (iout,*) "ireq,req",ireq,req(ireq)
9008 c          do i=1,nn
9009 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
9010 c          enddo
9011         endif
9012       enddo
9013 c      write (iout,*) "number of requests (contacts)",ireq
9014 c      write (iout,*) "req",(req(i),i=1,4)
9015 c      call flush(iout)
9016       if (ireq.gt.0)
9017      & call MPI_Waitall(ireq,req,status_array,ierr)
9018       do iii=1,ntask_cont_from
9019         iproc=itask_cont_from(iii)
9020         nn=ncont_recv(iii)
9021         if (lprn) then
9022         write (iout,*) "Received",nn," contacts from processor",iproc,
9023      &   " of CONT_FROM_COMM group"
9024         call flush(iout)
9025         do i=1,nn
9026           write(iout,'(2f5.0,4f10.5)')(zapas_recv(j,i,iii),j=1,5)
9027         enddo
9028         call flush(iout)
9029         endif
9030         do i=1,nn
9031           ii=zapas_recv(1,i,iii)
9032 c Flag the received contacts to prevent double-counting
9033           jj=-zapas_recv(2,i,iii)
9034 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
9035 c          call flush(iout)
9036           nnn=num_cont_hb(ii)+1
9037           num_cont_hb(ii)=nnn
9038           jcont_hb(nnn,ii)=jj
9039           facont_hb(nnn,ii)=zapas_recv(3,i,iii)
9040           ees0p(nnn,ii)=zapas_recv(4,i,iii)
9041           ees0m(nnn,ii)=zapas_recv(5,i,iii)
9042           gacont_hbr(1,nnn,ii)=zapas_recv(6,i,iii)
9043           gacont_hbr(2,nnn,ii)=zapas_recv(7,i,iii)
9044           gacont_hbr(3,nnn,ii)=zapas_recv(8,i,iii)
9045           gacontm_hb1(1,nnn,ii)=zapas_recv(9,i,iii)
9046           gacontm_hb1(2,nnn,ii)=zapas_recv(10,i,iii)
9047           gacontm_hb1(3,nnn,ii)=zapas_recv(11,i,iii)
9048           gacontp_hb1(1,nnn,ii)=zapas_recv(12,i,iii)
9049           gacontp_hb1(2,nnn,ii)=zapas_recv(13,i,iii)
9050           gacontp_hb1(3,nnn,ii)=zapas_recv(14,i,iii)
9051           gacontm_hb2(1,nnn,ii)=zapas_recv(15,i,iii)
9052           gacontm_hb2(2,nnn,ii)=zapas_recv(16,i,iii)
9053           gacontm_hb2(3,nnn,ii)=zapas_recv(17,i,iii)
9054           gacontp_hb2(1,nnn,ii)=zapas_recv(18,i,iii)
9055           gacontp_hb2(2,nnn,ii)=zapas_recv(19,i,iii)
9056           gacontp_hb2(3,nnn,ii)=zapas_recv(20,i,iii)
9057           gacontm_hb3(1,nnn,ii)=zapas_recv(21,i,iii)
9058           gacontm_hb3(2,nnn,ii)=zapas_recv(22,i,iii)
9059           gacontm_hb3(3,nnn,ii)=zapas_recv(23,i,iii)
9060           gacontp_hb3(1,nnn,ii)=zapas_recv(24,i,iii)
9061           gacontp_hb3(2,nnn,ii)=zapas_recv(25,i,iii)
9062           gacontp_hb3(3,nnn,ii)=zapas_recv(26,i,iii)
9063         enddo
9064       enddo
9065       if (lprn) then
9066         write (iout,'(a)') 'Contact function values after receive:'
9067         do i=nnt,nct-2
9068           write (iout,'(2i3,50(1x,i3,f5.2))')
9069      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
9070      &    j=1,num_cont_hb(i))
9071         enddo
9072         call flush(iout)
9073       endif
9074    30 continue
9075 #endif
9076       if (lprn) then
9077         write (iout,'(a)') 'Contact function values:'
9078         do i=nnt,nct-2
9079           write (iout,'(2i3,50(1x,i3,f5.2))')
9080      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
9081      &    j=1,num_cont_hb(i))
9082         enddo
9083         call flush(iout)
9084       endif
9085       ecorr=0.0D0
9086 C Remove the loop below after debugging !!!
9087       do i=nnt,nct
9088         do j=1,3
9089           gradcorr(j,i)=0.0D0
9090           gradxorr(j,i)=0.0D0
9091         enddo
9092       enddo
9093 C Calculate the local-electrostatic correlation terms
9094       do i=min0(iatel_s,iturn4_start),max0(iatel_e,iturn3_end)
9095         i1=i+1
9096         num_conti=num_cont_hb(i)
9097         num_conti1=num_cont_hb(i+1)
9098         do jj=1,num_conti
9099           j=jcont_hb(jj,i)
9100           jp=iabs(j)
9101           do kk=1,num_conti1
9102             j1=jcont_hb(kk,i1)
9103             jp1=iabs(j1)
9104 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
9105 c     &         ' jj=',jj,' kk=',kk
9106 c            call flush(iout)
9107             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
9108      &          .or. j.lt.0 .and. j1.gt.0) .and.
9109      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
9110 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
9111 C The system gains extra energy.
9112               ecorr=ecorr+ehbcorr(i,jp,i+1,jp1,jj,kk,0.72D0,0.32D0)
9113               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
9114      &            'ecorrh',i,j,ehbcorr(i,j,i+1,j1,jj,kk,0.72D0,0.32D0)
9115               n_corr=n_corr+1
9116             else if (j1.eq.j) then
9117 C Contacts I-J and I-(J+1) occur simultaneously.
9118 C The system loses extra energy.
9119 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
9120             endif
9121           enddo ! kk
9122           do kk=1,num_conti
9123             j1=jcont_hb(kk,i)
9124 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
9125 c    &         ' jj=',jj,' kk=',kk
9126             if (j1.eq.j+1) then
9127 C Contacts I-J and (I+1)-J occur simultaneously.
9128 C The system loses extra energy.
9129 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
9130             endif ! j1==j+1
9131           enddo ! kk
9132         enddo ! jj
9133       enddo ! i
9134       return
9135       end
9136 c------------------------------------------------------------------------------
9137       subroutine add_hb_contact(ii,jj,itask)
9138       implicit real*8 (a-h,o-z)
9139       include "DIMENSIONS"
9140       include "COMMON.IOUNITS"
9141       integer max_cont
9142       integer max_dim
9143       parameter (max_cont=maxconts)
9144       parameter (max_dim=26)
9145       include "COMMON.CONTACTS"
9146       double precision zapas(max_dim,maxconts,max_fg_procs),
9147      &  zapas_recv(max_dim,maxconts,max_fg_procs)
9148       common /przechowalnia/ zapas
9149       integer i,j,ii,jj,iproc,itask(4),nn
9150 c      write (iout,*) "itask",itask
9151       do i=1,2
9152         iproc=itask(i)
9153         if (iproc.gt.0) then
9154           do j=1,num_cont_hb(ii)
9155             jjc=jcont_hb(j,ii)
9156 c            write (iout,*) "i",ii," j",jj," jjc",jjc
9157             if (jjc.eq.jj) then
9158               ncont_sent(iproc)=ncont_sent(iproc)+1
9159               nn=ncont_sent(iproc)
9160               zapas(1,nn,iproc)=ii
9161               zapas(2,nn,iproc)=jjc
9162               zapas(3,nn,iproc)=facont_hb(j,ii)
9163               zapas(4,nn,iproc)=ees0p(j,ii)
9164               zapas(5,nn,iproc)=ees0m(j,ii)
9165               zapas(6,nn,iproc)=gacont_hbr(1,j,ii)
9166               zapas(7,nn,iproc)=gacont_hbr(2,j,ii)
9167               zapas(8,nn,iproc)=gacont_hbr(3,j,ii)
9168               zapas(9,nn,iproc)=gacontm_hb1(1,j,ii)
9169               zapas(10,nn,iproc)=gacontm_hb1(2,j,ii)
9170               zapas(11,nn,iproc)=gacontm_hb1(3,j,ii)
9171               zapas(12,nn,iproc)=gacontp_hb1(1,j,ii)
9172               zapas(13,nn,iproc)=gacontp_hb1(2,j,ii)
9173               zapas(14,nn,iproc)=gacontp_hb1(3,j,ii)
9174               zapas(15,nn,iproc)=gacontm_hb2(1,j,ii)
9175               zapas(16,nn,iproc)=gacontm_hb2(2,j,ii)
9176               zapas(17,nn,iproc)=gacontm_hb2(3,j,ii)
9177               zapas(18,nn,iproc)=gacontp_hb2(1,j,ii)
9178               zapas(19,nn,iproc)=gacontp_hb2(2,j,ii)
9179               zapas(20,nn,iproc)=gacontp_hb2(3,j,ii)
9180               zapas(21,nn,iproc)=gacontm_hb3(1,j,ii)
9181               zapas(22,nn,iproc)=gacontm_hb3(2,j,ii)
9182               zapas(23,nn,iproc)=gacontm_hb3(3,j,ii)
9183               zapas(24,nn,iproc)=gacontp_hb3(1,j,ii)
9184               zapas(25,nn,iproc)=gacontp_hb3(2,j,ii)
9185               zapas(26,nn,iproc)=gacontp_hb3(3,j,ii)
9186               exit
9187             endif
9188           enddo
9189         endif
9190       enddo
9191       return
9192       end
9193 c------------------------------------------------------------------------------
9194       subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,
9195      &  n_corr1)
9196 C This subroutine calculates multi-body contributions to hydrogen-bonding
9197       implicit real*8 (a-h,o-z)
9198       include 'DIMENSIONS'
9199       include 'COMMON.IOUNITS'
9200 #ifdef MPI
9201       include "mpif.h"
9202       parameter (max_cont=maxconts)
9203       parameter (max_dim=70)
9204       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
9205       double precision zapas(max_dim,maxconts,max_fg_procs),
9206      &  zapas_recv(max_dim,maxconts,max_fg_procs)
9207       common /przechowalnia/ zapas
9208       integer status(MPI_STATUS_SIZE),req(maxconts*2),
9209      &  status_array(MPI_STATUS_SIZE,maxconts*2)
9210 #endif
9211       include 'COMMON.SETUP'
9212       include 'COMMON.FFIELD'
9213       include 'COMMON.DERIV'
9214       include 'COMMON.LOCAL'
9215       include 'COMMON.INTERACT'
9216       include 'COMMON.CONTACTS'
9217       include 'COMMON.CHAIN'
9218       include 'COMMON.CONTROL'
9219       include 'COMMON.SHIELD'
9220       double precision gx(3),gx1(3)
9221       integer num_cont_hb_old(maxres)
9222       logical lprn,ldone
9223       double precision eello4,eello5,eelo6,eello_turn6
9224       external eello4,eello5,eello6,eello_turn6
9225 C Set lprn=.true. for debugging
9226       lprn=.false.
9227       eturn6=0.0d0
9228 #ifdef MPI
9229       do i=1,nres
9230         num_cont_hb_old(i)=num_cont_hb(i)
9231       enddo
9232       n_corr=0
9233       n_corr1=0
9234       if (nfgtasks.le.1) goto 30
9235       if (lprn) then
9236         write (iout,'(a)') 'Contact function values before RECEIVE:'
9237         do i=nnt,nct-2
9238           write (iout,'(2i3,50(1x,i2,f5.2))')
9239      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
9240      &    j=1,num_cont_hb(i))
9241         enddo
9242       endif
9243       do i=1,ntask_cont_from
9244         ncont_recv(i)=0
9245       enddo
9246       do i=1,ntask_cont_to
9247         ncont_sent(i)=0
9248       enddo
9249 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
9250 c     & ntask_cont_to
9251 C Make the list of contacts to send to send to other procesors
9252       do i=iturn3_start,iturn3_end
9253 c        write (iout,*) "make contact list turn3",i," num_cont",
9254 c     &    num_cont_hb(i)
9255         call add_hb_contact_eello(i,i+2,iturn3_sent_local(1,i))
9256       enddo
9257       do i=iturn4_start,iturn4_end
9258 c        write (iout,*) "make contact list turn4",i," num_cont",
9259 c     &   num_cont_hb(i)
9260         call add_hb_contact_eello(i,i+3,iturn4_sent_local(1,i))
9261       enddo
9262       do ii=1,nat_sent
9263         i=iat_sent(ii)
9264 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
9265 c     &    num_cont_hb(i)
9266         do j=1,num_cont_hb(i)
9267         do k=1,4
9268           jjc=jcont_hb(j,i)
9269           iproc=iint_sent_local(k,jjc,ii)
9270 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
9271           if (iproc.ne.0) then
9272             ncont_sent(iproc)=ncont_sent(iproc)+1
9273             nn=ncont_sent(iproc)
9274             zapas(1,nn,iproc)=i
9275             zapas(2,nn,iproc)=jjc
9276             zapas(3,nn,iproc)=d_cont(j,i)
9277             ind=3
9278             do kk=1,3
9279               ind=ind+1
9280               zapas(ind,nn,iproc)=grij_hb_cont(kk,j,i)
9281             enddo
9282             do kk=1,2
9283               do ll=1,2
9284                 ind=ind+1
9285                 zapas(ind,nn,iproc)=a_chuj(ll,kk,j,i)
9286               enddo
9287             enddo
9288             do jj=1,5
9289               do kk=1,3
9290                 do ll=1,2
9291                   do mm=1,2
9292                     ind=ind+1
9293                     zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,i)
9294                   enddo
9295                 enddo
9296               enddo
9297             enddo
9298           endif
9299         enddo
9300         enddo
9301       enddo
9302       if (lprn) then
9303       write (iout,*)
9304      &  "Numbers of contacts to be sent to other processors",
9305      &  (ncont_sent(i),i=1,ntask_cont_to)
9306       write (iout,*) "Contacts sent"
9307       do ii=1,ntask_cont_to
9308         nn=ncont_sent(ii)
9309         iproc=itask_cont_to(ii)
9310         write (iout,*) nn," contacts to processor",iproc,
9311      &   " of CONT_TO_COMM group"
9312         do i=1,nn
9313           write(iout,'(2f5.0,10f10.5)')(zapas(j,i,ii),j=1,10)
9314         enddo
9315       enddo
9316       call flush(iout)
9317       endif
9318       CorrelType=477
9319       CorrelID=fg_rank+1
9320       CorrelType1=478
9321       CorrelID1=nfgtasks+fg_rank+1
9322       ireq=0
9323 C Receive the numbers of needed contacts from other processors
9324       do ii=1,ntask_cont_from
9325         iproc=itask_cont_from(ii)
9326         ireq=ireq+1
9327         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
9328      &    FG_COMM,req(ireq),IERR)
9329       enddo
9330 c      write (iout,*) "IRECV ended"
9331 c      call flush(iout)
9332 C Send the number of contacts needed by other processors
9333       do ii=1,ntask_cont_to
9334         iproc=itask_cont_to(ii)
9335         ireq=ireq+1
9336         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
9337      &    FG_COMM,req(ireq),IERR)
9338       enddo
9339 c      write (iout,*) "ISEND ended"
9340 c      write (iout,*) "number of requests (nn)",ireq
9341 c      call flush(iout)
9342       if (ireq.gt.0)
9343      &  call MPI_Waitall(ireq,req,status_array,ierr)
9344 c      write (iout,*)
9345 c     &  "Numbers of contacts to be received from other processors",
9346 c     &  (ncont_recv(i),i=1,ntask_cont_from)
9347 c      call flush(iout)
9348 C Receive contacts
9349       ireq=0
9350       do ii=1,ntask_cont_from
9351         iproc=itask_cont_from(ii)
9352         nn=ncont_recv(ii)
9353 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
9354 c     &   " of CONT_TO_COMM group"
9355 c        call flush(iout)
9356         if (nn.gt.0) then
9357           ireq=ireq+1
9358           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
9359      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
9360 c          write (iout,*) "ireq,req",ireq,req(ireq)
9361         endif
9362       enddo
9363 C Send the contacts to processors that need them
9364       do ii=1,ntask_cont_to
9365         iproc=itask_cont_to(ii)
9366         nn=ncont_sent(ii)
9367 c        write (iout,*) nn," contacts to processor",iproc,
9368 c     &   " of CONT_TO_COMM group"
9369         if (nn.gt.0) then
9370           ireq=ireq+1
9371           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
9372      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
9373 c          write (iout,*) "ireq,req",ireq,req(ireq)
9374 c          do i=1,nn
9375 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
9376 c          enddo
9377         endif
9378       enddo
9379 c      write (iout,*) "number of requests (contacts)",ireq
9380 c      write (iout,*) "req",(req(i),i=1,4)
9381 c      call flush(iout)
9382       if (ireq.gt.0)
9383      & call MPI_Waitall(ireq,req,status_array,ierr)
9384       do iii=1,ntask_cont_from
9385         iproc=itask_cont_from(iii)
9386         nn=ncont_recv(iii)
9387         if (lprn) then
9388         write (iout,*) "Received",nn," contacts from processor",iproc,
9389      &   " of CONT_FROM_COMM group"
9390         call flush(iout)
9391         do i=1,nn
9392           write(iout,'(2f5.0,10f10.5)')(zapas_recv(j,i,iii),j=1,10)
9393         enddo
9394         call flush(iout)
9395         endif
9396         do i=1,nn
9397           ii=zapas_recv(1,i,iii)
9398 c Flag the received contacts to prevent double-counting
9399           jj=-zapas_recv(2,i,iii)
9400 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
9401 c          call flush(iout)
9402           nnn=num_cont_hb(ii)+1
9403           num_cont_hb(ii)=nnn
9404           jcont_hb(nnn,ii)=jj
9405           d_cont(nnn,ii)=zapas_recv(3,i,iii)
9406           ind=3
9407           do kk=1,3
9408             ind=ind+1
9409             grij_hb_cont(kk,nnn,ii)=zapas_recv(ind,i,iii)
9410           enddo
9411           do kk=1,2
9412             do ll=1,2
9413               ind=ind+1
9414               a_chuj(ll,kk,nnn,ii)=zapas_recv(ind,i,iii)
9415             enddo
9416           enddo
9417           do jj=1,5
9418             do kk=1,3
9419               do ll=1,2
9420                 do mm=1,2
9421                   ind=ind+1
9422                   a_chuj_der(mm,ll,kk,jj,nnn,ii)=zapas_recv(ind,i,iii)
9423                 enddo
9424               enddo
9425             enddo
9426           enddo
9427         enddo
9428       enddo
9429       if (lprn) then
9430         write (iout,'(a)') 'Contact function values after receive:'
9431         do i=nnt,nct-2
9432           write (iout,'(2i3,50(1x,i3,5f6.3))')
9433      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
9434      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
9435         enddo
9436         call flush(iout)
9437       endif
9438    30 continue
9439 #endif
9440       if (lprn) then
9441         write (iout,'(a)') 'Contact function values:'
9442         do i=nnt,nct-2
9443           write (iout,'(2i3,50(1x,i2,5f6.3))')
9444      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
9445      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
9446         enddo
9447       endif
9448       ecorr=0.0D0
9449       ecorr5=0.0d0
9450       ecorr6=0.0d0
9451 C Remove the loop below after debugging !!!
9452       do i=nnt,nct
9453         do j=1,3
9454           gradcorr(j,i)=0.0D0
9455           gradxorr(j,i)=0.0D0
9456         enddo
9457       enddo
9458 C Calculate the dipole-dipole interaction energies
9459       if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
9460       do i=iatel_s,iatel_e+1
9461         num_conti=num_cont_hb(i)
9462         do jj=1,num_conti
9463           j=jcont_hb(jj,i)
9464 #ifdef MOMENT
9465           call dipole(i,j,jj)
9466 #endif
9467         enddo
9468       enddo
9469       endif
9470 C Calculate the local-electrostatic correlation terms
9471 c                write (iout,*) "gradcorr5 in eello5 before loop"
9472 c                do iii=1,nres
9473 c                  write (iout,'(i5,3f10.5)')
9474 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
9475 c                enddo
9476       do i=min0(iatel_s,iturn4_start),max0(iatel_e+1,iturn3_end+1)
9477 c        write (iout,*) "corr loop i",i
9478         i1=i+1
9479         num_conti=num_cont_hb(i)
9480         num_conti1=num_cont_hb(i+1)
9481         do jj=1,num_conti
9482           j=jcont_hb(jj,i)
9483           jp=iabs(j)
9484           do kk=1,num_conti1
9485             j1=jcont_hb(kk,i1)
9486             jp1=iabs(j1)
9487 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
9488 c     &         ' jj=',jj,' kk=',kk
9489 c            if (j1.eq.j+1 .or. j1.eq.j-1) then
9490             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
9491      &          .or. j.lt.0 .and. j1.gt.0) .and.
9492      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
9493 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
9494 C The system gains extra energy.
9495               n_corr=n_corr+1
9496               sqd1=dsqrt(d_cont(jj,i))
9497               sqd2=dsqrt(d_cont(kk,i1))
9498               sred_geom = sqd1*sqd2
9499               IF (sred_geom.lt.cutoff_corr) THEN
9500                 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,
9501      &            ekont,fprimcont)
9502 cd               write (iout,*) 'i=',i,' j=',jp,' i1=',i1,' j1=',jp1,
9503 cd     &         ' jj=',jj,' kk=',kk
9504                 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
9505                 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
9506                 do l=1,3
9507                   g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
9508                   g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
9509                 enddo
9510                 n_corr1=n_corr1+1
9511 cd               write (iout,*) 'sred_geom=',sred_geom,
9512 cd     &          ' ekont=',ekont,' fprim=',fprimcont,
9513 cd     &          ' fac_prim1',fac_prim1,' fac_prim2',fac_prim2
9514 cd               write (iout,*) "g_contij",g_contij
9515 cd               write (iout,*) "grij_hb_cont i",grij_hb_cont(:,jj,i)
9516 cd               write (iout,*) "grij_hb_cont i1",grij_hb_cont(:,jj,i1)
9517                 call calc_eello(i,jp,i+1,jp1,jj,kk)
9518                 if (wcorr4.gt.0.0d0)
9519      &            ecorr=ecorr+eello4(i,jp,i+1,jp1,jj,kk)
9520 CC     &            *fac_shield(i)**2*fac_shield(j)**2
9521                   if (energy_dec.and.wcorr4.gt.0.0d0)
9522      1                 write (iout,'(a6,4i5,0pf7.3)')
9523      2                'ecorr4',i,j,i+1,j1,eello4(i,jp,i+1,jp1,jj,kk)
9524 c                write (iout,*) "gradcorr5 before eello5"
9525 c                do iii=1,nres
9526 c                  write (iout,'(i5,3f10.5)')
9527 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
9528 c                enddo
9529                 if (wcorr5.gt.0.0d0)
9530      &            ecorr5=ecorr5+eello5(i,jp,i+1,jp1,jj,kk)
9531 c                write (iout,*) "gradcorr5 after eello5"
9532 c                do iii=1,nres
9533 c                  write (iout,'(i5,3f10.5)')
9534 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
9535 c                enddo
9536                   if (energy_dec.and.wcorr5.gt.0.0d0)
9537      1                 write (iout,'(a6,4i5,0pf7.3)')
9538      2                'ecorr5',i,j,i+1,j1,eello5(i,jp,i+1,jp1,jj,kk)
9539 cd                write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
9540 cd                write(2,*)'ijkl',i,jp,i+1,jp1
9541                 if (wcorr6.gt.0.0d0 .and. (jp.ne.i+4 .or. jp1.ne.i+3
9542      &               .or. wturn6.eq.0.0d0))then
9543 cd                  write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
9544                   ecorr6=ecorr6+eello6(i,jp,i+1,jp1,jj,kk)
9545                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
9546      1                'ecorr6',i,j,i+1,j1,eello6(i,jp,i+1,jp1,jj,kk)
9547 cd                write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
9548 cd     &            'ecorr6=',ecorr6
9549 cd                write (iout,'(4e15.5)') sred_geom,
9550 cd     &          dabs(eello4(i,jp,i+1,jp1,jj,kk)),
9551 cd     &          dabs(eello5(i,jp,i+1,jp1,jj,kk)),
9552 cd     &          dabs(eello6(i,jp,i+1,jp1,jj,kk))
9553                 else if (wturn6.gt.0.0d0
9554      &            .and. (jp.eq.i+4 .and. jp1.eq.i+3)) then
9555 cd                  write (iout,*) '******eturn6: i,j,i+1,j1',i,jip,i+1,jp1
9556                   eturn6=eturn6+eello_turn6(i,jj,kk)
9557                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
9558      1                 'eturn6',i,j,i+1,j1,eello_turn6(i,jj,kk)
9559 cd                  write (2,*) 'multibody_eello:eturn6',eturn6
9560                 endif
9561               ENDIF
9562 1111          continue
9563             endif
9564           enddo ! kk
9565         enddo ! jj
9566       enddo ! i
9567       do i=1,nres
9568         num_cont_hb(i)=num_cont_hb_old(i)
9569       enddo
9570 c                write (iout,*) "gradcorr5 in eello5"
9571 c                do iii=1,nres
9572 c                  write (iout,'(i5,3f10.5)')
9573 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
9574 c                enddo
9575       return
9576       end
9577 c------------------------------------------------------------------------------
9578       subroutine add_hb_contact_eello(ii,jj,itask)
9579       implicit real*8 (a-h,o-z)
9580       include "DIMENSIONS"
9581       include "COMMON.IOUNITS"
9582       integer max_cont
9583       integer max_dim
9584       parameter (max_cont=maxconts)
9585       parameter (max_dim=70)
9586       include "COMMON.CONTACTS"
9587       double precision zapas(max_dim,maxconts,max_fg_procs),
9588      &  zapas_recv(max_dim,maxconts,max_fg_procs)
9589       common /przechowalnia/ zapas
9590       integer i,j,ii,jj,iproc,itask(4),nn
9591 c      write (iout,*) "itask",itask
9592       do i=1,2
9593         iproc=itask(i)
9594         if (iproc.gt.0) then
9595           do j=1,num_cont_hb(ii)
9596             jjc=jcont_hb(j,ii)
9597 c            write (iout,*) "send turns i",ii," j",jj," jjc",jjc
9598             if (jjc.eq.jj) then
9599               ncont_sent(iproc)=ncont_sent(iproc)+1
9600               nn=ncont_sent(iproc)
9601               zapas(1,nn,iproc)=ii
9602               zapas(2,nn,iproc)=jjc
9603               zapas(3,nn,iproc)=d_cont(j,ii)
9604               ind=3
9605               do kk=1,3
9606                 ind=ind+1
9607                 zapas(ind,nn,iproc)=grij_hb_cont(kk,j,ii)
9608               enddo
9609               do kk=1,2
9610                 do ll=1,2
9611                   ind=ind+1
9612                   zapas(ind,nn,iproc)=a_chuj(ll,kk,j,ii)
9613                 enddo
9614               enddo
9615               do jj=1,5
9616                 do kk=1,3
9617                   do ll=1,2
9618                     do mm=1,2
9619                       ind=ind+1
9620                       zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,ii)
9621                     enddo
9622                   enddo
9623                 enddo
9624               enddo
9625               exit
9626             endif
9627           enddo
9628         endif
9629       enddo
9630       return
9631       end
9632 c------------------------------------------------------------------------------
9633       double precision function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
9634       implicit real*8 (a-h,o-z)
9635       include 'DIMENSIONS'
9636       include 'COMMON.IOUNITS'
9637       include 'COMMON.DERIV'
9638       include 'COMMON.INTERACT'
9639       include 'COMMON.CONTACTS'
9640       include 'COMMON.SHIELD'
9641       include 'COMMON.CONTROL'
9642       double precision gx(3),gx1(3)
9643       logical lprn
9644       lprn=.false.
9645 C      print *,"wchodze",fac_shield(i),shield_mode
9646       eij=facont_hb(jj,i)
9647       ekl=facont_hb(kk,k)
9648       ees0pij=ees0p(jj,i)
9649       ees0pkl=ees0p(kk,k)
9650       ees0mij=ees0m(jj,i)
9651       ees0mkl=ees0m(kk,k)
9652       ekont=eij*ekl
9653       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
9654 C*
9655 C     & fac_shield(i)**2*fac_shield(j)**2
9656 cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
9657 C Following 4 lines for diagnostics.
9658 cd    ees0pkl=0.0D0
9659 cd    ees0pij=1.0D0
9660 cd    ees0mkl=0.0D0
9661 cd    ees0mij=1.0D0
9662 c      write (iout,'(2(a,2i3,a,f10.5,a,2f10.5),a,f10.5,a,$)')
9663 c     & 'Contacts ',i,j,
9664 c     & ' eij',eij,' eesij',ees0pij,ees0mij,' and ',k,l
9665 c     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' energy=',ekont*ees,
9666 c     & 'gradcorr_long'
9667 C Calculate the multi-body contribution to energy.
9668 C      ecorr=ecorr+ekont*ees
9669 C Calculate multi-body contributions to the gradient.
9670       coeffpees0pij=coeffp*ees0pij
9671       coeffmees0mij=coeffm*ees0mij
9672       coeffpees0pkl=coeffp*ees0pkl
9673       coeffmees0mkl=coeffm*ees0mkl
9674       do ll=1,3
9675 cgrad        ghalfi=ees*ekl*gacont_hbr(ll,jj,i)
9676         gradcorr(ll,i)=gradcorr(ll,i)!+0.5d0*ghalfi
9677      &  -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+
9678      &  coeffmees0mkl*gacontm_hb1(ll,jj,i))
9679         gradcorr(ll,j)=gradcorr(ll,j)!+0.5d0*ghalfi
9680      &  -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+
9681      &  coeffmees0mkl*gacontm_hb2(ll,jj,i))
9682 cgrad        ghalfk=ees*eij*gacont_hbr(ll,kk,k)
9683         gradcorr(ll,k)=gradcorr(ll,k)!+0.5d0*ghalfk
9684      &  -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+
9685      &  coeffmees0mij*gacontm_hb1(ll,kk,k))
9686         gradcorr(ll,l)=gradcorr(ll,l)!+0.5d0*ghalfk
9687      &  -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+
9688      &  coeffmees0mij*gacontm_hb2(ll,kk,k))
9689         gradlongij=ees*ekl*gacont_hbr(ll,jj,i)-
9690      &     ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+
9691      &     coeffmees0mkl*gacontm_hb3(ll,jj,i))
9692         gradcorr_long(ll,j)=gradcorr_long(ll,j)+gradlongij
9693         gradcorr_long(ll,i)=gradcorr_long(ll,i)-gradlongij
9694         gradlongkl=ees*eij*gacont_hbr(ll,kk,k)-
9695      &     ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+
9696      &     coeffmees0mij*gacontm_hb3(ll,kk,k))
9697         gradcorr_long(ll,l)=gradcorr_long(ll,l)+gradlongkl
9698         gradcorr_long(ll,k)=gradcorr_long(ll,k)-gradlongkl
9699 c        write (iout,'(2f10.5,2x,$)') gradlongij,gradlongkl
9700       enddo
9701 c      write (iout,*)
9702 cgrad      do m=i+1,j-1
9703 cgrad        do ll=1,3
9704 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
9705 cgrad     &     ees*ekl*gacont_hbr(ll,jj,i)-
9706 cgrad     &     ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
9707 cgrad     &     coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
9708 cgrad        enddo
9709 cgrad      enddo
9710 cgrad      do m=k+1,l-1
9711 cgrad        do ll=1,3
9712 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
9713 cgrad     &     ees*eij*gacont_hbr(ll,kk,k)-
9714 cgrad     &     ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
9715 cgrad     &     coeffm*ees0mij*gacontm_hb3(ll,kk,k))
9716 cgrad        enddo
9717 cgrad      enddo
9718 c      write (iout,*) "ehbcorr",ekont*ees
9719 C      print *,ekont,ees,i,k
9720       ehbcorr=ekont*ees
9721 C now gradient over shielding
9722 C      return
9723       if (shield_mode.gt.0) then
9724        j=ees0plist(jj,i)
9725        l=ees0plist(kk,k)
9726 C        print *,i,j,fac_shield(i),fac_shield(j),
9727 C     &fac_shield(k),fac_shield(l)
9728         if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
9729      &      (fac_shield(k).gt.0).and.(fac_shield(l).gt.0)) then
9730           do ilist=1,ishield_list(i)
9731            iresshield=shield_list(ilist,i)
9732            do m=1,3
9733            rlocshield=grad_shield_side(m,ilist,i)*ehbcorr/fac_shield(i)
9734 C     &      *2.0
9735            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
9736      &              rlocshield
9737      & +grad_shield_loc(m,ilist,i)*ehbcorr/fac_shield(i)
9738             gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
9739      &+rlocshield
9740            enddo
9741           enddo
9742           do ilist=1,ishield_list(j)
9743            iresshield=shield_list(ilist,j)
9744            do m=1,3
9745            rlocshield=grad_shield_side(m,ilist,j)*ehbcorr/fac_shield(j)
9746 C     &     *2.0
9747            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
9748      &              rlocshield
9749      & +grad_shield_loc(m,ilist,j)*ehbcorr/fac_shield(j)
9750            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
9751      &     +rlocshield
9752            enddo
9753           enddo
9754
9755           do ilist=1,ishield_list(k)
9756            iresshield=shield_list(ilist,k)
9757            do m=1,3
9758            rlocshield=grad_shield_side(m,ilist,k)*ehbcorr/fac_shield(k)
9759 C     &     *2.0
9760            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
9761      &              rlocshield
9762      & +grad_shield_loc(m,ilist,k)*ehbcorr/fac_shield(k)
9763            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
9764      &     +rlocshield
9765            enddo
9766           enddo
9767           do ilist=1,ishield_list(l)
9768            iresshield=shield_list(ilist,l)
9769            do m=1,3
9770            rlocshield=grad_shield_side(m,ilist,l)*ehbcorr/fac_shield(l)
9771 C     &     *2.0
9772            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
9773      &              rlocshield
9774      & +grad_shield_loc(m,ilist,l)*ehbcorr/fac_shield(l)
9775            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
9776      &     +rlocshield
9777            enddo
9778           enddo
9779 C          print *,gshieldx(m,iresshield)
9780           do m=1,3
9781             gshieldc_ec(m,i)=gshieldc_ec(m,i)+
9782      &              grad_shield(m,i)*ehbcorr/fac_shield(i)
9783             gshieldc_ec(m,j)=gshieldc_ec(m,j)+
9784      &              grad_shield(m,j)*ehbcorr/fac_shield(j)
9785             gshieldc_ec(m,i-1)=gshieldc_ec(m,i-1)+
9786      &              grad_shield(m,i)*ehbcorr/fac_shield(i)
9787             gshieldc_ec(m,j-1)=gshieldc_ec(m,j-1)+
9788      &              grad_shield(m,j)*ehbcorr/fac_shield(j)
9789
9790             gshieldc_ec(m,k)=gshieldc_ec(m,k)+
9791      &              grad_shield(m,k)*ehbcorr/fac_shield(k)
9792             gshieldc_ec(m,l)=gshieldc_ec(m,l)+
9793      &              grad_shield(m,l)*ehbcorr/fac_shield(l)
9794             gshieldc_ec(m,k-1)=gshieldc_ec(m,k-1)+
9795      &              grad_shield(m,k)*ehbcorr/fac_shield(k)
9796             gshieldc_ec(m,l-1)=gshieldc_ec(m,l-1)+
9797      &              grad_shield(m,l)*ehbcorr/fac_shield(l)
9798
9799            enddo
9800       endif
9801       endif
9802       return
9803       end
9804 #ifdef MOMENT
9805 C---------------------------------------------------------------------------
9806       subroutine dipole(i,j,jj)
9807       implicit real*8 (a-h,o-z)
9808       include 'DIMENSIONS'
9809       include 'COMMON.IOUNITS'
9810       include 'COMMON.CHAIN'
9811       include 'COMMON.FFIELD'
9812       include 'COMMON.DERIV'
9813       include 'COMMON.INTERACT'
9814       include 'COMMON.CONTACTS'
9815       include 'COMMON.TORSION'
9816       include 'COMMON.VAR'
9817       include 'COMMON.GEO'
9818       dimension dipi(2,2),dipj(2,2),dipderi(2),dipderj(2),auxvec(2),
9819      &  auxmat(2,2)
9820       iti1 = itortyp(itype(i+1))
9821       if (j.lt.nres-1) then
9822         itj1 = itype2loc(itype(j+1))
9823       else
9824         itj1=nloctyp
9825       endif
9826       do iii=1,2
9827         dipi(iii,1)=Ub2(iii,i)
9828         dipderi(iii)=Ub2der(iii,i)
9829         dipi(iii,2)=b1(iii,i+1)
9830         dipj(iii,1)=Ub2(iii,j)
9831         dipderj(iii)=Ub2der(iii,j)
9832         dipj(iii,2)=b1(iii,j+1)
9833       enddo
9834       kkk=0
9835       do iii=1,2
9836         call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
9837         do jjj=1,2
9838           kkk=kkk+1
9839           dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
9840         enddo
9841       enddo
9842       do kkk=1,5
9843         do lll=1,3
9844           mmm=0
9845           do iii=1,2
9846             call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),
9847      &        auxvec(1))
9848             do jjj=1,2
9849               mmm=mmm+1
9850               dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
9851             enddo
9852           enddo
9853         enddo
9854       enddo
9855       call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
9856       call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
9857       do iii=1,2
9858         dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
9859       enddo
9860       call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
9861       do iii=1,2
9862         dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
9863       enddo
9864       return
9865       end
9866 #endif
9867 C---------------------------------------------------------------------------
9868       subroutine calc_eello(i,j,k,l,jj,kk)
9869 C
9870 C This subroutine computes matrices and vectors needed to calculate
9871 C the fourth-, fifth-, and sixth-order local-electrostatic terms.
9872 C
9873       implicit real*8 (a-h,o-z)
9874       include 'DIMENSIONS'
9875       include 'COMMON.IOUNITS'
9876       include 'COMMON.CHAIN'
9877       include 'COMMON.DERIV'
9878       include 'COMMON.INTERACT'
9879       include 'COMMON.CONTACTS'
9880       include 'COMMON.TORSION'
9881       include 'COMMON.VAR'
9882       include 'COMMON.GEO'
9883       include 'COMMON.FFIELD'
9884       double precision aa1(2,2),aa2(2,2),aa1t(2,2),aa2t(2,2),
9885      &  aa1tder(2,2,3,5),aa2tder(2,2,3,5),auxmat(2,2)
9886       logical lprn
9887       common /kutas/ lprn
9888 cd      write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
9889 cd     & ' jj=',jj,' kk=',kk
9890 cd      if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
9891 cd      write (iout,*) "a_chujij",((a_chuj(iii,jjj,jj,i),iii=1,2),jjj=1,2)
9892 cd      write (iout,*) "a_chujkl",((a_chuj(iii,jjj,kk,k),iii=1,2),jjj=1,2)
9893       do iii=1,2
9894         do jjj=1,2
9895           aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
9896           aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
9897         enddo
9898       enddo
9899       call transpose2(aa1(1,1),aa1t(1,1))
9900       call transpose2(aa2(1,1),aa2t(1,1))
9901       do kkk=1,5
9902         do lll=1,3
9903           call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),
9904      &      aa1tder(1,1,lll,kkk))
9905           call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),
9906      &      aa2tder(1,1,lll,kkk))
9907         enddo
9908       enddo
9909       if (l.eq.j+1) then
9910 C parallel orientation of the two CA-CA-CA frames.
9911         if (i.gt.1) then
9912           iti=itype2loc(itype(i))
9913         else
9914           iti=nloctyp
9915         endif
9916         itk1=itype2loc(itype(k+1))
9917         itj=itype2loc(itype(j))
9918         if (l.lt.nres-1) then
9919           itl1=itype2loc(itype(l+1))
9920         else
9921           itl1=nloctyp
9922         endif
9923 C A1 kernel(j+1) A2T
9924 cd        do iii=1,2
9925 cd          write (iout,'(3f10.5,5x,3f10.5)')
9926 cd     &     (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
9927 cd        enddo
9928         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9929      &   aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),
9930      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
9931 C Following matrices are needed only for 6-th order cumulants
9932         IF (wcorr6.gt.0.0d0) THEN
9933         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9934      &   aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),
9935      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
9936         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9937      &   aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),
9938      &   Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
9939      &   ADtEAderx(1,1,1,1,1,1))
9940         lprn=.false.
9941         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9942      &   aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),
9943      &   DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
9944      &   ADtEA1derx(1,1,1,1,1,1))
9945         ENDIF
9946 C End 6-th order cumulants
9947 cd        lprn=.false.
9948 cd        if (lprn) then
9949 cd        write (2,*) 'In calc_eello6'
9950 cd        do iii=1,2
9951 cd          write (2,*) 'iii=',iii
9952 cd          do kkk=1,5
9953 cd            write (2,*) 'kkk=',kkk
9954 cd            do jjj=1,2
9955 cd              write (2,'(3(2f10.5),5x)')
9956 cd     &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
9957 cd            enddo
9958 cd          enddo
9959 cd        enddo
9960 cd        endif
9961         call transpose2(EUgder(1,1,k),auxmat(1,1))
9962         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
9963         call transpose2(EUg(1,1,k),auxmat(1,1))
9964         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
9965         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
9966 C AL 4/16/16: Derivatives of the quantitied related to matrices C, D, and E
9967 c    in theta; to be sriten later.
9968 c#ifdef NEWCORR
9969 c        call transpose2(gtEE(1,1,k),auxmat(1,1))
9970 c        call matmat2(auxmat(1,1),AEA(1,1,1),EAEAdert(1,1,1,1))
9971 c        call transpose2(EUg(1,1,k),auxmat(1,1))
9972 c        call matmat2(auxmat(1,1),AEAdert(1,1,1),EAEAdert(1,1,2,1))
9973 c#endif
9974         do iii=1,2
9975           do kkk=1,5
9976             do lll=1,3
9977               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
9978      &          EAEAderx(1,1,lll,kkk,iii,1))
9979             enddo
9980           enddo
9981         enddo
9982 C A1T kernel(i+1) A2
9983         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
9984      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),
9985      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
9986 C Following matrices are needed only for 6-th order cumulants
9987         IF (wcorr6.gt.0.0d0) THEN
9988         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
9989      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),
9990      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
9991         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
9992      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),
9993      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
9994      &   ADtEAderx(1,1,1,1,1,2))
9995         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
9996      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),
9997      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
9998      &   ADtEA1derx(1,1,1,1,1,2))
9999         ENDIF
10000 C End 6-th order cumulants
10001         call transpose2(EUgder(1,1,l),auxmat(1,1))
10002         call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
10003         call transpose2(EUg(1,1,l),auxmat(1,1))
10004         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
10005         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
10006         do iii=1,2
10007           do kkk=1,5
10008             do lll=1,3
10009               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
10010      &          EAEAderx(1,1,lll,kkk,iii,2))
10011             enddo
10012           enddo
10013         enddo
10014 C AEAb1 and AEAb2
10015 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
10016 C They are needed only when the fifth- or the sixth-order cumulants are
10017 C indluded.
10018         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
10019         call transpose2(AEA(1,1,1),auxmat(1,1))
10020         call matvec2(auxmat(1,1),b1(1,i),AEAb1(1,1,1))
10021         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
10022         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
10023         call transpose2(AEAderg(1,1,1),auxmat(1,1))
10024         call matvec2(auxmat(1,1),b1(1,i),AEAb1derg(1,1,1))
10025         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
10026         call matvec2(AEA(1,1,1),b1(1,k+1),AEAb1(1,2,1))
10027         call matvec2(AEAderg(1,1,1),b1(1,k+1),AEAb1derg(1,2,1))
10028         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
10029         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
10030         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
10031         call transpose2(AEA(1,1,2),auxmat(1,1))
10032         call matvec2(auxmat(1,1),b1(1,j),AEAb1(1,1,2))
10033         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
10034         call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
10035         call transpose2(AEAderg(1,1,2),auxmat(1,1))
10036         call matvec2(auxmat(1,1),b1(1,j),AEAb1derg(1,1,2))
10037         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
10038         call matvec2(AEA(1,1,2),b1(1,l+1),AEAb1(1,2,2))
10039         call matvec2(AEAderg(1,1,2),b1(1,l+1),AEAb1derg(1,2,2))
10040         call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
10041         call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
10042         call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
10043 C Calculate the Cartesian derivatives of the vectors.
10044         do iii=1,2
10045           do kkk=1,5
10046             do lll=1,3
10047               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
10048               call matvec2(auxmat(1,1),b1(1,i),
10049      &          AEAb1derx(1,lll,kkk,iii,1,1))
10050               call matvec2(auxmat(1,1),Ub2(1,i),
10051      &          AEAb2derx(1,lll,kkk,iii,1,1))
10052               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
10053      &          AEAb1derx(1,lll,kkk,iii,2,1))
10054               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
10055      &          AEAb2derx(1,lll,kkk,iii,2,1))
10056               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
10057               call matvec2(auxmat(1,1),b1(1,j),
10058      &          AEAb1derx(1,lll,kkk,iii,1,2))
10059               call matvec2(auxmat(1,1),Ub2(1,j),
10060      &          AEAb2derx(1,lll,kkk,iii,1,2))
10061               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,l+1),
10062      &          AEAb1derx(1,lll,kkk,iii,2,2))
10063               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),
10064      &          AEAb2derx(1,lll,kkk,iii,2,2))
10065             enddo
10066           enddo
10067         enddo
10068         ENDIF
10069 C End vectors
10070       else
10071 C Antiparallel orientation of the two CA-CA-CA frames.
10072         if (i.gt.1) then
10073           iti=itype2loc(itype(i))
10074         else
10075           iti=nloctyp
10076         endif
10077         itk1=itype2loc(itype(k+1))
10078         itl=itype2loc(itype(l))
10079         itj=itype2loc(itype(j))
10080         if (j.lt.nres-1) then
10081           itj1=itype2loc(itype(j+1))
10082         else
10083           itj1=nloctyp
10084         endif
10085 C A2 kernel(j-1)T A1T
10086         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
10087      &   aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),
10088      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
10089 C Following matrices are needed only for 6-th order cumulants
10090         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
10091      &     j.eq.i+4 .and. l.eq.i+3)) THEN
10092         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
10093      &   aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),
10094      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
10095         call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
10096      &   aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),
10097      &   Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
10098      &   ADtEAderx(1,1,1,1,1,1))
10099         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
10100      &   aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),
10101      &   DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
10102      &   ADtEA1derx(1,1,1,1,1,1))
10103         ENDIF
10104 C End 6-th order cumulants
10105         call transpose2(EUgder(1,1,k),auxmat(1,1))
10106         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
10107         call transpose2(EUg(1,1,k),auxmat(1,1))
10108         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
10109         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
10110         do iii=1,2
10111           do kkk=1,5
10112             do lll=1,3
10113               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
10114      &          EAEAderx(1,1,lll,kkk,iii,1))
10115             enddo
10116           enddo
10117         enddo
10118 C A2T kernel(i+1)T A1
10119         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
10120      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),
10121      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
10122 C Following matrices are needed only for 6-th order cumulants
10123         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
10124      &     j.eq.i+4 .and. l.eq.i+3)) THEN
10125         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
10126      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),
10127      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
10128         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
10129      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),
10130      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
10131      &   ADtEAderx(1,1,1,1,1,2))
10132         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
10133      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),
10134      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
10135      &   ADtEA1derx(1,1,1,1,1,2))
10136         ENDIF
10137 C End 6-th order cumulants
10138         call transpose2(EUgder(1,1,j),auxmat(1,1))
10139         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
10140         call transpose2(EUg(1,1,j),auxmat(1,1))
10141         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
10142         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
10143         do iii=1,2
10144           do kkk=1,5
10145             do lll=1,3
10146               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
10147      &          EAEAderx(1,1,lll,kkk,iii,2))
10148             enddo
10149           enddo
10150         enddo
10151 C AEAb1 and AEAb2
10152 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
10153 C They are needed only when the fifth- or the sixth-order cumulants are
10154 C indluded.
10155         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or.
10156      &    (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
10157         call transpose2(AEA(1,1,1),auxmat(1,1))
10158         call matvec2(auxmat(1,1),b1(1,i),AEAb1(1,1,1))
10159         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
10160         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
10161         call transpose2(AEAderg(1,1,1),auxmat(1,1))
10162         call matvec2(auxmat(1,1),b1(1,i),AEAb1derg(1,1,1))
10163         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
10164         call matvec2(AEA(1,1,1),b1(1,k+1),AEAb1(1,2,1))
10165         call matvec2(AEAderg(1,1,1),b1(1,k+1),AEAb1derg(1,2,1))
10166         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
10167         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
10168         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
10169         call transpose2(AEA(1,1,2),auxmat(1,1))
10170         call matvec2(auxmat(1,1),b1(1,j+1),AEAb1(1,1,2))
10171         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
10172         call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
10173         call transpose2(AEAderg(1,1,2),auxmat(1,1))
10174         call matvec2(auxmat(1,1),b1(1,l),AEAb1(1,1,2))
10175         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
10176         call matvec2(AEA(1,1,2),b1(1,j+1),AEAb1(1,2,2))
10177         call matvec2(AEAderg(1,1,2),b1(1,j+1),AEAb1derg(1,2,2))
10178         call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
10179         call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
10180         call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
10181 C Calculate the Cartesian derivatives of the vectors.
10182         do iii=1,2
10183           do kkk=1,5
10184             do lll=1,3
10185               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
10186               call matvec2(auxmat(1,1),b1(1,i),
10187      &          AEAb1derx(1,lll,kkk,iii,1,1))
10188               call matvec2(auxmat(1,1),Ub2(1,i),
10189      &          AEAb2derx(1,lll,kkk,iii,1,1))
10190               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
10191      &          AEAb1derx(1,lll,kkk,iii,2,1))
10192               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
10193      &          AEAb2derx(1,lll,kkk,iii,2,1))
10194               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
10195               call matvec2(auxmat(1,1),b1(1,l),
10196      &          AEAb1derx(1,lll,kkk,iii,1,2))
10197               call matvec2(auxmat(1,1),Ub2(1,l),
10198      &          AEAb2derx(1,lll,kkk,iii,1,2))
10199               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,j+1),
10200      &          AEAb1derx(1,lll,kkk,iii,2,2))
10201               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),
10202      &          AEAb2derx(1,lll,kkk,iii,2,2))
10203             enddo
10204           enddo
10205         enddo
10206         ENDIF
10207 C End vectors
10208       endif
10209       return
10210       end
10211 C---------------------------------------------------------------------------
10212       subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,
10213      &  KK,KKderg,AKA,AKAderg,AKAderx)
10214       implicit none
10215       integer nderg
10216       logical transp
10217       double precision aa1(2,2),aa2t(2,2),aa1derx(2,2,3,5),
10218      &  aa2tderx(2,2,3,5),KK(2,2),KKderg(2,2,nderg),AKA(2,2),
10219      &  AKAderg(2,2,nderg),AKAderx(2,2,3,5,2)
10220       integer iii,kkk,lll
10221       integer jjj,mmm
10222       logical lprn
10223       common /kutas/ lprn
10224       call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
10225       do iii=1,nderg
10226         call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,
10227      &    AKAderg(1,1,iii))
10228       enddo
10229 cd      if (lprn) write (2,*) 'In kernel'
10230       do kkk=1,5
10231 cd        if (lprn) write (2,*) 'kkk=',kkk
10232         do lll=1,3
10233           call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),
10234      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
10235 cd          if (lprn) then
10236 cd            write (2,*) 'lll=',lll
10237 cd            write (2,*) 'iii=1'
10238 cd            do jjj=1,2
10239 cd              write (2,'(3(2f10.5),5x)')
10240 cd     &        (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
10241 cd            enddo
10242 cd          endif
10243           call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),
10244      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
10245 cd          if (lprn) then
10246 cd            write (2,*) 'lll=',lll
10247 cd            write (2,*) 'iii=2'
10248 cd            do jjj=1,2
10249 cd              write (2,'(3(2f10.5),5x)')
10250 cd     &        (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
10251 cd            enddo
10252 cd          endif
10253         enddo
10254       enddo
10255       return
10256       end
10257 C---------------------------------------------------------------------------
10258       double precision function eello4(i,j,k,l,jj,kk)
10259       implicit real*8 (a-h,o-z)
10260       include 'DIMENSIONS'
10261       include 'COMMON.IOUNITS'
10262       include 'COMMON.CHAIN'
10263       include 'COMMON.DERIV'
10264       include 'COMMON.INTERACT'
10265       include 'COMMON.CONTACTS'
10266       include 'COMMON.TORSION'
10267       include 'COMMON.VAR'
10268       include 'COMMON.GEO'
10269       double precision pizda(2,2),ggg1(3),ggg2(3)
10270 cd      if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
10271 cd        eello4=0.0d0
10272 cd        return
10273 cd      endif
10274 cd      print *,'eello4:',i,j,k,l,jj,kk
10275 cd      write (2,*) 'i',i,' j',j,' k',k,' l',l
10276 cd      call checkint4(i,j,k,l,jj,kk,eel4_num)
10277 cold      eij=facont_hb(jj,i)
10278 cold      ekl=facont_hb(kk,k)
10279 cold      ekont=eij*ekl
10280       eel4=-EAEA(1,1,1)-EAEA(2,2,1)
10281 cd      eel41=-EAEA(1,1,2)-EAEA(2,2,2)
10282       gcorr_loc(k-1)=gcorr_loc(k-1)
10283      &   -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
10284       if (l.eq.j+1) then
10285         gcorr_loc(l-1)=gcorr_loc(l-1)
10286      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
10287 C Al 4/16/16: Derivatives in theta, to be added later.
10288 c#ifdef NEWCORR
10289 c        gcorr_loc(nphi+l-1)=gcorr_loc(nphi+l-1)
10290 c     &     -ekont*(EAEAdert(1,1,2,1)+EAEAdert(2,2,2,1))
10291 c#endif
10292       else
10293         gcorr_loc(j-1)=gcorr_loc(j-1)
10294      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
10295 c#ifdef NEWCORR
10296 c        gcorr_loc(nphi+j-1)=gcorr_loc(nphi+j-1)
10297 c     &     -ekont*(EAEAdert(1,1,2,1)+EAEAdert(2,2,2,1))
10298 c#endif
10299       endif
10300       do iii=1,2
10301         do kkk=1,5
10302           do lll=1,3
10303             derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1)
10304      &                        -EAEAderx(2,2,lll,kkk,iii,1)
10305 cd            derx(lll,kkk,iii)=0.0d0
10306           enddo
10307         enddo
10308       enddo
10309 cd      gcorr_loc(l-1)=0.0d0
10310 cd      gcorr_loc(j-1)=0.0d0
10311 cd      gcorr_loc(k-1)=0.0d0
10312 cd      eel4=1.0d0
10313 cd      write (iout,*)'Contacts have occurred for peptide groups',
10314 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l,
10315 cd     &  ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
10316       if (j.lt.nres-1) then
10317         j1=j+1
10318         j2=j-1
10319       else
10320         j1=j-1
10321         j2=j-2
10322       endif
10323       if (l.lt.nres-1) then
10324         l1=l+1
10325         l2=l-1
10326       else
10327         l1=l-1
10328         l2=l-2
10329       endif
10330       do ll=1,3
10331 cgrad        ggg1(ll)=eel4*g_contij(ll,1)
10332 cgrad        ggg2(ll)=eel4*g_contij(ll,2)
10333         glongij=eel4*g_contij(ll,1)+ekont*derx(ll,1,1)
10334         glongkl=eel4*g_contij(ll,2)+ekont*derx(ll,1,2)
10335 cgrad        ghalf=0.5d0*ggg1(ll)
10336         gradcorr(ll,i)=gradcorr(ll,i)+ekont*derx(ll,2,1)
10337         gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
10338         gradcorr(ll,j)=gradcorr(ll,j)+ekont*derx(ll,4,1)
10339         gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
10340         gradcorr_long(ll,j)=gradcorr_long(ll,j)+glongij
10341         gradcorr_long(ll,i)=gradcorr_long(ll,i)-glongij
10342 cgrad        ghalf=0.5d0*ggg2(ll)
10343         gradcorr(ll,k)=gradcorr(ll,k)+ekont*derx(ll,2,2)
10344         gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
10345         gradcorr(ll,l)=gradcorr(ll,l)+ekont*derx(ll,4,2)
10346         gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
10347         gradcorr_long(ll,l)=gradcorr_long(ll,l)+glongkl
10348         gradcorr_long(ll,k)=gradcorr_long(ll,k)-glongkl
10349       enddo
10350 cgrad      do m=i+1,j-1
10351 cgrad        do ll=1,3
10352 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
10353 cgrad        enddo
10354 cgrad      enddo
10355 cgrad      do m=k+1,l-1
10356 cgrad        do ll=1,3
10357 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
10358 cgrad        enddo
10359 cgrad      enddo
10360 cgrad      do m=i+2,j2
10361 cgrad        do ll=1,3
10362 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
10363 cgrad        enddo
10364 cgrad      enddo
10365 cgrad      do m=k+2,l2
10366 cgrad        do ll=1,3
10367 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
10368 cgrad        enddo
10369 cgrad      enddo
10370 cd      do iii=1,nres-3
10371 cd        write (2,*) iii,gcorr_loc(iii)
10372 cd      enddo
10373       eello4=ekont*eel4
10374 cd      write (2,*) 'ekont',ekont
10375 cd      write (iout,*) 'eello4',ekont*eel4
10376       return
10377       end
10378 C---------------------------------------------------------------------------
10379       double precision function eello5(i,j,k,l,jj,kk)
10380       implicit real*8 (a-h,o-z)
10381       include 'DIMENSIONS'
10382       include 'COMMON.IOUNITS'
10383       include 'COMMON.CHAIN'
10384       include 'COMMON.DERIV'
10385       include 'COMMON.INTERACT'
10386       include 'COMMON.CONTACTS'
10387       include 'COMMON.TORSION'
10388       include 'COMMON.VAR'
10389       include 'COMMON.GEO'
10390       double precision pizda(2,2),auxmat(2,2),auxmat1(2,2),vv(2)
10391       double precision ggg1(3),ggg2(3)
10392 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10393 C                                                                              C
10394 C                            Parallel chains                                   C
10395 C                                                                              C
10396 C          o             o                   o             o                   C
10397 C         /l\           / \             \   / \           / \   /              C
10398 C        /   \         /   \             \ /   \         /   \ /               C
10399 C       j| o |l1       | o |              o| o |         | o |o                C
10400 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
10401 C      \i/   \         /   \ /             /   \         /   \                 C
10402 C       o    k1             o                                                  C
10403 C         (I)          (II)                (III)          (IV)                 C
10404 C                                                                              C
10405 C      eello5_1        eello5_2            eello5_3       eello5_4             C
10406 C                                                                              C
10407 C                            Antiparallel chains                               C
10408 C                                                                              C
10409 C          o             o                   o             o                   C
10410 C         /j\           / \             \   / \           / \   /              C
10411 C        /   \         /   \             \ /   \         /   \ /               C
10412 C      j1| o |l        | o |              o| o |         | o |o                C
10413 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
10414 C      \i/   \         /   \ /             /   \         /   \                 C
10415 C       o     k1            o                                                  C
10416 C         (I)          (II)                (III)          (IV)                 C
10417 C                                                                              C
10418 C      eello5_1        eello5_2            eello5_3       eello5_4             C
10419 C                                                                              C
10420 C o denotes a local interaction, vertical lines an electrostatic interaction.  C
10421 C                                                                              C
10422 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10423 cd      if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
10424 cd        eello5=0.0d0
10425 cd        return
10426 cd      endif
10427 cd      write (iout,*)
10428 cd     &   'EELLO5: Contacts have occurred for peptide groups',i,j,
10429 cd     &   ' and',k,l
10430       itk=itype2loc(itype(k))
10431       itl=itype2loc(itype(l))
10432       itj=itype2loc(itype(j))
10433       eello5_1=0.0d0
10434       eello5_2=0.0d0
10435       eello5_3=0.0d0
10436       eello5_4=0.0d0
10437 cd      call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
10438 cd     &   eel5_3_num,eel5_4_num)
10439       do iii=1,2
10440         do kkk=1,5
10441           do lll=1,3
10442             derx(lll,kkk,iii)=0.0d0
10443           enddo
10444         enddo
10445       enddo
10446 cd      eij=facont_hb(jj,i)
10447 cd      ekl=facont_hb(kk,k)
10448 cd      ekont=eij*ekl
10449 cd      write (iout,*)'Contacts have occurred for peptide groups',
10450 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l
10451 cd      goto 1111
10452 C Contribution from the graph I.
10453 cd      write (2,*) 'AEA  ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
10454 cd      write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
10455       call transpose2(EUg(1,1,k),auxmat(1,1))
10456       call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
10457       vv(1)=pizda(1,1)-pizda(2,2)
10458       vv(2)=pizda(1,2)+pizda(2,1)
10459       eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k))
10460      & +0.5d0*scalar2(vv(1),Dtobr2(1,i))
10461 C Explicit gradient in virtual-dihedral angles.
10462       if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1)
10463      & +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k))
10464      & +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
10465       call transpose2(EUgder(1,1,k),auxmat1(1,1))
10466       call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
10467       vv(1)=pizda(1,1)-pizda(2,2)
10468       vv(2)=pizda(1,2)+pizda(2,1)
10469       g_corr5_loc(k-1)=g_corr5_loc(k-1)
10470      & +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k))
10471      & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
10472       call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
10473       vv(1)=pizda(1,1)-pizda(2,2)
10474       vv(2)=pizda(1,2)+pizda(2,1)
10475       if (l.eq.j+1) then
10476         if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1)
10477      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
10478      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
10479       else
10480         if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1)
10481      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
10482      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
10483       endif
10484 C Cartesian gradient
10485       do iii=1,2
10486         do kkk=1,5
10487           do lll=1,3
10488             call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),
10489      &        pizda(1,1))
10490             vv(1)=pizda(1,1)-pizda(2,2)
10491             vv(2)=pizda(1,2)+pizda(2,1)
10492             derx(lll,kkk,iii)=derx(lll,kkk,iii)
10493      &       +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k))
10494      &       +0.5d0*scalar2(vv(1),Dtobr2(1,i))
10495           enddo
10496         enddo
10497       enddo
10498 c      goto 1112
10499 c1111  continue
10500 C Contribution from graph II
10501       call transpose2(EE(1,1,k),auxmat(1,1))
10502       call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
10503       vv(1)=pizda(1,1)+pizda(2,2)
10504       vv(2)=pizda(2,1)-pizda(1,2)
10505       eello5_2=scalar2(AEAb1(1,2,1),b1(1,k))
10506      & -0.5d0*scalar2(vv(1),Ctobr(1,k))
10507 C Explicit gradient in virtual-dihedral angles.
10508       g_corr5_loc(k-1)=g_corr5_loc(k-1)
10509      & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
10510       call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
10511       vv(1)=pizda(1,1)+pizda(2,2)
10512       vv(2)=pizda(2,1)-pizda(1,2)
10513       if (l.eq.j+1) then
10514         g_corr5_loc(l-1)=g_corr5_loc(l-1)
10515      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,k))
10516      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
10517       else
10518         g_corr5_loc(j-1)=g_corr5_loc(j-1)
10519      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,k))
10520      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
10521       endif
10522 C Cartesian gradient
10523       do iii=1,2
10524         do kkk=1,5
10525           do lll=1,3
10526             call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
10527      &        pizda(1,1))
10528             vv(1)=pizda(1,1)+pizda(2,2)
10529             vv(2)=pizda(2,1)-pizda(1,2)
10530             derx(lll,kkk,iii)=derx(lll,kkk,iii)
10531      &       +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,k))
10532      &       -0.5d0*scalar2(vv(1),Ctobr(1,k))
10533           enddo
10534         enddo
10535       enddo
10536 cd      goto 1112
10537 cd1111  continue
10538       if (l.eq.j+1) then
10539 cd        goto 1110
10540 C Parallel orientation
10541 C Contribution from graph III
10542         call transpose2(EUg(1,1,l),auxmat(1,1))
10543         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
10544         vv(1)=pizda(1,1)-pizda(2,2)
10545         vv(2)=pizda(1,2)+pizda(2,1)
10546         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l))
10547      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j))
10548 C Explicit gradient in virtual-dihedral angles.
10549         g_corr5_loc(j-1)=g_corr5_loc(j-1)
10550      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l))
10551      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
10552         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
10553         vv(1)=pizda(1,1)-pizda(2,2)
10554         vv(2)=pizda(1,2)+pizda(2,1)
10555         g_corr5_loc(k-1)=g_corr5_loc(k-1)
10556      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l))
10557      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
10558         call transpose2(EUgder(1,1,l),auxmat1(1,1))
10559         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
10560         vv(1)=pizda(1,1)-pizda(2,2)
10561         vv(2)=pizda(1,2)+pizda(2,1)
10562         g_corr5_loc(l-1)=g_corr5_loc(l-1)
10563      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l))
10564      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
10565 C Cartesian gradient
10566         do iii=1,2
10567           do kkk=1,5
10568             do lll=1,3
10569               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
10570      &          pizda(1,1))
10571               vv(1)=pizda(1,1)-pizda(2,2)
10572               vv(2)=pizda(1,2)+pizda(2,1)
10573               derx(lll,kkk,iii)=derx(lll,kkk,iii)
10574      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l))
10575      &         +0.5d0*scalar2(vv(1),Dtobr2(1,j))
10576             enddo
10577           enddo
10578         enddo
10579 cd        goto 1112
10580 C Contribution from graph IV
10581 cd1110    continue
10582         call transpose2(EE(1,1,l),auxmat(1,1))
10583         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
10584         vv(1)=pizda(1,1)+pizda(2,2)
10585         vv(2)=pizda(2,1)-pizda(1,2)
10586         eello5_4=scalar2(AEAb1(1,2,2),b1(1,l))
10587      &   -0.5d0*scalar2(vv(1),Ctobr(1,l))
10588 C Explicit gradient in virtual-dihedral angles.
10589         g_corr5_loc(l-1)=g_corr5_loc(l-1)
10590      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
10591         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
10592         vv(1)=pizda(1,1)+pizda(2,2)
10593         vv(2)=pizda(2,1)-pizda(1,2)
10594         g_corr5_loc(k-1)=g_corr5_loc(k-1)
10595      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,l))
10596      &   -0.5d0*scalar2(vv(1),Ctobr(1,l)))
10597 C Cartesian gradient
10598         do iii=1,2
10599           do kkk=1,5
10600             do lll=1,3
10601               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
10602      &          pizda(1,1))
10603               vv(1)=pizda(1,1)+pizda(2,2)
10604               vv(2)=pizda(2,1)-pizda(1,2)
10605               derx(lll,kkk,iii)=derx(lll,kkk,iii)
10606      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,l))
10607      &         -0.5d0*scalar2(vv(1),Ctobr(1,l))
10608             enddo
10609           enddo
10610         enddo
10611       else
10612 C Antiparallel orientation
10613 C Contribution from graph III
10614 c        goto 1110
10615         call transpose2(EUg(1,1,j),auxmat(1,1))
10616         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
10617         vv(1)=pizda(1,1)-pizda(2,2)
10618         vv(2)=pizda(1,2)+pizda(2,1)
10619         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j))
10620      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l))
10621 C Explicit gradient in virtual-dihedral angles.
10622         g_corr5_loc(l-1)=g_corr5_loc(l-1)
10623      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j))
10624      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
10625         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
10626         vv(1)=pizda(1,1)-pizda(2,2)
10627         vv(2)=pizda(1,2)+pizda(2,1)
10628         g_corr5_loc(k-1)=g_corr5_loc(k-1)
10629      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j))
10630      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
10631         call transpose2(EUgder(1,1,j),auxmat1(1,1))
10632         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
10633         vv(1)=pizda(1,1)-pizda(2,2)
10634         vv(2)=pizda(1,2)+pizda(2,1)
10635         g_corr5_loc(j-1)=g_corr5_loc(j-1)
10636      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j))
10637      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
10638 C Cartesian gradient
10639         do iii=1,2
10640           do kkk=1,5
10641             do lll=1,3
10642               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
10643      &          pizda(1,1))
10644               vv(1)=pizda(1,1)-pizda(2,2)
10645               vv(2)=pizda(1,2)+pizda(2,1)
10646               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
10647      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j))
10648      &         +0.5d0*scalar2(vv(1),Dtobr2(1,l))
10649             enddo
10650           enddo
10651         enddo
10652 cd        goto 1112
10653 C Contribution from graph IV
10654 1110    continue
10655         call transpose2(EE(1,1,j),auxmat(1,1))
10656         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
10657         vv(1)=pizda(1,1)+pizda(2,2)
10658         vv(2)=pizda(2,1)-pizda(1,2)
10659         eello5_4=scalar2(AEAb1(1,2,2),b1(1,j))
10660      &   -0.5d0*scalar2(vv(1),Ctobr(1,j))
10661 C Explicit gradient in virtual-dihedral angles.
10662         g_corr5_loc(j-1)=g_corr5_loc(j-1)
10663      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
10664         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
10665         vv(1)=pizda(1,1)+pizda(2,2)
10666         vv(2)=pizda(2,1)-pizda(1,2)
10667         g_corr5_loc(k-1)=g_corr5_loc(k-1)
10668      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,j))
10669      &   -0.5d0*scalar2(vv(1),Ctobr(1,j)))
10670 C Cartesian gradient
10671         do iii=1,2
10672           do kkk=1,5
10673             do lll=1,3
10674               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
10675      &          pizda(1,1))
10676               vv(1)=pizda(1,1)+pizda(2,2)
10677               vv(2)=pizda(2,1)-pizda(1,2)
10678               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
10679      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,j))
10680      &         -0.5d0*scalar2(vv(1),Ctobr(1,j))
10681             enddo
10682           enddo
10683         enddo
10684       endif
10685 1112  continue
10686       eel5=eello5_1+eello5_2+eello5_3+eello5_4
10687 cd      if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
10688 cd        write (2,*) 'ijkl',i,j,k,l
10689 cd        write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
10690 cd     &     ' eello5_3',eello5_3,' eello5_4',eello5_4
10691 cd      endif
10692 cd      write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
10693 cd      write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
10694 cd      write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
10695 cd      write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
10696       if (j.lt.nres-1) then
10697         j1=j+1
10698         j2=j-1
10699       else
10700         j1=j-1
10701         j2=j-2
10702       endif
10703       if (l.lt.nres-1) then
10704         l1=l+1
10705         l2=l-1
10706       else
10707         l1=l-1
10708         l2=l-2
10709       endif
10710 cd      eij=1.0d0
10711 cd      ekl=1.0d0
10712 cd      ekont=1.0d0
10713 cd      write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
10714 C 2/11/08 AL Gradients over DC's connecting interacting sites will be
10715 C        summed up outside the subrouine as for the other subroutines
10716 C        handling long-range interactions. The old code is commented out
10717 C        with "cgrad" to keep track of changes.
10718       do ll=1,3
10719 cgrad        ggg1(ll)=eel5*g_contij(ll,1)
10720 cgrad        ggg2(ll)=eel5*g_contij(ll,2)
10721         gradcorr5ij=eel5*g_contij(ll,1)+ekont*derx(ll,1,1)
10722         gradcorr5kl=eel5*g_contij(ll,2)+ekont*derx(ll,1,2)
10723 c        write (iout,'(a,3i3,a,5f8.3,2i3,a,5f8.3,a,f8.3)')
10724 c     &   "ecorr5",ll,i,j," derx",derx(ll,2,1),derx(ll,3,1),derx(ll,4,1),
10725 c     &   derx(ll,5,1),k,l," derx",derx(ll,2,2),derx(ll,3,2),
10726 c     &   derx(ll,4,2),derx(ll,5,2)," ekont",ekont
10727 c        write (iout,'(a,3i3,a,3f8.3,2i3,a,3f8.3)')
10728 c     &   "ecorr5",ll,i,j," gradcorr5",g_contij(ll,1),derx(ll,1,1),
10729 c     &   gradcorr5ij,
10730 c     &   k,l," gradcorr5",g_contij(ll,2),derx(ll,1,2),gradcorr5kl
10731 cold        ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
10732 cgrad        ghalf=0.5d0*ggg1(ll)
10733 cd        ghalf=0.0d0
10734         gradcorr5(ll,i)=gradcorr5(ll,i)+ekont*derx(ll,2,1)
10735         gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
10736         gradcorr5(ll,j)=gradcorr5(ll,j)+ekont*derx(ll,4,1)
10737         gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
10738         gradcorr5_long(ll,j)=gradcorr5_long(ll,j)+gradcorr5ij
10739         gradcorr5_long(ll,i)=gradcorr5_long(ll,i)-gradcorr5ij
10740 cold        ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
10741 cgrad        ghalf=0.5d0*ggg2(ll)
10742 cd        ghalf=0.0d0
10743         gradcorr5(ll,k)=gradcorr5(ll,k)+ekont*derx(ll,2,2)
10744         gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
10745         gradcorr5(ll,l)=gradcorr5(ll,l)+ekont*derx(ll,4,2)
10746         gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
10747         gradcorr5_long(ll,l)=gradcorr5_long(ll,l)+gradcorr5kl
10748         gradcorr5_long(ll,k)=gradcorr5_long(ll,k)-gradcorr5kl
10749       enddo
10750 cd      goto 1112
10751 cgrad      do m=i+1,j-1
10752 cgrad        do ll=1,3
10753 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
10754 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
10755 cgrad        enddo
10756 cgrad      enddo
10757 cgrad      do m=k+1,l-1
10758 cgrad        do ll=1,3
10759 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
10760 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
10761 cgrad        enddo
10762 cgrad      enddo
10763 c1112  continue
10764 cgrad      do m=i+2,j2
10765 cgrad        do ll=1,3
10766 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
10767 cgrad        enddo
10768 cgrad      enddo
10769 cgrad      do m=k+2,l2
10770 cgrad        do ll=1,3
10771 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
10772 cgrad        enddo
10773 cgrad      enddo
10774 cd      do iii=1,nres-3
10775 cd        write (2,*) iii,g_corr5_loc(iii)
10776 cd      enddo
10777       eello5=ekont*eel5
10778 cd      write (2,*) 'ekont',ekont
10779 cd      write (iout,*) 'eello5',ekont*eel5
10780       return
10781       end
10782 c--------------------------------------------------------------------------
10783       double precision function eello6(i,j,k,l,jj,kk)
10784       implicit real*8 (a-h,o-z)
10785       include 'DIMENSIONS'
10786       include 'COMMON.IOUNITS'
10787       include 'COMMON.CHAIN'
10788       include 'COMMON.DERIV'
10789       include 'COMMON.INTERACT'
10790       include 'COMMON.CONTACTS'
10791       include 'COMMON.TORSION'
10792       include 'COMMON.VAR'
10793       include 'COMMON.GEO'
10794       include 'COMMON.FFIELD'
10795       double precision ggg1(3),ggg2(3)
10796 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
10797 cd        eello6=0.0d0
10798 cd        return
10799 cd      endif
10800 cd      write (iout,*)
10801 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
10802 cd     &   ' and',k,l
10803       eello6_1=0.0d0
10804       eello6_2=0.0d0
10805       eello6_3=0.0d0
10806       eello6_4=0.0d0
10807       eello6_5=0.0d0
10808       eello6_6=0.0d0
10809 cd      call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
10810 cd     &   eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
10811       do iii=1,2
10812         do kkk=1,5
10813           do lll=1,3
10814             derx(lll,kkk,iii)=0.0d0
10815           enddo
10816         enddo
10817       enddo
10818 cd      eij=facont_hb(jj,i)
10819 cd      ekl=facont_hb(kk,k)
10820 cd      ekont=eij*ekl
10821 cd      eij=1.0d0
10822 cd      ekl=1.0d0
10823 cd      ekont=1.0d0
10824       if (l.eq.j+1) then
10825         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
10826         eello6_2=eello6_graph1(j,i,l,k,2,.false.)
10827         eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
10828         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
10829         eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
10830         eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
10831       else
10832         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
10833         eello6_2=eello6_graph1(l,k,j,i,2,.true.)
10834         eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
10835         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
10836         if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
10837           eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
10838         else
10839           eello6_5=0.0d0
10840         endif
10841         eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
10842       endif
10843 C If turn contributions are considered, they will be handled separately.
10844       eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
10845 cd      write(iout,*) 'eello6_1',eello6_1!,' eel6_1_num',16*eel6_1_num
10846 cd      write(iout,*) 'eello6_2',eello6_2!,' eel6_2_num',16*eel6_2_num
10847 cd      write(iout,*) 'eello6_3',eello6_3!,' eel6_3_num',16*eel6_3_num
10848 cd      write(iout,*) 'eello6_4',eello6_4!,' eel6_4_num',16*eel6_4_num
10849 cd      write(iout,*) 'eello6_5',eello6_5!,' eel6_5_num',16*eel6_5_num
10850 cd      write(iout,*) 'eello6_6',eello6_6!,' eel6_6_num',16*eel6_6_num
10851 cd      goto 1112
10852       if (j.lt.nres-1) then
10853         j1=j+1
10854         j2=j-1
10855       else
10856         j1=j-1
10857         j2=j-2
10858       endif
10859       if (l.lt.nres-1) then
10860         l1=l+1
10861         l2=l-1
10862       else
10863         l1=l-1
10864         l2=l-2
10865       endif
10866       do ll=1,3
10867 cgrad        ggg1(ll)=eel6*g_contij(ll,1)
10868 cgrad        ggg2(ll)=eel6*g_contij(ll,2)
10869 cold        ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
10870 cgrad        ghalf=0.5d0*ggg1(ll)
10871 cd        ghalf=0.0d0
10872         gradcorr6ij=eel6*g_contij(ll,1)+ekont*derx(ll,1,1)
10873         gradcorr6kl=eel6*g_contij(ll,2)+ekont*derx(ll,1,2)
10874         gradcorr6(ll,i)=gradcorr6(ll,i)+ekont*derx(ll,2,1)
10875         gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
10876         gradcorr6(ll,j)=gradcorr6(ll,j)+ekont*derx(ll,4,1)
10877         gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
10878         gradcorr6_long(ll,j)=gradcorr6_long(ll,j)+gradcorr6ij
10879         gradcorr6_long(ll,i)=gradcorr6_long(ll,i)-gradcorr6ij
10880 cgrad        ghalf=0.5d0*ggg2(ll)
10881 cold        ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
10882 cd        ghalf=0.0d0
10883         gradcorr6(ll,k)=gradcorr6(ll,k)+ekont*derx(ll,2,2)
10884         gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
10885         gradcorr6(ll,l)=gradcorr6(ll,l)+ekont*derx(ll,4,2)
10886         gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
10887         gradcorr6_long(ll,l)=gradcorr6_long(ll,l)+gradcorr6kl
10888         gradcorr6_long(ll,k)=gradcorr6_long(ll,k)-gradcorr6kl
10889       enddo
10890 cd      goto 1112
10891 cgrad      do m=i+1,j-1
10892 cgrad        do ll=1,3
10893 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
10894 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
10895 cgrad        enddo
10896 cgrad      enddo
10897 cgrad      do m=k+1,l-1
10898 cgrad        do ll=1,3
10899 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
10900 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
10901 cgrad        enddo
10902 cgrad      enddo
10903 cgrad1112  continue
10904 cgrad      do m=i+2,j2
10905 cgrad        do ll=1,3
10906 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
10907 cgrad        enddo
10908 cgrad      enddo
10909 cgrad      do m=k+2,l2
10910 cgrad        do ll=1,3
10911 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
10912 cgrad        enddo
10913 cgrad      enddo
10914 cd      do iii=1,nres-3
10915 cd        write (2,*) iii,g_corr6_loc(iii)
10916 cd      enddo
10917       eello6=ekont*eel6
10918 cd      write (2,*) 'ekont',ekont
10919 cd      write (iout,*) 'eello6',ekont*eel6
10920       return
10921       end
10922 c--------------------------------------------------------------------------
10923       double precision function eello6_graph1(i,j,k,l,imat,swap)
10924       implicit real*8 (a-h,o-z)
10925       include 'DIMENSIONS'
10926       include 'COMMON.IOUNITS'
10927       include 'COMMON.CHAIN'
10928       include 'COMMON.DERIV'
10929       include 'COMMON.INTERACT'
10930       include 'COMMON.CONTACTS'
10931       include 'COMMON.TORSION'
10932       include 'COMMON.VAR'
10933       include 'COMMON.GEO'
10934       double precision vv(2),vv1(2),pizda(2,2),auxmat(2,2),pizda1(2,2)
10935       logical swap
10936       logical lprn
10937       common /kutas/ lprn
10938 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10939 C                                                                              C
10940 C      Parallel       Antiparallel                                             C
10941 C                                                                              C
10942 C          o             o                                                     C
10943 C         /l\           /j\                                                    C
10944 C        /   \         /   \                                                   C
10945 C       /| o |         | o |\                                                  C
10946 C     \ j|/k\|  /   \  |/k\|l /                                                C
10947 C      \ /   \ /     \ /   \ /                                                 C
10948 C       o     o       o     o                                                  C
10949 C       i             i                                                        C
10950 C                                                                              C
10951 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10952       itk=itype2loc(itype(k))
10953       s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
10954       s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
10955       s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
10956       call transpose2(EUgC(1,1,k),auxmat(1,1))
10957       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
10958       vv1(1)=pizda1(1,1)-pizda1(2,2)
10959       vv1(2)=pizda1(1,2)+pizda1(2,1)
10960       s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
10961       vv(1)=AEAb1(1,2,imat)*b1(1,k)-AEAb1(2,2,imat)*b1(2,k)
10962       vv(2)=AEAb1(1,2,imat)*b1(2,k)+AEAb1(2,2,imat)*b1(1,k)
10963       s5=scalar2(vv(1),Dtobr2(1,i))
10964 cd      write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
10965       eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
10966       if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1)
10967      & -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i))
10968      & -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k))
10969      & +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k))
10970      & +0.5d0*scalar2(vv1(1),Dtobr2der(1,i))
10971      & +scalar2(vv(1),Dtobr2der(1,i)))
10972       call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
10973       vv1(1)=pizda1(1,1)-pizda1(2,2)
10974       vv1(2)=pizda1(1,2)+pizda1(2,1)
10975       vv(1)=AEAb1derg(1,2,imat)*b1(1,k)-AEAb1derg(2,2,imat)*b1(2,k)
10976       vv(2)=AEAb1derg(1,2,imat)*b1(2,k)+AEAb1derg(2,2,imat)*b1(1,k)
10977       if (l.eq.j+1) then
10978         g_corr6_loc(l-1)=g_corr6_loc(l-1)
10979      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
10980      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
10981      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
10982      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
10983       else
10984         g_corr6_loc(j-1)=g_corr6_loc(j-1)
10985      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
10986      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
10987      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
10988      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
10989       endif
10990       call transpose2(EUgCder(1,1,k),auxmat(1,1))
10991       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
10992       vv1(1)=pizda1(1,1)-pizda1(2,2)
10993       vv1(2)=pizda1(1,2)+pizda1(2,1)
10994       if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1)
10995      & +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k))
10996      & +scalar2(AEAb2(1,1,imat),CUgb2der(1,k))
10997      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
10998       do iii=1,2
10999         if (swap) then
11000           ind=3-iii
11001         else
11002           ind=iii
11003         endif
11004         do kkk=1,5
11005           do lll=1,3
11006             s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
11007             s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
11008             s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
11009             call transpose2(EUgC(1,1,k),auxmat(1,1))
11010             call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
11011      &        pizda1(1,1))
11012             vv1(1)=pizda1(1,1)-pizda1(2,2)
11013             vv1(2)=pizda1(1,2)+pizda1(2,1)
11014             s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
11015             vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,k)
11016      &       -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,k)
11017             vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,k)
11018      &       +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,k)
11019             s5=scalar2(vv(1),Dtobr2(1,i))
11020             derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
11021           enddo
11022         enddo
11023       enddo
11024       return
11025       end
11026 c----------------------------------------------------------------------------
11027       double precision function eello6_graph2(i,j,k,l,jj,kk,swap)
11028       implicit real*8 (a-h,o-z)
11029       include 'DIMENSIONS'
11030       include 'COMMON.IOUNITS'
11031       include 'COMMON.CHAIN'
11032       include 'COMMON.DERIV'
11033       include 'COMMON.INTERACT'
11034       include 'COMMON.CONTACTS'
11035       include 'COMMON.TORSION'
11036       include 'COMMON.VAR'
11037       include 'COMMON.GEO'
11038       logical swap
11039       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
11040      & auxvec1(2),auxvec2(2),auxmat1(2,2)
11041       logical lprn
11042       common /kutas/ lprn
11043 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
11044 C                                                                              C
11045 C      Parallel       Antiparallel                                             C
11046 C                                                                              C
11047 C          o             o                                                     C
11048 C     \   /l\           /j\   /                                                C
11049 C      \ /   \         /   \ /                                                 C
11050 C       o| o |         | o |o                                                  C
11051 C     \ j|/k\|      \  |/k\|l                                                  C
11052 C      \ /   \       \ /   \                                                   C
11053 C       o             o                                                        C
11054 C       i             i                                                        C
11055 C                                                                              C
11056 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
11057 cd      write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
11058 C AL 7/4/01 s1 would occur in the sixth-order moment,
11059 C           but not in a cluster cumulant
11060 #ifdef MOMENT
11061       s1=dip(1,jj,i)*dip(1,kk,k)
11062 #endif
11063       call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
11064       s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
11065       call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
11066       s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
11067       call transpose2(EUg(1,1,k),auxmat(1,1))
11068       call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
11069       vv(1)=pizda(1,1)-pizda(2,2)
11070       vv(2)=pizda(1,2)+pizda(2,1)
11071       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
11072 cd      write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
11073 #ifdef MOMENT
11074       eello6_graph2=-(s1+s2+s3+s4)
11075 #else
11076       eello6_graph2=-(s2+s3+s4)
11077 #endif
11078 c      eello6_graph2=-s3
11079 C Derivatives in gamma(i-1)
11080       if (i.gt.1) then
11081 #ifdef MOMENT
11082         s1=dipderg(1,jj,i)*dip(1,kk,k)
11083 #endif
11084         s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
11085         call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
11086         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
11087         s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
11088 #ifdef MOMENT
11089         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
11090 #else
11091         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
11092 #endif
11093 c        g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
11094       endif
11095 C Derivatives in gamma(k-1)
11096 #ifdef MOMENT
11097       s1=dip(1,jj,i)*dipderg(1,kk,k)
11098 #endif
11099       call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
11100       s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
11101       call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
11102       s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
11103       call transpose2(EUgder(1,1,k),auxmat1(1,1))
11104       call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
11105       vv(1)=pizda(1,1)-pizda(2,2)
11106       vv(2)=pizda(1,2)+pizda(2,1)
11107       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
11108 #ifdef MOMENT
11109       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
11110 #else
11111       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
11112 #endif
11113 c      g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
11114 C Derivatives in gamma(j-1) or gamma(l-1)
11115       if (j.gt.1) then
11116 #ifdef MOMENT
11117         s1=dipderg(3,jj,i)*dip(1,kk,k)
11118 #endif
11119         call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
11120         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
11121         s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
11122         call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
11123         vv(1)=pizda(1,1)-pizda(2,2)
11124         vv(2)=pizda(1,2)+pizda(2,1)
11125         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
11126 #ifdef MOMENT
11127         if (swap) then
11128           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
11129         else
11130           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
11131         endif
11132 #endif
11133         g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
11134 c        g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
11135       endif
11136 C Derivatives in gamma(l-1) or gamma(j-1)
11137       if (l.gt.1) then
11138 #ifdef MOMENT
11139         s1=dip(1,jj,i)*dipderg(3,kk,k)
11140 #endif
11141         call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
11142         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
11143         call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
11144         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
11145         call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
11146         vv(1)=pizda(1,1)-pizda(2,2)
11147         vv(2)=pizda(1,2)+pizda(2,1)
11148         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
11149 #ifdef MOMENT
11150         if (swap) then
11151           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
11152         else
11153           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
11154         endif
11155 #endif
11156         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
11157 c        g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
11158       endif
11159 C Cartesian derivatives.
11160       if (lprn) then
11161         write (2,*) 'In eello6_graph2'
11162         do iii=1,2
11163           write (2,*) 'iii=',iii
11164           do kkk=1,5
11165             write (2,*) 'kkk=',kkk
11166             do jjj=1,2
11167               write (2,'(3(2f10.5),5x)')
11168      &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
11169             enddo
11170           enddo
11171         enddo
11172       endif
11173       do iii=1,2
11174         do kkk=1,5
11175           do lll=1,3
11176 #ifdef MOMENT
11177             if (iii.eq.1) then
11178               s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
11179             else
11180               s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
11181             endif
11182 #endif
11183             call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),
11184      &        auxvec(1))
11185             s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
11186             call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),
11187      &        auxvec(1))
11188             s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
11189             call transpose2(EUg(1,1,k),auxmat(1,1))
11190             call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),
11191      &        pizda(1,1))
11192             vv(1)=pizda(1,1)-pizda(2,2)
11193             vv(2)=pizda(1,2)+pizda(2,1)
11194             s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
11195 cd            write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
11196 #ifdef MOMENT
11197             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
11198 #else
11199             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
11200 #endif
11201             if (swap) then
11202               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
11203             else
11204               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
11205             endif
11206           enddo
11207         enddo
11208       enddo
11209       return
11210       end
11211 c----------------------------------------------------------------------------
11212       double precision function eello6_graph3(i,j,k,l,jj,kk,swap)
11213       implicit real*8 (a-h,o-z)
11214       include 'DIMENSIONS'
11215       include 'COMMON.IOUNITS'
11216       include 'COMMON.CHAIN'
11217       include 'COMMON.DERIV'
11218       include 'COMMON.INTERACT'
11219       include 'COMMON.CONTACTS'
11220       include 'COMMON.TORSION'
11221       include 'COMMON.VAR'
11222       include 'COMMON.GEO'
11223       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2)
11224       logical swap
11225 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
11226 C                                                                              C
11227 C      Parallel       Antiparallel                                             C
11228 C                                                                              C
11229 C          o             o                                                     C
11230 C         /l\   /   \   /j\                                                    C
11231 C        /   \ /     \ /   \                                                   C
11232 C       /| o |o       o| o |\                                                  C
11233 C       j|/k\|  /      |/k\|l /                                                C
11234 C        /   \ /       /   \ /                                                 C
11235 C       /     o       /     o                                                  C
11236 C       i             i                                                        C
11237 C                                                                              C
11238 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
11239 C
11240 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
11241 C           energy moment and not to the cluster cumulant.
11242       iti=itortyp(itype(i))
11243       if (j.lt.nres-1) then
11244         itj1=itype2loc(itype(j+1))
11245       else
11246         itj1=nloctyp
11247       endif
11248       itk=itype2loc(itype(k))
11249       itk1=itype2loc(itype(k+1))
11250       if (l.lt.nres-1) then
11251         itl1=itype2loc(itype(l+1))
11252       else
11253         itl1=nloctyp
11254       endif
11255 #ifdef MOMENT
11256       s1=dip(4,jj,i)*dip(4,kk,k)
11257 #endif
11258       call matvec2(AECA(1,1,1),b1(1,k+1),auxvec(1))
11259       s2=0.5d0*scalar2(b1(1,k),auxvec(1))
11260       call matvec2(AECA(1,1,2),b1(1,l+1),auxvec(1))
11261       s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
11262       call transpose2(EE(1,1,k),auxmat(1,1))
11263       call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
11264       vv(1)=pizda(1,1)+pizda(2,2)
11265       vv(2)=pizda(2,1)-pizda(1,2)
11266       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
11267 cd      write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4,
11268 cd     & "sum",-(s2+s3+s4)
11269 #ifdef MOMENT
11270       eello6_graph3=-(s1+s2+s3+s4)
11271 #else
11272       eello6_graph3=-(s2+s3+s4)
11273 #endif
11274 c      eello6_graph3=-s4
11275 C Derivatives in gamma(k-1)
11276       call matvec2(AECAderg(1,1,2),b1(1,l+1),auxvec(1))
11277       s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
11278       s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
11279       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
11280 C Derivatives in gamma(l-1)
11281       call matvec2(AECAderg(1,1,1),b1(1,k+1),auxvec(1))
11282       s2=0.5d0*scalar2(b1(1,k),auxvec(1))
11283       call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
11284       vv(1)=pizda(1,1)+pizda(2,2)
11285       vv(2)=pizda(2,1)-pizda(1,2)
11286       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
11287       g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
11288 C Cartesian derivatives.
11289       do iii=1,2
11290         do kkk=1,5
11291           do lll=1,3
11292 #ifdef MOMENT
11293             if (iii.eq.1) then
11294               s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
11295             else
11296               s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
11297             endif
11298 #endif
11299             call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
11300      &        auxvec(1))
11301             s2=0.5d0*scalar2(b1(1,k),auxvec(1))
11302             call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,l+1),
11303      &        auxvec(1))
11304             s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
11305             call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),
11306      &        pizda(1,1))
11307             vv(1)=pizda(1,1)+pizda(2,2)
11308             vv(2)=pizda(2,1)-pizda(1,2)
11309             s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
11310 #ifdef MOMENT
11311             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
11312 #else
11313             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
11314 #endif
11315             if (swap) then
11316               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
11317             else
11318               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
11319             endif
11320 c            derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
11321           enddo
11322         enddo
11323       enddo
11324       return
11325       end
11326 c----------------------------------------------------------------------------
11327       double precision function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
11328       implicit real*8 (a-h,o-z)
11329       include 'DIMENSIONS'
11330       include 'COMMON.IOUNITS'
11331       include 'COMMON.CHAIN'
11332       include 'COMMON.DERIV'
11333       include 'COMMON.INTERACT'
11334       include 'COMMON.CONTACTS'
11335       include 'COMMON.TORSION'
11336       include 'COMMON.VAR'
11337       include 'COMMON.GEO'
11338       include 'COMMON.FFIELD'
11339       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
11340      & auxvec1(2),auxmat1(2,2)
11341       logical swap
11342 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
11343 C                                                                              C
11344 C      Parallel       Antiparallel                                             C
11345 C                                                                              C
11346 C          o             o                                                     C
11347 C         /l\   /   \   /j\                                                    C
11348 C        /   \ /     \ /   \                                                   C
11349 C       /| o |o       o| o |\                                                  C
11350 C     \ j|/k\|      \  |/k\|l                                                  C
11351 C      \ /   \       \ /   \                                                   C
11352 C       o     \       o     \                                                  C
11353 C       i             i                                                        C
11354 C                                                                              C
11355 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
11356 C
11357 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
11358 C           energy moment and not to the cluster cumulant.
11359 cd      write (2,*) 'eello_graph4: wturn6',wturn6
11360       iti=itype2loc(itype(i))
11361       itj=itype2loc(itype(j))
11362       if (j.lt.nres-1) then
11363         itj1=itype2loc(itype(j+1))
11364       else
11365         itj1=nloctyp
11366       endif
11367       itk=itype2loc(itype(k))
11368       if (k.lt.nres-1) then
11369         itk1=itype2loc(itype(k+1))
11370       else
11371         itk1=nloctyp
11372       endif
11373       itl=itype2loc(itype(l))
11374       if (l.lt.nres-1) then
11375         itl1=itype2loc(itype(l+1))
11376       else
11377         itl1=nloctyp
11378       endif
11379 cd      write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
11380 cd      write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
11381 cd     & ' itl',itl,' itl1',itl1
11382 #ifdef MOMENT
11383       if (imat.eq.1) then
11384         s1=dip(3,jj,i)*dip(3,kk,k)
11385       else
11386         s1=dip(2,jj,j)*dip(2,kk,l)
11387       endif
11388 #endif
11389       call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
11390       s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
11391       if (j.eq.l+1) then
11392         call matvec2(ADtEA1(1,1,3-imat),b1(1,j+1),auxvec1(1))
11393         s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
11394       else
11395         call matvec2(ADtEA1(1,1,3-imat),b1(1,l+1),auxvec1(1))
11396         s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
11397       endif
11398       call transpose2(EUg(1,1,k),auxmat(1,1))
11399       call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
11400       vv(1)=pizda(1,1)-pizda(2,2)
11401       vv(2)=pizda(2,1)+pizda(1,2)
11402       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
11403 cd      write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
11404 #ifdef MOMENT
11405       eello6_graph4=-(s1+s2+s3+s4)
11406 #else
11407       eello6_graph4=-(s2+s3+s4)
11408 #endif
11409 C Derivatives in gamma(i-1)
11410       if (i.gt.1) then
11411 #ifdef MOMENT
11412         if (imat.eq.1) then
11413           s1=dipderg(2,jj,i)*dip(3,kk,k)
11414         else
11415           s1=dipderg(4,jj,j)*dip(2,kk,l)
11416         endif
11417 #endif
11418         s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
11419         if (j.eq.l+1) then
11420           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,j+1),auxvec1(1))
11421           s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
11422         else
11423           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,l+1),auxvec1(1))
11424           s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
11425         endif
11426         s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
11427         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
11428 cd          write (2,*) 'turn6 derivatives'
11429 #ifdef MOMENT
11430           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
11431 #else
11432           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
11433 #endif
11434         else
11435 #ifdef MOMENT
11436           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
11437 #else
11438           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
11439 #endif
11440         endif
11441       endif
11442 C Derivatives in gamma(k-1)
11443 #ifdef MOMENT
11444       if (imat.eq.1) then
11445         s1=dip(3,jj,i)*dipderg(2,kk,k)
11446       else
11447         s1=dip(2,jj,j)*dipderg(4,kk,l)
11448       endif
11449 #endif
11450       call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
11451       s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
11452       if (j.eq.l+1) then
11453         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,j+1),auxvec1(1))
11454         s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
11455       else
11456         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,l+1),auxvec1(1))
11457         s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
11458       endif
11459       call transpose2(EUgder(1,1,k),auxmat1(1,1))
11460       call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
11461       vv(1)=pizda(1,1)-pizda(2,2)
11462       vv(2)=pizda(2,1)+pizda(1,2)
11463       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
11464       if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
11465 #ifdef MOMENT
11466         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
11467 #else
11468         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
11469 #endif
11470       else
11471 #ifdef MOMENT
11472         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
11473 #else
11474         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
11475 #endif
11476       endif
11477 C Derivatives in gamma(j-1) or gamma(l-1)
11478       if (l.eq.j+1 .and. l.gt.1) then
11479         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
11480         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
11481         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
11482         vv(1)=pizda(1,1)-pizda(2,2)
11483         vv(2)=pizda(2,1)+pizda(1,2)
11484         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
11485         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
11486       else if (j.gt.1) then
11487         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
11488         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
11489         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
11490         vv(1)=pizda(1,1)-pizda(2,2)
11491         vv(2)=pizda(2,1)+pizda(1,2)
11492         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
11493         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
11494           gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
11495         else
11496           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
11497         endif
11498       endif
11499 C Cartesian derivatives.
11500       do iii=1,2
11501         do kkk=1,5
11502           do lll=1,3
11503 #ifdef MOMENT
11504             if (iii.eq.1) then
11505               if (imat.eq.1) then
11506                 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
11507               else
11508                 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
11509               endif
11510             else
11511               if (imat.eq.1) then
11512                 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
11513               else
11514                 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
11515               endif
11516             endif
11517 #endif
11518             call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),
11519      &        auxvec(1))
11520             s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
11521             if (j.eq.l+1) then
11522               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
11523      &          b1(1,j+1),auxvec(1))
11524               s3=-0.5d0*scalar2(b1(1,j),auxvec(1))
11525             else
11526               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
11527      &          b1(1,l+1),auxvec(1))
11528               s3=-0.5d0*scalar2(b1(1,l),auxvec(1))
11529             endif
11530             call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
11531      &        pizda(1,1))
11532             vv(1)=pizda(1,1)-pizda(2,2)
11533             vv(2)=pizda(2,1)+pizda(1,2)
11534             s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
11535             if (swap) then
11536               if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
11537 #ifdef MOMENT
11538                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
11539      &             -(s1+s2+s4)
11540 #else
11541                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
11542      &             -(s2+s4)
11543 #endif
11544                 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
11545               else
11546 #ifdef MOMENT
11547                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
11548 #else
11549                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
11550 #endif
11551                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
11552               endif
11553             else
11554 #ifdef MOMENT
11555               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
11556 #else
11557               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
11558 #endif
11559               if (l.eq.j+1) then
11560                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
11561               else
11562                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
11563               endif
11564             endif
11565           enddo
11566         enddo
11567       enddo
11568       return
11569       end
11570 c----------------------------------------------------------------------------
11571       double precision function eello_turn6(i,jj,kk)
11572       implicit real*8 (a-h,o-z)
11573       include 'DIMENSIONS'
11574       include 'COMMON.IOUNITS'
11575       include 'COMMON.CHAIN'
11576       include 'COMMON.DERIV'
11577       include 'COMMON.INTERACT'
11578       include 'COMMON.CONTACTS'
11579       include 'COMMON.TORSION'
11580       include 'COMMON.VAR'
11581       include 'COMMON.GEO'
11582       double precision vtemp1(2),vtemp2(2),vtemp3(2),vtemp4(2),
11583      &  atemp(2,2),auxmat(2,2),achuj_temp(2,2),gtemp(2,2),gvec(2),
11584      &  ggg1(3),ggg2(3)
11585       double precision vtemp1d(2),vtemp2d(2),vtemp3d(2),vtemp4d(2),
11586      &  atempd(2,2),auxmatd(2,2),achuj_tempd(2,2),gtempd(2,2),gvecd(2)
11587 C 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
11588 C           the respective energy moment and not to the cluster cumulant.
11589       s1=0.0d0
11590       s8=0.0d0
11591       s13=0.0d0
11592 c
11593       eello_turn6=0.0d0
11594       j=i+4
11595       k=i+1
11596       l=i+3
11597       iti=itype2loc(itype(i))
11598       itk=itype2loc(itype(k))
11599       itk1=itype2loc(itype(k+1))
11600       itl=itype2loc(itype(l))
11601       itj=itype2loc(itype(j))
11602 cd      write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
11603 cd      write (2,*) 'i',i,' k',k,' j',j,' l',l
11604 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
11605 cd        eello6=0.0d0
11606 cd        return
11607 cd      endif
11608 cd      write (iout,*)
11609 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
11610 cd     &   ' and',k,l
11611 cd      call checkint_turn6(i,jj,kk,eel_turn6_num)
11612       do iii=1,2
11613         do kkk=1,5
11614           do lll=1,3
11615             derx_turn(lll,kkk,iii)=0.0d0
11616           enddo
11617         enddo
11618       enddo
11619 cd      eij=1.0d0
11620 cd      ekl=1.0d0
11621 cd      ekont=1.0d0
11622       eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
11623 cd      eello6_5=0.0d0
11624 cd      write (2,*) 'eello6_5',eello6_5
11625 #ifdef MOMENT
11626       call transpose2(AEA(1,1,1),auxmat(1,1))
11627       call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
11628       ss1=scalar2(Ub2(1,i+2),b1(1,l))
11629       s1 = (auxmat(1,1)+auxmat(2,2))*ss1
11630 #endif
11631       call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1(1))
11632       call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
11633       s2 = scalar2(b1(1,k),vtemp1(1))
11634 #ifdef MOMENT
11635       call transpose2(AEA(1,1,2),atemp(1,1))
11636       call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
11637       call matvec2(Ug2(1,1,i+2),dd(1,1,k+1),vtemp2(1))
11638       s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,l),vtemp2(1))
11639 #endif
11640       call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
11641       call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
11642       s12 = scalar2(Ub2(1,i+2),vtemp3(1))
11643 #ifdef MOMENT
11644       call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
11645       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
11646       call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
11647       call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
11648       ss13 = scalar2(b1(1,k),vtemp4(1))
11649       s13 = (gtemp(1,1)+gtemp(2,2))*ss13
11650 #endif
11651 c      write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
11652 c      s1=0.0d0
11653 c      s2=0.0d0
11654 c      s8=0.0d0
11655 c      s12=0.0d0
11656 c      s13=0.0d0
11657       eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
11658 C Derivatives in gamma(i+2)
11659       s1d =0.0d0
11660       s8d =0.0d0
11661 #ifdef MOMENT
11662       call transpose2(AEA(1,1,1),auxmatd(1,1))
11663       call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
11664       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
11665       call transpose2(AEAderg(1,1,2),atempd(1,1))
11666       call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
11667       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,l),vtemp2(1))
11668 #endif
11669       call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
11670       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
11671       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
11672 c      s1d=0.0d0
11673 c      s2d=0.0d0
11674 c      s8d=0.0d0
11675 c      s12d=0.0d0
11676 c      s13d=0.0d0
11677       gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
11678 C Derivatives in gamma(i+3)
11679 #ifdef MOMENT
11680       call transpose2(AEA(1,1,1),auxmatd(1,1))
11681       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
11682       ss1d=scalar2(Ub2der(1,i+2),b1(1,l))
11683       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
11684 #endif
11685       call matvec2(EUgder(1,1,i+2),b1(1,l),vtemp1d(1))
11686       call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
11687       s2d = scalar2(b1(1,k),vtemp1d(1))
11688 #ifdef MOMENT
11689       call matvec2(Ug2der(1,1,i+2),dd(1,1,k+1),vtemp2d(1))
11690       s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,l),vtemp2d(1))
11691 #endif
11692       s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
11693 #ifdef MOMENT
11694       call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
11695       call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
11696       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
11697 #endif
11698 c      s1d=0.0d0
11699 c      s2d=0.0d0
11700 c      s8d=0.0d0
11701 c      s12d=0.0d0
11702 c      s13d=0.0d0
11703 #ifdef MOMENT
11704       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
11705      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
11706 #else
11707       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
11708      &               -0.5d0*ekont*(s2d+s12d)
11709 #endif
11710 C Derivatives in gamma(i+4)
11711       call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
11712       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
11713       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
11714 #ifdef MOMENT
11715       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
11716       call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
11717       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
11718 #endif
11719 c      s1d=0.0d0
11720 c      s2d=0.0d0
11721 c      s8d=0.0d0
11722 C      s12d=0.0d0
11723 c      s13d=0.0d0
11724 #ifdef MOMENT
11725       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
11726 #else
11727       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
11728 #endif
11729 C Derivatives in gamma(i+5)
11730 #ifdef MOMENT
11731       call transpose2(AEAderg(1,1,1),auxmatd(1,1))
11732       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
11733       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
11734 #endif
11735       call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1d(1))
11736       call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
11737       s2d = scalar2(b1(1,k),vtemp1d(1))
11738 #ifdef MOMENT
11739       call transpose2(AEA(1,1,2),atempd(1,1))
11740       call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
11741       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,l),vtemp2(1))
11742 #endif
11743       call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
11744       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
11745 #ifdef MOMENT
11746       call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
11747       ss13d = scalar2(b1(1,k),vtemp4d(1))
11748       s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
11749 #endif
11750 c      s1d=0.0d0
11751 c      s2d=0.0d0
11752 c      s8d=0.0d0
11753 c      s12d=0.0d0
11754 c      s13d=0.0d0
11755 #ifdef MOMENT
11756       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
11757      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
11758 #else
11759       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
11760      &               -0.5d0*ekont*(s2d+s12d)
11761 #endif
11762 C Cartesian derivatives
11763       do iii=1,2
11764         do kkk=1,5
11765           do lll=1,3
11766 #ifdef MOMENT
11767             call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
11768             call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
11769             s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
11770 #endif
11771             call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1(1))
11772             call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),
11773      &          vtemp1d(1))
11774             s2d = scalar2(b1(1,k),vtemp1d(1))
11775 #ifdef MOMENT
11776             call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
11777             call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
11778             s8d = -(atempd(1,1)+atempd(2,2))*
11779      &           scalar2(cc(1,1,l),vtemp2(1))
11780 #endif
11781             call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),
11782      &           auxmatd(1,1))
11783             call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
11784             s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
11785 c      s1d=0.0d0
11786 c      s2d=0.0d0
11787 c      s8d=0.0d0
11788 c      s12d=0.0d0
11789 c      s13d=0.0d0
11790 #ifdef MOMENT
11791             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
11792      &        - 0.5d0*(s1d+s2d)
11793 #else
11794             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
11795      &        - 0.5d0*s2d
11796 #endif
11797 #ifdef MOMENT
11798             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
11799      &        - 0.5d0*(s8d+s12d)
11800 #else
11801             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
11802      &        - 0.5d0*s12d
11803 #endif
11804           enddo
11805         enddo
11806       enddo
11807 #ifdef MOMENT
11808       do kkk=1,5
11809         do lll=1,3
11810           call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),
11811      &      achuj_tempd(1,1))
11812           call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
11813           call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
11814           s13d=(gtempd(1,1)+gtempd(2,2))*ss13
11815           derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
11816           call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),
11817      &      vtemp4d(1))
11818           ss13d = scalar2(b1(1,k),vtemp4d(1))
11819           s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
11820           derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
11821         enddo
11822       enddo
11823 #endif
11824 cd      write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
11825 cd     &  16*eel_turn6_num
11826 cd      goto 1112
11827       if (j.lt.nres-1) then
11828         j1=j+1
11829         j2=j-1
11830       else
11831         j1=j-1
11832         j2=j-2
11833       endif
11834       if (l.lt.nres-1) then
11835         l1=l+1
11836         l2=l-1
11837       else
11838         l1=l-1
11839         l2=l-2
11840       endif
11841       do ll=1,3
11842 cgrad        ggg1(ll)=eel_turn6*g_contij(ll,1)
11843 cgrad        ggg2(ll)=eel_turn6*g_contij(ll,2)
11844 cgrad        ghalf=0.5d0*ggg1(ll)
11845 cd        ghalf=0.0d0
11846         gturn6ij=eel_turn6*g_contij(ll,1)+ekont*derx_turn(ll,1,1)
11847         gturn6kl=eel_turn6*g_contij(ll,2)+ekont*derx_turn(ll,1,2)
11848         gcorr6_turn(ll,i)=gcorr6_turn(ll,i)!+ghalf
11849      &    +ekont*derx_turn(ll,2,1)
11850         gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
11851         gcorr6_turn(ll,j)=gcorr6_turn(ll,j)!+ghalf
11852      &    +ekont*derx_turn(ll,4,1)
11853         gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
11854         gcorr6_turn_long(ll,j)=gcorr6_turn_long(ll,j)+gturn6ij
11855         gcorr6_turn_long(ll,i)=gcorr6_turn_long(ll,i)-gturn6ij
11856 cgrad        ghalf=0.5d0*ggg2(ll)
11857 cd        ghalf=0.0d0
11858         gcorr6_turn(ll,k)=gcorr6_turn(ll,k)!+ghalf
11859      &    +ekont*derx_turn(ll,2,2)
11860         gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
11861         gcorr6_turn(ll,l)=gcorr6_turn(ll,l)!+ghalf
11862      &    +ekont*derx_turn(ll,4,2)
11863         gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
11864         gcorr6_turn_long(ll,l)=gcorr6_turn_long(ll,l)+gturn6kl
11865         gcorr6_turn_long(ll,k)=gcorr6_turn_long(ll,k)-gturn6kl
11866       enddo
11867 cd      goto 1112
11868 cgrad      do m=i+1,j-1
11869 cgrad        do ll=1,3
11870 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
11871 cgrad        enddo
11872 cgrad      enddo
11873 cgrad      do m=k+1,l-1
11874 cgrad        do ll=1,3
11875 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
11876 cgrad        enddo
11877 cgrad      enddo
11878 cgrad1112  continue
11879 cgrad      do m=i+2,j2
11880 cgrad        do ll=1,3
11881 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
11882 cgrad        enddo
11883 cgrad      enddo
11884 cgrad      do m=k+2,l2
11885 cgrad        do ll=1,3
11886 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
11887 cgrad        enddo
11888 cgrad      enddo
11889 cd      do iii=1,nres-3
11890 cd        write (2,*) iii,g_corr6_loc(iii)
11891 cd      enddo
11892       eello_turn6=ekont*eel_turn6
11893 cd      write (2,*) 'ekont',ekont
11894 cd      write (2,*) 'eel_turn6',ekont*eel_turn6
11895       return
11896       end
11897
11898 C-----------------------------------------------------------------------------
11899       double precision function scalar(u,v)
11900 !DIR$ INLINEALWAYS scalar
11901 #ifndef OSF
11902 cDEC$ ATTRIBUTES FORCEINLINE::scalar
11903 #endif
11904       implicit none
11905       double precision u(3),v(3)
11906 cd      double precision sc
11907 cd      integer i
11908 cd      sc=0.0d0
11909 cd      do i=1,3
11910 cd        sc=sc+u(i)*v(i)
11911 cd      enddo
11912 cd      scalar=sc
11913
11914       scalar=u(1)*v(1)+u(2)*v(2)+u(3)*v(3)
11915       return
11916       end
11917 crc-------------------------------------------------
11918       SUBROUTINE MATVEC2(A1,V1,V2)
11919 !DIR$ INLINEALWAYS MATVEC2
11920 #ifndef OSF
11921 cDEC$ ATTRIBUTES FORCEINLINE::MATVEC2
11922 #endif
11923       implicit real*8 (a-h,o-z)
11924       include 'DIMENSIONS'
11925       DIMENSION A1(2,2),V1(2),V2(2)
11926 c      DO 1 I=1,2
11927 c        VI=0.0
11928 c        DO 3 K=1,2
11929 c    3     VI=VI+A1(I,K)*V1(K)
11930 c        Vaux(I)=VI
11931 c    1 CONTINUE
11932
11933       vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
11934       vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
11935
11936       v2(1)=vaux1
11937       v2(2)=vaux2
11938       END
11939 C---------------------------------------
11940       SUBROUTINE MATMAT2(A1,A2,A3)
11941 #ifndef OSF
11942 cDEC$ ATTRIBUTES FORCEINLINE::MATMAT2
11943 #endif
11944       implicit real*8 (a-h,o-z)
11945       include 'DIMENSIONS'
11946       DIMENSION A1(2,2),A2(2,2),A3(2,2)
11947 c      DIMENSION AI3(2,2)
11948 c        DO  J=1,2
11949 c          A3IJ=0.0
11950 c          DO K=1,2
11951 c           A3IJ=A3IJ+A1(I,K)*A2(K,J)
11952 c          enddo
11953 c          A3(I,J)=A3IJ
11954 c       enddo
11955 c      enddo
11956
11957       ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
11958       ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
11959       ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
11960       ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
11961
11962       A3(1,1)=AI3_11
11963       A3(2,1)=AI3_21
11964       A3(1,2)=AI3_12
11965       A3(2,2)=AI3_22
11966       END
11967
11968 c-------------------------------------------------------------------------
11969       double precision function scalar2(u,v)
11970 !DIR$ INLINEALWAYS scalar2
11971       implicit none
11972       double precision u(2),v(2)
11973       double precision sc
11974       integer i
11975       scalar2=u(1)*v(1)+u(2)*v(2)
11976       return
11977       end
11978
11979 C-----------------------------------------------------------------------------
11980
11981       subroutine transpose2(a,at)
11982 !DIR$ INLINEALWAYS transpose2
11983 #ifndef OSF
11984 cDEC$ ATTRIBUTES FORCEINLINE::transpose2
11985 #endif
11986       implicit none
11987       double precision a(2,2),at(2,2)
11988       at(1,1)=a(1,1)
11989       at(1,2)=a(2,1)
11990       at(2,1)=a(1,2)
11991       at(2,2)=a(2,2)
11992       return
11993       end
11994 c--------------------------------------------------------------------------
11995       subroutine transpose(n,a,at)
11996       implicit none
11997       integer n,i,j
11998       double precision a(n,n),at(n,n)
11999       do i=1,n
12000         do j=1,n
12001           at(j,i)=a(i,j)
12002         enddo
12003       enddo
12004       return
12005       end
12006 C---------------------------------------------------------------------------
12007       subroutine prodmat3(a1,a2,kk,transp,prod)
12008 !DIR$ INLINEALWAYS prodmat3
12009 #ifndef OSF
12010 cDEC$ ATTRIBUTES FORCEINLINE::prodmat3
12011 #endif
12012       implicit none
12013       integer i,j
12014       double precision a1(2,2),a2(2,2),a2t(2,2),kk(2,2),prod(2,2)
12015       logical transp
12016 crc      double precision auxmat(2,2),prod_(2,2)
12017
12018       if (transp) then
12019 crc        call transpose2(kk(1,1),auxmat(1,1))
12020 crc        call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
12021 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
12022
12023            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1)
12024      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
12025            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2)
12026      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
12027            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1)
12028      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
12029            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2)
12030      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
12031
12032       else
12033 crc        call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
12034 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
12035
12036            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1)
12037      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
12038            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2)
12039      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
12040            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1)
12041      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
12042            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2)
12043      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
12044
12045       endif
12046 c      call transpose2(a2(1,1),a2t(1,1))
12047
12048 crc      print *,transp
12049 crc      print *,((prod_(i,j),i=1,2),j=1,2)
12050 crc      print *,((prod(i,j),i=1,2),j=1,2)
12051
12052       return
12053       end
12054 CCC----------------------------------------------
12055       subroutine Eliptransfer(eliptran)
12056       implicit real*8 (a-h,o-z)
12057       include 'DIMENSIONS'
12058       include 'COMMON.GEO'
12059       include 'COMMON.VAR'
12060       include 'COMMON.LOCAL'
12061       include 'COMMON.CHAIN'
12062       include 'COMMON.DERIV'
12063       include 'COMMON.NAMES'
12064       include 'COMMON.INTERACT'
12065       include 'COMMON.IOUNITS'
12066       include 'COMMON.CALC'
12067       include 'COMMON.CONTROL'
12068       include 'COMMON.SPLITELE'
12069       include 'COMMON.SBRIDGE'
12070 C this is done by Adasko
12071 C      print *,"wchodze"
12072 C structure of box:
12073 C      water
12074 C--bordliptop-- buffore starts
12075 C--bufliptop--- here true lipid starts
12076 C      lipid
12077 C--buflipbot--- lipid ends buffore starts
12078 C--bordlipbot--buffore ends
12079       eliptran=0.0
12080       do i=ilip_start,ilip_end
12081 C       do i=1,1
12082         if (itype(i).eq.ntyp1) cycle
12083
12084         positi=(mod(((c(3,i)+c(3,i+1))/2.0d0),boxzsize))
12085         if (positi.le.0.0) positi=positi+boxzsize
12086 C        print *,i
12087 C first for peptide groups
12088 c for each residue check if it is in lipid or lipid water border area
12089        if ((positi.gt.bordlipbot)
12090      &.and.(positi.lt.bordliptop)) then
12091 C the energy transfer exist
12092         if (positi.lt.buflipbot) then
12093 C what fraction I am in
12094          fracinbuf=1.0d0-
12095      &        ((positi-bordlipbot)/lipbufthick)
12096 C lipbufthick is thickenes of lipid buffore
12097          sslip=sscalelip(fracinbuf)
12098          ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
12099          eliptran=eliptran+sslip*pepliptran
12100          gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
12101          gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
12102 C         gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
12103
12104 C        print *,"doing sccale for lower part"
12105 C         print *,i,sslip,fracinbuf,ssgradlip
12106         elseif (positi.gt.bufliptop) then
12107          fracinbuf=1.0d0-((bordliptop-positi)/lipbufthick)
12108          sslip=sscalelip(fracinbuf)
12109          ssgradlip=sscagradlip(fracinbuf)/lipbufthick
12110          eliptran=eliptran+sslip*pepliptran
12111          gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
12112          gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
12113 C         gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
12114 C          print *, "doing sscalefor top part"
12115 C         print *,i,sslip,fracinbuf,ssgradlip
12116         else
12117          eliptran=eliptran+pepliptran
12118 C         print *,"I am in true lipid"
12119         endif
12120 C       else
12121 C       eliptran=elpitran+0.0 ! I am in water
12122        endif
12123        enddo
12124 C       print *, "nic nie bylo w lipidzie?"
12125 C now multiply all by the peptide group transfer factor
12126 C       eliptran=eliptran*pepliptran
12127 C now the same for side chains
12128 CV       do i=1,1
12129        do i=ilip_start,ilip_end
12130         if (itype(i).eq.ntyp1) cycle
12131         positi=(mod(c(3,i+nres),boxzsize))
12132         if (positi.le.0) positi=positi+boxzsize
12133 C       print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop
12134 c for each residue check if it is in lipid or lipid water border area
12135 C       respos=mod(c(3,i+nres),boxzsize)
12136 C       print *,positi,bordlipbot,buflipbot
12137        if ((positi.gt.bordlipbot)
12138      & .and.(positi.lt.bordliptop)) then
12139 C the energy transfer exist
12140         if (positi.lt.buflipbot) then
12141          fracinbuf=1.0d0-
12142      &     ((positi-bordlipbot)/lipbufthick)
12143 C lipbufthick is thickenes of lipid buffore
12144          sslip=sscalelip(fracinbuf)
12145          ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
12146          eliptran=eliptran+sslip*liptranene(itype(i))
12147          gliptranx(3,i)=gliptranx(3,i)
12148      &+ssgradlip*liptranene(itype(i))
12149          gliptranc(3,i-1)= gliptranc(3,i-1)
12150      &+ssgradlip*liptranene(itype(i))
12151 C         print *,"doing sccale for lower part"
12152         elseif (positi.gt.bufliptop) then
12153          fracinbuf=1.0d0-
12154      &((bordliptop-positi)/lipbufthick)
12155          sslip=sscalelip(fracinbuf)
12156          ssgradlip=sscagradlip(fracinbuf)/lipbufthick
12157          eliptran=eliptran+sslip*liptranene(itype(i))
12158          gliptranx(3,i)=gliptranx(3,i)
12159      &+ssgradlip*liptranene(itype(i))
12160          gliptranc(3,i-1)= gliptranc(3,i-1)
12161      &+ssgradlip*liptranene(itype(i))
12162 C          print *, "doing sscalefor top part",sslip,fracinbuf
12163         else
12164          eliptran=eliptran+liptranene(itype(i))
12165 C         print *,"I am in true lipid"
12166         endif
12167         endif ! if in lipid or buffor
12168 C       else
12169 C       eliptran=elpitran+0.0 ! I am in water
12170        enddo
12171        return
12172        end
12173 C---------------------------------------------------------
12174 C AFM soubroutine for constant force
12175        subroutine AFMforce(Eafmforce)
12176        implicit real*8 (a-h,o-z)
12177       include 'DIMENSIONS'
12178       include 'COMMON.GEO'
12179       include 'COMMON.VAR'
12180       include 'COMMON.LOCAL'
12181       include 'COMMON.CHAIN'
12182       include 'COMMON.DERIV'
12183       include 'COMMON.NAMES'
12184       include 'COMMON.INTERACT'
12185       include 'COMMON.IOUNITS'
12186       include 'COMMON.CALC'
12187       include 'COMMON.CONTROL'
12188       include 'COMMON.SPLITELE'
12189       include 'COMMON.SBRIDGE'
12190       real*8 diffafm(3)
12191       dist=0.0d0
12192       Eafmforce=0.0d0
12193       do i=1,3
12194       diffafm(i)=c(i,afmend)-c(i,afmbeg)
12195       dist=dist+diffafm(i)**2
12196       enddo
12197       dist=dsqrt(dist)
12198       Eafmforce=-forceAFMconst*(dist-distafminit)
12199       do i=1,3
12200       gradafm(i,afmend-1)=-forceAFMconst*diffafm(i)/dist
12201       gradafm(i,afmbeg-1)=forceAFMconst*diffafm(i)/dist
12202       enddo
12203 C      print *,'AFM',Eafmforce
12204       return
12205       end
12206 C---------------------------------------------------------
12207 C AFM subroutine with pseudoconstant velocity
12208        subroutine AFMvel(Eafmforce)
12209        implicit real*8 (a-h,o-z)
12210       include 'DIMENSIONS'
12211       include 'COMMON.GEO'
12212       include 'COMMON.VAR'
12213       include 'COMMON.LOCAL'
12214       include 'COMMON.CHAIN'
12215       include 'COMMON.DERIV'
12216       include 'COMMON.NAMES'
12217       include 'COMMON.INTERACT'
12218       include 'COMMON.IOUNITS'
12219       include 'COMMON.CALC'
12220       include 'COMMON.CONTROL'
12221       include 'COMMON.SPLITELE'
12222       include 'COMMON.SBRIDGE'
12223       real*8 diffafm(3)
12224 C Only for check grad COMMENT if not used for checkgrad
12225 C      totT=3.0d0
12226 C--------------------------------------------------------
12227 C      print *,"wchodze"
12228       dist=0.0d0
12229       Eafmforce=0.0d0
12230       do i=1,3
12231       diffafm(i)=c(i,afmend)-c(i,afmbeg)
12232       dist=dist+diffafm(i)**2
12233       enddo
12234       dist=dsqrt(dist)
12235       Eafmforce=0.5d0*forceAFMconst
12236      & *(distafminit+totTafm*velAFMconst-dist)**2
12237 C      Eafmforce=-forceAFMconst*(dist-distafminit)
12238       do i=1,3
12239       gradafm(i,afmend-1)=-forceAFMconst*
12240      &(distafminit+totTafm*velAFMconst-dist)
12241      &*diffafm(i)/dist
12242       gradafm(i,afmbeg-1)=forceAFMconst*
12243      &(distafminit+totTafm*velAFMconst-dist)
12244      &*diffafm(i)/dist
12245       enddo
12246 C      print *,'AFM',Eafmforce,totTafm*velAFMconst,dist
12247       return
12248       end
12249 C-----------------------------------------------------------
12250 C first for shielding is setting of function of side-chains
12251        subroutine set_shield_fac
12252       implicit real*8 (a-h,o-z)
12253       include 'DIMENSIONS'
12254       include 'COMMON.CHAIN'
12255       include 'COMMON.DERIV'
12256       include 'COMMON.IOUNITS'
12257       include 'COMMON.SHIELD'
12258       include 'COMMON.INTERACT'
12259 C this is the squar root 77 devided by 81 the epislion in lipid (in protein)
12260       double precision div77_81/0.974996043d0/,
12261      &div4_81/0.2222222222d0/,sh_frac_dist_grad(3)
12262
12263 C the vector between center of side_chain and peptide group
12264        double precision pep_side(3),long,side_calf(3),
12265      &pept_group(3),costhet_grad(3),cosphi_grad_long(3),
12266      &cosphi_grad_loc(3),pep_side_norm(3),side_calf_norm(3)
12267 C the line belowe needs to be changed for FGPROC>1
12268       do i=1,nres-1
12269       if ((itype(i).eq.ntyp1).and.itype(i+1).eq.ntyp1) cycle
12270       ishield_list(i)=0
12271 Cif there two consequtive dummy atoms there is no peptide group between them
12272 C the line below has to be changed for FGPROC>1
12273       VolumeTotal=0.0
12274       do k=1,nres
12275        if ((itype(k).eq.ntyp1).or.(itype(k).eq.10)) cycle
12276        dist_pep_side=0.0
12277        dist_side_calf=0.0
12278        do j=1,3
12279 C first lets set vector conecting the ithe side-chain with kth side-chain
12280       pep_side(j)=c(j,k+nres)-(c(j,i)+c(j,i+1))/2.0d0
12281 C      pep_side(j)=2.0d0
12282 C and vector conecting the side-chain with its proper calfa
12283       side_calf(j)=c(j,k+nres)-c(j,k)
12284 C      side_calf(j)=2.0d0
12285       pept_group(j)=c(j,i)-c(j,i+1)
12286 C lets have their lenght
12287       dist_pep_side=pep_side(j)**2+dist_pep_side
12288       dist_side_calf=dist_side_calf+side_calf(j)**2
12289       dist_pept_group=dist_pept_group+pept_group(j)**2
12290       enddo
12291        dist_pep_side=dsqrt(dist_pep_side)
12292        dist_pept_group=dsqrt(dist_pept_group)
12293        dist_side_calf=dsqrt(dist_side_calf)
12294       do j=1,3
12295         pep_side_norm(j)=pep_side(j)/dist_pep_side
12296         side_calf_norm(j)=dist_side_calf
12297       enddo
12298 C now sscale fraction
12299        sh_frac_dist=-(dist_pep_side-rpp(1,1)-buff_shield)/buff_shield
12300 C       print *,buff_shield,"buff"
12301 C now sscale
12302         if (sh_frac_dist.le.0.0) cycle
12303 C If we reach here it means that this side chain reaches the shielding sphere
12304 C Lets add him to the list for gradient
12305         ishield_list(i)=ishield_list(i)+1
12306 C ishield_list is a list of non 0 side-chain that contribute to factor gradient
12307 C this list is essential otherwise problem would be O3
12308         shield_list(ishield_list(i),i)=k
12309 C Lets have the sscale value
12310         if (sh_frac_dist.gt.1.0) then
12311          scale_fac_dist=1.0d0
12312          do j=1,3
12313          sh_frac_dist_grad(j)=0.0d0
12314          enddo
12315         else
12316          scale_fac_dist=-sh_frac_dist*sh_frac_dist
12317      &                   *(2.0*sh_frac_dist-3.0d0)
12318          fac_help_scale=6.0*(sh_frac_dist-sh_frac_dist**2)
12319      &                  /dist_pep_side/buff_shield*0.5
12320 C remember for the final gradient multiply sh_frac_dist_grad(j)
12321 C for side_chain by factor -2 !
12322          do j=1,3
12323          sh_frac_dist_grad(j)=fac_help_scale*pep_side(j)
12324 C         print *,"jestem",scale_fac_dist,fac_help_scale,
12325 C     &                    sh_frac_dist_grad(j)
12326          enddo
12327         endif
12328 C        if ((i.eq.3).and.(k.eq.2)) then
12329 C        print *,i,sh_frac_dist,dist_pep,fac_help_scale,scale_fac_dist
12330 C     & ,"TU"
12331 C        endif
12332
12333 C this is what is now we have the distance scaling now volume...
12334       short=short_r_sidechain(itype(k))
12335       long=long_r_sidechain(itype(k))
12336       costhet=1.0d0/dsqrt(1.0+short**2/dist_pep_side**2)
12337 C now costhet_grad
12338 C       costhet=0.0d0
12339        costhet_fac=costhet**3*short**2*(-0.5)/dist_pep_side**4
12340 C       costhet_fac=0.0d0
12341        do j=1,3
12342          costhet_grad(j)=costhet_fac*pep_side(j)
12343        enddo
12344 C remember for the final gradient multiply costhet_grad(j)
12345 C for side_chain by factor -2 !
12346 C fac alfa is angle between CB_k,CA_k, CA_i,CA_i+1
12347 C pep_side0pept_group is vector multiplication
12348       pep_side0pept_group=0.0
12349       do j=1,3
12350       pep_side0pept_group=pep_side0pept_group+pep_side(j)*side_calf(j)
12351       enddo
12352       cosalfa=(pep_side0pept_group/
12353      & (dist_pep_side*dist_side_calf))
12354       fac_alfa_sin=1.0-cosalfa**2
12355       fac_alfa_sin=dsqrt(fac_alfa_sin)
12356       rkprim=fac_alfa_sin*(long-short)+short
12357 C now costhet_grad
12358        cosphi=1.0d0/dsqrt(1.0+rkprim**2/dist_pep_side**2)
12359        cosphi_fac=cosphi**3*rkprim**2*(-0.5)/dist_pep_side**4
12360
12361        do j=1,3
12362          cosphi_grad_long(j)=cosphi_fac*pep_side(j)
12363      &+cosphi**3*0.5/dist_pep_side**2*(-rkprim)
12364      &*(long-short)/fac_alfa_sin*cosalfa/
12365      &((dist_pep_side*dist_side_calf))*
12366      &((side_calf(j))-cosalfa*
12367      &((pep_side(j)/dist_pep_side)*dist_side_calf))
12368
12369         cosphi_grad_loc(j)=cosphi**3*0.5/dist_pep_side**2*(-rkprim)
12370      &*(long-short)/fac_alfa_sin*cosalfa
12371      &/((dist_pep_side*dist_side_calf))*
12372      &(pep_side(j)-
12373      &cosalfa*side_calf(j)/dist_side_calf*dist_pep_side)
12374        enddo
12375
12376       VofOverlap=VSolvSphere/2.0d0*(1.0-costhet)*(1.0-cosphi)
12377      &                    /VSolvSphere_div
12378      &                    *wshield
12379 C now the gradient...
12380 C grad_shield is gradient of Calfa for peptide groups
12381 C      write(iout,*) "shield_compon",i,k,VSolvSphere,scale_fac_dist,
12382 C     &               costhet,cosphi
12383 C       write(iout,*) "cosphi_compon",i,k,pep_side0pept_group,
12384 C     & dist_pep_side,dist_side_calf,c(1,k+nres),c(1,k),itype(k)
12385       do j=1,3
12386       grad_shield(j,i)=grad_shield(j,i)
12387 C gradient po skalowaniu
12388      &                +(sh_frac_dist_grad(j)
12389 C  gradient po costhet
12390      &-scale_fac_dist*costhet_grad(j)/(1.0-costhet)
12391      &-scale_fac_dist*(cosphi_grad_long(j))
12392      &/(1.0-cosphi) )*div77_81
12393      &*VofOverlap
12394 C grad_shield_side is Cbeta sidechain gradient
12395       grad_shield_side(j,ishield_list(i),i)=
12396      &        (sh_frac_dist_grad(j)*(-2.0d0)
12397      &       +scale_fac_dist*costhet_grad(j)*2.0d0/(1.0-costhet)
12398      &       +scale_fac_dist*(cosphi_grad_long(j))
12399      &        *2.0d0/(1.0-cosphi))
12400      &        *div77_81*VofOverlap
12401
12402        grad_shield_loc(j,ishield_list(i),i)=
12403      &   scale_fac_dist*cosphi_grad_loc(j)
12404      &        *2.0d0/(1.0-cosphi)
12405      &        *div77_81*VofOverlap
12406       enddo
12407       VolumeTotal=VolumeTotal+VofOverlap*scale_fac_dist
12408       enddo
12409       fac_shield(i)=VolumeTotal*div77_81+div4_81
12410 c      write(2,*) "TOTAL VOLUME",i,VolumeTotal,fac_shield(i)
12411       enddo
12412       return
12413       end
12414 C--------------------------------------------------------------------------
12415       double precision function tschebyshev(m,n,x,y)
12416       implicit none
12417       include "DIMENSIONS"
12418       integer i,m,n
12419       double precision x(n),y,yy(0:maxvar),aux
12420 c Tschebyshev polynomial. Note that the first term is omitted
12421 c m=0: the constant term is included
12422 c m=1: the constant term is not included
12423       yy(0)=1.0d0
12424       yy(1)=y
12425       do i=2,n
12426         yy(i)=2*yy(1)*yy(i-1)-yy(i-2)
12427       enddo
12428       aux=0.0d0
12429       do i=m,n
12430         aux=aux+x(i)*yy(i)
12431       enddo
12432       tschebyshev=aux
12433       return
12434       end
12435 C--------------------------------------------------------------------------
12436       double precision function gradtschebyshev(m,n,x,y)
12437       implicit none
12438       include "DIMENSIONS"
12439       integer i,m,n
12440       double precision x(n+1),y,yy(0:maxvar),aux
12441 c Tschebyshev polynomial. Note that the first term is omitted
12442 c m=0: the constant term is included
12443 c m=1: the constant term is not included
12444       yy(0)=1.0d0
12445       yy(1)=2.0d0*y
12446       do i=2,n
12447         yy(i)=2*y*yy(i-1)-yy(i-2)
12448       enddo
12449       aux=0.0d0
12450       do i=m,n
12451         aux=aux+x(i+1)*yy(i)*(i+1)
12452 C        print *, x(i+1),yy(i),i
12453       enddo
12454       gradtschebyshev=aux
12455       return
12456       end
12457 C------------------------------------------------------------------------
12458 C first for shielding is setting of function of side-chains
12459        subroutine set_shield_fac2
12460       implicit real*8 (a-h,o-z)
12461       include 'DIMENSIONS'
12462       include 'COMMON.CHAIN'
12463       include 'COMMON.DERIV'
12464       include 'COMMON.IOUNITS'
12465       include 'COMMON.SHIELD'
12466       include 'COMMON.INTERACT'
12467 C this is the squar root 77 devided by 81 the epislion in lipid (in protein)
12468       double precision div77_81/0.974996043d0/,
12469      &div4_81/0.2222222222d0/,sh_frac_dist_grad(3)
12470
12471 C the vector between center of side_chain and peptide group
12472        double precision pep_side(3),long,side_calf(3),
12473      &pept_group(3),costhet_grad(3),cosphi_grad_long(3),
12474      &cosphi_grad_loc(3),pep_side_norm(3),side_calf_norm(3)
12475 C the line belowe needs to be changed for FGPROC>1
12476       do i=1,nres-1
12477       if ((itype(i).eq.ntyp1).and.itype(i+1).eq.ntyp1) cycle
12478       ishield_list(i)=0
12479 Cif there two consequtive dummy atoms there is no peptide group between them
12480 C the line below has to be changed for FGPROC>1
12481       VolumeTotal=0.0
12482       do k=1,nres
12483        if ((itype(k).eq.ntyp1).or.(itype(k).eq.10)) cycle
12484        dist_pep_side=0.0
12485        dist_side_calf=0.0
12486        do j=1,3
12487 C first lets set vector conecting the ithe side-chain with kth side-chain
12488       pep_side(j)=c(j,k+nres)-(c(j,i)+c(j,i+1))/2.0d0
12489 C      pep_side(j)=2.0d0
12490 C and vector conecting the side-chain with its proper calfa
12491       side_calf(j)=c(j,k+nres)-c(j,k)
12492 C      side_calf(j)=2.0d0
12493       pept_group(j)=c(j,i)-c(j,i+1)
12494 C lets have their lenght
12495       dist_pep_side=pep_side(j)**2+dist_pep_side
12496       dist_side_calf=dist_side_calf+side_calf(j)**2
12497       dist_pept_group=dist_pept_group+pept_group(j)**2
12498       enddo
12499        dist_pep_side=dsqrt(dist_pep_side)
12500        dist_pept_group=dsqrt(dist_pept_group)
12501        dist_side_calf=dsqrt(dist_side_calf)
12502       do j=1,3
12503         pep_side_norm(j)=pep_side(j)/dist_pep_side
12504         side_calf_norm(j)=dist_side_calf
12505       enddo
12506 C now sscale fraction
12507        sh_frac_dist=-(dist_pep_side-rpp(1,1)-buff_shield)/buff_shield
12508 C       print *,buff_shield,"buff"
12509 C now sscale
12510         if (sh_frac_dist.le.0.0) cycle
12511 C If we reach here it means that this side chain reaches the shielding sphere
12512 C Lets add him to the list for gradient
12513         ishield_list(i)=ishield_list(i)+1
12514 C ishield_list is a list of non 0 side-chain that contribute to factor gradient
12515 C this list is essential otherwise problem would be O3
12516         shield_list(ishield_list(i),i)=k
12517 C Lets have the sscale value
12518         if (sh_frac_dist.gt.1.0) then
12519          scale_fac_dist=1.0d0
12520          do j=1,3
12521          sh_frac_dist_grad(j)=0.0d0
12522          enddo
12523         else
12524          scale_fac_dist=-sh_frac_dist*sh_frac_dist
12525      &                   *(2.0d0*sh_frac_dist-3.0d0)
12526          fac_help_scale=6.0d0*(sh_frac_dist-sh_frac_dist**2)
12527      &                  /dist_pep_side/buff_shield*0.5d0
12528 C remember for the final gradient multiply sh_frac_dist_grad(j)
12529 C for side_chain by factor -2 !
12530          do j=1,3
12531          sh_frac_dist_grad(j)=fac_help_scale*pep_side(j)
12532 C         sh_frac_dist_grad(j)=0.0d0
12533 C         scale_fac_dist=1.0d0
12534 C         print *,"jestem",scale_fac_dist,fac_help_scale,
12535 C     &                    sh_frac_dist_grad(j)
12536          enddo
12537         endif
12538 C this is what is now we have the distance scaling now volume...
12539       short=short_r_sidechain(itype(k))
12540       long=long_r_sidechain(itype(k))
12541       costhet=1.0d0/dsqrt(1.0d0+short**2/dist_pep_side**2)
12542       sinthet=short/dist_pep_side*costhet
12543 C now costhet_grad
12544 C       costhet=0.6d0
12545 C       sinthet=0.8
12546        costhet_fac=costhet**3*short**2*(-0.5d0)/dist_pep_side**4
12547 C       sinthet_fac=costhet**2*0.5d0*(short**3/dist_pep_side**4*costhet
12548 C     &             -short/dist_pep_side**2/costhet)
12549 C       costhet_fac=0.0d0
12550        do j=1,3
12551          costhet_grad(j)=costhet_fac*pep_side(j)
12552        enddo
12553 C remember for the final gradient multiply costhet_grad(j)
12554 C for side_chain by factor -2 !
12555 C fac alfa is angle between CB_k,CA_k, CA_i,CA_i+1
12556 C pep_side0pept_group is vector multiplication
12557       pep_side0pept_group=0.0d0
12558       do j=1,3
12559       pep_side0pept_group=pep_side0pept_group+pep_side(j)*side_calf(j)
12560       enddo
12561       cosalfa=(pep_side0pept_group/
12562      & (dist_pep_side*dist_side_calf))
12563       fac_alfa_sin=1.0d0-cosalfa**2
12564       fac_alfa_sin=dsqrt(fac_alfa_sin)
12565       rkprim=fac_alfa_sin*(long-short)+short
12566 C      rkprim=short
12567
12568 C now costhet_grad
12569        cosphi=1.0d0/dsqrt(1.0d0+rkprim**2/dist_pep_side**2)
12570 C       cosphi=0.6
12571        cosphi_fac=cosphi**3*rkprim**2*(-0.5d0)/dist_pep_side**4
12572        sinphi=rkprim/dist_pep_side/dsqrt(1.0d0+rkprim**2/
12573      &      dist_pep_side**2)
12574 C       sinphi=0.8
12575        do j=1,3
12576          cosphi_grad_long(j)=cosphi_fac*pep_side(j)
12577      &+cosphi**3*0.5d0/dist_pep_side**2*(-rkprim)
12578      &*(long-short)/fac_alfa_sin*cosalfa/
12579      &((dist_pep_side*dist_side_calf))*
12580      &((side_calf(j))-cosalfa*
12581      &((pep_side(j)/dist_pep_side)*dist_side_calf))
12582 C       cosphi_grad_long(j)=0.0d0
12583         cosphi_grad_loc(j)=cosphi**3*0.5d0/dist_pep_side**2*(-rkprim)
12584      &*(long-short)/fac_alfa_sin*cosalfa
12585      &/((dist_pep_side*dist_side_calf))*
12586      &(pep_side(j)-
12587      &cosalfa*side_calf(j)/dist_side_calf*dist_pep_side)
12588 C       cosphi_grad_loc(j)=0.0d0
12589        enddo
12590 C      print *,sinphi,sinthet
12591 c      write (iout,*) "VSolvSphere",VSolvSphere," VSolvSphere_div",
12592 c     &  VSolvSphere_div," sinphi",sinphi," sinthet",sinthet
12593       VofOverlap=VSolvSphere/2.0d0*(1.0d0-dsqrt(1.0d0-sinphi*sinthet))
12594      &                    /VSolvSphere_div
12595 C     &                    *wshield
12596 C now the gradient...
12597       do j=1,3
12598       grad_shield(j,i)=grad_shield(j,i)
12599 C gradient po skalowaniu
12600      &                +(sh_frac_dist_grad(j)*VofOverlap
12601 C  gradient po costhet
12602      &       +scale_fac_dist*VSolvSphere/VSolvSphere_div/4.0d0*
12603      &(1.0d0/(-dsqrt(1.0d0-sinphi*sinthet))*(
12604      &       sinphi/sinthet*costhet*costhet_grad(j)
12605      &      +sinthet/sinphi*cosphi*cosphi_grad_long(j)))
12606      & )*wshield
12607 C grad_shield_side is Cbeta sidechain gradient
12608       grad_shield_side(j,ishield_list(i),i)=
12609      &        (sh_frac_dist_grad(j)*(-2.0d0)
12610      &        *VofOverlap
12611      &       -scale_fac_dist*VSolvSphere/VSolvSphere_div/2.0d0*
12612      &(1.0d0/(-dsqrt(1.0d0-sinphi*sinthet))*(
12613      &       sinphi/sinthet*costhet*costhet_grad(j)
12614      &      +sinthet/sinphi*cosphi*cosphi_grad_long(j)))
12615      &       )*wshield
12616
12617        grad_shield_loc(j,ishield_list(i),i)=
12618      &       scale_fac_dist*VSolvSphere/VSolvSphere_div/2.0d0*
12619      &(1.0d0/(dsqrt(1.0d0-sinphi*sinthet))*(
12620      &       sinthet/sinphi*cosphi*cosphi_grad_loc(j)
12621      &        ))
12622      &        *wshield
12623       enddo
12624 c      write (iout,*) "VofOverlap",VofOverlap," scale_fac_dist",
12625 c     & scale_fac_dist
12626       VolumeTotal=VolumeTotal+VofOverlap*scale_fac_dist
12627       enddo
12628       fac_shield(i)=VolumeTotal*wshield+(1.0d0-wshield)
12629 c      write(2,*) "TOTAL VOLUME",i,VolumeTotal,fac_shield(i),
12630 c     &  " wshield",wshield
12631 c      write(2,*) "TU",rpp(1,1),short,long,buff_shield
12632       enddo
12633       return
12634       end
12635 C-----------------------------------------------------------------------
12636 C-----------------------------------------------------------
12637 C This subroutine is to mimic the histone like structure but as well can be
12638 C utilizet to nanostructures (infinit) small modification has to be used to
12639 C make it finite (z gradient at the ends has to be changes as well as the x,y
12640 C gradient has to be modified at the ends
12641 C The energy function is Kihara potential
12642 C E=4esp*((sigma/(r-r0))^12 - (sigma/(r-r0))^6)
12643 C 4eps is depth of well sigma is r_minimum r is distance from center of tube
12644 C and r0 is the excluded size of nanotube (can be set to 0 if we want just a
12645 C simple Kihara potential
12646       subroutine calctube(Etube)
12647        implicit real*8 (a-h,o-z)
12648       include 'DIMENSIONS'
12649       include 'COMMON.GEO'
12650       include 'COMMON.VAR'
12651       include 'COMMON.LOCAL'
12652       include 'COMMON.CHAIN'
12653       include 'COMMON.DERIV'
12654       include 'COMMON.NAMES'
12655       include 'COMMON.INTERACT'
12656       include 'COMMON.IOUNITS'
12657       include 'COMMON.CALC'
12658       include 'COMMON.CONTROL'
12659       include 'COMMON.SPLITELE'
12660       include 'COMMON.SBRIDGE'
12661       double precision tub_r,vectube(3),enetube(maxres*2)
12662       Etube=0.0d0
12663       do i=1,2*nres
12664         enetube(i)=0.0d0
12665       enddo
12666 C first we calculate the distance from tube center
12667 C first sugare-phosphate group for NARES this would be peptide group
12668 C for UNRES
12669       do i=1,nres
12670 C lets ommit dummy atoms for now
12671        if ((itype(i).eq.ntyp1).or.(itype(i+1).eq.ntyp1)) cycle
12672 C now calculate distance from center of tube and direction vectors
12673       vectube(1)=mod((c(1,i)+c(1,i+1))/2.0d0,boxxsize)
12674           if (vectube(1).lt.0) vectube(1)=vectube(1)+boxxsize
12675       vectube(2)=mod((c(2,i)+c(2,i+1))/2.0d0,boxxsize)
12676           if (vectube(2).lt.0) vectube(2)=vectube(2)+boxxsize
12677       vectube(1)=vectube(1)-tubecenter(1)
12678       vectube(2)=vectube(2)-tubecenter(2)
12679
12680 C      print *,"x",(c(1,i)+c(1,i+1))/2.0d0,tubecenter(1)
12681 C      print *,"y",(c(2,i)+c(2,i+1))/2.0d0,tubecenter(2)
12682
12683 C as the tube is infinity we do not calculate the Z-vector use of Z
12684 C as chosen axis
12685       vectube(3)=0.0d0
12686 C now calculte the distance
12687        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
12688 C now normalize vector
12689       vectube(1)=vectube(1)/tub_r
12690       vectube(2)=vectube(2)/tub_r
12691 C calculte rdiffrence between r and r0
12692       rdiff=tub_r-tubeR0
12693 C and its 6 power
12694       rdiff6=rdiff**6.0d0
12695 C for vectorization reasons we will sumup at the end to avoid depenence of previous
12696        enetube(i)=pep_aa_tube/rdiff6**2.0d0-pep_bb_tube/rdiff6
12697 C       write(iout,*) "TU13",i,rdiff6,enetube(i)
12698 C       print *,rdiff,rdiff6,pep_aa_tube
12699 C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
12700 C now we calculate gradient
12701        fac=(-12.0d0*pep_aa_tube/rdiff6+
12702      &       6.0d0*pep_bb_tube)/rdiff6/rdiff
12703 C       write(iout,'(a5,i4,f12.1,3f12.5)') "TU13",i,rdiff6,enetube(i),
12704 C     &rdiff,fac
12705
12706 C now direction of gg_tube vector
12707         do j=1,3
12708         gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac/2.0d0
12709         gg_tube(j,i)=gg_tube(j,i)+vectube(j)*fac/2.0d0
12710         enddo
12711         enddo
12712 C basically thats all code now we split for side-chains (REMEMBER to sum up at the END)
12713         do i=1,nres
12714 C Lets not jump over memory as we use many times iti
12715          iti=itype(i)
12716 C lets ommit dummy atoms for now
12717          if ((iti.eq.ntyp1)
12718 C in UNRES uncomment the line below as GLY has no side-chain...
12719 C      .or.(iti.eq.10)
12720      &   ) cycle
12721           vectube(1)=c(1,i+nres)
12722           vectube(1)=mod(vectube(1),boxxsize)
12723           if (vectube(1).lt.0) vectube(1)=vectube(1)+boxxsize
12724           vectube(2)=c(2,i+nres)
12725           vectube(2)=mod(vectube(2),boxxsize)
12726           if (vectube(2).lt.0) vectube(2)=vectube(2)+boxxsize
12727
12728       vectube(1)=vectube(1)-tubecenter(1)
12729       vectube(2)=vectube(2)-tubecenter(2)
12730
12731 C as the tube is infinity we do not calculate the Z-vector use of Z
12732 C as chosen axis
12733       vectube(3)=0.0d0
12734 C now calculte the distance
12735        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
12736 C now normalize vector
12737       vectube(1)=vectube(1)/tub_r
12738       vectube(2)=vectube(2)/tub_r
12739 C calculte rdiffrence between r and r0
12740       rdiff=tub_r-tubeR0
12741 C and its 6 power
12742       rdiff6=rdiff**6.0d0
12743 C for vectorization reasons we will sumup at the end to avoid depenence of previous
12744        sc_aa_tube=sc_aa_tube_par(iti)
12745        sc_bb_tube=sc_bb_tube_par(iti)
12746        enetube(i+nres)=sc_aa_tube/rdiff6**2.0d0-sc_bb_tube/rdiff6
12747 C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
12748 C now we calculate gradient
12749        fac=-12.0d0*sc_aa_tube/rdiff6**2.0d0/rdiff+
12750      &       6.0d0*sc_bb_tube/rdiff6/rdiff
12751 C now direction of gg_tube vector
12752          do j=1,3
12753           gg_tube_SC(j,i)=gg_tube_SC(j,i)+vectube(j)*fac
12754           gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac
12755          enddo
12756         enddo
12757         do i=1,2*nres
12758           Etube=Etube+enetube(i)
12759         enddo
12760 C        print *,"ETUBE", etube
12761         return
12762         end
12763 C TO DO 1) add to total energy
12764 C       2) add to gradient summation
12765 C       3) add reading parameters (AND of course oppening of PARAM file)
12766 C       4) add reading the center of tube
12767 C       5) add COMMONs
12768 C       6) add to zerograd
12769
12770 C-----------------------------------------------------------------------
12771 C-----------------------------------------------------------
12772 C This subroutine is to mimic the histone like structure but as well can be
12773 C utilizet to nanostructures (infinit) small modification has to be used to
12774 C make it finite (z gradient at the ends has to be changes as well as the x,y
12775 C gradient has to be modified at the ends
12776 C The energy function is Kihara potential
12777 C E=4esp*((sigma/(r-r0))^12 - (sigma/(r-r0))^6)
12778 C 4eps is depth of well sigma is r_minimum r is distance from center of tube
12779 C and r0 is the excluded size of nanotube (can be set to 0 if we want just a
12780 C simple Kihara potential
12781       subroutine calctube2(Etube)
12782        implicit real*8 (a-h,o-z)
12783       include 'DIMENSIONS'
12784       include 'COMMON.GEO'
12785       include 'COMMON.VAR'
12786       include 'COMMON.LOCAL'
12787       include 'COMMON.CHAIN'
12788       include 'COMMON.DERIV'
12789       include 'COMMON.NAMES'
12790       include 'COMMON.INTERACT'
12791       include 'COMMON.IOUNITS'
12792       include 'COMMON.CALC'
12793       include 'COMMON.CONTROL'
12794       include 'COMMON.SPLITELE'
12795       include 'COMMON.SBRIDGE'
12796       double precision tub_r,vectube(3),enetube(maxres*2)
12797       Etube=0.0d0
12798       do i=1,2*nres
12799         enetube(i)=0.0d0
12800       enddo
12801 C first we calculate the distance from tube center
12802 C first sugare-phosphate group for NARES this would be peptide group
12803 C for UNRES
12804       do i=1,nres
12805 C lets ommit dummy atoms for now
12806        if ((itype(i).eq.ntyp1).or.(itype(i+1).eq.ntyp1)) cycle
12807 C now calculate distance from center of tube and direction vectors
12808       vectube(1)=mod((c(1,i)+c(1,i+1))/2.0d0,boxxsize)
12809           if (vectube(1).lt.0) vectube(1)=vectube(1)+boxxsize
12810       vectube(2)=mod((c(2,i)+c(2,i+1))/2.0d0,boxxsize)
12811           if (vectube(2).lt.0) vectube(2)=vectube(2)+boxxsize
12812       vectube(1)=vectube(1)-tubecenter(1)
12813       vectube(2)=vectube(2)-tubecenter(2)
12814
12815 C      print *,"x",(c(1,i)+c(1,i+1))/2.0d0,tubecenter(1)
12816 C      print *,"y",(c(2,i)+c(2,i+1))/2.0d0,tubecenter(2)
12817
12818 C as the tube is infinity we do not calculate the Z-vector use of Z
12819 C as chosen axis
12820       vectube(3)=0.0d0
12821 C now calculte the distance
12822        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
12823 C now normalize vector
12824       vectube(1)=vectube(1)/tub_r
12825       vectube(2)=vectube(2)/tub_r
12826 C calculte rdiffrence between r and r0
12827       rdiff=tub_r-tubeR0
12828 C and its 6 power
12829       rdiff6=rdiff**6.0d0
12830 C for vectorization reasons we will sumup at the end to avoid depenence of previous
12831        enetube(i)=pep_aa_tube/rdiff6**2.0d0-pep_bb_tube/rdiff6
12832 C       write(iout,*) "TU13",i,rdiff6,enetube(i)
12833 C       print *,rdiff,rdiff6,pep_aa_tube
12834 C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
12835 C now we calculate gradient
12836        fac=(-12.0d0*pep_aa_tube/rdiff6+
12837      &       6.0d0*pep_bb_tube)/rdiff6/rdiff
12838 C       write(iout,'(a5,i4,f12.1,3f12.5)') "TU13",i,rdiff6,enetube(i),
12839 C     &rdiff,fac
12840
12841 C now direction of gg_tube vector
12842         do j=1,3
12843         gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac/2.0d0
12844         gg_tube(j,i)=gg_tube(j,i)+vectube(j)*fac/2.0d0
12845         enddo
12846         enddo
12847 C basically thats all code now we split for side-chains (REMEMBER to sum up at the END)
12848         do i=1,nres
12849 C Lets not jump over memory as we use many times iti
12850          iti=itype(i)
12851 C lets ommit dummy atoms for now
12852          if ((iti.eq.ntyp1)
12853 C in UNRES uncomment the line below as GLY has no side-chain...
12854      &      .or.(iti.eq.10)
12855      &   ) cycle
12856           vectube(1)=c(1,i+nres)
12857           vectube(1)=mod(vectube(1),boxxsize)
12858           if (vectube(1).lt.0) vectube(1)=vectube(1)+boxxsize
12859           vectube(2)=c(2,i+nres)
12860           vectube(2)=mod(vectube(2),boxxsize)
12861           if (vectube(2).lt.0) vectube(2)=vectube(2)+boxxsize
12862
12863       vectube(1)=vectube(1)-tubecenter(1)
12864       vectube(2)=vectube(2)-tubecenter(2)
12865 C THIS FRAGMENT MAKES TUBE FINITE
12866         positi=(mod(c(3,i+nres),boxzsize))
12867         if (positi.le.0) positi=positi+boxzsize
12868 C       print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop
12869 c for each residue check if it is in lipid or lipid water border area
12870 C       respos=mod(c(3,i+nres),boxzsize)
12871        print *,positi,bordtubebot,buftubebot,bordtubetop
12872        if ((positi.gt.bordtubebot)
12873      & .and.(positi.lt.bordtubetop)) then
12874 C the energy transfer exist
12875         if (positi.lt.buftubebot) then
12876          fracinbuf=1.0d0-
12877      &     ((positi-bordtubebot)/tubebufthick)
12878 C lipbufthick is thickenes of lipid buffore
12879          sstube=sscalelip(fracinbuf)
12880          ssgradtube=-sscagradlip(fracinbuf)/tubebufthick
12881          print *,ssgradtube, sstube,tubetranene(itype(i))
12882          enetube(i+nres)=enetube(i+nres)+sstube*tubetranene(itype(i))
12883          gg_tube_SC(3,i)=gg_tube_SC(3,i)
12884      &+ssgradtube*tubetranene(itype(i))
12885          gg_tube(3,i-1)= gg_tube(3,i-1)
12886      &+ssgradtube*tubetranene(itype(i))
12887 C         print *,"doing sccale for lower part"
12888         elseif (positi.gt.buftubetop) then
12889          fracinbuf=1.0d0-
12890      &((bordtubetop-positi)/tubebufthick)
12891          sstube=sscalelip(fracinbuf)
12892          ssgradtube=sscagradlip(fracinbuf)/tubebufthick
12893          enetube(i+nres)=enetube(i+nres)+sstube*tubetranene(itype(i))
12894 C         gg_tube_SC(3,i)=gg_tube_SC(3,i)
12895 C     &+ssgradtube*tubetranene(itype(i))
12896 C         gg_tube(3,i-1)= gg_tube(3,i-1)
12897 C     &+ssgradtube*tubetranene(itype(i))
12898 C          print *, "doing sscalefor top part",sslip,fracinbuf
12899         else
12900          sstube=1.0d0
12901          ssgradtube=0.0d0
12902          enetube(i+nres)=enetube(i+nres)+sstube*tubetranene(itype(i))
12903 C         print *,"I am in true lipid"
12904         endif
12905         else
12906 C          sstube=0.0d0
12907 C          ssgradtube=0.0d0
12908         cycle
12909         endif ! if in lipid or buffor
12910 CEND OF FINITE FRAGMENT
12911 C as the tube is infinity we do not calculate the Z-vector use of Z
12912 C as chosen axis
12913       vectube(3)=0.0d0
12914 C now calculte the distance
12915        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
12916 C now normalize vector
12917       vectube(1)=vectube(1)/tub_r
12918       vectube(2)=vectube(2)/tub_r
12919 C calculte rdiffrence between r and r0
12920       rdiff=tub_r-tubeR0
12921 C and its 6 power
12922       rdiff6=rdiff**6.0d0
12923 C for vectorization reasons we will sumup at the end to avoid depenence of previous
12924        sc_aa_tube=sc_aa_tube_par(iti)
12925        sc_bb_tube=sc_bb_tube_par(iti)
12926        enetube(i+nres)=(sc_aa_tube/rdiff6**2.0d0-sc_bb_tube/rdiff6)
12927      &                 *sstube+enetube(i+nres)
12928 C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
12929 C now we calculate gradient
12930        fac=(-12.0d0*sc_aa_tube/rdiff6**2.0d0/rdiff+
12931      &       6.0d0*sc_bb_tube/rdiff6/rdiff)*sstube
12932 C now direction of gg_tube vector
12933          do j=1,3
12934           gg_tube_SC(j,i)=gg_tube_SC(j,i)+vectube(j)*fac
12935           gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac
12936          enddo
12937          gg_tube_SC(3,i)=gg_tube_SC(3,i)
12938      &+ssgradtube*enetube(i+nres)/sstube
12939          gg_tube(3,i-1)= gg_tube(3,i-1)
12940      &+ssgradtube*enetube(i+nres)/sstube
12941
12942         enddo
12943         do i=1,2*nres
12944           Etube=Etube+enetube(i)
12945         enddo
12946 C        print *,"ETUBE", etube
12947         return
12948         end
12949 C TO DO 1) add to total energy
12950 C       2) add to gradient summation
12951 C       3) add reading parameters (AND of course oppening of PARAM file)
12952 C       4) add reading the center of tube
12953 C       5) add COMMONs
12954 C       6) add to zerograd
12955 c----------------------------------------------------------------------------
12956       subroutine e_saxs(Esaxs_constr)
12957       implicit none
12958       include 'DIMENSIONS'
12959 #ifdef MPI
12960       include "mpif.h"
12961       include "COMMON.SETUP"
12962       integer IERR
12963 #endif
12964       include 'COMMON.SBRIDGE'
12965       include 'COMMON.CHAIN'
12966       include 'COMMON.GEO'
12967       include 'COMMON.DERIV'
12968       include 'COMMON.LOCAL'
12969       include 'COMMON.INTERACT'
12970       include 'COMMON.VAR'
12971       include 'COMMON.IOUNITS'
12972       include 'COMMON.MD'
12973       include 'COMMON.CONTROL'
12974       include 'COMMON.NAMES'
12975       include 'COMMON.TIME1'
12976       include 'COMMON.FFIELD'
12977 c
12978       double precision Esaxs_constr
12979       integer i,iint,j,k,l
12980       double precision PgradC(maxSAXS,3,maxres),
12981      &  PgradX(maxSAXS,3,maxres),Pcalc(maxSAXS)
12982 #ifdef MPI
12983       double precision PgradC_(maxSAXS,3,maxres),
12984      &  PgradX_(maxSAXS,3,maxres),Pcalc_(maxSAXS)
12985 #endif
12986       double precision dk,dijCACA,dijCASC,dijSCCA,dijSCSC,
12987      & sigma2CACA,sigma2CASC,sigma2SCCA,sigma2SCSC,expCACA,expCASC,
12988      & expSCCA,expSCSC,CASCgrad,SCCAgrad,SCSCgrad,aux,auxC,auxC1,
12989      & auxX,auxX1,CACAgrad,Cnorm,sigmaCACA,threesig
12990       double precision sss2,ssgrad2,rrr,sscalgrad2,sscale2
12991       double precision dist,mygauss,mygaussder
12992       external dist
12993       integer llicz,lllicz
12994       double precision time01
12995 c  SAXS restraint penalty function
12996 #ifdef DEBUG
12997       write(iout,*) "------- SAXS penalty function start -------"
12998       write (iout,*) "nsaxs",nsaxs
12999       write (iout,*) "Esaxs: iatsc_s",iatsc_s," iatsc_e",iatsc_e
13000       write (iout,*) "Psaxs"
13001       do i=1,nsaxs
13002         write (iout,'(i5,e15.5)') i, Psaxs(i)
13003       enddo
13004 #endif
13005 #ifdef TIMING
13006       time01=MPI_Wtime()
13007 #endif
13008       Esaxs_constr = 0.0d0
13009       do k=1,nsaxs
13010         Pcalc(k)=0.0d0
13011         do j=1,nres
13012           do l=1,3
13013             PgradC(k,l,j)=0.0d0
13014             PgradX(k,l,j)=0.0d0
13015           enddo
13016         enddo
13017       enddo
13018 c      lllicz=0
13019       do i=iatsc_s,iatsc_e
13020        if (itype(i).eq.ntyp1) cycle
13021        do iint=1,nint_gr(i)
13022          do j=istart(i,iint),iend(i,iint)
13023            if (itype(j).eq.ntyp1) cycle
13024 #ifdef ALLSAXS
13025            dijCACA=dist(i,j)
13026            dijCASC=dist(i,j+nres)
13027            dijSCCA=dist(i+nres,j)
13028            dijSCSC=dist(i+nres,j+nres)
13029            sigma2CACA=2.0d0/(pstok**2)
13030            sigma2CASC=4.0d0/(pstok**2+restok(itype(j))**2)
13031            sigma2SCCA=4.0d0/(pstok**2+restok(itype(i))**2)
13032            sigma2SCSC=4.0d0/(restok(itype(j))**2+restok(itype(i))**2)
13033            do k=1,nsaxs
13034              dk = distsaxs(k)
13035              expCACA = dexp(-0.5d0*sigma2CACA*(dijCACA-dk)**2)
13036              if (itype(j).ne.10) then
13037              expCASC = dexp(-0.5d0*sigma2CASC*(dijCASC-dk)**2)
13038              else
13039              endif
13040              expCASC = 0.0d0
13041              if (itype(i).ne.10) then
13042              expSCCA = dexp(-0.5d0*sigma2SCCA*(dijSCCA-dk)**2)
13043              else
13044              expSCCA = 0.0d0
13045              endif
13046              if (itype(i).ne.10 .and. itype(j).ne.10) then
13047              expSCSC = dexp(-0.5d0*sigma2SCSC*(dijSCSC-dk)**2)
13048              else
13049              expSCSC = 0.0d0
13050              endif
13051              Pcalc(k) = Pcalc(k)+expCACA+expCASC+expSCCA+expSCSC
13052 #ifdef DEBUG
13053              write(iout,*) "i j k Pcalc",i,j,Pcalc(k)
13054 #endif
13055              CACAgrad = sigma2CACA*(dijCACA-dk)*expCACA
13056              CASCgrad = sigma2CASC*(dijCASC-dk)*expCASC
13057              SCCAgrad = sigma2SCCA*(dijSCCA-dk)*expSCCA
13058              SCSCgrad = sigma2SCSC*(dijSCSC-dk)*expSCSC
13059              do l=1,3
13060 c CA CA
13061                aux = CACAgrad*(C(l,j)-C(l,i))/dijCACA
13062                PgradC(k,l,i) = PgradC(k,l,i)-aux
13063                PgradC(k,l,j) = PgradC(k,l,j)+aux
13064 c CA SC
13065                if (itype(j).ne.10) then
13066                aux = CASCgrad*(C(l,j+nres)-C(l,i))/dijCASC
13067                PgradC(k,l,i) = PgradC(k,l,i)-aux
13068                PgradC(k,l,j) = PgradC(k,l,j)+aux
13069                PgradX(k,l,j) = PgradX(k,l,j)+aux
13070                endif
13071 c SC CA
13072                if (itype(i).ne.10) then
13073                aux = SCCAgrad*(C(l,j)-C(l,i+nres))/dijSCCA
13074                PgradX(k,l,i) = PgradX(k,l,i)-aux
13075                PgradC(k,l,i) = PgradC(k,l,i)-aux
13076                PgradC(k,l,j) = PgradC(k,l,j)+aux
13077                endif
13078 c SC SC
13079                if (itype(i).ne.10 .and. itype(j).ne.10) then
13080                aux = SCSCgrad*(C(l,j+nres)-C(l,i+nres))/dijSCSC
13081                PgradC(k,l,i) = PgradC(k,l,i)-aux
13082                PgradC(k,l,j) = PgradC(k,l,j)+aux
13083                PgradX(k,l,i) = PgradX(k,l,i)-aux
13084                PgradX(k,l,j) = PgradX(k,l,j)+aux
13085                endif
13086              enddo ! l
13087            enddo ! k
13088 #else
13089            dijCACA=dist(i,j)
13090            sigma2CACA=scal_rad**2*0.25d0/
13091      &        (restok(itype(j))**2+restok(itype(i))**2)
13092 c           write (iout,*) "scal_rad",scal_rad," restok",restok(itype(j))
13093 c     &       ,restok(itype(i)),"sigma",1.0d0/dsqrt(sigma2CACA)
13094 #ifdef MYGAUSS
13095            sigmaCACA=dsqrt(sigma2CACA)
13096            threesig=3.0d0/sigmaCACA
13097 c           llicz=0
13098            do k=1,nsaxs
13099              dk = distsaxs(k)
13100              if (dabs(dijCACA-dk).ge.threesig) cycle
13101 c             llicz=llicz+1
13102 c             lllicz=lllicz+1
13103              aux = sigmaCACA*(dijCACA-dk)
13104              expCACA = mygauss(aux)
13105 c             if (expcaca.eq.0.0d0) cycle
13106              Pcalc(k) = Pcalc(k)+expCACA
13107              CACAgrad = -sigmaCACA*mygaussder(aux)
13108 c             write (iout,*) "i,j,k,aux",i,j,k,CACAgrad
13109              do l=1,3
13110                aux = CACAgrad*(C(l,j)-C(l,i))/dijCACA
13111                PgradC(k,l,i) = PgradC(k,l,i)-aux
13112                PgradC(k,l,j) = PgradC(k,l,j)+aux
13113              enddo ! l
13114            enddo ! k
13115 c           write (iout,*) "i",i," j",j," llicz",llicz
13116 #else
13117            IF (saxs_cutoff.eq.0) THEN
13118            do k=1,nsaxs
13119              dk = distsaxs(k)
13120              expCACA = dexp(-0.5d0*sigma2CACA*(dijCACA-dk)**2)
13121              Pcalc(k) = Pcalc(k)+expCACA
13122              CACAgrad = sigma2CACA*(dijCACA-dk)*expCACA
13123              do l=1,3
13124                aux = CACAgrad*(C(l,j)-C(l,i))/dijCACA
13125                PgradC(k,l,i) = PgradC(k,l,i)-aux
13126                PgradC(k,l,j) = PgradC(k,l,j)+aux
13127              enddo ! l
13128            enddo ! k
13129            ELSE
13130            rrr = saxs_cutoff*2.0d0/dsqrt(sigma2CACA)
13131            do k=1,nsaxs
13132              dk = distsaxs(k)
13133 c             write (2,*) "ijk",i,j,k
13134              sss2 = sscale2(dijCACA,rrr,dk,0.3d0)
13135              if (sss2.eq.0.0d0) cycle
13136              ssgrad2 = sscalgrad2(dijCACA,rrr,dk,0.3d0)
13137              if (energy_dec) write(iout,'(a4,3i5,8f10.4)')
13138      &          'saxs',i,j,k,dijCACA,restok(itype(i)),restok(itype(j)),
13139      &          1.0d0/dsqrt(sigma2CACA),rrr,dk,
13140      &           sss2,ssgrad2
13141              expCACA = dexp(-0.5d0*sigma2CACA*(dijCACA-dk)**2)*sss2
13142              Pcalc(k) = Pcalc(k)+expCACA
13143 #ifdef DEBUG
13144              write(iout,*) "i j k Pcalc",i,j,Pcalc(k)
13145 #endif
13146              CACAgrad = -sigma2CACA*(dijCACA-dk)*expCACA+
13147      &             ssgrad2*expCACA/sss2
13148              do l=1,3
13149 c CA CA
13150                aux = CACAgrad*(C(l,j)-C(l,i))/dijCACA
13151                PgradC(k,l,i) = PgradC(k,l,i)+aux
13152                PgradC(k,l,j) = PgradC(k,l,j)-aux
13153              enddo ! l
13154            enddo ! k
13155            ENDIF
13156 #endif
13157 #endif
13158          enddo ! j
13159        enddo ! iint
13160       enddo ! i
13161 c#ifdef TIMING
13162 c      time_SAXS=time_SAXS+MPI_Wtime()-time01
13163 c#endif
13164 c      write (iout,*) "lllicz",lllicz
13165 c#ifdef TIMING
13166 c      time01=MPI_Wtime()
13167 c#endif
13168 #ifdef MPI
13169       if (nfgtasks.gt.1) then
13170        call MPI_AllReduce(Pcalc(1),Pcalc_(1),nsaxs,MPI_DOUBLE_PRECISION,
13171      &    MPI_SUM,FG_COMM,IERR)
13172 c        if (fg_rank.eq.king) then
13173           do k=1,nsaxs
13174             Pcalc(k) = Pcalc_(k)
13175           enddo
13176 c        endif
13177 c        call MPI_AllReduce(PgradC(k,1,1),PgradC_(k,1,1),3*maxsaxs*nres,
13178 c     &    MPI_DOUBLE_PRECISION,MPI_SUM,FG_COMM,IERR)
13179 c        if (fg_rank.eq.king) then
13180 c          do i=1,nres
13181 c            do l=1,3
13182 c              do k=1,nsaxs
13183 c                PgradC(k,l,i) = PgradC_(k,l,i)
13184 c              enddo
13185 c            enddo
13186 c          enddo
13187 c        endif
13188 #ifdef ALLSAXS
13189 c        call MPI_AllReduce(PgradX(k,1,1),PgradX_(k,1,1),3*maxsaxs*nres,
13190 c     &    MPI_DOUBLE_PRECISION,MPI_SUM,FG_COMM,IERR)
13191 c        if (fg_rank.eq.king) then
13192 c          do i=1,nres
13193 c            do l=1,3
13194 c              do k=1,nsaxs
13195 c                PgradX(k,l,i) = PgradX_(k,l,i)
13196 c              enddo
13197 c            enddo
13198 c          enddo
13199 c        endif
13200 #endif
13201       endif
13202 #endif
13203       Cnorm = 0.0d0
13204       do k=1,nsaxs
13205         Cnorm = Cnorm + Pcalc(k)
13206       enddo
13207 #ifdef MPI
13208       if (fg_rank.eq.king) then
13209 #endif
13210       Esaxs_constr = dlog(Cnorm)-wsaxs0
13211       do k=1,nsaxs
13212         if (Pcalc(k).gt.0.0d0)
13213      &  Esaxs_constr = Esaxs_constr - Psaxs(k)*dlog(Pcalc(k))
13214 #ifdef DEBUG
13215         write (iout,*) "k",k," Esaxs_constr",Esaxs_constr
13216 #endif
13217       enddo
13218 #ifdef DEBUG
13219       write (iout,*) "Cnorm",Cnorm," Esaxs_constr",Esaxs_constr
13220 #endif
13221 #ifdef MPI
13222       endif
13223 #endif
13224       gsaxsC=0.0d0
13225       gsaxsX=0.0d0
13226       do i=nnt,nct
13227         do l=1,3
13228           auxC=0.0d0
13229           auxC1=0.0d0
13230           auxX=0.0d0
13231           auxX1=0.d0
13232           do k=1,nsaxs
13233             if (Pcalc(k).gt.0)
13234      &      auxC  = auxC +Psaxs(k)*PgradC(k,l,i)/Pcalc(k)
13235             auxC1 = auxC1+PgradC(k,l,i)
13236 #ifdef ALLSAXS
13237             auxX  = auxX +Psaxs(k)*PgradX(k,l,i)/Pcalc(k)
13238             auxX1 = auxX1+PgradX(k,l,i)
13239 #endif
13240           enddo
13241           gsaxsC(l,i) = auxC - auxC1/Cnorm
13242 #ifdef ALLSAXS
13243           gsaxsX(l,i) = auxX - auxX1/Cnorm
13244 #endif
13245 c          write (iout,*) "l i",l,i," gradC",wsaxs*(auxC - auxC1/Cnorm),
13246 c     *     " gradX",wsaxs*(auxX - auxX1/Cnorm)
13247 c          write (iout,*) "l i",l,i," gradC",wsaxs*gsaxsC(l,i),
13248 c     *     " gradX",wsaxs*gsaxsX(l,i)
13249         enddo
13250       enddo
13251 #ifdef TIMING
13252       time_SAXS=time_SAXS+MPI_Wtime()-time01
13253 #endif
13254 #ifdef DEBUG
13255       write (iout,*) "gsaxsc"
13256       do i=nnt,nct
13257         write (iout,'(i5,3e15.5)') i,(gsaxsc(j,i),j=1,3)
13258       enddo
13259 #endif
13260 #ifdef MPI
13261 c      endif
13262 #endif
13263       return
13264       end
13265 c----------------------------------------------------------------------------
13266       subroutine e_saxsC(Esaxs_constr)
13267       implicit none
13268       include 'DIMENSIONS'
13269 #ifdef MPI
13270       include "mpif.h"
13271       include "COMMON.SETUP"
13272       integer IERR
13273 #endif
13274       include 'COMMON.SBRIDGE'
13275       include 'COMMON.CHAIN'
13276       include 'COMMON.GEO'
13277       include 'COMMON.DERIV'
13278       include 'COMMON.LOCAL'
13279       include 'COMMON.INTERACT'
13280       include 'COMMON.VAR'
13281       include 'COMMON.IOUNITS'
13282       include 'COMMON.MD'
13283       include 'COMMON.CONTROL'
13284       include 'COMMON.NAMES'
13285       include 'COMMON.TIME1'
13286       include 'COMMON.FFIELD'
13287 c
13288       double precision Esaxs_constr
13289       integer i,iint,j,k,l
13290       double precision PgradC(3,maxres),PgradX(3,maxres),Pcalc,logPtot
13291 #ifdef MPI
13292       double precision gsaxsc_(3,maxres),gsaxsx_(3,maxres),logPtot_
13293 #endif
13294       double precision dk,dijCASPH,dijSCSPH,
13295      & sigma2CA,sigma2SC,expCASPH,expSCSPH,
13296      & CASPHgrad,SCSPHgrad,aux,auxC,auxC1,
13297      & auxX,auxX1,Cnorm
13298 c  SAXS restraint penalty function
13299 #ifdef DEBUG
13300       write(iout,*) "------- SAXS penalty function start -------"
13301       write (iout,*) "nsaxs",nsaxs
13302
13303       do i=nnt,nct
13304         print *,MyRank,"C",i,(C(j,i),j=1,3)
13305       enddo
13306       do i=nnt,nct
13307         print *,MyRank,"CSaxs",i,(Csaxs(j,i),j=1,3)
13308       enddo
13309 #endif
13310       Esaxs_constr = 0.0d0
13311       logPtot=0.0d0
13312       do j=isaxs_start,isaxs_end
13313         Pcalc=0.0d0
13314         do i=1,nres
13315           do l=1,3
13316             PgradC(l,i)=0.0d0
13317             PgradX(l,i)=0.0d0
13318           enddo
13319         enddo
13320         do i=nnt,nct
13321           if (itype(i).eq.ntyp1) cycle
13322           dijCASPH=0.0d0
13323           dijSCSPH=0.0d0
13324           do l=1,3
13325             dijCASPH=dijCASPH+(C(l,i)-Csaxs(l,j))**2
13326           enddo
13327           if (itype(i).ne.10) then
13328           do l=1,3
13329             dijSCSPH=dijSCSPH+(C(l,i+nres)-Csaxs(l,j))**2
13330           enddo
13331           endif
13332           sigma2CA=2.0d0/pstok**2
13333           sigma2SC=4.0d0/restok(itype(i))**2
13334           expCASPH = dexp(-0.5d0*sigma2CA*dijCASPH)
13335           expSCSPH = dexp(-0.5d0*sigma2SC*dijSCSPH)
13336           Pcalc = Pcalc+expCASPH+expSCSPH
13337 #ifdef DEBUG
13338           write(*,*) "processor i j Pcalc",
13339      &       MyRank,i,j,dijCASPH,dijSCSPH, Pcalc
13340 #endif
13341           CASPHgrad = sigma2CA*expCASPH
13342           SCSPHgrad = sigma2SC*expSCSPH
13343           do l=1,3
13344             aux = (C(l,i+nres)-Csaxs(l,j))*SCSPHgrad
13345             PgradX(l,i) = PgradX(l,i) + aux
13346             PgradC(l,i) = PgradC(l,i)+(C(l,i)-Csaxs(l,j))*CASPHgrad+aux
13347           enddo ! l
13348         enddo ! i
13349         do i=nnt,nct
13350           do l=1,3
13351             gsaxsc(l,i)=gsaxsc(l,i)+PgradC(l,i)/Pcalc
13352             gsaxsx(l,i)=gsaxsx(l,i)+PgradX(l,i)/Pcalc
13353           enddo
13354         enddo
13355         logPtot = logPtot - dlog(Pcalc)
13356 c        print *,"me",me,MyRank," j",j," logPcalc",-dlog(Pcalc),
13357 c     &    " logPtot",logPtot
13358       enddo ! j
13359 #ifdef MPI
13360       if (nfgtasks.gt.1) then
13361 c        write (iout,*) "logPtot before reduction",logPtot
13362         call MPI_Reduce(logPtot,logPtot_,1,MPI_DOUBLE_PRECISION,
13363      &    MPI_SUM,king,FG_COMM,IERR)
13364         logPtot = logPtot_
13365 c        write (iout,*) "logPtot after reduction",logPtot
13366         call MPI_Reduce(gsaxsC(1,1),gsaxsC_(1,1),3*nres,
13367      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
13368         if (fg_rank.eq.king) then
13369           do i=1,nres
13370             do l=1,3
13371               gsaxsC(l,i) = gsaxsC_(l,i)
13372             enddo
13373           enddo
13374         endif
13375         call MPI_Reduce(gsaxsX(1,1),gsaxsX_(1,1),3*nres,
13376      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
13377         if (fg_rank.eq.king) then
13378           do i=1,nres
13379             do l=1,3
13380               gsaxsX(l,i) = gsaxsX_(l,i)
13381             enddo
13382           enddo
13383         endif
13384       endif
13385 #endif
13386       Esaxs_constr = logPtot
13387       return
13388       end
13389 c----------------------------------------------------------------------------
13390       double precision function sscale2(r,r_cut,r0,rlamb)
13391       implicit none
13392       double precision r,gamm,r_cut,r0,rlamb,rr
13393       rr = dabs(r-r0)
13394 c      write (2,*) "r",r," r_cut",r_cut," r0",r0," rlamb",rlamb
13395 c      write (2,*) "rr",rr
13396       if(rr.lt.r_cut-rlamb) then
13397         sscale2=1.0d0
13398       else if(rr.le.r_cut.and.rr.ge.r_cut-rlamb) then
13399         gamm=(rr-(r_cut-rlamb))/rlamb
13400         sscale2=1.0d0+gamm*gamm*(2*gamm-3.0d0)
13401       else
13402         sscale2=0d0
13403       endif
13404       return
13405       end
13406 C-----------------------------------------------------------------------
13407       double precision function sscalgrad2(r,r_cut,r0,rlamb)
13408       implicit none
13409       double precision r,gamm,r_cut,r0,rlamb,rr
13410       rr = dabs(r-r0)
13411       if(rr.lt.r_cut-rlamb) then
13412         sscalgrad2=0.0d0
13413       else if(rr.le.r_cut.and.rr.ge.r_cut-rlamb) then
13414         gamm=(rr-(r_cut-rlamb))/rlamb
13415         if (r.ge.r0) then
13416           sscalgrad2=gamm*(6*gamm-6.0d0)/rlamb
13417         else
13418           sscalgrad2=-gamm*(6*gamm-6.0d0)/rlamb
13419         endif
13420       else
13421         sscalgrad2=0.0d0
13422       endif
13423       return
13424       end