source/unres/src_MD-M/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 #ifdef MPI
  29 c      print*,"ETOTAL Processor",fg_rank," absolute rank",myrank,
  30 c     & " nfgtasks",nfgtasks
  31       if (nfgtasks.gt.1) then
  32         time00=MPI_Wtime()
  33 C FG slaves call the following matching MPI_Bcast in ERGASTULUM
  34         if (fg_rank.eq.0) then
  35           call MPI_Bcast(0,1,MPI_INTEGER,king,FG_COMM,IERROR)
  36 c          print *,"Processor",myrank," BROADCAST iorder"
  37 C FG master sets up the WEIGHTS_ array which will be broadcast to the
  38 C FG slaves as WEIGHTS array.
  39           weights_(1)=wsc
  40           weights_(2)=wscp
  41           weights_(3)=welec
  42           weights_(4)=wcorr
  43           weights_(5)=wcorr5
  44           weights_(6)=wcorr6
  45           weights_(7)=wel_loc
  46           weights_(8)=wturn3
  47           weights_(9)=wturn4
  48           weights_(10)=wturn6
  49           weights_(11)=wang
  50           weights_(12)=wscloc
  51           weights_(13)=wtor
  52           weights_(14)=wtor_d
  53           weights_(15)=wstrain
  54           weights_(16)=wvdwpp
  55           weights_(17)=wbond
  56           weights_(18)=scal14
  57           weights_(21)=wsccor
  58           weights_(25)=wsaxs
  59 C FG Master broadcasts the WEIGHTS_ array
  60           call MPI_Bcast(weights_(1),n_ene,
  61      &        MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
  62         else
  63 C FG slaves receive the WEIGHTS array
  64           call MPI_Bcast(weights(1),n_ene,
  65      &        MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
  66           wsc=weights(1)
  67           wscp=weights(2)
  68           welec=weights(3)
  69           wcorr=weights(4)
  70           wcorr5=weights(5)
  71           wcorr6=weights(6)
  72           wel_loc=weights(7)
  73           wturn3=weights(8)
  74           wturn4=weights(9)
  75           wturn6=weights(10)
  76           wang=weights(11)
  77           wscloc=weights(12)
  78           wtor=weights(13)
  79           wtor_d=weights(14)
  80           wstrain=weights(15)
  81           wvdwpp=weights(16)
  82           wbond=weights(17)
  83           scal14=weights(18)
  84           wsccor=weights(21)
  85           wsaxs=weights(25)
  86         endif
  87         time_Bcast=time_Bcast+MPI_Wtime()-time00
  88         time_Bcastw=time_Bcastw+MPI_Wtime()-time00
  89 c        call chainbuild_cart
  90       endif
  91 c      print *,'Processor',myrank,' calling etotal ipot=',ipot
  92 c      print *,'Processor',myrank,' nnt=',nnt,' nct=',nct
  93 #else
  94 c      if (modecalc.eq.12.or.modecalc.eq.14) then
  95 c        call int_from_cart1(.false.)
  96 c      endif
  97 #endif
  98 #ifdef TIMING
  99       time00=MPI_Wtime()
 100 #endif
 101 C
 102 C Compute the side-chain and electrostatic interaction energy
 103 C
 104 C      print *,ipot
 105       goto (101,102,103,104,105,106) ipot
 106 C Lennard-Jones potential.
 107   101 call elj(evdw)
 108 cd    print '(a)','Exit ELJ'
 109       goto 107
 110 C Lennard-Jones-Kihara potential (shifted).
 111   102 call eljk(evdw)
 112       goto 107
 113 C Berne-Pechukas potential (dilated LJ, angular dependence).
 114   103 call ebp(evdw)
 115       goto 107
 116 C Gay-Berne potential (shifted LJ, angular dependence).
 117   104 call egb(evdw)
 118 C      print *,"bylem w egb"
 119       goto 107
 120 C Gay-Berne-Vorobjev potential (shifted LJ, angular dependence).
 121   105 call egbv(evdw)
 122       goto 107
 123 C Soft-sphere potential
 124   106 call e_softsphere(evdw)
 125 C
 126 C Calculate electrostatic (H-bonding) energy of the main chain.
 127 C
 128   107 continue
 129 cmc
 130 cmc Sep-06: egb takes care of dynamic ss bonds too
 131 cmc
 132 c      if (dyn_ss) call dyn_set_nss
 133
 134 c      print *,"Processor",myrank," computed USCSC"
 135 #ifdef TIMING
 136       time01=MPI_Wtime()
 137 #endif
 138       call vec_and_deriv
 139 #ifdef TIMING
 140       time_vec=time_vec+MPI_Wtime()-time01
 141 #endif
 142 c      print *,"Processor",myrank," left VEC_AND_DERIV"
 143       if (ipot.lt.6) then
 144 #ifdef SPLITELE
 145          if (welec.gt.0d0.or.wvdwpp.gt.0d0.or.wel_loc.gt.0d0.or.
 146      &       wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0
 147      &       .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0
 148      &       .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
 149 #else
 150          if (welec.gt.0d0.or.wel_loc.gt.0d0.or.
 151      &       wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0
 152      &       .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0
 153      &       .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
 154 #endif
 155             call eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
 156          else
 157             ees=0.0d0
 158             evdw1=0.0d0
 159             eel_loc=0.0d0
 160             eello_turn3=0.0d0
 161             eello_turn4=0.0d0
 162          endif
 163       else
 164         write (iout,*) "Soft-spheer ELEC potential"
 165         call eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,
 166      &   eello_turn4)
 167       endif
 168 c      print *,"Processor",myrank," computed UELEC"
 169 C
 170 C Calculate excluded-volume interaction energy between peptide groups
 171 C and side chains.
 172 C
 173       if (ipot.lt.6) then
 174        if(wscp.gt.0d0) then
 175         call escp(evdw2,evdw2_14)
 176        else
 177         evdw2=0
 178         evdw2_14=0
 179        endif
 180       else
 181 c        write (iout,*) "Soft-sphere SCP potential"
 182         call escp_soft_sphere(evdw2,evdw2_14)
 183       endif
 184 c
 185 c Calculate the bond-stretching energy
 186 c
 187       call ebond(estr)
 188 C
 189 C Calculate the disulfide-bridge and other energy and the contributions
 190 C from other distance constraints.
 191 cd    print *,'Calling EHPB'
 192       call edis(ehpb)
 193 cd    print *,'EHPB exitted succesfully.'
 194 C
 195 C Calculate the virtual-bond-angle energy.
 196 C
 197       if (wang.gt.0d0) then
 198         call ebend(ebe)
 199       else
 200         ebe=0
 201       endif
 202 c      print *,"Processor",myrank," computed UB"
 203 C
 204 C Calculate the SC local energy.
 205 C
 206 C      print *,"TU DOCHODZE?"
 207       call esc(escloc)
 208 c      print *,"Processor",myrank," computed USC"
 209 C
 210 C Calculate the virtual-bond torsional energy.
 211 C
 212 cd    print *,'nterm=',nterm
 213       if (wtor.gt.0) then
 214        call etor(etors,edihcnstr)
 215       else
 216        etors=0
 217        edihcnstr=0
 218       endif
 219
 220       if (constr_homology.ge.1) then
 221         call e_modeller(ehomology_constr)
 222 c        print *,'iset=',iset,'me=',me,ehomology_constr,
 223 c     &  'Processor',fg_rank,' CG group',kolor,
 224 c     &  ' absolute rank',MyRank
 225       else
 226         ehomology_constr=0.0d0
 227       endif
 228
 229
 230 c      write(iout,*) ehomology_constr
 231 c      print *,"Processor",myrank," computed Utor"
 232 C
 233 C 6/23/01 Calculate double-torsional energy
 234 C
 235       if (wtor_d.gt.0) then
 236        call etor_d(etors_d)
 237       else
 238        etors_d=0
 239       endif
 240 c      print *,"Processor",myrank," computed Utord"
 241 C
 242 C 21/5/07 Calculate local sicdechain correlation energy
 243 C
 244       if (wsccor.gt.0.0d0) then
 245         call eback_sc_corr(esccor)
 246       else
 247         esccor=0.0d0
 248       endif
 249 C      print *,"PRZED MULIt"
 250 c      print *,"Processor",myrank," computed Usccorr"
 251 C
 252 C 12/1/95 Multi-body terms
 253 C
 254       n_corr=0
 255       n_corr1=0
 256       if ((wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0
 257      &    .or. wturn6.gt.0.0d0) .and. ipot.lt.6) then
 258          call multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1)
 259 cd         write(2,*)'multibody_eello n_corr=',n_corr,' n_corr1=',n_corr1,
 260 cd     &" ecorr",ecorr," ecorr5",ecorr5," ecorr6",ecorr6," eturn6",eturn6
 261       else
 262          ecorr=0.0d0
 263          ecorr5=0.0d0
 264          ecorr6=0.0d0
 265          eturn6=0.0d0
 266       endif
 267       if ((wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) .and. ipot.lt.6) then
 268          call multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
 269 cd         write (iout,*) "multibody_hb ecorr",ecorr
 270       endif
 271 c      write (iout,*) "nsaxs",nsaxs," saxs_mode",saxs_mode
 272       if (nsaxs.gt.0 .and. saxs_mode.eq.0) then
 273         call e_saxs(Esaxs_constr)
 274 c        write (iout,*) "From Esaxs: Esaxs_constr",Esaxs_constr
 275       else if (nsaxs.gt.0 .and. saxs_mode.gt.0) then
 276         call e_saxsC(Esaxs_constr)
 277 c        write (iout,*) "From EsaxsC: Esaxs_constr",Esaxs_constr
 278       else
 279         Esaxs_constr = 0.0d0
 280       endif
 281 c      print *,"Processor",myrank," computed Ucorr"
 282 C
 283 C If performing constraint dynamics, call the constraint energy
 284 C  after the equilibration time
 285       if(usampl.and.totT.gt.eq_time) then
 286          call EconstrQ
 287          call Econstr_back
 288       else
 289          Uconst=0.0d0
 290          Uconst_back=0.0d0
 291       endif
 292 C 01/27/2015 added by adasko
 293 C the energy component below is energy transfer into lipid environment
 294 C based on partition function
 295 C      print *,"przed lipidami"
 296       if (wliptran.gt.0) then
 297         call Eliptransfer(eliptran)
 298       endif
 299 C      print *,"za lipidami"
 300       if (AFMlog.gt.0) then
 301         call AFMforce(Eafmforce)
 302       else if (selfguide.gt.0) then
 303         call AFMvel(Eafmforce)
 304       endif
 305 #ifdef TIMING
 306       time_enecalc=time_enecalc+MPI_Wtime()-time00
 307 #endif
 308 c      print *,"Processor",myrank," computed Uconstr"
 309 #ifdef TIMING
 310       time00=MPI_Wtime()
 311 #endif
 312 c
 313 C Sum the energies
 314 C
 315       energia(1)=evdw
 316 #ifdef SCP14
 317       energia(2)=evdw2-evdw2_14
 318       energia(18)=evdw2_14
 319 #else
 320       energia(2)=evdw2
 321       energia(18)=0.0d0
 322 #endif
 323 #ifdef SPLITELE
 324       energia(3)=ees
 325       energia(16)=evdw1
 326 #else
 327       energia(3)=ees+evdw1
 328       energia(16)=0.0d0
 329 #endif
 330       energia(4)=ecorr
 331       energia(5)=ecorr5
 332       energia(6)=ecorr6
 333       energia(7)=eel_loc
 334       energia(8)=eello_turn3
 335       energia(9)=eello_turn4
 336       energia(10)=eturn6
 337       energia(11)=ebe
 338       energia(12)=escloc
 339       energia(13)=etors
 340       energia(14)=etors_d
 341       energia(15)=ehpb
 342       energia(19)=edihcnstr
 343       energia(17)=estr
 344       energia(20)=Uconst+Uconst_back
 345       energia(21)=esccor
 346       energia(22)=eliptran
 347       energia(23)=Eafmforce
 348       energia(24)=ehomology_constr
 349       energia(25)=Esaxs_constr
 350 c    Here are the energies showed per procesor if the are more processors
 351 c    per molecule then we sum it up in sum_energy subroutine
 352 c      print *," Processor",myrank," calls SUM_ENERGY"
 353       call sum_energy(energia,.true.)
 354       if (dyn_ss) call dyn_set_nss
 355 c      print *," Processor",myrank," left SUM_ENERGY"
 356 #ifdef TIMING
 357       time_sumene=time_sumene+MPI_Wtime()-time00
 358 #endif
 359       return
 360       end
 361 c-------------------------------------------------------------------------------
 362       subroutine sum_energy(energia,reduce)
 363       implicit real*8 (a-h,o-z)
 364       include 'DIMENSIONS'
 365 #ifndef ISNAN
 366       external proc_proc
 367 #ifdef WINPGI
 368 cMS$ATTRIBUTES C ::  proc_proc
 369 #endif
 370 #endif
 371 #ifdef MPI
 372       include "mpif.h"
 373 #endif
 374       include 'COMMON.SETUP'
 375       include 'COMMON.IOUNITS'
 376       double precision energia(0:n_ene),enebuff(0:n_ene+1)
 377       include 'COMMON.FFIELD'
 378       include 'COMMON.DERIV'
 379       include 'COMMON.INTERACT'
 380       include 'COMMON.SBRIDGE'
 381       include 'COMMON.CHAIN'
 382       include 'COMMON.VAR'
 383       include 'COMMON.CONTROL'
 384       include 'COMMON.TIME1'
 385       logical reduce
 386 #ifdef MPI
 387       if (nfgtasks.gt.1 .and. reduce) then
 388 #ifdef DEBUG
 389         write (iout,*) "energies before REDUCE"
 390         call enerprint(energia)
 391         call flush(iout)
 392 #endif
 393         do i=0,n_ene
 394           enebuff(i)=energia(i)
 395         enddo
 396         time00=MPI_Wtime()
 397         call MPI_Barrier(FG_COMM,IERR)
 398         time_barrier_e=time_barrier_e+MPI_Wtime()-time00
 399         time00=MPI_Wtime()
 400         call MPI_Reduce(enebuff(0),energia(0),n_ene+1,
 401      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 402 #ifdef DEBUG
 403         write (iout,*) "energies after REDUCE"
 404         call enerprint(energia)
 405         call flush(iout)
 406 #endif
 407         time_Reduce=time_Reduce+MPI_Wtime()-time00
 408       endif
 409       if (fg_rank.eq.0) then
 410 #endif
 411       evdw=energia(1)
 412 #ifdef SCP14
 413       evdw2=energia(2)+energia(18)
 414       evdw2_14=energia(18)
 415 #else
 416       evdw2=energia(2)
 417 #endif
 418 #ifdef SPLITELE
 419       ees=energia(3)
 420       evdw1=energia(16)
 421 #else
 422       ees=energia(3)
 423       evdw1=0.0d0
 424 #endif
 425       ecorr=energia(4)
 426       ecorr5=energia(5)
 427       ecorr6=energia(6)
 428       eel_loc=energia(7)
 429       eello_turn3=energia(8)
 430       eello_turn4=energia(9)
 431       eturn6=energia(10)
 432       ebe=energia(11)
 433       escloc=energia(12)
 434       etors=energia(13)
 435       etors_d=energia(14)
 436       ehpb=energia(15)
 437       edihcnstr=energia(19)
 438       estr=energia(17)
 439       Uconst=energia(20)
 440       esccor=energia(21)
 441       eliptran=energia(22)
 442       Eafmforce=energia(23)
 443       ehomology_constr=energia(24)
 444       esaxs_constr=energia(25)
 445 c      write (iout,*) "sum_energy esaxs_constr",esaxs_constr,
 446 c     &  " wsaxs",wsaxs
 447 #ifdef SPLITELE
 448       etot=wsc*evdw+wscp*evdw2+welec*ees+wvdwpp*evdw1
 449      & +wang*ebe+wtor*etors+wscloc*escloc
 450      & +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5
 451      & +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3
 452      & +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d
 453      & +wbond*estr+Uconst+wsccor*esccor+ehomology_constr
 454      & +wsaxs*esaxs_constr+wliptran*eliptran+Eafmforce
 455 #else
 456       etot=wsc*evdw+wscp*evdw2+welec*(ees+evdw1)
 457      & +wang*ebe+wtor*etors+wscloc*escloc
 458      & +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5
 459      & +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3
 460      & +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d
 461      & +wbond*estr+Uconst+wsccor*esccor+ehomology_constr
 462      & +wsaxs*esaxs_constr+wliptran*eliptran
 463      & +Eafmforce
 464 #endif
 465       energia(0)=etot
 466 c detecting NaNQ
 467 #ifdef ISNAN
 468 #ifdef AIX
 469       if (isnan(etot).ne.0) energia(0)=1.0d+99
 470 #else
 471       if (isnan(etot)) energia(0)=1.0d+99
 472 #endif
 473 #else
 474       i=0
 475 #ifdef WINPGI
 476       idumm=proc_proc(etot,i)
 477 #else
 478       call proc_proc(etot,i)
 479 #endif
 480       if(i.eq.1)energia(0)=1.0d+99
 481 #endif
 482 #ifdef MPI
 483       endif
 484 #endif
 485       return
 486       end
 487 c-------------------------------------------------------------------------------
 488       subroutine sum_gradient
 489       implicit real*8 (a-h,o-z)
 490       include 'DIMENSIONS'
 491 #ifndef ISNAN
 492       external proc_proc
 493 #ifdef WINPGI
 494 cMS$ATTRIBUTES C ::  proc_proc
 495 #endif
 496 #endif
 497 #ifdef MPI
 498       include 'mpif.h'
 499 #endif
 500       double precision gradbufc(3,-1:maxres),gradbufx(3,-1:maxres),
 501      & glocbuf(4*maxres),gradbufc_sum(3,-1:maxres)
 502      & ,gloc_scbuf(3,-1:maxres)
 503       include 'COMMON.SETUP'
 504       include 'COMMON.IOUNITS'
 505       include 'COMMON.FFIELD'
 506       include 'COMMON.DERIV'
 507       include 'COMMON.INTERACT'
 508       include 'COMMON.SBRIDGE'
 509       include 'COMMON.CHAIN'
 510       include 'COMMON.VAR'
 511       include 'COMMON.CONTROL'
 512       include 'COMMON.TIME1'
 513       include 'COMMON.MAXGRAD'
 514       include 'COMMON.SCCOR'
 515       include 'COMMON.MD'
 516 #ifdef TIMING
 517       time01=MPI_Wtime()
 518 #endif
 519 #ifdef DEBUG
 520       write (iout,*) "sum_gradient gvdwc, gvdwx"
 521       do i=0,nres
 522         write (iout,'(i3,3e15.5,5x,3e15.5)')
 523      &   i,(gvdwx(j,i),j=1,3),(gvdwc(j,i),j=1,3)
 524       enddo
 525       call flush(iout)
 526 #endif
 527 #ifdef DEBUG
 528       write (iout,*) "sum_gradient gsaxsc, gsaxsx"
 529       do i=0,nres
 530         write (iout,'(i3,3e15.5,5x,3e15.5)')
 531      &   i,(gsaxsc(j,i),j=1,3),(gsaxsx(j,i),j=1,3)
 532       enddo
 533       call flush(iout)
 534 #endif
 535 #ifdef MPI
 536 C FG slaves call the following matching MPI_Bcast in ERGASTULUM
 537         if (nfgtasks.gt.1 .and. fg_rank.eq.0)
 538      &    call MPI_Bcast(1,1,MPI_INTEGER,king,FG_COMM,IERROR)
 539 #endif
 540 C
 541 C 9/29/08 AL Transform parts of gradients in site coordinates to the gradient
 542 C            in virtual-bond-vector coordinates
 543 C
 544 #ifdef DEBUG
 545 c      write (iout,*) "gel_loc gel_loc_long and gel_loc_loc"
 546 c      do i=1,nres-1
 547 c        write (iout,'(i5,3f10.5,2x,3f10.5,2x,f10.5)')
 548 c     &   i,(gel_loc(j,i),j=1,3),(gel_loc_long(j,i),j=1,3),gel_loc_loc(i)
 549 c      enddo
 550 c      write (iout,*) "gel_loc_tur3 gel_loc_turn4"
 551 c      do i=1,nres-1
 552 c        write (iout,'(i5,3f10.5,2x,f10.5)')
 553 c     &  i,(gcorr4_turn(j,i),j=1,3),gel_loc_turn4(i)
 554 c      enddo
 555       write (iout,*) "gradcorr5 gradcorr5_long gradcorr5_loc"
 556       do i=1,nres
 557         write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)')
 558      &   i,(gradcorr5(j,i),j=1,3),(gradcorr5_long(j,i),j=1,3),
 559      &   g_corr5_loc(i)
 560       enddo
 561       call flush(iout)
 562 #endif
 563 #ifdef SPLITELE
 564       do i=0,nct
 565         do j=1,3
 566           gradbufc(j,i)=wsc*gvdwc(j,i)+
 567      &                wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+
 568      &                welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+
 569      &                wel_loc*gel_loc_long(j,i)+
 570      &                wcorr*gradcorr_long(j,i)+
 571      &                wcorr5*gradcorr5_long(j,i)+
 572      &                wcorr6*gradcorr6_long(j,i)+
 573      &                wturn6*gcorr6_turn_long(j,i)+
 574      &                wstrain*ghpbc(j,i)+
 575      &                wsaxs*gsaxsc(j,i)
 576      &                +wliptran*gliptranc(j,i)
 577      &                +gradafm(j,i)
 578
 579         enddo
 580       enddo
 581 #else
 582       do i=0,nct
 583         do j=1,3
 584           gradbufc(j,i)=wsc*gvdwc(j,i)+
 585      &                wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+
 586      &                welec*gelc_long(j,i)+
 587      &                wbond*gradb(j,i)+
 588      &                wel_loc*gel_loc_long(j,i)+
 589      &                wcorr*gradcorr_long(j,i)+
 590      &                wcorr5*gradcorr5_long(j,i)+
 591      &                wcorr6*gradcorr6_long(j,i)+
 592      &                wturn6*gcorr6_turn_long(j,i)+
 593      &                wstrain*ghpbc(j,i)+
 594      &                wsaxs*gsaxsc(j,i)
 595      &                +wliptran*gliptranc(j,i)
 596      &                +gradafm(j,i)
 597
 598         enddo
 599       enddo
 600 #endif
 601 #ifdef MPI
 602       if (nfgtasks.gt.1) then
 603       time00=MPI_Wtime()
 604 #ifdef DEBUG
 605       write (iout,*) "gradbufc before allreduce"
 606       do i=1,nres
 607         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 608       enddo
 609       call flush(iout)
 610 #endif
 611       do i=0,nres
 612         do j=1,3
 613           gradbufc_sum(j,i)=gradbufc(j,i)
 614         enddo
 615       enddo
 616 c      call MPI_AllReduce(gradbufc(1,1),gradbufc_sum(1,1),3*nres,
 617 c     &    MPI_DOUBLE_PRECISION,MPI_SUM,FG_COMM,IERR)
 618 c      time_reduce=time_reduce+MPI_Wtime()-time00
 619 #ifdef DEBUG
 620 c      write (iout,*) "gradbufc_sum after allreduce"
 621 c      do i=1,nres
 622 c        write (iout,'(i3,3f10.5)') i,(gradbufc_sum(j,i),j=1,3)
 623 c      enddo
 624 c      call flush(iout)
 625 #endif
 626 #ifdef TIMING
 627 c      time_allreduce=time_allreduce+MPI_Wtime()-time00
 628 #endif
 629       do i=nnt,nres
 630         do k=1,3
 631           gradbufc(k,i)=0.0d0
 632         enddo
 633       enddo
 634 #ifdef DEBUG
 635       write (iout,*) "igrad_start",igrad_start," igrad_end",igrad_end
 636       write (iout,*) (i," jgrad_start",jgrad_start(i),
 637      &                  " jgrad_end  ",jgrad_end(i),
 638      &                  i=igrad_start,igrad_end)
 639 #endif
 640 c
 641 c Obsolete and inefficient code; we can make the effort O(n) and, therefore,
 642 c do not parallelize this part.
 643 c
 644 c      do i=igrad_start,igrad_end
 645 c        do j=jgrad_start(i),jgrad_end(i)
 646 c          do k=1,3
 647 c            gradbufc(k,i)=gradbufc(k,i)+gradbufc_sum(k,j)
 648 c          enddo
 649 c        enddo
 650 c      enddo
 651       do j=1,3
 652         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
 653       enddo
 654       do i=nres-2,0,-1
 655 c      do i=nres-2,nnt,-1
 656         do j=1,3
 657           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
 658         enddo
 659       enddo
 660 #ifdef DEBUG
 661       write (iout,*) "gradbufc after summing"
 662       do i=1,nres
 663         write (iout,'(i3,3e15.5)') i,(gradbufc(j,i),j=1,3)
 664       enddo
 665       call flush(iout)
 666 #endif
 667       else
 668 #endif
 669 #ifdef DEBUG
 670       write (iout,*) "gradbufc"
 671       do i=0,nres
 672         write (iout,'(i3,3e15.5)') i,(gradbufc(j,i),j=1,3)
 673       enddo
 674       call flush(iout)
 675 #endif
 676       do i=-1,nres
 677         do j=1,3
 678           gradbufc_sum(j,i)=gradbufc(j,i)
 679           gradbufc(j,i)=0.0d0
 680         enddo
 681       enddo
 682       do j=1,3
 683         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
 684       enddo
 685       do i=nres-2,0,-1
 686 c      do i=nres-2,nnt,-1
 687         do j=1,3
 688           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
 689         enddo
 690       enddo
 691 c      do i=nnt,nres-1
 692 c        do k=1,3
 693 c          gradbufc(k,i)=0.0d0
 694 c        enddo
 695 c        do j=i+1,nres
 696 c          do k=1,3
 697 c            gradbufc(k,i)=gradbufc(k,i)+gradbufc(k,j)
 698 c          enddo
 699 c        enddo
 700 c      enddo
 701 #ifdef DEBUG
 702       write (iout,*) "gradbufc after summing"
 703       do i=0,nres
 704         write (iout,'(i3,3e15.5)') i,(gradbufc(j,i),j=1,3)
 705       enddo
 706       call flush(iout)
 707 #endif
 708 #ifdef MPI
 709       endif
 710 #endif
 711       do k=1,3
 712         gradbufc(k,nres)=0.0d0
 713       enddo
 714       do i=-1,nct
 715         do j=1,3
 716 #ifdef SPLITELE
 717           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+
 718      &                wel_loc*gel_loc(j,i)+
 719      &                0.5d0*(wscp*gvdwc_scpp(j,i)+
 720      &                welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+
 721      &                wel_loc*gel_loc_long(j,i)+
 722      &                wcorr*gradcorr_long(j,i)+
 723      &                wcorr5*gradcorr5_long(j,i)+
 724      &                wcorr6*gradcorr6_long(j,i)+
 725      &                wturn6*gcorr6_turn_long(j,i))+
 726      &                wbond*gradb(j,i)+
 727      &                wcorr*gradcorr(j,i)+
 728      &                wturn3*gcorr3_turn(j,i)+
 729      &                wturn4*gcorr4_turn(j,i)+
 730      &                wcorr5*gradcorr5(j,i)+
 731      &                wcorr6*gradcorr6(j,i)+
 732      &                wturn6*gcorr6_turn(j,i)+
 733      &                wsccor*gsccorc(j,i)
 734      &               +wscloc*gscloc(j,i)
 735      &               +wliptran*gliptranc(j,i)
 736      &                +gradafm(j,i)
 737 #else
 738           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+
 739      &                wel_loc*gel_loc(j,i)+
 740      &                0.5d0*(wscp*gvdwc_scpp(j,i)+
 741      &                welec*gelc_long(j,i) +
 742      &                wel_loc*gel_loc_long(j,i)+
 743      &                wcorr*gcorr_long(j,i)+
 744      &                wcorr5*gradcorr5_long(j,i)+
 745      &                wcorr6*gradcorr6_long(j,i)+
 746      &                wturn6*gcorr6_turn_long(j,i))+
 747      &                wbond*gradb(j,i)+
 748      &                wcorr*gradcorr(j,i)+
 749      &                wturn3*gcorr3_turn(j,i)+
 750      &                wturn4*gcorr4_turn(j,i)+
 751      &                wcorr5*gradcorr5(j,i)+
 752      &                wcorr6*gradcorr6(j,i)+
 753      &                wturn6*gcorr6_turn(j,i)+
 754      &                wsccor*gsccorc(j,i)
 755      &               +wscloc*gscloc(j,i)
 756      &               +wliptran*gliptranc(j,i)
 757      &                +gradafm(j,i)
 758
 759 #endif
 760           gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+
 761      &                  wbond*gradbx(j,i)+
 762      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)
 763      &                 +wsaxs*gsaxsx(j,i)
 764      &                 +wsccor*gsccorx(j,i)
 765      &                 +wscloc*gsclocx(j,i)
 766      &                 +wliptran*gliptranx(j,i)
 767         enddo
 768       enddo
 769       if (constr_homology.gt.0) then
 770         do i=1,nct
 771           do j=1,3
 772             gradc(j,i,icg)=gradc(j,i,icg)+duscdiff(j,i)
 773             gradx(j,i,icg)=gradx(j,i,icg)+duscdiffx(j,i)
 774           enddo
 775         enddo
 776       endif
 777 #ifdef DEBUG
 778       write (iout,*) "gloc before adding corr"
 779       do i=1,4*nres
 780         write (iout,*) i,gloc(i,icg)
 781       enddo
 782 #endif
 783       do i=1,nres-3
 784         gloc(i,icg)=gloc(i,icg)+wcorr*gcorr_loc(i)
 785      &   +wcorr5*g_corr5_loc(i)
 786      &   +wcorr6*g_corr6_loc(i)
 787      &   +wturn4*gel_loc_turn4(i)
 788      &   +wturn3*gel_loc_turn3(i)
 789      &   +wturn6*gel_loc_turn6(i)
 790      &   +wel_loc*gel_loc_loc(i)
 791       enddo
 792 #ifdef DEBUG
 793       write (iout,*) "gloc after adding corr"
 794       do i=1,4*nres
 795         write (iout,*) i,gloc(i,icg)
 796       enddo
 797 #endif
 798 #ifdef MPI
 799       if (nfgtasks.gt.1) then
 800         do j=1,3
 801           do i=1,nres
 802             gradbufc(j,i)=gradc(j,i,icg)
 803             gradbufx(j,i)=gradx(j,i,icg)
 804           enddo
 805         enddo
 806         do i=1,4*nres
 807           glocbuf(i)=gloc(i,icg)
 808         enddo
 809 c#define DEBUG
 810 #ifdef DEBUG
 811       write (iout,*) "gloc_sc before reduce"
 812       do i=1,nres
 813        do j=1,1
 814         write (iout,*) i,j,gloc_sc(j,i,icg)
 815        enddo
 816       enddo
 817 #endif
 818 c#undef DEBUG
 819         do i=1,nres
 820          do j=1,3
 821           gloc_scbuf(j,i)=gloc_sc(j,i,icg)
 822          enddo
 823         enddo
 824         time00=MPI_Wtime()
 825         call MPI_Barrier(FG_COMM,IERR)
 826         time_barrier_g=time_barrier_g+MPI_Wtime()-time00
 827         time00=MPI_Wtime()
 828         call MPI_Reduce(gradbufc(1,1),gradc(1,1,icg),3*nres,
 829      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 830         call MPI_Reduce(gradbufx(1,1),gradx(1,1,icg),3*nres,
 831      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 832         call MPI_Reduce(glocbuf(1),gloc(1,icg),4*nres,
 833      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 834         time_reduce=time_reduce+MPI_Wtime()-time00
 835         call MPI_Reduce(gloc_scbuf(1,1),gloc_sc(1,1,icg),3*nres,
 836      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 837         time_reduce=time_reduce+MPI_Wtime()-time00
 838 c#define DEBUG
 839 #ifdef DEBUG
 840       write (iout,*) "gloc_sc after reduce"
 841       do i=1,nres
 842        do j=1,1
 843         write (iout,*) i,j,gloc_sc(j,i,icg)
 844        enddo
 845       enddo
 846 #endif
 847 c#undef DEBUG
 848 #ifdef DEBUG
 849       write (iout,*) "gloc after reduce"
 850       do i=1,4*nres
 851         write (iout,*) i,gloc(i,icg)
 852       enddo
 853 #endif
 854       endif
 855 #endif
 856       if (gnorm_check) then
 857 c
 858 c Compute the maximum elements of the gradient
 859 c
 860       gvdwc_max=0.0d0
 861       gvdwc_scp_max=0.0d0
 862       gelc_max=0.0d0
 863       gvdwpp_max=0.0d0
 864       gradb_max=0.0d0
 865       ghpbc_max=0.0d0
 866       gradcorr_max=0.0d0
 867       gel_loc_max=0.0d0
 868       gcorr3_turn_max=0.0d0
 869       gcorr4_turn_max=0.0d0
 870       gradcorr5_max=0.0d0
 871       gradcorr6_max=0.0d0
 872       gcorr6_turn_max=0.0d0
 873       gsccorc_max=0.0d0
 874       gscloc_max=0.0d0
 875       gvdwx_max=0.0d0
 876       gradx_scp_max=0.0d0
 877       ghpbx_max=0.0d0
 878       gradxorr_max=0.0d0
 879       gsccorx_max=0.0d0
 880       gsclocx_max=0.0d0
 881       do i=1,nct
 882         gvdwc_norm=dsqrt(scalar(gvdwc(1,i),gvdwc(1,i)))
 883         if (gvdwc_norm.gt.gvdwc_max) gvdwc_max=gvdwc_norm
 884         gvdwc_scp_norm=dsqrt(scalar(gvdwc_scp(1,i),gvdwc_scp(1,i)))
 885         if (gvdwc_scp_norm.gt.gvdwc_scp_max)
 886      &   gvdwc_scp_max=gvdwc_scp_norm
 887         gelc_norm=dsqrt(scalar(gelc(1,i),gelc(1,i)))
 888         if (gelc_norm.gt.gelc_max) gelc_max=gelc_norm
 889         gvdwpp_norm=dsqrt(scalar(gvdwpp(1,i),gvdwpp(1,i)))
 890         if (gvdwpp_norm.gt.gvdwpp_max) gvdwpp_max=gvdwpp_norm
 891         gradb_norm=dsqrt(scalar(gradb(1,i),gradb(1,i)))
 892         if (gradb_norm.gt.gradb_max) gradb_max=gradb_norm
 893         ghpbc_norm=dsqrt(scalar(ghpbc(1,i),ghpbc(1,i)))
 894         if (ghpbc_norm.gt.ghpbc_max) ghpbc_max=ghpbc_norm
 895         gradcorr_norm=dsqrt(scalar(gradcorr(1,i),gradcorr(1,i)))
 896         if (gradcorr_norm.gt.gradcorr_max) gradcorr_max=gradcorr_norm
 897         gel_loc_norm=dsqrt(scalar(gel_loc(1,i),gel_loc(1,i)))
 898         if (gel_loc_norm.gt.gel_loc_max) gel_loc_max=gel_loc_norm
 899         gcorr3_turn_norm=dsqrt(scalar(gcorr3_turn(1,i),
 900      &    gcorr3_turn(1,i)))
 901         if (gcorr3_turn_norm.gt.gcorr3_turn_max)
 902      &    gcorr3_turn_max=gcorr3_turn_norm
 903         gcorr4_turn_norm=dsqrt(scalar(gcorr4_turn(1,i),
 904      &    gcorr4_turn(1,i)))
 905         if (gcorr4_turn_norm.gt.gcorr4_turn_max)
 906      &    gcorr4_turn_max=gcorr4_turn_norm
 907         gradcorr5_norm=dsqrt(scalar(gradcorr5(1,i),gradcorr5(1,i)))
 908         if (gradcorr5_norm.gt.gradcorr5_max)
 909      &    gradcorr5_max=gradcorr5_norm
 910         gradcorr6_norm=dsqrt(scalar(gradcorr6(1,i),gradcorr6(1,i)))
 911         if (gradcorr6_norm.gt.gradcorr6_max) gcorr6_max=gradcorr6_norm
 912         gcorr6_turn_norm=dsqrt(scalar(gcorr6_turn(1,i),
 913      &    gcorr6_turn(1,i)))
 914         if (gcorr6_turn_norm.gt.gcorr6_turn_max)
 915      &    gcorr6_turn_max=gcorr6_turn_norm
 916         gsccorr_norm=dsqrt(scalar(gsccorc(1,i),gsccorc(1,i)))
 917         if (gsccorr_norm.gt.gsccorr_max) gsccorr_max=gsccorr_norm
 918         gscloc_norm=dsqrt(scalar(gscloc(1,i),gscloc(1,i)))
 919         if (gscloc_norm.gt.gscloc_max) gscloc_max=gscloc_norm
 920         gvdwx_norm=dsqrt(scalar(gvdwx(1,i),gvdwx(1,i)))
 921         if (gvdwx_norm.gt.gvdwx_max) gvdwx_max=gvdwx_norm
 922         gradx_scp_norm=dsqrt(scalar(gradx_scp(1,i),gradx_scp(1,i)))
 923         if (gradx_scp_norm.gt.gradx_scp_max)
 924      &    gradx_scp_max=gradx_scp_norm
 925         ghpbx_norm=dsqrt(scalar(ghpbx(1,i),ghpbx(1,i)))
 926         if (ghpbx_norm.gt.ghpbx_max) ghpbx_max=ghpbx_norm
 927         gradxorr_norm=dsqrt(scalar(gradxorr(1,i),gradxorr(1,i)))
 928         if (gradxorr_norm.gt.gradxorr_max) gradxorr_max=gradxorr_norm
 929         gsccorrx_norm=dsqrt(scalar(gsccorx(1,i),gsccorx(1,i)))
 930         if (gsccorrx_norm.gt.gsccorrx_max) gsccorrx_max=gsccorrx_norm
 931         gsclocx_norm=dsqrt(scalar(gsclocx(1,i),gsclocx(1,i)))
 932         if (gsclocx_norm.gt.gsclocx_max) gsclocx_max=gsclocx_norm
 933       enddo
 934       if (gradout) then
 935 #ifdef AIX
 936         open(istat,file=statname,position="append")
 937 #else
 938         open(istat,file=statname,access="append")
 939 #endif
 940         write (istat,'(1h#,21f10.2)') gvdwc_max,gvdwc_scp_max,
 941      &     gelc_max,gvdwpp_max,gradb_max,ghpbc_max,
 942      &     gradcorr_max,gel_loc_max,gcorr3_turn_max,gcorr4_turn_max,
 943      &     gradcorr5_max,gradcorr6_max,gcorr6_turn_max,gsccorc_max,
 944      &     gscloc_max,gvdwx_max,gradx_scp_max,ghpbx_max,gradxorr_max,
 945      &     gsccorx_max,gsclocx_max
 946         close(istat)
 947         if (gvdwc_max.gt.1.0d4) then
 948           write (iout,*) "gvdwc gvdwx gradb gradbx"
 949           do i=nnt,nct
 950             write(iout,'(i5,4(3f10.2,5x))') i,(gvdwc(j,i),gvdwx(j,i),
 951      &        gradb(j,i),gradbx(j,i),j=1,3)
 952           enddo
 953           call pdbout(0.0d0,'cipiszcze',iout)
 954           call flush(iout)
 955         endif
 956       endif
 957       endif
 958 #ifdef DEBUG
 959       write (iout,*) "gradc gradx gloc"
 960       do i=1,nres
 961         write (iout,'(i5,3e15.5,5x,3e15.5,5x,e15.5)')
 962      &   i,(gradc(j,i,icg),j=1,3),(gradx(j,i,icg),j=1,3),gloc(i,icg)
 963       enddo
 964 #endif
 965 #ifdef TIMING
 966       time_sumgradient=time_sumgradient+MPI_Wtime()-time01
 967 #endif
 968       return
 969       end
 970 c-------------------------------------------------------------------------------
 971       subroutine rescale_weights(t_bath)
 972       implicit real*8 (a-h,o-z)
 973       include 'DIMENSIONS'
 974       include 'COMMON.IOUNITS'
 975       include 'COMMON.FFIELD'
 976       include 'COMMON.SBRIDGE'
 977       double precision kfac /2.4d0/
 978       double precision x,x2,x3,x4,x5,licznik /1.12692801104297249644/
 979 c      facT=temp0/t_bath
 980 c      facT=2*temp0/(t_bath+temp0)
 981       if (rescale_mode.eq.0) then
 982         facT=1.0d0
 983         facT2=1.0d0
 984         facT3=1.0d0
 985         facT4=1.0d0
 986         facT5=1.0d0
 987       else if (rescale_mode.eq.1) then
 988         facT=kfac/(kfac-1.0d0+t_bath/temp0)
 989         facT2=kfac**2/(kfac**2-1.0d0+(t_bath/temp0)**2)
 990         facT3=kfac**3/(kfac**3-1.0d0+(t_bath/temp0)**3)
 991         facT4=kfac**4/(kfac**4-1.0d0+(t_bath/temp0)**4)
 992         facT5=kfac**5/(kfac**5-1.0d0+(t_bath/temp0)**5)
 993       else if (rescale_mode.eq.2) then
 994         x=t_bath/temp0
 995         x2=x*x
 996         x3=x2*x
 997         x4=x3*x
 998         x5=x4*x
 999         facT=licznik/dlog(dexp(x)+dexp(-x))
1000         facT2=licznik/dlog(dexp(x2)+dexp(-x2))
1001         facT3=licznik/dlog(dexp(x3)+dexp(-x3))
1002         facT4=licznik/dlog(dexp(x4)+dexp(-x4))
1003         facT5=licznik/dlog(dexp(x5)+dexp(-x5))
1004       else
1005         write (iout,*) "Wrong RESCALE_MODE",rescale_mode
1006         write (*,*) "Wrong RESCALE_MODE",rescale_mode
1007 #ifdef MPI
1008        call MPI_Finalize(MPI_COMM_WORLD,IERROR)
1009 #endif
1010        stop 555
1011       endif
1012       welec=weights(3)*fact
1013       wcorr=weights(4)*fact3
1014       wcorr5=weights(5)*fact4
1015       wcorr6=weights(6)*fact5
1016       wel_loc=weights(7)*fact2
1017       wturn3=weights(8)*fact2
1018       wturn4=weights(9)*fact3
1019       wturn6=weights(10)*fact5
1020       wtor=weights(13)*fact
1021       wtor_d=weights(14)*fact2
1022       wsccor=weights(21)*fact
1023
1024       return
1025       end
1026 C------------------------------------------------------------------------
1027       subroutine enerprint(energia)
1028       implicit real*8 (a-h,o-z)
1029       include 'DIMENSIONS'
1030       include 'COMMON.IOUNITS'
1031       include 'COMMON.FFIELD'
1032       include 'COMMON.SBRIDGE'
1033       include 'COMMON.MD'
1034       double precision energia(0:n_ene)
1035       etot=energia(0)
1036       evdw=energia(1)
1037       evdw2=energia(2)
1038 #ifdef SCP14
1039       evdw2=energia(2)+energia(18)
1040 #else
1041       evdw2=energia(2)
1042 #endif
1043       ees=energia(3)
1044 #ifdef SPLITELE
1045       evdw1=energia(16)
1046 #endif
1047       ecorr=energia(4)
1048       ecorr5=energia(5)
1049       ecorr6=energia(6)
1050       eel_loc=energia(7)
1051       eello_turn3=energia(8)
1052       eello_turn4=energia(9)
1053       eello_turn6=energia(10)
1054       ebe=energia(11)
1055       escloc=energia(12)
1056       etors=energia(13)
1057       etors_d=energia(14)
1058       ehpb=energia(15)
1059       edihcnstr=energia(19)
1060       estr=energia(17)
1061       Uconst=energia(20)
1062       esccor=energia(21)
1063       ehomology_constr=energia(24)
1064       esaxs_constr=energia(25)
1065       eliptran=energia(22)
1066       Eafmforce=energia(23)
1067 #ifdef SPLITELE
1068       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,evdw1,wvdwpp,
1069      &  estr,wbond,ebe,wang,
1070      &  escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,
1071      &  ecorr,wcorr,
1072      &  ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,
1073      &  eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccor,
1074      &  edihcnstr,ehomology_constr,esaxs_constr*wsaxs, ebr*nss,
1075      &  Uconst,eliptran,wliptran,Eafmforce,etot
1076    10 format (/'Virtual-chain energies:'//
1077      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
1078      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
1079      & 'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/
1080      & 'EVDWPP=',1pE16.6,' WEIGHT=',1pD16.6,' (p-p VDW)'/
1081      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
1082      & 'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
1083      & 'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
1084      & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
1085      & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
1086      & 'EHPB=  ',1pE16.6,' WEIGHT=',1pD16.6,
1087      & ' (SS bridges & dist. cnstr.)'/
1088      & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1089      & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1090      & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1091      & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
1092      & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
1093      & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
1094      & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
1095      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
1096      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
1097      & 'H_CONS=',1pE16.6,' (Homology model constraints energy)'/
1098      & 'E_SAXS=',1pE16.6,' (SAXS restraints)'/
1099      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
1100      & 'UCONST= ',1pE16.6,' (Constraint energy)'/
1101      & 'ELT=',1pE16.6, ' WEIGHT=',1pD16.6,' (Lipid transfer energy)'/
1102      & 'EAFM=  ',1pE16.6,' (atomic-force microscopy)'/
1103      & 'ETOT=  ',1pE16.6,' (total)')
1104
1105 #else
1106       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,
1107      &  estr,wbond,ebe,wang,
1108      &  escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,
1109      &  ecorr,wcorr,
1110      &  ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,
1111      &  eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccro,edihcnstr,
1112      &  ehomology_constr,esaxs_constr*wsaxs,ebr*nss,Uconst,
1113      &  eliptran,wliptran,Eafmforc,
1114      &  etot
1115    10 format (/'Virtual-chain energies:'//
1116      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
1117      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
1118      & 'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/
1119      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
1120      & 'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
1121      & 'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
1122      & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
1123      & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
1124      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6,
1125      & ' (SS bridges & dist. cnstr.)'/
1126      & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1127      & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1128      & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1129      & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
1130      & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
1131      & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
1132      & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
1133      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
1134      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
1135      & 'H_CONS=',1pE16.6,' (Homology model constraints energy)'/
1136      & 'E_SAXS=',1pE16.6,' (SAXS restraints)'/
1137      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
1138      & 'UCONST=',1pE16.6,' (Constraint energy)'/
1139      & 'ELT=',1pE16.6, ' WEIGHT=',1pD16.6,' (Lipid transfer energy)'/
1140      & 'EAFM=  ',1pE16.6,' (atomic-force microscopy)'/
1141      & 'ETOT=  ',1pE16.6,' (total)')
1142 #endif
1143       return
1144       end
1145 C-----------------------------------------------------------------------
1146       subroutine elj(evdw)
1147 C
1148 C This subroutine calculates the interaction energy of nonbonded side chains
1149 C assuming the LJ potential of interaction.
1150 C
1151       implicit real*8 (a-h,o-z)
1152       include 'DIMENSIONS'
1153       parameter (accur=1.0d-10)
1154       include 'COMMON.GEO'
1155       include 'COMMON.VAR'
1156       include 'COMMON.LOCAL'
1157       include 'COMMON.CHAIN'
1158       include 'COMMON.DERIV'
1159       include 'COMMON.INTERACT'
1160       include 'COMMON.TORSION'
1161       include 'COMMON.SBRIDGE'
1162       include 'COMMON.NAMES'
1163       include 'COMMON.IOUNITS'
1164       include 'COMMON.CONTACTS'
1165       dimension gg(3)
1166 c      write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
1167       evdw=0.0D0
1168       do i=iatsc_s,iatsc_e
1169         itypi=iabs(itype(i))
1170         if (itypi.eq.ntyp1) cycle
1171         itypi1=iabs(itype(i+1))
1172         xi=c(1,nres+i)
1173         yi=c(2,nres+i)
1174         zi=c(3,nres+i)
1175 C Change 12/1/95
1176         num_conti=0
1177 C
1178 C Calculate SC interaction energy.
1179 C
1180         do iint=1,nint_gr(i)
1181 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
1182 cd   &                  'iend=',iend(i,iint)
1183           do j=istart(i,iint),iend(i,iint)
1184             itypj=iabs(itype(j))
1185             if (itypj.eq.ntyp1) cycle
1186             xj=c(1,nres+j)-xi
1187             yj=c(2,nres+j)-yi
1188             zj=c(3,nres+j)-zi
1189 C Change 12/1/95 to calculate four-body interactions
1190             rij=xj*xj+yj*yj+zj*zj
1191             rrij=1.0D0/rij
1192 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
1193             eps0ij=eps(itypi,itypj)
1194             fac=rrij**expon2
1195 C have you changed here?
1196             e1=fac*fac*aa
1197             e2=fac*bb
1198             evdwij=e1+e2
1199 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1200 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1201 cd          write (iout,'(2(a3,i3,2x),6(1pd12.4)/2(3(1pd12.4),5x)/)')
1202 cd   &        restyp(itypi),i,restyp(itypj),j,a(itypi,itypj),
1203 cd   &        bb(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,epsi,sigm,
1204 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1205             evdw=evdw+evdwij
1206 C
1207 C Calculate the components of the gradient in DC and X
1208 C
1209             fac=-rrij*(e1+evdwij)
1210             gg(1)=xj*fac
1211             gg(2)=yj*fac
1212             gg(3)=zj*fac
1213             do k=1,3
1214               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1215               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1216               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1217               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1218             enddo
1219 cgrad            do k=i,j-1
1220 cgrad              do l=1,3
1221 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1222 cgrad              enddo
1223 cgrad            enddo
1224 C
1225 C 12/1/95, revised on 5/20/97
1226 C
1227 C Calculate the contact function. The ith column of the array JCONT will
1228 C contain the numbers of atoms that make contacts with the atom I (of numbers
1229 C greater than I). The arrays FACONT and GACONT will contain the values of
1230 C the contact function and its derivative.
1231 C
1232 C Uncomment next line, if the correlation interactions include EVDW explicitly.
1233 c           if (j.gt.i+1 .and. evdwij.le.0.0D0) then
1234 C Uncomment next line, if the correlation interactions are contact function only
1235             if (j.gt.i+1.and. eps0ij.gt.0.0D0) then
1236               rij=dsqrt(rij)
1237               sigij=sigma(itypi,itypj)
1238               r0ij=rs0(itypi,itypj)
1239 C
1240 C Check whether the SC's are not too far to make a contact.
1241 C
1242               rcut=1.5d0*r0ij
1243               call gcont(rij,rcut,1.0d0,0.2d0*rcut,fcont,fprimcont)
1244 C Add a new contact, if the SC's are close enough, but not too close (r<sigma).
1245 C
1246               if (fcont.gt.0.0D0) then
1247 C If the SC-SC distance if close to sigma, apply spline.
1248 cAdam           call gcont(-rij,-1.03d0*sigij,2.0d0*sigij,1.0d0,
1249 cAdam &             fcont1,fprimcont1)
1250 cAdam           fcont1=1.0d0-fcont1
1251 cAdam           if (fcont1.gt.0.0d0) then
1252 cAdam             fprimcont=fprimcont*fcont1+fcont*fprimcont1
1253 cAdam             fcont=fcont*fcont1
1254 cAdam           endif
1255 C Uncomment following 4 lines to have the geometric average of the epsilon0's
1256 cga             eps0ij=1.0d0/dsqrt(eps0ij)
1257 cga             do k=1,3
1258 cga               gg(k)=gg(k)*eps0ij
1259 cga             enddo
1260 cga             eps0ij=-evdwij*eps0ij
1261 C Uncomment for AL's type of SC correlation interactions.
1262 cadam           eps0ij=-evdwij
1263                 num_conti=num_conti+1
1264                 jcont(num_conti,i)=j
1265                 facont(num_conti,i)=fcont*eps0ij
1266                 fprimcont=eps0ij*fprimcont/rij
1267                 fcont=expon*fcont
1268 cAdam           gacont(1,num_conti,i)=-fprimcont*xj+fcont*gg(1)
1269 cAdam           gacont(2,num_conti,i)=-fprimcont*yj+fcont*gg(2)
1270 cAdam           gacont(3,num_conti,i)=-fprimcont*zj+fcont*gg(3)
1271 C Uncomment following 3 lines for Skolnick's type of SC correlation.
1272                 gacont(1,num_conti,i)=-fprimcont*xj
1273                 gacont(2,num_conti,i)=-fprimcont*yj
1274                 gacont(3,num_conti,i)=-fprimcont*zj
1275 cd              write (iout,'(2i5,2f10.5)') i,j,rij,facont(num_conti,i)
1276 cd              write (iout,'(2i3,3f10.5)')
1277 cd   &           i,j,(gacont(kk,num_conti,i),kk=1,3)
1278               endif
1279             endif
1280           enddo      ! j
1281         enddo        ! iint
1282 C Change 12/1/95
1283         num_cont(i)=num_conti
1284       enddo          ! i
1285       do i=1,nct
1286         do j=1,3
1287           gvdwc(j,i)=expon*gvdwc(j,i)
1288           gvdwx(j,i)=expon*gvdwx(j,i)
1289         enddo
1290       enddo
1291 C******************************************************************************
1292 C
1293 C                              N O T E !!!
1294 C
1295 C To save time, the factor of EXPON has been extracted from ALL components
1296 C of GVDWC and GRADX. Remember to multiply them by this factor before further
1297 C use!
1298 C
1299 C******************************************************************************
1300       return
1301       end
1302 C-----------------------------------------------------------------------------
1303       subroutine eljk(evdw)
1304 C
1305 C This subroutine calculates the interaction energy of nonbonded side chains
1306 C assuming the LJK potential of interaction.
1307 C
1308       implicit real*8 (a-h,o-z)
1309       include 'DIMENSIONS'
1310       include 'COMMON.GEO'
1311       include 'COMMON.VAR'
1312       include 'COMMON.LOCAL'
1313       include 'COMMON.CHAIN'
1314       include 'COMMON.DERIV'
1315       include 'COMMON.INTERACT'
1316       include 'COMMON.IOUNITS'
1317       include 'COMMON.NAMES'
1318       dimension gg(3)
1319       logical scheck
1320 c     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
1321       evdw=0.0D0
1322       do i=iatsc_s,iatsc_e
1323         itypi=iabs(itype(i))
1324         if (itypi.eq.ntyp1) cycle
1325         itypi1=iabs(itype(i+1))
1326         xi=c(1,nres+i)
1327         yi=c(2,nres+i)
1328         zi=c(3,nres+i)
1329 C
1330 C Calculate SC interaction energy.
1331 C
1332         do iint=1,nint_gr(i)
1333           do j=istart(i,iint),iend(i,iint)
1334             itypj=iabs(itype(j))
1335             if (itypj.eq.ntyp1) cycle
1336             xj=c(1,nres+j)-xi
1337             yj=c(2,nres+j)-yi
1338             zj=c(3,nres+j)-zi
1339             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1340             fac_augm=rrij**expon
1341             e_augm=augm(itypi,itypj)*fac_augm
1342             r_inv_ij=dsqrt(rrij)
1343             rij=1.0D0/r_inv_ij
1344             r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
1345             fac=r_shift_inv**expon
1346 C have you changed here?
1347             e1=fac*fac*aa
1348             e2=fac*bb
1349             evdwij=e_augm+e1+e2
1350 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1351 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1352 cd          write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
1353 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
1354 cd   &        bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
1355 cd   &        sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
1356 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1357             evdw=evdw+evdwij
1358 C
1359 C Calculate the components of the gradient in DC and X
1360 C
1361             fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
1362             gg(1)=xj*fac
1363             gg(2)=yj*fac
1364             gg(3)=zj*fac
1365             do k=1,3
1366               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1367               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1368               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1369               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1370             enddo
1371 cgrad            do k=i,j-1
1372 cgrad              do l=1,3
1373 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1374 cgrad              enddo
1375 cgrad            enddo
1376           enddo      ! j
1377         enddo        ! iint
1378       enddo          ! i
1379       do i=1,nct
1380         do j=1,3
1381           gvdwc(j,i)=expon*gvdwc(j,i)
1382           gvdwx(j,i)=expon*gvdwx(j,i)
1383         enddo
1384       enddo
1385       return
1386       end
1387 C-----------------------------------------------------------------------------
1388       subroutine ebp(evdw)
1389 C
1390 C This subroutine calculates the interaction energy of nonbonded side chains
1391 C assuming the Berne-Pechukas potential of interaction.
1392 C
1393       implicit real*8 (a-h,o-z)
1394       include 'DIMENSIONS'
1395       include 'COMMON.GEO'
1396       include 'COMMON.VAR'
1397       include 'COMMON.LOCAL'
1398       include 'COMMON.CHAIN'
1399       include 'COMMON.DERIV'
1400       include 'COMMON.NAMES'
1401       include 'COMMON.INTERACT'
1402       include 'COMMON.IOUNITS'
1403       include 'COMMON.CALC'
1404       common /srutu/ icall
1405 c     double precision rrsave(maxdim)
1406       logical lprn
1407       evdw=0.0D0
1408 c     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
1409       evdw=0.0D0
1410 c     if (icall.eq.0) then
1411 c       lprn=.true.
1412 c     else
1413         lprn=.false.
1414 c     endif
1415       ind=0
1416       do i=iatsc_s,iatsc_e
1417         itypi=iabs(itype(i))
1418         if (itypi.eq.ntyp1) cycle
1419         itypi1=iabs(itype(i+1))
1420         xi=c(1,nres+i)
1421         yi=c(2,nres+i)
1422         zi=c(3,nres+i)
1423         dxi=dc_norm(1,nres+i)
1424         dyi=dc_norm(2,nres+i)
1425         dzi=dc_norm(3,nres+i)
1426 c        dsci_inv=dsc_inv(itypi)
1427         dsci_inv=vbld_inv(i+nres)
1428 C
1429 C Calculate SC interaction energy.
1430 C
1431         do iint=1,nint_gr(i)
1432           do j=istart(i,iint),iend(i,iint)
1433             ind=ind+1
1434             itypj=iabs(itype(j))
1435             if (itypj.eq.ntyp1) cycle
1436 c            dscj_inv=dsc_inv(itypj)
1437             dscj_inv=vbld_inv(j+nres)
1438             chi1=chi(itypi,itypj)
1439             chi2=chi(itypj,itypi)
1440             chi12=chi1*chi2
1441             chip1=chip(itypi)
1442             chip2=chip(itypj)
1443             chip12=chip1*chip2
1444             alf1=alp(itypi)
1445             alf2=alp(itypj)
1446             alf12=0.5D0*(alf1+alf2)
1447 C For diagnostics only!!!
1448 c           chi1=0.0D0
1449 c           chi2=0.0D0
1450 c           chi12=0.0D0
1451 c           chip1=0.0D0
1452 c           chip2=0.0D0
1453 c           chip12=0.0D0
1454 c           alf1=0.0D0
1455 c           alf2=0.0D0
1456 c           alf12=0.0D0
1457             xj=c(1,nres+j)-xi
1458             yj=c(2,nres+j)-yi
1459             zj=c(3,nres+j)-zi
1460             dxj=dc_norm(1,nres+j)
1461             dyj=dc_norm(2,nres+j)
1462             dzj=dc_norm(3,nres+j)
1463             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1464 cd          if (icall.eq.0) then
1465 cd            rrsave(ind)=rrij
1466 cd          else
1467 cd            rrij=rrsave(ind)
1468 cd          endif
1469             rij=dsqrt(rrij)
1470 C Calculate the angle-dependent terms of energy & contributions to derivatives.
1471             call sc_angular
1472 C Calculate whole angle-dependent part of epsilon and contributions
1473 C to its derivatives
1474 C have you changed here?
1475             fac=(rrij*sigsq)**expon2
1476             e1=fac*fac*aa
1477             e2=fac*bb
1478             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1479             eps2der=evdwij*eps3rt
1480             eps3der=evdwij*eps2rt
1481             evdwij=evdwij*eps2rt*eps3rt
1482             evdw=evdw+evdwij
1483             if (lprn) then
1484             sigm=dabs(aa/bb)**(1.0D0/6.0D0)
1485             epsi=bb**2/aa
1486 cd            write (iout,'(2(a3,i3,2x),15(0pf7.3))')
1487 cd     &        restyp(itypi),i,restyp(itypj),j,
1488 cd     &        epsi,sigm,chi1,chi2,chip1,chip2,
1489 cd     &        eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
1490 cd     &        om1,om2,om12,1.0D0/dsqrt(rrij),
1491 cd     &        evdwij
1492             endif
1493 C Calculate gradient components.
1494             e1=e1*eps1*eps2rt**2*eps3rt**2
1495             fac=-expon*(e1+evdwij)
1496             sigder=fac/sigsq
1497             fac=rrij*fac
1498 C Calculate radial part of the gradient
1499             gg(1)=xj*fac
1500             gg(2)=yj*fac
1501             gg(3)=zj*fac
1502 C Calculate the angular part of the gradient and sum add the contributions
1503 C to the appropriate components of the Cartesian gradient.
1504             call sc_grad
1505           enddo      ! j
1506         enddo        ! iint
1507       enddo          ! i
1508 c     stop
1509       return
1510       end
1511 C-----------------------------------------------------------------------------
1512       subroutine egb(evdw)
1513 C
1514 C This subroutine calculates the interaction energy of nonbonded side chains
1515 C assuming the Gay-Berne potential of interaction.
1516 C
1517       implicit real*8 (a-h,o-z)
1518       include 'DIMENSIONS'
1519       include 'COMMON.GEO'
1520       include 'COMMON.VAR'
1521       include 'COMMON.LOCAL'
1522       include 'COMMON.CHAIN'
1523       include 'COMMON.DERIV'
1524       include 'COMMON.NAMES'
1525       include 'COMMON.INTERACT'
1526       include 'COMMON.IOUNITS'
1527       include 'COMMON.CALC'
1528       include 'COMMON.CONTROL'
1529       include 'COMMON.SPLITELE'
1530       include 'COMMON.SBRIDGE'
1531       logical lprn
1532       integer xshift,yshift,zshift
1533       evdw=0.0D0
1534 ccccc      energy_dec=.false.
1535 C      print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1536       evdw=0.0D0
1537       lprn=.false.
1538 c     if (icall.eq.0) lprn=.false.
1539       ind=0
1540 C the loop over all 27 posible neigbours (for xshift=0,yshift=0,zshift=0
1541 C we have the original box)
1542 C      do xshift=-1,1
1543 C      do yshift=-1,1
1544 C      do zshift=-1,1
1545       do i=iatsc_s,iatsc_e
1546         itypi=iabs(itype(i))
1547         if (itypi.eq.ntyp1) cycle
1548         itypi1=iabs(itype(i+1))
1549         xi=c(1,nres+i)
1550         yi=c(2,nres+i)
1551         zi=c(3,nres+i)
1552 C Return atom into box, boxxsize is size of box in x dimension
1553 c  134   continue
1554 c        if (xi.gt.((xshift+0.5d0)*boxxsize)) xi=xi-boxxsize
1555 c        if (xi.lt.((xshift-0.5d0)*boxxsize)) xi=xi+boxxsize
1556 C Condition for being inside the proper box
1557 c        if ((xi.gt.((xshift+0.5d0)*boxxsize)).or.
1558 c     &       (xi.lt.((xshift-0.5d0)*boxxsize))) then
1559 c        go to 134
1560 c        endif
1561 c  135   continue
1562 c        if (yi.gt.((yshift+0.5d0)*boxysize)) yi=yi-boxysize
1563 c        if (yi.lt.((yshift-0.5d0)*boxysize)) yi=yi+boxysize
1564 C Condition for being inside the proper box
1565 c        if ((yi.gt.((yshift+0.5d0)*boxysize)).or.
1566 c     &       (yi.lt.((yshift-0.5d0)*boxysize))) then
1567 c        go to 135
1568 c        endif
1569 c  136   continue
1570 c        if (zi.gt.((zshift+0.5d0)*boxzsize)) zi=zi-boxzsize
1571 c        if (zi.lt.((zshift-0.5d0)*boxzsize)) zi=zi+boxzsize
1572 C Condition for being inside the proper box
1573 c        if ((zi.gt.((zshift+0.5d0)*boxzsize)).or.
1574 c     &       (zi.lt.((zshift-0.5d0)*boxzsize))) then
1575 c        go to 136
1576 c        endif
1577           xi=mod(xi,boxxsize)
1578           if (xi.lt.0) xi=xi+boxxsize
1579           yi=mod(yi,boxysize)
1580           if (yi.lt.0) yi=yi+boxysize
1581           zi=mod(zi,boxzsize)
1582           if (zi.lt.0) zi=zi+boxzsize
1583 C define scaling factor for lipids
1584
1585 C        if (positi.le.0) positi=positi+boxzsize
1586 C        print *,i
1587 C first for peptide groups
1588 c for each residue check if it is in lipid or lipid water border area
1589        if ((zi.gt.bordlipbot)
1590      &.and.(zi.lt.bordliptop)) then
1591 C the energy transfer exist
1592         if (zi.lt.buflipbot) then
1593 C what fraction I am in
1594          fracinbuf=1.0d0-
1595      &        ((zi-bordlipbot)/lipbufthick)
1596 C lipbufthick is thickenes of lipid buffore
1597          sslipi=sscalelip(fracinbuf)
1598          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
1599         elseif (zi.gt.bufliptop) then
1600          fracinbuf=1.0d0-((bordliptop-zi)/lipbufthick)
1601          sslipi=sscalelip(fracinbuf)
1602          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
1603         else
1604          sslipi=1.0d0
1605          ssgradlipi=0.0
1606         endif
1607        else
1608          sslipi=0.0d0
1609          ssgradlipi=0.0
1610        endif
1611
1612 C          xi=xi+xshift*boxxsize
1613 C          yi=yi+yshift*boxysize
1614 C          zi=zi+zshift*boxzsize
1615
1616         dxi=dc_norm(1,nres+i)
1617         dyi=dc_norm(2,nres+i)
1618         dzi=dc_norm(3,nres+i)
1619 c        dsci_inv=dsc_inv(itypi)
1620         dsci_inv=vbld_inv(i+nres)
1621 c        write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)
1622 c        write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi
1623 C
1624 C Calculate SC interaction energy.
1625 C
1626         do iint=1,nint_gr(i)
1627           do j=istart(i,iint),iend(i,iint)
1628             IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN
1629               call dyn_ssbond_ene(i,j,evdwij)
1630               evdw=evdw+evdwij
1631               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)')
1632      &                        'evdw',i,j,evdwij,' ss'
1633             ELSE
1634             ind=ind+1
1635             itypj=iabs(itype(j))
1636             if (itypj.eq.ntyp1) cycle
1637 c            dscj_inv=dsc_inv(itypj)
1638             dscj_inv=vbld_inv(j+nres)
1639 c            write (iout,*) "j",j,dsc_inv(itypj),dscj_inv,
1640 c     &       1.0d0/vbld(j+nres)
1641 c            write (iout,*) "i",i," j", j," itype",itype(i),itype(j)
1642             sig0ij=sigma(itypi,itypj)
1643             chi1=chi(itypi,itypj)
1644             chi2=chi(itypj,itypi)
1645             chi12=chi1*chi2
1646             chip1=chip(itypi)
1647             chip2=chip(itypj)
1648             chip12=chip1*chip2
1649             alf1=alp(itypi)
1650             alf2=alp(itypj)
1651             alf12=0.5D0*(alf1+alf2)
1652 C For diagnostics only!!!
1653 c           chi1=0.0D0
1654 c           chi2=0.0D0
1655 c           chi12=0.0D0
1656 c           chip1=0.0D0
1657 c           chip2=0.0D0
1658 c           chip12=0.0D0
1659 c           alf1=0.0D0
1660 c           alf2=0.0D0
1661 c           alf12=0.0D0
1662             xj=c(1,nres+j)
1663             yj=c(2,nres+j)
1664             zj=c(3,nres+j)
1665 C Return atom J into box the original box
1666 c  137   continue
1667 c        if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
1668 c        if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
1669 C Condition for being inside the proper box
1670 c        if ((xj.gt.((0.5d0)*boxxsize)).or.
1671 c     &       (xj.lt.((-0.5d0)*boxxsize))) then
1672 c        go to 137
1673 c        endif
1674 c  138   continue
1675 c        if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
1676 c        if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
1677 C Condition for being inside the proper box
1678 c        if ((yj.gt.((0.5d0)*boxysize)).or.
1679 c     &       (yj.lt.((-0.5d0)*boxysize))) then
1680 c        go to 138
1681 c        endif
1682 c  139   continue
1683 c        if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
1684 c        if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
1685 C Condition for being inside the proper box
1686 c        if ((zj.gt.((0.5d0)*boxzsize)).or.
1687 c     &       (zj.lt.((-0.5d0)*boxzsize))) then
1688 c        go to 139
1689 c        endif
1690           xj=mod(xj,boxxsize)
1691           if (xj.lt.0) xj=xj+boxxsize
1692           yj=mod(yj,boxysize)
1693           if (yj.lt.0) yj=yj+boxysize
1694           zj=mod(zj,boxzsize)
1695           if (zj.lt.0) zj=zj+boxzsize
1696        if ((zj.gt.bordlipbot)
1697      &.and.(zj.lt.bordliptop)) then
1698 C the energy transfer exist
1699         if (zj.lt.buflipbot) then
1700 C what fraction I am in
1701          fracinbuf=1.0d0-
1702      &        ((zj-bordlipbot)/lipbufthick)
1703 C lipbufthick is thickenes of lipid buffore
1704          sslipj=sscalelip(fracinbuf)
1705          ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
1706         elseif (zj.gt.bufliptop) then
1707          fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
1708          sslipj=sscalelip(fracinbuf)
1709          ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
1710         else
1711          sslipj=1.0d0
1712          ssgradlipj=0.0
1713         endif
1714        else
1715          sslipj=0.0d0
1716          ssgradlipj=0.0
1717        endif
1718       aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
1719      &  +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1720       bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
1721      &  +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1722 C      if (aa.ne.aa_aq(itypi,itypj)) write(63,'(2e10.5)')
1723 C     &(aa-aa_aq(itypi,itypj)),(bb-bb_aq(itypi,itypj))
1724 C      if (ssgradlipj.gt.0.0d0) print *,"??WTF??"
1725 C      print *,sslipi,sslipj,bordlipbot,zi,zj
1726       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
1727       xj_safe=xj
1728       yj_safe=yj
1729       zj_safe=zj
1730       subchap=0
1731       do xshift=-1,1
1732       do yshift=-1,1
1733       do zshift=-1,1
1734           xj=xj_safe+xshift*boxxsize
1735           yj=yj_safe+yshift*boxysize
1736           zj=zj_safe+zshift*boxzsize
1737           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
1738           if(dist_temp.lt.dist_init) then
1739             dist_init=dist_temp
1740             xj_temp=xj
1741             yj_temp=yj
1742             zj_temp=zj
1743             subchap=1
1744           endif
1745        enddo
1746        enddo
1747        enddo
1748        if (subchap.eq.1) then
1749           xj=xj_temp-xi
1750           yj=yj_temp-yi
1751           zj=zj_temp-zi
1752        else
1753           xj=xj_safe-xi
1754           yj=yj_safe-yi
1755           zj=zj_safe-zi
1756        endif
1757             dxj=dc_norm(1,nres+j)
1758             dyj=dc_norm(2,nres+j)
1759             dzj=dc_norm(3,nres+j)
1760 C            xj=xj-xi
1761 C            yj=yj-yi
1762 C            zj=zj-zi
1763 c            write (iout,*) "dcnorj",dxi*dxi+dyi*dyi+dzi*dzi
1764 c            write (iout,*) "j",j," dc_norm",
1765 c     &       dc_norm(1,nres+j),dc_norm(2,nres+j),dc_norm(3,nres+j)
1766             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1767             rij=dsqrt(rrij)
1768             sss=sscale((1.0d0/rij)/sigma(itypi,itypj))
1769             sssgrad=sscagrad((1.0d0/rij)/sigma(itypi,itypj))
1770
1771 c            write (iout,'(a7,4f8.3)')
1772 c    &      "ssscale",sss,((1.0d0/rij)/sigma(itypi,itypj)),r_cut,rlamb
1773             if (sss.gt.0.0d0) then
1774 C Calculate angle-dependent terms of energy and contributions to their
1775 C derivatives.
1776             call sc_angular
1777             sigsq=1.0D0/sigsq
1778             sig=sig0ij*dsqrt(sigsq)
1779             rij_shift=1.0D0/rij-sig+sig0ij
1780 c for diagnostics; uncomment
1781 c            rij_shift=1.2*sig0ij
1782 C I hate to put IF's in the loops, but here don't have another choice!!!!
1783             if (rij_shift.le.0.0D0) then
1784               evdw=1.0D20
1785 cd              write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1786 cd     &        restyp(itypi),i,restyp(itypj),j,
1787 cd     &        rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq)
1788               return
1789             endif
1790             sigder=-sig*sigsq
1791 c---------------------------------------------------------------
1792             rij_shift=1.0D0/rij_shift
1793             fac=rij_shift**expon
1794 C here to start with
1795 C            if (c(i,3).gt.
1796             faclip=fac
1797             e1=fac*fac*aa
1798             e2=fac*bb
1799             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1800             eps2der=evdwij*eps3rt
1801             eps3der=evdwij*eps2rt
1802 C       write(63,'(2i3,2e10.3,2f10.5)') i,j,aa,bb, evdwij,
1803 C     &((sslipi+sslipj)/2.0d0+
1804 C     &(2.0d0-sslipi-sslipj)/2.0d0)
1805 c            write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt,
1806 c     &        " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2
1807             evdwij=evdwij*eps2rt*eps3rt
1808             evdw=evdw+evdwij*sss
1809             if (lprn) then
1810             sigm=dabs(aa/bb)**(1.0D0/6.0D0)
1811             epsi=bb**2/aa
1812             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1813      &        restyp(itypi),i,restyp(itypj),j,
1814      &        epsi,sigm,chi1,chi2,chip1,chip2,
1815      &        eps1,eps2rt**2,eps3rt**2,sig,sig0ij,
1816      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1817      &        evdwij
1818             endif
1819
1820             if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
1821      &                        'evdw',i,j,evdwij
1822
1823 C Calculate gradient components.
1824             e1=e1*eps1*eps2rt**2*eps3rt**2
1825             fac=-expon*(e1+evdwij)*rij_shift
1826             sigder=fac*sigder
1827             fac=rij*fac
1828 c            print '(2i4,6f8.4)',i,j,sss,sssgrad*
1829 c     &      evdwij,fac,sigma(itypi,itypj),expon
1830             fac=fac+evdwij/sss*sssgrad/sigma(itypi,itypj)*rij
1831 c            fac=0.0d0
1832 C Calculate the radial part of the gradient
1833             gg_lipi(3)=eps1*(eps2rt*eps2rt)
1834      &*(eps3rt*eps3rt)*sss/2.0d0*(faclip*faclip*
1835      & (aa_lip(itypi,itypj)-aa_aq(itypi,itypj))
1836      &+faclip*(bb_lip(itypi,itypj)-bb_aq(itypi,itypj)))
1837             gg_lipj(3)=ssgradlipj*gg_lipi(3)
1838             gg_lipi(3)=gg_lipi(3)*ssgradlipi
1839 C            gg_lipi(3)=0.0d0
1840 C            gg_lipj(3)=0.0d0
1841             gg(1)=xj*fac
1842             gg(2)=yj*fac
1843             gg(3)=zj*fac
1844 C Calculate angular part of the gradient.
1845             call sc_grad
1846             endif
1847             ENDIF    ! dyn_ss
1848           enddo      ! j
1849         enddo        ! iint
1850       enddo          ! i
1851 C      enddo          ! zshift
1852 C      enddo          ! yshift
1853 C      enddo          ! xshift
1854 c      write (iout,*) "Number of loop steps in EGB:",ind
1855 cccc      energy_dec=.false.
1856       return
1857       end
1858 C-----------------------------------------------------------------------------
1859       subroutine egbv(evdw)
1860 C
1861 C This subroutine calculates the interaction energy of nonbonded side chains
1862 C assuming the Gay-Berne-Vorobjev potential of interaction.
1863 C
1864       implicit real*8 (a-h,o-z)
1865       include 'DIMENSIONS'
1866       include 'COMMON.GEO'
1867       include 'COMMON.VAR'
1868       include 'COMMON.LOCAL'
1869       include 'COMMON.CHAIN'
1870       include 'COMMON.DERIV'
1871       include 'COMMON.NAMES'
1872       include 'COMMON.INTERACT'
1873       include 'COMMON.IOUNITS'
1874       include 'COMMON.CALC'
1875       common /srutu/ icall
1876       logical lprn
1877       evdw=0.0D0
1878 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1879       evdw=0.0D0
1880       lprn=.false.
1881 c     if (icall.eq.0) lprn=.true.
1882       ind=0
1883       do i=iatsc_s,iatsc_e
1884         itypi=iabs(itype(i))
1885         if (itypi.eq.ntyp1) cycle
1886         itypi1=iabs(itype(i+1))
1887         xi=c(1,nres+i)
1888         yi=c(2,nres+i)
1889         zi=c(3,nres+i)
1890           xi=mod(xi,boxxsize)
1891           if (xi.lt.0) xi=xi+boxxsize
1892           yi=mod(yi,boxysize)
1893           if (yi.lt.0) yi=yi+boxysize
1894           zi=mod(zi,boxzsize)
1895           if (zi.lt.0) zi=zi+boxzsize
1896 C define scaling factor for lipids
1897
1898 C        if (positi.le.0) positi=positi+boxzsize
1899 C        print *,i
1900 C first for peptide groups
1901 c for each residue check if it is in lipid or lipid water border area
1902        if ((zi.gt.bordlipbot)
1903      &.and.(zi.lt.bordliptop)) then
1904 C the energy transfer exist
1905         if (zi.lt.buflipbot) then
1906 C what fraction I am in
1907          fracinbuf=1.0d0-
1908      &        ((zi-bordlipbot)/lipbufthick)
1909 C lipbufthick is thickenes of lipid buffore
1910          sslipi=sscalelip(fracinbuf)
1911          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
1912         elseif (zi.gt.bufliptop) then
1913          fracinbuf=1.0d0-((bordliptop-zi)/lipbufthick)
1914          sslipi=sscalelip(fracinbuf)
1915          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
1916         else
1917          sslipi=1.0d0
1918          ssgradlipi=0.0
1919         endif
1920        else
1921          sslipi=0.0d0
1922          ssgradlipi=0.0
1923        endif
1924
1925         dxi=dc_norm(1,nres+i)
1926         dyi=dc_norm(2,nres+i)
1927         dzi=dc_norm(3,nres+i)
1928 c        dsci_inv=dsc_inv(itypi)
1929         dsci_inv=vbld_inv(i+nres)
1930 C
1931 C Calculate SC interaction energy.
1932 C
1933         do iint=1,nint_gr(i)
1934           do j=istart(i,iint),iend(i,iint)
1935             ind=ind+1
1936             itypj=iabs(itype(j))
1937             if (itypj.eq.ntyp1) cycle
1938 c            dscj_inv=dsc_inv(itypj)
1939             dscj_inv=vbld_inv(j+nres)
1940             sig0ij=sigma(itypi,itypj)
1941             r0ij=r0(itypi,itypj)
1942             chi1=chi(itypi,itypj)
1943             chi2=chi(itypj,itypi)
1944             chi12=chi1*chi2
1945             chip1=chip(itypi)
1946             chip2=chip(itypj)
1947             chip12=chip1*chip2
1948             alf1=alp(itypi)
1949             alf2=alp(itypj)
1950             alf12=0.5D0*(alf1+alf2)
1951 C For diagnostics only!!!
1952 c           chi1=0.0D0
1953 c           chi2=0.0D0
1954 c           chi12=0.0D0
1955 c           chip1=0.0D0
1956 c           chip2=0.0D0
1957 c           chip12=0.0D0
1958 c           alf1=0.0D0
1959 c           alf2=0.0D0
1960 c           alf12=0.0D0
1961 C            xj=c(1,nres+j)-xi
1962 C            yj=c(2,nres+j)-yi
1963 C            zj=c(3,nres+j)-zi
1964           xj=mod(xj,boxxsize)
1965           if (xj.lt.0) xj=xj+boxxsize
1966           yj=mod(yj,boxysize)
1967           if (yj.lt.0) yj=yj+boxysize
1968           zj=mod(zj,boxzsize)
1969           if (zj.lt.0) zj=zj+boxzsize
1970        if ((zj.gt.bordlipbot)
1971      &.and.(zj.lt.bordliptop)) then
1972 C the energy transfer exist
1973         if (zj.lt.buflipbot) then
1974 C what fraction I am in
1975          fracinbuf=1.0d0-
1976      &        ((zj-bordlipbot)/lipbufthick)
1977 C lipbufthick is thickenes of lipid buffore
1978          sslipj=sscalelip(fracinbuf)
1979          ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
1980         elseif (zj.gt.bufliptop) then
1981          fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
1982          sslipj=sscalelip(fracinbuf)
1983          ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
1984         else
1985          sslipj=1.0d0
1986          ssgradlipj=0.0
1987         endif
1988        else
1989          sslipj=0.0d0
1990          ssgradlipj=0.0
1991        endif
1992       aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
1993      &  +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1994       bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
1995      &  +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1996 C      if (aa.ne.aa_aq(itypi,itypj)) write(63,'2e10.5')
1997 C     &(aa-aa_aq(itypi,itypj)),(bb-bb_aq(itypi,itypj))
1998       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
1999       xj_safe=xj
2000       yj_safe=yj
2001       zj_safe=zj
2002       subchap=0
2003       do xshift=-1,1
2004       do yshift=-1,1
2005       do zshift=-1,1
2006           xj=xj_safe+xshift*boxxsize
2007           yj=yj_safe+yshift*boxysize
2008           zj=zj_safe+zshift*boxzsize
2009           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
2010           if(dist_temp.lt.dist_init) then
2011             dist_init=dist_temp
2012             xj_temp=xj
2013             yj_temp=yj
2014             zj_temp=zj
2015             subchap=1
2016           endif
2017        enddo
2018        enddo
2019        enddo
2020        if (subchap.eq.1) then
2021           xj=xj_temp-xi
2022           yj=yj_temp-yi
2023           zj=zj_temp-zi
2024        else
2025           xj=xj_safe-xi
2026           yj=yj_safe-yi
2027           zj=zj_safe-zi
2028        endif
2029             dxj=dc_norm(1,nres+j)
2030             dyj=dc_norm(2,nres+j)
2031             dzj=dc_norm(3,nres+j)
2032             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
2033             rij=dsqrt(rrij)
2034 C Calculate angle-dependent terms of energy and contributions to their
2035 C derivatives.
2036             call sc_angular
2037             sigsq=1.0D0/sigsq
2038             sig=sig0ij*dsqrt(sigsq)
2039             rij_shift=1.0D0/rij-sig+r0ij
2040 C I hate to put IF's in the loops, but here don't have another choice!!!!
2041             if (rij_shift.le.0.0D0) then
2042               evdw=1.0D20
2043               return
2044             endif
2045             sigder=-sig*sigsq
2046 c---------------------------------------------------------------
2047             rij_shift=1.0D0/rij_shift
2048             fac=rij_shift**expon
2049             e1=fac*fac*aa
2050             e2=fac*bb
2051             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
2052             eps2der=evdwij*eps3rt
2053             eps3der=evdwij*eps2rt
2054             fac_augm=rrij**expon
2055             e_augm=augm(itypi,itypj)*fac_augm
2056             evdwij=evdwij*eps2rt*eps3rt
2057             evdw=evdw+evdwij+e_augm
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,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),
2064      &        chi1,chi2,chip1,chip2,
2065      &        eps1,eps2rt**2,eps3rt**2,
2066      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
2067      &        evdwij+e_augm
2068             endif
2069 C Calculate gradient components.
2070             e1=e1*eps1*eps2rt**2*eps3rt**2
2071             fac=-expon*(e1+evdwij)*rij_shift
2072             sigder=fac*sigder
2073             fac=rij*fac-2*expon*rrij*e_augm
2074             fac=fac+evdwij/sss*sssgrad/sigma(itypi,itypj)*rij
2075 C Calculate the radial part of the gradient
2076             gg(1)=xj*fac
2077             gg(2)=yj*fac
2078             gg(3)=zj*fac
2079 C Calculate angular part of the gradient.
2080             call sc_grad
2081           enddo      ! j
2082         enddo        ! iint
2083       enddo          ! i
2084       end
2085 C-----------------------------------------------------------------------------
2086       subroutine sc_angular
2087 C Calculate eps1,eps2,eps3,sigma, and parts of their derivatives in om1,om2,
2088 C om12. Called by ebp, egb, and egbv.
2089       implicit none
2090       include 'COMMON.CALC'
2091       include 'COMMON.IOUNITS'
2092       erij(1)=xj*rij
2093       erij(2)=yj*rij
2094       erij(3)=zj*rij
2095       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
2096       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
2097       om12=dxi*dxj+dyi*dyj+dzi*dzj
2098       chiom12=chi12*om12
2099 C Calculate eps1(om12) and its derivative in om12
2100       faceps1=1.0D0-om12*chiom12
2101       faceps1_inv=1.0D0/faceps1
2102       eps1=dsqrt(faceps1_inv)
2103 C Following variable is eps1*deps1/dom12
2104       eps1_om12=faceps1_inv*chiom12
2105 c diagnostics only
2106 c      faceps1_inv=om12
2107 c      eps1=om12
2108 c      eps1_om12=1.0d0
2109 c      write (iout,*) "om12",om12," eps1",eps1
2110 C Calculate sigma(om1,om2,om12) and the derivatives of sigma**2 in om1,om2,
2111 C and om12.
2112       om1om2=om1*om2
2113       chiom1=chi1*om1
2114       chiom2=chi2*om2
2115       facsig=om1*chiom1+om2*chiom2-2.0D0*om1om2*chiom12
2116       sigsq=1.0D0-facsig*faceps1_inv
2117       sigsq_om1=(chiom1-chiom12*om2)*faceps1_inv
2118       sigsq_om2=(chiom2-chiom12*om1)*faceps1_inv
2119       sigsq_om12=-chi12*(om1om2*faceps1-om12*facsig)*faceps1_inv**2
2120 c diagnostics only
2121 c      sigsq=1.0d0
2122 c      sigsq_om1=0.0d0
2123 c      sigsq_om2=0.0d0
2124 c      sigsq_om12=0.0d0
2125 c      write (iout,*) "chiom1",chiom1," chiom2",chiom2," chiom12",chiom12
2126 c      write (iout,*) "faceps1",faceps1," faceps1_inv",faceps1_inv,
2127 c     &    " eps1",eps1
2128 C Calculate eps2 and its derivatives in om1, om2, and om12.
2129       chipom1=chip1*om1
2130       chipom2=chip2*om2
2131       chipom12=chip12*om12
2132       facp=1.0D0-om12*chipom12
2133       facp_inv=1.0D0/facp
2134       facp1=om1*chipom1+om2*chipom2-2.0D0*om1om2*chipom12
2135 c      write (iout,*) "chipom1",chipom1," chipom2",chipom2,
2136 c     &  " chipom12",chipom12," facp",facp," facp_inv",facp_inv
2137 C Following variable is the square root of eps2
2138       eps2rt=1.0D0-facp1*facp_inv
2139 C Following three variables are the derivatives of the square root of eps
2140 C in om1, om2, and om12.
2141       eps2rt_om1=-4.0D0*(chipom1-chipom12*om2)*facp_inv
2142       eps2rt_om2=-4.0D0*(chipom2-chipom12*om1)*facp_inv
2143       eps2rt_om12=4.0D0*chip12*(om1om2*facp-om12*facp1)*facp_inv**2
2144 C Evaluate the "asymmetric" factor in the VDW constant, eps3
2145       eps3rt=1.0D0-alf1*om1+alf2*om2-alf12*om12
2146 c      write (iout,*) "eps2rt",eps2rt," eps3rt",eps3rt
2147 c      write (iout,*) "eps2rt_om1",eps2rt_om1," eps2rt_om2",eps2rt_om2,
2148 c     &  " eps2rt_om12",eps2rt_om12
2149 C Calculate whole angle-dependent part of epsilon and contributions
2150 C to its derivatives
2151       return
2152       end
2153 C----------------------------------------------------------------------------
2154       subroutine sc_grad
2155       implicit real*8 (a-h,o-z)
2156       include 'DIMENSIONS'
2157       include 'COMMON.CHAIN'
2158       include 'COMMON.DERIV'
2159       include 'COMMON.CALC'
2160       include 'COMMON.IOUNITS'
2161       double precision dcosom1(3),dcosom2(3)
2162 cc      print *,'sss=',sss
2163       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
2164       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
2165       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12
2166      &     -2.0D0*alf12*eps3der+sigder*sigsq_om12
2167 c diagnostics only
2168 c      eom1=0.0d0
2169 c      eom2=0.0d0
2170 c      eom12=evdwij*eps1_om12
2171 c end diagnostics
2172 c      write (iout,*) "eps2der",eps2der," eps3der",eps3der,
2173 c     &  " sigder",sigder
2174 c      write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12
2175 c      write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12
2176       do k=1,3
2177         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
2178         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
2179       enddo
2180       do k=1,3
2181         gg(k)=(gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k))*sss
2182       enddo
2183 c      write (iout,*) "gg",(gg(k),k=1,3)
2184       do k=1,3
2185         gvdwx(k,i)=gvdwx(k,i)-gg(k)+gg_lipi(k)
2186      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
2187      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv*sss
2188         gvdwx(k,j)=gvdwx(k,j)+gg(k)+gg_lipj(k)
2189      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
2190      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv*sss
2191 c        write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
2192 c     &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
2193 c        write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
2194 c     &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
2195       enddo
2196 C
2197 C Calculate the components of the gradient in DC and X
2198 C
2199 cgrad      do k=i,j-1
2200 cgrad        do l=1,3
2201 cgrad          gvdwc(l,k)=gvdwc(l,k)+gg(l)
2202 cgrad        enddo
2203 cgrad      enddo
2204       do l=1,3
2205         gvdwc(l,i)=gvdwc(l,i)-gg(l)+gg_lipi(l)
2206         gvdwc(l,j)=gvdwc(l,j)+gg(l)+gg_lipj(l)
2207       enddo
2208       return
2209       end
2210 C-----------------------------------------------------------------------
2211       subroutine e_softsphere(evdw)
2212 C
2213 C This subroutine calculates the interaction energy of nonbonded side chains
2214 C assuming the LJ potential of interaction.
2215 C
2216       implicit real*8 (a-h,o-z)
2217       include 'DIMENSIONS'
2218       parameter (accur=1.0d-10)
2219       include 'COMMON.GEO'
2220       include 'COMMON.VAR'
2221       include 'COMMON.LOCAL'
2222       include 'COMMON.CHAIN'
2223       include 'COMMON.DERIV'
2224       include 'COMMON.INTERACT'
2225       include 'COMMON.TORSION'
2226       include 'COMMON.SBRIDGE'
2227       include 'COMMON.NAMES'
2228       include 'COMMON.IOUNITS'
2229       include 'COMMON.CONTACTS'
2230       dimension gg(3)
2231 cd    print *,'Entering Esoft_sphere nnt=',nnt,' nct=',nct
2232       evdw=0.0D0
2233       do i=iatsc_s,iatsc_e
2234         itypi=iabs(itype(i))
2235         if (itypi.eq.ntyp1) cycle
2236         itypi1=iabs(itype(i+1))
2237         xi=c(1,nres+i)
2238         yi=c(2,nres+i)
2239         zi=c(3,nres+i)
2240 C
2241 C Calculate SC interaction energy.
2242 C
2243         do iint=1,nint_gr(i)
2244 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
2245 cd   &                  'iend=',iend(i,iint)
2246           do j=istart(i,iint),iend(i,iint)
2247             itypj=iabs(itype(j))
2248             if (itypj.eq.ntyp1) cycle
2249             xj=c(1,nres+j)-xi
2250             yj=c(2,nres+j)-yi
2251             zj=c(3,nres+j)-zi
2252             rij=xj*xj+yj*yj+zj*zj
2253 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
2254             r0ij=r0(itypi,itypj)
2255             r0ijsq=r0ij*r0ij
2256 c            print *,i,j,r0ij,dsqrt(rij)
2257             if (rij.lt.r0ijsq) then
2258               evdwij=0.25d0*(rij-r0ijsq)**2
2259               fac=rij-r0ijsq
2260             else
2261               evdwij=0.0d0
2262               fac=0.0d0
2263             endif
2264             evdw=evdw+evdwij
2265 C
2266 C Calculate the components of the gradient in DC and X
2267 C
2268             gg(1)=xj*fac
2269             gg(2)=yj*fac
2270             gg(3)=zj*fac
2271             do k=1,3
2272               gvdwx(k,i)=gvdwx(k,i)-gg(k)
2273               gvdwx(k,j)=gvdwx(k,j)+gg(k)
2274               gvdwc(k,i)=gvdwc(k,i)-gg(k)
2275               gvdwc(k,j)=gvdwc(k,j)+gg(k)
2276             enddo
2277 cgrad            do k=i,j-1
2278 cgrad              do l=1,3
2279 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
2280 cgrad              enddo
2281 cgrad            enddo
2282           enddo ! j
2283         enddo ! iint
2284       enddo ! i
2285       return
2286       end
2287 C--------------------------------------------------------------------------
2288       subroutine eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,
2289      &              eello_turn4)
2290 C
2291 C Soft-sphere potential of p-p interaction
2292 C
2293       implicit real*8 (a-h,o-z)
2294       include 'DIMENSIONS'
2295       include 'COMMON.CONTROL'
2296       include 'COMMON.IOUNITS'
2297       include 'COMMON.GEO'
2298       include 'COMMON.VAR'
2299       include 'COMMON.LOCAL'
2300       include 'COMMON.CHAIN'
2301       include 'COMMON.DERIV'
2302       include 'COMMON.INTERACT'
2303       include 'COMMON.CONTACTS'
2304       include 'COMMON.TORSION'
2305       include 'COMMON.VECTORS'
2306       include 'COMMON.FFIELD'
2307       dimension ggg(3)
2308 C      write(iout,*) 'In EELEC_soft_sphere'
2309       ees=0.0D0
2310       evdw1=0.0D0
2311       eel_loc=0.0d0
2312       eello_turn3=0.0d0
2313       eello_turn4=0.0d0
2314       ind=0
2315       do i=iatel_s,iatel_e
2316         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
2317         dxi=dc(1,i)
2318         dyi=dc(2,i)
2319         dzi=dc(3,i)
2320         xmedi=c(1,i)+0.5d0*dxi
2321         ymedi=c(2,i)+0.5d0*dyi
2322         zmedi=c(3,i)+0.5d0*dzi
2323           xmedi=mod(xmedi,boxxsize)
2324           if (xmedi.lt.0) xmedi=xmedi+boxxsize
2325           ymedi=mod(ymedi,boxysize)
2326           if (ymedi.lt.0) ymedi=ymedi+boxysize
2327           zmedi=mod(zmedi,boxzsize)
2328           if (zmedi.lt.0) zmedi=zmedi+boxzsize
2329         num_conti=0
2330 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
2331         do j=ielstart(i),ielend(i)
2332           if (itype(j).eq.ntyp1 .or. itype(j+1).eq.ntyp1) cycle
2333           ind=ind+1
2334           iteli=itel(i)
2335           itelj=itel(j)
2336           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
2337           r0ij=rpp(iteli,itelj)
2338           r0ijsq=r0ij*r0ij
2339           dxj=dc(1,j)
2340           dyj=dc(2,j)
2341           dzj=dc(3,j)
2342           xj=c(1,j)+0.5D0*dxj
2343           yj=c(2,j)+0.5D0*dyj
2344           zj=c(3,j)+0.5D0*dzj
2345           xj=mod(xj,boxxsize)
2346           if (xj.lt.0) xj=xj+boxxsize
2347           yj=mod(yj,boxysize)
2348           if (yj.lt.0) yj=yj+boxysize
2349           zj=mod(zj,boxzsize)
2350           if (zj.lt.0) zj=zj+boxzsize
2351       dist_init=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
2352       xj_safe=xj
2353       yj_safe=yj
2354       zj_safe=zj
2355       isubchap=0
2356       do xshift=-1,1
2357       do yshift=-1,1
2358       do zshift=-1,1
2359           xj=xj_safe+xshift*boxxsize
2360           yj=yj_safe+yshift*boxysize
2361           zj=zj_safe+zshift*boxzsize
2362           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
2363           if(dist_temp.lt.dist_init) then
2364             dist_init=dist_temp
2365             xj_temp=xj
2366             yj_temp=yj
2367             zj_temp=zj
2368             isubchap=1
2369           endif
2370        enddo
2371        enddo
2372        enddo
2373        if (isubchap.eq.1) then
2374           xj=xj_temp-xmedi
2375           yj=yj_temp-ymedi
2376           zj=zj_temp-zmedi
2377        else
2378           xj=xj_safe-xmedi
2379           yj=yj_safe-ymedi
2380           zj=zj_safe-zmedi
2381        endif
2382           rij=xj*xj+yj*yj+zj*zj
2383             sss=sscale(sqrt(rij))
2384             sssgrad=sscagrad(sqrt(rij))
2385           if (rij.lt.r0ijsq) then
2386             evdw1ij=0.25d0*(rij-r0ijsq)**2
2387             fac=rij-r0ijsq
2388           else
2389             evdw1ij=0.0d0
2390             fac=0.0d0
2391           endif
2392           evdw1=evdw1+evdw1ij*sss
2393 C
2394 C Calculate contributions to the Cartesian gradient.
2395 C
2396           ggg(1)=fac*xj*sssgrad
2397           ggg(2)=fac*yj*sssgrad
2398           ggg(3)=fac*zj*sssgrad
2399           do k=1,3
2400             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
2401             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
2402           enddo
2403 *
2404 * Loop over residues i+1 thru j-1.
2405 *
2406 cgrad          do k=i+1,j-1
2407 cgrad            do l=1,3
2408 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
2409 cgrad            enddo
2410 cgrad          enddo
2411         enddo ! j
2412       enddo   ! i
2413 cgrad      do i=nnt,nct-1
2414 cgrad        do k=1,3
2415 cgrad          gelc(k,i)=gelc(k,i)+0.5d0*gelc(k,i)
2416 cgrad        enddo
2417 cgrad        do j=i+1,nct-1
2418 cgrad          do k=1,3
2419 cgrad            gelc(k,i)=gelc(k,i)+gelc(k,j)
2420 cgrad          enddo
2421 cgrad        enddo
2422 cgrad      enddo
2423       return
2424       end
2425 c------------------------------------------------------------------------------
2426       subroutine vec_and_deriv
2427       implicit real*8 (a-h,o-z)
2428       include 'DIMENSIONS'
2429 #ifdef MPI
2430       include 'mpif.h'
2431 #endif
2432       include 'COMMON.IOUNITS'
2433       include 'COMMON.GEO'
2434       include 'COMMON.VAR'
2435       include 'COMMON.LOCAL'
2436       include 'COMMON.CHAIN'
2437       include 'COMMON.VECTORS'
2438       include 'COMMON.SETUP'
2439       include 'COMMON.TIME1'
2440       dimension uyder(3,3,2),uzder(3,3,2),vbld_inv_temp(2)
2441 C Compute the local reference systems. For reference system (i), the
2442 C X-axis points from CA(i) to CA(i+1), the Y axis is in the
2443 C CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
2444 #ifdef PARVEC
2445       do i=ivec_start,ivec_end
2446 #else
2447       do i=1,nres-1
2448 #endif
2449           if (i.eq.nres-1) then
2450 C Case of the last full residue
2451 C Compute the Z-axis
2452             call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
2453             costh=dcos(pi-theta(nres))
2454             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2455             do k=1,3
2456               uz(k,i)=fac*uz(k,i)
2457             enddo
2458 C Compute the derivatives of uz
2459             uzder(1,1,1)= 0.0d0
2460             uzder(2,1,1)=-dc_norm(3,i-1)
2461             uzder(3,1,1)= dc_norm(2,i-1)
2462             uzder(1,2,1)= dc_norm(3,i-1)
2463             uzder(2,2,1)= 0.0d0
2464             uzder(3,2,1)=-dc_norm(1,i-1)
2465             uzder(1,3,1)=-dc_norm(2,i-1)
2466             uzder(2,3,1)= dc_norm(1,i-1)
2467             uzder(3,3,1)= 0.0d0
2468             uzder(1,1,2)= 0.0d0
2469             uzder(2,1,2)= dc_norm(3,i)
2470             uzder(3,1,2)=-dc_norm(2,i)
2471             uzder(1,2,2)=-dc_norm(3,i)
2472             uzder(2,2,2)= 0.0d0
2473             uzder(3,2,2)= dc_norm(1,i)
2474             uzder(1,3,2)= dc_norm(2,i)
2475             uzder(2,3,2)=-dc_norm(1,i)
2476             uzder(3,3,2)= 0.0d0
2477 C Compute the Y-axis
2478             facy=fac
2479             do k=1,3
2480               uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
2481             enddo
2482 C Compute the derivatives of uy
2483             do j=1,3
2484               do k=1,3
2485                 uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i)
2486      &                        -dc_norm(k,i)*dc_norm(j,i-1)
2487                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2488               enddo
2489               uyder(j,j,1)=uyder(j,j,1)-costh
2490               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2491             enddo
2492             do j=1,2
2493               do k=1,3
2494                 do l=1,3
2495                   uygrad(l,k,j,i)=uyder(l,k,j)
2496                   uzgrad(l,k,j,i)=uzder(l,k,j)
2497                 enddo
2498               enddo
2499             enddo
2500             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2501             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2502             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2503             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2504           else
2505 C Other residues
2506 C Compute the Z-axis
2507             call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
2508             costh=dcos(pi-theta(i+2))
2509             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2510             do k=1,3
2511               uz(k,i)=fac*uz(k,i)
2512             enddo
2513 C Compute the derivatives of uz
2514             uzder(1,1,1)= 0.0d0
2515             uzder(2,1,1)=-dc_norm(3,i+1)
2516             uzder(3,1,1)= dc_norm(2,i+1)
2517             uzder(1,2,1)= dc_norm(3,i+1)
2518             uzder(2,2,1)= 0.0d0
2519             uzder(3,2,1)=-dc_norm(1,i+1)
2520             uzder(1,3,1)=-dc_norm(2,i+1)
2521             uzder(2,3,1)= dc_norm(1,i+1)
2522             uzder(3,3,1)= 0.0d0
2523             uzder(1,1,2)= 0.0d0
2524             uzder(2,1,2)= dc_norm(3,i)
2525             uzder(3,1,2)=-dc_norm(2,i)
2526             uzder(1,2,2)=-dc_norm(3,i)
2527             uzder(2,2,2)= 0.0d0
2528             uzder(3,2,2)= dc_norm(1,i)
2529             uzder(1,3,2)= dc_norm(2,i)
2530             uzder(2,3,2)=-dc_norm(1,i)
2531             uzder(3,3,2)= 0.0d0
2532 C Compute the Y-axis
2533             facy=fac
2534             do k=1,3
2535               uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
2536             enddo
2537 C Compute the derivatives of uy
2538             do j=1,3
2539               do k=1,3
2540                 uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i)
2541      &                        -dc_norm(k,i)*dc_norm(j,i+1)
2542                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2543               enddo
2544               uyder(j,j,1)=uyder(j,j,1)-costh
2545               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2546             enddo
2547             do j=1,2
2548               do k=1,3
2549                 do l=1,3
2550                   uygrad(l,k,j,i)=uyder(l,k,j)
2551                   uzgrad(l,k,j,i)=uzder(l,k,j)
2552                 enddo
2553               enddo
2554             enddo
2555             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2556             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2557             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2558             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2559           endif
2560       enddo
2561       do i=1,nres-1
2562         vbld_inv_temp(1)=vbld_inv(i+1)
2563         if (i.lt.nres-1) then
2564           vbld_inv_temp(2)=vbld_inv(i+2)
2565           else
2566           vbld_inv_temp(2)=vbld_inv(i)
2567           endif
2568         do j=1,2
2569           do k=1,3
2570             do l=1,3
2571               uygrad(l,k,j,i)=vbld_inv_temp(j)*uygrad(l,k,j,i)
2572               uzgrad(l,k,j,i)=vbld_inv_temp(j)*uzgrad(l,k,j,i)
2573             enddo
2574           enddo
2575         enddo
2576       enddo
2577 #if defined(PARVEC) && defined(MPI)
2578       if (nfgtasks1.gt.1) then
2579         time00=MPI_Wtime()
2580 c        print *,"Processor",fg_rank1,kolor1," ivec_start",ivec_start,
2581 c     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks1-1),
2582 c     &   " ivec_count",(ivec_count(i),i=0,nfgtasks1-1)
2583         call MPI_Allgatherv(uy(1,ivec_start),ivec_count(fg_rank1),
2584      &   MPI_UYZ,uy(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
2585      &   FG_COMM1,IERR)
2586         call MPI_Allgatherv(uz(1,ivec_start),ivec_count(fg_rank1),
2587      &   MPI_UYZ,uz(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
2588      &   FG_COMM1,IERR)
2589         call MPI_Allgatherv(uygrad(1,1,1,ivec_start),
2590      &   ivec_count(fg_rank1),MPI_UYZGRAD,uygrad(1,1,1,1),ivec_count(0),
2591      &   ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2592         call MPI_Allgatherv(uzgrad(1,1,1,ivec_start),
2593      &   ivec_count(fg_rank1),MPI_UYZGRAD,uzgrad(1,1,1,1),ivec_count(0),
2594      &   ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2595         time_gather=time_gather+MPI_Wtime()-time00
2596       endif
2597 c      if (fg_rank.eq.0) then
2598 c        write (iout,*) "Arrays UY and UZ"
2599 c        do i=1,nres-1
2600 c          write (iout,'(i5,3f10.5,5x,3f10.5)') i,(uy(k,i),k=1,3),
2601 c     &     (uz(k,i),k=1,3)
2602 c        enddo
2603 c      endif
2604 #endif
2605       return
2606       end
2607 C-----------------------------------------------------------------------------
2608       subroutine check_vecgrad
2609       implicit real*8 (a-h,o-z)
2610       include 'DIMENSIONS'
2611       include 'COMMON.IOUNITS'
2612       include 'COMMON.GEO'
2613       include 'COMMON.VAR'
2614       include 'COMMON.LOCAL'
2615       include 'COMMON.CHAIN'
2616       include 'COMMON.VECTORS'
2617       dimension uygradt(3,3,2,maxres),uzgradt(3,3,2,maxres)
2618       dimension uyt(3,maxres),uzt(3,maxres)
2619       dimension uygradn(3,3,2),uzgradn(3,3,2),erij(3)
2620       double precision delta /1.0d-7/
2621       call vec_and_deriv
2622 cd      do i=1,nres
2623 crc          write(iout,'(2i5,2(3f10.5,5x))') i,1,dc_norm(:,i)
2624 crc          write(iout,'(2i5,2(3f10.5,5x))') i,2,uy(:,i)
2625 crc          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,uz(:,i)
2626 cd          write(iout,'(2i5,2(3f10.5,5x))') i,1,
2627 cd     &     (dc_norm(if90,i),if90=1,3)
2628 cd          write(iout,'(2i5,2(3f10.5,5x))') i,2,(uy(if90,i),if90=1,3)
2629 cd          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,(uz(if90,i),if90=1,3)
2630 cd          write(iout,'(a)')
2631 cd      enddo
2632       do i=1,nres
2633         do j=1,2
2634           do k=1,3
2635             do l=1,3
2636               uygradt(l,k,j,i)=uygrad(l,k,j,i)
2637               uzgradt(l,k,j,i)=uzgrad(l,k,j,i)
2638             enddo
2639           enddo
2640         enddo
2641       enddo
2642       call vec_and_deriv
2643       do i=1,nres
2644         do j=1,3
2645           uyt(j,i)=uy(j,i)
2646           uzt(j,i)=uz(j,i)
2647         enddo
2648       enddo
2649       do i=1,nres
2650 cd        write (iout,*) 'i=',i
2651         do k=1,3
2652           erij(k)=dc_norm(k,i)
2653         enddo
2654         do j=1,3
2655           do k=1,3
2656             dc_norm(k,i)=erij(k)
2657           enddo
2658           dc_norm(j,i)=dc_norm(j,i)+delta
2659 c          fac=dsqrt(scalar(dc_norm(1,i),dc_norm(1,i)))
2660 c          do k=1,3
2661 c            dc_norm(k,i)=dc_norm(k,i)/fac
2662 c          enddo
2663 c          write (iout,*) (dc_norm(k,i),k=1,3)
2664 c          write (iout,*) (erij(k),k=1,3)
2665           call vec_and_deriv
2666           do k=1,3
2667             uygradn(k,j,1)=(uy(k,i)-uyt(k,i))/delta
2668             uygradn(k,j,2)=(uy(k,i-1)-uyt(k,i-1))/delta
2669             uzgradn(k,j,1)=(uz(k,i)-uzt(k,i))/delta
2670             uzgradn(k,j,2)=(uz(k,i-1)-uzt(k,i-1))/delta
2671           enddo
2672 c          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2673 c     &      j,(uzgradt(k,j,1,i),k=1,3),(uzgradn(k,j,1),k=1,3),
2674 c     &      (uzgradt(k,j,2,i-1),k=1,3),(uzgradn(k,j,2),k=1,3)
2675         enddo
2676         do k=1,3
2677           dc_norm(k,i)=erij(k)
2678         enddo
2679 cd        do k=1,3
2680 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2681 cd     &      k,(uygradt(k,l,1,i),l=1,3),(uygradn(k,l,1),l=1,3),
2682 cd     &      (uygradt(k,l,2,i-1),l=1,3),(uygradn(k,l,2),l=1,3)
2683 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2684 cd     &      k,(uzgradt(k,l,1,i),l=1,3),(uzgradn(k,l,1),l=1,3),
2685 cd     &      (uzgradt(k,l,2,i-1),l=1,3),(uzgradn(k,l,2),l=1,3)
2686 cd          write (iout,'(a)')
2687 cd        enddo
2688       enddo
2689       return
2690       end
2691 C--------------------------------------------------------------------------
2692       subroutine set_matrices
2693       implicit real*8 (a-h,o-z)
2694       include 'DIMENSIONS'
2695 #ifdef MPI
2696       include "mpif.h"
2697       include "COMMON.SETUP"
2698       integer IERR
2699       integer status(MPI_STATUS_SIZE)
2700 #endif
2701       include 'COMMON.IOUNITS'
2702       include 'COMMON.GEO'
2703       include 'COMMON.VAR'
2704       include 'COMMON.LOCAL'
2705       include 'COMMON.CHAIN'
2706       include 'COMMON.DERIV'
2707       include 'COMMON.INTERACT'
2708       include 'COMMON.CONTACTS'
2709       include 'COMMON.TORSION'
2710       include 'COMMON.VECTORS'
2711       include 'COMMON.FFIELD'
2712       double precision auxvec(2),auxmat(2,2)
2713 C
2714 C Compute the virtual-bond-torsional-angle dependent quantities needed
2715 C to calculate the el-loc multibody terms of various order.
2716 C
2717 c      write(iout,*) 'nphi=',nphi,nres
2718 #ifdef PARMAT
2719       do i=ivec_start+2,ivec_end+2
2720 #else
2721       do i=3,nres+1
2722 #endif
2723 #ifdef NEWCORR
2724         if (i.gt. nnt+2 .and. i.lt.nct+2) then
2725           iti = itortyp(itype(i-2))
2726         else
2727           iti=ntortyp+1
2728         endif
2729 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2730         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2731           iti1 = itortyp(itype(i-1))
2732         else
2733           iti1=ntortyp+1
2734         endif
2735 c        write(iout,*),i
2736         b1(1,i-2)=bnew1(1,1,iti)*dsin(theta(i-1)/2.0)
2737      &           +bnew1(2,1,iti)*dsin(theta(i-1))
2738      &           +bnew1(3,1,iti)*dcos(theta(i-1)/2.0)
2739         gtb1(1,i-2)=bnew1(1,1,iti)*dcos(theta(i-1)/2.0d0)/2.0d0
2740      &             +bnew1(2,1,iti)*dcos(theta(i-1))
2741      &             -bnew1(3,1,iti)*dsin(theta(i-1)/2.0d0)/2.0d0
2742 c     &           +bnew1(3,1,iti)*sin(alpha(i))*cos(beta(i))
2743 c     &*(cos(theta(i)/2.0)
2744         b2(1,i-2)=bnew2(1,1,iti)*dsin(theta(i-1)/2.0)
2745      &           +bnew2(2,1,iti)*dsin(theta(i-1))
2746      &           +bnew2(3,1,iti)*dcos(theta(i-1)/2.0)
2747 c     &           +bnew2(3,1,iti)*sin(alpha(i))*cos(beta(i))
2748 c     &*(cos(theta(i)/2.0)
2749         gtb2(1,i-2)=bnew2(1,1,iti)*dcos(theta(i-1)/2.0d0)/2.0d0
2750      &             +bnew2(2,1,iti)*dcos(theta(i-1))
2751      &             -bnew2(3,1,iti)*dsin(theta(i-1)/2.0d0)/2.0d0
2752 c        if (ggb1(1,i).eq.0.0d0) then
2753 c        write(iout,*) 'i=',i,ggb1(1,i),
2754 c     &bnew1(1,1,iti)*cos(theta(i)/2.0)/2.0,
2755 c     &bnew1(2,1,iti)*cos(theta(i)),
2756 c     &bnew1(3,1,iti)*sin(theta(i)/2.0)/2.0
2757 c        endif
2758         b1(2,i-2)=bnew1(1,2,iti)
2759         gtb1(2,i-2)=0.0
2760         b2(2,i-2)=bnew2(1,2,iti)
2761         gtb2(2,i-2)=0.0
2762         EE(1,1,i-2)=eenew(1,iti)*dcos(theta(i-1))
2763         EE(1,2,i-2)=eeold(1,2,iti)
2764         EE(2,1,i-2)=eeold(2,1,iti)
2765         EE(2,2,i-2)=eeold(2,2,iti)
2766         gtEE(1,1,i-2)=-eenew(1,iti)*dsin(theta(i-1))
2767         gtEE(1,2,i-2)=0.0d0
2768         gtEE(2,2,i-2)=0.0d0
2769         gtEE(2,1,i-2)=0.0d0
2770 c        EE(2,2,iti)=0.0d0
2771 c        EE(1,2,iti)=0.5d0*eenew(1,iti)
2772 c        EE(2,1,iti)=0.5d0*eenew(1,iti)
2773 c        b1(2,iti)=bnew1(1,2,iti)*sin(alpha(i))*sin(beta(i))
2774 c        b2(2,iti)=bnew2(1,2,iti)*sin(alpha(i))*sin(beta(i))
2775        b1tilde(1,i-2)=b1(1,i-2)
2776        b1tilde(2,i-2)=-b1(2,i-2)
2777        b2tilde(1,i-2)=b2(1,i-2)
2778        b2tilde(2,i-2)=-b2(2,i-2)
2779 c       write (iout,*) 'i=',i-2,gtb1(2,i-2),gtb1(1,i-2)
2780 c       write(iout,*)  'b1=',b1(1,i-2)
2781 c       write (iout,*) 'theta=', theta(i-1)
2782        enddo
2783 #else
2784         if (i.gt. nnt+2 .and. i.lt.nct+2) then
2785           iti = itortyp(itype(i-2))
2786         else
2787           iti=ntortyp+1
2788         endif
2789 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2790         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2791           iti1 = itortyp(itype(i-1))
2792         else
2793           iti1=ntortyp+1
2794         endif
2795         b1(1,i-2)=b(3,iti)
2796         b1(2,i-2)=b(5,iti)
2797         b2(1,i-2)=b(2,iti)
2798         b2(2,i-2)=b(4,iti)
2799        b1tilde(1,i-2)=b1(1,i-2)
2800        b1tilde(2,i-2)=-b1(2,i-2)
2801        b2tilde(1,i-2)=b2(1,i-2)
2802        b2tilde(2,i-2)=-b2(2,i-2)
2803         EE(1,2,i-2)=eeold(1,2,iti)
2804         EE(2,1,i-2)=eeold(2,1,iti)
2805         EE(2,2,i-2)=eeold(2,2,iti)
2806         EE(1,1,i-2)=eeold(1,1,iti)
2807       enddo
2808 #endif
2809 #ifdef PARMAT
2810       do i=ivec_start+2,ivec_end+2
2811 #else
2812       do i=3,nres+1
2813 #endif
2814         if (i .lt. nres+1) then
2815           sin1=dsin(phi(i))
2816           cos1=dcos(phi(i))
2817           sintab(i-2)=sin1
2818           costab(i-2)=cos1
2819           obrot(1,i-2)=cos1
2820           obrot(2,i-2)=sin1
2821           sin2=dsin(2*phi(i))
2822           cos2=dcos(2*phi(i))
2823           sintab2(i-2)=sin2
2824           costab2(i-2)=cos2
2825           obrot2(1,i-2)=cos2
2826           obrot2(2,i-2)=sin2
2827           Ug(1,1,i-2)=-cos1
2828           Ug(1,2,i-2)=-sin1
2829           Ug(2,1,i-2)=-sin1
2830           Ug(2,2,i-2)= cos1
2831           Ug2(1,1,i-2)=-cos2
2832           Ug2(1,2,i-2)=-sin2
2833           Ug2(2,1,i-2)=-sin2
2834           Ug2(2,2,i-2)= cos2
2835         else
2836           costab(i-2)=1.0d0
2837           sintab(i-2)=0.0d0
2838           obrot(1,i-2)=1.0d0
2839           obrot(2,i-2)=0.0d0
2840           obrot2(1,i-2)=0.0d0
2841           obrot2(2,i-2)=0.0d0
2842           Ug(1,1,i-2)=1.0d0
2843           Ug(1,2,i-2)=0.0d0
2844           Ug(2,1,i-2)=0.0d0
2845           Ug(2,2,i-2)=1.0d0
2846           Ug2(1,1,i-2)=0.0d0
2847           Ug2(1,2,i-2)=0.0d0
2848           Ug2(2,1,i-2)=0.0d0
2849           Ug2(2,2,i-2)=0.0d0
2850         endif
2851         if (i .gt. 3 .and. i .lt. nres+1) then
2852           obrot_der(1,i-2)=-sin1
2853           obrot_der(2,i-2)= cos1
2854           Ugder(1,1,i-2)= sin1
2855           Ugder(1,2,i-2)=-cos1
2856           Ugder(2,1,i-2)=-cos1
2857           Ugder(2,2,i-2)=-sin1
2858           dwacos2=cos2+cos2
2859           dwasin2=sin2+sin2
2860           obrot2_der(1,i-2)=-dwasin2
2861           obrot2_der(2,i-2)= dwacos2
2862           Ug2der(1,1,i-2)= dwasin2
2863           Ug2der(1,2,i-2)=-dwacos2
2864           Ug2der(2,1,i-2)=-dwacos2
2865           Ug2der(2,2,i-2)=-dwasin2
2866         else
2867           obrot_der(1,i-2)=0.0d0
2868           obrot_der(2,i-2)=0.0d0
2869           Ugder(1,1,i-2)=0.0d0
2870           Ugder(1,2,i-2)=0.0d0
2871           Ugder(2,1,i-2)=0.0d0
2872           Ugder(2,2,i-2)=0.0d0
2873           obrot2_der(1,i-2)=0.0d0
2874           obrot2_der(2,i-2)=0.0d0
2875           Ug2der(1,1,i-2)=0.0d0
2876           Ug2der(1,2,i-2)=0.0d0
2877           Ug2der(2,1,i-2)=0.0d0
2878           Ug2der(2,2,i-2)=0.0d0
2879         endif
2880 c        if (i.gt. iatel_s+2 .and. i.lt.iatel_e+5) then
2881         if (i.gt. nnt+2 .and. i.lt.nct+2) then
2882           iti = itortyp(itype(i-2))
2883         else
2884           iti=ntortyp
2885         endif
2886 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2887         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2888           iti1 = itortyp(itype(i-1))
2889         else
2890           iti1=ntortyp
2891         endif
2892 cd        write (iout,*) '*******i',i,' iti1',iti
2893 cd        write (iout,*) 'b1',b1(:,iti)
2894 cd        write (iout,*) 'b2',b2(:,iti)
2895 cd         write (iout,*) "phi(",i,")=",phi(i)," sin1",sin1," cos1",cos1
2896 cd         write (iout,*) 'Ug',Ug(:,:,i-2)
2897 c        if (i .gt. iatel_s+2) then
2898         if (i .gt. nnt+2) then
2899           call matvec2(Ug(1,1,i-2),b2(1,i-2),Ub2(1,i-2))
2900 #ifdef NEWCORR
2901           call matvec2(Ug(1,1,i-2),gtb2(1,i-2),gUb2(1,i-2))
2902 c          write (iout,*) Ug(1,1,i-2),gtb2(1,i-2),gUb2(1,i-2),"chuj"
2903 #endif
2904 c          write(iout,*) "co jest kurwa", iti, EE(1,1,iti),EE(2,1,iti),
2905 c     &    EE(1,2,iti),EE(2,2,iti)
2906           call matmat2(EE(1,1,i-2),Ug(1,1,i-2),EUg(1,1,i-2))
2907           call matmat2(gtEE(1,1,i-2),Ug(1,1,i-2),gtEUg(1,1,i-2))
2908 c          write(iout,*) "Macierz EUG",
2909 c     &    eug(1,1,i-2),eug(1,2,i-2),eug(2,1,i-2),
2910 c     &    eug(2,2,i-2)
2911           if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2912      &    then
2913           call matmat2(CC(1,1,iti),Ug(1,1,i-2),CUg(1,1,i-2))
2914           call matmat2(DD(1,1,iti),Ug(1,1,i-2),DUg(1,1,i-2))
2915           call matmat2(Dtilde(1,1,iti),Ug2(1,1,i-2),DtUg2(1,1,i-2))
2916           call matvec2(Ctilde(1,1,iti1),obrot(1,i-2),Ctobr(1,i-2))
2917           call matvec2(Dtilde(1,1,iti),obrot2(1,i-2),Dtobr2(1,i-2))
2918           endif
2919         else
2920           do k=1,2
2921             Ub2(k,i-2)=0.0d0
2922             Ctobr(k,i-2)=0.0d0
2923             Dtobr2(k,i-2)=0.0d0
2924             do l=1,2
2925               EUg(l,k,i-2)=0.0d0
2926               CUg(l,k,i-2)=0.0d0
2927               DUg(l,k,i-2)=0.0d0
2928               DtUg2(l,k,i-2)=0.0d0
2929             enddo
2930           enddo
2931         endif
2932         call matvec2(Ugder(1,1,i-2),b2(1,i-2),Ub2der(1,i-2))
2933         call matmat2(EE(1,1,i-2),Ugder(1,1,i-2),EUgder(1,1,i-2))
2934         do k=1,2
2935           muder(k,i-2)=Ub2der(k,i-2)
2936         enddo
2937 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2938         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2939           if (itype(i-1).le.ntyp) then
2940             iti1 = itortyp(itype(i-1))
2941           else
2942             iti1=ntortyp
2943           endif
2944         else
2945           iti1=ntortyp
2946         endif
2947         do k=1,2
2948           mu(k,i-2)=Ub2(k,i-2)+b1(k,i-1)
2949         enddo
2950 C        write (iout,*) 'mumu',i,b1(1,i-1),Ub2(1,i-2)
2951 cd        write (iout,*) 'mu  ',mu(:,i-2),i-2
2952 cd        write (iout,*) 'b1  ',b1(:,i-1),i-2
2953 cd        write (iout,*) 'Ub2 ',Ub2(:,i-2),i-2
2954 cd        write (iout,*) 'Ug  ',Ug(:,:,i-2),i-2
2955 cd        write (iout,*) 'b2  ',b2(:,i-2),i-2
2956 cd        write (iout,*) 'mu1',mu1(:,i-2)
2957 cd        write (iout,*) 'mu2',mu2(:,i-2)
2958         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
2959      &  then
2960         call matmat2(CC(1,1,iti1),Ugder(1,1,i-2),CUgder(1,1,i-2))
2961         call matmat2(DD(1,1,iti),Ugder(1,1,i-2),DUgder(1,1,i-2))
2962         call matmat2(Dtilde(1,1,iti),Ug2der(1,1,i-2),DtUg2der(1,1,i-2))
2963         call matvec2(Ctilde(1,1,iti1),obrot_der(1,i-2),Ctobrder(1,i-2))
2964         call matvec2(Dtilde(1,1,iti),obrot2_der(1,i-2),Dtobr2der(1,i-2))
2965 C Vectors and matrices dependent on a single virtual-bond dihedral.
2966         call matvec2(DD(1,1,iti),b1tilde(1,i-1),auxvec(1))
2967         call matvec2(Ug2(1,1,i-2),auxvec(1),Ug2Db1t(1,i-2))
2968         call matvec2(Ug2der(1,1,i-2),auxvec(1),Ug2Db1tder(1,i-2))
2969         call matvec2(CC(1,1,iti1),Ub2(1,i-2),CUgb2(1,i-2))
2970         call matvec2(CC(1,1,iti1),Ub2der(1,i-2),CUgb2der(1,i-2))
2971         call matmat2(EUg(1,1,i-2),CC(1,1,iti1),EUgC(1,1,i-2))
2972         call matmat2(EUgder(1,1,i-2),CC(1,1,iti1),EUgCder(1,1,i-2))
2973         call matmat2(EUg(1,1,i-2),DD(1,1,iti1),EUgD(1,1,i-2))
2974         call matmat2(EUgder(1,1,i-2),DD(1,1,iti1),EUgDder(1,1,i-2))
2975         endif
2976       enddo
2977 C Matrices dependent on two consecutive virtual-bond dihedrals.
2978 C The order of matrices is from left to right.
2979       if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
2980      &then
2981 c      do i=max0(ivec_start,2),ivec_end
2982       do i=2,nres-1
2983         call matmat2(DtUg2(1,1,i-1),EUg(1,1,i),DtUg2EUg(1,1,i))
2984         call matmat2(DtUg2der(1,1,i-1),EUg(1,1,i),DtUg2EUgder(1,1,1,i))
2985         call matmat2(DtUg2(1,1,i-1),EUgder(1,1,i),DtUg2EUgder(1,1,2,i))
2986         call transpose2(DtUg2(1,1,i-1),auxmat(1,1))
2987         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUg(1,1,i))
2988         call matmat2(auxmat(1,1),EUgder(1,1,i),Ug2DtEUgder(1,1,2,i))
2989         call transpose2(DtUg2der(1,1,i-1),auxmat(1,1))
2990         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUgder(1,1,1,i))
2991       enddo
2992       endif
2993 #if defined(MPI) && defined(PARMAT)
2994 #ifdef DEBUG
2995 c      if (fg_rank.eq.0) then
2996         write (iout,*) "Arrays UG and UGDER before GATHER"
2997         do i=1,nres-1
2998           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2999      &     ((ug(l,k,i),l=1,2),k=1,2),
3000      &     ((ugder(l,k,i),l=1,2),k=1,2)
3001         enddo
3002         write (iout,*) "Arrays UG2 and UG2DER"
3003         do i=1,nres-1
3004           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3005      &     ((ug2(l,k,i),l=1,2),k=1,2),
3006      &     ((ug2der(l,k,i),l=1,2),k=1,2)
3007         enddo
3008         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
3009         do i=1,nres-1
3010           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3011      &     (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
3012      &     (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
3013         enddo
3014         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
3015         do i=1,nres-1
3016           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3017      &     costab(i),sintab(i),costab2(i),sintab2(i)
3018         enddo
3019         write (iout,*) "Array MUDER"
3020         do i=1,nres-1
3021           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
3022         enddo
3023 c      endif
3024 #endif
3025       if (nfgtasks.gt.1) then
3026         time00=MPI_Wtime()
3027 c        write(iout,*)"Processor",fg_rank,kolor," ivec_start",ivec_start,
3028 c     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks-1),
3029 c     &   " ivec_count",(ivec_count(i),i=0,nfgtasks-1)
3030 #ifdef MATGATHER
3031         call MPI_Allgatherv(Ub2(1,ivec_start),ivec_count(fg_rank1),
3032      &   MPI_MU,Ub2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3033      &   FG_COMM1,IERR)
3034         call MPI_Allgatherv(Ub2der(1,ivec_start),ivec_count(fg_rank1),
3035      &   MPI_MU,Ub2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3036      &   FG_COMM1,IERR)
3037         call MPI_Allgatherv(mu(1,ivec_start),ivec_count(fg_rank1),
3038      &   MPI_MU,mu(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3039      &   FG_COMM1,IERR)
3040         call MPI_Allgatherv(muder(1,ivec_start),ivec_count(fg_rank1),
3041      &   MPI_MU,muder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3042      &   FG_COMM1,IERR)
3043         call MPI_Allgatherv(Eug(1,1,ivec_start),ivec_count(fg_rank1),
3044      &   MPI_MAT1,Eug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3045      &   FG_COMM1,IERR)
3046         call MPI_Allgatherv(Eugder(1,1,ivec_start),ivec_count(fg_rank1),
3047      &   MPI_MAT1,Eugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3048      &   FG_COMM1,IERR)
3049         call MPI_Allgatherv(costab(ivec_start),ivec_count(fg_rank1),
3050      &   MPI_DOUBLE_PRECISION,costab(1),ivec_count(0),ivec_displ(0),
3051      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3052         call MPI_Allgatherv(sintab(ivec_start),ivec_count(fg_rank1),
3053      &   MPI_DOUBLE_PRECISION,sintab(1),ivec_count(0),ivec_displ(0),
3054      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3055         call MPI_Allgatherv(costab2(ivec_start),ivec_count(fg_rank1),
3056      &   MPI_DOUBLE_PRECISION,costab2(1),ivec_count(0),ivec_displ(0),
3057      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3058         call MPI_Allgatherv(sintab2(ivec_start),ivec_count(fg_rank1),
3059      &   MPI_DOUBLE_PRECISION,sintab2(1),ivec_count(0),ivec_displ(0),
3060      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3061         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
3062      &  then
3063         call MPI_Allgatherv(Ctobr(1,ivec_start),ivec_count(fg_rank1),
3064      &   MPI_MU,Ctobr(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3065      &   FG_COMM1,IERR)
3066         call MPI_Allgatherv(Ctobrder(1,ivec_start),ivec_count(fg_rank1),
3067      &   MPI_MU,Ctobrder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3068      &   FG_COMM1,IERR)
3069         call MPI_Allgatherv(Dtobr2(1,ivec_start),ivec_count(fg_rank1),
3070      &   MPI_MU,Dtobr2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3071      &   FG_COMM1,IERR)
3072        call MPI_Allgatherv(Dtobr2der(1,ivec_start),ivec_count(fg_rank1),
3073      &   MPI_MU,Dtobr2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3074      &   FG_COMM1,IERR)
3075         call MPI_Allgatherv(Ug2Db1t(1,ivec_start),ivec_count(fg_rank1),
3076      &   MPI_MU,Ug2Db1t(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3077      &   FG_COMM1,IERR)
3078         call MPI_Allgatherv(Ug2Db1tder(1,ivec_start),
3079      &   ivec_count(fg_rank1),
3080      &   MPI_MU,Ug2Db1tder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3081      &   FG_COMM1,IERR)
3082         call MPI_Allgatherv(CUgb2(1,ivec_start),ivec_count(fg_rank1),
3083      &   MPI_MU,CUgb2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3084      &   FG_COMM1,IERR)
3085         call MPI_Allgatherv(CUgb2der(1,ivec_start),ivec_count(fg_rank1),
3086      &   MPI_MU,CUgb2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3087      &   FG_COMM1,IERR)
3088         call MPI_Allgatherv(Cug(1,1,ivec_start),ivec_count(fg_rank1),
3089      &   MPI_MAT1,Cug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3090      &   FG_COMM1,IERR)
3091         call MPI_Allgatherv(Cugder(1,1,ivec_start),ivec_count(fg_rank1),
3092      &   MPI_MAT1,Cugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3093      &   FG_COMM1,IERR)
3094         call MPI_Allgatherv(Dug(1,1,ivec_start),ivec_count(fg_rank1),
3095      &   MPI_MAT1,Dug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3096      &   FG_COMM1,IERR)
3097         call MPI_Allgatherv(Dugder(1,1,ivec_start),ivec_count(fg_rank1),
3098      &   MPI_MAT1,Dugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3099      &   FG_COMM1,IERR)
3100         call MPI_Allgatherv(Dtug2(1,1,ivec_start),ivec_count(fg_rank1),
3101      &   MPI_MAT1,Dtug2(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3102      &   FG_COMM1,IERR)
3103         call MPI_Allgatherv(Dtug2der(1,1,ivec_start),
3104      &   ivec_count(fg_rank1),
3105      &   MPI_MAT1,Dtug2der(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3106      &   FG_COMM1,IERR)
3107         call MPI_Allgatherv(EugC(1,1,ivec_start),ivec_count(fg_rank1),
3108      &   MPI_MAT1,EugC(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3109      &   FG_COMM1,IERR)
3110        call MPI_Allgatherv(EugCder(1,1,ivec_start),ivec_count(fg_rank1),
3111      &   MPI_MAT1,EugCder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3112      &   FG_COMM1,IERR)
3113         call MPI_Allgatherv(EugD(1,1,ivec_start),ivec_count(fg_rank1),
3114      &   MPI_MAT1,EugD(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3115      &   FG_COMM1,IERR)
3116        call MPI_Allgatherv(EugDder(1,1,ivec_start),ivec_count(fg_rank1),
3117      &   MPI_MAT1,EugDder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3118      &   FG_COMM1,IERR)
3119         call MPI_Allgatherv(DtUg2EUg(1,1,ivec_start),
3120      &   ivec_count(fg_rank1),
3121      &   MPI_MAT1,DtUg2EUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3122      &   FG_COMM1,IERR)
3123         call MPI_Allgatherv(Ug2DtEUg(1,1,ivec_start),
3124      &   ivec_count(fg_rank1),
3125      &   MPI_MAT1,Ug2DtEUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3126      &   FG_COMM1,IERR)
3127         call MPI_Allgatherv(DtUg2EUgder(1,1,1,ivec_start),
3128      &   ivec_count(fg_rank1),
3129      &   MPI_MAT2,DtUg2EUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
3130      &   MPI_MAT2,FG_COMM1,IERR)
3131         call MPI_Allgatherv(Ug2DtEUgder(1,1,1,ivec_start),
3132      &   ivec_count(fg_rank1),
3133      &   MPI_MAT2,Ug2DtEUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
3134      &   MPI_MAT2,FG_COMM1,IERR)
3135         endif
3136 #else
3137 c Passes matrix info through the ring
3138       isend=fg_rank1
3139       irecv=fg_rank1-1
3140       if (irecv.lt.0) irecv=nfgtasks1-1
3141       iprev=irecv
3142       inext=fg_rank1+1
3143       if (inext.ge.nfgtasks1) inext=0
3144       do i=1,nfgtasks1-1
3145 c        write (iout,*) "isend",isend," irecv",irecv
3146 c        call flush(iout)
3147         lensend=lentyp(isend)
3148         lenrecv=lentyp(irecv)
3149 c        write (iout,*) "lensend",lensend," lenrecv",lenrecv
3150 c        call MPI_SENDRECV(ug(1,1,ivec_displ(isend)+1),1,
3151 c     &   MPI_ROTAT1(lensend),inext,2200+isend,
3152 c     &   ug(1,1,ivec_displ(irecv)+1),1,MPI_ROTAT1(lenrecv),
3153 c     &   iprev,2200+irecv,FG_COMM,status,IERR)
3154 c        write (iout,*) "Gather ROTAT1"
3155 c        call flush(iout)
3156 c        call MPI_SENDRECV(obrot(1,ivec_displ(isend)+1),1,
3157 c     &   MPI_ROTAT2(lensend),inext,3300+isend,
3158 c     &   obrot(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
3159 c     &   iprev,3300+irecv,FG_COMM,status,IERR)
3160 c        write (iout,*) "Gather ROTAT2"
3161 c        call flush(iout)
3162         call MPI_SENDRECV(costab(ivec_displ(isend)+1),1,
3163      &   MPI_ROTAT_OLD(lensend),inext,4400+isend,
3164      &   costab(ivec_displ(irecv)+1),1,MPI_ROTAT_OLD(lenrecv),
3165      &   iprev,4400+irecv,FG_COMM,status,IERR)
3166 c        write (iout,*) "Gather ROTAT_OLD"
3167 c        call flush(iout)
3168         call MPI_SENDRECV(mu(1,ivec_displ(isend)+1),1,
3169      &   MPI_PRECOMP11(lensend),inext,5500+isend,
3170      &   mu(1,ivec_displ(irecv)+1),1,MPI_PRECOMP11(lenrecv),
3171      &   iprev,5500+irecv,FG_COMM,status,IERR)
3172 c        write (iout,*) "Gather PRECOMP11"
3173 c        call flush(iout)
3174         call MPI_SENDRECV(Eug(1,1,ivec_displ(isend)+1),1,
3175      &   MPI_PRECOMP12(lensend),inext,6600+isend,
3176      &   Eug(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP12(lenrecv),
3177      &   iprev,6600+irecv,FG_COMM,status,IERR)
3178 c        write (iout,*) "Gather PRECOMP12"
3179 c        call flush(iout)
3180         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
3181      &  then
3182         call MPI_SENDRECV(ug2db1t(1,ivec_displ(isend)+1),1,
3183      &   MPI_ROTAT2(lensend),inext,7700+isend,
3184      &   ug2db1t(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
3185      &   iprev,7700+irecv,FG_COMM,status,IERR)
3186 c        write (iout,*) "Gather PRECOMP21"
3187 c        call flush(iout)
3188         call MPI_SENDRECV(EUgC(1,1,ivec_displ(isend)+1),1,
3189      &   MPI_PRECOMP22(lensend),inext,8800+isend,
3190      &   EUgC(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP22(lenrecv),
3191      &   iprev,8800+irecv,FG_COMM,status,IERR)
3192 c        write (iout,*) "Gather PRECOMP22"
3193 c        call flush(iout)
3194         call MPI_SENDRECV(Ug2DtEUgder(1,1,1,ivec_displ(isend)+1),1,
3195      &   MPI_PRECOMP23(lensend),inext,9900+isend,
3196      &   Ug2DtEUgder(1,1,1,ivec_displ(irecv)+1),1,
3197      &   MPI_PRECOMP23(lenrecv),
3198      &   iprev,9900+irecv,FG_COMM,status,IERR)
3199 c        write (iout,*) "Gather PRECOMP23"
3200 c        call flush(iout)
3201         endif
3202         isend=irecv
3203         irecv=irecv-1
3204         if (irecv.lt.0) irecv=nfgtasks1-1
3205       enddo
3206 #endif
3207         time_gather=time_gather+MPI_Wtime()-time00
3208       endif
3209 #ifdef DEBUG
3210 c      if (fg_rank.eq.0) then
3211         write (iout,*) "Arrays UG and UGDER"
3212         do i=1,nres-1
3213           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3214      &     ((ug(l,k,i),l=1,2),k=1,2),
3215      &     ((ugder(l,k,i),l=1,2),k=1,2)
3216         enddo
3217         write (iout,*) "Arrays UG2 and UG2DER"
3218         do i=1,nres-1
3219           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3220      &     ((ug2(l,k,i),l=1,2),k=1,2),
3221      &     ((ug2der(l,k,i),l=1,2),k=1,2)
3222         enddo
3223         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
3224         do i=1,nres-1
3225           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3226      &     (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
3227      &     (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
3228         enddo
3229         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
3230         do i=1,nres-1
3231           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3232      &     costab(i),sintab(i),costab2(i),sintab2(i)
3233         enddo
3234         write (iout,*) "Array MUDER"
3235         do i=1,nres-1
3236           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
3237         enddo
3238 c      endif
3239 #endif
3240 #endif
3241 cd      do i=1,nres
3242 cd        iti = itortyp(itype(i))
3243 cd        write (iout,*) i
3244 cd        do j=1,2
3245 cd        write (iout,'(2f10.5,5x,2f10.5,5x,2f10.5)')
3246 cd     &  (EE(j,k,iti),k=1,2),(Ug(j,k,i),k=1,2),(EUg(j,k,i),k=1,2)
3247 cd        enddo
3248 cd      enddo
3249       return
3250       end
3251 C--------------------------------------------------------------------------
3252       subroutine eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
3253 C
3254 C This subroutine calculates the average interaction energy and its gradient
3255 C in the virtual-bond vectors between non-adjacent peptide groups, based on
3256 C the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
3257 C The potential depends both on the distance of peptide-group centers and on
3258 C the orientation of the CA-CA virtual bonds.
3259 C
3260       implicit real*8 (a-h,o-z)
3261 #ifdef MPI
3262       include 'mpif.h'
3263 #endif
3264       include 'DIMENSIONS'
3265       include 'COMMON.CONTROL'
3266       include 'COMMON.SETUP'
3267       include 'COMMON.IOUNITS'
3268       include 'COMMON.GEO'
3269       include 'COMMON.VAR'
3270       include 'COMMON.LOCAL'
3271       include 'COMMON.CHAIN'
3272       include 'COMMON.DERIV'
3273       include 'COMMON.INTERACT'
3274       include 'COMMON.CONTACTS'
3275       include 'COMMON.TORSION'
3276       include 'COMMON.VECTORS'
3277       include 'COMMON.FFIELD'
3278       include 'COMMON.TIME1'
3279       include 'COMMON.SPLITELE'
3280       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
3281      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
3282       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
3283      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4),gmuij(4)
3284       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3285      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3286      &    num_conti,j1,j2
3287 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
3288 #ifdef MOMENT
3289       double precision scal_el /1.0d0/
3290 #else
3291       double precision scal_el /0.5d0/
3292 #endif
3293 C 12/13/98
3294 C 13-go grudnia roku pamietnego...
3295       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
3296      &                   0.0d0,1.0d0,0.0d0,
3297      &                   0.0d0,0.0d0,1.0d0/
3298 cd      write(iout,*) 'In EELEC'
3299 cd      do i=1,nloctyp
3300 cd        write(iout,*) 'Type',i
3301 cd        write(iout,*) 'B1',B1(:,i)
3302 cd        write(iout,*) 'B2',B2(:,i)
3303 cd        write(iout,*) 'CC',CC(:,:,i)
3304 cd        write(iout,*) 'DD',DD(:,:,i)
3305 cd        write(iout,*) 'EE',EE(:,:,i)
3306 cd      enddo
3307 cd      call check_vecgrad
3308 cd      stop
3309       if (icheckgrad.eq.1) then
3310         do i=1,nres-1
3311           fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
3312           do k=1,3
3313             dc_norm(k,i)=dc(k,i)*fac
3314           enddo
3315 c          write (iout,*) 'i',i,' fac',fac
3316         enddo
3317       endif
3318       if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
3319      &    .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or.
3320      &    wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
3321 c        call vec_and_deriv
3322 #ifdef TIMING
3323         time01=MPI_Wtime()
3324 #endif
3325         call set_matrices
3326 #ifdef TIMING
3327         time_mat=time_mat+MPI_Wtime()-time01
3328 #endif
3329       endif
3330 cd      do i=1,nres-1
3331 cd        write (iout,*) 'i=',i
3332 cd        do k=1,3
3333 cd        write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
3334 cd        enddo
3335 cd        do k=1,3
3336 cd          write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
3337 cd     &     uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
3338 cd        enddo
3339 cd      enddo
3340       t_eelecij=0.0d0
3341       ees=0.0D0
3342       evdw1=0.0D0
3343       eel_loc=0.0d0
3344       eello_turn3=0.0d0
3345       eello_turn4=0.0d0
3346       ind=0
3347       do i=1,nres
3348         num_cont_hb(i)=0
3349       enddo
3350 cd      print '(a)','Enter EELEC'
3351 cd      write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
3352       do i=1,nres
3353         gel_loc_loc(i)=0.0d0
3354         gcorr_loc(i)=0.0d0
3355       enddo
3356 c
3357 c
3358 c 9/27/08 AL Split the interaction loop to ensure load balancing of turn terms
3359 C
3360 C Loop over i,i+2 and i,i+3 pairs of the peptide groups
3361 C
3362 C 14/01/2014 TURN3,TUNR4 does no go under periodic boundry condition
3363       do i=iturn3_start,iturn3_end
3364 CAna        if (i.le.1) cycle
3365 C        write(iout,*) "tu jest i",i
3366         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
3367 C changes suggested by Ana to avoid out of bounds
3368 CAna     & .or.((i+4).gt.nres)
3369 CAna     & .or.((i-1).le.0)
3370 C end of changes by Ana
3371      &  .or. itype(i+2).eq.ntyp1
3372      &  .or. itype(i+3).eq.ntyp1) cycle
3373 CAna        if(i.gt.1)then
3374 CAna          if(itype(i-1).eq.ntyp1)cycle
3375 CAna        end if
3376 CAna        if(i.LT.nres-3)then
3377 CAna          if (itype(i+4).eq.ntyp1) cycle
3378 CAna        end if
3379         dxi=dc(1,i)
3380         dyi=dc(2,i)
3381         dzi=dc(3,i)
3382         dx_normi=dc_norm(1,i)
3383         dy_normi=dc_norm(2,i)
3384         dz_normi=dc_norm(3,i)
3385         xmedi=c(1,i)+0.5d0*dxi
3386         ymedi=c(2,i)+0.5d0*dyi
3387         zmedi=c(3,i)+0.5d0*dzi
3388           xmedi=mod(xmedi,boxxsize)
3389           if (xmedi.lt.0) xmedi=xmedi+boxxsize
3390           ymedi=mod(ymedi,boxysize)
3391           if (ymedi.lt.0) ymedi=ymedi+boxysize
3392           zmedi=mod(zmedi,boxzsize)
3393           if (zmedi.lt.0) zmedi=zmedi+boxzsize
3394         num_conti=0
3395         call eelecij(i,i+2,ees,evdw1,eel_loc)
3396         if (wturn3.gt.0.0d0) call eturn3(i,eello_turn3)
3397         num_cont_hb(i)=num_conti
3398       enddo
3399       do i=iturn4_start,iturn4_end
3400 cAna        if (i.le.1) cycle
3401         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
3402 C changes suggested by Ana to avoid out of bounds
3403 cAna     & .or.((i+5).gt.nres)
3404 cAna     & .or.((i-1).le.0)
3405 C end of changes suggested by Ana
3406      &    .or. itype(i+3).eq.ntyp1
3407      &    .or. itype(i+4).eq.ntyp1
3408 cAna     &    .or. itype(i+5).eq.ntyp1
3409 cAna     &    .or. itype(i).eq.ntyp1
3410 cAna     &    .or. itype(i-1).eq.ntyp1
3411      &                             ) cycle
3412         dxi=dc(1,i)
3413         dyi=dc(2,i)
3414         dzi=dc(3,i)
3415         dx_normi=dc_norm(1,i)
3416         dy_normi=dc_norm(2,i)
3417         dz_normi=dc_norm(3,i)
3418         xmedi=c(1,i)+0.5d0*dxi
3419         ymedi=c(2,i)+0.5d0*dyi
3420         zmedi=c(3,i)+0.5d0*dzi
3421 C Return atom into box, boxxsize is size of box in x dimension
3422 c  194   continue
3423 c        if (xmedi.gt.((0.5d0)*boxxsize)) xmedi=xmedi-boxxsize
3424 c        if (xmedi.lt.((-0.5d0)*boxxsize)) xmedi=xmedi+boxxsize
3425 C Condition for being inside the proper box
3426 c        if ((xmedi.gt.((0.5d0)*boxxsize)).or.
3427 c     &       (xmedi.lt.((-0.5d0)*boxxsize))) then
3428 c        go to 194
3429 c        endif
3430 c  195   continue
3431 c        if (ymedi.gt.((0.5d0)*boxysize)) ymedi=ymedi-boxysize
3432 c        if (ymedi.lt.((-0.5d0)*boxysize)) ymedi=ymedi+boxysize
3433 C Condition for being inside the proper box
3434 c        if ((ymedi.gt.((0.5d0)*boxysize)).or.
3435 c     &       (ymedi.lt.((-0.5d0)*boxysize))) then
3436 c        go to 195
3437 c        endif
3438 c  196   continue
3439 c        if (zmedi.gt.((0.5d0)*boxzsize)) zmedi=zmedi-boxzsize
3440 c        if (zmedi.lt.((-0.5d0)*boxzsize)) zmedi=zmedi+boxzsize
3441 C Condition for being inside the proper box
3442 c        if ((zmedi.gt.((0.5d0)*boxzsize)).or.
3443 c     &       (zmedi.lt.((-0.5d0)*boxzsize))) then
3444 c        go to 196
3445 c        endif
3446           xmedi=mod(xmedi,boxxsize)
3447           if (xmedi.lt.0) xmedi=xmedi+boxxsize
3448           ymedi=mod(ymedi,boxysize)
3449           if (ymedi.lt.0) ymedi=ymedi+boxysize
3450           zmedi=mod(zmedi,boxzsize)
3451           if (zmedi.lt.0) zmedi=zmedi+boxzsize
3452
3453         num_conti=num_cont_hb(i)
3454 c        write(iout,*) "JESTEM W PETLI"
3455         call eelecij(i,i+3,ees,evdw1,eel_loc)
3456         if (wturn4.gt.0.0d0 .and. itype(i+2).ne.ntyp1)
3457      &   call eturn4(i,eello_turn4)
3458         num_cont_hb(i)=num_conti
3459       enddo   ! i
3460 C Loop over all neighbouring boxes
3461 C      do xshift=-1,1
3462 C      do yshift=-1,1
3463 C      do zshift=-1,1
3464 c
3465 c Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
3466 c
3467       do i=iatel_s,iatel_e
3468 cAna        if (i.le.1) cycle
3469         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
3470 C changes suggested by Ana to avoid out of bounds
3471 cAna     & .or.((i+2).gt.nres)
3472 cAna     & .or.((i-1).le.0)
3473 C end of changes by Ana
3474 cAna     &  .or. itype(i+2).eq.ntyp1
3475 cAna     &  .or. itype(i-1).eq.ntyp1
3476      &                ) cycle
3477         dxi=dc(1,i)
3478         dyi=dc(2,i)
3479         dzi=dc(3,i)
3480         dx_normi=dc_norm(1,i)
3481         dy_normi=dc_norm(2,i)
3482         dz_normi=dc_norm(3,i)
3483         xmedi=c(1,i)+0.5d0*dxi
3484         ymedi=c(2,i)+0.5d0*dyi
3485         zmedi=c(3,i)+0.5d0*dzi
3486           xmedi=mod(xmedi,boxxsize)
3487           if (xmedi.lt.0) xmedi=xmedi+boxxsize
3488           ymedi=mod(ymedi,boxysize)
3489           if (ymedi.lt.0) ymedi=ymedi+boxysize
3490           zmedi=mod(zmedi,boxzsize)
3491           if (zmedi.lt.0) zmedi=zmedi+boxzsize
3492 C          xmedi=xmedi+xshift*boxxsize
3493 C          ymedi=ymedi+yshift*boxysize
3494 C          zmedi=zmedi+zshift*boxzsize
3495
3496 C Return tom into box, boxxsize is size of box in x dimension
3497 c  164   continue
3498 c        if (xmedi.gt.((xshift+0.5d0)*boxxsize)) xmedi=xmedi-boxxsize
3499 c        if (xmedi.lt.((xshift-0.5d0)*boxxsize)) xmedi=xmedi+boxxsize
3500 C Condition for being inside the proper box
3501 c        if ((xmedi.gt.((xshift+0.5d0)*boxxsize)).or.
3502 c     &       (xmedi.lt.((xshift-0.5d0)*boxxsize))) then
3503 c        go to 164
3504 c        endif
3505 c  165   continue
3506 c        if (ymedi.gt.((yshift+0.5d0)*boxysize)) ymedi=ymedi-boxysize
3507 c        if (ymedi.lt.((yshift-0.5d0)*boxysize)) ymedi=ymedi+boxysize
3508 C Condition for being inside the proper box
3509 c        if ((ymedi.gt.((yshift+0.5d0)*boxysize)).or.
3510 c     &       (ymedi.lt.((yshift-0.5d0)*boxysize))) then
3511 c        go to 165
3512 c        endif
3513 c  166   continue
3514 c        if (zmedi.gt.((zshift+0.5d0)*boxzsize)) zmedi=zmedi-boxzsize
3515 c        if (zmedi.lt.((zshift-0.5d0)*boxzsize)) zmedi=zmedi+boxzsize
3516 cC Condition for being inside the proper box
3517 c        if ((zmedi.gt.((zshift+0.5d0)*boxzsize)).or.
3518 c     &       (zmedi.lt.((zshift-0.5d0)*boxzsize))) then
3519 c        go to 166
3520 c        endif
3521
3522 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
3523         num_conti=num_cont_hb(i)
3524         do j=ielstart(i),ielend(i)
3525 C          write (iout,*) i,j
3526 cAna         if (j.le.1) cycle
3527           if (itype(j).eq.ntyp1.or. itype(j+1).eq.ntyp1
3528 C changes suggested by Ana to avoid out of bounds
3529 cAna     & .or.((j+2).gt.nres)
3530 cAna     & .or.((j-1).le.0)
3531 C end of changes by Ana
3532 cAna     & .or.itype(j+2).eq.ntyp1
3533 cAna     & .or.itype(j-1).eq.ntyp1
3534      &) cycle
3535           call eelecij(i,j,ees,evdw1,eel_loc)
3536         enddo ! j
3537         num_cont_hb(i)=num_conti
3538       enddo   ! i
3539 C     enddo   ! zshift
3540 C      enddo   ! yshift
3541 C      enddo   ! xshift
3542
3543 c      write (iout,*) "Number of loop steps in EELEC:",ind
3544 cd      do i=1,nres
3545 cd        write (iout,'(i3,3f10.5,5x,3f10.5)')
3546 cd     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
3547 cd      enddo
3548 c 12/7/99 Adam eello_turn3 will be considered as a separate energy term
3549 ccc      eel_loc=eel_loc+eello_turn3
3550 cd      print *,"Processor",fg_rank," t_eelecij",t_eelecij
3551       return
3552       end
3553 C-------------------------------------------------------------------------------
3554       subroutine eelecij(i,j,ees,evdw1,eel_loc)
3555       implicit real*8 (a-h,o-z)
3556       include 'DIMENSIONS'
3557 #ifdef MPI
3558       include "mpif.h"
3559 #endif
3560       include 'COMMON.CONTROL'
3561       include 'COMMON.IOUNITS'
3562       include 'COMMON.GEO'
3563       include 'COMMON.VAR'
3564       include 'COMMON.LOCAL'
3565       include 'COMMON.CHAIN'
3566       include 'COMMON.DERIV'
3567       include 'COMMON.INTERACT'
3568       include 'COMMON.CONTACTS'
3569       include 'COMMON.TORSION'
3570       include 'COMMON.VECTORS'
3571       include 'COMMON.FFIELD'
3572       include 'COMMON.TIME1'
3573       include 'COMMON.SPLITELE'
3574       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
3575      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
3576       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
3577      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4),gmuij1(4),gmuji1(4),
3578      &    gmuij2(4),gmuji2(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 c          time00=MPI_Wtime()
3594 cd      write (iout,*) "eelecij",i,j
3595 c          ind=ind+1
3596           iteli=itel(i)
3597           itelj=itel(j)
3598           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
3599           aaa=app(iteli,itelj)
3600           bbb=bpp(iteli,itelj)
3601           ael6i=ael6(iteli,itelj)
3602           ael3i=ael3(iteli,itelj)
3603           dxj=dc(1,j)
3604           dyj=dc(2,j)
3605           dzj=dc(3,j)
3606           dx_normj=dc_norm(1,j)
3607           dy_normj=dc_norm(2,j)
3608           dz_normj=dc_norm(3,j)
3609 C          xj=c(1,j)+0.5D0*dxj-xmedi
3610 C          yj=c(2,j)+0.5D0*dyj-ymedi
3611 C          zj=c(3,j)+0.5D0*dzj-zmedi
3612           xj=c(1,j)+0.5D0*dxj
3613           yj=c(2,j)+0.5D0*dyj
3614           zj=c(3,j)+0.5D0*dzj
3615           xj=mod(xj,boxxsize)
3616           if (xj.lt.0) xj=xj+boxxsize
3617           yj=mod(yj,boxysize)
3618           if (yj.lt.0) yj=yj+boxysize
3619           zj=mod(zj,boxzsize)
3620           if (zj.lt.0) zj=zj+boxzsize
3621           if ((zj.lt.0).or.(xj.lt.0).or.(yj.lt.0)) write (*,*) "CHUJ"
3622       dist_init=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
3623       xj_safe=xj
3624       yj_safe=yj
3625       zj_safe=zj
3626       isubchap=0
3627       do xshift=-1,1
3628       do yshift=-1,1
3629       do zshift=-1,1
3630           xj=xj_safe+xshift*boxxsize
3631           yj=yj_safe+yshift*boxysize
3632           zj=zj_safe+zshift*boxzsize
3633           dist_temp=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
3634           if(dist_temp.lt.dist_init) then
3635             dist_init=dist_temp
3636             xj_temp=xj
3637             yj_temp=yj
3638             zj_temp=zj
3639             isubchap=1
3640           endif
3641        enddo
3642        enddo
3643        enddo
3644        if (isubchap.eq.1) then
3645           xj=xj_temp-xmedi
3646           yj=yj_temp-ymedi
3647           zj=zj_temp-zmedi
3648        else
3649           xj=xj_safe-xmedi
3650           yj=yj_safe-ymedi
3651           zj=zj_safe-zmedi
3652        endif
3653 C        if ((i+3).lt.j) then !this condition keeps for turn3 and turn4 not subject to PBC
3654 c  174   continue
3655 c        if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
3656 c        if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
3657 C Condition for being inside the proper box
3658 c        if ((xj.gt.((0.5d0)*boxxsize)).or.
3659 c     &       (xj.lt.((-0.5d0)*boxxsize))) then
3660 c        go to 174
3661 c        endif
3662 c  175   continue
3663 c        if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
3664 c        if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
3665 C Condition for being inside the proper box
3666 c        if ((yj.gt.((0.5d0)*boxysize)).or.
3667 c     &       (yj.lt.((-0.5d0)*boxysize))) then
3668 c        go to 175
3669 c        endif
3670 c  176   continue
3671 c        if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
3672 c        if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
3673 C Condition for being inside the proper box
3674 c        if ((zj.gt.((0.5d0)*boxzsize)).or.
3675 c     &       (zj.lt.((-0.5d0)*boxzsize))) then
3676 c        go to 176
3677 c        endif
3678 C        endif !endPBC condintion
3679 C        xj=xj-xmedi
3680 C        yj=yj-ymedi
3681 C        zj=zj-zmedi
3682           rij=xj*xj+yj*yj+zj*zj
3683
3684             sss=sscale(sqrt(rij))
3685             sssgrad=sscagrad(sqrt(rij))
3686 c            if (sss.gt.0.0d0) then
3687           rrmij=1.0D0/rij
3688           rij=dsqrt(rij)
3689           rmij=1.0D0/rij
3690           r3ij=rrmij*rmij
3691           r6ij=r3ij*r3ij
3692           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
3693           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
3694           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
3695           fac=cosa-3.0D0*cosb*cosg
3696           ev1=aaa*r6ij*r6ij
3697 c 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
3698           if (j.eq.i+2) ev1=scal_el*ev1
3699           ev2=bbb*r6ij
3700           fac3=ael6i*r6ij
3701           fac4=ael3i*r3ij
3702           evdwij=(ev1+ev2)
3703           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
3704           el2=fac4*fac
3705 C MARYSIA
3706           eesij=(el1+el2)
3707 C 12/26/95 - for the evaluation of multi-body H-bonding interactions
3708           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
3709           ees=ees+eesij
3710           evdw1=evdw1+evdwij*sss
3711 cd          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
3712 cd     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
3713 cd     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
3714 cd     &      xmedi,ymedi,zmedi,xj,yj,zj
3715
3716           if (energy_dec) then
3717               write (iout,'(a6,2i5,0pf7.3,2i5,2e11.3)')
3718      &'evdw1',i,j,evdwij
3719 c     &,iteli,itelj,aaa,evdw1
3720               write (iout,'(a6,2i5,0pf7.3)') 'ees',i,j,eesij
3721           endif
3722
3723 C
3724 C Calculate contributions to the Cartesian gradient.
3725 C
3726 #ifdef SPLITELE
3727           facvdw=-6*rrmij*(ev1+evdwij)*sss
3728           facel=-3*rrmij*(el1+eesij)
3729           fac1=fac
3730           erij(1)=xj*rmij
3731           erij(2)=yj*rmij
3732           erij(3)=zj*rmij
3733 *
3734 * Radial derivatives. First process both termini of the fragment (i,j)
3735 *
3736           ggg(1)=facel*xj
3737           ggg(2)=facel*yj
3738           ggg(3)=facel*zj
3739 c          do k=1,3
3740 c            ghalf=0.5D0*ggg(k)
3741 c            gelc(k,i)=gelc(k,i)+ghalf
3742 c            gelc(k,j)=gelc(k,j)+ghalf
3743 c          enddo
3744 c 9/28/08 AL Gradient compotents will be summed only at the end
3745           do k=1,3
3746             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
3747             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
3748           enddo
3749 *
3750 * Loop over residues i+1 thru j-1.
3751 *
3752 cgrad          do k=i+1,j-1
3753 cgrad            do l=1,3
3754 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3755 cgrad            enddo
3756 cgrad          enddo
3757           if (sss.gt.0.0) then
3758           ggg(1)=facvdw*xj+sssgrad*rmij*evdwij*xj
3759           ggg(2)=facvdw*yj+sssgrad*rmij*evdwij*yj
3760           ggg(3)=facvdw*zj+sssgrad*rmij*evdwij*zj
3761           else
3762           ggg(1)=0.0
3763           ggg(2)=0.0
3764           ggg(3)=0.0
3765           endif
3766 c          do k=1,3
3767 c            ghalf=0.5D0*ggg(k)
3768 c            gvdwpp(k,i)=gvdwpp(k,i)+ghalf
3769 c            gvdwpp(k,j)=gvdwpp(k,j)+ghalf
3770 c          enddo
3771 c 9/28/08 AL Gradient compotents will be summed only at the end
3772           do k=1,3
3773             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
3774             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
3775           enddo
3776 *
3777 * Loop over residues i+1 thru j-1.
3778 *
3779 cgrad          do k=i+1,j-1
3780 cgrad            do l=1,3
3781 cgrad              gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
3782 cgrad            enddo
3783 cgrad          enddo
3784 #else
3785 C MARYSIA
3786           facvdw=(ev1+evdwij)*sss
3787           facel=(el1+eesij)
3788           fac1=fac
3789           fac=-3*rrmij*(facvdw+facvdw+facel)
3790           erij(1)=xj*rmij
3791           erij(2)=yj*rmij
3792           erij(3)=zj*rmij
3793 *
3794 * Radial derivatives. First process both termini of the fragment (i,j)
3795 *
3796           ggg(1)=fac*xj
3797           ggg(2)=fac*yj
3798           ggg(3)=fac*zj
3799 c          do k=1,3
3800 c            ghalf=0.5D0*ggg(k)
3801 c            gelc(k,i)=gelc(k,i)+ghalf
3802 c            gelc(k,j)=gelc(k,j)+ghalf
3803 c          enddo
3804 c 9/28/08 AL Gradient compotents will be summed only at the end
3805           do k=1,3
3806             gelc_long(k,j)=gelc(k,j)+ggg(k)
3807             gelc_long(k,i)=gelc(k,i)-ggg(k)
3808           enddo
3809 *
3810 * Loop over residues i+1 thru j-1.
3811 *
3812 cgrad          do k=i+1,j-1
3813 cgrad            do l=1,3
3814 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3815 cgrad            enddo
3816 cgrad          enddo
3817 c 9/28/08 AL Gradient compotents will be summed only at the end
3818           ggg(1)=facvdw*xj+sssgrad*rmij*evdwij*xj
3819           ggg(2)=facvdw*yj+sssgrad*rmij*evdwij*yj
3820           ggg(3)=facvdw*zj+sssgrad*rmij*evdwij*zj
3821           do k=1,3
3822             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
3823             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
3824           enddo
3825 #endif
3826 *
3827 * Angular part
3828 *
3829           ecosa=2.0D0*fac3*fac1+fac4
3830           fac4=-3.0D0*fac4
3831           fac3=-6.0D0*fac3
3832           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
3833           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
3834           do k=1,3
3835             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
3836             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
3837           enddo
3838 cd        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
3839 cd   &          (dcosg(k),k=1,3)
3840           do k=1,3
3841             ggg(k)=ecosb*dcosb(k)+ecosg*dcosg(k)
3842           enddo
3843 c          do k=1,3
3844 c            ghalf=0.5D0*ggg(k)
3845 c            gelc(k,i)=gelc(k,i)+ghalf
3846 c     &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
3847 c     &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3848 c            gelc(k,j)=gelc(k,j)+ghalf
3849 c     &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
3850 c     &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3851 c          enddo
3852 cgrad          do k=i+1,j-1
3853 cgrad            do l=1,3
3854 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3855 cgrad            enddo
3856 cgrad          enddo
3857           do k=1,3
3858             gelc(k,i)=gelc(k,i)
3859      &           +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
3860      &           + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3861             gelc(k,j)=gelc(k,j)
3862      &           +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
3863      &           + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3864             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
3865             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
3866           enddo
3867 C MARYSIA
3868 c          endif !sscale
3869           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
3870      &        .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0
3871      &        .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
3872 C
3873 C 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
3874 C   energy of a peptide unit is assumed in the form of a second-order
3875 C   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
3876 C   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
3877 C   are computed for EVERY pair of non-contiguous peptide groups.
3878 C
3879
3880           if (j.lt.nres-1) then
3881             j1=j+1
3882             j2=j-1
3883           else
3884             j1=j-1
3885             j2=j-2
3886           endif
3887           kkk=0
3888           lll=0
3889           do k=1,2
3890             do l=1,2
3891               kkk=kkk+1
3892               muij(kkk)=mu(k,i)*mu(l,j)
3893 c              write(iout,*) 'mumu=', mu(k,i),mu(l,j),i,j,k,l
3894 #ifdef NEWCORR
3895              gmuij1(kkk)=gtb1(k,i+1)*mu(l,j)
3896 c             write(iout,*) 'k=',k,i,gtb1(k,i+1),gtb1(k,i+1)*mu(l,j)
3897              gmuij2(kkk)=gUb2(k,i)*mu(l,j)
3898              gmuji1(kkk)=mu(k,i)*gtb1(l,j+1)
3899 c             write(iout,*) 'l=',l,j,gtb1(l,j+1),gtb1(l,j+1)*mu(k,i)
3900              gmuji2(kkk)=mu(k,i)*gUb2(l,j)
3901 #endif
3902             enddo
3903           enddo
3904 cd         write (iout,*) 'EELEC: i',i,' j',j
3905 cd          write (iout,*) 'j',j,' j1',j1,' j2',j2
3906 cd          write(iout,*) 'muij',muij
3907           ury=scalar(uy(1,i),erij)
3908           urz=scalar(uz(1,i),erij)
3909           vry=scalar(uy(1,j),erij)
3910           vrz=scalar(uz(1,j),erij)
3911           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
3912           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
3913           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
3914           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
3915           fac=dsqrt(-ael6i)*r3ij
3916           a22=a22*fac
3917           a23=a23*fac
3918           a32=a32*fac
3919           a33=a33*fac
3920 cd          write (iout,'(4i5,4f10.5)')
3921 cd     &     i,itortyp(itype(i)),j,itortyp(itype(j)),a22,a23,a32,a33
3922 cd          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
3923 cd          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') uy(:,i),uz(:,i),
3924 cd     &      uy(:,j),uz(:,j)
3925 cd          write (iout,'(4f10.5)')
3926 cd     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
3927 cd     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
3928 cd          write (iout,'(4f10.5)') ury,urz,vry,vrz
3929 cd           write (iout,'(9f10.5/)')
3930 cd     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
3931 C Derivatives of the elements of A in virtual-bond vectors
3932           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
3933           do k=1,3
3934             uryg(k,1)=scalar(erder(1,k),uy(1,i))
3935             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
3936             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
3937             urzg(k,1)=scalar(erder(1,k),uz(1,i))
3938             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
3939             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
3940             vryg(k,1)=scalar(erder(1,k),uy(1,j))
3941             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
3942             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
3943             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
3944             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
3945             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
3946           enddo
3947 C Compute radial contributions to the gradient
3948           facr=-3.0d0*rrmij
3949           a22der=a22*facr
3950           a23der=a23*facr
3951           a32der=a32*facr
3952           a33der=a33*facr
3953           agg(1,1)=a22der*xj
3954           agg(2,1)=a22der*yj
3955           agg(3,1)=a22der*zj
3956           agg(1,2)=a23der*xj
3957           agg(2,2)=a23der*yj
3958           agg(3,2)=a23der*zj
3959           agg(1,3)=a32der*xj
3960           agg(2,3)=a32der*yj
3961           agg(3,3)=a32der*zj
3962           agg(1,4)=a33der*xj
3963           agg(2,4)=a33der*yj
3964           agg(3,4)=a33der*zj
3965 C Add the contributions coming from er
3966           fac3=-3.0d0*fac
3967           do k=1,3
3968             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
3969             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
3970             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
3971             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
3972           enddo
3973           do k=1,3
3974 C Derivatives in DC(i)
3975 cgrad            ghalf1=0.5d0*agg(k,1)
3976 cgrad            ghalf2=0.5d0*agg(k,2)
3977 cgrad            ghalf3=0.5d0*agg(k,3)
3978 cgrad            ghalf4=0.5d0*agg(k,4)
3979             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j))
3980      &      -3.0d0*uryg(k,2)*vry)!+ghalf1
3981             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j))
3982      &      -3.0d0*uryg(k,2)*vrz)!+ghalf2
3983             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j))
3984      &      -3.0d0*urzg(k,2)*vry)!+ghalf3
3985             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j))
3986      &      -3.0d0*urzg(k,2)*vrz)!+ghalf4
3987 C Derivatives in DC(i+1)
3988             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j))
3989      &      -3.0d0*uryg(k,3)*vry)!+agg(k,1)
3990             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j))
3991      &      -3.0d0*uryg(k,3)*vrz)!+agg(k,2)
3992             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j))
3993      &      -3.0d0*urzg(k,3)*vry)!+agg(k,3)
3994             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j))
3995      &      -3.0d0*urzg(k,3)*vrz)!+agg(k,4)
3996 C Derivatives in DC(j)
3997             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i))
3998      &      -3.0d0*vryg(k,2)*ury)!+ghalf1
3999             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i))
4000      &      -3.0d0*vrzg(k,2)*ury)!+ghalf2
4001             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i))
4002      &      -3.0d0*vryg(k,2)*urz)!+ghalf3
4003             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i))
4004      &      -3.0d0*vrzg(k,2)*urz)!+ghalf4
4005 C Derivatives in DC(j+1) or DC(nres-1)
4006             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i))
4007      &      -3.0d0*vryg(k,3)*ury)
4008             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i))
4009      &      -3.0d0*vrzg(k,3)*ury)
4010             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i))
4011      &      -3.0d0*vryg(k,3)*urz)
4012             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i))
4013      &      -3.0d0*vrzg(k,3)*urz)
4014 cgrad            if (j.eq.nres-1 .and. i.lt.j-2) then
4015 cgrad              do l=1,4
4016 cgrad                aggj1(k,l)=aggj1(k,l)+agg(k,l)
4017 cgrad              enddo
4018 cgrad            endif
4019           enddo
4020           acipa(1,1)=a22
4021           acipa(1,2)=a23
4022           acipa(2,1)=a32
4023           acipa(2,2)=a33
4024           a22=-a22
4025           a23=-a23
4026           do l=1,2
4027             do k=1,3
4028               agg(k,l)=-agg(k,l)
4029               aggi(k,l)=-aggi(k,l)
4030               aggi1(k,l)=-aggi1(k,l)
4031               aggj(k,l)=-aggj(k,l)
4032               aggj1(k,l)=-aggj1(k,l)
4033             enddo
4034           enddo
4035           if (j.lt.nres-1) then
4036             a22=-a22
4037             a32=-a32
4038             do l=1,3,2
4039               do k=1,3
4040                 agg(k,l)=-agg(k,l)
4041                 aggi(k,l)=-aggi(k,l)
4042                 aggi1(k,l)=-aggi1(k,l)
4043                 aggj(k,l)=-aggj(k,l)
4044                 aggj1(k,l)=-aggj1(k,l)
4045               enddo
4046             enddo
4047           else
4048             a22=-a22
4049             a23=-a23
4050             a32=-a32
4051             a33=-a33
4052             do l=1,4
4053               do k=1,3
4054                 agg(k,l)=-agg(k,l)
4055                 aggi(k,l)=-aggi(k,l)
4056                 aggi1(k,l)=-aggi1(k,l)
4057                 aggj(k,l)=-aggj(k,l)
4058                 aggj1(k,l)=-aggj1(k,l)
4059               enddo
4060             enddo
4061           endif
4062           ENDIF ! WCORR
4063           IF (wel_loc.gt.0.0d0) THEN
4064 C Contribution to the local-electrostatic energy coming from the i-j pair
4065           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3)
4066      &     +a33*muij(4)
4067 c          write (iout,*) 'i',i,' j',j,itype(i),itype(j),
4068 c     &                     ' eel_loc_ij',eel_loc_ij
4069 C          write(iout,*) 'muije=',i,j,muij(1),muij(2),muij(3),muij(4)
4070 C Calculate patrial derivative for theta angle
4071 #ifdef NEWCORR
4072          geel_loc_ij=a22*gmuij1(1)
4073      &     +a23*gmuij1(2)
4074      &     +a32*gmuij1(3)
4075      &     +a33*gmuij1(4)
4076 c         write(iout,*) "derivative over thatai"
4077 c         write(iout,*) a22*gmuij1(1), a23*gmuij1(2) ,a32*gmuij1(3),
4078 c     &   a33*gmuij1(4)
4079          gloc(nphi+i,icg)=gloc(nphi+i,icg)+
4080      &      geel_loc_ij*wel_loc
4081 c         write(iout,*) "derivative over thatai-1"
4082 c         write(iout,*) a22*gmuij2(1), a23*gmuij2(2) ,a32*gmuij2(3),
4083 c     &   a33*gmuij2(4)
4084          geel_loc_ij=
4085      &     a22*gmuij2(1)
4086      &     +a23*gmuij2(2)
4087      &     +a32*gmuij2(3)
4088      &     +a33*gmuij2(4)
4089          gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
4090      &      geel_loc_ij*wel_loc
4091 c  Derivative over j residue
4092          geel_loc_ji=a22*gmuji1(1)
4093      &     +a23*gmuji1(2)
4094      &     +a32*gmuji1(3)
4095      &     +a33*gmuji1(4)
4096 c         write(iout,*) "derivative over thataj"
4097 c         write(iout,*) a22*gmuji1(1), a23*gmuji1(2) ,a32*gmuji1(3),
4098 c     &   a33*gmuji1(4)
4099
4100         gloc(nphi+j,icg)=gloc(nphi+j,icg)+
4101      &      geel_loc_ji*wel_loc
4102          geel_loc_ji=
4103      &     +a22*gmuji2(1)
4104      &     +a23*gmuji2(2)
4105      &     +a32*gmuji2(3)
4106      &     +a33*gmuji2(4)
4107 c         write(iout,*) "derivative over thataj-1"
4108 c         write(iout,*) a22*gmuji2(1), a23*gmuji2(2) ,a32*gmuji2(3),
4109 c     &   a33*gmuji2(4)
4110          gloc(nphi+j-1,icg)=gloc(nphi+j-1,icg)+
4111      &      geel_loc_ji*wel_loc
4112 #endif
4113 cd          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
4114
4115           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
4116      &            'eelloc',i,j,eel_loc_ij
4117 c           if (eel_loc_ij.ne.0)
4118 c     &      write (iout,'(a4,2i4,8f9.5)')'chuj',
4119 c     &     i,j,a22,muij(1),a23,muij(2),a32,muij(3),a33,muij(4)
4120
4121           eel_loc=eel_loc+eel_loc_ij
4122 C Partial derivatives in virtual-bond dihedral angles gamma
4123           if (i.gt.1)
4124      &    gel_loc_loc(i-1)=gel_loc_loc(i-1)+
4125      &            a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j)
4126      &           +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j)
4127           gel_loc_loc(j-1)=gel_loc_loc(j-1)+
4128      &            a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j)
4129      &           +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j)
4130 C Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
4131           do l=1,3
4132             ggg(l)=agg(l,1)*muij(1)+
4133      &          agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4)
4134             gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l)
4135             gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l)
4136 cgrad            ghalf=0.5d0*ggg(l)
4137 cgrad            gel_loc(l,i)=gel_loc(l,i)+ghalf
4138 cgrad            gel_loc(l,j)=gel_loc(l,j)+ghalf
4139           enddo
4140 cgrad          do k=i+1,j2
4141 cgrad            do l=1,3
4142 cgrad              gel_loc(l,k)=gel_loc(l,k)+ggg(l)
4143 cgrad            enddo
4144 cgrad          enddo
4145 C Remaining derivatives of eello
4146           do l=1,3
4147             gel_loc(l,i)=gel_loc(l,i)+(aggi(l,1)*muij(1)+
4148      &        aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4))
4149             gel_loc(l,i+1)=gel_loc(l,i+1)+(aggi1(l,1)*muij(1)+
4150      &     aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4))
4151             gel_loc(l,j)=gel_loc(l,j)+(aggj(l,1)*muij(1)+
4152      &       aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4))
4153             gel_loc(l,j1)=gel_loc(l,j1)+(aggj1(l,1)*muij(1)+
4154      &     aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4))
4155           enddo
4156           ENDIF
4157 C Change 12/26/95 to calculate four-body contributions to H-bonding energy
4158 c          if (j.gt.i+1 .and. num_conti.le.maxconts) then
4159           if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0
4160      &       .and. num_conti.le.maxconts) then
4161 c            write (iout,*) i,j," entered corr"
4162 C
4163 C Calculate the contact function. The ith column of the array JCONT will
4164 C contain the numbers of atoms that make contacts with the atom I (of numbers
4165 C greater than I). The arrays FACONT and GACONT will contain the values of
4166 C the contact function and its derivative.
4167 c           r0ij=1.02D0*rpp(iteli,itelj)
4168 c           r0ij=1.11D0*rpp(iteli,itelj)
4169             r0ij=2.20D0*rpp(iteli,itelj)
4170 c           r0ij=1.55D0*rpp(iteli,itelj)
4171             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
4172             if (fcont.gt.0.0D0) then
4173               num_conti=num_conti+1
4174               if (num_conti.gt.maxconts) then
4175                 write (iout,*) 'WARNING - max. # of contacts exceeded;',
4176      &                         ' will skip next contacts for this conf.'
4177               else
4178                 jcont_hb(num_conti,i)=j
4179 cd                write (iout,*) "i",i," j",j," num_conti",num_conti,
4180 cd     &           " jcont_hb",jcont_hb(num_conti,i)
4181                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.
4182      &          wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
4183 C 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
4184 C  terms.
4185                 d_cont(num_conti,i)=rij
4186 cd                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
4187 C     --- Electrostatic-interaction matrix ---
4188                 a_chuj(1,1,num_conti,i)=a22
4189                 a_chuj(1,2,num_conti,i)=a23
4190                 a_chuj(2,1,num_conti,i)=a32
4191                 a_chuj(2,2,num_conti,i)=a33
4192 C     --- Gradient of rij
4193                 do kkk=1,3
4194                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
4195                 enddo
4196                 kkll=0
4197                 do k=1,2
4198                   do l=1,2
4199                     kkll=kkll+1
4200                     do m=1,3
4201                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
4202                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
4203                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
4204                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
4205                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
4206                     enddo
4207                   enddo
4208                 enddo
4209                 ENDIF
4210                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
4211 C Calculate contact energies
4212                 cosa4=4.0D0*cosa
4213                 wij=cosa-3.0D0*cosb*cosg
4214                 cosbg1=cosb+cosg
4215                 cosbg2=cosb-cosg
4216 c               fac3=dsqrt(-ael6i)/r0ij**3
4217                 fac3=dsqrt(-ael6i)*r3ij
4218 c                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
4219                 ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
4220                 if (ees0tmp.gt.0) then
4221                   ees0pij=dsqrt(ees0tmp)
4222                 else
4223                   ees0pij=0
4224                 endif
4225 c                ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
4226                 ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
4227                 if (ees0tmp.gt.0) then
4228                   ees0mij=dsqrt(ees0tmp)
4229                 else
4230                   ees0mij=0
4231                 endif
4232 c               ees0mij=0.0D0
4233                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij)
4234                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij)
4235 C Diagnostics. Comment out or remove after debugging!
4236 c               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
4237 c               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
4238 c               ees0m(num_conti,i)=0.0D0
4239 C End diagnostics.
4240 c               write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
4241 c    & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
4242 C Angular derivatives of the contact function
4243                 ees0pij1=fac3/ees0pij
4244                 ees0mij1=fac3/ees0mij
4245                 fac3p=-3.0D0*fac3*rrmij
4246                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
4247                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
4248 c               ees0mij1=0.0D0
4249                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
4250                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
4251                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
4252                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
4253                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
4254                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
4255                 ecosap=ecosa1+ecosa2
4256                 ecosbp=ecosb1+ecosb2
4257                 ecosgp=ecosg1+ecosg2
4258                 ecosam=ecosa1-ecosa2
4259                 ecosbm=ecosb1-ecosb2
4260                 ecosgm=ecosg1-ecosg2
4261 C Diagnostics
4262 c               ecosap=ecosa1
4263 c               ecosbp=ecosb1
4264 c               ecosgp=ecosg1
4265 c               ecosam=0.0D0
4266 c               ecosbm=0.0D0
4267 c               ecosgm=0.0D0
4268 C End diagnostics
4269                 facont_hb(num_conti,i)=fcont
4270                 fprimcont=fprimcont/rij
4271 cd              facont_hb(num_conti,i)=1.0D0
4272 C Following line is for diagnostics.
4273 cd              fprimcont=0.0D0
4274                 do k=1,3
4275                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
4276                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
4277                 enddo
4278                 do k=1,3
4279                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
4280                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
4281                 enddo
4282                 gggp(1)=gggp(1)+ees0pijp*xj
4283                 gggp(2)=gggp(2)+ees0pijp*yj
4284                 gggp(3)=gggp(3)+ees0pijp*zj
4285                 gggm(1)=gggm(1)+ees0mijp*xj
4286                 gggm(2)=gggm(2)+ees0mijp*yj
4287                 gggm(3)=gggm(3)+ees0mijp*zj
4288 C Derivatives due to the contact function
4289                 gacont_hbr(1,num_conti,i)=fprimcont*xj
4290                 gacont_hbr(2,num_conti,i)=fprimcont*yj
4291                 gacont_hbr(3,num_conti,i)=fprimcont*zj
4292                 do k=1,3
4293 c
4294 c 10/24/08 cgrad and ! comments indicate the parts of the code removed
4295 c          following the change of gradient-summation algorithm.
4296 c
4297 cgrad                  ghalfp=0.5D0*gggp(k)
4298 cgrad                  ghalfm=0.5D0*gggm(k)
4299                   gacontp_hb1(k,num_conti,i)=!ghalfp
4300      &              +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i))
4301      &              + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
4302                   gacontp_hb2(k,num_conti,i)=!ghalfp
4303      &              +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j))
4304      &              + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
4305                   gacontp_hb3(k,num_conti,i)=gggp(k)
4306                   gacontm_hb1(k,num_conti,i)=!ghalfm
4307      &              +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i))
4308      &              + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
4309                   gacontm_hb2(k,num_conti,i)=!ghalfm
4310      &              +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j))
4311      &              + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
4312                   gacontm_hb3(k,num_conti,i)=gggm(k)
4313                 enddo
4314 C Diagnostics. Comment out or remove after debugging!
4315 cdiag           do k=1,3
4316 cdiag             gacontp_hb1(k,num_conti,i)=0.0D0
4317 cdiag             gacontp_hb2(k,num_conti,i)=0.0D0
4318 cdiag             gacontp_hb3(k,num_conti,i)=0.0D0
4319 cdiag             gacontm_hb1(k,num_conti,i)=0.0D0
4320 cdiag             gacontm_hb2(k,num_conti,i)=0.0D0
4321 cdiag             gacontm_hb3(k,num_conti,i)=0.0D0
4322 cdiag           enddo
4323               ENDIF ! wcorr
4324               endif  ! num_conti.le.maxconts
4325             endif  ! fcont.gt.0
4326           endif    ! j.gt.i+1
4327           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
4328             do k=1,4
4329               do l=1,3
4330                 ghalf=0.5d0*agg(l,k)
4331                 aggi(l,k)=aggi(l,k)+ghalf
4332                 aggi1(l,k)=aggi1(l,k)+agg(l,k)
4333                 aggj(l,k)=aggj(l,k)+ghalf
4334               enddo
4335             enddo
4336             if (j.eq.nres-1 .and. i.lt.j-2) then
4337               do k=1,4
4338                 do l=1,3
4339                   aggj1(l,k)=aggj1(l,k)+agg(l,k)
4340                 enddo
4341               enddo
4342             endif
4343           endif
4344 c          t_eelecij=t_eelecij+MPI_Wtime()-time00
4345       return
4346       end
4347 C-----------------------------------------------------------------------------
4348       subroutine eturn3(i,eello_turn3)
4349 C Third- and fourth-order contributions from turns
4350       implicit real*8 (a-h,o-z)
4351       include 'DIMENSIONS'
4352       include 'COMMON.IOUNITS'
4353       include 'COMMON.GEO'
4354       include 'COMMON.VAR'
4355       include 'COMMON.LOCAL'
4356       include 'COMMON.CHAIN'
4357       include 'COMMON.DERIV'
4358       include 'COMMON.INTERACT'
4359       include 'COMMON.CONTACTS'
4360       include 'COMMON.TORSION'
4361       include 'COMMON.VECTORS'
4362       include 'COMMON.FFIELD'
4363       include 'COMMON.CONTROL'
4364       dimension ggg(3)
4365       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
4366      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
4367      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2),gpizda1(2,2),
4368      &  gpizda2(2,2),auxgmat1(2,2),auxgmatt1(2,2),
4369      &  auxgmat2(2,2),auxgmatt2(2,2)
4370       double precision agg(3,4),aggi(3,4),aggi1(3,4),
4371      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
4372       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
4373      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
4374      &    num_conti,j1,j2
4375       j=i+2
4376 c      write (iout,*) "eturn3",i,j,j1,j2
4377       a_temp(1,1)=a22
4378       a_temp(1,2)=a23
4379       a_temp(2,1)=a32
4380       a_temp(2,2)=a33
4381 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4382 C
4383 C               Third-order contributions
4384 C
4385 C                 (i+2)o----(i+3)
4386 C                      | |
4387 C                      | |
4388 C                 (i+1)o----i
4389 C
4390 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4391 cd        call checkint_turn3(i,a_temp,eello_turn3_num)
4392         call matmat2(EUg(1,1,i+1),EUg(1,1,i+2),auxmat(1,1))
4393 c auxalary matices for theta gradient
4394 c auxalary matrix for i+1 and constant i+2
4395         call matmat2(gtEUg(1,1,i+1),EUg(1,1,i+2),auxgmat1(1,1))
4396 c auxalary matrix for i+2 and constant i+1
4397         call matmat2(EUg(1,1,i+1),gtEUg(1,1,i+2),auxgmat2(1,1))
4398         call transpose2(auxmat(1,1),auxmat1(1,1))
4399         call transpose2(auxgmat1(1,1),auxgmatt1(1,1))
4400         call transpose2(auxgmat2(1,1),auxgmatt2(1,1))
4401         call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4402         call matmat2(a_temp(1,1),auxgmatt1(1,1),gpizda1(1,1))
4403         call matmat2(a_temp(1,1),auxgmatt2(1,1),gpizda2(1,1))
4404         eello_turn3=eello_turn3+0.5d0*(pizda(1,1)+pizda(2,2))
4405 C Derivatives in theta
4406         gloc(nphi+i,icg)=gloc(nphi+i,icg)
4407      &  +0.5d0*(gpizda1(1,1)+gpizda1(2,2))*wturn3
4408         gloc(nphi+i+1,icg)=gloc(nphi+i+1,icg)
4409      &  +0.5d0*(gpizda2(1,1)+gpizda2(2,2))*wturn3
4410
4411         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
4412      &          'eturn3',i,j,0.5d0*(pizda(1,1)+pizda(2,2))
4413 cd        write (2,*) 'i,',i,' j',j,'eello_turn3',
4414 cd     &    0.5d0*(pizda(1,1)+pizda(2,2)),
4415 cd     &    ' eello_turn3_num',4*eello_turn3_num
4416 C Derivatives in gamma(i)
4417         call matmat2(EUgder(1,1,i+1),EUg(1,1,i+2),auxmat2(1,1))
4418         call transpose2(auxmat2(1,1),auxmat3(1,1))
4419         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
4420         gel_loc_turn3(i)=gel_loc_turn3(i)+0.5d0*(pizda(1,1)+pizda(2,2))
4421 C Derivatives in gamma(i+1)
4422         call matmat2(EUg(1,1,i+1),EUgder(1,1,i+2),auxmat2(1,1))
4423         call transpose2(auxmat2(1,1),auxmat3(1,1))
4424         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
4425         gel_loc_turn3(i+1)=gel_loc_turn3(i+1)
4426      &    +0.5d0*(pizda(1,1)+pizda(2,2))
4427 C Cartesian derivatives
4428 !DIR$ UNROLL(0)
4429         do l=1,3
4430 c            ghalf1=0.5d0*agg(l,1)
4431 c            ghalf2=0.5d0*agg(l,2)
4432 c            ghalf3=0.5d0*agg(l,3)
4433 c            ghalf4=0.5d0*agg(l,4)
4434           a_temp(1,1)=aggi(l,1)!+ghalf1
4435           a_temp(1,2)=aggi(l,2)!+ghalf2
4436           a_temp(2,1)=aggi(l,3)!+ghalf3
4437           a_temp(2,2)=aggi(l,4)!+ghalf4
4438           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4439           gcorr3_turn(l,i)=gcorr3_turn(l,i)
4440      &      +0.5d0*(pizda(1,1)+pizda(2,2))
4441           a_temp(1,1)=aggi1(l,1)!+agg(l,1)
4442           a_temp(1,2)=aggi1(l,2)!+agg(l,2)
4443           a_temp(2,1)=aggi1(l,3)!+agg(l,3)
4444           a_temp(2,2)=aggi1(l,4)!+agg(l,4)
4445           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4446           gcorr3_turn(l,i+1)=gcorr3_turn(l,i+1)
4447      &      +0.5d0*(pizda(1,1)+pizda(2,2))
4448           a_temp(1,1)=aggj(l,1)!+ghalf1
4449           a_temp(1,2)=aggj(l,2)!+ghalf2
4450           a_temp(2,1)=aggj(l,3)!+ghalf3
4451           a_temp(2,2)=aggj(l,4)!+ghalf4
4452           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4453           gcorr3_turn(l,j)=gcorr3_turn(l,j)
4454      &      +0.5d0*(pizda(1,1)+pizda(2,2))
4455           a_temp(1,1)=aggj1(l,1)
4456           a_temp(1,2)=aggj1(l,2)
4457           a_temp(2,1)=aggj1(l,3)
4458           a_temp(2,2)=aggj1(l,4)
4459           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4460           gcorr3_turn(l,j1)=gcorr3_turn(l,j1)
4461      &      +0.5d0*(pizda(1,1)+pizda(2,2))
4462         enddo
4463       return
4464       end
4465 C-------------------------------------------------------------------------------
4466       subroutine eturn4(i,eello_turn4)
4467 C Third- and fourth-order contributions from turns
4468       implicit real*8 (a-h,o-z)
4469       include 'DIMENSIONS'
4470       include 'COMMON.IOUNITS'
4471       include 'COMMON.GEO'
4472       include 'COMMON.VAR'
4473       include 'COMMON.LOCAL'
4474       include 'COMMON.CHAIN'
4475       include 'COMMON.DERIV'
4476       include 'COMMON.INTERACT'
4477       include 'COMMON.CONTACTS'
4478       include 'COMMON.TORSION'
4479       include 'COMMON.VECTORS'
4480       include 'COMMON.FFIELD'
4481       include 'COMMON.CONTROL'
4482       dimension ggg(3)
4483       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
4484      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
4485      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2),auxgvec(2),
4486      &  auxgEvec1(2),auxgEvec2(2),auxgEvec3(2),
4487      &  gte1t(2,2),gte2t(2,2),gte3t(2,2),
4488      &  gte1a(2,2),gtae3(2,2),gtae3e2(2,2), ae3gte2(2,2),
4489      &  gtEpizda1(2,2),gtEpizda2(2,2),gtEpizda3(2,2)
4490       double precision agg(3,4),aggi(3,4),aggi1(3,4),
4491      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
4492       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
4493      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
4494      &    num_conti,j1,j2
4495       j=i+3
4496 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4497 C
4498 C               Fourth-order contributions
4499 C
4500 C                 (i+3)o----(i+4)
4501 C                     /  |
4502 C               (i+2)o   |
4503 C                     \  |
4504 C                 (i+1)o----i
4505 C
4506 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4507 cd        call checkint_turn4(i,a_temp,eello_turn4_num)
4508 c        write (iout,*) "eturn4 i",i," j",j," j1",j1," j2",j2
4509 c        write(iout,*)"WCHODZE W PROGRAM"
4510         a_temp(1,1)=a22
4511         a_temp(1,2)=a23
4512         a_temp(2,1)=a32
4513         a_temp(2,2)=a33
4514         iti1=itortyp(itype(i+1))
4515         iti2=itortyp(itype(i+2))
4516         iti3=itortyp(itype(i+3))
4517 c        write(iout,*) "iti1",iti1," iti2",iti2," iti3",iti3
4518         call transpose2(EUg(1,1,i+1),e1t(1,1))
4519         call transpose2(Eug(1,1,i+2),e2t(1,1))
4520         call transpose2(Eug(1,1,i+3),e3t(1,1))
4521 C Ematrix derivative in theta
4522         call transpose2(gtEUg(1,1,i+1),gte1t(1,1))
4523         call transpose2(gtEug(1,1,i+2),gte2t(1,1))
4524         call transpose2(gtEug(1,1,i+3),gte3t(1,1))
4525         call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4526 c       eta1 in derivative theta
4527         call matmat2(gte1t(1,1),a_temp(1,1),gte1a(1,1))
4528         call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4529 c       auxgvec is derivative of Ub2 so i+3 theta
4530         call matvec2(e1a(1,1),gUb2(1,i+3),auxgvec(1))
4531 c       auxalary matrix of E i+1
4532         call matvec2(gte1a(1,1),Ub2(1,i+3),auxgEvec1(1))
4533 c        s1=0.0
4534 c        gs1=0.0
4535         s1=scalar2(b1(1,i+2),auxvec(1))
4536 c derivative of theta i+2 with constant i+3
4537         gs23=scalar2(gtb1(1,i+2),auxvec(1))
4538 c derivative of theta i+2 with constant i+2
4539         gs32=scalar2(b1(1,i+2),auxgvec(1))
4540 c derivative of E matix in theta of i+1
4541         gsE13=scalar2(b1(1,i+2),auxgEvec1(1))
4542
4543         call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4544 c       ea31 in derivative theta
4545         call matmat2(a_temp(1,1),gte3t(1,1),gtae3(1,1))
4546         call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4547 c auxilary matrix auxgvec of Ub2 with constant E matirx
4548         call matvec2(ae3(1,1),gUb2(1,i+2),auxgvec(1))
4549 c auxilary matrix auxgEvec1 of E matix with Ub2 constant
4550         call matvec2(gtae3(1,1),Ub2(1,i+2),auxgEvec3(1))
4551
4552 c        s2=0.0
4553 c        gs2=0.0
4554         s2=scalar2(b1(1,i+1),auxvec(1))
4555 c derivative of theta i+1 with constant i+3
4556         gs13=scalar2(gtb1(1,i+1),auxvec(1))
4557 c derivative of theta i+2 with constant i+1
4558         gs21=scalar2(b1(1,i+1),auxgvec(1))
4559 c derivative of theta i+3 with constant i+1
4560         gsE31=scalar2(b1(1,i+1),auxgEvec3(1))
4561 c        write(iout,*) gs1,gs2,'i=',i,auxgvec(1),gUb2(1,i+2),gtb1(1,i+2),
4562 c     &  gtb1(1,i+1)
4563         call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4564 c two derivatives over diffetent matrices
4565 c gtae3e2 is derivative over i+3
4566         call matmat2(gtae3(1,1),e2t(1,1),gtae3e2(1,1))
4567 c ae3gte2 is derivative over i+2
4568         call matmat2(ae3(1,1),gte2t(1,1),ae3gte2(1,1))
4569         call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4570 c three possible derivative over theta E matices
4571 c i+1
4572         call matmat2(ae3e2(1,1),gte1t(1,1),gtEpizda1(1,1))
4573 c i+2
4574         call matmat2(ae3gte2(1,1),e1t(1,1),gtEpizda2(1,1))
4575 c i+3
4576         call matmat2(gtae3e2(1,1),e1t(1,1),gtEpizda3(1,1))
4577         s3=0.5d0*(pizda(1,1)+pizda(2,2))
4578
4579         gsEE1=0.5d0*(gtEpizda1(1,1)+gtEpizda1(2,2))
4580         gsEE2=0.5d0*(gtEpizda2(1,1)+gtEpizda2(2,2))
4581         gsEE3=0.5d0*(gtEpizda3(1,1)+gtEpizda3(2,2))
4582
4583         eello_turn4=eello_turn4-(s1+s2+s3)
4584 c             write(iout,*)'chujOWO', auxvec(1),b1(1,iti2)
4585 c        if (energy_dec) write (iout,'(a6,2i5,0pf7.3,3f7.3)')
4586 c     &      'eturn4',i,j,-(s1+s2+s3),s1,s2,s3
4587 cd        write (2,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
4588 cd     &    ' eello_turn4_num',8*eello_turn4_num
4589 #ifdef NEWCORR
4590         gloc(nphi+i,icg)=gloc(nphi+i,icg)
4591      &                  -(gs13+gsE13+gsEE1)*wturn4
4592         gloc(nphi+i+1,icg)= gloc(nphi+i+1,icg)
4593      &                    -(gs23+gs21+gsEE2)*wturn4
4594         gloc(nphi+i+2,icg)= gloc(nphi+i+2,icg)
4595      &                    -(gs32+gsE31+gsEE3)*wturn4
4596 c         gloc(nphi+i+1,icg)=gloc(nphi+i+1,icg)-
4597 c     &   gs2
4598 #endif
4599         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
4600      &      'eturn4',i,j,-(s1+s2+s3)
4601 c        write (iout,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
4602 c     &    ' eello_turn4_num',8*eello_turn4_num
4603 C Derivatives in gamma(i)
4604         call transpose2(EUgder(1,1,i+1),e1tder(1,1))
4605         call matmat2(e1tder(1,1),a_temp(1,1),auxmat(1,1))
4606         call matvec2(auxmat(1,1),Ub2(1,i+3),auxvec(1))
4607         s1=scalar2(b1(1,i+2),auxvec(1))
4608         call matmat2(ae3e2(1,1),e1tder(1,1),pizda(1,1))
4609         s3=0.5d0*(pizda(1,1)+pizda(2,2))
4610         gel_loc_turn4(i)=gel_loc_turn4(i)-(s1+s3)
4611 C Derivatives in gamma(i+1)
4612         call transpose2(EUgder(1,1,i+2),e2tder(1,1))
4613         call matvec2(ae3(1,1),Ub2der(1,i+2),auxvec(1))
4614         s2=scalar2(b1(1,i+1),auxvec(1))
4615         call matmat2(ae3(1,1),e2tder(1,1),auxmat(1,1))
4616         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
4617         s3=0.5d0*(pizda(1,1)+pizda(2,2))
4618         gel_loc_turn4(i+1)=gel_loc_turn4(i+1)-(s2+s3)
4619 C Derivatives in gamma(i+2)
4620         call transpose2(EUgder(1,1,i+3),e3tder(1,1))
4621         call matvec2(e1a(1,1),Ub2der(1,i+3),auxvec(1))
4622         s1=scalar2(b1(1,i+2),auxvec(1))
4623         call matmat2(a_temp(1,1),e3tder(1,1),auxmat(1,1))
4624         call matvec2(auxmat(1,1),Ub2(1,i+2),auxvec(1))
4625         s2=scalar2(b1(1,i+1),auxvec(1))
4626         call matmat2(auxmat(1,1),e2t(1,1),auxmat3(1,1))
4627         call matmat2(auxmat3(1,1),e1t(1,1),pizda(1,1))
4628         s3=0.5d0*(pizda(1,1)+pizda(2,2))
4629         gel_loc_turn4(i+2)=gel_loc_turn4(i+2)-(s1+s2+s3)
4630 C Cartesian derivatives
4631 C Derivatives of this turn contributions in DC(i+2)
4632         if (j.lt.nres-1) then
4633           do l=1,3
4634             a_temp(1,1)=agg(l,1)
4635             a_temp(1,2)=agg(l,2)
4636             a_temp(2,1)=agg(l,3)
4637             a_temp(2,2)=agg(l,4)
4638             call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4639             call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4640             s1=scalar2(b1(1,i+2),auxvec(1))
4641             call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4642             call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4643             s2=scalar2(b1(1,i+1),auxvec(1))
4644             call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4645             call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4646             s3=0.5d0*(pizda(1,1)+pizda(2,2))
4647             ggg(l)=-(s1+s2+s3)
4648             gcorr4_turn(l,i+2)=gcorr4_turn(l,i+2)-(s1+s2+s3)
4649           enddo
4650         endif
4651 C Remaining derivatives of this turn contribution
4652         do l=1,3
4653           a_temp(1,1)=aggi(l,1)
4654           a_temp(1,2)=aggi(l,2)
4655           a_temp(2,1)=aggi(l,3)
4656           a_temp(2,2)=aggi(l,4)
4657           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4658           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4659           s1=scalar2(b1(1,i+2),auxvec(1))
4660           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4661           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4662           s2=scalar2(b1(1,i+1),auxvec(1))
4663           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4664           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4665           s3=0.5d0*(pizda(1,1)+pizda(2,2))
4666           gcorr4_turn(l,i)=gcorr4_turn(l,i)-(s1+s2+s3)
4667           a_temp(1,1)=aggi1(l,1)
4668           a_temp(1,2)=aggi1(l,2)
4669           a_temp(2,1)=aggi1(l,3)
4670           a_temp(2,2)=aggi1(l,4)
4671           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4672           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4673           s1=scalar2(b1(1,i+2),auxvec(1))
4674           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4675           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4676           s2=scalar2(b1(1,i+1),auxvec(1))
4677           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4678           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4679           s3=0.5d0*(pizda(1,1)+pizda(2,2))
4680           gcorr4_turn(l,i+1)=gcorr4_turn(l,i+1)-(s1+s2+s3)
4681           a_temp(1,1)=aggj(l,1)
4682           a_temp(1,2)=aggj(l,2)
4683           a_temp(2,1)=aggj(l,3)
4684           a_temp(2,2)=aggj(l,4)
4685           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4686           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4687           s1=scalar2(b1(1,i+2),auxvec(1))
4688           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4689           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4690           s2=scalar2(b1(1,i+1),auxvec(1))
4691           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4692           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4693           s3=0.5d0*(pizda(1,1)+pizda(2,2))
4694           gcorr4_turn(l,j)=gcorr4_turn(l,j)-(s1+s2+s3)
4695           a_temp(1,1)=aggj1(l,1)
4696           a_temp(1,2)=aggj1(l,2)
4697           a_temp(2,1)=aggj1(l,3)
4698           a_temp(2,2)=aggj1(l,4)
4699           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4700           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4701           s1=scalar2(b1(1,i+2),auxvec(1))
4702           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4703           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4704           s2=scalar2(b1(1,i+1),auxvec(1))
4705           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4706           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4707           s3=0.5d0*(pizda(1,1)+pizda(2,2))
4708 c          write (iout,*) "s1",s1," s2",s2," s3",s3," s1+s2+s3",s1+s2+s3
4709           gcorr4_turn(l,j1)=gcorr4_turn(l,j1)-(s1+s2+s3)
4710         enddo
4711       return
4712       end
4713 C-----------------------------------------------------------------------------
4714       subroutine vecpr(u,v,w)
4715       implicit real*8(a-h,o-z)
4716       dimension u(3),v(3),w(3)
4717       w(1)=u(2)*v(3)-u(3)*v(2)
4718       w(2)=-u(1)*v(3)+u(3)*v(1)
4719       w(3)=u(1)*v(2)-u(2)*v(1)
4720       return
4721       end
4722 C-----------------------------------------------------------------------------
4723       subroutine unormderiv(u,ugrad,unorm,ungrad)
4724 C This subroutine computes the derivatives of a normalized vector u, given
4725 C the derivatives computed without normalization conditions, ugrad. Returns
4726 C ungrad.
4727       implicit none
4728       double precision u(3),ugrad(3,3),unorm,ungrad(3,3)
4729       double precision vec(3)
4730       double precision scalar
4731       integer i,j
4732 c      write (2,*) 'ugrad',ugrad
4733 c      write (2,*) 'u',u
4734       do i=1,3
4735         vec(i)=scalar(ugrad(1,i),u(1))
4736       enddo
4737 c      write (2,*) 'vec',vec
4738       do i=1,3
4739         do j=1,3
4740           ungrad(j,i)=(ugrad(j,i)-u(j)*vec(i))*unorm
4741         enddo
4742       enddo
4743 c      write (2,*) 'ungrad',ungrad
4744       return
4745       end
4746 C-----------------------------------------------------------------------------
4747       subroutine escp_soft_sphere(evdw2,evdw2_14)
4748 C
4749 C This subroutine calculates the excluded-volume interaction energy between
4750 C peptide-group centers and side chains and its gradient in virtual-bond and
4751 C side-chain vectors.
4752 C
4753       implicit real*8 (a-h,o-z)
4754       include 'DIMENSIONS'
4755       include 'COMMON.GEO'
4756       include 'COMMON.VAR'
4757       include 'COMMON.LOCAL'
4758       include 'COMMON.CHAIN'
4759       include 'COMMON.DERIV'
4760       include 'COMMON.INTERACT'
4761       include 'COMMON.FFIELD'
4762       include 'COMMON.IOUNITS'
4763       include 'COMMON.CONTROL'
4764       dimension ggg(3)
4765       evdw2=0.0D0
4766       evdw2_14=0.0d0
4767       r0_scp=4.5d0
4768 cd    print '(a)','Enter ESCP'
4769 cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
4770 C      do xshift=-1,1
4771 C      do yshift=-1,1
4772 C      do zshift=-1,1
4773       do i=iatscp_s,iatscp_e
4774         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
4775         iteli=itel(i)
4776         xi=0.5D0*(c(1,i)+c(1,i+1))
4777         yi=0.5D0*(c(2,i)+c(2,i+1))
4778         zi=0.5D0*(c(3,i)+c(3,i+1))
4779 C Return atom into box, boxxsize is size of box in x dimension
4780 c  134   continue
4781 c        if (xi.gt.((xshift+0.5d0)*boxxsize)) xi=xi-boxxsize
4782 c        if (xi.lt.((xshift-0.5d0)*boxxsize)) xi=xi+boxxsize
4783 C Condition for being inside the proper box
4784 c        if ((xi.gt.((xshift+0.5d0)*boxxsize)).or.
4785 c     &       (xi.lt.((xshift-0.5d0)*boxxsize))) then
4786 c        go to 134
4787 c        endif
4788 c  135   continue
4789 c        if (yi.gt.((yshift+0.5d0)*boxysize)) yi=yi-boxysize
4790 c        if (yi.lt.((yshift-0.5d0)*boxysize)) yi=yi+boxysize
4791 C Condition for being inside the proper box
4792 c        if ((yi.gt.((yshift+0.5d0)*boxysize)).or.
4793 c     &       (yi.lt.((yshift-0.5d0)*boxysize))) then
4794 c        go to 135
4795 c c       endif
4796 c  136   continue
4797 c        if (zi.gt.((zshift+0.5d0)*boxzsize)) zi=zi-boxzsize
4798 c        if (zi.lt.((zshift-0.5d0)*boxzsize)) zi=zi+boxzsize
4799 cC Condition for being inside the proper box
4800 c        if ((zi.gt.((zshift+0.5d0)*boxzsize)).or.
4801 c     &       (zi.lt.((zshift-0.5d0)*boxzsize))) then
4802 c        go to 136
4803 c        endif
4804           xi=mod(xi,boxxsize)
4805           if (xi.lt.0) xi=xi+boxxsize
4806           yi=mod(yi,boxysize)
4807           if (yi.lt.0) yi=yi+boxysize
4808           zi=mod(zi,boxzsize)
4809           if (zi.lt.0) zi=zi+boxzsize
4810 C          xi=xi+xshift*boxxsize
4811 C          yi=yi+yshift*boxysize
4812 C          zi=zi+zshift*boxzsize
4813         do iint=1,nscp_gr(i)
4814
4815         do j=iscpstart(i,iint),iscpend(i,iint)
4816           if (itype(j).eq.ntyp1) cycle
4817           itypj=iabs(itype(j))
4818 C Uncomment following three lines for SC-p interactions
4819 c         xj=c(1,nres+j)-xi
4820 c         yj=c(2,nres+j)-yi
4821 c         zj=c(3,nres+j)-zi
4822 C Uncomment following three lines for Ca-p interactions
4823           xj=c(1,j)
4824           yj=c(2,j)
4825           zj=c(3,j)
4826 c  174   continue
4827 c        if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
4828 c        if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
4829 C Condition for being inside the proper box
4830 c        if ((xj.gt.((0.5d0)*boxxsize)).or.
4831 c     &       (xj.lt.((-0.5d0)*boxxsize))) then
4832 c        go to 174
4833 c        endif
4834 c  175   continue
4835 c        if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
4836 c        if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
4837 cC Condition for being inside the proper box
4838 c        if ((yj.gt.((0.5d0)*boxysize)).or.
4839 c     &       (yj.lt.((-0.5d0)*boxysize))) then
4840 c        go to 175
4841 c        endif
4842 c  176   continue
4843 c        if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
4844 c        if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
4845 C Condition for being inside the proper box
4846 c        if ((zj.gt.((0.5d0)*boxzsize)).or.
4847 c     &       (zj.lt.((-0.5d0)*boxzsize))) then
4848 c        go to 176
4849           xj=mod(xj,boxxsize)
4850           if (xj.lt.0) xj=xj+boxxsize
4851           yj=mod(yj,boxysize)
4852           if (yj.lt.0) yj=yj+boxysize
4853           zj=mod(zj,boxzsize)
4854           if (zj.lt.0) zj=zj+boxzsize
4855       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
4856       xj_safe=xj
4857       yj_safe=yj
4858       zj_safe=zj
4859       subchap=0
4860       do xshift=-1,1
4861       do yshift=-1,1
4862       do zshift=-1,1
4863           xj=xj_safe+xshift*boxxsize
4864           yj=yj_safe+yshift*boxysize
4865           zj=zj_safe+zshift*boxzsize
4866           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
4867           if(dist_temp.lt.dist_init) then
4868             dist_init=dist_temp
4869             xj_temp=xj
4870             yj_temp=yj
4871             zj_temp=zj
4872             subchap=1
4873           endif
4874        enddo
4875        enddo
4876        enddo
4877        if (subchap.eq.1) then
4878           xj=xj_temp-xi
4879           yj=yj_temp-yi
4880           zj=zj_temp-zi
4881        else
4882           xj=xj_safe-xi
4883           yj=yj_safe-yi
4884           zj=zj_safe-zi
4885        endif
4886 c c       endif
4887 C          xj=xj-xi
4888 C          yj=yj-yi
4889 C          zj=zj-zi
4890           rij=xj*xj+yj*yj+zj*zj
4891
4892           r0ij=r0_scp
4893           r0ijsq=r0ij*r0ij
4894           if (rij.lt.r0ijsq) then
4895             evdwij=0.25d0*(rij-r0ijsq)**2
4896             fac=rij-r0ijsq
4897           else
4898             evdwij=0.0d0
4899             fac=0.0d0
4900           endif
4901           evdw2=evdw2+evdwij
4902 C
4903 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
4904 C
4905           ggg(1)=xj*fac
4906           ggg(2)=yj*fac
4907           ggg(3)=zj*fac
4908 cgrad          if (j.lt.i) then
4909 cd          write (iout,*) 'j<i'
4910 C Uncomment following three lines for SC-p interactions
4911 c           do k=1,3
4912 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
4913 c           enddo
4914 cgrad          else
4915 cd          write (iout,*) 'j>i'
4916 cgrad            do k=1,3
4917 cgrad              ggg(k)=-ggg(k)
4918 C Uncomment following line for SC-p interactions
4919 c             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
4920 cgrad            enddo
4921 cgrad          endif
4922 cgrad          do k=1,3
4923 cgrad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
4924 cgrad          enddo
4925 cgrad          kstart=min0(i+1,j)
4926 cgrad          kend=max0(i-1,j-1)
4927 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
4928 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
4929 cgrad          do k=kstart,kend
4930 cgrad            do l=1,3
4931 cgrad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
4932 cgrad            enddo
4933 cgrad          enddo
4934           do k=1,3
4935             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
4936             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
4937           enddo
4938         enddo
4939
4940         enddo ! iint
4941       enddo ! i
4942 C      enddo !zshift
4943 C      enddo !yshift
4944 C      enddo !xshift
4945       return
4946       end
4947 C-----------------------------------------------------------------------------
4948       subroutine escp(evdw2,evdw2_14)
4949 C
4950 C This subroutine calculates the excluded-volume interaction energy between
4951 C peptide-group centers and side chains and its gradient in virtual-bond and
4952 C side-chain vectors.
4953 C
4954       implicit real*8 (a-h,o-z)
4955       include 'DIMENSIONS'
4956       include 'COMMON.GEO'
4957       include 'COMMON.VAR'
4958       include 'COMMON.LOCAL'
4959       include 'COMMON.CHAIN'
4960       include 'COMMON.DERIV'
4961       include 'COMMON.INTERACT'
4962       include 'COMMON.FFIELD'
4963       include 'COMMON.IOUNITS'
4964       include 'COMMON.CONTROL'
4965       include 'COMMON.SPLITELE'
4966       dimension ggg(3)
4967       evdw2=0.0D0
4968       evdw2_14=0.0d0
4969 c        print *,boxxsize,boxysize,boxzsize,'wymiary pudla'
4970 cd    print '(a)','Enter ESCP'
4971 cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
4972 C      do xshift=-1,1
4973 C      do yshift=-1,1
4974 C      do zshift=-1,1
4975       do i=iatscp_s,iatscp_e
4976         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
4977         iteli=itel(i)
4978         xi=0.5D0*(c(1,i)+c(1,i+1))
4979         yi=0.5D0*(c(2,i)+c(2,i+1))
4980         zi=0.5D0*(c(3,i)+c(3,i+1))
4981           xi=mod(xi,boxxsize)
4982           if (xi.lt.0) xi=xi+boxxsize
4983           yi=mod(yi,boxysize)
4984           if (yi.lt.0) yi=yi+boxysize
4985           zi=mod(zi,boxzsize)
4986           if (zi.lt.0) zi=zi+boxzsize
4987 c          xi=xi+xshift*boxxsize
4988 c          yi=yi+yshift*boxysize
4989 c          zi=zi+zshift*boxzsize
4990 c        print *,xi,yi,zi,'polozenie i'
4991 C Return atom into box, boxxsize is size of box in x dimension
4992 c  134   continue
4993 c        if (xi.gt.((xshift+0.5d0)*boxxsize)) xi=xi-boxxsize
4994 c        if (xi.lt.((xshift-0.5d0)*boxxsize)) xi=xi+boxxsize
4995 C Condition for being inside the proper box
4996 c        if ((xi.gt.((xshift+0.5d0)*boxxsize)).or.
4997 c     &       (xi.lt.((xshift-0.5d0)*boxxsize))) then
4998 c        go to 134
4999 c        endif
5000 c  135   continue
5001 c          print *,xi,boxxsize,"pierwszy"
5002
5003 c        if (yi.gt.((yshift+0.5d0)*boxysize)) yi=yi-boxysize
5004 c        if (yi.lt.((yshift-0.5d0)*boxysize)) yi=yi+boxysize
5005 C Condition for being inside the proper box
5006 c        if ((yi.gt.((yshift+0.5d0)*boxysize)).or.
5007 c     &       (yi.lt.((yshift-0.5d0)*boxysize))) then
5008 c        go to 135
5009 c        endif
5010 c  136   continue
5011 c        if (zi.gt.((zshift+0.5d0)*boxzsize)) zi=zi-boxzsize
5012 c        if (zi.lt.((zshift-0.5d0)*boxzsize)) zi=zi+boxzsize
5013 C Condition for being inside the proper box
5014 c        if ((zi.gt.((zshift+0.5d0)*boxzsize)).or.
5015 c     &       (zi.lt.((zshift-0.5d0)*boxzsize))) then
5016 c        go to 136
5017 c        endif
5018         do iint=1,nscp_gr(i)
5019
5020         do j=iscpstart(i,iint),iscpend(i,iint)
5021           itypj=iabs(itype(j))
5022           if (itypj.eq.ntyp1) cycle
5023 C Uncomment following three lines for SC-p interactions
5024 c         xj=c(1,nres+j)-xi
5025 c         yj=c(2,nres+j)-yi
5026 c         zj=c(3,nres+j)-zi
5027 C Uncomment following three lines for Ca-p interactions
5028           xj=c(1,j)
5029           yj=c(2,j)
5030           zj=c(3,j)
5031           xj=mod(xj,boxxsize)
5032           if (xj.lt.0) xj=xj+boxxsize
5033           yj=mod(yj,boxysize)
5034           if (yj.lt.0) yj=yj+boxysize
5035           zj=mod(zj,boxzsize)
5036           if (zj.lt.0) zj=zj+boxzsize
5037 c  174   continue
5038 c        if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
5039 c        if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
5040 C Condition for being inside the proper box
5041 c        if ((xj.gt.((0.5d0)*boxxsize)).or.
5042 c     &       (xj.lt.((-0.5d0)*boxxsize))) then
5043 c        go to 174
5044 c        endif
5045 c  175   continue
5046 c        if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
5047 c        if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
5048 cC Condition for being inside the proper box
5049 c        if ((yj.gt.((0.5d0)*boxysize)).or.
5050 c     &       (yj.lt.((-0.5d0)*boxysize))) then
5051 c        go to 175
5052 c        endif
5053 c  176   continue
5054 c        if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
5055 c        if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
5056 C Condition for being inside the proper box
5057 c        if ((zj.gt.((0.5d0)*boxzsize)).or.
5058 c     &       (zj.lt.((-0.5d0)*boxzsize))) then
5059 c        go to 176
5060 c        endif
5061 CHERE IS THE CALCULATION WHICH MIRROR IMAGE IS THE CLOSEST ONE
5062       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
5063       xj_safe=xj
5064       yj_safe=yj
5065       zj_safe=zj
5066       subchap=0
5067       do xshift=-1,1
5068       do yshift=-1,1
5069       do zshift=-1,1
5070           xj=xj_safe+xshift*boxxsize
5071           yj=yj_safe+yshift*boxysize
5072           zj=zj_safe+zshift*boxzsize
5073           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
5074           if(dist_temp.lt.dist_init) then
5075             dist_init=dist_temp
5076             xj_temp=xj
5077             yj_temp=yj
5078             zj_temp=zj
5079             subchap=1
5080           endif
5081        enddo
5082        enddo
5083        enddo
5084        if (subchap.eq.1) then
5085           xj=xj_temp-xi
5086           yj=yj_temp-yi
5087           zj=zj_temp-zi
5088        else
5089           xj=xj_safe-xi
5090           yj=yj_safe-yi
5091           zj=zj_safe-zi
5092        endif
5093 c          print *,xj,yj,zj,'polozenie j'
5094           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
5095 c          print *,rrij
5096           sss=sscale(1.0d0/(dsqrt(rrij)))
5097 c          print *,r_cut,1.0d0/dsqrt(rrij),sss,'tu patrz'
5098 c          if (sss.eq.0) print *,'czasem jest OK'
5099           if (sss.le.0.0d0) cycle
5100           sssgrad=sscagrad(1.0d0/(dsqrt(rrij)))
5101           fac=rrij**expon2
5102           e1=fac*fac*aad(itypj,iteli)
5103           e2=fac*bad(itypj,iteli)
5104           if (iabs(j-i) .le. 2) then
5105             e1=scal14*e1
5106             e2=scal14*e2
5107             evdw2_14=evdw2_14+(e1+e2)*sss
5108           endif
5109           evdwij=e1+e2
5110           evdw2=evdw2+evdwij*sss
5111           if (energy_dec) write (iout,'(a6,2i5,0pf7.3,2i3,3e11.3)')
5112      &        'evdw2',i,j,evdwij
5113 c     &        ,iteli,itypj,fac,aad(itypj,iteli),bad(itypj,iteli)
5114 C
5115 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
5116 C
5117           fac=-(evdwij+e1)*rrij*sss
5118           fac=fac+(evdwij)*sssgrad*dsqrt(rrij)/expon
5119           ggg(1)=xj*fac
5120           ggg(2)=yj*fac
5121           ggg(3)=zj*fac
5122 cgrad          if (j.lt.i) then
5123 cd          write (iout,*) 'j<i'
5124 C Uncomment following three lines for SC-p interactions
5125 c           do k=1,3
5126 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
5127 c           enddo
5128 cgrad          else
5129 cd          write (iout,*) 'j>i'
5130 cgrad            do k=1,3
5131 cgrad              ggg(k)=-ggg(k)
5132 C Uncomment following line for SC-p interactions
5133 ccgrad             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
5134 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
5135 cgrad            enddo
5136 cgrad          endif
5137 cgrad          do k=1,3
5138 cgrad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
5139 cgrad          enddo
5140 cgrad          kstart=min0(i+1,j)
5141 cgrad          kend=max0(i-1,j-1)
5142 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
5143 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
5144 cgrad          do k=kstart,kend
5145 cgrad            do l=1,3
5146 cgrad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
5147 cgrad            enddo
5148 cgrad          enddo
5149           do k=1,3
5150             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
5151             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
5152           enddo
5153 c        endif !endif for sscale cutoff
5154         enddo ! j
5155
5156         enddo ! iint
5157       enddo ! i
5158 c      enddo !zshift
5159 c      enddo !yshift
5160 c      enddo !xshift
5161       do i=1,nct
5162         do j=1,3
5163           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
5164           gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
5165           gradx_scp(j,i)=expon*gradx_scp(j,i)
5166         enddo
5167       enddo
5168 C******************************************************************************
5169 C
5170 C                              N O T E !!!
5171 C
5172 C To save time the factor EXPON has been extracted from ALL components
5173 C of GVDWC and GRADX. Remember to multiply them by this factor before further
5174 C use!
5175 C
5176 C******************************************************************************
5177       return
5178       end
5179 C--------------------------------------------------------------------------
5180       subroutine edis(ehpb)
5181 C
5182 C Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors.
5183 C
5184       implicit real*8 (a-h,o-z)
5185       include 'DIMENSIONS'
5186       include 'COMMON.SBRIDGE'
5187       include 'COMMON.CHAIN'
5188       include 'COMMON.DERIV'
5189       include 'COMMON.VAR'
5190       include 'COMMON.INTERACT'
5191       include 'COMMON.IOUNITS'
5192       dimension ggg(3)
5193       ehpb=0.0D0
5194 cd      write(iout,*)'edis: nhpb=',nhpb,' fbr=',fbr
5195 cd      write(iout,*)'link_start=',link_start,' link_end=',link_end
5196       if (link_end.eq.0) return
5197       do i=link_start,link_end
5198 C If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a
5199 C CA-CA distance used in regularization of structure.
5200         ii=ihpb(i)
5201         jj=jhpb(i)
5202 C iii and jjj point to the residues for which the distance is assigned.
5203         if (ii.gt.nres) then
5204           iii=ii-nres
5205           jjj=jj-nres
5206         else
5207           iii=ii
5208           jjj=jj
5209         endif
5210 c        write (iout,*) "i",i," ii",ii," iii",iii," jj",jj," jjj",jjj,
5211 c     &    dhpb(i),dhpb1(i),forcon(i)
5212 C 24/11/03 AL: SS bridges handled separately because of introducing a specific
5213 C    distance and angle dependent SS bond potential.
5214 C        if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and.
5215 C     & iabs(itype(jjj)).eq.1) then
5216 cmc        if (ii.gt.nres .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then
5217 C 18/07/06 MC: Use the convention that the first nss pairs are SS bonds
5218         if (.not.dyn_ss .and. i.le.nss) then
5219 C 15/02/13 CC dynamic SSbond - additional check
5220          if (ii.gt.nres
5221      &       .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then
5222           call ssbond_ene(iii,jjj,eij)
5223           ehpb=ehpb+2*eij
5224          endif
5225 cd          write (iout,*) "eij",eij
5226         else
5227 C Calculate the distance between the two points and its difference from the
5228 C target distance.
5229           dd=dist(ii,jj)
5230             rdis=dd-dhpb(i)
5231 C Get the force constant corresponding to this distance.
5232             waga=forcon(i)
5233 C Calculate the contribution to energy.
5234             ehpb=ehpb+waga*rdis*rdis
5235 C
5236 C Evaluate gradient.
5237 C
5238             fac=waga*rdis/dd
5239 cd      print *,'i=',i,' ii=',ii,' jj=',jj,' dhpb=',dhpb(i),' dd=',dd,
5240 cd   &   ' waga=',waga,' fac=',fac
5241             do j=1,3
5242               ggg(j)=fac*(c(j,jj)-c(j,ii))
5243             enddo
5244 cd      print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
5245 C If this is a SC-SC distance, we need to calculate the contributions to the
5246 C Cartesian gradient in the SC vectors (ghpbx).
5247           if (iii.lt.ii) then
5248           do j=1,3
5249             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
5250             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
5251           enddo
5252           endif
5253 cgrad        do j=iii,jjj-1
5254 cgrad          do k=1,3
5255 cgrad            ghpbc(k,j)=ghpbc(k,j)+ggg(k)
5256 cgrad          enddo
5257 cgrad        enddo
5258           do k=1,3
5259             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
5260             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
5261           enddo
5262         endif
5263       enddo
5264       ehpb=0.5D0*ehpb
5265       return
5266       end
5267 C--------------------------------------------------------------------------
5268       subroutine ssbond_ene(i,j,eij)
5269 C
5270 C Calculate the distance and angle dependent SS-bond potential energy
5271 C using a free-energy function derived based on RHF/6-31G** ab initio
5272 C calculations of diethyl disulfide.
5273 C
5274 C A. Liwo and U. Kozlowska, 11/24/03
5275 C
5276       implicit real*8 (a-h,o-z)
5277       include 'DIMENSIONS'
5278       include 'COMMON.SBRIDGE'
5279       include 'COMMON.CHAIN'
5280       include 'COMMON.DERIV'
5281       include 'COMMON.LOCAL'
5282       include 'COMMON.INTERACT'
5283       include 'COMMON.VAR'
5284       include 'COMMON.IOUNITS'
5285       double precision erij(3),dcosom1(3),dcosom2(3),gg(3)
5286       itypi=iabs(itype(i))
5287       xi=c(1,nres+i)
5288       yi=c(2,nres+i)
5289       zi=c(3,nres+i)
5290       dxi=dc_norm(1,nres+i)
5291       dyi=dc_norm(2,nres+i)
5292       dzi=dc_norm(3,nres+i)
5293 c      dsci_inv=dsc_inv(itypi)
5294       dsci_inv=vbld_inv(nres+i)
5295       itypj=iabs(itype(j))
5296 c      dscj_inv=dsc_inv(itypj)
5297       dscj_inv=vbld_inv(nres+j)
5298       xj=c(1,nres+j)-xi
5299       yj=c(2,nres+j)-yi
5300       zj=c(3,nres+j)-zi
5301       dxj=dc_norm(1,nres+j)
5302       dyj=dc_norm(2,nres+j)
5303       dzj=dc_norm(3,nres+j)
5304       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
5305       rij=dsqrt(rrij)
5306       erij(1)=xj*rij
5307       erij(2)=yj*rij
5308       erij(3)=zj*rij
5309       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
5310       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
5311       om12=dxi*dxj+dyi*dyj+dzi*dzj
5312       do k=1,3
5313         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
5314         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
5315       enddo
5316       rij=1.0d0/rij
5317       deltad=rij-d0cm
5318       deltat1=1.0d0-om1
5319       deltat2=1.0d0+om2
5320       deltat12=om2-om1+2.0d0
5321       cosphi=om12-om1*om2
5322       eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2)
5323      &  +akct*deltad*deltat12
5324      &  +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi+ebr
5325 c      write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth,
5326 c     &  " akct",akct," deltad",deltad," deltat",deltat1,deltat2,
5327 c     &  " deltat12",deltat12," eij",eij
5328       ed=2*akcm*deltad+akct*deltat12
5329       pom1=akct*deltad
5330       pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
5331       eom1=-2*akth*deltat1-pom1-om2*pom2
5332       eom2= 2*akth*deltat2+pom1-om1*pom2
5333       eom12=pom2
5334       do k=1,3
5335         ggk=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
5336         ghpbx(k,i)=ghpbx(k,i)-ggk
5337      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
5338      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
5339         ghpbx(k,j)=ghpbx(k,j)+ggk
5340      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
5341      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
5342         ghpbc(k,i)=ghpbc(k,i)-ggk
5343         ghpbc(k,j)=ghpbc(k,j)+ggk
5344       enddo
5345 C
5346 C Calculate the components of the gradient in DC and X
5347 C
5348 cgrad      do k=i,j-1
5349 cgrad        do l=1,3
5350 cgrad          ghpbc(l,k)=ghpbc(l,k)+gg(l)
5351 cgrad        enddo
5352 cgrad      enddo
5353       return
5354       end
5355 C--------------------------------------------------------------------------
5356       subroutine ebond(estr)
5357 c
5358 c Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
5359 c
5360       implicit real*8 (a-h,o-z)
5361       include 'DIMENSIONS'
5362       include 'COMMON.LOCAL'
5363       include 'COMMON.GEO'
5364       include 'COMMON.INTERACT'
5365       include 'COMMON.DERIV'
5366       include 'COMMON.VAR'
5367       include 'COMMON.CHAIN'
5368       include 'COMMON.IOUNITS'
5369       include 'COMMON.NAMES'
5370       include 'COMMON.FFIELD'
5371       include 'COMMON.CONTROL'
5372       include 'COMMON.SETUP'
5373       double precision u(3),ud(3)
5374       estr=0.0d0
5375       estr1=0.0d0
5376       do i=ibondp_start,ibondp_end
5377         if (itype(i-1).eq.ntyp1 .and. itype(i).eq.ntyp1) cycle
5378 c          estr1=estr1+gnmr1(vbld(i),-1.0d0,distchainmax)
5379 c          do j=1,3
5380 c          gradb(j,i-1)=gnmr1prim(vbld(i),-1.0d0,distchainmax)
5381 c     &      *dc(j,i-1)/vbld(i)
5382 c          enddo
5383 c          if (energy_dec) write(iout,*)
5384 c     &       "estr1",i,gnmr1(vbld(i),-1.0d0,distchainmax)
5385 c        else
5386 C       Checking if it involves dummy (NH3+ or COO-) group
5387          if (itype(i-1).eq.ntyp1 .or. itype(i).eq.ntyp1) then
5388 C YES   vbldpDUM is the equlibrium length of spring for Dummy atom
5389         diff = vbld(i)-vbldpDUM
5390          else
5391 C NO    vbldp0 is the equlibrium lenght of spring for peptide group
5392         diff = vbld(i)-vbldp0
5393          endif
5394         if (energy_dec)    write (iout,'(a7,i5,4f7.3)')
5395      &     "estr bb",i,vbld(i),vbldp0,diff,AKP*diff*diff
5396         estr=estr+diff*diff
5397         do j=1,3
5398           gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)
5399         enddo
5400 c        write (iout,'(i5,3f10.5)') i,(gradb(j,i-1),j=1,3)
5401 c        endif
5402       enddo
5403       estr=0.5d0*AKP*estr+estr1
5404 c
5405 c 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included
5406 c
5407       do i=ibond_start,ibond_end
5408         iti=iabs(itype(i))
5409         if (iti.ne.10 .and. iti.ne.ntyp1) then
5410           nbi=nbondterm(iti)
5411           if (nbi.eq.1) then
5412             diff=vbld(i+nres)-vbldsc0(1,iti)
5413             if (energy_dec)  write (iout,*)
5414      &      "estr sc",i,iti,vbld(i+nres),vbldsc0(1,iti),diff,
5415      &      AKSC(1,iti),AKSC(1,iti)*diff*diff
5416             estr=estr+0.5d0*AKSC(1,iti)*diff*diff
5417             do j=1,3
5418               gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
5419             enddo
5420           else
5421             do j=1,nbi
5422               diff=vbld(i+nres)-vbldsc0(j,iti)
5423               ud(j)=aksc(j,iti)*diff
5424               u(j)=abond0(j,iti)+0.5d0*ud(j)*diff
5425             enddo
5426             uprod=u(1)
5427             do j=2,nbi
5428               uprod=uprod*u(j)
5429             enddo
5430             usum=0.0d0
5431             usumsqder=0.0d0
5432             do j=1,nbi
5433               uprod1=1.0d0
5434               uprod2=1.0d0
5435               do k=1,nbi
5436                 if (k.ne.j) then
5437                   uprod1=uprod1*u(k)
5438                   uprod2=uprod2*u(k)*u(k)
5439                 endif
5440               enddo
5441               usum=usum+uprod1
5442               usumsqder=usumsqder+ud(j)*uprod2
5443             enddo
5444             estr=estr+uprod/usum
5445             do j=1,3
5446              gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
5447             enddo
5448           endif
5449         endif
5450       enddo
5451       return
5452       end
5453 #ifdef CRYST_THETA
5454 C--------------------------------------------------------------------------
5455       subroutine ebend(etheta)
5456 C
5457 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
5458 C angles gamma and its derivatives in consecutive thetas and gammas.
5459 C
5460       implicit real*8 (a-h,o-z)
5461       include 'DIMENSIONS'
5462       include 'COMMON.LOCAL'
5463       include 'COMMON.GEO'
5464       include 'COMMON.INTERACT'
5465       include 'COMMON.DERIV'
5466       include 'COMMON.VAR'
5467       include 'COMMON.CHAIN'
5468       include 'COMMON.IOUNITS'
5469       include 'COMMON.NAMES'
5470       include 'COMMON.FFIELD'
5471       include 'COMMON.CONTROL'
5472       common /calcthet/ term1,term2,termm,diffak,ratak,
5473      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
5474      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
5475       double precision y(2),z(2)
5476       delta=0.02d0*pi
5477 c      time11=dexp(-2*time)
5478 c      time12=1.0d0
5479       etheta=0.0D0
5480 c     write (*,'(a,i2)') 'EBEND ICG=',icg
5481       do i=ithet_start,ithet_end
5482         if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
5483      &  .or.itype(i).eq.ntyp1) cycle
5484 C Zero the energy function and its derivative at 0 or pi.
5485         call splinthet(theta(i),0.5d0*delta,ss,ssd)
5486         it=itype(i-1)
5487         ichir1=isign(1,itype(i-2))
5488         ichir2=isign(1,itype(i))
5489          if (itype(i-2).eq.10) ichir1=isign(1,itype(i-1))
5490          if (itype(i).eq.10) ichir2=isign(1,itype(i-1))
5491          if (itype(i-1).eq.10) then
5492           itype1=isign(10,itype(i-2))
5493           ichir11=isign(1,itype(i-2))
5494           ichir12=isign(1,itype(i-2))
5495           itype2=isign(10,itype(i))
5496           ichir21=isign(1,itype(i))
5497           ichir22=isign(1,itype(i))
5498          endif
5499
5500         if (i.gt.3 .and. itype(i-3).ne.ntyp1) then
5501 #ifdef OSF
5502           phii=phi(i)
5503           if (phii.ne.phii) phii=150.0
5504 #else
5505           phii=phi(i)
5506 #endif
5507           y(1)=dcos(phii)
5508           y(2)=dsin(phii)
5509         else
5510           y(1)=0.0D0
5511           y(2)=0.0D0
5512         endif
5513         if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
5514 #ifdef OSF
5515           phii1=phi(i+1)
5516           if (phii1.ne.phii1) phii1=150.0
5517           phii1=pinorm(phii1)
5518           z(1)=cos(phii1)
5519 #else
5520           phii1=phi(i+1)
5521 #endif
5522           z(1)=dcos(phii1)
5523           z(2)=dsin(phii1)
5524         else
5525           z(1)=0.0D0
5526           z(2)=0.0D0
5527         endif
5528 C Calculate the "mean" value of theta from the part of the distribution
5529 C dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2).
5530 C In following comments this theta will be referred to as t_c.
5531         thet_pred_mean=0.0d0
5532         do k=1,2
5533             athetk=athet(k,it,ichir1,ichir2)
5534             bthetk=bthet(k,it,ichir1,ichir2)
5535           if (it.eq.10) then
5536              athetk=athet(k,itype1,ichir11,ichir12)
5537              bthetk=bthet(k,itype2,ichir21,ichir22)
5538           endif
5539          thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k)
5540 c         write(iout,*) 'chuj tu', y(k),z(k)
5541         enddo
5542         dthett=thet_pred_mean*ssd
5543         thet_pred_mean=thet_pred_mean*ss+a0thet(it)
5544 C Derivatives of the "mean" values in gamma1 and gamma2.
5545         dthetg1=(-athet(1,it,ichir1,ichir2)*y(2)
5546      &+athet(2,it,ichir1,ichir2)*y(1))*ss
5547          dthetg2=(-bthet(1,it,ichir1,ichir2)*z(2)
5548      &          +bthet(2,it,ichir1,ichir2)*z(1))*ss
5549          if (it.eq.10) then
5550       dthetg1=(-athet(1,itype1,ichir11,ichir12)*y(2)
5551      &+athet(2,itype1,ichir11,ichir12)*y(1))*ss
5552         dthetg2=(-bthet(1,itype2,ichir21,ichir22)*z(2)
5553      &         +bthet(2,itype2,ichir21,ichir22)*z(1))*ss
5554          endif
5555         if (theta(i).gt.pi-delta) then
5556           call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,
5557      &         E_tc0)
5558           call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0)
5559           call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
5560           call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,
5561      &        E_theta)
5562           call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,
5563      &        E_tc)
5564         else if (theta(i).lt.delta) then
5565           call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0)
5566           call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
5567           call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,
5568      &        E_theta)
5569           call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0)
5570           call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,
5571      &        E_tc)
5572         else
5573           call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,
5574      &        E_theta,E_tc)
5575         endif
5576         etheta=etheta+ethetai
5577         if (energy_dec) write (iout,'(a6,i5,0pf7.3,f7.3,i5)')
5578      &      'ebend',i,ethetai,theta(i),itype(i)
5579         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1
5580         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2
5581         gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)+gloc(nphi+i-2,icg)
5582       enddo
5583 C Ufff.... We've done all this!!!
5584       return
5585       end
5586 C---------------------------------------------------------------------------
5587       subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,
5588      &     E_tc)
5589       implicit real*8 (a-h,o-z)
5590       include 'DIMENSIONS'
5591       include 'COMMON.LOCAL'
5592       include 'COMMON.IOUNITS'
5593       common /calcthet/ term1,term2,termm,diffak,ratak,
5594      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
5595      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
5596 C Calculate the contributions to both Gaussian lobes.
5597 C 6/6/97 - Deform the Gaussians using the factor of 1/(1+time)
5598 C The "polynomial part" of the "standard deviation" of this part of
5599 C the distributioni.
5600 ccc        write (iout,*) thetai,thet_pred_mean
5601         sig=polthet(3,it)
5602         do j=2,0,-1
5603           sig=sig*thet_pred_mean+polthet(j,it)
5604         enddo
5605 C Derivative of the "interior part" of the "standard deviation of the"
5606 C gamma-dependent Gaussian lobe in t_c.
5607         sigtc=3*polthet(3,it)
5608         do j=2,1,-1
5609           sigtc=sigtc*thet_pred_mean+j*polthet(j,it)
5610         enddo
5611         sigtc=sig*sigtc
5612 C Set the parameters of both Gaussian lobes of the distribution.
5613 C "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc)
5614         fac=sig*sig+sigc0(it)
5615         sigcsq=fac+fac
5616         sigc=1.0D0/sigcsq
5617 C Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c
5618         sigsqtc=-4.0D0*sigcsq*sigtc
5619 c       print *,i,sig,sigtc,sigsqtc
5620 C Following variable (sigtc) is d[sigma(t_c)]/dt_c
5621         sigtc=-sigtc/(fac*fac)
5622 C Following variable is sigma(t_c)**(-2)
5623         sigcsq=sigcsq*sigcsq
5624         sig0i=sig0(it)
5625         sig0inv=1.0D0/sig0i**2
5626         delthec=thetai-thet_pred_mean
5627         delthe0=thetai-theta0i
5628         term1=-0.5D0*sigcsq*delthec*delthec
5629         term2=-0.5D0*sig0inv*delthe0*delthe0
5630 C        write (iout,*)'term1',term1,term2,sigcsq,delthec,sig0inv,delthe0
5631 C Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and
5632 C NaNs in taking the logarithm. We extract the largest exponent which is added
5633 C to the energy (this being the log of the distribution) at the end of energy
5634 C term evaluation for this virtual-bond angle.
5635         if (term1.gt.term2) then
5636           termm=term1
5637           term2=dexp(term2-termm)
5638           term1=1.0d0
5639         else
5640           termm=term2
5641           term1=dexp(term1-termm)
5642           term2=1.0d0
5643         endif
5644 C The ratio between the gamma-independent and gamma-dependent lobes of
5645 C the distribution is a Gaussian function of thet_pred_mean too.
5646         diffak=gthet(2,it)-thet_pred_mean
5647         ratak=diffak/gthet(3,it)**2
5648         ak=dexp(gthet(1,it)-0.5D0*diffak*ratak)
5649 C Let's differentiate it in thet_pred_mean NOW.
5650         aktc=ak*ratak
5651 C Now put together the distribution terms to make complete distribution.
5652         termexp=term1+ak*term2
5653         termpre=sigc+ak*sig0i
5654 C Contribution of the bending energy from this theta is just the -log of
5655 C the sum of the contributions from the two lobes and the pre-exponential
5656 C factor. Simple enough, isn't it?
5657         ethetai=(-dlog(termexp)-termm+dlog(termpre))
5658 C       write (iout,*) 'termexp',termexp,termm,termpre,i
5659 C NOW the derivatives!!!
5660 C 6/6/97 Take into account the deformation.
5661         E_theta=(delthec*sigcsq*term1
5662      &       +ak*delthe0*sig0inv*term2)/termexp
5663         E_tc=((sigtc+aktc*sig0i)/termpre
5664      &      -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+
5665      &       aktc*term2)/termexp)
5666       return
5667       end
5668 c-----------------------------------------------------------------------------
5669       subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)
5670       implicit real*8 (a-h,o-z)
5671       include 'DIMENSIONS'
5672       include 'COMMON.LOCAL'
5673       include 'COMMON.IOUNITS'
5674       common /calcthet/ term1,term2,termm,diffak,ratak,
5675      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
5676      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
5677       delthec=thetai-thet_pred_mean
5678       delthe0=thetai-theta0i
5679 C "Thank you" to MAPLE (probably spared one day of hand-differentiation).
5680       t3 = thetai-thet_pred_mean
5681       t6 = t3**2
5682       t9 = term1
5683       t12 = t3*sigcsq
5684       t14 = t12+t6*sigsqtc
5685       t16 = 1.0d0
5686       t21 = thetai-theta0i
5687       t23 = t21**2
5688       t26 = term2
5689       t27 = t21*t26
5690       t32 = termexp
5691       t40 = t32**2
5692       E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9
5693      & -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40
5694      & *(-t12*t9-ak*sig0inv*t27)
5695       return
5696       end
5697 #else
5698 C--------------------------------------------------------------------------
5699       subroutine ebend(etheta)
5700 C
5701 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
5702 C angles gamma and its derivatives in consecutive thetas and gammas.
5703 C ab initio-derived potentials from
5704 c Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203
5705 C
5706       implicit real*8 (a-h,o-z)
5707       include 'DIMENSIONS'
5708       include 'COMMON.LOCAL'
5709       include 'COMMON.GEO'
5710       include 'COMMON.INTERACT'
5711       include 'COMMON.DERIV'
5712       include 'COMMON.VAR'
5713       include 'COMMON.CHAIN'
5714       include 'COMMON.IOUNITS'
5715       include 'COMMON.NAMES'
5716       include 'COMMON.FFIELD'
5717       include 'COMMON.CONTROL'
5718       double precision coskt(mmaxtheterm),sinkt(mmaxtheterm),
5719      & cosph1(maxsingle),sinph1(maxsingle),cosph2(maxsingle),
5720      & sinph2(maxsingle),cosph1ph2(maxdouble,maxdouble),
5721      & sinph1ph2(maxdouble,maxdouble)
5722       logical lprn /.false./, lprn1 /.false./
5723       etheta=0.0D0
5724       do i=ithet_start,ithet_end
5725 c        if (i.eq.2) cycle
5726 c        print *,i,itype(i-1),itype(i),itype(i-2)
5727         if ((itype(i-1).eq.ntyp1).or.(itype(i-2).eq.ntyp1)
5728      &  .or.(itype(i).eq.ntyp1)) cycle
5729 C In current verion the ALL DUMMY ATOM POTENTIALS ARE OFF
5730
5731         if (iabs(itype(i+1)).eq.20) iblock=2
5732         if (iabs(itype(i+1)).ne.20) iblock=1
5733         dethetai=0.0d0
5734         dephii=0.0d0
5735         dephii1=0.0d0
5736         theti2=0.5d0*theta(i)
5737         ityp2=ithetyp((itype(i-1)))
5738         do k=1,nntheterm
5739           coskt(k)=dcos(k*theti2)
5740           sinkt(k)=dsin(k*theti2)
5741         enddo
5742         if (i.gt.3 .and. itype(max0(i-3,1)).ne.ntyp1) then
5743 #ifdef OSF
5744           phii=phi(i)
5745           if (phii.ne.phii) phii=150.0
5746 #else
5747           phii=phi(i)
5748 #endif
5749           ityp1=ithetyp((itype(i-2)))
5750 C propagation of chirality for glycine type
5751           do k=1,nsingle
5752             cosph1(k)=dcos(k*phii)
5753             sinph1(k)=dsin(k*phii)
5754           enddo
5755         else
5756           phii=0.0d0
5757           ityp1=ithetyp(itype(i-2))
5758           do k=1,nsingle
5759             cosph1(k)=0.0d0
5760             sinph1(k)=0.0d0
5761           enddo
5762         endif
5763         if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
5764 #ifdef OSF
5765           phii1=phi(i+1)
5766           if (phii1.ne.phii1) phii1=150.0
5767           phii1=pinorm(phii1)
5768 #else
5769           phii1=phi(i+1)
5770 #endif
5771           ityp3=ithetyp((itype(i)))
5772           do k=1,nsingle
5773             cosph2(k)=dcos(k*phii1)
5774             sinph2(k)=dsin(k*phii1)
5775           enddo
5776         else
5777           phii1=0.0d0
5778           ityp3=ithetyp(itype(i))
5779           do k=1,nsingle
5780             cosph2(k)=0.0d0
5781             sinph2(k)=0.0d0
5782           enddo
5783         endif
5784         ethetai=aa0thet(ityp1,ityp2,ityp3,iblock)
5785         do k=1,ndouble
5786           do l=1,k-1
5787             ccl=cosph1(l)*cosph2(k-l)
5788             ssl=sinph1(l)*sinph2(k-l)
5789             scl=sinph1(l)*cosph2(k-l)
5790             csl=cosph1(l)*sinph2(k-l)
5791             cosph1ph2(l,k)=ccl-ssl
5792             cosph1ph2(k,l)=ccl+ssl
5793             sinph1ph2(l,k)=scl+csl
5794             sinph1ph2(k,l)=scl-csl
5795           enddo
5796         enddo
5797         if (lprn) then
5798         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,
5799      &    " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
5800         write (iout,*) "coskt and sinkt"
5801         do k=1,nntheterm
5802           write (iout,*) k,coskt(k),sinkt(k)
5803         enddo
5804         endif
5805         do k=1,ntheterm
5806           ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3,iblock)*sinkt(k)
5807           dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3,iblock)
5808      &      *coskt(k)
5809           if (lprn)
5810      &    write (iout,*) "k",k,"
5811      &     aathet",aathet(k,ityp1,ityp2,ityp3,iblock),
5812      &     " ethetai",ethetai
5813         enddo
5814         if (lprn) then
5815         write (iout,*) "cosph and sinph"
5816         do k=1,nsingle
5817           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
5818         enddo
5819         write (iout,*) "cosph1ph2 and sinph2ph2"
5820         do k=2,ndouble
5821           do l=1,k-1
5822             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),
5823      &         sinph1ph2(l,k),sinph1ph2(k,l)
5824           enddo
5825         enddo
5826         write(iout,*) "ethetai",ethetai
5827         endif
5828         do m=1,ntheterm2
5829           do k=1,nsingle
5830             aux=bbthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)
5831      &         +ccthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k)
5832      &         +ddthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)
5833      &         +eethet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k)
5834             ethetai=ethetai+sinkt(m)*aux
5835             dethetai=dethetai+0.5d0*m*aux*coskt(m)
5836             dephii=dephii+k*sinkt(m)*(
5837      &          ccthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)-
5838      &          bbthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k))
5839             dephii1=dephii1+k*sinkt(m)*(
5840      &          eethet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)-
5841      &          ddthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k))
5842             if (lprn)
5843      &      write (iout,*) "m",m," k",k," bbthet",
5844      &         bbthet(k,m,ityp1,ityp2,ityp3,iblock)," ccthet",
5845      &         ccthet(k,m,ityp1,ityp2,ityp3,iblock)," ddthet",
5846      &         ddthet(k,m,ityp1,ityp2,ityp3,iblock)," eethet",
5847      &         eethet(k,m,ityp1,ityp2,ityp3,iblock)," ethetai",ethetai
5848           enddo
5849         enddo
5850         if (lprn)
5851      &  write(iout,*) "ethetai",ethetai
5852         do m=1,ntheterm3
5853           do k=2,ndouble
5854             do l=1,k-1
5855               aux=ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
5856      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l)+
5857      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
5858      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)
5859               ethetai=ethetai+sinkt(m)*aux
5860               dethetai=dethetai+0.5d0*m*coskt(m)*aux
5861               dephii=dephii+l*sinkt(m)*(
5862      &           -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)-
5863      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
5864      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
5865      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
5866               dephii1=dephii1+(k-l)*sinkt(m)*(
5867      &           -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
5868      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
5869      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)-
5870      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
5871               if (lprn) then
5872               write (iout,*) "m",m," k",k," l",l," ffthet",
5873      &            ffthet(l,k,m,ityp1,ityp2,ityp3,iblock),
5874      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)," ggthet",
5875      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock),
5876      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock),
5877      &            " ethetai",ethetai
5878               write (iout,*) cosph1ph2(l,k)*sinkt(m),
5879      &            cosph1ph2(k,l)*sinkt(m),
5880      &            sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
5881               endif
5882             enddo
5883           enddo
5884         enddo
5885 10      continue
5886 c        lprn1=.true.
5887         if (lprn1)
5888      &    write (iout,'(i2,3f8.1,9h ethetai ,f10.5)')
5889      &   i,theta(i)*rad2deg,phii*rad2deg,
5890      &   phii1*rad2deg,ethetai
5891 c        lprn1=.false.
5892         etheta=etheta+ethetai
5893         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
5894      &      'ebend',i,ethetai
5895         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
5896         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
5897         gloc(nphi+i-2,icg)=wang*dethetai+gloc(nphi+i-2,icg)
5898       enddo
5899       return
5900       end
5901 #endif
5902 #ifdef CRYST_SC
5903 c-----------------------------------------------------------------------------
5904       subroutine esc(escloc)
5905 C Calculate the local energy of a side chain and its derivatives in the
5906 C corresponding virtual-bond valence angles THETA and the spherical angles
5907 C ALPHA and OMEGA.
5908       implicit real*8 (a-h,o-z)
5909       include 'DIMENSIONS'
5910       include 'COMMON.GEO'
5911       include 'COMMON.LOCAL'
5912       include 'COMMON.VAR'
5913       include 'COMMON.INTERACT'
5914       include 'COMMON.DERIV'
5915       include 'COMMON.CHAIN'
5916       include 'COMMON.IOUNITS'
5917       include 'COMMON.NAMES'
5918       include 'COMMON.FFIELD'
5919       include 'COMMON.CONTROL'
5920       double precision x(3),dersc(3),xemp(3),dersc0(3),dersc1(3),
5921      &     ddersc0(3),ddummy(3),xtemp(3),temp(3)
5922       common /sccalc/ time11,time12,time112,theti,it,nlobit
5923       delta=0.02d0*pi
5924       escloc=0.0D0
5925 c     write (iout,'(a)') 'ESC'
5926       do i=loc_start,loc_end
5927         it=itype(i)
5928         if (it.eq.ntyp1) cycle
5929         if (it.eq.10) goto 1
5930         nlobit=nlob(iabs(it))
5931 c       print *,'i=',i,' it=',it,' nlobit=',nlobit
5932 c       write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
5933         theti=theta(i+1)-pipol
5934         x(1)=dtan(theti)
5935         x(2)=alph(i)
5936         x(3)=omeg(i)
5937
5938         if (x(2).gt.pi-delta) then
5939           xtemp(1)=x(1)
5940           xtemp(2)=pi-delta
5941           xtemp(3)=x(3)
5942           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
5943           xtemp(2)=pi
5944           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
5945           call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),
5946      &        escloci,dersc(2))
5947           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
5948      &        ddersc0(1),dersc(1))
5949           call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),
5950      &        ddersc0(3),dersc(3))
5951           xtemp(2)=pi-delta
5952           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
5953           xtemp(2)=pi
5954           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
5955           call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,
5956      &            dersc0(2),esclocbi,dersc02)
5957           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
5958      &            dersc12,dersc01)
5959           call splinthet(x(2),0.5d0*delta,ss,ssd)
5960           dersc0(1)=dersc01
5961           dersc0(2)=dersc02
5962           dersc0(3)=0.0d0
5963           do k=1,3
5964             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
5965           enddo
5966           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
5967 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
5968 c    &             esclocbi,ss,ssd
5969           escloci=ss*escloci+(1.0d0-ss)*esclocbi
5970 c         escloci=esclocbi
5971 c         write (iout,*) escloci
5972         else if (x(2).lt.delta) then
5973           xtemp(1)=x(1)
5974           xtemp(2)=delta
5975           xtemp(3)=x(3)
5976           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
5977           xtemp(2)=0.0d0
5978           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
5979           call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),
5980      &        escloci,dersc(2))
5981           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
5982      &        ddersc0(1),dersc(1))
5983           call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),
5984      &        ddersc0(3),dersc(3))
5985           xtemp(2)=delta
5986           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
5987           xtemp(2)=0.0d0
5988           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
5989           call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,
5990      &            dersc0(2),esclocbi,dersc02)
5991           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
5992      &            dersc12,dersc01)
5993           dersc0(1)=dersc01
5994           dersc0(2)=dersc02
5995           dersc0(3)=0.0d0
5996           call splinthet(x(2),0.5d0*delta,ss,ssd)
5997           do k=1,3
5998             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
5999           enddo
6000           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
6001 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
6002 c    &             esclocbi,ss,ssd
6003           escloci=ss*escloci+(1.0d0-ss)*esclocbi
6004 c         write (iout,*) escloci
6005         else
6006           call enesc(x,escloci,dersc,ddummy,.false.)
6007         endif
6008
6009         escloc=escloc+escloci
6010         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
6011      &     'escloc',i,escloci
6012 c       write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
6013
6014         gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
6015      &   wscloc*dersc(1)
6016         gloc(ialph(i,1),icg)=wscloc*dersc(2)
6017         gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
6018     1   continue
6019       enddo
6020       return
6021       end
6022 C---------------------------------------------------------------------------
6023       subroutine enesc(x,escloci,dersc,ddersc,mixed)
6024       implicit real*8 (a-h,o-z)
6025       include 'DIMENSIONS'
6026       include 'COMMON.GEO'
6027       include 'COMMON.LOCAL'
6028       include 'COMMON.IOUNITS'
6029       common /sccalc/ time11,time12,time112,theti,it,nlobit
6030       double precision x(3),z(3),Ax(3,maxlob,-1:1),dersc(3),ddersc(3)
6031       double precision contr(maxlob,-1:1)
6032       logical mixed
6033 c       write (iout,*) 'it=',it,' nlobit=',nlobit
6034         escloc_i=0.0D0
6035         do j=1,3
6036           dersc(j)=0.0D0
6037           if (mixed) ddersc(j)=0.0d0
6038         enddo
6039         x3=x(3)
6040
6041 C Because of periodicity of the dependence of the SC energy in omega we have
6042 C to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
6043 C To avoid underflows, first compute & store the exponents.
6044
6045         do iii=-1,1
6046
6047           x(3)=x3+iii*dwapi
6048
6049           do j=1,nlobit
6050             do k=1,3
6051               z(k)=x(k)-censc(k,j,it)
6052             enddo
6053             do k=1,3
6054               Axk=0.0D0
6055               do l=1,3
6056                 Axk=Axk+gaussc(l,k,j,it)*z(l)
6057               enddo
6058               Ax(k,j,iii)=Axk
6059             enddo
6060             expfac=0.0D0
6061             do k=1,3
6062               expfac=expfac+Ax(k,j,iii)*z(k)
6063             enddo
6064             contr(j,iii)=expfac
6065           enddo ! j
6066
6067         enddo ! iii
6068
6069         x(3)=x3
6070 C As in the case of ebend, we want to avoid underflows in exponentiation and
6071 C subsequent NaNs and INFs in energy calculation.
6072 C Find the largest exponent
6073         emin=contr(1,-1)
6074         do iii=-1,1
6075           do j=1,nlobit
6076             if (emin.gt.contr(j,iii)) emin=contr(j,iii)
6077           enddo
6078         enddo
6079         emin=0.5D0*emin
6080 cd      print *,'it=',it,' emin=',emin
6081
6082 C Compute the contribution to SC energy and derivatives
6083         do iii=-1,1
6084
6085           do j=1,nlobit
6086 #ifdef OSF
6087             adexp=bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin
6088             if(adexp.ne.adexp) adexp=1.0
6089             expfac=dexp(adexp)
6090 #else
6091             expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin)
6092 #endif
6093 cd          print *,'j=',j,' expfac=',expfac
6094             escloc_i=escloc_i+expfac
6095             do k=1,3
6096               dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
6097             enddo
6098             if (mixed) then
6099               do k=1,3,2
6100                 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii)
6101      &            +gaussc(k,2,j,it))*expfac
6102               enddo
6103             endif
6104           enddo
6105
6106         enddo ! iii
6107
6108         dersc(1)=dersc(1)/cos(theti)**2
6109         ddersc(1)=ddersc(1)/cos(theti)**2
6110         ddersc(3)=ddersc(3)
6111
6112         escloci=-(dlog(escloc_i)-emin)
6113         do j=1,3
6114           dersc(j)=dersc(j)/escloc_i
6115         enddo
6116         if (mixed) then
6117           do j=1,3,2
6118             ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
6119           enddo
6120         endif
6121       return
6122       end
6123 C------------------------------------------------------------------------------
6124       subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
6125       implicit real*8 (a-h,o-z)
6126       include 'DIMENSIONS'
6127       include 'COMMON.GEO'
6128       include 'COMMON.LOCAL'
6129       include 'COMMON.IOUNITS'
6130       common /sccalc/ time11,time12,time112,theti,it,nlobit
6131       double precision x(3),z(3),Ax(3,maxlob),dersc(3)
6132       double precision contr(maxlob)
6133       logical mixed
6134
6135       escloc_i=0.0D0
6136
6137       do j=1,3
6138         dersc(j)=0.0D0
6139       enddo
6140
6141       do j=1,nlobit
6142         do k=1,2
6143           z(k)=x(k)-censc(k,j,it)
6144         enddo
6145         z(3)=dwapi
6146         do k=1,3
6147           Axk=0.0D0
6148           do l=1,3
6149             Axk=Axk+gaussc(l,k,j,it)*z(l)
6150           enddo
6151           Ax(k,j)=Axk
6152         enddo
6153         expfac=0.0D0
6154         do k=1,3
6155           expfac=expfac+Ax(k,j)*z(k)
6156         enddo
6157         contr(j)=expfac
6158       enddo ! j
6159
6160 C As in the case of ebend, we want to avoid underflows in exponentiation and
6161 C subsequent NaNs and INFs in energy calculation.
6162 C Find the largest exponent
6163       emin=contr(1)
6164       do j=1,nlobit
6165         if (emin.gt.contr(j)) emin=contr(j)
6166       enddo
6167       emin=0.5D0*emin
6168
6169 C Compute the contribution to SC energy and derivatives
6170
6171       dersc12=0.0d0
6172       do j=1,nlobit
6173         expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j)+emin)
6174         escloc_i=escloc_i+expfac
6175         do k=1,2
6176           dersc(k)=dersc(k)+Ax(k,j)*expfac
6177         enddo
6178         if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j)
6179      &            +gaussc(1,2,j,it))*expfac
6180         dersc(3)=0.0d0
6181       enddo
6182
6183       dersc(1)=dersc(1)/cos(theti)**2
6184       dersc12=dersc12/cos(theti)**2
6185       escloci=-(dlog(escloc_i)-emin)
6186       do j=1,2
6187         dersc(j)=dersc(j)/escloc_i
6188       enddo
6189       if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
6190       return
6191       end
6192 #else
6193 c----------------------------------------------------------------------------------
6194       subroutine esc(escloc)
6195 C Calculate the local energy of a side chain and its derivatives in the
6196 C corresponding virtual-bond valence angles THETA and the spherical angles
6197 C ALPHA and OMEGA derived from AM1 all-atom calculations.
6198 C added by Urszula Kozlowska. 07/11/2007
6199 C
6200       implicit real*8 (a-h,o-z)
6201       include 'DIMENSIONS'
6202       include 'COMMON.GEO'
6203       include 'COMMON.LOCAL'
6204       include 'COMMON.VAR'
6205       include 'COMMON.SCROT'
6206       include 'COMMON.INTERACT'
6207       include 'COMMON.DERIV'
6208       include 'COMMON.CHAIN'
6209       include 'COMMON.IOUNITS'
6210       include 'COMMON.NAMES'
6211       include 'COMMON.FFIELD'
6212       include 'COMMON.CONTROL'
6213       include 'COMMON.VECTORS'
6214       double precision x_prime(3),y_prime(3),z_prime(3)
6215      &    , sumene,dsc_i,dp2_i,x(65),
6216      &     xx,yy,zz,sumene1,sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6,
6217      &    de_dxx,de_dyy,de_dzz,de_dt
6218       double precision s1_t,s1_6_t,s2_t,s2_6_t
6219       double precision
6220      & dXX_Ci1(3),dYY_Ci1(3),dZZ_Ci1(3),dXX_Ci(3),
6221      & dYY_Ci(3),dZZ_Ci(3),dXX_XYZ(3),dYY_XYZ(3),dZZ_XYZ(3),
6222      & dt_dCi(3),dt_dCi1(3)
6223       common /sccalc/ time11,time12,time112,theti,it,nlobit
6224       delta=0.02d0*pi
6225       escloc=0.0D0
6226       do i=loc_start,loc_end
6227         if (itype(i).eq.ntyp1) cycle
6228         costtab(i+1) =dcos(theta(i+1))
6229         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
6230         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
6231         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
6232         cosfac2=0.5d0/(1.0d0+costtab(i+1))
6233         cosfac=dsqrt(cosfac2)
6234         sinfac2=0.5d0/(1.0d0-costtab(i+1))
6235         sinfac=dsqrt(sinfac2)
6236         it=iabs(itype(i))
6237         if (it.eq.10) goto 1
6238 c
6239 C  Compute the axes of tghe local cartesian coordinates system; store in
6240 c   x_prime, y_prime and z_prime
6241 c
6242         do j=1,3
6243           x_prime(j) = 0.00
6244           y_prime(j) = 0.00
6245           z_prime(j) = 0.00
6246         enddo
6247 C        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
6248 C     &   dc_norm(3,i+nres)
6249         do j = 1,3
6250           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
6251           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
6252         enddo
6253         do j = 1,3
6254           z_prime(j) = -uz(j,i-1)*dsign(1.0d0,dfloat(itype(i)))
6255         enddo
6256 c       write (2,*) "i",i
6257 c       write (2,*) "x_prime",(x_prime(j),j=1,3)
6258 c       write (2,*) "y_prime",(y_prime(j),j=1,3)
6259 c       write (2,*) "z_prime",(z_prime(j),j=1,3)
6260 c       write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
6261 c      & " xy",scalar(x_prime(1),y_prime(1)),
6262 c      & " xz",scalar(x_prime(1),z_prime(1)),
6263 c      & " yy",scalar(y_prime(1),y_prime(1)),
6264 c      & " yz",scalar(y_prime(1),z_prime(1)),
6265 c      & " zz",scalar(z_prime(1),z_prime(1))
6266 c
6267 C Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
6268 C to local coordinate system. Store in xx, yy, zz.
6269 c
6270         xx=0.0d0
6271         yy=0.0d0
6272         zz=0.0d0
6273         do j = 1,3
6274           xx = xx + x_prime(j)*dc_norm(j,i+nres)
6275           yy = yy + y_prime(j)*dc_norm(j,i+nres)
6276           zz = zz + z_prime(j)*dc_norm(j,i+nres)
6277         enddo
6278
6279         xxtab(i)=xx
6280         yytab(i)=yy
6281         zztab(i)=zz
6282 C
6283 C Compute the energy of the ith side cbain
6284 C
6285 c        write (2,*) "xx",xx," yy",yy," zz",zz
6286         it=iabs(itype(i))
6287         do j = 1,65
6288           x(j) = sc_parmin(j,it)
6289         enddo
6290 #ifdef CHECK_COORD
6291 Cc diagnostics - remove later
6292         xx1 = dcos(alph(2))
6293         yy1 = dsin(alph(2))*dcos(omeg(2))
6294         zz1 = -dsign(1.0,dfloat(itype(i)))*dsin(alph(2))*dsin(omeg(2))
6295         write(2,'(3f8.1,3f9.3,1x,3f9.3)')
6296      &    alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,
6297      &    xx1,yy1,zz1
6298 C,"  --- ", xx_w,yy_w,zz_w
6299 c end diagnostics
6300 #endif
6301         sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
6302      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
6303      &   + x(10)*yy*zz
6304         sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
6305      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
6306      & + x(20)*yy*zz
6307         sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
6308      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
6309      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
6310      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
6311      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
6312      &  +x(40)*xx*yy*zz
6313         sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
6314      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
6315      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
6316      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
6317      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
6318      &  +x(60)*xx*yy*zz
6319         dsc_i   = 0.743d0+x(61)
6320         dp2_i   = 1.9d0+x(62)
6321         dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
6322      &          *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
6323         dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
6324      &          *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
6325         s1=(1+x(63))/(0.1d0 + dscp1)
6326         s1_6=(1+x(64))/(0.1d0 + dscp1**6)
6327         s2=(1+x(65))/(0.1d0 + dscp2)
6328         s2_6=(1+x(65))/(0.1d0 + dscp2**6)
6329         sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6)
6330      & + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
6331 c        write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
6332 c     &   sumene4,
6333 c     &   dscp1,dscp2,sumene
6334 c        sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6335         escloc = escloc + sumene
6336         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
6337      &     'escloc',i,sumene
6338 c        write (2,*) "i",i," escloc",sumene,escloc,it,itype(i)
6339 c     & ,zz,xx,yy
6340 c#define DEBUG
6341 #ifdef DEBUG
6342 C
6343 C This section to check the numerical derivatives of the energy of ith side
6344 C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
6345 C #define DEBUG in the code to turn it on.
6346 C
6347         write (2,*) "sumene               =",sumene
6348         aincr=1.0d-7
6349         xxsave=xx
6350         xx=xx+aincr
6351         write (2,*) xx,yy,zz
6352         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6353         de_dxx_num=(sumenep-sumene)/aincr
6354         xx=xxsave
6355         write (2,*) "xx+ sumene from enesc=",sumenep
6356         yysave=yy
6357         yy=yy+aincr
6358         write (2,*) xx,yy,zz
6359         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6360         de_dyy_num=(sumenep-sumene)/aincr
6361         yy=yysave
6362         write (2,*) "yy+ sumene from enesc=",sumenep
6363         zzsave=zz
6364         zz=zz+aincr
6365         write (2,*) xx,yy,zz
6366         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6367         de_dzz_num=(sumenep-sumene)/aincr
6368         zz=zzsave
6369         write (2,*) "zz+ sumene from enesc=",sumenep
6370         costsave=cost2tab(i+1)
6371         sintsave=sint2tab(i+1)
6372         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
6373         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
6374         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6375         de_dt_num=(sumenep-sumene)/aincr
6376         write (2,*) " t+ sumene from enesc=",sumenep
6377         cost2tab(i+1)=costsave
6378         sint2tab(i+1)=sintsave
6379 C End of diagnostics section.
6380 #endif
6381 C
6382 C Compute the gradient of esc
6383 C
6384 c        zz=zz*dsign(1.0,dfloat(itype(i)))
6385         pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
6386         pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
6387         pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
6388         pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
6389         pom_dx=dsc_i*dp2_i*cost2tab(i+1)
6390         pom_dy=dsc_i*dp2_i*sint2tab(i+1)
6391         pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
6392         pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
6393         pom1=(sumene3*sint2tab(i+1)+sumene1)
6394      &     *(pom_s1/dscp1+pom_s16*dscp1**4)
6395         pom2=(sumene4*cost2tab(i+1)+sumene2)
6396      &     *(pom_s2/dscp2+pom_s26*dscp2**4)
6397         sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
6398         sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2
6399      &  +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2)
6400      &  +x(40)*yy*zz
6401         sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
6402         sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2
6403      &  +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2)
6404      &  +x(60)*yy*zz
6405         de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6)
6406      &        +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6)
6407      &        +(pom1+pom2)*pom_dx
6408 #ifdef DEBUG
6409         write(2,*), "de_dxx = ", de_dxx,de_dxx_num,itype(i)
6410 #endif
6411 C
6412         sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
6413         sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2
6414      &  +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2)
6415      &  +x(40)*xx*zz
6416         sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
6417         sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz
6418      &  +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz
6419      &  +x(59)*zz**2 +x(60)*xx*zz
6420         de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6)
6421      &        +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6)
6422      &        +(pom1-pom2)*pom_dy
6423 #ifdef DEBUG
6424         write(2,*), "de_dyy = ", de_dyy,de_dyy_num,itype(i)
6425 #endif
6426 C
6427         de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy
6428      &  +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx
6429      &  +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6)
6430      &  +(x(4) + 2*x(7)*zz+  x(8)*xx + x(10)*yy)*(s1+s1_6)
6431      &  +(x(44)+2*x(47)*zz +x(48)*xx   +x(50)*yy  +3*x(53)*zz**2
6432      &  +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy
6433      &  +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6)
6434      &  + ( x(14) + 2*x(17)*zz+  x(18)*xx + x(20)*yy)*(s2+s2_6)
6435 #ifdef DEBUG
6436         write(2,*), "de_dzz = ", de_dzz,de_dzz_num,itype(i)
6437 #endif
6438 C
6439         de_dt =  0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6)
6440      &  -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6)
6441      &  +pom1*pom_dt1+pom2*pom_dt2
6442 #ifdef DEBUG
6443         write(2,*), "de_dt = ", de_dt,de_dt_num,itype(i)
6444 #endif
6445 c#undef DEBUG
6446 c
6447 C
6448        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
6449        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
6450        cosfac2xx=cosfac2*xx
6451        sinfac2yy=sinfac2*yy
6452        do k = 1,3
6453          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))*
6454      &      vbld_inv(i+1)
6455          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))*
6456      &      vbld_inv(i)
6457          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
6458          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
6459 c         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
6460 c     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
6461 c         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
6462 c     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
6463          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
6464          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
6465          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
6466          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
6467          dZZ_Ci1(k)=0.0d0
6468          dZZ_Ci(k)=0.0d0
6469          do j=1,3
6470            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)
6471      &     *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
6472            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)
6473      &     *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
6474          enddo
6475
6476          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
6477          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
6478          dZZ_XYZ(k)=vbld_inv(i+nres)*
6479      &   (z_prime(k)-zz*dC_norm(k,i+nres))
6480 c
6481          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
6482          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
6483        enddo
6484
6485        do k=1,3
6486          dXX_Ctab(k,i)=dXX_Ci(k)
6487          dXX_C1tab(k,i)=dXX_Ci1(k)
6488          dYY_Ctab(k,i)=dYY_Ci(k)
6489          dYY_C1tab(k,i)=dYY_Ci1(k)
6490          dZZ_Ctab(k,i)=dZZ_Ci(k)
6491          dZZ_C1tab(k,i)=dZZ_Ci1(k)
6492          dXX_XYZtab(k,i)=dXX_XYZ(k)
6493          dYY_XYZtab(k,i)=dYY_XYZ(k)
6494          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
6495        enddo
6496
6497        do k = 1,3
6498 c         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
6499 c     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
6500 c         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
6501 c     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
6502 c         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
6503 c     &    dt_dci(k)
6504 c         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
6505 c     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
6506          gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k)
6507      &    +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
6508          gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k)
6509      &    +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
6510          gsclocx(k,i)=                 de_dxx*dxx_XYZ(k)
6511      &    +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
6512        enddo
6513 c       write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
6514 c     &  (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
6515
6516 C to check gradient call subroutine check_grad
6517
6518     1 continue
6519       enddo
6520       return
6521       end
6522 c------------------------------------------------------------------------------
6523       double precision function enesc(x,xx,yy,zz,cost2,sint2)
6524       implicit none
6525       double precision x(65),xx,yy,zz,cost2,sint2,sumene1,sumene2,
6526      & sumene3,sumene4,sumene,dsc_i,dp2_i,dscp1,dscp2,s1,s1_6,s2,s2_6
6527       sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
6528      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
6529      &   + x(10)*yy*zz
6530       sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
6531      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
6532      & + x(20)*yy*zz
6533       sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
6534      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
6535      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
6536      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
6537      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
6538      &  +x(40)*xx*yy*zz
6539       sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
6540      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
6541      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
6542      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
6543      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
6544      &  +x(60)*xx*yy*zz
6545       dsc_i   = 0.743d0+x(61)
6546       dp2_i   = 1.9d0+x(62)
6547       dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
6548      &          *(xx*cost2+yy*sint2))
6549       dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
6550      &          *(xx*cost2-yy*sint2))
6551       s1=(1+x(63))/(0.1d0 + dscp1)
6552       s1_6=(1+x(64))/(0.1d0 + dscp1**6)
6553       s2=(1+x(65))/(0.1d0 + dscp2)
6554       s2_6=(1+x(65))/(0.1d0 + dscp2**6)
6555       sumene = ( sumene3*sint2 + sumene1)*(s1+s1_6)
6556      & + (sumene4*cost2 +sumene2)*(s2+s2_6)
6557       enesc=sumene
6558       return
6559       end
6560 #endif
6561 c------------------------------------------------------------------------------
6562       subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
6563 C
6564 C This procedure calculates two-body contact function g(rij) and its derivative:
6565 C
6566 C           eps0ij                                     !       x < -1
6567 C g(rij) =  esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5)  ! -1 =< x =< 1
6568 C            0                                         !       x > 1
6569 C
6570 C where x=(rij-r0ij)/delta
6571 C
6572 C rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
6573 C
6574       implicit none
6575       double precision rij,r0ij,eps0ij,fcont,fprimcont
6576       double precision x,x2,x4,delta
6577 c     delta=0.02D0*r0ij
6578 c      delta=0.2D0*r0ij
6579       x=(rij-r0ij)/delta
6580       if (x.lt.-1.0D0) then
6581         fcont=eps0ij
6582         fprimcont=0.0D0
6583       else if (x.le.1.0D0) then
6584         x2=x*x
6585         x4=x2*x2
6586         fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
6587         fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
6588       else
6589         fcont=0.0D0
6590         fprimcont=0.0D0
6591       endif
6592       return
6593       end
6594 c------------------------------------------------------------------------------
6595       subroutine splinthet(theti,delta,ss,ssder)
6596       implicit real*8 (a-h,o-z)
6597       include 'DIMENSIONS'
6598       include 'COMMON.VAR'
6599       include 'COMMON.GEO'
6600       thetup=pi-delta
6601       thetlow=delta
6602       if (theti.gt.pipol) then
6603         call gcont(theti,thetup,1.0d0,delta,ss,ssder)
6604       else
6605         call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
6606         ssder=-ssder
6607       endif
6608       return
6609       end
6610 c------------------------------------------------------------------------------
6611       subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
6612       implicit none
6613       double precision x,x0,delta,f0,f1,fprim0,f,fprim
6614       double precision ksi,ksi2,ksi3,a1,a2,a3
6615       a1=fprim0*delta/(f1-f0)
6616       a2=3.0d0-2.0d0*a1
6617       a3=a1-2.0d0
6618       ksi=(x-x0)/delta
6619       ksi2=ksi*ksi
6620       ksi3=ksi2*ksi
6621       f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
6622       fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
6623       return
6624       end
6625 c------------------------------------------------------------------------------
6626       subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
6627       implicit none
6628       double precision x,x0,delta,f0x,f1x,fprim0x,fx
6629       double precision ksi,ksi2,ksi3,a1,a2,a3
6630       ksi=(x-x0)/delta
6631       ksi2=ksi*ksi
6632       ksi3=ksi2*ksi
6633       a1=fprim0x*delta
6634       a2=3*(f1x-f0x)-2*fprim0x*delta
6635       a3=fprim0x*delta-2*(f1x-f0x)
6636       fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
6637       return
6638       end
6639 C-----------------------------------------------------------------------------
6640 #ifdef CRYST_TOR
6641 C-----------------------------------------------------------------------------
6642       subroutine etor(etors,edihcnstr)
6643       implicit real*8 (a-h,o-z)
6644       include 'DIMENSIONS'
6645       include 'COMMON.VAR'
6646       include 'COMMON.GEO'
6647       include 'COMMON.LOCAL'
6648       include 'COMMON.TORSION'
6649       include 'COMMON.INTERACT'
6650       include 'COMMON.DERIV'
6651       include 'COMMON.CHAIN'
6652       include 'COMMON.NAMES'
6653       include 'COMMON.IOUNITS'
6654       include 'COMMON.FFIELD'
6655       include 'COMMON.TORCNSTR'
6656       include 'COMMON.CONTROL'
6657       logical lprn
6658 C Set lprn=.true. for debugging
6659       lprn=.false.
6660 c      lprn=.true.
6661       etors=0.0D0
6662       do i=iphi_start,iphi_end
6663       etors_ii=0.0D0
6664         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
6665      &      .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
6666         itori=itortyp(itype(i-2))
6667         itori1=itortyp(itype(i-1))
6668         phii=phi(i)
6669         gloci=0.0D0
6670 C Proline-Proline pair is a special case...
6671         if (itori.eq.3 .and. itori1.eq.3) then
6672           if (phii.gt.-dwapi3) then
6673             cosphi=dcos(3*phii)
6674             fac=1.0D0/(1.0D0-cosphi)
6675             etorsi=v1(1,3,3)*fac
6676             etorsi=etorsi+etorsi
6677             etors=etors+etorsi-v1(1,3,3)
6678             if (energy_dec) etors_ii=etors_ii+etorsi-v1(1,3,3)
6679             gloci=gloci-3*fac*etorsi*dsin(3*phii)
6680           endif
6681           do j=1,3
6682             v1ij=v1(j+1,itori,itori1)
6683             v2ij=v2(j+1,itori,itori1)
6684             cosphi=dcos(j*phii)
6685             sinphi=dsin(j*phii)
6686             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
6687             if (energy_dec) etors_ii=etors_ii+
6688      &                              v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
6689             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
6690           enddo
6691         else
6692           do j=1,nterm_old
6693             v1ij=v1(j,itori,itori1)
6694             v2ij=v2(j,itori,itori1)
6695             cosphi=dcos(j*phii)
6696             sinphi=dsin(j*phii)
6697             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
6698             if (energy_dec) etors_ii=etors_ii+
6699      &                  v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
6700             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
6701           enddo
6702         endif
6703         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
6704              'etor',i,etors_ii
6705         if (lprn)
6706      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
6707      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
6708      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
6709         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
6710 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
6711       enddo
6712 ! 6/20/98 - dihedral angle constraints
6713       edihcnstr=0.0d0
6714       do i=1,ndih_constr
6715         itori=idih_constr(i)
6716         phii=phi(itori)
6717         difi=phii-phi0(i)
6718         if (difi.gt.drange(i)) then
6719           difi=difi-drange(i)
6720           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
6721           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
6722         else if (difi.lt.-drange(i)) then
6723           difi=difi+drange(i)
6724           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
6725           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
6726         endif
6727 !        write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii,
6728 !     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
6729       enddo
6730 !      write (iout,*) 'edihcnstr',edihcnstr
6731       return
6732       end
6733 c------------------------------------------------------------------------------
6734 c LICZENIE WIEZOW Z ROWNANIA ENERGII MODELLERA
6735       subroutine e_modeller(ehomology_constr)
6736       ehomology_constr=0.0d0
6737       write (iout,*) "!!!!!UWAGA, JESTEM W DZIWNEJ PETLI, TEST!!!!!"
6738       return
6739       end
6740 C !!!!!!!! NIE CZYTANE !!!!!!!!!!!
6741
6742 c------------------------------------------------------------------------------
6743       subroutine etor_d(etors_d)
6744       etors_d=0.0d0
6745       return
6746       end
6747 c----------------------------------------------------------------------------
6748 #else
6749       subroutine etor(etors,edihcnstr)
6750       implicit real*8 (a-h,o-z)
6751       include 'DIMENSIONS'
6752       include 'COMMON.VAR'
6753       include 'COMMON.GEO'
6754       include 'COMMON.LOCAL'
6755       include 'COMMON.TORSION'
6756       include 'COMMON.INTERACT'
6757       include 'COMMON.DERIV'
6758       include 'COMMON.CHAIN'
6759       include 'COMMON.NAMES'
6760       include 'COMMON.IOUNITS'
6761       include 'COMMON.FFIELD'
6762       include 'COMMON.TORCNSTR'
6763       include 'COMMON.CONTROL'
6764       logical lprn
6765 C Set lprn=.true. for debugging
6766       lprn=.false.
6767 c     lprn=.true.
6768       etors=0.0D0
6769       do i=iphi_start,iphi_end
6770 C ANY TWO ARE DUMMY ATOMS in row CYCLE
6771 c        if (((itype(i-3).eq.ntyp1).and.(itype(i-2).eq.ntyp1)).or.
6772 c     &      ((itype(i-2).eq.ntyp1).and.(itype(i-1).eq.ntyp1))  .or.
6773 c     &      ((itype(i-1).eq.ntyp1).and.(itype(i).eq.ntyp1))) cycle
6774         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
6775      &      .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
6776 C In current verion the ALL DUMMY ATOM POTENTIALS ARE OFF
6777 C For introducing the NH3+ and COO- group please check the etor_d for reference
6778 C and guidance
6779         etors_ii=0.0D0
6780          if (iabs(itype(i)).eq.20) then
6781          iblock=2
6782          else
6783          iblock=1
6784          endif
6785         itori=itortyp(itype(i-2))
6786         itori1=itortyp(itype(i-1))
6787         phii=phi(i)
6788         gloci=0.0D0
6789 C Regular cosine and sine terms
6790         do j=1,nterm(itori,itori1,iblock)
6791           v1ij=v1(j,itori,itori1,iblock)
6792           v2ij=v2(j,itori,itori1,iblock)
6793           cosphi=dcos(j*phii)
6794           sinphi=dsin(j*phii)
6795           etors=etors+v1ij*cosphi+v2ij*sinphi
6796           if (energy_dec) etors_ii=etors_ii+
6797      &                v1ij*cosphi+v2ij*sinphi
6798           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
6799         enddo
6800 C Lorentz terms
6801 C                         v1
6802 C  E = SUM ----------------------------------- - v1
6803 C          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
6804 C
6805         cosphi=dcos(0.5d0*phii)
6806         sinphi=dsin(0.5d0*phii)
6807         do j=1,nlor(itori,itori1,iblock)
6808           vl1ij=vlor1(j,itori,itori1)
6809           vl2ij=vlor2(j,itori,itori1)
6810           vl3ij=vlor3(j,itori,itori1)
6811           pom=vl2ij*cosphi+vl3ij*sinphi
6812           pom1=1.0d0/(pom*pom+1.0d0)
6813           etors=etors+vl1ij*pom1
6814           if (energy_dec) etors_ii=etors_ii+
6815      &                vl1ij*pom1
6816           pom=-pom*pom1*pom1
6817           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
6818         enddo
6819 C Subtract the constant term
6820         etors=etors-v0(itori,itori1,iblock)
6821           if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
6822      &         'etor',i,etors_ii-v0(itori,itori1,iblock)
6823         if (lprn)
6824      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
6825      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
6826      &  (v1(j,itori,itori1,iblock),j=1,6),
6827      &  (v2(j,itori,itori1,iblock),j=1,6)
6828         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
6829 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
6830       enddo
6831 ! 6/20/98 - dihedral angle constraints
6832       edihcnstr=0.0d0
6833 c      do i=1,ndih_constr
6834       do i=idihconstr_start,idihconstr_end
6835         itori=idih_constr(i)
6836         phii=phi(itori)
6837         difi=pinorm(phii-phi0(i))
6838         if (difi.gt.drange(i)) then
6839           difi=difi-drange(i)
6840           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
6841           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
6842         else if (difi.lt.-drange(i)) then
6843           difi=difi+drange(i)
6844           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
6845           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
6846         else
6847           difi=0.0
6848         endif
6849 cd        write (iout,'(2i5,4f8.3,2e14.5)') i,itori,rad2deg*phii,
6850 cd     &    rad2deg*phi0(i),  rad2deg*drange(i),
6851 cd     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
6852       enddo
6853 cd       write (iout,*) 'edihcnstr',edihcnstr
6854       return
6855       end
6856 c----------------------------------------------------------------------------
6857 c MODELLER restraint function
6858       subroutine e_modeller(ehomology_constr)
6859       implicit real*8 (a-h,o-z)
6860       include 'DIMENSIONS'
6861
6862       integer nnn, i, j, k, ki, irec, l
6863       integer katy, odleglosci, test7
6864       real*8 odleg, odleg2, odleg3, kat, kat2, kat3, gdih(max_template)
6865       real*8 Eval,Erot
6866       real*8 distance(max_template),distancek(max_template),
6867      &    min_odl,godl(max_template),dih_diff(max_template)
6868
6869 c
6870 c     FP - 30/10/2014 Temporary specifications for homology restraints
6871 c
6872       double precision utheta_i,gutheta_i,sum_gtheta,sum_sgtheta,
6873      &                 sgtheta
6874       double precision, dimension (maxres) :: guscdiff,usc_diff
6875       double precision, dimension (max_template) ::
6876      &           gtheta,dscdiff,uscdiffk,guscdiff2,guscdiff3,
6877      &           theta_diff
6878 c
6879
6880       include 'COMMON.SBRIDGE'
6881       include 'COMMON.CHAIN'
6882       include 'COMMON.GEO'
6883       include 'COMMON.DERIV'
6884       include 'COMMON.LOCAL'
6885       include 'COMMON.INTERACT'
6886       include 'COMMON.VAR'
6887       include 'COMMON.IOUNITS'
6888       include 'COMMON.MD'
6889       include 'COMMON.CONTROL'
6890 c
6891 c     From subroutine Econstr_back
6892 c
6893       include 'COMMON.NAMES'
6894       include 'COMMON.TIME1'
6895 c
6896
6897
6898       do i=1,19
6899         distancek(i)=9999999.9
6900       enddo
6901
6902
6903       odleg=0.0d0
6904
6905 c Pseudo-energy and gradient from homology restraints (MODELLER-like
6906 c function)
6907 C AL 5/2/14 - Introduce list of restraints
6908 c     write(iout,*) "waga_theta",waga_theta,"waga_d",waga_d
6909 #ifdef DEBUG
6910       write(iout,*) "------- dist restrs start -------"
6911 #endif
6912       do ii = link_start_homo,link_end_homo
6913          i = ires_homo(ii)
6914          j = jres_homo(ii)
6915          dij=dist(i,j)
6916 c        write (iout,*) "dij(",i,j,") =",dij
6917          do k=1,constr_homology
6918 c           write(iout,*) ii,k,i,j,l_homo(k,ii),dij,odl(k,ii)
6919            if(.not.l_homo(k,ii)) cycle
6920            distance(k)=odl(k,ii)-dij
6921 c          write (iout,*) "distance(",k,") =",distance(k)
6922 c
6923 c          For Gaussian-type Urestr
6924 c
6925            distancek(k)=0.5d0*distance(k)**2*sigma_odl(k,ii) ! waga_dist rmvd from Gaussian argument
6926 c          write (iout,*) "sigma_odl(",k,ii,") =",sigma_odl(k,ii)
6927 c          write (iout,*) "distancek(",k,") =",distancek(k)
6928 c          distancek(k)=0.5d0*waga_dist*distance(k)**2*sigma_odl(k,ii)
6929 c
6930 c          For Lorentzian-type Urestr
6931 c
6932            if (waga_dist.lt.0.0d0) then
6933               sigma_odlir(k,ii)=dsqrt(1/sigma_odl(k,ii))
6934               distancek(k)=distance(k)**2/(sigma_odlir(k,ii)*
6935      &                     (distance(k)**2+sigma_odlir(k,ii)**2))
6936            endif
6937          enddo
6938
6939 c         min_odl=minval(distancek)
6940          do kk=1,constr_homology
6941           if(l_homo(kk,ii)) then
6942             min_odl=distancek(kk)
6943             exit
6944           endif
6945          enddo
6946          do kk=1,constr_homology
6947           if(l_homo(kk,ii) .and. distancek(kk).lt.min_odl)
6948      &              min_odl=distancek(kk)
6949          enddo
6950
6951 c        write (iout,* )"min_odl",min_odl
6952 #ifdef DEBUG
6953          write (iout,*) "ij dij",i,j,dij
6954          write (iout,*) "distance",(distance(k),k=1,constr_homology)
6955          write (iout,*) "distancek",(distancek(k),k=1,constr_homology)
6956          write (iout,* )"min_odl",min_odl
6957 #endif
6958          odleg2=0.0d0
6959          do k=1,constr_homology
6960 c Nie wiem po co to liczycie jeszcze raz!
6961 c            odleg3=-waga_dist(iset)*((distance(i,j,k)**2)/
6962 c     &              (2*(sigma_odl(i,j,k))**2))
6963            if(.not.l_homo(k,ii)) cycle
6964            if (waga_dist.ge.0.0d0) then
6965 c
6966 c          For Gaussian-type Urestr
6967 c
6968             godl(k)=dexp(-distancek(k)+min_odl)
6969             odleg2=odleg2+godl(k)
6970 c
6971 c          For Lorentzian-type Urestr
6972 c
6973            else
6974             odleg2=odleg2+distancek(k)
6975            endif
6976
6977 ccc       write(iout,779) i,j,k, "odleg2=",odleg2, "odleg3=", odleg3,
6978 ccc     & "dEXP(odleg3)=", dEXP(odleg3),"distance(i,j,k)^2=",
6979 ccc     & distance(i,j,k)**2, "dist(i+1,j+1)=", dist(i+1,j+1),
6980 ccc     & "sigma_odl(i,j,k)=", sigma_odl(i,j,k)
6981
6982          enddo
6983 c        write (iout,*) "godl",(godl(k),k=1,constr_homology) ! exponents
6984 c        write (iout,*) "ii i j",ii,i,j," odleg2",odleg2 ! sum of exps
6985 #ifdef DEBUG
6986          write (iout,*) "godl",(godl(k),k=1,constr_homology) ! exponents
6987          write (iout,*) "ii i j",ii,i,j," odleg2",odleg2 ! sum of exps
6988 #endif
6989            if (waga_dist.ge.0.0d0) then
6990 c
6991 c          For Gaussian-type Urestr
6992 c
6993               odleg=odleg-dLOG(odleg2/constr_homology)+min_odl
6994 c
6995 c          For Lorentzian-type Urestr
6996 c
6997            else
6998               odleg=odleg+odleg2/constr_homology
6999            endif
7000 c
7001 c        write (iout,*) "odleg",odleg ! sum of -ln-s
7002 c Gradient
7003 c
7004 c          For Gaussian-type Urestr
7005 c
7006          if (waga_dist.ge.0.0d0) sum_godl=odleg2
7007          sum_sgodl=0.0d0
7008          do k=1,constr_homology
7009 c            godl=dexp(((-(distance(i,j,k)**2)/(2*(sigma_odl(i,j,k))**2))
7010 c     &           *waga_dist)+min_odl
7011 c          sgodl=-godl(k)*distance(k)*sigma_odl(k,ii)*waga_dist
7012 c
7013          if(.not.l_homo(k,ii)) cycle
7014          if (waga_dist.ge.0.0d0) then
7015 c          For Gaussian-type Urestr
7016 c
7017            sgodl=-godl(k)*distance(k)*sigma_odl(k,ii) ! waga_dist rmvd
7018 c
7019 c          For Lorentzian-type Urestr
7020 c
7021          else
7022            sgodl=-2*sigma_odlir(k,ii)*(distance(k)/(distance(k)**2+
7023      &           sigma_odlir(k,ii)**2)**2)
7024          endif
7025            sum_sgodl=sum_sgodl+sgodl
7026
7027 c            sgodl2=sgodl2+sgodl
7028 c      write(iout,*) i, j, k, distance(i,j,k), "W GRADIENCIE1"
7029 c      write(iout,*) "constr_homology=",constr_homology
7030 c      write(iout,*) i, j, k, "TEST K"
7031          enddo
7032          if (waga_dist.ge.0.0d0) then
7033 c
7034 c          For Gaussian-type Urestr
7035 c
7036             grad_odl3=waga_homology(iset)*waga_dist
7037      &                *sum_sgodl/(sum_godl*dij)
7038 c
7039 c          For Lorentzian-type Urestr
7040 c
7041          else
7042 c Original grad expr modified by analogy w Gaussian-type Urestr grad
7043 c           grad_odl3=-waga_homology(iset)*waga_dist*sum_sgodl
7044             grad_odl3=-waga_homology(iset)*waga_dist*
7045      &                sum_sgodl/(constr_homology*dij)
7046          endif
7047 c
7048 c        grad_odl3=sum_sgodl/(sum_godl*dij)
7049
7050
7051 c      write(iout,*) i, j, k, distance(i,j,k), "W GRADIENCIE2"
7052 c      write(iout,*) (distance(i,j,k)**2), (2*(sigma_odl(i,j,k))**2),
7053 c     &              (-(distance(i,j,k)**2)/(2*(sigma_odl(i,j,k))**2))
7054
7055 ccc      write(iout,*) godl, sgodl, grad_odl3
7056
7057 c          grad_odl=grad_odl+grad_odl3
7058
7059          do jik=1,3
7060             ggodl=grad_odl3*(c(jik,i)-c(jik,j))
7061 ccc      write(iout,*) c(jik,i+1), c(jik,j+1), (c(jik,i+1)-c(jik,j+1))
7062 ccc      write(iout,746) "GRAD_ODL_1", i, j, jik, ggodl,
7063 ccc     &              ghpbc(jik,i+1), ghpbc(jik,j+1)
7064             ghpbc(jik,i)=ghpbc(jik,i)+ggodl
7065             ghpbc(jik,j)=ghpbc(jik,j)-ggodl
7066 ccc      write(iout,746) "GRAD_ODL_2", i, j, jik, ggodl,
7067 ccc     &              ghpbc(jik,i+1), ghpbc(jik,j+1)
7068 c         if (i.eq.25.and.j.eq.27) then
7069 c         write(iout,*) "jik",jik,"i",i,"j",j
7070 c         write(iout,*) "sum_sgodl",sum_sgodl,"sgodl",sgodl
7071 c         write(iout,*) "grad_odl3",grad_odl3
7072 c         write(iout,*) "c(",jik,i,")",c(jik,i),"c(",jik,j,")",c(jik,j)
7073 c         write(iout,*) "ggodl",ggodl
7074 c         write(iout,*) "ghpbc(",jik,i,")",
7075 c     &                 ghpbc(jik,i),"ghpbc(",jik,j,")",
7076 c     &                 ghpbc(jik,j)
7077 c         endif
7078          enddo
7079 ccc       write(iout,778)"TEST: odleg2=", odleg2, "DLOG(odleg2)=",
7080 ccc     & dLOG(odleg2),"-odleg=", -odleg
7081
7082       enddo ! ii-loop for dist
7083 #ifdef DEBUG
7084       write(iout,*) "------- dist restrs end -------"
7085 c     if (waga_angle.eq.1.0d0 .or. waga_theta.eq.1.0d0 .or.
7086 c    &     waga_d.eq.1.0d0) call sum_gradient
7087 #endif
7088 c Pseudo-energy and gradient from dihedral-angle restraints from
7089 c homology templates
7090 c      write (iout,*) "End of distance loop"
7091 c      call flush(iout)
7092       kat=0.0d0
7093 c      write (iout,*) idihconstr_start_homo,idihconstr_end_homo
7094 #ifdef DEBUG
7095       write(iout,*) "------- dih restrs start -------"
7096       do i=idihconstr_start_homo,idihconstr_end_homo
7097         write (iout,*) "gloc_init(",i,icg,")",gloc(i,icg)
7098       enddo
7099 #endif
7100       do i=idihconstr_start_homo,idihconstr_end_homo
7101         kat2=0.0d0
7102 c        betai=beta(i,i+1,i+2,i+3)
7103         betai = phi(i)
7104 c       write (iout,*) "betai =",betai
7105         do k=1,constr_homology
7106           dih_diff(k)=pinorm(dih(k,i)-betai)
7107 cd          write (iout,'(a8,2i4,2f15.8)') "dih_diff",i,k,dih_diff(k)
7108 cd     &                  ,sigma_dih(k,i)
7109 c          if (dih_diff(i,k).gt.3.14159) dih_diff(i,k)=
7110 c     &                                   -(6.28318-dih_diff(i,k))
7111 c          if (dih_diff(i,k).lt.-3.14159) dih_diff(i,k)=
7112 c     &                                   6.28318+dih_diff(i,k)
7113
7114           kat3=-0.5d0*dih_diff(k)**2*sigma_dih(k,i) ! waga_angle rmvd from Gaussian argument
7115 c         kat3=-0.5d0*waga_angle*dih_diff(k)**2*sigma_dih(k,i)
7116           gdih(k)=dexp(kat3)
7117           kat2=kat2+gdih(k)
7118 c          write(iout,*) "kat2=", kat2, "exp(kat3)=", exp(kat3)
7119 c          write(*,*)""
7120         enddo
7121 c       write (iout,*) "gdih",(gdih(k),k=1,constr_homology) ! exps
7122 c       write (iout,*) "i",i," betai",betai," kat2",kat2 ! sum of exps
7123 #ifdef DEBUG
7124         write (iout,*) "i",i," betai",betai," kat2",kat2
7125         write (iout,*) "gdih",(gdih(k),k=1,constr_homology)
7126 #endif
7127         if (kat2.le.1.0d-14) cycle
7128         kat=kat-dLOG(kat2/constr_homology)
7129 c       write (iout,*) "kat",kat ! sum of -ln-s
7130
7131 ccc       write(iout,778)"TEST: kat2=", kat2, "DLOG(kat2)=",
7132 ccc     & dLOG(kat2), "-kat=", -kat
7133
7134 c ----------------------------------------------------------------------
7135 c Gradient
7136 c ----------------------------------------------------------------------
7137
7138         sum_gdih=kat2
7139         sum_sgdih=0.0d0
7140         do k=1,constr_homology
7141           sgdih=-gdih(k)*dih_diff(k)*sigma_dih(k,i)  ! waga_angle rmvd
7142 c         sgdih=-gdih(k)*dih_diff(k)*sigma_dih(k,i)*waga_angle
7143           sum_sgdih=sum_sgdih+sgdih
7144         enddo
7145 c       grad_dih3=sum_sgdih/sum_gdih
7146         grad_dih3=waga_homology(iset)*waga_angle*sum_sgdih/sum_gdih
7147
7148 c      write(iout,*)i,k,gdih,sgdih,beta(i+1,i+2,i+3,i+4),grad_dih3
7149 ccc      write(iout,747) "GRAD_KAT_1", i, nphi, icg, grad_dih3,
7150 ccc     & gloc(nphi+i-3,icg)
7151         gloc(i-3,icg)=gloc(i-3,icg)+grad_dih3
7152 c        if (i.eq.25) then
7153 c        write(iout,*) "i",i,"icg",icg,"gloc(",i,icg,")",gloc(i,icg)
7154 c        endif
7155 ccc      write(iout,747) "GRAD_KAT_2", i, nphi, icg, grad_dih3,
7156 ccc     & gloc(nphi+i-3,icg)
7157
7158       enddo ! i-loop for dih
7159 #ifdef DEBUG
7160       write(iout,*) "------- dih restrs end -------"
7161 #endif
7162
7163 c Pseudo-energy and gradient for theta angle restraints from
7164 c homology templates
7165 c FP 01/15 - inserted from econstr_local_test.F, loop structure
7166 c adapted
7167
7168 c
7169 c     For constr_homology reference structures (FP)
7170 c
7171 c     Uconst_back_tot=0.0d0
7172       Eval=0.0d0
7173       Erot=0.0d0
7174 c     Econstr_back legacy
7175       do i=1,nres
7176 c     do i=ithet_start,ithet_end
7177        dutheta(i)=0.0d0
7178 c     enddo
7179 c     do i=loc_start,loc_end
7180         do j=1,3
7181           duscdiff(j,i)=0.0d0
7182           duscdiffx(j,i)=0.0d0
7183         enddo
7184       enddo
7185 c
7186 c     do iref=1,nref
7187 c     write (iout,*) "ithet_start =",ithet_start,"ithet_end =",ithet_end
7188 c     write (iout,*) "waga_theta",waga_theta
7189       if (waga_theta.gt.0.0d0) then
7190 #ifdef DEBUG
7191       write (iout,*) "usampl",usampl
7192       write(iout,*) "------- theta restrs start -------"
7193 c     do i=ithet_start,ithet_end
7194 c       write (iout,*) "gloc_init(",nphi+i,icg,")",gloc(nphi+i,icg)
7195 c     enddo
7196 #endif
7197 c     write (iout,*) "maxres",maxres,"nres",nres
7198
7199       do i=ithet_start,ithet_end
7200 c
7201 c     do i=1,nfrag_back
7202 c       ii = ifrag_back(2,i,iset)-ifrag_back(1,i,iset)
7203 c
7204 c Deviation of theta angles wrt constr_homology ref structures
7205 c
7206         utheta_i=0.0d0 ! argument of Gaussian for single k
7207         gutheta_i=0.0d0 ! Sum of Gaussians over constr_homology ref structures
7208 c       do j=ifrag_back(1,i,iset)+2,ifrag_back(2,i,iset) ! original loop
7209 c       over residues in a fragment
7210 c       write (iout,*) "theta(",i,")=",theta(i)
7211         do k=1,constr_homology
7212 c
7213 c         dtheta_i=theta(j)-thetaref(j,iref)
7214 c         dtheta_i=thetaref(k,i)-theta(i) ! original form without indexing
7215           theta_diff(k)=thetatpl(k,i)-theta(i)
7216 cd          write (iout,'(a8,2i4,2f15.8)') "theta_diff",i,k,theta_diff(k)
7217 cd     &                  ,sigma_theta(k,i)
7218
7219 c
7220           utheta_i=-0.5d0*theta_diff(k)**2*sigma_theta(k,i) ! waga_theta rmvd from Gaussian argument
7221 c         utheta_i=-0.5d0*waga_theta*theta_diff(k)**2*sigma_theta(k,i) ! waga_theta?
7222           gtheta(k)=dexp(utheta_i) ! + min_utheta_i?
7223           gutheta_i=gutheta_i+dexp(utheta_i)   ! Sum of Gaussians (pk)
7224 c         Gradient for single Gaussian restraint in subr Econstr_back
7225 c         dutheta(j-2)=dutheta(j-2)+wfrag_back(1,i,iset)*dtheta_i/(ii-1)
7226 c
7227         enddo
7228 c       write (iout,*) "gtheta",(gtheta(k),k=1,constr_homology) ! exps
7229 c       write (iout,*) "i",i," gutheta_i",gutheta_i ! sum of exps
7230
7231 c
7232 c         Gradient for multiple Gaussian restraint
7233         sum_gtheta=gutheta_i
7234         sum_sgtheta=0.0d0
7235         do k=1,constr_homology
7236 c        New generalized expr for multiple Gaussian from Econstr_back
7237          sgtheta=-gtheta(k)*theta_diff(k)*sigma_theta(k,i) ! waga_theta rmvd
7238 c
7239 c        sgtheta=-gtheta(k)*theta_diff(k)*sigma_theta(k,i)*waga_theta ! right functional form?
7240           sum_sgtheta=sum_sgtheta+sgtheta ! cum variable
7241         enddo
7242 c       Final value of gradient using same var as in Econstr_back
7243         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)
7244      &      +sum_sgtheta/sum_gtheta*waga_theta
7245      &               *waga_homology(iset)
7246 c        dutheta(i-2)=sum_sgtheta/sum_gtheta*waga_theta
7247 c     &               *waga_homology(iset)
7248 c       dutheta(i)=sum_sgtheta/sum_gtheta
7249 c
7250 c       Uconst_back=Uconst_back+waga_theta*utheta(i) ! waga_theta added as weight
7251         Eval=Eval-dLOG(gutheta_i/constr_homology)
7252 c       write (iout,*) "utheta(",i,")=",utheta(i) ! -ln of sum of exps
7253 c       write (iout,*) "Uconst_back",Uconst_back ! sum of -ln-s
7254 c       Uconst_back=Uconst_back+utheta(i)
7255       enddo ! (i-loop for theta)
7256 #ifdef DEBUG
7257       write(iout,*) "------- theta restrs end -------"
7258 #endif
7259       endif
7260 c
7261 c Deviation of local SC geometry
7262 c
7263 c Separation of two i-loops (instructed by AL - 11/3/2014)
7264 c
7265 c     write (iout,*) "loc_start =",loc_start,"loc_end =",loc_end
7266 c     write (iout,*) "waga_d",waga_d
7267
7268 #ifdef DEBUG
7269       write(iout,*) "------- SC restrs start -------"
7270       write (iout,*) "Initial duscdiff,duscdiffx"
7271       do i=loc_start,loc_end
7272         write (iout,*) i,(duscdiff(jik,i),jik=1,3),
7273      &                 (duscdiffx(jik,i),jik=1,3)
7274       enddo
7275 #endif
7276       do i=loc_start,loc_end
7277         usc_diff_i=0.0d0 ! argument of Gaussian for single k
7278         guscdiff(i)=0.0d0 ! Sum of Gaussians over constr_homology ref structures
7279 c       do j=ifrag_back(1,i,iset)+1,ifrag_back(2,i,iset)-1 ! Econstr_back legacy
7280 c       write(iout,*) "xxtab, yytab, zztab"
7281 c       write(iout,'(i5,3f8.2)') i,xxtab(i),yytab(i),zztab(i)
7282         do k=1,constr_homology
7283 c
7284           dxx=-xxtpl(k,i)+xxtab(i) ! Diff b/w x component of ith SC vector in model and kth ref str?
7285 c                                    Original sign inverted for calc of gradients (s. Econstr_back)
7286           dyy=-yytpl(k,i)+yytab(i) ! ibid y
7287           dzz=-zztpl(k,i)+zztab(i) ! ibid z
7288 c         write(iout,*) "dxx, dyy, dzz"
7289 cd          write(iout,'(2i5,4f8.2)') k,i,dxx,dyy,dzz,sigma_d(k,i)
7290 c
7291           usc_diff_i=-0.5d0*(dxx**2+dyy**2+dzz**2)*sigma_d(k,i)  ! waga_d rmvd from Gaussian argument
7292 c         usc_diff(i)=-0.5d0*waga_d*(dxx**2+dyy**2+dzz**2)*sigma_d(k,i) ! waga_d?
7293 c         uscdiffk(k)=usc_diff(i)
7294           guscdiff2(k)=dexp(usc_diff_i) ! without min_scdiff
7295           guscdiff(i)=guscdiff(i)+dexp(usc_diff_i)   !Sum of Gaussians (pk)
7296 c          write (iout,'(i5,6f10.5)') j,xxtab(j),yytab(j),zztab(j),
7297 c     &      xxref(j),yyref(j),zzref(j)
7298         enddo
7299 c
7300 c       Gradient
7301 c
7302 c       Generalized expression for multiple Gaussian acc to that for a single
7303 c       Gaussian in Econstr_back as instructed by AL (FP - 03/11/2014)
7304 c
7305 c       Original implementation
7306 c       sum_guscdiff=guscdiff(i)
7307 c
7308 c       sum_sguscdiff=0.0d0
7309 c       do k=1,constr_homology
7310 c          sguscdiff=-guscdiff2(k)*dscdiff(k)*sigma_d(k,i)*waga_d !waga_d?
7311 c          sguscdiff=-guscdiff3(k)*dscdiff(k)*sigma_d(k,i)*waga_d ! w min_uscdiff
7312 c          sum_sguscdiff=sum_sguscdiff+sguscdiff
7313 c       enddo
7314 c
7315 c       Implementation of new expressions for gradient (Jan. 2015)
7316 c
7317 c       grad_uscdiff=sum_sguscdiff/(sum_guscdiff*dtab) !?
7318         do k=1,constr_homology
7319 c
7320 c       New calculation of dxx, dyy, and dzz corrected by AL (07/11), was missing and wrong
7321 c       before. Now the drivatives should be correct
7322 c
7323           dxx=-xxtpl(k,i)+xxtab(i) ! Diff b/w x component of ith SC vector in model and kth ref str?
7324 c                                  Original sign inverted for calc of gradients (s. Econstr_back)
7325           dyy=-yytpl(k,i)+yytab(i) ! ibid y
7326           dzz=-zztpl(k,i)+zztab(i) ! ibid z
7327 c
7328 c         New implementation
7329 c
7330           sum_guscdiff=guscdiff2(k)*!(dsqrt(dxx*dxx+dyy*dyy+dzz*dzz))* -> wrong!
7331      &                 sigma_d(k,i) ! for the grad wrt r'
7332 c         sum_sguscdiff=sum_sguscdiff+sum_guscdiff
7333 c
7334 c
7335 c        New implementation
7336          sum_guscdiff = waga_homology(iset)*waga_d*sum_guscdiff
7337          do jik=1,3
7338             duscdiff(jik,i-1)=duscdiff(jik,i-1)+
7339      &      sum_guscdiff*(dXX_C1tab(jik,i)*dxx+
7340      &      dYY_C1tab(jik,i)*dyy+dZZ_C1tab(jik,i)*dzz)/guscdiff(i)
7341             duscdiff(jik,i)=duscdiff(jik,i)+
7342      &      sum_guscdiff*(dXX_Ctab(jik,i)*dxx+
7343      &      dYY_Ctab(jik,i)*dyy+dZZ_Ctab(jik,i)*dzz)/guscdiff(i)
7344             duscdiffx(jik,i)=duscdiffx(jik,i)+
7345      &      sum_guscdiff*(dXX_XYZtab(jik,i)*dxx+
7346      &      dYY_XYZtab(jik,i)*dyy+dZZ_XYZtab(jik,i)*dzz)/guscdiff(i)
7347 c
7348 #ifdef DEBUG
7349              write(iout,*) "jik",jik,"i",i
7350              write(iout,*) "dxx, dyy, dzz"
7351              write(iout,'(2i5,3f8.2)') k,i,dxx,dyy,dzz
7352              write(iout,*) "guscdiff2(",k,")",guscdiff2(k)
7353 c            write(iout,*) "sum_sguscdiff",sum_sguscdiff
7354 cc           write(iout,*) "dXX_Ctab(",jik,i,")",dXX_Ctab(jik,i)
7355 c            write(iout,*) "dYY_Ctab(",jik,i,")",dYY_Ctab(jik,i)
7356 c            write(iout,*) "dZZ_Ctab(",jik,i,")",dZZ_Ctab(jik,i)
7357 c            write(iout,*) "dXX_C1tab(",jik,i,")",dXX_C1tab(jik,i)
7358 c            write(iout,*) "dYY_C1tab(",jik,i,")",dYY_C1tab(jik,i)
7359 c            write(iout,*) "dZZ_C1tab(",jik,i,")",dZZ_C1tab(jik,i)
7360 c            write(iout,*) "dXX_XYZtab(",jik,i,")",dXX_XYZtab(jik,i)
7361 c            write(iout,*) "dYY_XYZtab(",jik,i,")",dYY_XYZtab(jik,i)
7362 c            write(iout,*) "dZZ_XYZtab(",jik,i,")",dZZ_XYZtab(jik,i)
7363 c            write(iout,*) "duscdiff(",jik,i-1,")",duscdiff(jik,i-1)
7364 c            write(iout,*) "duscdiff(",jik,i,")",duscdiff(jik,i)
7365 c            write(iout,*) "duscdiffx(",jik,i,")",duscdiffx(jik,i)
7366 c            endif
7367 #endif
7368          enddo
7369         enddo
7370 c
7371 c       uscdiff(i)=-dLOG(guscdiff(i)/(ii-1))      ! Weighting by (ii-1) required?
7372 c        usc_diff(i)=-dLOG(guscdiff(i)/constr_homology) ! + min_uscdiff ?
7373 c
7374 c        write (iout,*) i," uscdiff",uscdiff(i)
7375 c
7376 c Put together deviations from local geometry
7377
7378 c       Uconst_back=Uconst_back+wfrag_back(1,i,iset)*utheta(i)+
7379 c      &            wfrag_back(3,i,iset)*uscdiff(i)
7380         Erot=Erot-dLOG(guscdiff(i)/constr_homology)
7381 c       write (iout,*) "usc_diff(",i,")=",usc_diff(i) ! -ln of sum of exps
7382 c       write (iout,*) "Uconst_back",Uconst_back ! cum sum of -ln-s
7383 c       Uconst_back=Uconst_back+usc_diff(i)
7384 c
7385 c     Gradient of multiple Gaussian restraint (FP - 04/11/2014 - right?)
7386 c
7387 c     New implment: multiplied by sum_sguscdiff
7388 c
7389
7390       enddo ! (i-loop for dscdiff)
7391
7392 c      endif
7393
7394 #ifdef DEBUG
7395       write(iout,*) "------- SC restrs end -------"
7396         write (iout,*) "------ After SC loop in e_modeller ------"
7397         do i=loc_start,loc_end
7398          write (iout,*) "i",i," gradc",(gradc(j,i,icg),j=1,3)
7399          write (iout,*) "i",i," gradx",(gradx(j,i,icg),j=1,3)
7400         enddo
7401       if (waga_theta.eq.1.0d0) then
7402       write (iout,*) "in e_modeller after SC restr end: dutheta"
7403       do i=ithet_start,ithet_end
7404         write (iout,*) i,dutheta(i)
7405       enddo
7406       endif
7407       if (waga_d.eq.1.0d0) then
7408       write (iout,*) "e_modeller after SC loop: duscdiff/x"
7409       do i=1,nres
7410         write (iout,*) i,(duscdiff(j,i),j=1,3)
7411         write (iout,*) i,(duscdiffx(j,i),j=1,3)
7412       enddo
7413       endif
7414 #endif
7415
7416 c Total energy from homology restraints
7417 #ifdef DEBUG
7418       write (iout,*) "odleg",odleg," kat",kat
7419 #endif
7420 c
7421 c Addition of energy of theta angle and SC local geom over constr_homologs ref strs
7422 c
7423 c     ehomology_constr=odleg+kat
7424 c
7425 c     For Lorentzian-type Urestr
7426 c
7427
7428       if (waga_dist.ge.0.0d0) then
7429 c
7430 c          For Gaussian-type Urestr
7431 c
7432         ehomology_constr=(waga_dist*odleg+waga_angle*kat+
7433      &              waga_theta*Eval+waga_d*Erot)*waga_homology(iset)
7434 c     write (iout,*) "ehomology_constr=",ehomology_constr
7435       else
7436 c
7437 c          For Lorentzian-type Urestr
7438 c
7439         ehomology_constr=(-waga_dist*odleg+waga_angle*kat+
7440      &              waga_theta*Eval+waga_d*Erot)*waga_homology(iset)
7441 c     write (iout,*) "ehomology_constr=",ehomology_constr
7442       endif
7443 #ifdef DEBUG
7444       write (iout,*) "odleg",waga_dist,odleg," kat",waga_angle,kat,
7445      & "Eval",waga_theta,eval,
7446      &   "Erot",waga_d,Erot
7447       write (iout,*) "ehomology_constr",ehomology_constr
7448 #endif
7449       return
7450 c
7451 c FP 01/15 end
7452 c
7453   748 format(a8,f12.3,a6,f12.3,a7,f12.3)
7454   747 format(a12,i4,i4,i4,f8.3,f8.3)
7455   746 format(a12,i4,i4,i4,f8.3,f8.3,f8.3)
7456   778 format(a7,1X,f10.3,1X,a4,1X,f10.3,1X,a5,1X,f10.3)
7457   779 format(i3,1X,i3,1X,i2,1X,a7,1X,f7.3,1X,a7,1X,f7.3,1X,a13,1X,
7458      &       f7.3,1X,a17,1X,f9.3,1X,a10,1X,f8.3,1X,a10,1X,f8.3)
7459       end
7460
7461 c------------------------------------------------------------------------------
7462       subroutine etor_d(etors_d)
7463 C 6/23/01 Compute double torsional energy
7464       implicit real*8 (a-h,o-z)
7465       include 'DIMENSIONS'
7466       include 'COMMON.VAR'
7467       include 'COMMON.GEO'
7468       include 'COMMON.LOCAL'
7469       include 'COMMON.TORSION'
7470       include 'COMMON.INTERACT'
7471       include 'COMMON.DERIV'
7472       include 'COMMON.CHAIN'
7473       include 'COMMON.NAMES'
7474       include 'COMMON.IOUNITS'
7475       include 'COMMON.FFIELD'
7476       include 'COMMON.TORCNSTR'
7477       include 'COMMON.CONTROL'
7478       logical lprn
7479 C Set lprn=.true. for debugging
7480       lprn=.false.
7481 c     lprn=.true.
7482       etors_d=0.0D0
7483 c      write(iout,*) "a tu??"
7484       do i=iphid_start,iphid_end
7485 C ANY TWO ARE DUMMY ATOMS in row CYCLE
7486 C        if (((itype(i-3).eq.ntyp1).and.(itype(i-2).eq.ntyp1)).or.
7487 C     &      ((itype(i-2).eq.ntyp1).and.(itype(i-1).eq.ntyp1)).or.
7488 C     &      ((itype(i-1).eq.ntyp1).and.(itype(i).eq.ntyp1))  .or.
7489 C     &      ((itype(i).eq.ntyp1).and.(itype(i+1).eq.ntyp1))) cycle
7490          if ((itype(i-2).eq.ntyp1).or.itype(i-3).eq.ntyp1.or.
7491      &  (itype(i-1).eq.ntyp1).or.(itype(i).eq.ntyp1).or.
7492      &  (itype(i+1).eq.ntyp1)) cycle
7493 C In current verion the ALL DUMMY ATOM POTENTIALS ARE OFF
7494         etors_d_ii=0.0D0
7495         itori=itortyp(itype(i-2))
7496         itori1=itortyp(itype(i-1))
7497         itori2=itortyp(itype(i))
7498         phii=phi(i)
7499         phii1=phi(i+1)
7500         gloci1=0.0D0
7501         gloci2=0.0D0
7502         iblock=1
7503         if (iabs(itype(i+1)).eq.20) iblock=2
7504 C Iblock=2 Proline type
7505 C ADASKO: WHEN PARAMETERS FOR THIS TYPE OF BLOCKING GROUP IS READY UNCOMMENT
7506 C CHECK WEATHER THERE IS NECCESITY FOR iblock=3 for COO-
7507 C        if (itype(i+1).eq.ntyp1) iblock=3
7508 C The problem of NH3+ group can be resolved by adding new parameters please note if there
7509 C IS or IS NOT need for this
7510 C IF Yes uncomment below and add to parmread.F appropriate changes and to v1cij and so on
7511 C        is (itype(i-3).eq.ntyp1) ntblock=2
7512 C        ntblock is N-terminal blocking group
7513
7514 C Regular cosine and sine terms
7515         do j=1,ntermd_1(itori,itori1,itori2,iblock)
7516 C Example of changes for NH3+ blocking group
7517 C       do j=1,ntermd_1(itori,itori1,itori2,iblock,ntblock)
7518 C          v1cij=v1c(1,j,itori,itori1,itori2,iblock,ntblock)
7519           v1cij=v1c(1,j,itori,itori1,itori2,iblock)
7520           v1sij=v1s(1,j,itori,itori1,itori2,iblock)
7521           v2cij=v1c(2,j,itori,itori1,itori2,iblock)
7522           v2sij=v1s(2,j,itori,itori1,itori2,iblock)
7523           cosphi1=dcos(j*phii)
7524           sinphi1=dsin(j*phii)
7525           cosphi2=dcos(j*phii1)
7526           sinphi2=dsin(j*phii1)
7527           etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+
7528      &     v2cij*cosphi2+v2sij*sinphi2
7529           if (energy_dec) etors_d_ii=etors_d_ii+
7530      &     v1cij*cosphi1+v1sij*sinphi1+v2cij*cosphi2+v2sij*sinphi2
7531           gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
7532           gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
7533         enddo
7534         do k=2,ntermd_2(itori,itori1,itori2,iblock)
7535           do l=1,k-1
7536             v1cdij = v2c(k,l,itori,itori1,itori2,iblock)
7537             v2cdij = v2c(l,k,itori,itori1,itori2,iblock)
7538             v1sdij = v2s(k,l,itori,itori1,itori2,iblock)
7539             v2sdij = v2s(l,k,itori,itori1,itori2,iblock)
7540             cosphi1p2=dcos(l*phii+(k-l)*phii1)
7541             cosphi1m2=dcos(l*phii-(k-l)*phii1)
7542             sinphi1p2=dsin(l*phii+(k-l)*phii1)
7543             sinphi1m2=dsin(l*phii-(k-l)*phii1)
7544             etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+
7545      &        v1sdij*sinphi1p2+v2sdij*sinphi1m2
7546             if (energy_dec) etors_d_ii=etors_d_ii+
7547      &        v1cdij*cosphi1p2+v2cdij*cosphi1m2+
7548      &        v1sdij*sinphi1p2+v2sdij*sinphi1m2
7549             gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2
7550      &        -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
7551             gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2
7552      &        -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
7553           enddo
7554         enddo
7555           if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
7556      &         'etor_d',i,etors_d_ii
7557         gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*gloci1
7558         gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*gloci2
7559       enddo
7560       return
7561       end
7562 #endif
7563 c------------------------------------------------------------------------------
7564       subroutine eback_sc_corr(esccor)
7565 c 7/21/2007 Correlations between the backbone-local and side-chain-local
7566 c        conformational states; temporarily implemented as differences
7567 c        between UNRES torsional potentials (dependent on three types of
7568 c        residues) and the torsional potentials dependent on all 20 types
7569 c        of residues computed from AM1  energy surfaces of terminally-blocked
7570 c        amino-acid residues.
7571       implicit real*8 (a-h,o-z)
7572       include 'DIMENSIONS'
7573       include 'COMMON.VAR'
7574       include 'COMMON.GEO'
7575       include 'COMMON.LOCAL'
7576       include 'COMMON.TORSION'
7577       include 'COMMON.SCCOR'
7578       include 'COMMON.INTERACT'
7579       include 'COMMON.DERIV'
7580       include 'COMMON.CHAIN'
7581       include 'COMMON.NAMES'
7582       include 'COMMON.IOUNITS'
7583       include 'COMMON.FFIELD'
7584       include 'COMMON.CONTROL'
7585       logical lprn
7586 C Set lprn=.true. for debugging
7587       lprn=.false.
7588 c      lprn=.true.
7589 c      write (iout,*) "EBACK_SC_COR",itau_start,itau_end
7590       esccor=0.0D0
7591       do i=itau_start,itau_end
7592         if ((itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)) cycle
7593         isccori=isccortyp(itype(i-2))
7594         isccori1=isccortyp(itype(i-1))
7595 c      write (iout,*) "EBACK_SC_COR",i,nterm_sccor(isccori,isccori1)
7596         phii=phi(i)
7597         do intertyp=1,3 !intertyp
7598          esccor_ii=0.0D0
7599 cc Added 09 May 2012 (Adasko)
7600 cc  Intertyp means interaction type of backbone mainchain correlation:
7601 c   1 = SC...Ca...Ca...Ca
7602 c   2 = Ca...Ca...Ca...SC
7603 c   3 = SC...Ca...Ca...SCi
7604         gloci=0.0D0
7605         if (((intertyp.eq.3).and.((itype(i-2).eq.10).or.
7606      &      (itype(i-1).eq.10).or.(itype(i-2).eq.ntyp1).or.
7607      &      (itype(i-1).eq.ntyp1)))
7608      &    .or. ((intertyp.eq.1).and.((itype(i-2).eq.10)
7609      &     .or.(itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)
7610      &     .or.(itype(i).eq.ntyp1)))
7611      &    .or.((intertyp.eq.2).and.((itype(i-1).eq.10).or.
7612      &      (itype(i-1).eq.ntyp1).or.(itype(i-2).eq.ntyp1).or.
7613      &      (itype(i-3).eq.ntyp1)))) cycle
7614         if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1).eq.ntyp1)) cycle
7615         if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres).eq.ntyp1))
7616      & cycle
7617        do j=1,nterm_sccor(isccori,isccori1)
7618           v1ij=v1sccor(j,intertyp,isccori,isccori1)
7619           v2ij=v2sccor(j,intertyp,isccori,isccori1)
7620           cosphi=dcos(j*tauangle(intertyp,i))
7621           sinphi=dsin(j*tauangle(intertyp,i))
7622           if (energy_dec) esccor_ii=esccor_ii+v1ij*cosphi+v2ij*sinphi
7623           esccor=esccor+v1ij*cosphi+v2ij*sinphi
7624           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7625         enddo
7626          if (energy_dec) write (iout,'(a6,i5,i2,0pf7.3)')
7627      &         'esccor',i,intertyp,esccor_ii
7628 c      write (iout,*) "EBACK_SC_COR",i,v1ij*cosphi+v2ij*sinphi,intertyp
7629         gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci
7630         if (lprn)
7631      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
7632      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,isccori,isccori1,
7633      &  (v1sccor(j,intertyp,isccori,isccori1),j=1,6)
7634      & ,(v2sccor(j,intertyp,isccori,isccori1),j=1,6)
7635         gsccor_loc(i-3)=gsccor_loc(i-3)+gloci
7636        enddo !intertyp
7637       enddo
7638
7639       return
7640       end
7641 c----------------------------------------------------------------------------
7642       subroutine multibody(ecorr)
7643 C This subroutine calculates multi-body contributions to energy following
7644 C the idea of Skolnick et al. If side chains I and J make a contact and
7645 C at the same time side chains I+1 and J+1 make a contact, an extra
7646 C contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
7647       implicit real*8 (a-h,o-z)
7648       include 'DIMENSIONS'
7649       include 'COMMON.IOUNITS'
7650       include 'COMMON.DERIV'
7651       include 'COMMON.INTERACT'
7652       include 'COMMON.CONTACTS'
7653       double precision gx(3),gx1(3)
7654       logical lprn
7655
7656 C Set lprn=.true. for debugging
7657       lprn=.false.
7658
7659       if (lprn) then
7660         write (iout,'(a)') 'Contact function values:'
7661         do i=nnt,nct-2
7662           write (iout,'(i2,20(1x,i2,f10.5))')
7663      &        i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
7664         enddo
7665       endif
7666       ecorr=0.0D0
7667       do i=nnt,nct
7668         do j=1,3
7669           gradcorr(j,i)=0.0D0
7670           gradxorr(j,i)=0.0D0
7671         enddo
7672       enddo
7673       do i=nnt,nct-2
7674
7675         DO ISHIFT = 3,4
7676
7677         i1=i+ishift
7678         num_conti=num_cont(i)
7679         num_conti1=num_cont(i1)
7680         do jj=1,num_conti
7681           j=jcont(jj,i)
7682           do kk=1,num_conti1
7683             j1=jcont(kk,i1)
7684             if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
7685 cd          write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
7686 cd   &                   ' ishift=',ishift
7687 C Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
7688 C The system gains extra energy.
7689               ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
7690             endif   ! j1==j+-ishift
7691           enddo     ! kk
7692         enddo       ! jj
7693
7694         ENDDO ! ISHIFT
7695
7696       enddo         ! i
7697       return
7698       end
7699 c------------------------------------------------------------------------------
7700       double precision function esccorr(i,j,k,l,jj,kk)
7701       implicit real*8 (a-h,o-z)
7702       include 'DIMENSIONS'
7703       include 'COMMON.IOUNITS'
7704       include 'COMMON.DERIV'
7705       include 'COMMON.INTERACT'
7706       include 'COMMON.CONTACTS'
7707       double precision gx(3),gx1(3)
7708       logical lprn
7709       lprn=.false.
7710       eij=facont(jj,i)
7711       ekl=facont(kk,k)
7712 cd    write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
7713 C Calculate the multi-body contribution to energy.
7714 C Calculate multi-body contributions to the gradient.
7715 cd    write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
7716 cd   & k,l,(gacont(m,kk,k),m=1,3)
7717       do m=1,3
7718         gx(m) =ekl*gacont(m,jj,i)
7719         gx1(m)=eij*gacont(m,kk,k)
7720         gradxorr(m,i)=gradxorr(m,i)-gx(m)
7721         gradxorr(m,j)=gradxorr(m,j)+gx(m)
7722         gradxorr(m,k)=gradxorr(m,k)-gx1(m)
7723         gradxorr(m,l)=gradxorr(m,l)+gx1(m)
7724       enddo
7725       do m=i,j-1
7726         do ll=1,3
7727           gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
7728         enddo
7729       enddo
7730       do m=k,l-1
7731         do ll=1,3
7732           gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
7733         enddo
7734       enddo
7735       esccorr=-eij*ekl
7736       return
7737       end
7738 c------------------------------------------------------------------------------
7739       subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
7740 C This subroutine calculates multi-body contributions to hydrogen-bonding
7741       implicit real*8 (a-h,o-z)
7742       include 'DIMENSIONS'
7743       include 'COMMON.IOUNITS'
7744 #ifdef MPI
7745       include "mpif.h"
7746       parameter (max_cont=maxconts)
7747       parameter (max_dim=26)
7748       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
7749       double precision zapas(max_dim,maxconts,max_fg_procs),
7750      &  zapas_recv(max_dim,maxconts,max_fg_procs)
7751       common /przechowalnia/ zapas
7752       integer status(MPI_STATUS_SIZE),req(maxconts*2),
7753      &  status_array(MPI_STATUS_SIZE,maxconts*2)
7754 #endif
7755       include 'COMMON.SETUP'
7756       include 'COMMON.FFIELD'
7757       include 'COMMON.DERIV'
7758       include 'COMMON.INTERACT'
7759       include 'COMMON.CONTACTS'
7760       include 'COMMON.CONTROL'
7761       include 'COMMON.LOCAL'
7762       double precision gx(3),gx1(3),time00
7763       logical lprn,ldone
7764
7765 C Set lprn=.true. for debugging
7766       lprn=.false.
7767 #ifdef MPI
7768       n_corr=0
7769       n_corr1=0
7770       if (nfgtasks.le.1) goto 30
7771       if (lprn) then
7772         write (iout,'(a)') 'Contact function values before RECEIVE:'
7773         do i=nnt,nct-2
7774           write (iout,'(2i3,50(1x,i2,f5.2))')
7775      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
7776      &    j=1,num_cont_hb(i))
7777         enddo
7778       endif
7779       call flush(iout)
7780       do i=1,ntask_cont_from
7781         ncont_recv(i)=0
7782       enddo
7783       do i=1,ntask_cont_to
7784         ncont_sent(i)=0
7785       enddo
7786 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
7787 c     & ntask_cont_to
7788 C Make the list of contacts to send to send to other procesors
7789 c      write (iout,*) "limits",max0(iturn4_end-1,iatel_s),iturn3_end
7790 c      call flush(iout)
7791       do i=iturn3_start,iturn3_end
7792 c        write (iout,*) "make contact list turn3",i," num_cont",
7793 c     &    num_cont_hb(i)
7794         call add_hb_contact(i,i+2,iturn3_sent_local(1,i))
7795       enddo
7796       do i=iturn4_start,iturn4_end
7797 c        write (iout,*) "make contact list turn4",i," num_cont",
7798 c     &   num_cont_hb(i)
7799         call add_hb_contact(i,i+3,iturn4_sent_local(1,i))
7800       enddo
7801       do ii=1,nat_sent
7802         i=iat_sent(ii)
7803 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
7804 c     &    num_cont_hb(i)
7805         do j=1,num_cont_hb(i)
7806         do k=1,4
7807           jjc=jcont_hb(j,i)
7808           iproc=iint_sent_local(k,jjc,ii)
7809 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
7810           if (iproc.gt.0) then
7811             ncont_sent(iproc)=ncont_sent(iproc)+1
7812             nn=ncont_sent(iproc)
7813             zapas(1,nn,iproc)=i
7814             zapas(2,nn,iproc)=jjc
7815             zapas(3,nn,iproc)=facont_hb(j,i)
7816             zapas(4,nn,iproc)=ees0p(j,i)
7817             zapas(5,nn,iproc)=ees0m(j,i)
7818             zapas(6,nn,iproc)=gacont_hbr(1,j,i)
7819             zapas(7,nn,iproc)=gacont_hbr(2,j,i)
7820             zapas(8,nn,iproc)=gacont_hbr(3,j,i)
7821             zapas(9,nn,iproc)=gacontm_hb1(1,j,i)
7822             zapas(10,nn,iproc)=gacontm_hb1(2,j,i)
7823             zapas(11,nn,iproc)=gacontm_hb1(3,j,i)
7824             zapas(12,nn,iproc)=gacontp_hb1(1,j,i)
7825             zapas(13,nn,iproc)=gacontp_hb1(2,j,i)
7826             zapas(14,nn,iproc)=gacontp_hb1(3,j,i)
7827             zapas(15,nn,iproc)=gacontm_hb2(1,j,i)
7828             zapas(16,nn,iproc)=gacontm_hb2(2,j,i)
7829             zapas(17,nn,iproc)=gacontm_hb2(3,j,i)
7830             zapas(18,nn,iproc)=gacontp_hb2(1,j,i)
7831             zapas(19,nn,iproc)=gacontp_hb2(2,j,i)
7832             zapas(20,nn,iproc)=gacontp_hb2(3,j,i)
7833             zapas(21,nn,iproc)=gacontm_hb3(1,j,i)
7834             zapas(22,nn,iproc)=gacontm_hb3(2,j,i)
7835             zapas(23,nn,iproc)=gacontm_hb3(3,j,i)
7836             zapas(24,nn,iproc)=gacontp_hb3(1,j,i)
7837             zapas(25,nn,iproc)=gacontp_hb3(2,j,i)
7838             zapas(26,nn,iproc)=gacontp_hb3(3,j,i)
7839           endif
7840         enddo
7841         enddo
7842       enddo
7843       if (lprn) then
7844       write (iout,*)
7845      &  "Numbers of contacts to be sent to other processors",
7846      &  (ncont_sent(i),i=1,ntask_cont_to)
7847       write (iout,*) "Contacts sent"
7848       do ii=1,ntask_cont_to
7849         nn=ncont_sent(ii)
7850         iproc=itask_cont_to(ii)
7851         write (iout,*) nn," contacts to processor",iproc,
7852      &   " of CONT_TO_COMM group"
7853         do i=1,nn
7854           write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
7855         enddo
7856       enddo
7857       call flush(iout)
7858       endif
7859       CorrelType=477
7860       CorrelID=fg_rank+1
7861       CorrelType1=478
7862       CorrelID1=nfgtasks+fg_rank+1
7863       ireq=0
7864 C Receive the numbers of needed contacts from other processors
7865       do ii=1,ntask_cont_from
7866         iproc=itask_cont_from(ii)
7867         ireq=ireq+1
7868         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
7869      &    FG_COMM,req(ireq),IERR)
7870       enddo
7871 c      write (iout,*) "IRECV ended"
7872 c      call flush(iout)
7873 C Send the number of contacts needed by other processors
7874       do ii=1,ntask_cont_to
7875         iproc=itask_cont_to(ii)
7876         ireq=ireq+1
7877         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
7878      &    FG_COMM,req(ireq),IERR)
7879       enddo
7880 c      write (iout,*) "ISEND ended"
7881 c      write (iout,*) "number of requests (nn)",ireq
7882       call flush(iout)
7883       if (ireq.gt.0)
7884      &  call MPI_Waitall(ireq,req,status_array,ierr)
7885 c      write (iout,*)
7886 c     &  "Numbers of contacts to be received from other processors",
7887 c     &  (ncont_recv(i),i=1,ntask_cont_from)
7888 c      call flush(iout)
7889 C Receive contacts
7890       ireq=0
7891       do ii=1,ntask_cont_from
7892         iproc=itask_cont_from(ii)
7893         nn=ncont_recv(ii)
7894 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
7895 c     &   " of CONT_TO_COMM group"
7896         call flush(iout)
7897         if (nn.gt.0) then
7898           ireq=ireq+1
7899           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
7900      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
7901 c          write (iout,*) "ireq,req",ireq,req(ireq)
7902         endif
7903       enddo
7904 C Send the contacts to processors that need them
7905       do ii=1,ntask_cont_to
7906         iproc=itask_cont_to(ii)
7907         nn=ncont_sent(ii)
7908 c        write (iout,*) nn," contacts to processor",iproc,
7909 c     &   " of CONT_TO_COMM group"
7910         if (nn.gt.0) then
7911           ireq=ireq+1
7912           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
7913      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
7914 c          write (iout,*) "ireq,req",ireq,req(ireq)
7915 c          do i=1,nn
7916 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
7917 c          enddo
7918         endif
7919       enddo
7920 c      write (iout,*) "number of requests (contacts)",ireq
7921 c      write (iout,*) "req",(req(i),i=1,4)
7922 c      call flush(iout)
7923       if (ireq.gt.0)
7924      & call MPI_Waitall(ireq,req,status_array,ierr)
7925       do iii=1,ntask_cont_from
7926         iproc=itask_cont_from(iii)
7927         nn=ncont_recv(iii)
7928         if (lprn) then
7929         write (iout,*) "Received",nn," contacts from processor",iproc,
7930      &   " of CONT_FROM_COMM group"
7931         call flush(iout)
7932         do i=1,nn
7933           write(iout,'(2f5.0,4f10.5)')(zapas_recv(j,i,iii),j=1,5)
7934         enddo
7935         call flush(iout)
7936         endif
7937         do i=1,nn
7938           ii=zapas_recv(1,i,iii)
7939 c Flag the received contacts to prevent double-counting
7940           jj=-zapas_recv(2,i,iii)
7941 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
7942 c          call flush(iout)
7943           nnn=num_cont_hb(ii)+1
7944           num_cont_hb(ii)=nnn
7945           jcont_hb(nnn,ii)=jj
7946           facont_hb(nnn,ii)=zapas_recv(3,i,iii)
7947           ees0p(nnn,ii)=zapas_recv(4,i,iii)
7948           ees0m(nnn,ii)=zapas_recv(5,i,iii)
7949           gacont_hbr(1,nnn,ii)=zapas_recv(6,i,iii)
7950           gacont_hbr(2,nnn,ii)=zapas_recv(7,i,iii)
7951           gacont_hbr(3,nnn,ii)=zapas_recv(8,i,iii)
7952           gacontm_hb1(1,nnn,ii)=zapas_recv(9,i,iii)
7953           gacontm_hb1(2,nnn,ii)=zapas_recv(10,i,iii)
7954           gacontm_hb1(3,nnn,ii)=zapas_recv(11,i,iii)
7955           gacontp_hb1(1,nnn,ii)=zapas_recv(12,i,iii)
7956           gacontp_hb1(2,nnn,ii)=zapas_recv(13,i,iii)
7957           gacontp_hb1(3,nnn,ii)=zapas_recv(14,i,iii)
7958           gacontm_hb2(1,nnn,ii)=zapas_recv(15,i,iii)
7959           gacontm_hb2(2,nnn,ii)=zapas_recv(16,i,iii)
7960           gacontm_hb2(3,nnn,ii)=zapas_recv(17,i,iii)
7961           gacontp_hb2(1,nnn,ii)=zapas_recv(18,i,iii)
7962           gacontp_hb2(2,nnn,ii)=zapas_recv(19,i,iii)
7963           gacontp_hb2(3,nnn,ii)=zapas_recv(20,i,iii)
7964           gacontm_hb3(1,nnn,ii)=zapas_recv(21,i,iii)
7965           gacontm_hb3(2,nnn,ii)=zapas_recv(22,i,iii)
7966           gacontm_hb3(3,nnn,ii)=zapas_recv(23,i,iii)
7967           gacontp_hb3(1,nnn,ii)=zapas_recv(24,i,iii)
7968           gacontp_hb3(2,nnn,ii)=zapas_recv(25,i,iii)
7969           gacontp_hb3(3,nnn,ii)=zapas_recv(26,i,iii)
7970         enddo
7971       enddo
7972       call flush(iout)
7973       if (lprn) then
7974         write (iout,'(a)') 'Contact function values after receive:'
7975         do i=nnt,nct-2
7976           write (iout,'(2i3,50(1x,i3,f5.2))')
7977      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
7978      &    j=1,num_cont_hb(i))
7979         enddo
7980         call flush(iout)
7981       endif
7982    30 continue
7983 #endif
7984       if (lprn) then
7985         write (iout,'(a)') 'Contact function values:'
7986         do i=nnt,nct-2
7987           write (iout,'(2i3,50(1x,i3,f5.2))')
7988      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
7989      &    j=1,num_cont_hb(i))
7990         enddo
7991       endif
7992       ecorr=0.0D0
7993 C Remove the loop below after debugging !!!
7994       do i=nnt,nct
7995         do j=1,3
7996           gradcorr(j,i)=0.0D0
7997           gradxorr(j,i)=0.0D0
7998         enddo
7999       enddo
8000 C Calculate the local-electrostatic correlation terms
8001       do i=min0(iatel_s,iturn4_start),max0(iatel_e,iturn3_end)
8002         i1=i+1
8003         num_conti=num_cont_hb(i)
8004         num_conti1=num_cont_hb(i+1)
8005         do jj=1,num_conti
8006           j=jcont_hb(jj,i)
8007           jp=iabs(j)
8008           do kk=1,num_conti1
8009             j1=jcont_hb(kk,i1)
8010             jp1=iabs(j1)
8011 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
8012 c     &         ' jj=',jj,' kk=',kk
8013             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
8014      &          .or. j.lt.0 .and. j1.gt.0) .and.
8015      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
8016 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
8017 C The system gains extra energy.
8018               ecorr=ecorr+ehbcorr(i,jp,i+1,jp1,jj,kk,0.72D0,0.32D0)
8019               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
8020      &            'ecorrh',i,j,ehbcorr(i,j,i+1,j1,jj,kk,0.72D0,0.32D0)
8021               n_corr=n_corr+1
8022             else if (j1.eq.j) then
8023 C Contacts I-J and I-(J+1) occur simultaneously.
8024 C The system loses extra energy.
8025 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
8026             endif
8027           enddo ! kk
8028           do kk=1,num_conti
8029             j1=jcont_hb(kk,i)
8030 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
8031 c    &         ' jj=',jj,' kk=',kk
8032             if (j1.eq.j+1) then
8033 C Contacts I-J and (I+1)-J occur simultaneously.
8034 C The system loses extra energy.
8035 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
8036             endif ! j1==j+1
8037           enddo ! kk
8038         enddo ! jj
8039       enddo ! i
8040       return
8041       end
8042 c------------------------------------------------------------------------------
8043       subroutine add_hb_contact(ii,jj,itask)
8044       implicit real*8 (a-h,o-z)
8045       include "DIMENSIONS"
8046       include "COMMON.IOUNITS"
8047       integer max_cont
8048       integer max_dim
8049       parameter (max_cont=maxconts)
8050       parameter (max_dim=26)
8051       include "COMMON.CONTACTS"
8052       double precision zapas(max_dim,maxconts,max_fg_procs),
8053      &  zapas_recv(max_dim,maxconts,max_fg_procs)
8054       common /przechowalnia/ zapas
8055       integer i,j,ii,jj,iproc,itask(4),nn
8056 c      write (iout,*) "itask",itask
8057       do i=1,2
8058         iproc=itask(i)
8059         if (iproc.gt.0) then
8060           do j=1,num_cont_hb(ii)
8061             jjc=jcont_hb(j,ii)
8062 c            write (iout,*) "i",ii," j",jj," jjc",jjc
8063             if (jjc.eq.jj) then
8064               ncont_sent(iproc)=ncont_sent(iproc)+1
8065               nn=ncont_sent(iproc)
8066               zapas(1,nn,iproc)=ii
8067               zapas(2,nn,iproc)=jjc
8068               zapas(3,nn,iproc)=facont_hb(j,ii)
8069               zapas(4,nn,iproc)=ees0p(j,ii)
8070               zapas(5,nn,iproc)=ees0m(j,ii)
8071               zapas(6,nn,iproc)=gacont_hbr(1,j,ii)
8072               zapas(7,nn,iproc)=gacont_hbr(2,j,ii)
8073               zapas(8,nn,iproc)=gacont_hbr(3,j,ii)
8074               zapas(9,nn,iproc)=gacontm_hb1(1,j,ii)
8075               zapas(10,nn,iproc)=gacontm_hb1(2,j,ii)
8076               zapas(11,nn,iproc)=gacontm_hb1(3,j,ii)
8077               zapas(12,nn,iproc)=gacontp_hb1(1,j,ii)
8078               zapas(13,nn,iproc)=gacontp_hb1(2,j,ii)
8079               zapas(14,nn,iproc)=gacontp_hb1(3,j,ii)
8080               zapas(15,nn,iproc)=gacontm_hb2(1,j,ii)
8081               zapas(16,nn,iproc)=gacontm_hb2(2,j,ii)
8082               zapas(17,nn,iproc)=gacontm_hb2(3,j,ii)
8083               zapas(18,nn,iproc)=gacontp_hb2(1,j,ii)
8084               zapas(19,nn,iproc)=gacontp_hb2(2,j,ii)
8085               zapas(20,nn,iproc)=gacontp_hb2(3,j,ii)
8086               zapas(21,nn,iproc)=gacontm_hb3(1,j,ii)
8087               zapas(22,nn,iproc)=gacontm_hb3(2,j,ii)
8088               zapas(23,nn,iproc)=gacontm_hb3(3,j,ii)
8089               zapas(24,nn,iproc)=gacontp_hb3(1,j,ii)
8090               zapas(25,nn,iproc)=gacontp_hb3(2,j,ii)
8091               zapas(26,nn,iproc)=gacontp_hb3(3,j,ii)
8092               exit
8093             endif
8094           enddo
8095         endif
8096       enddo
8097       return
8098       end
8099 c------------------------------------------------------------------------------
8100       subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,
8101      &  n_corr1)
8102 C This subroutine calculates multi-body contributions to hydrogen-bonding
8103       implicit real*8 (a-h,o-z)
8104       include 'DIMENSIONS'
8105       include 'COMMON.IOUNITS'
8106 #ifdef MPI
8107       include "mpif.h"
8108       parameter (max_cont=maxconts)
8109       parameter (max_dim=70)
8110       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
8111       double precision zapas(max_dim,maxconts,max_fg_procs),
8112      &  zapas_recv(max_dim,maxconts,max_fg_procs)
8113       common /przechowalnia/ zapas
8114       integer status(MPI_STATUS_SIZE),req(maxconts*2),
8115      &  status_array(MPI_STATUS_SIZE,maxconts*2)
8116 #endif
8117       include 'COMMON.SETUP'
8118       include 'COMMON.FFIELD'
8119       include 'COMMON.DERIV'
8120       include 'COMMON.LOCAL'
8121       include 'COMMON.INTERACT'
8122       include 'COMMON.CONTACTS'
8123       include 'COMMON.CHAIN'
8124       include 'COMMON.CONTROL'
8125       double precision gx(3),gx1(3)
8126       integer num_cont_hb_old(maxres)
8127       logical lprn,ldone
8128       double precision eello4,eello5,eelo6,eello_turn6
8129       external eello4,eello5,eello6,eello_turn6
8130 C Set lprn=.true. for debugging
8131       lprn=.false.
8132       eturn6=0.0d0
8133 #ifdef MPI
8134       do i=1,nres
8135         num_cont_hb_old(i)=num_cont_hb(i)
8136       enddo
8137       n_corr=0
8138       n_corr1=0
8139       if (nfgtasks.le.1) goto 30
8140       if (lprn) then
8141         write (iout,'(a)') 'Contact function values before RECEIVE:'
8142         do i=nnt,nct-2
8143           write (iout,'(2i3,50(1x,i2,f5.2))')
8144      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
8145      &    j=1,num_cont_hb(i))
8146         enddo
8147       endif
8148       call flush(iout)
8149       do i=1,ntask_cont_from
8150         ncont_recv(i)=0
8151       enddo
8152       do i=1,ntask_cont_to
8153         ncont_sent(i)=0
8154       enddo
8155 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
8156 c     & ntask_cont_to
8157 C Make the list of contacts to send to send to other procesors
8158       do i=iturn3_start,iturn3_end
8159 c        write (iout,*) "make contact list turn3",i," num_cont",
8160 c     &    num_cont_hb(i)
8161         call add_hb_contact_eello(i,i+2,iturn3_sent_local(1,i))
8162       enddo
8163       do i=iturn4_start,iturn4_end
8164 c        write (iout,*) "make contact list turn4",i," num_cont",
8165 c     &   num_cont_hb(i)
8166         call add_hb_contact_eello(i,i+3,iturn4_sent_local(1,i))
8167       enddo
8168       do ii=1,nat_sent
8169         i=iat_sent(ii)
8170 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
8171 c     &    num_cont_hb(i)
8172         do j=1,num_cont_hb(i)
8173         do k=1,4
8174           jjc=jcont_hb(j,i)
8175           iproc=iint_sent_local(k,jjc,ii)
8176 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
8177           if (iproc.ne.0) then
8178             ncont_sent(iproc)=ncont_sent(iproc)+1
8179             nn=ncont_sent(iproc)
8180             zapas(1,nn,iproc)=i
8181             zapas(2,nn,iproc)=jjc
8182             zapas(3,nn,iproc)=d_cont(j,i)
8183             ind=3
8184             do kk=1,3
8185               ind=ind+1
8186               zapas(ind,nn,iproc)=grij_hb_cont(kk,j,i)
8187             enddo
8188             do kk=1,2
8189               do ll=1,2
8190                 ind=ind+1
8191                 zapas(ind,nn,iproc)=a_chuj(ll,kk,j,i)
8192               enddo
8193             enddo
8194             do jj=1,5
8195               do kk=1,3
8196                 do ll=1,2
8197                   do mm=1,2
8198                     ind=ind+1
8199                     zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,i)
8200                   enddo
8201                 enddo
8202               enddo
8203             enddo
8204           endif
8205         enddo
8206         enddo
8207       enddo
8208       if (lprn) then
8209       write (iout,*)
8210      &  "Numbers of contacts to be sent to other processors",
8211      &  (ncont_sent(i),i=1,ntask_cont_to)
8212       write (iout,*) "Contacts sent"
8213       do ii=1,ntask_cont_to
8214         nn=ncont_sent(ii)
8215         iproc=itask_cont_to(ii)
8216         write (iout,*) nn," contacts to processor",iproc,
8217      &   " of CONT_TO_COMM group"
8218         do i=1,nn
8219           write(iout,'(2f5.0,10f10.5)')(zapas(j,i,ii),j=1,10)
8220         enddo
8221       enddo
8222       call flush(iout)
8223       endif
8224       CorrelType=477
8225       CorrelID=fg_rank+1
8226       CorrelType1=478
8227       CorrelID1=nfgtasks+fg_rank+1
8228       ireq=0
8229 C Receive the numbers of needed contacts from other processors
8230       do ii=1,ntask_cont_from
8231         iproc=itask_cont_from(ii)
8232         ireq=ireq+1
8233         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
8234      &    FG_COMM,req(ireq),IERR)
8235       enddo
8236 c      write (iout,*) "IRECV ended"
8237 c      call flush(iout)
8238 C Send the number of contacts needed by other processors
8239       do ii=1,ntask_cont_to
8240         iproc=itask_cont_to(ii)
8241         ireq=ireq+1
8242         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
8243      &    FG_COMM,req(ireq),IERR)
8244       enddo
8245 c      write (iout,*) "ISEND ended"
8246 c      write (iout,*) "number of requests (nn)",ireq
8247       call flush(iout)
8248       if (ireq.gt.0)
8249      &  call MPI_Waitall(ireq,req,status_array,ierr)
8250 c      write (iout,*)
8251 c     &  "Numbers of contacts to be received from other processors",
8252 c     &  (ncont_recv(i),i=1,ntask_cont_from)
8253 c      call flush(iout)
8254 C Receive contacts
8255       ireq=0
8256       do ii=1,ntask_cont_from
8257         iproc=itask_cont_from(ii)
8258         nn=ncont_recv(ii)
8259 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
8260 c     &   " of CONT_TO_COMM group"
8261         call flush(iout)
8262         if (nn.gt.0) then
8263           ireq=ireq+1
8264           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
8265      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
8266 c          write (iout,*) "ireq,req",ireq,req(ireq)
8267         endif
8268       enddo
8269 C Send the contacts to processors that need them
8270       do ii=1,ntask_cont_to
8271         iproc=itask_cont_to(ii)
8272         nn=ncont_sent(ii)
8273 c        write (iout,*) nn," contacts to processor",iproc,
8274 c     &   " of CONT_TO_COMM group"
8275         if (nn.gt.0) then
8276           ireq=ireq+1
8277           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
8278      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
8279 c          write (iout,*) "ireq,req",ireq,req(ireq)
8280 c          do i=1,nn
8281 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
8282 c          enddo
8283         endif
8284       enddo
8285 c      write (iout,*) "number of requests (contacts)",ireq
8286 c      write (iout,*) "req",(req(i),i=1,4)
8287 c      call flush(iout)
8288       if (ireq.gt.0)
8289      & call MPI_Waitall(ireq,req,status_array,ierr)
8290       do iii=1,ntask_cont_from
8291         iproc=itask_cont_from(iii)
8292         nn=ncont_recv(iii)
8293         if (lprn) then
8294         write (iout,*) "Received",nn," contacts from processor",iproc,
8295      &   " of CONT_FROM_COMM group"
8296         call flush(iout)
8297         do i=1,nn
8298           write(iout,'(2f5.0,10f10.5)')(zapas_recv(j,i,iii),j=1,10)
8299         enddo
8300         call flush(iout)
8301         endif
8302         do i=1,nn
8303           ii=zapas_recv(1,i,iii)
8304 c Flag the received contacts to prevent double-counting
8305           jj=-zapas_recv(2,i,iii)
8306 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
8307 c          call flush(iout)
8308           nnn=num_cont_hb(ii)+1
8309           num_cont_hb(ii)=nnn
8310           jcont_hb(nnn,ii)=jj
8311           d_cont(nnn,ii)=zapas_recv(3,i,iii)
8312           ind=3
8313           do kk=1,3
8314             ind=ind+1
8315             grij_hb_cont(kk,nnn,ii)=zapas_recv(ind,i,iii)
8316           enddo
8317           do kk=1,2
8318             do ll=1,2
8319               ind=ind+1
8320               a_chuj(ll,kk,nnn,ii)=zapas_recv(ind,i,iii)
8321             enddo
8322           enddo
8323           do jj=1,5
8324             do kk=1,3
8325               do ll=1,2
8326                 do mm=1,2
8327                   ind=ind+1
8328                   a_chuj_der(mm,ll,kk,jj,nnn,ii)=zapas_recv(ind,i,iii)
8329                 enddo
8330               enddo
8331             enddo
8332           enddo
8333         enddo
8334       enddo
8335       call flush(iout)
8336       if (lprn) then
8337         write (iout,'(a)') 'Contact function values after receive:'
8338         do i=nnt,nct-2
8339           write (iout,'(2i3,50(1x,i3,5f6.3))')
8340      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
8341      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
8342         enddo
8343         call flush(iout)
8344       endif
8345    30 continue
8346 #endif
8347       if (lprn) then
8348         write (iout,'(a)') 'Contact function values:'
8349         do i=nnt,nct-2
8350           write (iout,'(2i3,50(1x,i2,5f6.3))')
8351      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
8352      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
8353         enddo
8354       endif
8355       ecorr=0.0D0
8356       ecorr5=0.0d0
8357       ecorr6=0.0d0
8358 C Remove the loop below after debugging !!!
8359       do i=nnt,nct
8360         do j=1,3
8361           gradcorr(j,i)=0.0D0
8362           gradxorr(j,i)=0.0D0
8363         enddo
8364       enddo
8365 C Calculate the dipole-dipole interaction energies
8366       if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
8367       do i=iatel_s,iatel_e+1
8368         num_conti=num_cont_hb(i)
8369         do jj=1,num_conti
8370           j=jcont_hb(jj,i)
8371 #ifdef MOMENT
8372           call dipole(i,j,jj)
8373 #endif
8374         enddo
8375       enddo
8376       endif
8377 C Calculate the local-electrostatic correlation terms
8378 c                write (iout,*) "gradcorr5 in eello5 before loop"
8379 c                do iii=1,nres
8380 c                  write (iout,'(i5,3f10.5)')
8381 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
8382 c                enddo
8383       do i=min0(iatel_s,iturn4_start),max0(iatel_e+1,iturn3_end+1)
8384 c        write (iout,*) "corr loop i",i
8385         i1=i+1
8386         num_conti=num_cont_hb(i)
8387         num_conti1=num_cont_hb(i+1)
8388         do jj=1,num_conti
8389           j=jcont_hb(jj,i)
8390           jp=iabs(j)
8391           do kk=1,num_conti1
8392             j1=jcont_hb(kk,i1)
8393             jp1=iabs(j1)
8394 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
8395 c     &         ' jj=',jj,' kk=',kk
8396 c            if (j1.eq.j+1 .or. j1.eq.j-1) then
8397             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
8398      &          .or. j.lt.0 .and. j1.gt.0) .and.
8399      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
8400 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
8401 C The system gains extra energy.
8402               n_corr=n_corr+1
8403               sqd1=dsqrt(d_cont(jj,i))
8404               sqd2=dsqrt(d_cont(kk,i1))
8405               sred_geom = sqd1*sqd2
8406               IF (sred_geom.lt.cutoff_corr) THEN
8407                 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,
8408      &            ekont,fprimcont)
8409 cd               write (iout,*) 'i=',i,' j=',jp,' i1=',i1,' j1=',jp1,
8410 cd     &         ' jj=',jj,' kk=',kk
8411                 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
8412                 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
8413                 do l=1,3
8414                   g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
8415                   g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
8416                 enddo
8417                 n_corr1=n_corr1+1
8418 cd               write (iout,*) 'sred_geom=',sred_geom,
8419 cd     &          ' ekont=',ekont,' fprim=',fprimcont,
8420 cd     &          ' fac_prim1',fac_prim1,' fac_prim2',fac_prim2
8421 cd               write (iout,*) "g_contij",g_contij
8422 cd               write (iout,*) "grij_hb_cont i",grij_hb_cont(:,jj,i)
8423 cd               write (iout,*) "grij_hb_cont i1",grij_hb_cont(:,jj,i1)
8424                 call calc_eello(i,jp,i+1,jp1,jj,kk)
8425                 if (wcorr4.gt.0.0d0)
8426      &            ecorr=ecorr+eello4(i,jp,i+1,jp1,jj,kk)
8427                   if (energy_dec.and.wcorr4.gt.0.0d0)
8428      1                 write (iout,'(a6,4i5,0pf7.3)')
8429      2                'ecorr4',i,j,i+1,j1,eello4(i,jp,i+1,jp1,jj,kk)
8430 c                write (iout,*) "gradcorr5 before eello5"
8431 c                do iii=1,nres
8432 c                  write (iout,'(i5,3f10.5)')
8433 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
8434 c                enddo
8435                 if (wcorr5.gt.0.0d0)
8436      &            ecorr5=ecorr5+eello5(i,jp,i+1,jp1,jj,kk)
8437 c                write (iout,*) "gradcorr5 after eello5"
8438 c                do iii=1,nres
8439 c                  write (iout,'(i5,3f10.5)')
8440 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
8441 c                enddo
8442                   if (energy_dec.and.wcorr5.gt.0.0d0)
8443      1                 write (iout,'(a6,4i5,0pf7.3)')
8444      2                'ecorr5',i,j,i+1,j1,eello5(i,jp,i+1,jp1,jj,kk)
8445 cd                write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
8446 cd                write(2,*)'ijkl',i,jp,i+1,jp1
8447                 if (wcorr6.gt.0.0d0 .and. (jp.ne.i+4 .or. jp1.ne.i+3
8448      &               .or. wturn6.eq.0.0d0))then
8449 cd                  write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
8450                   ecorr6=ecorr6+eello6(i,jp,i+1,jp1,jj,kk)
8451                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
8452      1                'ecorr6',i,j,i+1,j1,eello6(i,jp,i+1,jp1,jj,kk)
8453 cd                write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
8454 cd     &            'ecorr6=',ecorr6
8455 cd                write (iout,'(4e15.5)') sred_geom,
8456 cd     &          dabs(eello4(i,jp,i+1,jp1,jj,kk)),
8457 cd     &          dabs(eello5(i,jp,i+1,jp1,jj,kk)),
8458 cd     &          dabs(eello6(i,jp,i+1,jp1,jj,kk))
8459                 else if (wturn6.gt.0.0d0
8460      &            .and. (jp.eq.i+4 .and. jp1.eq.i+3)) then
8461 cd                  write (iout,*) '******eturn6: i,j,i+1,j1',i,jip,i+1,jp1
8462                   eturn6=eturn6+eello_turn6(i,jj,kk)
8463                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
8464      1                 'eturn6',i,j,i+1,j1,eello_turn6(i,jj,kk)
8465 cd                  write (2,*) 'multibody_eello:eturn6',eturn6
8466                 endif
8467               ENDIF
8468 1111          continue
8469             endif
8470           enddo ! kk
8471         enddo ! jj
8472       enddo ! i
8473       do i=1,nres
8474         num_cont_hb(i)=num_cont_hb_old(i)
8475       enddo
8476 c                write (iout,*) "gradcorr5 in eello5"
8477 c                do iii=1,nres
8478 c                  write (iout,'(i5,3f10.5)')
8479 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
8480 c                enddo
8481       return
8482       end
8483 c------------------------------------------------------------------------------
8484       subroutine add_hb_contact_eello(ii,jj,itask)
8485       implicit real*8 (a-h,o-z)
8486       include "DIMENSIONS"
8487       include "COMMON.IOUNITS"
8488       integer max_cont
8489       integer max_dim
8490       parameter (max_cont=maxconts)
8491       parameter (max_dim=70)
8492       include "COMMON.CONTACTS"
8493       double precision zapas(max_dim,maxconts,max_fg_procs),
8494      &  zapas_recv(max_dim,maxconts,max_fg_procs)
8495       common /przechowalnia/ zapas
8496       integer i,j,ii,jj,iproc,itask(4),nn
8497 c      write (iout,*) "itask",itask
8498       do i=1,2
8499         iproc=itask(i)
8500         if (iproc.gt.0) then
8501           do j=1,num_cont_hb(ii)
8502             jjc=jcont_hb(j,ii)
8503 c            write (iout,*) "send turns i",ii," j",jj," jjc",jjc
8504             if (jjc.eq.jj) then
8505               ncont_sent(iproc)=ncont_sent(iproc)+1
8506               nn=ncont_sent(iproc)
8507               zapas(1,nn,iproc)=ii
8508               zapas(2,nn,iproc)=jjc
8509               zapas(3,nn,iproc)=d_cont(j,ii)
8510               ind=3
8511               do kk=1,3
8512                 ind=ind+1
8513                 zapas(ind,nn,iproc)=grij_hb_cont(kk,j,ii)
8514               enddo
8515               do kk=1,2
8516                 do ll=1,2
8517                   ind=ind+1
8518                   zapas(ind,nn,iproc)=a_chuj(ll,kk,j,ii)
8519                 enddo
8520               enddo
8521               do jj=1,5
8522                 do kk=1,3
8523                   do ll=1,2
8524                     do mm=1,2
8525                       ind=ind+1
8526                       zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,ii)
8527                     enddo
8528                   enddo
8529                 enddo
8530               enddo
8531               exit
8532             endif
8533           enddo
8534         endif
8535       enddo
8536       return
8537       end
8538 c------------------------------------------------------------------------------
8539       double precision function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
8540       implicit real*8 (a-h,o-z)
8541       include 'DIMENSIONS'
8542       include 'COMMON.IOUNITS'
8543       include 'COMMON.DERIV'
8544       include 'COMMON.INTERACT'
8545       include 'COMMON.CONTACTS'
8546       double precision gx(3),gx1(3)
8547       logical lprn
8548       lprn=.false.
8549       eij=facont_hb(jj,i)
8550       ekl=facont_hb(kk,k)
8551       ees0pij=ees0p(jj,i)
8552       ees0pkl=ees0p(kk,k)
8553       ees0mij=ees0m(jj,i)
8554       ees0mkl=ees0m(kk,k)
8555       ekont=eij*ekl
8556       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
8557 cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
8558 C Following 4 lines for diagnostics.
8559 cd    ees0pkl=0.0D0
8560 cd    ees0pij=1.0D0
8561 cd    ees0mkl=0.0D0
8562 cd    ees0mij=1.0D0
8563 c      write (iout,'(2(a,2i3,a,f10.5,a,2f10.5),a,f10.5,a,$)')
8564 c     & 'Contacts ',i,j,
8565 c     & ' eij',eij,' eesij',ees0pij,ees0mij,' and ',k,l
8566 c     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' energy=',ekont*ees,
8567 c     & 'gradcorr_long'
8568 C Calculate the multi-body contribution to energy.
8569 c      ecorr=ecorr+ekont*ees
8570 C Calculate multi-body contributions to the gradient.
8571       coeffpees0pij=coeffp*ees0pij
8572       coeffmees0mij=coeffm*ees0mij
8573       coeffpees0pkl=coeffp*ees0pkl
8574       coeffmees0mkl=coeffm*ees0mkl
8575       do ll=1,3
8576 cgrad        ghalfi=ees*ekl*gacont_hbr(ll,jj,i)
8577         gradcorr(ll,i)=gradcorr(ll,i)!+0.5d0*ghalfi
8578      &  -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+
8579      &  coeffmees0mkl*gacontm_hb1(ll,jj,i))
8580         gradcorr(ll,j)=gradcorr(ll,j)!+0.5d0*ghalfi
8581      &  -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+
8582      &  coeffmees0mkl*gacontm_hb2(ll,jj,i))
8583 cgrad        ghalfk=ees*eij*gacont_hbr(ll,kk,k)
8584         gradcorr(ll,k)=gradcorr(ll,k)!+0.5d0*ghalfk
8585      &  -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+
8586      &  coeffmees0mij*gacontm_hb1(ll,kk,k))
8587         gradcorr(ll,l)=gradcorr(ll,l)!+0.5d0*ghalfk
8588      &  -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+
8589      &  coeffmees0mij*gacontm_hb2(ll,kk,k))
8590         gradlongij=ees*ekl*gacont_hbr(ll,jj,i)-
8591      &     ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+
8592      &     coeffmees0mkl*gacontm_hb3(ll,jj,i))
8593         gradcorr_long(ll,j)=gradcorr_long(ll,j)+gradlongij
8594         gradcorr_long(ll,i)=gradcorr_long(ll,i)-gradlongij
8595         gradlongkl=ees*eij*gacont_hbr(ll,kk,k)-
8596      &     ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+
8597      &     coeffmees0mij*gacontm_hb3(ll,kk,k))
8598         gradcorr_long(ll,l)=gradcorr_long(ll,l)+gradlongkl
8599         gradcorr_long(ll,k)=gradcorr_long(ll,k)-gradlongkl
8600 c        write (iout,'(2f10.5,2x,$)') gradlongij,gradlongkl
8601       enddo
8602 c      write (iout,*)
8603 cgrad      do m=i+1,j-1
8604 cgrad        do ll=1,3
8605 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
8606 cgrad     &     ees*ekl*gacont_hbr(ll,jj,i)-
8607 cgrad     &     ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
8608 cgrad     &     coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
8609 cgrad        enddo
8610 cgrad      enddo
8611 cgrad      do m=k+1,l-1
8612 cgrad        do ll=1,3
8613 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
8614 cgrad     &     ees*eij*gacont_hbr(ll,kk,k)-
8615 cgrad     &     ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
8616 cgrad     &     coeffm*ees0mij*gacontm_hb3(ll,kk,k))
8617 cgrad        enddo
8618 cgrad      enddo
8619 c      write (iout,*) "ehbcorr",ekont*ees
8620       ehbcorr=ekont*ees
8621       return
8622       end
8623 #ifdef MOMENT
8624 C---------------------------------------------------------------------------
8625       subroutine dipole(i,j,jj)
8626       implicit real*8 (a-h,o-z)
8627       include 'DIMENSIONS'
8628       include 'COMMON.IOUNITS'
8629       include 'COMMON.CHAIN'
8630       include 'COMMON.FFIELD'
8631       include 'COMMON.DERIV'
8632       include 'COMMON.INTERACT'
8633       include 'COMMON.CONTACTS'
8634       include 'COMMON.TORSION'
8635       include 'COMMON.VAR'
8636       include 'COMMON.GEO'
8637       dimension dipi(2,2),dipj(2,2),dipderi(2),dipderj(2),auxvec(2),
8638      &  auxmat(2,2)
8639       iti1 = itortyp(itype(i+1))
8640       if (j.lt.nres-1) then
8641         itj1 = itortyp(itype(j+1))
8642       else
8643         itj1=ntortyp
8644       endif
8645       do iii=1,2
8646         dipi(iii,1)=Ub2(iii,i)
8647         dipderi(iii)=Ub2der(iii,i)
8648         dipi(iii,2)=b1(iii,i+1)
8649         dipj(iii,1)=Ub2(iii,j)
8650         dipderj(iii)=Ub2der(iii,j)
8651         dipj(iii,2)=b1(iii,j+1)
8652       enddo
8653       kkk=0
8654       do iii=1,2
8655         call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
8656         do jjj=1,2
8657           kkk=kkk+1
8658           dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
8659         enddo
8660       enddo
8661       do kkk=1,5
8662         do lll=1,3
8663           mmm=0
8664           do iii=1,2
8665             call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),
8666      &        auxvec(1))
8667             do jjj=1,2
8668               mmm=mmm+1
8669               dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
8670             enddo
8671           enddo
8672         enddo
8673       enddo
8674       call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
8675       call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
8676       do iii=1,2
8677         dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
8678       enddo
8679       call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
8680       do iii=1,2
8681         dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
8682       enddo
8683       return
8684       end
8685 #endif
8686 C---------------------------------------------------------------------------
8687       subroutine calc_eello(i,j,k,l,jj,kk)
8688 C
8689 C This subroutine computes matrices and vectors needed to calculate
8690 C the fourth-, fifth-, and sixth-order local-electrostatic terms.
8691 C
8692       implicit real*8 (a-h,o-z)
8693       include 'DIMENSIONS'
8694       include 'COMMON.IOUNITS'
8695       include 'COMMON.CHAIN'
8696       include 'COMMON.DERIV'
8697       include 'COMMON.INTERACT'
8698       include 'COMMON.CONTACTS'
8699       include 'COMMON.TORSION'
8700       include 'COMMON.VAR'
8701       include 'COMMON.GEO'
8702       include 'COMMON.FFIELD'
8703       double precision aa1(2,2),aa2(2,2),aa1t(2,2),aa2t(2,2),
8704      &  aa1tder(2,2,3,5),aa2tder(2,2,3,5),auxmat(2,2)
8705       logical lprn
8706       common /kutas/ lprn
8707 cd      write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
8708 cd     & ' jj=',jj,' kk=',kk
8709 cd      if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
8710 cd      write (iout,*) "a_chujij",((a_chuj(iii,jjj,jj,i),iii=1,2),jjj=1,2)
8711 cd      write (iout,*) "a_chujkl",((a_chuj(iii,jjj,kk,k),iii=1,2),jjj=1,2)
8712       do iii=1,2
8713         do jjj=1,2
8714           aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
8715           aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
8716         enddo
8717       enddo
8718       call transpose2(aa1(1,1),aa1t(1,1))
8719       call transpose2(aa2(1,1),aa2t(1,1))
8720       do kkk=1,5
8721         do lll=1,3
8722           call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),
8723      &      aa1tder(1,1,lll,kkk))
8724           call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),
8725      &      aa2tder(1,1,lll,kkk))
8726         enddo
8727       enddo
8728       if (l.eq.j+1) then
8729 C parallel orientation of the two CA-CA-CA frames.
8730         if (i.gt.1) then
8731           iti=itortyp(itype(i))
8732         else
8733           iti=ntortyp
8734         endif
8735         itk1=itortyp(itype(k+1))
8736         itj=itortyp(itype(j))
8737         if (l.lt.nres-1) then
8738           itl1=itortyp(itype(l+1))
8739         else
8740           itl1=ntortyp
8741         endif
8742 C A1 kernel(j+1) A2T
8743 cd        do iii=1,2
8744 cd          write (iout,'(3f10.5,5x,3f10.5)')
8745 cd     &     (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
8746 cd        enddo
8747         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
8748      &   aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),
8749      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
8750 C Following matrices are needed only for 6-th order cumulants
8751         IF (wcorr6.gt.0.0d0) THEN
8752         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
8753      &   aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),
8754      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
8755         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
8756      &   aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),
8757      &   Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
8758      &   ADtEAderx(1,1,1,1,1,1))
8759         lprn=.false.
8760         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
8761      &   aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),
8762      &   DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
8763      &   ADtEA1derx(1,1,1,1,1,1))
8764         ENDIF
8765 C End 6-th order cumulants
8766 cd        lprn=.false.
8767 cd        if (lprn) then
8768 cd        write (2,*) 'In calc_eello6'
8769 cd        do iii=1,2
8770 cd          write (2,*) 'iii=',iii
8771 cd          do kkk=1,5
8772 cd            write (2,*) 'kkk=',kkk
8773 cd            do jjj=1,2
8774 cd              write (2,'(3(2f10.5),5x)')
8775 cd     &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
8776 cd            enddo
8777 cd          enddo
8778 cd        enddo
8779 cd        endif
8780         call transpose2(EUgder(1,1,k),auxmat(1,1))
8781         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
8782         call transpose2(EUg(1,1,k),auxmat(1,1))
8783         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
8784         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
8785         do iii=1,2
8786           do kkk=1,5
8787             do lll=1,3
8788               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
8789      &          EAEAderx(1,1,lll,kkk,iii,1))
8790             enddo
8791           enddo
8792         enddo
8793 C A1T kernel(i+1) A2
8794         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
8795      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),
8796      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
8797 C Following matrices are needed only for 6-th order cumulants
8798         IF (wcorr6.gt.0.0d0) THEN
8799         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
8800      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),
8801      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
8802         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
8803      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),
8804      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
8805      &   ADtEAderx(1,1,1,1,1,2))
8806         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
8807      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),
8808      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
8809      &   ADtEA1derx(1,1,1,1,1,2))
8810         ENDIF
8811 C End 6-th order cumulants
8812         call transpose2(EUgder(1,1,l),auxmat(1,1))
8813         call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
8814         call transpose2(EUg(1,1,l),auxmat(1,1))
8815         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
8816         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
8817         do iii=1,2
8818           do kkk=1,5
8819             do lll=1,3
8820               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
8821      &          EAEAderx(1,1,lll,kkk,iii,2))
8822             enddo
8823           enddo
8824         enddo
8825 C AEAb1 and AEAb2
8826 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
8827 C They are needed only when the fifth- or the sixth-order cumulants are
8828 C indluded.
8829         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
8830         call transpose2(AEA(1,1,1),auxmat(1,1))
8831         call matvec2(auxmat(1,1),b1(1,i),AEAb1(1,1,1))
8832         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
8833         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
8834         call transpose2(AEAderg(1,1,1),auxmat(1,1))
8835         call matvec2(auxmat(1,1),b1(1,i),AEAb1derg(1,1,1))
8836         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
8837         call matvec2(AEA(1,1,1),b1(1,k+1),AEAb1(1,2,1))
8838         call matvec2(AEAderg(1,1,1),b1(1,k+1),AEAb1derg(1,2,1))
8839         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
8840         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
8841         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
8842         call transpose2(AEA(1,1,2),auxmat(1,1))
8843         call matvec2(auxmat(1,1),b1(1,j),AEAb1(1,1,2))
8844         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
8845         call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
8846         call transpose2(AEAderg(1,1,2),auxmat(1,1))
8847         call matvec2(auxmat(1,1),b1(1,j),AEAb1derg(1,1,2))
8848         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
8849         call matvec2(AEA(1,1,2),b1(1,l+1),AEAb1(1,2,2))
8850         call matvec2(AEAderg(1,1,2),b1(1,l+1),AEAb1derg(1,2,2))
8851         call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
8852         call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
8853         call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
8854 C Calculate the Cartesian derivatives of the vectors.
8855         do iii=1,2
8856           do kkk=1,5
8857             do lll=1,3
8858               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
8859               call matvec2(auxmat(1,1),b1(1,i),
8860      &          AEAb1derx(1,lll,kkk,iii,1,1))
8861               call matvec2(auxmat(1,1),Ub2(1,i),
8862      &          AEAb2derx(1,lll,kkk,iii,1,1))
8863               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
8864      &          AEAb1derx(1,lll,kkk,iii,2,1))
8865               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
8866      &          AEAb2derx(1,lll,kkk,iii,2,1))
8867               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
8868               call matvec2(auxmat(1,1),b1(1,j),
8869      &          AEAb1derx(1,lll,kkk,iii,1,2))
8870               call matvec2(auxmat(1,1),Ub2(1,j),
8871      &          AEAb2derx(1,lll,kkk,iii,1,2))
8872               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,l+1),
8873      &          AEAb1derx(1,lll,kkk,iii,2,2))
8874               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),
8875      &          AEAb2derx(1,lll,kkk,iii,2,2))
8876             enddo
8877           enddo
8878         enddo
8879         ENDIF
8880 C End vectors
8881       else
8882 C Antiparallel orientation of the two CA-CA-CA frames.
8883         if (i.gt.1) then
8884           iti=itortyp(itype(i))
8885         else
8886           iti=ntortyp
8887         endif
8888         itk1=itortyp(itype(k+1))
8889         itl=itortyp(itype(l))
8890         itj=itortyp(itype(j))
8891         if (j.lt.nres-1) then
8892           itj1=itortyp(itype(j+1))
8893         else
8894           itj1=ntortyp
8895         endif
8896 C A2 kernel(j-1)T A1T
8897         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
8898      &   aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),
8899      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
8900 C Following matrices are needed only for 6-th order cumulants
8901         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
8902      &     j.eq.i+4 .and. l.eq.i+3)) THEN
8903         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
8904      &   aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),
8905      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
8906         call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
8907      &   aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),
8908      &   Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
8909      &   ADtEAderx(1,1,1,1,1,1))
8910         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
8911      &   aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),
8912      &   DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
8913      &   ADtEA1derx(1,1,1,1,1,1))
8914         ENDIF
8915 C End 6-th order cumulants
8916         call transpose2(EUgder(1,1,k),auxmat(1,1))
8917         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
8918         call transpose2(EUg(1,1,k),auxmat(1,1))
8919         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
8920         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
8921         do iii=1,2
8922           do kkk=1,5
8923             do lll=1,3
8924               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
8925      &          EAEAderx(1,1,lll,kkk,iii,1))
8926             enddo
8927           enddo
8928         enddo
8929 C A2T kernel(i+1)T A1
8930         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
8931      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),
8932      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
8933 C Following matrices are needed only for 6-th order cumulants
8934         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
8935      &     j.eq.i+4 .and. l.eq.i+3)) THEN
8936         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
8937      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),
8938      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
8939         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
8940      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),
8941      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
8942      &   ADtEAderx(1,1,1,1,1,2))
8943         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
8944      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),
8945      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
8946      &   ADtEA1derx(1,1,1,1,1,2))
8947         ENDIF
8948 C End 6-th order cumulants
8949         call transpose2(EUgder(1,1,j),auxmat(1,1))
8950         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
8951         call transpose2(EUg(1,1,j),auxmat(1,1))
8952         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
8953         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
8954         do iii=1,2
8955           do kkk=1,5
8956             do lll=1,3
8957               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
8958      &          EAEAderx(1,1,lll,kkk,iii,2))
8959             enddo
8960           enddo
8961         enddo
8962 C AEAb1 and AEAb2
8963 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
8964 C They are needed only when the fifth- or the sixth-order cumulants are
8965 C indluded.
8966         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or.
8967      &    (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
8968         call transpose2(AEA(1,1,1),auxmat(1,1))
8969         call matvec2(auxmat(1,1),b1(1,i),AEAb1(1,1,1))
8970         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
8971         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
8972         call transpose2(AEAderg(1,1,1),auxmat(1,1))
8973         call matvec2(auxmat(1,1),b1(1,i),AEAb1derg(1,1,1))
8974         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
8975         call matvec2(AEA(1,1,1),b1(1,k+1),AEAb1(1,2,1))
8976         call matvec2(AEAderg(1,1,1),b1(1,k+1),AEAb1derg(1,2,1))
8977         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
8978         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
8979         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
8980         call transpose2(AEA(1,1,2),auxmat(1,1))
8981         call matvec2(auxmat(1,1),b1(1,j+1),AEAb1(1,1,2))
8982         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
8983         call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
8984         call transpose2(AEAderg(1,1,2),auxmat(1,1))
8985         call matvec2(auxmat(1,1),b1(1,l),AEAb1(1,1,2))
8986         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
8987         call matvec2(AEA(1,1,2),b1(1,j+1),AEAb1(1,2,2))
8988         call matvec2(AEAderg(1,1,2),b1(1,j+1),AEAb1derg(1,2,2))
8989         call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
8990         call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
8991         call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
8992 C Calculate the Cartesian derivatives of the vectors.
8993         do iii=1,2
8994           do kkk=1,5
8995             do lll=1,3
8996               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
8997               call matvec2(auxmat(1,1),b1(1,i),
8998      &          AEAb1derx(1,lll,kkk,iii,1,1))
8999               call matvec2(auxmat(1,1),Ub2(1,i),
9000      &          AEAb2derx(1,lll,kkk,iii,1,1))
9001               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
9002      &          AEAb1derx(1,lll,kkk,iii,2,1))
9003               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
9004      &          AEAb2derx(1,lll,kkk,iii,2,1))
9005               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
9006               call matvec2(auxmat(1,1),b1(1,l),
9007      &          AEAb1derx(1,lll,kkk,iii,1,2))
9008               call matvec2(auxmat(1,1),Ub2(1,l),
9009      &          AEAb2derx(1,lll,kkk,iii,1,2))
9010               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,j+1),
9011      &          AEAb1derx(1,lll,kkk,iii,2,2))
9012               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),
9013      &          AEAb2derx(1,lll,kkk,iii,2,2))
9014             enddo
9015           enddo
9016         enddo
9017         ENDIF
9018 C End vectors
9019       endif
9020       return
9021       end
9022 C---------------------------------------------------------------------------
9023       subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,
9024      &  KK,KKderg,AKA,AKAderg,AKAderx)
9025       implicit none
9026       integer nderg
9027       logical transp
9028       double precision aa1(2,2),aa2t(2,2),aa1derx(2,2,3,5),
9029      &  aa2tderx(2,2,3,5),KK(2,2),KKderg(2,2,nderg),AKA(2,2),
9030      &  AKAderg(2,2,nderg),AKAderx(2,2,3,5,2)
9031       integer iii,kkk,lll
9032       integer jjj,mmm
9033       logical lprn
9034       common /kutas/ lprn
9035       call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
9036       do iii=1,nderg
9037         call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,
9038      &    AKAderg(1,1,iii))
9039       enddo
9040 cd      if (lprn) write (2,*) 'In kernel'
9041       do kkk=1,5
9042 cd        if (lprn) write (2,*) 'kkk=',kkk
9043         do lll=1,3
9044           call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),
9045      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
9046 cd          if (lprn) then
9047 cd            write (2,*) 'lll=',lll
9048 cd            write (2,*) 'iii=1'
9049 cd            do jjj=1,2
9050 cd              write (2,'(3(2f10.5),5x)')
9051 cd     &        (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
9052 cd            enddo
9053 cd          endif
9054           call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),
9055      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
9056 cd          if (lprn) then
9057 cd            write (2,*) 'lll=',lll
9058 cd            write (2,*) 'iii=2'
9059 cd            do jjj=1,2
9060 cd              write (2,'(3(2f10.5),5x)')
9061 cd     &        (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
9062 cd            enddo
9063 cd          endif
9064         enddo
9065       enddo
9066       return
9067       end
9068 C---------------------------------------------------------------------------
9069       double precision function eello4(i,j,k,l,jj,kk)
9070       implicit real*8 (a-h,o-z)
9071       include 'DIMENSIONS'
9072       include 'COMMON.IOUNITS'
9073       include 'COMMON.CHAIN'
9074       include 'COMMON.DERIV'
9075       include 'COMMON.INTERACT'
9076       include 'COMMON.CONTACTS'
9077       include 'COMMON.TORSION'
9078       include 'COMMON.VAR'
9079       include 'COMMON.GEO'
9080       double precision pizda(2,2),ggg1(3),ggg2(3)
9081 cd      if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
9082 cd        eello4=0.0d0
9083 cd        return
9084 cd      endif
9085 cd      print *,'eello4:',i,j,k,l,jj,kk
9086 cd      write (2,*) 'i',i,' j',j,' k',k,' l',l
9087 cd      call checkint4(i,j,k,l,jj,kk,eel4_num)
9088 cold      eij=facont_hb(jj,i)
9089 cold      ekl=facont_hb(kk,k)
9090 cold      ekont=eij*ekl
9091       eel4=-EAEA(1,1,1)-EAEA(2,2,1)
9092 cd      eel41=-EAEA(1,1,2)-EAEA(2,2,2)
9093       gcorr_loc(k-1)=gcorr_loc(k-1)
9094      &   -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
9095       if (l.eq.j+1) then
9096         gcorr_loc(l-1)=gcorr_loc(l-1)
9097      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
9098       else
9099         gcorr_loc(j-1)=gcorr_loc(j-1)
9100      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
9101       endif
9102       do iii=1,2
9103         do kkk=1,5
9104           do lll=1,3
9105             derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1)
9106      &                        -EAEAderx(2,2,lll,kkk,iii,1)
9107 cd            derx(lll,kkk,iii)=0.0d0
9108           enddo
9109         enddo
9110       enddo
9111 cd      gcorr_loc(l-1)=0.0d0
9112 cd      gcorr_loc(j-1)=0.0d0
9113 cd      gcorr_loc(k-1)=0.0d0
9114 cd      eel4=1.0d0
9115 cd      write (iout,*)'Contacts have occurred for peptide groups',
9116 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l,
9117 cd     &  ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
9118       if (j.lt.nres-1) then
9119         j1=j+1
9120         j2=j-1
9121       else
9122         j1=j-1
9123         j2=j-2
9124       endif
9125       if (l.lt.nres-1) then
9126         l1=l+1
9127         l2=l-1
9128       else
9129         l1=l-1
9130         l2=l-2
9131       endif
9132       do ll=1,3
9133 cgrad        ggg1(ll)=eel4*g_contij(ll,1)
9134 cgrad        ggg2(ll)=eel4*g_contij(ll,2)
9135         glongij=eel4*g_contij(ll,1)+ekont*derx(ll,1,1)
9136         glongkl=eel4*g_contij(ll,2)+ekont*derx(ll,1,2)
9137 cgrad        ghalf=0.5d0*ggg1(ll)
9138         gradcorr(ll,i)=gradcorr(ll,i)+ekont*derx(ll,2,1)
9139         gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
9140         gradcorr(ll,j)=gradcorr(ll,j)+ekont*derx(ll,4,1)
9141         gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
9142         gradcorr_long(ll,j)=gradcorr_long(ll,j)+glongij
9143         gradcorr_long(ll,i)=gradcorr_long(ll,i)-glongij
9144 cgrad        ghalf=0.5d0*ggg2(ll)
9145         gradcorr(ll,k)=gradcorr(ll,k)+ekont*derx(ll,2,2)
9146         gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
9147         gradcorr(ll,l)=gradcorr(ll,l)+ekont*derx(ll,4,2)
9148         gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
9149         gradcorr_long(ll,l)=gradcorr_long(ll,l)+glongkl
9150         gradcorr_long(ll,k)=gradcorr_long(ll,k)-glongkl
9151       enddo
9152 cgrad      do m=i+1,j-1
9153 cgrad        do ll=1,3
9154 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
9155 cgrad        enddo
9156 cgrad      enddo
9157 cgrad      do m=k+1,l-1
9158 cgrad        do ll=1,3
9159 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
9160 cgrad        enddo
9161 cgrad      enddo
9162 cgrad      do m=i+2,j2
9163 cgrad        do ll=1,3
9164 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
9165 cgrad        enddo
9166 cgrad      enddo
9167 cgrad      do m=k+2,l2
9168 cgrad        do ll=1,3
9169 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
9170 cgrad        enddo
9171 cgrad      enddo
9172 cd      do iii=1,nres-3
9173 cd        write (2,*) iii,gcorr_loc(iii)
9174 cd      enddo
9175       eello4=ekont*eel4
9176 cd      write (2,*) 'ekont',ekont
9177 cd      write (iout,*) 'eello4',ekont*eel4
9178       return
9179       end
9180 C---------------------------------------------------------------------------
9181       double precision function eello5(i,j,k,l,jj,kk)
9182       implicit real*8 (a-h,o-z)
9183       include 'DIMENSIONS'
9184       include 'COMMON.IOUNITS'
9185       include 'COMMON.CHAIN'
9186       include 'COMMON.DERIV'
9187       include 'COMMON.INTERACT'
9188       include 'COMMON.CONTACTS'
9189       include 'COMMON.TORSION'
9190       include 'COMMON.VAR'
9191       include 'COMMON.GEO'
9192       double precision pizda(2,2),auxmat(2,2),auxmat1(2,2),vv(2)
9193       double precision ggg1(3),ggg2(3)
9194 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9195 C                                                                              C
9196 C                            Parallel chains                                   C
9197 C                                                                              C
9198 C          o             o                   o             o                   C
9199 C         /l\           / \             \   / \           / \   /              C
9200 C        /   \         /   \             \ /   \         /   \ /               C
9201 C       j| o |l1       | o |              o| o |         | o |o                C
9202 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
9203 C      \i/   \         /   \ /             /   \         /   \                 C
9204 C       o    k1             o                                                  C
9205 C         (I)          (II)                (III)          (IV)                 C
9206 C                                                                              C
9207 C      eello5_1        eello5_2            eello5_3       eello5_4             C
9208 C                                                                              C
9209 C                            Antiparallel chains                               C
9210 C                                                                              C
9211 C          o             o                   o             o                   C
9212 C         /j\           / \             \   / \           / \   /              C
9213 C        /   \         /   \             \ /   \         /   \ /               C
9214 C      j1| o |l        | o |              o| o |         | o |o                C
9215 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
9216 C      \i/   \         /   \ /             /   \         /   \                 C
9217 C       o     k1            o                                                  C
9218 C         (I)          (II)                (III)          (IV)                 C
9219 C                                                                              C
9220 C      eello5_1        eello5_2            eello5_3       eello5_4             C
9221 C                                                                              C
9222 C o denotes a local interaction, vertical lines an electrostatic interaction.  C
9223 C                                                                              C
9224 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9225 cd      if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
9226 cd        eello5=0.0d0
9227 cd        return
9228 cd      endif
9229 cd      write (iout,*)
9230 cd     &   'EELLO5: Contacts have occurred for peptide groups',i,j,
9231 cd     &   ' and',k,l
9232       itk=itortyp(itype(k))
9233       itl=itortyp(itype(l))
9234       itj=itortyp(itype(j))
9235       eello5_1=0.0d0
9236       eello5_2=0.0d0
9237       eello5_3=0.0d0
9238       eello5_4=0.0d0
9239 cd      call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
9240 cd     &   eel5_3_num,eel5_4_num)
9241       do iii=1,2
9242         do kkk=1,5
9243           do lll=1,3
9244             derx(lll,kkk,iii)=0.0d0
9245           enddo
9246         enddo
9247       enddo
9248 cd      eij=facont_hb(jj,i)
9249 cd      ekl=facont_hb(kk,k)
9250 cd      ekont=eij*ekl
9251 cd      write (iout,*)'Contacts have occurred for peptide groups',
9252 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l
9253 cd      goto 1111
9254 C Contribution from the graph I.
9255 cd      write (2,*) 'AEA  ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
9256 cd      write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
9257       call transpose2(EUg(1,1,k),auxmat(1,1))
9258       call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
9259       vv(1)=pizda(1,1)-pizda(2,2)
9260       vv(2)=pizda(1,2)+pizda(2,1)
9261       eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k))
9262      & +0.5d0*scalar2(vv(1),Dtobr2(1,i))
9263 C Explicit gradient in virtual-dihedral angles.
9264       if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1)
9265      & +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k))
9266      & +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
9267       call transpose2(EUgder(1,1,k),auxmat1(1,1))
9268       call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
9269       vv(1)=pizda(1,1)-pizda(2,2)
9270       vv(2)=pizda(1,2)+pizda(2,1)
9271       g_corr5_loc(k-1)=g_corr5_loc(k-1)
9272      & +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k))
9273      & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
9274       call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
9275       vv(1)=pizda(1,1)-pizda(2,2)
9276       vv(2)=pizda(1,2)+pizda(2,1)
9277       if (l.eq.j+1) then
9278         if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1)
9279      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
9280      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
9281       else
9282         if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1)
9283      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
9284      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
9285       endif
9286 C Cartesian gradient
9287       do iii=1,2
9288         do kkk=1,5
9289           do lll=1,3
9290             call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),
9291      &        pizda(1,1))
9292             vv(1)=pizda(1,1)-pizda(2,2)
9293             vv(2)=pizda(1,2)+pizda(2,1)
9294             derx(lll,kkk,iii)=derx(lll,kkk,iii)
9295      &       +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k))
9296      &       +0.5d0*scalar2(vv(1),Dtobr2(1,i))
9297           enddo
9298         enddo
9299       enddo
9300 c      goto 1112
9301 c1111  continue
9302 C Contribution from graph II
9303       call transpose2(EE(1,1,itk),auxmat(1,1))
9304       call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
9305       vv(1)=pizda(1,1)+pizda(2,2)
9306       vv(2)=pizda(2,1)-pizda(1,2)
9307       eello5_2=scalar2(AEAb1(1,2,1),b1(1,k))
9308      & -0.5d0*scalar2(vv(1),Ctobr(1,k))
9309 C Explicit gradient in virtual-dihedral angles.
9310       g_corr5_loc(k-1)=g_corr5_loc(k-1)
9311      & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
9312       call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
9313       vv(1)=pizda(1,1)+pizda(2,2)
9314       vv(2)=pizda(2,1)-pizda(1,2)
9315       if (l.eq.j+1) then
9316         g_corr5_loc(l-1)=g_corr5_loc(l-1)
9317      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,k))
9318      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
9319       else
9320         g_corr5_loc(j-1)=g_corr5_loc(j-1)
9321      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,k))
9322      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
9323       endif
9324 C Cartesian gradient
9325       do iii=1,2
9326         do kkk=1,5
9327           do lll=1,3
9328             call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
9329      &        pizda(1,1))
9330             vv(1)=pizda(1,1)+pizda(2,2)
9331             vv(2)=pizda(2,1)-pizda(1,2)
9332             derx(lll,kkk,iii)=derx(lll,kkk,iii)
9333      &       +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,k))
9334      &       -0.5d0*scalar2(vv(1),Ctobr(1,k))
9335           enddo
9336         enddo
9337       enddo
9338 cd      goto 1112
9339 cd1111  continue
9340       if (l.eq.j+1) then
9341 cd        goto 1110
9342 C Parallel orientation
9343 C Contribution from graph III
9344         call transpose2(EUg(1,1,l),auxmat(1,1))
9345         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
9346         vv(1)=pizda(1,1)-pizda(2,2)
9347         vv(2)=pizda(1,2)+pizda(2,1)
9348         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l))
9349      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j))
9350 C Explicit gradient in virtual-dihedral angles.
9351         g_corr5_loc(j-1)=g_corr5_loc(j-1)
9352      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l))
9353      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
9354         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
9355         vv(1)=pizda(1,1)-pizda(2,2)
9356         vv(2)=pizda(1,2)+pizda(2,1)
9357         g_corr5_loc(k-1)=g_corr5_loc(k-1)
9358      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l))
9359      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
9360         call transpose2(EUgder(1,1,l),auxmat1(1,1))
9361         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
9362         vv(1)=pizda(1,1)-pizda(2,2)
9363         vv(2)=pizda(1,2)+pizda(2,1)
9364         g_corr5_loc(l-1)=g_corr5_loc(l-1)
9365      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l))
9366      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
9367 C Cartesian gradient
9368         do iii=1,2
9369           do kkk=1,5
9370             do lll=1,3
9371               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
9372      &          pizda(1,1))
9373               vv(1)=pizda(1,1)-pizda(2,2)
9374               vv(2)=pizda(1,2)+pizda(2,1)
9375               derx(lll,kkk,iii)=derx(lll,kkk,iii)
9376      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l))
9377      &         +0.5d0*scalar2(vv(1),Dtobr2(1,j))
9378             enddo
9379           enddo
9380         enddo
9381 cd        goto 1112
9382 C Contribution from graph IV
9383 cd1110    continue
9384         call transpose2(EE(1,1,itl),auxmat(1,1))
9385         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
9386         vv(1)=pizda(1,1)+pizda(2,2)
9387         vv(2)=pizda(2,1)-pizda(1,2)
9388         eello5_4=scalar2(AEAb1(1,2,2),b1(1,l))
9389      &   -0.5d0*scalar2(vv(1),Ctobr(1,l))
9390 C Explicit gradient in virtual-dihedral angles.
9391         g_corr5_loc(l-1)=g_corr5_loc(l-1)
9392      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
9393         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
9394         vv(1)=pizda(1,1)+pizda(2,2)
9395         vv(2)=pizda(2,1)-pizda(1,2)
9396         g_corr5_loc(k-1)=g_corr5_loc(k-1)
9397      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,l))
9398      &   -0.5d0*scalar2(vv(1),Ctobr(1,l)))
9399 C Cartesian gradient
9400         do iii=1,2
9401           do kkk=1,5
9402             do lll=1,3
9403               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
9404      &          pizda(1,1))
9405               vv(1)=pizda(1,1)+pizda(2,2)
9406               vv(2)=pizda(2,1)-pizda(1,2)
9407               derx(lll,kkk,iii)=derx(lll,kkk,iii)
9408      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,l))
9409      &         -0.5d0*scalar2(vv(1),Ctobr(1,l))
9410             enddo
9411           enddo
9412         enddo
9413       else
9414 C Antiparallel orientation
9415 C Contribution from graph III
9416 c        goto 1110
9417         call transpose2(EUg(1,1,j),auxmat(1,1))
9418         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
9419         vv(1)=pizda(1,1)-pizda(2,2)
9420         vv(2)=pizda(1,2)+pizda(2,1)
9421         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j))
9422      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l))
9423 C Explicit gradient in virtual-dihedral angles.
9424         g_corr5_loc(l-1)=g_corr5_loc(l-1)
9425      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j))
9426      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
9427         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
9428         vv(1)=pizda(1,1)-pizda(2,2)
9429         vv(2)=pizda(1,2)+pizda(2,1)
9430         g_corr5_loc(k-1)=g_corr5_loc(k-1)
9431      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j))
9432      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
9433         call transpose2(EUgder(1,1,j),auxmat1(1,1))
9434         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
9435         vv(1)=pizda(1,1)-pizda(2,2)
9436         vv(2)=pizda(1,2)+pizda(2,1)
9437         g_corr5_loc(j-1)=g_corr5_loc(j-1)
9438      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j))
9439      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
9440 C Cartesian gradient
9441         do iii=1,2
9442           do kkk=1,5
9443             do lll=1,3
9444               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
9445      &          pizda(1,1))
9446               vv(1)=pizda(1,1)-pizda(2,2)
9447               vv(2)=pizda(1,2)+pizda(2,1)
9448               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
9449      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j))
9450      &         +0.5d0*scalar2(vv(1),Dtobr2(1,l))
9451             enddo
9452           enddo
9453         enddo
9454 cd        goto 1112
9455 C Contribution from graph IV
9456 1110    continue
9457         call transpose2(EE(1,1,itj),auxmat(1,1))
9458         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
9459         vv(1)=pizda(1,1)+pizda(2,2)
9460         vv(2)=pizda(2,1)-pizda(1,2)
9461         eello5_4=scalar2(AEAb1(1,2,2),b1(1,j))
9462      &   -0.5d0*scalar2(vv(1),Ctobr(1,j))
9463 C Explicit gradient in virtual-dihedral angles.
9464         g_corr5_loc(j-1)=g_corr5_loc(j-1)
9465      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
9466         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
9467         vv(1)=pizda(1,1)+pizda(2,2)
9468         vv(2)=pizda(2,1)-pizda(1,2)
9469         g_corr5_loc(k-1)=g_corr5_loc(k-1)
9470      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,j))
9471      &   -0.5d0*scalar2(vv(1),Ctobr(1,j)))
9472 C Cartesian gradient
9473         do iii=1,2
9474           do kkk=1,5
9475             do lll=1,3
9476               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
9477      &          pizda(1,1))
9478               vv(1)=pizda(1,1)+pizda(2,2)
9479               vv(2)=pizda(2,1)-pizda(1,2)
9480               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
9481      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,j))
9482      &         -0.5d0*scalar2(vv(1),Ctobr(1,j))
9483             enddo
9484           enddo
9485         enddo
9486       endif
9487 1112  continue
9488       eel5=eello5_1+eello5_2+eello5_3+eello5_4
9489 cd      if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
9490 cd        write (2,*) 'ijkl',i,j,k,l
9491 cd        write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
9492 cd     &     ' eello5_3',eello5_3,' eello5_4',eello5_4
9493 cd      endif
9494 cd      write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
9495 cd      write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
9496 cd      write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
9497 cd      write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
9498       if (j.lt.nres-1) then
9499         j1=j+1
9500         j2=j-1
9501       else
9502         j1=j-1
9503         j2=j-2
9504       endif
9505       if (l.lt.nres-1) then
9506         l1=l+1
9507         l2=l-1
9508       else
9509         l1=l-1
9510         l2=l-2
9511       endif
9512 cd      eij=1.0d0
9513 cd      ekl=1.0d0
9514 cd      ekont=1.0d0
9515 cd      write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
9516 C 2/11/08 AL Gradients over DC's connecting interacting sites will be
9517 C        summed up outside the subrouine as for the other subroutines
9518 C        handling long-range interactions. The old code is commented out
9519 C        with "cgrad" to keep track of changes.
9520       do ll=1,3
9521 cgrad        ggg1(ll)=eel5*g_contij(ll,1)
9522 cgrad        ggg2(ll)=eel5*g_contij(ll,2)
9523         gradcorr5ij=eel5*g_contij(ll,1)+ekont*derx(ll,1,1)
9524         gradcorr5kl=eel5*g_contij(ll,2)+ekont*derx(ll,1,2)
9525 c        write (iout,'(a,3i3,a,5f8.3,2i3,a,5f8.3,a,f8.3)')
9526 c     &   "ecorr5",ll,i,j," derx",derx(ll,2,1),derx(ll,3,1),derx(ll,4,1),
9527 c     &   derx(ll,5,1),k,l," derx",derx(ll,2,2),derx(ll,3,2),
9528 c     &   derx(ll,4,2),derx(ll,5,2)," ekont",ekont
9529 c        write (iout,'(a,3i3,a,3f8.3,2i3,a,3f8.3)')
9530 c     &   "ecorr5",ll,i,j," gradcorr5",g_contij(ll,1),derx(ll,1,1),
9531 c     &   gradcorr5ij,
9532 c     &   k,l," gradcorr5",g_contij(ll,2),derx(ll,1,2),gradcorr5kl
9533 cold        ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
9534 cgrad        ghalf=0.5d0*ggg1(ll)
9535 cd        ghalf=0.0d0
9536         gradcorr5(ll,i)=gradcorr5(ll,i)+ekont*derx(ll,2,1)
9537         gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
9538         gradcorr5(ll,j)=gradcorr5(ll,j)+ekont*derx(ll,4,1)
9539         gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
9540         gradcorr5_long(ll,j)=gradcorr5_long(ll,j)+gradcorr5ij
9541         gradcorr5_long(ll,i)=gradcorr5_long(ll,i)-gradcorr5ij
9542 cold        ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
9543 cgrad        ghalf=0.5d0*ggg2(ll)
9544 cd        ghalf=0.0d0
9545         gradcorr5(ll,k)=gradcorr5(ll,k)+ghalf+ekont*derx(ll,2,2)
9546         gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
9547         gradcorr5(ll,l)=gradcorr5(ll,l)+ghalf+ekont*derx(ll,4,2)
9548         gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
9549         gradcorr5_long(ll,l)=gradcorr5_long(ll,l)+gradcorr5kl
9550         gradcorr5_long(ll,k)=gradcorr5_long(ll,k)-gradcorr5kl
9551       enddo
9552 cd      goto 1112
9553 cgrad      do m=i+1,j-1
9554 cgrad        do ll=1,3
9555 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
9556 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
9557 cgrad        enddo
9558 cgrad      enddo
9559 cgrad      do m=k+1,l-1
9560 cgrad        do ll=1,3
9561 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
9562 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
9563 cgrad        enddo
9564 cgrad      enddo
9565 c1112  continue
9566 cgrad      do m=i+2,j2
9567 cgrad        do ll=1,3
9568 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
9569 cgrad        enddo
9570 cgrad      enddo
9571 cgrad      do m=k+2,l2
9572 cgrad        do ll=1,3
9573 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
9574 cgrad        enddo
9575 cgrad      enddo
9576 cd      do iii=1,nres-3
9577 cd        write (2,*) iii,g_corr5_loc(iii)
9578 cd      enddo
9579       eello5=ekont*eel5
9580 cd      write (2,*) 'ekont',ekont
9581 cd      write (iout,*) 'eello5',ekont*eel5
9582       return
9583       end
9584 c--------------------------------------------------------------------------
9585       double precision function eello6(i,j,k,l,jj,kk)
9586       implicit real*8 (a-h,o-z)
9587       include 'DIMENSIONS'
9588       include 'COMMON.IOUNITS'
9589       include 'COMMON.CHAIN'
9590       include 'COMMON.DERIV'
9591       include 'COMMON.INTERACT'
9592       include 'COMMON.CONTACTS'
9593       include 'COMMON.TORSION'
9594       include 'COMMON.VAR'
9595       include 'COMMON.GEO'
9596       include 'COMMON.FFIELD'
9597       double precision ggg1(3),ggg2(3)
9598 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
9599 cd        eello6=0.0d0
9600 cd        return
9601 cd      endif
9602 cd      write (iout,*)
9603 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
9604 cd     &   ' and',k,l
9605       eello6_1=0.0d0
9606       eello6_2=0.0d0
9607       eello6_3=0.0d0
9608       eello6_4=0.0d0
9609       eello6_5=0.0d0
9610       eello6_6=0.0d0
9611 cd      call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
9612 cd     &   eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
9613       do iii=1,2
9614         do kkk=1,5
9615           do lll=1,3
9616             derx(lll,kkk,iii)=0.0d0
9617           enddo
9618         enddo
9619       enddo
9620 cd      eij=facont_hb(jj,i)
9621 cd      ekl=facont_hb(kk,k)
9622 cd      ekont=eij*ekl
9623 cd      eij=1.0d0
9624 cd      ekl=1.0d0
9625 cd      ekont=1.0d0
9626       if (l.eq.j+1) then
9627         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
9628         eello6_2=eello6_graph1(j,i,l,k,2,.false.)
9629         eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
9630         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
9631         eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
9632         eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
9633       else
9634         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
9635         eello6_2=eello6_graph1(l,k,j,i,2,.true.)
9636         eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
9637         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
9638         if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
9639           eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
9640         else
9641           eello6_5=0.0d0
9642         endif
9643         eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
9644       endif
9645 C If turn contributions are considered, they will be handled separately.
9646       eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
9647 cd      write(iout,*) 'eello6_1',eello6_1!,' eel6_1_num',16*eel6_1_num
9648 cd      write(iout,*) 'eello6_2',eello6_2!,' eel6_2_num',16*eel6_2_num
9649 cd      write(iout,*) 'eello6_3',eello6_3!,' eel6_3_num',16*eel6_3_num
9650 cd      write(iout,*) 'eello6_4',eello6_4!,' eel6_4_num',16*eel6_4_num
9651 cd      write(iout,*) 'eello6_5',eello6_5!,' eel6_5_num',16*eel6_5_num
9652 cd      write(iout,*) 'eello6_6',eello6_6!,' eel6_6_num',16*eel6_6_num
9653 cd      goto 1112
9654       if (j.lt.nres-1) then
9655         j1=j+1
9656         j2=j-1
9657       else
9658         j1=j-1
9659         j2=j-2
9660       endif
9661       if (l.lt.nres-1) then
9662         l1=l+1
9663         l2=l-1
9664       else
9665         l1=l-1
9666         l2=l-2
9667       endif
9668       do ll=1,3
9669 cgrad        ggg1(ll)=eel6*g_contij(ll,1)
9670 cgrad        ggg2(ll)=eel6*g_contij(ll,2)
9671 cold        ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
9672 cgrad        ghalf=0.5d0*ggg1(ll)
9673 cd        ghalf=0.0d0
9674         gradcorr6ij=eel6*g_contij(ll,1)+ekont*derx(ll,1,1)
9675         gradcorr6kl=eel6*g_contij(ll,2)+ekont*derx(ll,1,2)
9676         gradcorr6(ll,i)=gradcorr6(ll,i)+ekont*derx(ll,2,1)
9677         gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
9678         gradcorr6(ll,j)=gradcorr6(ll,j)+ekont*derx(ll,4,1)
9679         gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
9680         gradcorr6_long(ll,j)=gradcorr6_long(ll,j)+gradcorr6ij
9681         gradcorr6_long(ll,i)=gradcorr6_long(ll,i)-gradcorr6ij
9682 cgrad        ghalf=0.5d0*ggg2(ll)
9683 cold        ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
9684 cd        ghalf=0.0d0
9685         gradcorr6(ll,k)=gradcorr6(ll,k)+ekont*derx(ll,2,2)
9686         gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
9687         gradcorr6(ll,l)=gradcorr6(ll,l)+ekont*derx(ll,4,2)
9688         gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
9689         gradcorr6_long(ll,l)=gradcorr6_long(ll,l)+gradcorr6kl
9690         gradcorr6_long(ll,k)=gradcorr6_long(ll,k)-gradcorr6kl
9691       enddo
9692 cd      goto 1112
9693 cgrad      do m=i+1,j-1
9694 cgrad        do ll=1,3
9695 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
9696 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
9697 cgrad        enddo
9698 cgrad      enddo
9699 cgrad      do m=k+1,l-1
9700 cgrad        do ll=1,3
9701 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
9702 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
9703 cgrad        enddo
9704 cgrad      enddo
9705 cgrad1112  continue
9706 cgrad      do m=i+2,j2
9707 cgrad        do ll=1,3
9708 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
9709 cgrad        enddo
9710 cgrad      enddo
9711 cgrad      do m=k+2,l2
9712 cgrad        do ll=1,3
9713 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
9714 cgrad        enddo
9715 cgrad      enddo
9716 cd      do iii=1,nres-3
9717 cd        write (2,*) iii,g_corr6_loc(iii)
9718 cd      enddo
9719       eello6=ekont*eel6
9720 cd      write (2,*) 'ekont',ekont
9721 cd      write (iout,*) 'eello6',ekont*eel6
9722       return
9723       end
9724 c--------------------------------------------------------------------------
9725       double precision function eello6_graph1(i,j,k,l,imat,swap)
9726       implicit real*8 (a-h,o-z)
9727       include 'DIMENSIONS'
9728       include 'COMMON.IOUNITS'
9729       include 'COMMON.CHAIN'
9730       include 'COMMON.DERIV'
9731       include 'COMMON.INTERACT'
9732       include 'COMMON.CONTACTS'
9733       include 'COMMON.TORSION'
9734       include 'COMMON.VAR'
9735       include 'COMMON.GEO'
9736       double precision vv(2),vv1(2),pizda(2,2),auxmat(2,2),pizda1(2,2)
9737       logical swap
9738       logical lprn
9739       common /kutas/ lprn
9740 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9741 C                                                                              C
9742 C      Parallel       Antiparallel                                             C
9743 C                                                                              C
9744 C          o             o                                                     C
9745 C         /l\           /j\                                                    C
9746 C        /   \         /   \                                                   C
9747 C       /| o |         | o |\                                                  C
9748 C     \ j|/k\|  /   \  |/k\|l /                                                C
9749 C      \ /   \ /     \ /   \ /                                                 C
9750 C       o     o       o     o                                                  C
9751 C       i             i                                                        C
9752 C                                                                              C
9753 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9754       itk=itortyp(itype(k))
9755       s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
9756       s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
9757       s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
9758       call transpose2(EUgC(1,1,k),auxmat(1,1))
9759       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
9760       vv1(1)=pizda1(1,1)-pizda1(2,2)
9761       vv1(2)=pizda1(1,2)+pizda1(2,1)
9762       s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
9763       vv(1)=AEAb1(1,2,imat)*b1(1,k)-AEAb1(2,2,imat)*b1(2,k)
9764       vv(2)=AEAb1(1,2,imat)*b1(2,k)+AEAb1(2,2,imat)*b1(1,k)
9765       s5=scalar2(vv(1),Dtobr2(1,i))
9766 cd      write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
9767       eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
9768       if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1)
9769      & -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i))
9770      & -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k))
9771      & +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k))
9772      & +0.5d0*scalar2(vv1(1),Dtobr2der(1,i))
9773      & +scalar2(vv(1),Dtobr2der(1,i)))
9774       call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
9775       vv1(1)=pizda1(1,1)-pizda1(2,2)
9776       vv1(2)=pizda1(1,2)+pizda1(2,1)
9777       vv(1)=AEAb1derg(1,2,imat)*b1(1,k)-AEAb1derg(2,2,imat)*b1(2,k)
9778       vv(2)=AEAb1derg(1,2,imat)*b1(2,k)+AEAb1derg(2,2,imat)*b1(1,k)
9779       if (l.eq.j+1) then
9780         g_corr6_loc(l-1)=g_corr6_loc(l-1)
9781      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
9782      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
9783      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
9784      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
9785       else
9786         g_corr6_loc(j-1)=g_corr6_loc(j-1)
9787      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
9788      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
9789      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
9790      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
9791       endif
9792       call transpose2(EUgCder(1,1,k),auxmat(1,1))
9793       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
9794       vv1(1)=pizda1(1,1)-pizda1(2,2)
9795       vv1(2)=pizda1(1,2)+pizda1(2,1)
9796       if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1)
9797      & +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k))
9798      & +scalar2(AEAb2(1,1,imat),CUgb2der(1,k))
9799      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
9800       do iii=1,2
9801         if (swap) then
9802           ind=3-iii
9803         else
9804           ind=iii
9805         endif
9806         do kkk=1,5
9807           do lll=1,3
9808             s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
9809             s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
9810             s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
9811             call transpose2(EUgC(1,1,k),auxmat(1,1))
9812             call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
9813      &        pizda1(1,1))
9814             vv1(1)=pizda1(1,1)-pizda1(2,2)
9815             vv1(2)=pizda1(1,2)+pizda1(2,1)
9816             s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
9817             vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,k)
9818      &       -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,k)
9819             vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,k)
9820      &       +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,k)
9821             s5=scalar2(vv(1),Dtobr2(1,i))
9822             derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
9823           enddo
9824         enddo
9825       enddo
9826       return
9827       end
9828 c----------------------------------------------------------------------------
9829       double precision function eello6_graph2(i,j,k,l,jj,kk,swap)
9830       implicit real*8 (a-h,o-z)
9831       include 'DIMENSIONS'
9832       include 'COMMON.IOUNITS'
9833       include 'COMMON.CHAIN'
9834       include 'COMMON.DERIV'
9835       include 'COMMON.INTERACT'
9836       include 'COMMON.CONTACTS'
9837       include 'COMMON.TORSION'
9838       include 'COMMON.VAR'
9839       include 'COMMON.GEO'
9840       logical swap
9841       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
9842      & auxvec1(2),auxvec2(2),auxmat1(2,2)
9843       logical lprn
9844       common /kutas/ lprn
9845 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9846 C                                                                              C
9847 C      Parallel       Antiparallel                                             C
9848 C                                                                              C
9849 C          o             o                                                     C
9850 C     \   /l\           /j\   /                                                C
9851 C      \ /   \         /   \ /                                                 C
9852 C       o| o |         | o |o                                                  C
9853 C     \ j|/k\|      \  |/k\|l                                                  C
9854 C      \ /   \       \ /   \                                                   C
9855 C       o             o                                                        C
9856 C       i             i                                                        C
9857 C                                                                              C
9858 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9859 cd      write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
9860 C AL 7/4/01 s1 would occur in the sixth-order moment,
9861 C           but not in a cluster cumulant
9862 #ifdef MOMENT
9863       s1=dip(1,jj,i)*dip(1,kk,k)
9864 #endif
9865       call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
9866       s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
9867       call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
9868       s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
9869       call transpose2(EUg(1,1,k),auxmat(1,1))
9870       call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
9871       vv(1)=pizda(1,1)-pizda(2,2)
9872       vv(2)=pizda(1,2)+pizda(2,1)
9873       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
9874 cd      write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
9875 #ifdef MOMENT
9876       eello6_graph2=-(s1+s2+s3+s4)
9877 #else
9878       eello6_graph2=-(s2+s3+s4)
9879 #endif
9880 c      eello6_graph2=-s3
9881 C Derivatives in gamma(i-1)
9882       if (i.gt.1) then
9883 #ifdef MOMENT
9884         s1=dipderg(1,jj,i)*dip(1,kk,k)
9885 #endif
9886         s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
9887         call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
9888         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
9889         s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
9890 #ifdef MOMENT
9891         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
9892 #else
9893         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
9894 #endif
9895 c        g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
9896       endif
9897 C Derivatives in gamma(k-1)
9898 #ifdef MOMENT
9899       s1=dip(1,jj,i)*dipderg(1,kk,k)
9900 #endif
9901       call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
9902       s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
9903       call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
9904       s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
9905       call transpose2(EUgder(1,1,k),auxmat1(1,1))
9906       call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
9907       vv(1)=pizda(1,1)-pizda(2,2)
9908       vv(2)=pizda(1,2)+pizda(2,1)
9909       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
9910 #ifdef MOMENT
9911       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
9912 #else
9913       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
9914 #endif
9915 c      g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
9916 C Derivatives in gamma(j-1) or gamma(l-1)
9917       if (j.gt.1) then
9918 #ifdef MOMENT
9919         s1=dipderg(3,jj,i)*dip(1,kk,k)
9920 #endif
9921         call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
9922         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
9923         s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
9924         call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
9925         vv(1)=pizda(1,1)-pizda(2,2)
9926         vv(2)=pizda(1,2)+pizda(2,1)
9927         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
9928 #ifdef MOMENT
9929         if (swap) then
9930           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
9931         else
9932           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
9933         endif
9934 #endif
9935         g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
9936 c        g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
9937       endif
9938 C Derivatives in gamma(l-1) or gamma(j-1)
9939       if (l.gt.1) then
9940 #ifdef MOMENT
9941         s1=dip(1,jj,i)*dipderg(3,kk,k)
9942 #endif
9943         call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
9944         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
9945         call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
9946         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
9947         call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
9948         vv(1)=pizda(1,1)-pizda(2,2)
9949         vv(2)=pizda(1,2)+pizda(2,1)
9950         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
9951 #ifdef MOMENT
9952         if (swap) then
9953           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
9954         else
9955           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
9956         endif
9957 #endif
9958         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
9959 c        g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
9960       endif
9961 C Cartesian derivatives.
9962       if (lprn) then
9963         write (2,*) 'In eello6_graph2'
9964         do iii=1,2
9965           write (2,*) 'iii=',iii
9966           do kkk=1,5
9967             write (2,*) 'kkk=',kkk
9968             do jjj=1,2
9969               write (2,'(3(2f10.5),5x)')
9970      &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
9971             enddo
9972           enddo
9973         enddo
9974       endif
9975       do iii=1,2
9976         do kkk=1,5
9977           do lll=1,3
9978 #ifdef MOMENT
9979             if (iii.eq.1) then
9980               s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
9981             else
9982               s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
9983             endif
9984 #endif
9985             call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),
9986      &        auxvec(1))
9987             s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
9988             call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),
9989      &        auxvec(1))
9990             s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
9991             call transpose2(EUg(1,1,k),auxmat(1,1))
9992             call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),
9993      &        pizda(1,1))
9994             vv(1)=pizda(1,1)-pizda(2,2)
9995             vv(2)=pizda(1,2)+pizda(2,1)
9996             s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
9997 cd            write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
9998 #ifdef MOMENT
9999             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
10000 #else
10001             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
10002 #endif
10003             if (swap) then
10004               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
10005             else
10006               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
10007             endif
10008           enddo
10009         enddo
10010       enddo
10011       return
10012       end
10013 c----------------------------------------------------------------------------
10014       double precision function eello6_graph3(i,j,k,l,jj,kk,swap)
10015       implicit real*8 (a-h,o-z)
10016       include 'DIMENSIONS'
10017       include 'COMMON.IOUNITS'
10018       include 'COMMON.CHAIN'
10019       include 'COMMON.DERIV'
10020       include 'COMMON.INTERACT'
10021       include 'COMMON.CONTACTS'
10022       include 'COMMON.TORSION'
10023       include 'COMMON.VAR'
10024       include 'COMMON.GEO'
10025       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2)
10026       logical swap
10027 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10028 C                                                                              C
10029 C      Parallel       Antiparallel                                             C
10030 C                                                                              C
10031 C          o             o                                                     C
10032 C         /l\   /   \   /j\                                                    C
10033 C        /   \ /     \ /   \                                                   C
10034 C       /| o |o       o| o |\                                                  C
10035 C       j|/k\|  /      |/k\|l /                                                C
10036 C        /   \ /       /   \ /                                                 C
10037 C       /     o       /     o                                                  C
10038 C       i             i                                                        C
10039 C                                                                              C
10040 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10041 C
10042 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
10043 C           energy moment and not to the cluster cumulant.
10044       iti=itortyp(itype(i))
10045       if (j.lt.nres-1) then
10046         itj1=itortyp(itype(j+1))
10047       else
10048         itj1=ntortyp
10049       endif
10050       itk=itortyp(itype(k))
10051       itk1=itortyp(itype(k+1))
10052       if (l.lt.nres-1) then
10053         itl1=itortyp(itype(l+1))
10054       else
10055         itl1=ntortyp
10056       endif
10057 #ifdef MOMENT
10058       s1=dip(4,jj,i)*dip(4,kk,k)
10059 #endif
10060       call matvec2(AECA(1,1,1),b1(1,k+1),auxvec(1))
10061       s2=0.5d0*scalar2(b1(1,k),auxvec(1))
10062       call matvec2(AECA(1,1,2),b1(1,l+1),auxvec(1))
10063       s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
10064       call transpose2(EE(1,1,itk),auxmat(1,1))
10065       call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
10066       vv(1)=pizda(1,1)+pizda(2,2)
10067       vv(2)=pizda(2,1)-pizda(1,2)
10068       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
10069 cd      write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4,
10070 cd     & "sum",-(s2+s3+s4)
10071 #ifdef MOMENT
10072       eello6_graph3=-(s1+s2+s3+s4)
10073 #else
10074       eello6_graph3=-(s2+s3+s4)
10075 #endif
10076 c      eello6_graph3=-s4
10077 C Derivatives in gamma(k-1)
10078       call matvec2(AECAderg(1,1,2),b1(1,l+1),auxvec(1))
10079       s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
10080       s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
10081       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
10082 C Derivatives in gamma(l-1)
10083       call matvec2(AECAderg(1,1,1),b1(1,k+1),auxvec(1))
10084       s2=0.5d0*scalar2(b1(1,k),auxvec(1))
10085       call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
10086       vv(1)=pizda(1,1)+pizda(2,2)
10087       vv(2)=pizda(2,1)-pizda(1,2)
10088       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
10089       g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
10090 C Cartesian derivatives.
10091       do iii=1,2
10092         do kkk=1,5
10093           do lll=1,3
10094 #ifdef MOMENT
10095             if (iii.eq.1) then
10096               s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
10097             else
10098               s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
10099             endif
10100 #endif
10101             call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
10102      &        auxvec(1))
10103             s2=0.5d0*scalar2(b1(1,k),auxvec(1))
10104             call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,l+1),
10105      &        auxvec(1))
10106             s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
10107             call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),
10108      &        pizda(1,1))
10109             vv(1)=pizda(1,1)+pizda(2,2)
10110             vv(2)=pizda(2,1)-pizda(1,2)
10111             s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
10112 #ifdef MOMENT
10113             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
10114 #else
10115             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
10116 #endif
10117             if (swap) then
10118               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
10119             else
10120               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
10121             endif
10122 c            derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
10123           enddo
10124         enddo
10125       enddo
10126       return
10127       end
10128 c----------------------------------------------------------------------------
10129       double precision function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
10130       implicit real*8 (a-h,o-z)
10131       include 'DIMENSIONS'
10132       include 'COMMON.IOUNITS'
10133       include 'COMMON.CHAIN'
10134       include 'COMMON.DERIV'
10135       include 'COMMON.INTERACT'
10136       include 'COMMON.CONTACTS'
10137       include 'COMMON.TORSION'
10138       include 'COMMON.VAR'
10139       include 'COMMON.GEO'
10140       include 'COMMON.FFIELD'
10141       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
10142      & auxvec1(2),auxmat1(2,2)
10143       logical swap
10144 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10145 C                                                                              C
10146 C      Parallel       Antiparallel                                             C
10147 C                                                                              C
10148 C          o             o                                                     C
10149 C         /l\   /   \   /j\                                                    C
10150 C        /   \ /     \ /   \                                                   C
10151 C       /| o |o       o| o |\                                                  C
10152 C     \ j|/k\|      \  |/k\|l                                                  C
10153 C      \ /   \       \ /   \                                                   C
10154 C       o     \       o     \                                                  C
10155 C       i             i                                                        C
10156 C                                                                              C
10157 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10158 C
10159 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
10160 C           energy moment and not to the cluster cumulant.
10161 cd      write (2,*) 'eello_graph4: wturn6',wturn6
10162       iti=itortyp(itype(i))
10163       itj=itortyp(itype(j))
10164       if (j.lt.nres-1) then
10165         itj1=itortyp(itype(j+1))
10166       else
10167         itj1=ntortyp
10168       endif
10169       itk=itortyp(itype(k))
10170       if (k.lt.nres-1) then
10171         itk1=itortyp(itype(k+1))
10172       else
10173         itk1=ntortyp
10174       endif
10175       itl=itortyp(itype(l))
10176       if (l.lt.nres-1) then
10177         itl1=itortyp(itype(l+1))
10178       else
10179         itl1=ntortyp
10180       endif
10181 cd      write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
10182 cd      write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
10183 cd     & ' itl',itl,' itl1',itl1
10184 #ifdef MOMENT
10185       if (imat.eq.1) then
10186         s1=dip(3,jj,i)*dip(3,kk,k)
10187       else
10188         s1=dip(2,jj,j)*dip(2,kk,l)
10189       endif
10190 #endif
10191       call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
10192       s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
10193       if (j.eq.l+1) then
10194         call matvec2(ADtEA1(1,1,3-imat),b1(1,j+1),auxvec1(1))
10195         s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
10196       else
10197         call matvec2(ADtEA1(1,1,3-imat),b1(1,l+1),auxvec1(1))
10198         s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
10199       endif
10200       call transpose2(EUg(1,1,k),auxmat(1,1))
10201       call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
10202       vv(1)=pizda(1,1)-pizda(2,2)
10203       vv(2)=pizda(2,1)+pizda(1,2)
10204       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
10205 cd      write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
10206 #ifdef MOMENT
10207       eello6_graph4=-(s1+s2+s3+s4)
10208 #else
10209       eello6_graph4=-(s2+s3+s4)
10210 #endif
10211 C Derivatives in gamma(i-1)
10212       if (i.gt.1) then
10213 #ifdef MOMENT
10214         if (imat.eq.1) then
10215           s1=dipderg(2,jj,i)*dip(3,kk,k)
10216         else
10217           s1=dipderg(4,jj,j)*dip(2,kk,l)
10218         endif
10219 #endif
10220         s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
10221         if (j.eq.l+1) then
10222           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,j+1),auxvec1(1))
10223           s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
10224         else
10225           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,l+1),auxvec1(1))
10226           s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
10227         endif
10228         s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
10229         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
10230 cd          write (2,*) 'turn6 derivatives'
10231 #ifdef MOMENT
10232           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
10233 #else
10234           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
10235 #endif
10236         else
10237 #ifdef MOMENT
10238           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
10239 #else
10240           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
10241 #endif
10242         endif
10243       endif
10244 C Derivatives in gamma(k-1)
10245 #ifdef MOMENT
10246       if (imat.eq.1) then
10247         s1=dip(3,jj,i)*dipderg(2,kk,k)
10248       else
10249         s1=dip(2,jj,j)*dipderg(4,kk,l)
10250       endif
10251 #endif
10252       call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
10253       s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
10254       if (j.eq.l+1) then
10255         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,j+1),auxvec1(1))
10256         s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
10257       else
10258         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,l+1),auxvec1(1))
10259         s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
10260       endif
10261       call transpose2(EUgder(1,1,k),auxmat1(1,1))
10262       call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
10263       vv(1)=pizda(1,1)-pizda(2,2)
10264       vv(2)=pizda(2,1)+pizda(1,2)
10265       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
10266       if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
10267 #ifdef MOMENT
10268         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
10269 #else
10270         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
10271 #endif
10272       else
10273 #ifdef MOMENT
10274         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
10275 #else
10276         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
10277 #endif
10278       endif
10279 C Derivatives in gamma(j-1) or gamma(l-1)
10280       if (l.eq.j+1 .and. l.gt.1) then
10281         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
10282         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
10283         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
10284         vv(1)=pizda(1,1)-pizda(2,2)
10285         vv(2)=pizda(2,1)+pizda(1,2)
10286         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
10287         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
10288       else if (j.gt.1) then
10289         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
10290         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
10291         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
10292         vv(1)=pizda(1,1)-pizda(2,2)
10293         vv(2)=pizda(2,1)+pizda(1,2)
10294         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
10295         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
10296           gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
10297         else
10298           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
10299         endif
10300       endif
10301 C Cartesian derivatives.
10302       do iii=1,2
10303         do kkk=1,5
10304           do lll=1,3
10305 #ifdef MOMENT
10306             if (iii.eq.1) then
10307               if (imat.eq.1) then
10308                 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
10309               else
10310                 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
10311               endif
10312             else
10313               if (imat.eq.1) then
10314                 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
10315               else
10316                 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
10317               endif
10318             endif
10319 #endif
10320             call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),
10321      &        auxvec(1))
10322             s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
10323             if (j.eq.l+1) then
10324               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
10325      &          b1(1,j+1),auxvec(1))
10326               s3=-0.5d0*scalar2(b1(1,j),auxvec(1))
10327             else
10328               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
10329      &          b1(1,l+1),auxvec(1))
10330               s3=-0.5d0*scalar2(b1(1,l),auxvec(1))
10331             endif
10332             call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
10333      &        pizda(1,1))
10334             vv(1)=pizda(1,1)-pizda(2,2)
10335             vv(2)=pizda(2,1)+pizda(1,2)
10336             s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
10337             if (swap) then
10338               if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
10339 #ifdef MOMENT
10340                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
10341      &             -(s1+s2+s4)
10342 #else
10343                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
10344      &             -(s2+s4)
10345 #endif
10346                 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
10347               else
10348 #ifdef MOMENT
10349                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
10350 #else
10351                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
10352 #endif
10353                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
10354               endif
10355             else
10356 #ifdef MOMENT
10357               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
10358 #else
10359               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
10360 #endif
10361               if (l.eq.j+1) then
10362                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
10363               else
10364                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
10365               endif
10366             endif
10367           enddo
10368         enddo
10369       enddo
10370       return
10371       end
10372 c----------------------------------------------------------------------------
10373       double precision function eello_turn6(i,jj,kk)
10374       implicit real*8 (a-h,o-z)
10375       include 'DIMENSIONS'
10376       include 'COMMON.IOUNITS'
10377       include 'COMMON.CHAIN'
10378       include 'COMMON.DERIV'
10379       include 'COMMON.INTERACT'
10380       include 'COMMON.CONTACTS'
10381       include 'COMMON.TORSION'
10382       include 'COMMON.VAR'
10383       include 'COMMON.GEO'
10384       double precision vtemp1(2),vtemp2(2),vtemp3(2),vtemp4(2),
10385      &  atemp(2,2),auxmat(2,2),achuj_temp(2,2),gtemp(2,2),gvec(2),
10386      &  ggg1(3),ggg2(3)
10387       double precision vtemp1d(2),vtemp2d(2),vtemp3d(2),vtemp4d(2),
10388      &  atempd(2,2),auxmatd(2,2),achuj_tempd(2,2),gtempd(2,2),gvecd(2)
10389 C 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
10390 C           the respective energy moment and not to the cluster cumulant.
10391       s1=0.0d0
10392       s8=0.0d0
10393       s13=0.0d0
10394 c
10395       eello_turn6=0.0d0
10396       j=i+4
10397       k=i+1
10398       l=i+3
10399       iti=itortyp(itype(i))
10400       itk=itortyp(itype(k))
10401       itk1=itortyp(itype(k+1))
10402       itl=itortyp(itype(l))
10403       itj=itortyp(itype(j))
10404 cd      write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
10405 cd      write (2,*) 'i',i,' k',k,' j',j,' l',l
10406 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
10407 cd        eello6=0.0d0
10408 cd        return
10409 cd      endif
10410 cd      write (iout,*)
10411 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
10412 cd     &   ' and',k,l
10413 cd      call checkint_turn6(i,jj,kk,eel_turn6_num)
10414       do iii=1,2
10415         do kkk=1,5
10416           do lll=1,3
10417             derx_turn(lll,kkk,iii)=0.0d0
10418           enddo
10419         enddo
10420       enddo
10421 cd      eij=1.0d0
10422 cd      ekl=1.0d0
10423 cd      ekont=1.0d0
10424       eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
10425 cd      eello6_5=0.0d0
10426 cd      write (2,*) 'eello6_5',eello6_5
10427 #ifdef MOMENT
10428       call transpose2(AEA(1,1,1),auxmat(1,1))
10429       call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
10430       ss1=scalar2(Ub2(1,i+2),b1(1,l))
10431       s1 = (auxmat(1,1)+auxmat(2,2))*ss1
10432 #endif
10433       call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1(1))
10434       call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
10435       s2 = scalar2(b1(1,k),vtemp1(1))
10436 #ifdef MOMENT
10437       call transpose2(AEA(1,1,2),atemp(1,1))
10438       call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
10439       call matvec2(Ug2(1,1,i+2),dd(1,1,itk1),vtemp2(1))
10440       s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
10441 #endif
10442       call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
10443       call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
10444       s12 = scalar2(Ub2(1,i+2),vtemp3(1))
10445 #ifdef MOMENT
10446       call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
10447       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
10448       call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
10449       call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
10450       ss13 = scalar2(b1(1,k),vtemp4(1))
10451       s13 = (gtemp(1,1)+gtemp(2,2))*ss13
10452 #endif
10453 c      write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
10454 c      s1=0.0d0
10455 c      s2=0.0d0
10456 c      s8=0.0d0
10457 c      s12=0.0d0
10458 c      s13=0.0d0
10459       eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
10460 C Derivatives in gamma(i+2)
10461       s1d =0.0d0
10462       s8d =0.0d0
10463 #ifdef MOMENT
10464       call transpose2(AEA(1,1,1),auxmatd(1,1))
10465       call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
10466       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
10467       call transpose2(AEAderg(1,1,2),atempd(1,1))
10468       call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
10469       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
10470 #endif
10471       call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
10472       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
10473       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
10474 c      s1d=0.0d0
10475 c      s2d=0.0d0
10476 c      s8d=0.0d0
10477 c      s12d=0.0d0
10478 c      s13d=0.0d0
10479       gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
10480 C Derivatives in gamma(i+3)
10481 #ifdef MOMENT
10482       call transpose2(AEA(1,1,1),auxmatd(1,1))
10483       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
10484       ss1d=scalar2(Ub2der(1,i+2),b1(1,l))
10485       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
10486 #endif
10487       call matvec2(EUgder(1,1,i+2),b1(1,l),vtemp1d(1))
10488       call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
10489       s2d = scalar2(b1(1,k),vtemp1d(1))
10490 #ifdef MOMENT
10491       call matvec2(Ug2der(1,1,i+2),dd(1,1,itk1),vtemp2d(1))
10492       s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2d(1))
10493 #endif
10494       s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
10495 #ifdef MOMENT
10496       call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
10497       call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
10498       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
10499 #endif
10500 c      s1d=0.0d0
10501 c      s2d=0.0d0
10502 c      s8d=0.0d0
10503 c      s12d=0.0d0
10504 c      s13d=0.0d0
10505 #ifdef MOMENT
10506       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
10507      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
10508 #else
10509       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
10510      &               -0.5d0*ekont*(s2d+s12d)
10511 #endif
10512 C Derivatives in gamma(i+4)
10513       call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
10514       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
10515       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
10516 #ifdef MOMENT
10517       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
10518       call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
10519       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
10520 #endif
10521 c      s1d=0.0d0
10522 c      s2d=0.0d0
10523 c      s8d=0.0d0
10524 C      s12d=0.0d0
10525 c      s13d=0.0d0
10526 #ifdef MOMENT
10527       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
10528 #else
10529       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
10530 #endif
10531 C Derivatives in gamma(i+5)
10532 #ifdef MOMENT
10533       call transpose2(AEAderg(1,1,1),auxmatd(1,1))
10534       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
10535       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
10536 #endif
10537       call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1d(1))
10538       call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
10539       s2d = scalar2(b1(1,k),vtemp1d(1))
10540 #ifdef MOMENT
10541       call transpose2(AEA(1,1,2),atempd(1,1))
10542       call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
10543       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
10544 #endif
10545       call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
10546       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
10547 #ifdef MOMENT
10548       call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
10549       ss13d = scalar2(b1(1,k),vtemp4d(1))
10550       s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
10551 #endif
10552 c      s1d=0.0d0
10553 c      s2d=0.0d0
10554 c      s8d=0.0d0
10555 c      s12d=0.0d0
10556 c      s13d=0.0d0
10557 #ifdef MOMENT
10558       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
10559      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
10560 #else
10561       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
10562      &               -0.5d0*ekont*(s2d+s12d)
10563 #endif
10564 C Cartesian derivatives
10565       do iii=1,2
10566         do kkk=1,5
10567           do lll=1,3
10568 #ifdef MOMENT
10569             call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
10570             call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
10571             s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
10572 #endif
10573             call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1(1))
10574             call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),
10575      &          vtemp1d(1))
10576             s2d = scalar2(b1(1,k),vtemp1d(1))
10577 #ifdef MOMENT
10578             call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
10579             call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
10580             s8d = -(atempd(1,1)+atempd(2,2))*
10581      &           scalar2(cc(1,1,itl),vtemp2(1))
10582 #endif
10583             call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),
10584      &           auxmatd(1,1))
10585             call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
10586             s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
10587 c      s1d=0.0d0
10588 c      s2d=0.0d0
10589 c      s8d=0.0d0
10590 c      s12d=0.0d0
10591 c      s13d=0.0d0
10592 #ifdef MOMENT
10593             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
10594      &        - 0.5d0*(s1d+s2d)
10595 #else
10596             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
10597      &        - 0.5d0*s2d
10598 #endif
10599 #ifdef MOMENT
10600             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
10601      &        - 0.5d0*(s8d+s12d)
10602 #else
10603             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
10604      &        - 0.5d0*s12d
10605 #endif
10606           enddo
10607         enddo
10608       enddo
10609 #ifdef MOMENT
10610       do kkk=1,5
10611         do lll=1,3
10612           call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),
10613      &      achuj_tempd(1,1))
10614           call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
10615           call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
10616           s13d=(gtempd(1,1)+gtempd(2,2))*ss13
10617           derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
10618           call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),
10619      &      vtemp4d(1))
10620           ss13d = scalar2(b1(1,k),vtemp4d(1))
10621           s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
10622           derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
10623         enddo
10624       enddo
10625 #endif
10626 cd      write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
10627 cd     &  16*eel_turn6_num
10628 cd      goto 1112
10629       if (j.lt.nres-1) then
10630         j1=j+1
10631         j2=j-1
10632       else
10633         j1=j-1
10634         j2=j-2
10635       endif
10636       if (l.lt.nres-1) then
10637         l1=l+1
10638         l2=l-1
10639       else
10640         l1=l-1
10641         l2=l-2
10642       endif
10643       do ll=1,3
10644 cgrad        ggg1(ll)=eel_turn6*g_contij(ll,1)
10645 cgrad        ggg2(ll)=eel_turn6*g_contij(ll,2)
10646 cgrad        ghalf=0.5d0*ggg1(ll)
10647 cd        ghalf=0.0d0
10648         gturn6ij=eel_turn6*g_contij(ll,1)+ekont*derx_turn(ll,1,1)
10649         gturn6kl=eel_turn6*g_contij(ll,2)+ekont*derx_turn(ll,1,2)
10650         gcorr6_turn(ll,i)=gcorr6_turn(ll,i)!+ghalf
10651      &    +ekont*derx_turn(ll,2,1)
10652         gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
10653         gcorr6_turn(ll,j)=gcorr6_turn(ll,j)!+ghalf
10654      &    +ekont*derx_turn(ll,4,1)
10655         gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
10656         gcorr6_turn_long(ll,j)=gcorr6_turn_long(ll,j)+gturn6ij
10657         gcorr6_turn_long(ll,i)=gcorr6_turn_long(ll,i)-gturn6ij
10658 cgrad        ghalf=0.5d0*ggg2(ll)
10659 cd        ghalf=0.0d0
10660         gcorr6_turn(ll,k)=gcorr6_turn(ll,k)!+ghalf
10661      &    +ekont*derx_turn(ll,2,2)
10662         gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
10663         gcorr6_turn(ll,l)=gcorr6_turn(ll,l)!+ghalf
10664      &    +ekont*derx_turn(ll,4,2)
10665         gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
10666         gcorr6_turn_long(ll,l)=gcorr6_turn_long(ll,l)+gturn6kl
10667         gcorr6_turn_long(ll,k)=gcorr6_turn_long(ll,k)-gturn6kl
10668       enddo
10669 cd      goto 1112
10670 cgrad      do m=i+1,j-1
10671 cgrad        do ll=1,3
10672 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
10673 cgrad        enddo
10674 cgrad      enddo
10675 cgrad      do m=k+1,l-1
10676 cgrad        do ll=1,3
10677 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
10678 cgrad        enddo
10679 cgrad      enddo
10680 cgrad1112  continue
10681 cgrad      do m=i+2,j2
10682 cgrad        do ll=1,3
10683 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
10684 cgrad        enddo
10685 cgrad      enddo
10686 cgrad      do m=k+2,l2
10687 cgrad        do ll=1,3
10688 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
10689 cgrad        enddo
10690 cgrad      enddo
10691 cd      do iii=1,nres-3
10692 cd        write (2,*) iii,g_corr6_loc(iii)
10693 cd      enddo
10694       eello_turn6=ekont*eel_turn6
10695 cd      write (2,*) 'ekont',ekont
10696 cd      write (2,*) 'eel_turn6',ekont*eel_turn6
10697       return
10698       end
10699
10700 C-----------------------------------------------------------------------------
10701       double precision function scalar(u,v)
10702 !DIR$ INLINEALWAYS scalar
10703 #ifndef OSF
10704 cDEC$ ATTRIBUTES FORCEINLINE::scalar
10705 #endif
10706       implicit none
10707       double precision u(3),v(3)
10708 cd      double precision sc
10709 cd      integer i
10710 cd      sc=0.0d0
10711 cd      do i=1,3
10712 cd        sc=sc+u(i)*v(i)
10713 cd      enddo
10714 cd      scalar=sc
10715
10716       scalar=u(1)*v(1)+u(2)*v(2)+u(3)*v(3)
10717       return
10718       end
10719 crc-------------------------------------------------
10720       SUBROUTINE MATVEC2(A1,V1,V2)
10721 !DIR$ INLINEALWAYS MATVEC2
10722 #ifndef OSF
10723 cDEC$ ATTRIBUTES FORCEINLINE::MATVEC2
10724 #endif
10725       implicit real*8 (a-h,o-z)
10726       include 'DIMENSIONS'
10727       DIMENSION A1(2,2),V1(2),V2(2)
10728 c      DO 1 I=1,2
10729 c        VI=0.0
10730 c        DO 3 K=1,2
10731 c    3     VI=VI+A1(I,K)*V1(K)
10732 c        Vaux(I)=VI
10733 c    1 CONTINUE
10734
10735       vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
10736       vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
10737
10738       v2(1)=vaux1
10739       v2(2)=vaux2
10740       END
10741 C---------------------------------------
10742       SUBROUTINE MATMAT2(A1,A2,A3)
10743 #ifndef OSF
10744 cDEC$ ATTRIBUTES FORCEINLINE::MATMAT2
10745 #endif
10746       implicit real*8 (a-h,o-z)
10747       include 'DIMENSIONS'
10748       DIMENSION A1(2,2),A2(2,2),A3(2,2)
10749 c      DIMENSION AI3(2,2)
10750 c        DO  J=1,2
10751 c          A3IJ=0.0
10752 c          DO K=1,2
10753 c           A3IJ=A3IJ+A1(I,K)*A2(K,J)
10754 c          enddo
10755 c          A3(I,J)=A3IJ
10756 c       enddo
10757 c      enddo
10758
10759       ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
10760       ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
10761       ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
10762       ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
10763
10764       A3(1,1)=AI3_11
10765       A3(2,1)=AI3_21
10766       A3(1,2)=AI3_12
10767       A3(2,2)=AI3_22
10768       END
10769
10770 c-------------------------------------------------------------------------
10771       double precision function scalar2(u,v)
10772 !DIR$ INLINEALWAYS scalar2
10773       implicit none
10774       double precision u(2),v(2)
10775       double precision sc
10776       integer i
10777       scalar2=u(1)*v(1)+u(2)*v(2)
10778       return
10779       end
10780
10781 C-----------------------------------------------------------------------------
10782
10783       subroutine transpose2(a,at)
10784 !DIR$ INLINEALWAYS transpose2
10785 #ifndef OSF
10786 cDEC$ ATTRIBUTES FORCEINLINE::transpose2
10787 #endif
10788       implicit none
10789       double precision a(2,2),at(2,2)
10790       at(1,1)=a(1,1)
10791       at(1,2)=a(2,1)
10792       at(2,1)=a(1,2)
10793       at(2,2)=a(2,2)
10794       return
10795       end
10796 c--------------------------------------------------------------------------
10797       subroutine transpose(n,a,at)
10798       implicit none
10799       integer n,i,j
10800       double precision a(n,n),at(n,n)
10801       do i=1,n
10802         do j=1,n
10803           at(j,i)=a(i,j)
10804         enddo
10805       enddo
10806       return
10807       end
10808 C---------------------------------------------------------------------------
10809       subroutine prodmat3(a1,a2,kk,transp,prod)
10810 !DIR$ INLINEALWAYS prodmat3
10811 #ifndef OSF
10812 cDEC$ ATTRIBUTES FORCEINLINE::prodmat3
10813 #endif
10814       implicit none
10815       integer i,j
10816       double precision a1(2,2),a2(2,2),a2t(2,2),kk(2,2),prod(2,2)
10817       logical transp
10818 crc      double precision auxmat(2,2),prod_(2,2)
10819
10820       if (transp) then
10821 crc        call transpose2(kk(1,1),auxmat(1,1))
10822 crc        call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
10823 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
10824
10825            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1)
10826      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
10827            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2)
10828      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
10829            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1)
10830      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
10831            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2)
10832      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
10833
10834       else
10835 crc        call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
10836 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
10837
10838            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1)
10839      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
10840            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2)
10841      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
10842            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1)
10843      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
10844            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2)
10845      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
10846
10847       endif
10848 c      call transpose2(a2(1,1),a2t(1,1))
10849
10850 crc      print *,transp
10851 crc      print *,((prod_(i,j),i=1,2),j=1,2)
10852 crc      print *,((prod(i,j),i=1,2),j=1,2)
10853
10854       return
10855       end
10856 CCC----------------------------------------------
10857       subroutine Eliptransfer(eliptran)
10858       implicit real*8 (a-h,o-z)
10859       include 'DIMENSIONS'
10860       include 'COMMON.GEO'
10861       include 'COMMON.VAR'
10862       include 'COMMON.LOCAL'
10863       include 'COMMON.CHAIN'
10864       include 'COMMON.DERIV'
10865       include 'COMMON.NAMES'
10866       include 'COMMON.INTERACT'
10867       include 'COMMON.IOUNITS'
10868       include 'COMMON.CALC'
10869       include 'COMMON.CONTROL'
10870       include 'COMMON.SPLITELE'
10871       include 'COMMON.SBRIDGE'
10872 C this is done by Adasko
10873 C      print *,"wchodze"
10874 C structure of box:
10875 C      water
10876 C--bordliptop-- buffore starts
10877 C--bufliptop--- here true lipid starts
10878 C      lipid
10879 C--buflipbot--- lipid ends buffore starts
10880 C--bordlipbot--buffore ends
10881       eliptran=0.0
10882       do i=ilip_start,ilip_end
10883 C       do i=1,1
10884         if (itype(i).eq.ntyp1) cycle
10885
10886         positi=(mod(((c(3,i)+c(3,i+1))/2.0d0),boxzsize))
10887         if (positi.le.0) positi=positi+boxzsize
10888 C        print *,i
10889 C first for peptide groups
10890 c for each residue check if it is in lipid or lipid water border area
10891        if ((positi.gt.bordlipbot)
10892      &.and.(positi.lt.bordliptop)) then
10893 C the energy transfer exist
10894         if (positi.lt.buflipbot) then
10895 C what fraction I am in
10896          fracinbuf=1.0d0-
10897      &        ((positi-bordlipbot)/lipbufthick)
10898 C lipbufthick is thickenes of lipid buffore
10899          sslip=sscalelip(fracinbuf)
10900          ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
10901          eliptran=eliptran+sslip*pepliptran
10902          gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
10903          gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
10904 C         gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
10905
10906 C        print *,"doing sccale for lower part"
10907 C         print *,i,sslip,fracinbuf,ssgradlip
10908         elseif (positi.gt.bufliptop) then
10909          fracinbuf=1.0d0-((bordliptop-positi)/lipbufthick)
10910          sslip=sscalelip(fracinbuf)
10911          ssgradlip=sscagradlip(fracinbuf)/lipbufthick
10912          eliptran=eliptran+sslip*pepliptran
10913          gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
10914          gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
10915 C         gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
10916 C          print *, "doing sscalefor top part"
10917 C         print *,i,sslip,fracinbuf,ssgradlip
10918         else
10919          eliptran=eliptran+pepliptran
10920 C         print *,"I am in true lipid"
10921         endif
10922 C       else
10923 C       eliptran=elpitran+0.0 ! I am in water
10924        endif
10925        enddo
10926 C       print *, "nic nie bylo w lipidzie?"
10927 C now multiply all by the peptide group transfer factor
10928 C       eliptran=eliptran*pepliptran
10929 C now the same for side chains
10930 CV       do i=1,1
10931        do i=ilip_start,ilip_end
10932         if (itype(i).eq.ntyp1) cycle
10933         positi=(mod(c(3,i+nres),boxzsize))
10934         if (positi.le.0) positi=positi+boxzsize
10935 C       print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop
10936 c for each residue check if it is in lipid or lipid water border area
10937 C       respos=mod(c(3,i+nres),boxzsize)
10938 C       print *,positi,bordlipbot,buflipbot
10939        if ((positi.gt.bordlipbot)
10940      & .and.(positi.lt.bordliptop)) then
10941 C the energy transfer exist
10942         if (positi.lt.buflipbot) then
10943          fracinbuf=1.0d0-
10944      &     ((positi-bordlipbot)/lipbufthick)
10945 C lipbufthick is thickenes of lipid buffore
10946          sslip=sscalelip(fracinbuf)
10947          ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
10948          eliptran=eliptran+sslip*liptranene(itype(i))
10949          gliptranx(3,i)=gliptranx(3,i)
10950      &+ssgradlip*liptranene(itype(i))
10951          gliptranc(3,i-1)= gliptranc(3,i-1)
10952      &+ssgradlip*liptranene(itype(i))
10953 C         print *,"doing sccale for lower part"
10954         elseif (positi.gt.bufliptop) then
10955          fracinbuf=1.0d0-
10956      &((bordliptop-positi)/lipbufthick)
10957          sslip=sscalelip(fracinbuf)
10958          ssgradlip=sscagradlip(fracinbuf)/lipbufthick
10959          eliptran=eliptran+sslip*liptranene(itype(i))
10960          gliptranx(3,i)=gliptranx(3,i)
10961      &+ssgradlip*liptranene(itype(i))
10962          gliptranc(3,i-1)= gliptranc(3,i-1)
10963      &+ssgradlip*liptranene(itype(i))
10964 C          print *, "doing sscalefor top part",sslip,fracinbuf
10965         else
10966          eliptran=eliptran+liptranene(itype(i))
10967 C         print *,"I am in true lipid"
10968         endif
10969         endif ! if in lipid or buffor
10970 C       else
10971 C       eliptran=elpitran+0.0 ! I am in water
10972        enddo
10973        return
10974        end
10975 C---------------------------------------------------------
10976 C AFM soubroutine for constant force
10977        subroutine AFMforce(Eafmforce)
10978        implicit real*8 (a-h,o-z)
10979       include 'DIMENSIONS'
10980       include 'COMMON.GEO'
10981       include 'COMMON.VAR'
10982       include 'COMMON.LOCAL'
10983       include 'COMMON.CHAIN'
10984       include 'COMMON.DERIV'
10985       include 'COMMON.NAMES'
10986       include 'COMMON.INTERACT'
10987       include 'COMMON.IOUNITS'
10988       include 'COMMON.CALC'
10989       include 'COMMON.CONTROL'
10990       include 'COMMON.SPLITELE'
10991       include 'COMMON.SBRIDGE'
10992       real*8 diffafm(3)
10993       dist=0.0d0
10994       Eafmforce=0.0d0
10995       do i=1,3
10996       diffafm(i)=c(i,afmend)-c(i,afmbeg)
10997       dist=dist+diffafm(i)**2
10998       enddo
10999       dist=dsqrt(dist)
11000       Eafmforce=-forceAFMconst*(dist-distafminit)
11001       do i=1,3
11002       gradafm(i,afmend-1)=-forceAFMconst*diffafm(i)/dist
11003       gradafm(i,afmbeg-1)=forceAFMconst*diffafm(i)/dist
11004       enddo
11005 C      print *,'AFM',Eafmforce
11006       return
11007       end
11008 C---------------------------------------------------------
11009 C AFM subroutine with pseudoconstant velocity
11010        subroutine AFMvel(Eafmforce)
11011        implicit real*8 (a-h,o-z)
11012       include 'DIMENSIONS'
11013       include 'COMMON.GEO'
11014       include 'COMMON.VAR'
11015       include 'COMMON.LOCAL'
11016       include 'COMMON.CHAIN'
11017       include 'COMMON.DERIV'
11018       include 'COMMON.NAMES'
11019       include 'COMMON.INTERACT'
11020       include 'COMMON.IOUNITS'
11021       include 'COMMON.CALC'
11022       include 'COMMON.CONTROL'
11023       include 'COMMON.SPLITELE'
11024       include 'COMMON.SBRIDGE'
11025       real*8 diffafm(3)
11026 C Only for check grad COMMENT if not used for checkgrad
11027 C      totT=3.0d0
11028 C--------------------------------------------------------
11029 C      print *,"wchodze"
11030       dist=0.0d0
11031       Eafmforce=0.0d0
11032       do i=1,3
11033       diffafm(i)=c(i,afmend)-c(i,afmbeg)
11034       dist=dist+diffafm(i)**2
11035       enddo
11036       dist=dsqrt(dist)
11037       Eafmforce=0.5d0*forceAFMconst
11038      & *(distafminit+totTafm*velAFMconst-dist)**2
11039 C      Eafmforce=-forceAFMconst*(dist-distafminit)
11040       do i=1,3
11041       gradafm(i,afmend-1)=-forceAFMconst*
11042      &(distafminit+totTafm*velAFMconst-dist)
11043      &*diffafm(i)/dist
11044       gradafm(i,afmbeg-1)=forceAFMconst*
11045      &(distafminit+totTafm*velAFMconst-dist)
11046      &*diffafm(i)/dist
11047       enddo
11048 C      print *,'AFM',Eafmforce,totTafm*velAFMconst,dist
11049       return
11050       end
11051
11052 c----------------------------------------------------------------------------
11053       double precision function sscale2(r,r_cut,r0,rlamb)
11054       implicit none
11055       double precision r,gamm,r_cut,r0,rlamb,rr
11056       rr = dabs(r-r0)
11057 c      write (2,*) "r",r," r_cut",r_cut," r0",r0," rlamb",rlamb
11058 c      write (2,*) "rr",rr
11059       if(rr.lt.r_cut-rlamb) then
11060         sscale2=1.0d0
11061       else if(rr.le.r_cut.and.rr.ge.r_cut-rlamb) then
11062         gamm=(rr-(r_cut-rlamb))/rlamb
11063         sscale2=1.0d0+gamm*gamm*(2*gamm-3.0d0)
11064       else
11065         sscale2=0d0
11066       endif
11067       return
11068       end
11069 C-----------------------------------------------------------------------
11070       double precision function sscalgrad2(r,r_cut,r0,rlamb)
11071       implicit none
11072       double precision r,gamm,r_cut,r0,rlamb,rr
11073       rr = dabs(r-r0)
11074       if(rr.lt.r_cut-rlamb) then
11075         sscalgrad2=0.0d0
11076       else if(rr.le.r_cut.and.rr.ge.r_cut-rlamb) then
11077         gamm=(rr-(r_cut-rlamb))/rlamb
11078         sscalgrad2=gamm*(6*gamm-6.0d0)/rlamb
11079         if (r.lt.r0) sscalgrad2=-sscalgrad2
11080       else
11081         sscalgrad2=0.0d0
11082       endif
11083       return
11084       end
11085 c----------------------------------------------------------------------------
11086       subroutine e_saxs(Esaxs_constr)
11087       implicit none
11088       include 'DIMENSIONS'
11089 #ifdef MPI
11090       include "mpif.h"
11091       include "COMMON.SETUP"
11092       integer IERR
11093 #endif
11094       include 'COMMON.SBRIDGE'
11095       include 'COMMON.CHAIN'
11096       include 'COMMON.GEO'
11097       include 'COMMON.DERIV'
11098       include 'COMMON.LOCAL'
11099       include 'COMMON.INTERACT'
11100       include 'COMMON.VAR'
11101       include 'COMMON.IOUNITS'
11102       include 'COMMON.MD'
11103       include 'COMMON.CONTROL'
11104       include 'COMMON.NAMES'
11105       include 'COMMON.TIME1'
11106       include 'COMMON.FFIELD'
11107 c
11108       double precision Esaxs_constr
11109       integer i,iint,j,k,l
11110       double precision PgradC(maxSAXS,3,maxres),
11111      &  PgradX(maxSAXS,3,maxres),Pcalc(maxSAXS)
11112 #ifdef MPI
11113       double precision PgradC_(maxSAXS,3,maxres),
11114      &  PgradX_(maxSAXS,3,maxres),Pcalc_(maxSAXS)
11115 #endif
11116       double precision dk,dijCACA,dijCASC,dijSCCA,dijSCSC,
11117      & sigma2CACA,sigma2CASC,sigma2SCCA,sigma2SCSC,expCACA,expCASC,
11118      & expSCCA,expSCSC,CASCgrad,SCCAgrad,SCSCgrad,aux,auxC,auxC1,
11119      & auxX,auxX1,CACAgrad,Cnorm
11120       double precision sss2,ssgrad2,rrr,sscalgrad2,sscale2
11121       double precision dist
11122       external dist
11123 c  SAXS restraint penalty function
11124 #ifdef DEBUG
11125       write(iout,*) "------- SAXS penalty function start -------"
11126       write (iout,*) "nsaxs",nsaxs
11127       write (iout,*) "Esaxs: iatsc_s",iatsc_s," iatsc_e",iatsc_e
11128       write (iout,*) "Psaxs"
11129       do i=1,nsaxs
11130         write (iout,'(i5,e15.5)') i, Psaxs(i)
11131       enddo
11132 #endif
11133       Esaxs_constr = 0.0d0
11134       do k=1,nsaxs
11135         Pcalc(k)=0.0d0
11136         do j=1,nres
11137           do l=1,3
11138             PgradC(k,l,j)=0.0d0
11139             PgradX(k,l,j)=0.0d0
11140           enddo
11141         enddo
11142       enddo
11143       do i=iatsc_s,iatsc_e
11144        if (itype(i).eq.ntyp1) cycle
11145        do iint=1,nint_gr(i)
11146          do j=istart(i,iint),iend(i,iint)
11147            if (itype(j).eq.ntyp1) cycle
11148 #ifdef ALLSAXS
11149            dijCACA=dist(i,j)
11150            dijCASC=dist(i,j+nres)
11151            dijSCCA=dist(i+nres,j)
11152            dijSCSC=dist(i+nres,j+nres)
11153            sigma2CACA=2.0d0/(pstok**2)
11154            sigma2CASC=4.0d0/(pstok**2+restok(itype(j))**2)
11155            sigma2SCCA=4.0d0/(pstok**2+restok(itype(i))**2)
11156            sigma2SCSC=4.0d0/(restok(itype(j))**2+restok(itype(i))**2)
11157            do k=1,nsaxs
11158              dk = distsaxs(k)
11159              expCACA = dexp(-0.5d0*sigma2CACA*(dijCACA-dk)**2)
11160              if (itype(j).ne.10) then
11161              expCASC = dexp(-0.5d0*sigma2CASC*(dijCASC-dk)**2)
11162              else
11163              endif
11164              expCASC = 0.0d0
11165              if (itype(i).ne.10) then
11166              expSCCA = dexp(-0.5d0*sigma2SCCA*(dijSCCA-dk)**2)
11167              else
11168              expSCCA = 0.0d0
11169              endif
11170              if (itype(i).ne.10 .and. itype(j).ne.10) then
11171              expSCSC = dexp(-0.5d0*sigma2SCSC*(dijSCSC-dk)**2)
11172              else
11173              expSCSC = 0.0d0
11174              endif
11175              Pcalc(k) = Pcalc(k)+expCACA+expCASC+expSCCA+expSCSC
11176 #ifdef DEBUG
11177              write(iout,*) "i j k Pcalc",i,j,Pcalc(k)
11178 #endif
11179              CACAgrad = sigma2CACA*(dijCACA-dk)*expCACA
11180              CASCgrad = sigma2CASC*(dijCASC-dk)*expCASC
11181              SCCAgrad = sigma2SCCA*(dijSCCA-dk)*expSCCA
11182              SCSCgrad = sigma2SCSC*(dijSCSC-dk)*expSCSC
11183              do l=1,3
11184 c CA CA
11185                aux = CACAgrad*(C(l,j)-C(l,i))/dijCACA
11186                PgradC(k,l,i) = PgradC(k,l,i)-aux
11187                PgradC(k,l,j) = PgradC(k,l,j)+aux
11188 c CA SC
11189                if (itype(j).ne.10) then
11190                aux = CASCgrad*(C(l,j+nres)-C(l,i))/dijCASC
11191                PgradC(k,l,i) = PgradC(k,l,i)-aux
11192                PgradC(k,l,j) = PgradC(k,l,j)+aux
11193                PgradX(k,l,j) = PgradX(k,l,j)+aux
11194                endif
11195 c SC CA
11196                if (itype(i).ne.10) then
11197                aux = SCCAgrad*(C(l,j)-C(l,i+nres))/dijSCCA
11198                PgradX(k,l,i) = PgradX(k,l,i)-aux
11199                PgradC(k,l,i) = PgradC(k,l,i)-aux
11200                PgradC(k,l,j) = PgradC(k,l,j)+aux
11201                endif
11202 c SC SC
11203                if (itype(i).ne.10 .and. itype(j).ne.10) then
11204                aux = SCSCgrad*(C(l,j+nres)-C(l,i+nres))/dijSCSC
11205                PgradC(k,l,i) = PgradC(k,l,i)-aux
11206                PgradC(k,l,j) = PgradC(k,l,j)+aux
11207                PgradX(k,l,i) = PgradX(k,l,i)-aux
11208                PgradX(k,l,j) = PgradX(k,l,j)+aux
11209                endif
11210              enddo ! l
11211            enddo ! k
11212 #else
11213            dijCACA=dist(i,j)
11214            sigma2CACA=scal_rad**2*0.25d0/
11215      &        (restok(itype(j))**2+restok(itype(i))**2)
11216            rrr = 2.0d0/dsqrt(sigma2CACA)
11217            do k=1,nsaxs
11218              dk = distsaxs(k)
11219 c             write (2,*) "ijk",i,j,k
11220              sss2 = sscale2(dijCACA,rrr,dk,0.3d0)
11221              if (sss2.ne.0.0d0) then
11222              ssgrad2 = sscalgrad2(dijCACA,rrr,dk,0.3d0)
11223              if (energy_dec) write(iout,'(a4,3i5,4f10.4)')
11224      &          'saxs',i,j,k,dijCACA,rrr,dk,sss2
11225              expCACA = dexp(-0.5d0*sigma2CACA*(dijCACA-dk)**2)*sss2
11226              Pcalc(k) = Pcalc(k)+expCACA
11227 #ifdef DEBUG
11228              write(iout,*) "i j k Pcalc",i,j,Pcalc(k)
11229 #endif
11230              CACAgrad = sigma2CACA*(dijCACA-dk)*expCACA+
11231      &             ssgrad2*expCACA/sss2
11232              do l=1,3
11233 c CA CA
11234                aux = CACAgrad*(C(l,j)-C(l,i))/dijCACA
11235                PgradC(k,l,i) = PgradC(k,l,i)-aux
11236                PgradC(k,l,j) = PgradC(k,l,j)+aux
11237              enddo ! l
11238              endif ! sss
11239            enddo ! k
11240 #endif
11241          enddo ! j
11242        enddo ! iint
11243       enddo ! i
11244 #ifdef MPI
11245       if (nfgtasks.gt.1) then
11246         call MPI_Reduce(Pcalc(1),Pcalc_(1),nsaxs,MPI_DOUBLE_PRECISION,
11247      &    MPI_SUM,king,FG_COMM,IERR)
11248         if (fg_rank.eq.king) then
11249           do k=1,nsaxs
11250             Pcalc(k) = Pcalc_(k)
11251           enddo
11252         endif
11253         call MPI_Reduce(PgradC(k,1,1),PgradC_(k,1,1),3*maxsaxs*nres,
11254      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
11255         if (fg_rank.eq.king) then
11256           do i=1,nres
11257             do l=1,3
11258               do k=1,nsaxs
11259                 PgradC(k,l,i) = PgradC_(k,l,i)
11260               enddo
11261             enddo
11262           enddo
11263         endif
11264 #ifdef ALLSAXS
11265         call MPI_Reduce(PgradX(k,1,1),PgradX_(k,1,1),3*maxsaxs*nres,
11266      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
11267         if (fg_rank.eq.king) then
11268           do i=1,nres
11269             do l=1,3
11270               do k=1,nsaxs
11271                 PgradX(k,l,i) = PgradX_(k,l,i)
11272               enddo
11273             enddo
11274           enddo
11275         endif
11276 #endif
11277       endif
11278 #endif
11279 #ifdef MPI
11280       if (fg_rank.eq.king) then
11281 #endif
11282       Cnorm = 0.0d0
11283       do k=1,nsaxs
11284         Cnorm = Cnorm + Pcalc(k)
11285       enddo
11286       Esaxs_constr = dlog(Cnorm)
11287       do k=1,nsaxs
11288         Esaxs_constr = Esaxs_constr - Psaxs(k)*dlog(Pcalc(k))
11289 #ifdef DEBUG
11290         write (iout,*) "k",k," Esaxs_constr",Esaxs_constr
11291 #endif
11292       enddo
11293 #ifdef DEBUG
11294       write (iout,*) "Cnorm",Cnorm," Esaxs_constr",Esaxs_constr
11295 #endif
11296       do i=nnt,nct
11297         do l=1,3
11298           auxC=0.0d0
11299           auxC1=0.0d0
11300           auxX=0.0d0
11301           auxX1=0.d0
11302           do k=1,nsaxs
11303             auxC  = auxC +Psaxs(k)*PgradC(k,l,i)/Pcalc(k)
11304             auxC1 = auxC1+PgradC(k,l,i)
11305 #ifdef ALLSAXS
11306             auxX  = auxX +Psaxs(k)*PgradX(k,l,i)/Pcalc(k)
11307             auxX1 = auxX1+PgradX(k,l,i)
11308 #endif
11309           enddo
11310           gsaxsC(l,i) = auxC - auxC1/Cnorm
11311 #ifdef ALLSAXS
11312           gsaxsX(l,i) = auxX - auxX1/Cnorm
11313 #endif
11314 c          write (iout,*) "l i",l,i," gradC",wsaxs*(auxC - auxC1/Cnorm),
11315 c     *     " gradX",wsaxs*(auxX - auxX1/Cnorm)
11316         enddo
11317       enddo
11318 #ifdef MPI
11319       endif
11320 #endif
11321       return
11322       end
11323 c----------------------------------------------------------------------------
11324       subroutine e_saxsC(Esaxs_constr)
11325       implicit none
11326       include 'DIMENSIONS'
11327 #ifdef MPI
11328       include "mpif.h"
11329       include "COMMON.SETUP"
11330       integer IERR
11331 #endif
11332       include 'COMMON.SBRIDGE'
11333       include 'COMMON.CHAIN'
11334       include 'COMMON.GEO'
11335       include 'COMMON.DERIV'
11336       include 'COMMON.LOCAL'
11337       include 'COMMON.INTERACT'
11338       include 'COMMON.VAR'
11339       include 'COMMON.IOUNITS'
11340       include 'COMMON.MD'
11341       include 'COMMON.CONTROL'
11342       include 'COMMON.NAMES'
11343       include 'COMMON.TIME1'
11344       include 'COMMON.FFIELD'
11345 c
11346       double precision Esaxs_constr
11347       integer i,iint,j,k,l
11348       double precision PgradC(3,maxres),PgradX(3,maxres),Pcalc,logPtot
11349 #ifdef MPI
11350       double precision gsaxsc_(3,maxres),gsaxsx_(3,maxres),logPtot_
11351 #endif
11352       double precision dk,dijCASPH,dijSCSPH,
11353      & sigma2CA,sigma2SC,expCASPH,expSCSPH,
11354      & CASPHgrad,SCSPHgrad,aux,auxC,auxC1,
11355      & auxX,auxX1,Cnorm
11356 c  SAXS restraint penalty function
11357 #ifdef DEBUG
11358       write(iout,*) "------- SAXS penalty function start -------"
11359       write (iout,*) "nsaxs",nsaxs
11360
11361       do i=nnt,nct
11362         print *,MyRank,"C",i,(C(j,i),j=1,3)
11363       enddo
11364       do i=nnt,nct
11365         print *,MyRank,"CSaxs",i,(Csaxs(j,i),j=1,3)
11366       enddo
11367 #endif
11368       Esaxs_constr = 0.0d0
11369       logPtot=0.0d0
11370       do j=isaxs_start,isaxs_end
11371         Pcalc=0.0d0
11372         do i=1,nres
11373           do l=1,3
11374             PgradC(l,i)=0.0d0
11375             PgradX(l,i)=0.0d0
11376           enddo
11377         enddo
11378         do i=nnt,nct
11379           if (itype(i).eq.ntyp1) cycle
11380           dijCASPH=0.0d0
11381           dijSCSPH=0.0d0
11382           do l=1,3
11383             dijCASPH=dijCASPH+(C(l,i)-Csaxs(l,j))**2
11384           enddo
11385           if (itype(i).ne.10) then
11386           do l=1,3
11387             dijSCSPH=dijSCSPH+(C(l,i+nres)-Csaxs(l,j))**2
11388           enddo
11389           endif
11390           sigma2CA=2.0d0/pstok**2
11391           sigma2SC=4.0d0/restok(itype(i))**2
11392           expCASPH = dexp(-0.5d0*sigma2CA*dijCASPH)
11393           expSCSPH = dexp(-0.5d0*sigma2SC*dijSCSPH)
11394           Pcalc = Pcalc+expCASPH+expSCSPH
11395 #ifdef DEBUG
11396           write(*,*) "processor i j Pcalc",
11397      &       MyRank,i,j,dijCASPH,dijSCSPH, Pcalc
11398 #endif
11399           CASPHgrad = sigma2CA*expCASPH
11400           SCSPHgrad = sigma2SC*expSCSPH
11401           do l=1,3
11402             aux = (C(l,i+nres)-Csaxs(l,j))*SCSPHgrad
11403             PgradX(l,i) = PgradX(l,i) + aux
11404             PgradC(l,i) = PgradC(l,i)+(C(l,i)-Csaxs(l,j))*CASPHgrad+aux
11405           enddo ! l
11406         enddo ! i
11407         do i=nnt,nct
11408           do l=1,3
11409             gsaxsc(l,i)=gsaxsc(l,i)+PgradC(l,i)/Pcalc
11410             gsaxsx(l,i)=gsaxsx(l,i)+PgradX(l,i)/Pcalc
11411           enddo
11412         enddo
11413         logPtot = logPtot - dlog(Pcalc)
11414 c        print *,"me",me,MyRank," j",j," logPcalc",-dlog(Pcalc),
11415 c     &    " logPtot",logPtot
11416       enddo ! j
11417 #ifdef MPI
11418       if (nfgtasks.gt.1) then
11419 c        write (iout,*) "logPtot before reduction",logPtot
11420         call MPI_Reduce(logPtot,logPtot_,1,MPI_DOUBLE_PRECISION,
11421      &    MPI_SUM,king,FG_COMM,IERR)
11422         logPtot = logPtot_
11423 c        write (iout,*) "logPtot after reduction",logPtot
11424         call MPI_Reduce(gsaxsC(1,1),gsaxsC_(1,1),3*nres,
11425      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
11426         if (fg_rank.eq.king) then
11427           do i=1,nres
11428             do l=1,3
11429               gsaxsC(l,i) = gsaxsC_(l,i)
11430             enddo
11431           enddo
11432         endif
11433         call MPI_Reduce(gsaxsX(1,1),gsaxsX_(1,1),3*nres,
11434      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
11435         if (fg_rank.eq.king) then
11436           do i=1,nres
11437             do l=1,3
11438               gsaxsX(l,i) = gsaxsX_(l,i)
11439             enddo
11440           enddo
11441         endif
11442       endif
11443 #endif
11444       Esaxs_constr = logPtot
11445       return
11446       end