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
1534       evdw=0.0D0
1535 ccccc      energy_dec=.false.
1536 C      print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1537       evdw=0.0D0
1538       lprn=.false.
1539 c     if (icall.eq.0) lprn=.false.
1540       ind=0
1541 C the loop over all 27 posible neigbours (for xshift=0,yshift=0,zshift=0
1542 C we have the original box)
1543 C      do xshift=-1,1
1544 C      do yshift=-1,1
1545 C      do zshift=-1,1
1546       do i=iatsc_s,iatsc_e
1547         itypi=iabs(itype(i))
1548         if (itypi.eq.ntyp1) cycle
1549         itypi1=iabs(itype(i+1))
1550         xi=c(1,nres+i)
1551         yi=c(2,nres+i)
1552         zi=c(3,nres+i)
1553 C Return atom into box, boxxsize is size of box in x dimension
1554 c  134   continue
1555 c        if (xi.gt.((xshift+0.5d0)*boxxsize)) xi=xi-boxxsize
1556 c        if (xi.lt.((xshift-0.5d0)*boxxsize)) xi=xi+boxxsize
1557 C Condition for being inside the proper box
1558 c        if ((xi.gt.((xshift+0.5d0)*boxxsize)).or.
1559 c     &       (xi.lt.((xshift-0.5d0)*boxxsize))) then
1560 c        go to 134
1561 c        endif
1562 c  135   continue
1563 c        if (yi.gt.((yshift+0.5d0)*boxysize)) yi=yi-boxysize
1564 c        if (yi.lt.((yshift-0.5d0)*boxysize)) yi=yi+boxysize
1565 C Condition for being inside the proper box
1566 c        if ((yi.gt.((yshift+0.5d0)*boxysize)).or.
1567 c     &       (yi.lt.((yshift-0.5d0)*boxysize))) then
1568 c        go to 135
1569 c        endif
1570 c  136   continue
1571 c        if (zi.gt.((zshift+0.5d0)*boxzsize)) zi=zi-boxzsize
1572 c        if (zi.lt.((zshift-0.5d0)*boxzsize)) zi=zi+boxzsize
1573 C Condition for being inside the proper box
1574 c        if ((zi.gt.((zshift+0.5d0)*boxzsize)).or.
1575 c     &       (zi.lt.((zshift-0.5d0)*boxzsize))) then
1576 c        go to 136
1577 c        endif
1578           xi=mod(xi,boxxsize)
1579           if (xi.lt.0) xi=xi+boxxsize
1580           yi=mod(yi,boxysize)
1581           if (yi.lt.0) yi=yi+boxysize
1582           zi=mod(zi,boxzsize)
1583           if (zi.lt.0) zi=zi+boxzsize
1584 C define scaling factor for lipids
1585
1586 C        if (positi.le.0) positi=positi+boxzsize
1587 C        print *,i
1588 C first for peptide groups
1589 c for each residue check if it is in lipid or lipid water border area
1590        if ((zi.gt.bordlipbot)
1591      &.and.(zi.lt.bordliptop)) then
1592 C the energy transfer exist
1593         if (zi.lt.buflipbot) then
1594 C what fraction I am in
1595          fracinbuf=1.0d0-
1596      &        ((zi-bordlipbot)/lipbufthick)
1597 C lipbufthick is thickenes of lipid buffore
1598          sslipi=sscalelip(fracinbuf)
1599          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
1600         elseif (zi.gt.bufliptop) then
1601          fracinbuf=1.0d0-((bordliptop-zi)/lipbufthick)
1602          sslipi=sscalelip(fracinbuf)
1603          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
1604         else
1605          sslipi=1.0d0
1606          ssgradlipi=0.0
1607         endif
1608        else
1609          sslipi=0.0d0
1610          ssgradlipi=0.0
1611        endif
1612
1613 C          xi=xi+xshift*boxxsize
1614 C          yi=yi+yshift*boxysize
1615 C          zi=zi+zshift*boxzsize
1616
1617         dxi=dc_norm(1,nres+i)
1618         dyi=dc_norm(2,nres+i)
1619         dzi=dc_norm(3,nres+i)
1620 c        dsci_inv=dsc_inv(itypi)
1621         dsci_inv=vbld_inv(i+nres)
1622 c        write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)
1623 c        write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi
1624 C
1625 C Calculate SC interaction energy.
1626 C
1627         do iint=1,nint_gr(i)
1628           do j=istart(i,iint),iend(i,iint)
1629             IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN
1630               call dyn_ssbond_ene(i,j,evdwij)
1631               evdw=evdw+evdwij
1632               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)')
1633      &                        'evdw',i,j,evdwij,' ss'
1634             ELSE
1635             ind=ind+1
1636             itypj=iabs(itype(j))
1637             if (itypj.eq.ntyp1) cycle
1638 c            dscj_inv=dsc_inv(itypj)
1639             dscj_inv=vbld_inv(j+nres)
1640 c            write (iout,*) "j",j,dsc_inv(itypj),dscj_inv,
1641 c     &       1.0d0/vbld(j+nres)
1642 c            write (iout,*) "i",i," j", j," itype",itype(i),itype(j)
1643             sig0ij=sigma(itypi,itypj)
1644             chi1=chi(itypi,itypj)
1645             chi2=chi(itypj,itypi)
1646             chi12=chi1*chi2
1647             chip1=chip(itypi)
1648             chip2=chip(itypj)
1649             chip12=chip1*chip2
1650             alf1=alp(itypi)
1651             alf2=alp(itypj)
1652             alf12=0.5D0*(alf1+alf2)
1653 C For diagnostics only!!!
1654 c           chi1=0.0D0
1655 c           chi2=0.0D0
1656 c           chi12=0.0D0
1657 c           chip1=0.0D0
1658 c           chip2=0.0D0
1659 c           chip12=0.0D0
1660 c           alf1=0.0D0
1661 c           alf2=0.0D0
1662 c           alf12=0.0D0
1663             xj=c(1,nres+j)
1664             yj=c(2,nres+j)
1665             zj=c(3,nres+j)
1666 C Return atom J into box the original box
1667 c  137   continue
1668 c        if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
1669 c        if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
1670 C Condition for being inside the proper box
1671 c        if ((xj.gt.((0.5d0)*boxxsize)).or.
1672 c     &       (xj.lt.((-0.5d0)*boxxsize))) then
1673 c        go to 137
1674 c        endif
1675 c  138   continue
1676 c        if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
1677 c        if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
1678 C Condition for being inside the proper box
1679 c        if ((yj.gt.((0.5d0)*boxysize)).or.
1680 c     &       (yj.lt.((-0.5d0)*boxysize))) then
1681 c        go to 138
1682 c        endif
1683 c  139   continue
1684 c        if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
1685 c        if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
1686 C Condition for being inside the proper box
1687 c        if ((zj.gt.((0.5d0)*boxzsize)).or.
1688 c     &       (zj.lt.((-0.5d0)*boxzsize))) then
1689 c        go to 139
1690 c        endif
1691           xj=mod(xj,boxxsize)
1692           if (xj.lt.0) xj=xj+boxxsize
1693           yj=mod(yj,boxysize)
1694           if (yj.lt.0) yj=yj+boxysize
1695           zj=mod(zj,boxzsize)
1696           if (zj.lt.0) zj=zj+boxzsize
1697        if ((zj.gt.bordlipbot)
1698      &.and.(zj.lt.bordliptop)) then
1699 C the energy transfer exist
1700         if (zj.lt.buflipbot) then
1701 C what fraction I am in
1702          fracinbuf=1.0d0-
1703      &        ((zj-bordlipbot)/lipbufthick)
1704 C lipbufthick is thickenes of lipid buffore
1705          sslipj=sscalelip(fracinbuf)
1706          ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
1707         elseif (zj.gt.bufliptop) then
1708          fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
1709          sslipj=sscalelip(fracinbuf)
1710          ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
1711         else
1712          sslipj=1.0d0
1713          ssgradlipj=0.0
1714         endif
1715        else
1716          sslipj=0.0d0
1717          ssgradlipj=0.0
1718        endif
1719       aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
1720      &  +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1721       bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
1722      &  +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1723 C      if (aa.ne.aa_aq(itypi,itypj)) write(63,'(2e10.5)')
1724 C     &(aa-aa_aq(itypi,itypj)),(bb-bb_aq(itypi,itypj))
1725 C      if (ssgradlipj.gt.0.0d0) print *,"??WTF??"
1726 C      print *,sslipi,sslipj,bordlipbot,zi,zj
1727       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
1728       xj_safe=xj
1729       yj_safe=yj
1730       zj_safe=zj
1731       subchap=0
1732       do xshift=-1,1
1733       do yshift=-1,1
1734       do zshift=-1,1
1735           xj=xj_safe+xshift*boxxsize
1736           yj=yj_safe+yshift*boxysize
1737           zj=zj_safe+zshift*boxzsize
1738           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
1739           if(dist_temp.lt.dist_init) then
1740             dist_init=dist_temp
1741             xj_temp=xj
1742             yj_temp=yj
1743             zj_temp=zj
1744             subchap=1
1745           endif
1746        enddo
1747        enddo
1748        enddo
1749        if (subchap.eq.1) then
1750           xj=xj_temp-xi
1751           yj=yj_temp-yi
1752           zj=zj_temp-zi
1753        else
1754           xj=xj_safe-xi
1755           yj=yj_safe-yi
1756           zj=zj_safe-zi
1757        endif
1758             dxj=dc_norm(1,nres+j)
1759             dyj=dc_norm(2,nres+j)
1760             dzj=dc_norm(3,nres+j)
1761 C            xj=xj-xi
1762 C            yj=yj-yi
1763 C            zj=zj-zi
1764 c            write (iout,*) "dcnorj",dxi*dxi+dyi*dyi+dzi*dzi
1765 c            write (iout,*) "j",j," dc_norm",
1766 c     &       dc_norm(1,nres+j),dc_norm(2,nres+j),dc_norm(3,nres+j)
1767             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1768             rij=dsqrt(rrij)
1769             sss=sscale((1.0d0/rij)/sigma(itypi,itypj))
1770             sssgrad=sscagrad((1.0d0/rij)/sigma(itypi,itypj))
1771
1772 c            write (iout,'(a7,4f8.3)')
1773 c    &      "ssscale",sss,((1.0d0/rij)/sigma(itypi,itypj)),r_cut,rlamb
1774             if (sss.gt.0.0d0) then
1775 C Calculate angle-dependent terms of energy and contributions to their
1776 C derivatives.
1777             call sc_angular
1778             sigsq=1.0D0/sigsq
1779             sig=sig0ij*dsqrt(sigsq)
1780             rij_shift=1.0D0/rij-sig+sig0ij
1781 c for diagnostics; uncomment
1782 c            rij_shift=1.2*sig0ij
1783 C I hate to put IF's in the loops, but here don't have another choice!!!!
1784             if (rij_shift.le.0.0D0) then
1785               evdw=1.0D20
1786 cd              write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1787 cd     &        restyp(itypi),i,restyp(itypj),j,
1788 cd     &        rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq)
1789               return
1790             endif
1791             sigder=-sig*sigsq
1792 c---------------------------------------------------------------
1793             rij_shift=1.0D0/rij_shift
1794             fac=rij_shift**expon
1795 C here to start with
1796 C            if (c(i,3).gt.
1797             faclip=fac
1798             e1=fac*fac*aa
1799             e2=fac*bb
1800             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1801             eps2der=evdwij*eps3rt
1802             eps3der=evdwij*eps2rt
1803 C       write(63,'(2i3,2e10.3,2f10.5)') i,j,aa,bb, evdwij,
1804 C     &((sslipi+sslipj)/2.0d0+
1805 C     &(2.0d0-sslipi-sslipj)/2.0d0)
1806 c            write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt,
1807 c     &        " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2
1808             evdwij=evdwij*eps2rt*eps3rt
1809             evdw=evdw+evdwij*sss
1810             if (lprn) then
1811             sigm=dabs(aa/bb)**(1.0D0/6.0D0)
1812             epsi=bb**2/aa
1813             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1814      &        restyp(itypi),i,restyp(itypj),j,
1815      &        epsi,sigm,chi1,chi2,chip1,chip2,
1816      &        eps1,eps2rt**2,eps3rt**2,sig,sig0ij,
1817      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1818      &        evdwij
1819             endif
1820
1821             if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
1822      &                        'evdw',i,j,evdwij
1823
1824 C Calculate gradient components.
1825             e1=e1*eps1*eps2rt**2*eps3rt**2
1826             fac=-expon*(e1+evdwij)*rij_shift
1827             sigder=fac*sigder
1828             fac=rij*fac
1829 c            print '(2i4,6f8.4)',i,j,sss,sssgrad*
1830 c     &      evdwij,fac,sigma(itypi,itypj),expon
1831             fac=fac+evdwij/sss*sssgrad/sigma(itypi,itypj)*rij
1832 c            fac=0.0d0
1833 C Calculate the radial part of the gradient
1834             gg_lipi(3)=eps1*(eps2rt*eps2rt)
1835      &*(eps3rt*eps3rt)*sss/2.0d0*(faclip*faclip*
1836      & (aa_lip(itypi,itypj)-aa_aq(itypi,itypj))
1837      &+faclip*(bb_lip(itypi,itypj)-bb_aq(itypi,itypj)))
1838             gg_lipj(3)=ssgradlipj*gg_lipi(3)
1839             gg_lipi(3)=gg_lipi(3)*ssgradlipi
1840 C            gg_lipi(3)=0.0d0
1841 C            gg_lipj(3)=0.0d0
1842             gg(1)=xj*fac
1843             gg(2)=yj*fac
1844             gg(3)=zj*fac
1845 C Calculate angular part of the gradient.
1846             call sc_grad
1847             endif
1848             ENDIF    ! dyn_ss
1849           enddo      ! j
1850         enddo        ! iint
1851       enddo          ! i
1852 C      enddo          ! zshift
1853 C      enddo          ! yshift
1854 C      enddo          ! xshift
1855 c      write (iout,*) "Number of loop steps in EGB:",ind
1856 cccc      energy_dec=.false.
1857       return
1858       end
1859 C-----------------------------------------------------------------------------
1860       subroutine egbv(evdw)
1861 C
1862 C This subroutine calculates the interaction energy of nonbonded side chains
1863 C assuming the Gay-Berne-Vorobjev potential of interaction.
1864 C
1865       implicit real*8 (a-h,o-z)
1866       include 'DIMENSIONS'
1867       include 'COMMON.GEO'
1868       include 'COMMON.VAR'
1869       include 'COMMON.LOCAL'
1870       include 'COMMON.CHAIN'
1871       include 'COMMON.DERIV'
1872       include 'COMMON.NAMES'
1873       include 'COMMON.INTERACT'
1874       include 'COMMON.IOUNITS'
1875       include 'COMMON.CALC'
1876       common /srutu/ icall
1877       logical lprn
1878       evdw=0.0D0
1879 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1880       evdw=0.0D0
1881       lprn=.false.
1882 c     if (icall.eq.0) lprn=.true.
1883       ind=0
1884       do i=iatsc_s,iatsc_e
1885         itypi=iabs(itype(i))
1886         if (itypi.eq.ntyp1) cycle
1887         itypi1=iabs(itype(i+1))
1888         xi=c(1,nres+i)
1889         yi=c(2,nres+i)
1890         zi=c(3,nres+i)
1891           xi=mod(xi,boxxsize)
1892           if (xi.lt.0) xi=xi+boxxsize
1893           yi=mod(yi,boxysize)
1894           if (yi.lt.0) yi=yi+boxysize
1895           zi=mod(zi,boxzsize)
1896           if (zi.lt.0) zi=zi+boxzsize
1897 C define scaling factor for lipids
1898
1899 C        if (positi.le.0) positi=positi+boxzsize
1900 C        print *,i
1901 C first for peptide groups
1902 c for each residue check if it is in lipid or lipid water border area
1903        if ((zi.gt.bordlipbot)
1904      &.and.(zi.lt.bordliptop)) then
1905 C the energy transfer exist
1906         if (zi.lt.buflipbot) then
1907 C what fraction I am in
1908          fracinbuf=1.0d0-
1909      &        ((zi-bordlipbot)/lipbufthick)
1910 C lipbufthick is thickenes of lipid buffore
1911          sslipi=sscalelip(fracinbuf)
1912          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
1913         elseif (zi.gt.bufliptop) then
1914          fracinbuf=1.0d0-((bordliptop-zi)/lipbufthick)
1915          sslipi=sscalelip(fracinbuf)
1916          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
1917         else
1918          sslipi=1.0d0
1919          ssgradlipi=0.0
1920         endif
1921        else
1922          sslipi=0.0d0
1923          ssgradlipi=0.0
1924        endif
1925
1926         dxi=dc_norm(1,nres+i)
1927         dyi=dc_norm(2,nres+i)
1928         dzi=dc_norm(3,nres+i)
1929 c        dsci_inv=dsc_inv(itypi)
1930         dsci_inv=vbld_inv(i+nres)
1931 C
1932 C Calculate SC interaction energy.
1933 C
1934         do iint=1,nint_gr(i)
1935           do j=istart(i,iint),iend(i,iint)
1936             ind=ind+1
1937             itypj=iabs(itype(j))
1938             if (itypj.eq.ntyp1) cycle
1939 c            dscj_inv=dsc_inv(itypj)
1940             dscj_inv=vbld_inv(j+nres)
1941             sig0ij=sigma(itypi,itypj)
1942             r0ij=r0(itypi,itypj)
1943             chi1=chi(itypi,itypj)
1944             chi2=chi(itypj,itypi)
1945             chi12=chi1*chi2
1946             chip1=chip(itypi)
1947             chip2=chip(itypj)
1948             chip12=chip1*chip2
1949             alf1=alp(itypi)
1950             alf2=alp(itypj)
1951             alf12=0.5D0*(alf1+alf2)
1952 C For diagnostics only!!!
1953 c           chi1=0.0D0
1954 c           chi2=0.0D0
1955 c           chi12=0.0D0
1956 c           chip1=0.0D0
1957 c           chip2=0.0D0
1958 c           chip12=0.0D0
1959 c           alf1=0.0D0
1960 c           alf2=0.0D0
1961 c           alf12=0.0D0
1962 C            xj=c(1,nres+j)-xi
1963 C            yj=c(2,nres+j)-yi
1964 C            zj=c(3,nres+j)-zi
1965           xj=mod(xj,boxxsize)
1966           if (xj.lt.0) xj=xj+boxxsize
1967           yj=mod(yj,boxysize)
1968           if (yj.lt.0) yj=yj+boxysize
1969           zj=mod(zj,boxzsize)
1970           if (zj.lt.0) zj=zj+boxzsize
1971        if ((zj.gt.bordlipbot)
1972      &.and.(zj.lt.bordliptop)) then
1973 C the energy transfer exist
1974         if (zj.lt.buflipbot) then
1975 C what fraction I am in
1976          fracinbuf=1.0d0-
1977      &        ((zj-bordlipbot)/lipbufthick)
1978 C lipbufthick is thickenes of lipid buffore
1979          sslipj=sscalelip(fracinbuf)
1980          ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
1981         elseif (zj.gt.bufliptop) then
1982          fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
1983          sslipj=sscalelip(fracinbuf)
1984          ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
1985         else
1986          sslipj=1.0d0
1987          ssgradlipj=0.0
1988         endif
1989        else
1990          sslipj=0.0d0
1991          ssgradlipj=0.0
1992        endif
1993       aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
1994      &  +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1995       bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
1996      &  +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1997 C      if (aa.ne.aa_aq(itypi,itypj)) write(63,'2e10.5')
1998 C     &(aa-aa_aq(itypi,itypj)),(bb-bb_aq(itypi,itypj))
1999       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
2000       xj_safe=xj
2001       yj_safe=yj
2002       zj_safe=zj
2003       subchap=0
2004       do xshift=-1,1
2005       do yshift=-1,1
2006       do zshift=-1,1
2007           xj=xj_safe+xshift*boxxsize
2008           yj=yj_safe+yshift*boxysize
2009           zj=zj_safe+zshift*boxzsize
2010           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
2011           if(dist_temp.lt.dist_init) then
2012             dist_init=dist_temp
2013             xj_temp=xj
2014             yj_temp=yj
2015             zj_temp=zj
2016             subchap=1
2017           endif
2018        enddo
2019        enddo
2020        enddo
2021        if (subchap.eq.1) then
2022           xj=xj_temp-xi
2023           yj=yj_temp-yi
2024           zj=zj_temp-zi
2025        else
2026           xj=xj_safe-xi
2027           yj=yj_safe-yi
2028           zj=zj_safe-zi
2029        endif
2030             dxj=dc_norm(1,nres+j)
2031             dyj=dc_norm(2,nres+j)
2032             dzj=dc_norm(3,nres+j)
2033             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
2034             rij=dsqrt(rrij)
2035 C Calculate angle-dependent terms of energy and contributions to their
2036 C derivatives.
2037             call sc_angular
2038             sigsq=1.0D0/sigsq
2039             sig=sig0ij*dsqrt(sigsq)
2040             rij_shift=1.0D0/rij-sig+r0ij
2041 C I hate to put IF's in the loops, but here don't have another choice!!!!
2042             if (rij_shift.le.0.0D0) then
2043               evdw=1.0D20
2044               return
2045             endif
2046             sigder=-sig*sigsq
2047 c---------------------------------------------------------------
2048             rij_shift=1.0D0/rij_shift
2049             fac=rij_shift**expon
2050             e1=fac*fac*aa
2051             e2=fac*bb
2052             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
2053             eps2der=evdwij*eps3rt
2054             eps3der=evdwij*eps2rt
2055             fac_augm=rrij**expon
2056             e_augm=augm(itypi,itypj)*fac_augm
2057             evdwij=evdwij*eps2rt*eps3rt
2058             evdw=evdw+evdwij+e_augm
2059             if (lprn) then
2060             sigm=dabs(aa/bb)**(1.0D0/6.0D0)
2061             epsi=bb**2/aa
2062             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
2063      &        restyp(itypi),i,restyp(itypj),j,
2064      &        epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),
2065      &        chi1,chi2,chip1,chip2,
2066      &        eps1,eps2rt**2,eps3rt**2,
2067      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
2068      &        evdwij+e_augm
2069             endif
2070 C Calculate gradient components.
2071             e1=e1*eps1*eps2rt**2*eps3rt**2
2072             fac=-expon*(e1+evdwij)*rij_shift
2073             sigder=fac*sigder
2074             fac=rij*fac-2*expon*rrij*e_augm
2075             fac=fac+evdwij/sss*sssgrad/sigma(itypi,itypj)*rij
2076 C Calculate the radial part of the gradient
2077             gg(1)=xj*fac
2078             gg(2)=yj*fac
2079             gg(3)=zj*fac
2080 C Calculate angular part of the gradient.
2081             call sc_grad
2082           enddo      ! j
2083         enddo        ! iint
2084       enddo          ! i
2085       end
2086 C-----------------------------------------------------------------------------
2087       subroutine sc_angular
2088 C Calculate eps1,eps2,eps3,sigma, and parts of their derivatives in om1,om2,
2089 C om12. Called by ebp, egb, and egbv.
2090       implicit none
2091       include 'COMMON.CALC'
2092       include 'COMMON.IOUNITS'
2093       erij(1)=xj*rij
2094       erij(2)=yj*rij
2095       erij(3)=zj*rij
2096       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
2097       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
2098       om12=dxi*dxj+dyi*dyj+dzi*dzj
2099       chiom12=chi12*om12
2100 C Calculate eps1(om12) and its derivative in om12
2101       faceps1=1.0D0-om12*chiom12
2102       faceps1_inv=1.0D0/faceps1
2103       eps1=dsqrt(faceps1_inv)
2104 C Following variable is eps1*deps1/dom12
2105       eps1_om12=faceps1_inv*chiom12
2106 c diagnostics only
2107 c      faceps1_inv=om12
2108 c      eps1=om12
2109 c      eps1_om12=1.0d0
2110 c      write (iout,*) "om12",om12," eps1",eps1
2111 C Calculate sigma(om1,om2,om12) and the derivatives of sigma**2 in om1,om2,
2112 C and om12.
2113       om1om2=om1*om2
2114       chiom1=chi1*om1
2115       chiom2=chi2*om2
2116       facsig=om1*chiom1+om2*chiom2-2.0D0*om1om2*chiom12
2117       sigsq=1.0D0-facsig*faceps1_inv
2118       sigsq_om1=(chiom1-chiom12*om2)*faceps1_inv
2119       sigsq_om2=(chiom2-chiom12*om1)*faceps1_inv
2120       sigsq_om12=-chi12*(om1om2*faceps1-om12*facsig)*faceps1_inv**2
2121 c diagnostics only
2122 c      sigsq=1.0d0
2123 c      sigsq_om1=0.0d0
2124 c      sigsq_om2=0.0d0
2125 c      sigsq_om12=0.0d0
2126 c      write (iout,*) "chiom1",chiom1," chiom2",chiom2," chiom12",chiom12
2127 c      write (iout,*) "faceps1",faceps1," faceps1_inv",faceps1_inv,
2128 c     &    " eps1",eps1
2129 C Calculate eps2 and its derivatives in om1, om2, and om12.
2130       chipom1=chip1*om1
2131       chipom2=chip2*om2
2132       chipom12=chip12*om12
2133       facp=1.0D0-om12*chipom12
2134       facp_inv=1.0D0/facp
2135       facp1=om1*chipom1+om2*chipom2-2.0D0*om1om2*chipom12
2136 c      write (iout,*) "chipom1",chipom1," chipom2",chipom2,
2137 c     &  " chipom12",chipom12," facp",facp," facp_inv",facp_inv
2138 C Following variable is the square root of eps2
2139       eps2rt=1.0D0-facp1*facp_inv
2140 C Following three variables are the derivatives of the square root of eps
2141 C in om1, om2, and om12.
2142       eps2rt_om1=-4.0D0*(chipom1-chipom12*om2)*facp_inv
2143       eps2rt_om2=-4.0D0*(chipom2-chipom12*om1)*facp_inv
2144       eps2rt_om12=4.0D0*chip12*(om1om2*facp-om12*facp1)*facp_inv**2
2145 C Evaluate the "asymmetric" factor in the VDW constant, eps3
2146       eps3rt=1.0D0-alf1*om1+alf2*om2-alf12*om12
2147 c      write (iout,*) "eps2rt",eps2rt," eps3rt",eps3rt
2148 c      write (iout,*) "eps2rt_om1",eps2rt_om1," eps2rt_om2",eps2rt_om2,
2149 c     &  " eps2rt_om12",eps2rt_om12
2150 C Calculate whole angle-dependent part of epsilon and contributions
2151 C to its derivatives
2152       return
2153       end
2154 C----------------------------------------------------------------------------
2155       subroutine sc_grad
2156       implicit real*8 (a-h,o-z)
2157       include 'DIMENSIONS'
2158       include 'COMMON.CHAIN'
2159       include 'COMMON.DERIV'
2160       include 'COMMON.CALC'
2161       include 'COMMON.IOUNITS'
2162       double precision dcosom1(3),dcosom2(3)
2163 cc      print *,'sss=',sss
2164       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
2165       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
2166       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12
2167      &     -2.0D0*alf12*eps3der+sigder*sigsq_om12
2168 c diagnostics only
2169 c      eom1=0.0d0
2170 c      eom2=0.0d0
2171 c      eom12=evdwij*eps1_om12
2172 c end diagnostics
2173 c      write (iout,*) "eps2der",eps2der," eps3der",eps3der,
2174 c     &  " sigder",sigder
2175 c      write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12
2176 c      write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12
2177       do k=1,3
2178         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
2179         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
2180       enddo
2181       do k=1,3
2182         gg(k)=(gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k))*sss
2183       enddo
2184 c      write (iout,*) "gg",(gg(k),k=1,3)
2185       do k=1,3
2186         gvdwx(k,i)=gvdwx(k,i)-gg(k)+gg_lipi(k)
2187      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
2188      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv*sss
2189         gvdwx(k,j)=gvdwx(k,j)+gg(k)+gg_lipj(k)
2190      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
2191      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv*sss
2192 c        write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
2193 c     &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
2194 c        write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
2195 c     &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
2196       enddo
2197 C
2198 C Calculate the components of the gradient in DC and X
2199 C
2200 cgrad      do k=i,j-1
2201 cgrad        do l=1,3
2202 cgrad          gvdwc(l,k)=gvdwc(l,k)+gg(l)
2203 cgrad        enddo
2204 cgrad      enddo
2205       do l=1,3
2206         gvdwc(l,i)=gvdwc(l,i)-gg(l)+gg_lipi(l)
2207         gvdwc(l,j)=gvdwc(l,j)+gg(l)+gg_lipj(l)
2208       enddo
2209       return
2210       end
2211 C-----------------------------------------------------------------------
2212       subroutine e_softsphere(evdw)
2213 C
2214 C This subroutine calculates the interaction energy of nonbonded side chains
2215 C assuming the LJ potential of interaction.
2216 C
2217       implicit real*8 (a-h,o-z)
2218       include 'DIMENSIONS'
2219       parameter (accur=1.0d-10)
2220       include 'COMMON.GEO'
2221       include 'COMMON.VAR'
2222       include 'COMMON.LOCAL'
2223       include 'COMMON.CHAIN'
2224       include 'COMMON.DERIV'
2225       include 'COMMON.INTERACT'
2226       include 'COMMON.TORSION'
2227       include 'COMMON.SBRIDGE'
2228       include 'COMMON.NAMES'
2229       include 'COMMON.IOUNITS'
2230       include 'COMMON.CONTACTS'
2231       dimension gg(3)
2232 cd    print *,'Entering Esoft_sphere nnt=',nnt,' nct=',nct
2233       evdw=0.0D0
2234       do i=iatsc_s,iatsc_e
2235         itypi=iabs(itype(i))
2236         if (itypi.eq.ntyp1) cycle
2237         itypi1=iabs(itype(i+1))
2238         xi=c(1,nres+i)
2239         yi=c(2,nres+i)
2240         zi=c(3,nres+i)
2241 C
2242 C Calculate SC interaction energy.
2243 C
2244         do iint=1,nint_gr(i)
2245 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
2246 cd   &                  'iend=',iend(i,iint)
2247           do j=istart(i,iint),iend(i,iint)
2248             itypj=iabs(itype(j))
2249             if (itypj.eq.ntyp1) cycle
2250             xj=c(1,nres+j)-xi
2251             yj=c(2,nres+j)-yi
2252             zj=c(3,nres+j)-zi
2253             rij=xj*xj+yj*yj+zj*zj
2254 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
2255             r0ij=r0(itypi,itypj)
2256             r0ijsq=r0ij*r0ij
2257 c            print *,i,j,r0ij,dsqrt(rij)
2258             if (rij.lt.r0ijsq) then
2259               evdwij=0.25d0*(rij-r0ijsq)**2
2260               fac=rij-r0ijsq
2261             else
2262               evdwij=0.0d0
2263               fac=0.0d0
2264             endif
2265             evdw=evdw+evdwij
2266 C
2267 C Calculate the components of the gradient in DC and X
2268 C
2269             gg(1)=xj*fac
2270             gg(2)=yj*fac
2271             gg(3)=zj*fac
2272             do k=1,3
2273               gvdwx(k,i)=gvdwx(k,i)-gg(k)
2274               gvdwx(k,j)=gvdwx(k,j)+gg(k)
2275               gvdwc(k,i)=gvdwc(k,i)-gg(k)
2276               gvdwc(k,j)=gvdwc(k,j)+gg(k)
2277             enddo
2278 cgrad            do k=i,j-1
2279 cgrad              do l=1,3
2280 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
2281 cgrad              enddo
2282 cgrad            enddo
2283           enddo ! j
2284         enddo ! iint
2285       enddo ! i
2286       return
2287       end
2288 C--------------------------------------------------------------------------
2289       subroutine eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,
2290      &              eello_turn4)
2291 C
2292 C Soft-sphere potential of p-p interaction
2293 C
2294       implicit real*8 (a-h,o-z)
2295       include 'DIMENSIONS'
2296       include 'COMMON.CONTROL'
2297       include 'COMMON.IOUNITS'
2298       include 'COMMON.GEO'
2299       include 'COMMON.VAR'
2300       include 'COMMON.LOCAL'
2301       include 'COMMON.CHAIN'
2302       include 'COMMON.DERIV'
2303       include 'COMMON.INTERACT'
2304       include 'COMMON.CONTACTS'
2305       include 'COMMON.TORSION'
2306       include 'COMMON.VECTORS'
2307       include 'COMMON.FFIELD'
2308       dimension ggg(3)
2309 C      write(iout,*) 'In EELEC_soft_sphere'
2310       ees=0.0D0
2311       evdw1=0.0D0
2312       eel_loc=0.0d0
2313       eello_turn3=0.0d0
2314       eello_turn4=0.0d0
2315       ind=0
2316       do i=iatel_s,iatel_e
2317         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
2318         dxi=dc(1,i)
2319         dyi=dc(2,i)
2320         dzi=dc(3,i)
2321         xmedi=c(1,i)+0.5d0*dxi
2322         ymedi=c(2,i)+0.5d0*dyi
2323         zmedi=c(3,i)+0.5d0*dzi
2324           xmedi=mod(xmedi,boxxsize)
2325           if (xmedi.lt.0) xmedi=xmedi+boxxsize
2326           ymedi=mod(ymedi,boxysize)
2327           if (ymedi.lt.0) ymedi=ymedi+boxysize
2328           zmedi=mod(zmedi,boxzsize)
2329           if (zmedi.lt.0) zmedi=zmedi+boxzsize
2330         num_conti=0
2331 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
2332         do j=ielstart(i),ielend(i)
2333           if (itype(j).eq.ntyp1 .or. itype(j+1).eq.ntyp1) cycle
2334           ind=ind+1
2335           iteli=itel(i)
2336           itelj=itel(j)
2337           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
2338           r0ij=rpp(iteli,itelj)
2339           r0ijsq=r0ij*r0ij
2340           dxj=dc(1,j)
2341           dyj=dc(2,j)
2342           dzj=dc(3,j)
2343           xj=c(1,j)+0.5D0*dxj
2344           yj=c(2,j)+0.5D0*dyj
2345           zj=c(3,j)+0.5D0*dzj
2346           xj=mod(xj,boxxsize)
2347           if (xj.lt.0) xj=xj+boxxsize
2348           yj=mod(yj,boxysize)
2349           if (yj.lt.0) yj=yj+boxysize
2350           zj=mod(zj,boxzsize)
2351           if (zj.lt.0) zj=zj+boxzsize
2352       dist_init=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
2353       xj_safe=xj
2354       yj_safe=yj
2355       zj_safe=zj
2356       isubchap=0
2357       do xshift=-1,1
2358       do yshift=-1,1
2359       do zshift=-1,1
2360           xj=xj_safe+xshift*boxxsize
2361           yj=yj_safe+yshift*boxysize
2362           zj=zj_safe+zshift*boxzsize
2363           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
2364           if(dist_temp.lt.dist_init) then
2365             dist_init=dist_temp
2366             xj_temp=xj
2367             yj_temp=yj
2368             zj_temp=zj
2369             isubchap=1
2370           endif
2371        enddo
2372        enddo
2373        enddo
2374        if (isubchap.eq.1) then
2375           xj=xj_temp-xmedi
2376           yj=yj_temp-ymedi
2377           zj=zj_temp-zmedi
2378        else
2379           xj=xj_safe-xmedi
2380           yj=yj_safe-ymedi
2381           zj=zj_safe-zmedi
2382        endif
2383           rij=xj*xj+yj*yj+zj*zj
2384             sss=sscale(sqrt(rij))
2385             sssgrad=sscagrad(sqrt(rij))
2386           if (rij.lt.r0ijsq) then
2387             evdw1ij=0.25d0*(rij-r0ijsq)**2
2388             fac=rij-r0ijsq
2389           else
2390             evdw1ij=0.0d0
2391             fac=0.0d0
2392           endif
2393           evdw1=evdw1+evdw1ij*sss
2394 C
2395 C Calculate contributions to the Cartesian gradient.
2396 C
2397           ggg(1)=fac*xj*sssgrad
2398           ggg(2)=fac*yj*sssgrad
2399           ggg(3)=fac*zj*sssgrad
2400           do k=1,3
2401             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
2402             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
2403           enddo
2404 *
2405 * Loop over residues i+1 thru j-1.
2406 *
2407 cgrad          do k=i+1,j-1
2408 cgrad            do l=1,3
2409 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
2410 cgrad            enddo
2411 cgrad          enddo
2412         enddo ! j
2413       enddo   ! i
2414 cgrad      do i=nnt,nct-1
2415 cgrad        do k=1,3
2416 cgrad          gelc(k,i)=gelc(k,i)+0.5d0*gelc(k,i)
2417 cgrad        enddo
2418 cgrad        do j=i+1,nct-1
2419 cgrad          do k=1,3
2420 cgrad            gelc(k,i)=gelc(k,i)+gelc(k,j)
2421 cgrad          enddo
2422 cgrad        enddo
2423 cgrad      enddo
2424       return
2425       end
2426 c------------------------------------------------------------------------------
2427       subroutine vec_and_deriv
2428       implicit real*8 (a-h,o-z)
2429       include 'DIMENSIONS'
2430 #ifdef MPI
2431       include 'mpif.h'
2432 #endif
2433       include 'COMMON.IOUNITS'
2434       include 'COMMON.GEO'
2435       include 'COMMON.VAR'
2436       include 'COMMON.LOCAL'
2437       include 'COMMON.CHAIN'
2438       include 'COMMON.VECTORS'
2439       include 'COMMON.SETUP'
2440       include 'COMMON.TIME1'
2441       dimension uyder(3,3,2),uzder(3,3,2),vbld_inv_temp(2)
2442 C Compute the local reference systems. For reference system (i), the
2443 C X-axis points from CA(i) to CA(i+1), the Y axis is in the
2444 C CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
2445 #ifdef PARVEC
2446       do i=ivec_start,ivec_end
2447 #else
2448       do i=1,nres-1
2449 #endif
2450           if (i.eq.nres-1) then
2451 C Case of the last full residue
2452 C Compute the Z-axis
2453             call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
2454             costh=dcos(pi-theta(nres))
2455             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2456             do k=1,3
2457               uz(k,i)=fac*uz(k,i)
2458             enddo
2459 C Compute the derivatives of uz
2460             uzder(1,1,1)= 0.0d0
2461             uzder(2,1,1)=-dc_norm(3,i-1)
2462             uzder(3,1,1)= dc_norm(2,i-1)
2463             uzder(1,2,1)= dc_norm(3,i-1)
2464             uzder(2,2,1)= 0.0d0
2465             uzder(3,2,1)=-dc_norm(1,i-1)
2466             uzder(1,3,1)=-dc_norm(2,i-1)
2467             uzder(2,3,1)= dc_norm(1,i-1)
2468             uzder(3,3,1)= 0.0d0
2469             uzder(1,1,2)= 0.0d0
2470             uzder(2,1,2)= dc_norm(3,i)
2471             uzder(3,1,2)=-dc_norm(2,i)
2472             uzder(1,2,2)=-dc_norm(3,i)
2473             uzder(2,2,2)= 0.0d0
2474             uzder(3,2,2)= dc_norm(1,i)
2475             uzder(1,3,2)= dc_norm(2,i)
2476             uzder(2,3,2)=-dc_norm(1,i)
2477             uzder(3,3,2)= 0.0d0
2478 C Compute the Y-axis
2479             facy=fac
2480             do k=1,3
2481               uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
2482             enddo
2483 C Compute the derivatives of uy
2484             do j=1,3
2485               do k=1,3
2486                 uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i)
2487      &                        -dc_norm(k,i)*dc_norm(j,i-1)
2488                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2489               enddo
2490               uyder(j,j,1)=uyder(j,j,1)-costh
2491               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2492             enddo
2493             do j=1,2
2494               do k=1,3
2495                 do l=1,3
2496                   uygrad(l,k,j,i)=uyder(l,k,j)
2497                   uzgrad(l,k,j,i)=uzder(l,k,j)
2498                 enddo
2499               enddo
2500             enddo
2501             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2502             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2503             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2504             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2505           else
2506 C Other residues
2507 C Compute the Z-axis
2508             call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
2509             costh=dcos(pi-theta(i+2))
2510             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2511             do k=1,3
2512               uz(k,i)=fac*uz(k,i)
2513             enddo
2514 C Compute the derivatives of uz
2515             uzder(1,1,1)= 0.0d0
2516             uzder(2,1,1)=-dc_norm(3,i+1)
2517             uzder(3,1,1)= dc_norm(2,i+1)
2518             uzder(1,2,1)= dc_norm(3,i+1)
2519             uzder(2,2,1)= 0.0d0
2520             uzder(3,2,1)=-dc_norm(1,i+1)
2521             uzder(1,3,1)=-dc_norm(2,i+1)
2522             uzder(2,3,1)= dc_norm(1,i+1)
2523             uzder(3,3,1)= 0.0d0
2524             uzder(1,1,2)= 0.0d0
2525             uzder(2,1,2)= dc_norm(3,i)
2526             uzder(3,1,2)=-dc_norm(2,i)
2527             uzder(1,2,2)=-dc_norm(3,i)
2528             uzder(2,2,2)= 0.0d0
2529             uzder(3,2,2)= dc_norm(1,i)
2530             uzder(1,3,2)= dc_norm(2,i)
2531             uzder(2,3,2)=-dc_norm(1,i)
2532             uzder(3,3,2)= 0.0d0
2533 C Compute the Y-axis
2534             facy=fac
2535             do k=1,3
2536               uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
2537             enddo
2538 C Compute the derivatives of uy
2539             do j=1,3
2540               do k=1,3
2541                 uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i)
2542      &                        -dc_norm(k,i)*dc_norm(j,i+1)
2543                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2544               enddo
2545               uyder(j,j,1)=uyder(j,j,1)-costh
2546               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2547             enddo
2548             do j=1,2
2549               do k=1,3
2550                 do l=1,3
2551                   uygrad(l,k,j,i)=uyder(l,k,j)
2552                   uzgrad(l,k,j,i)=uzder(l,k,j)
2553                 enddo
2554               enddo
2555             enddo
2556             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2557             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2558             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2559             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2560           endif
2561       enddo
2562       do i=1,nres-1
2563         vbld_inv_temp(1)=vbld_inv(i+1)
2564         if (i.lt.nres-1) then
2565           vbld_inv_temp(2)=vbld_inv(i+2)
2566           else
2567           vbld_inv_temp(2)=vbld_inv(i)
2568           endif
2569         do j=1,2
2570           do k=1,3
2571             do l=1,3
2572               uygrad(l,k,j,i)=vbld_inv_temp(j)*uygrad(l,k,j,i)
2573               uzgrad(l,k,j,i)=vbld_inv_temp(j)*uzgrad(l,k,j,i)
2574             enddo
2575           enddo
2576         enddo
2577       enddo
2578 #if defined(PARVEC) && defined(MPI)
2579       if (nfgtasks1.gt.1) then
2580         time00=MPI_Wtime()
2581 c        print *,"Processor",fg_rank1,kolor1," ivec_start",ivec_start,
2582 c     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks1-1),
2583 c     &   " ivec_count",(ivec_count(i),i=0,nfgtasks1-1)
2584         call MPI_Allgatherv(uy(1,ivec_start),ivec_count(fg_rank1),
2585      &   MPI_UYZ,uy(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
2586      &   FG_COMM1,IERR)
2587         call MPI_Allgatherv(uz(1,ivec_start),ivec_count(fg_rank1),
2588      &   MPI_UYZ,uz(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
2589      &   FG_COMM1,IERR)
2590         call MPI_Allgatherv(uygrad(1,1,1,ivec_start),
2591      &   ivec_count(fg_rank1),MPI_UYZGRAD,uygrad(1,1,1,1),ivec_count(0),
2592      &   ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2593         call MPI_Allgatherv(uzgrad(1,1,1,ivec_start),
2594      &   ivec_count(fg_rank1),MPI_UYZGRAD,uzgrad(1,1,1,1),ivec_count(0),
2595      &   ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2596         time_gather=time_gather+MPI_Wtime()-time00
2597       endif
2598 c      if (fg_rank.eq.0) then
2599 c        write (iout,*) "Arrays UY and UZ"
2600 c        do i=1,nres-1
2601 c          write (iout,'(i5,3f10.5,5x,3f10.5)') i,(uy(k,i),k=1,3),
2602 c     &     (uz(k,i),k=1,3)
2603 c        enddo
2604 c      endif
2605 #endif
2606       return
2607       end
2608 C-----------------------------------------------------------------------------
2609       subroutine check_vecgrad
2610       implicit real*8 (a-h,o-z)
2611       include 'DIMENSIONS'
2612       include 'COMMON.IOUNITS'
2613       include 'COMMON.GEO'
2614       include 'COMMON.VAR'
2615       include 'COMMON.LOCAL'
2616       include 'COMMON.CHAIN'
2617       include 'COMMON.VECTORS'
2618       dimension uygradt(3,3,2,maxres),uzgradt(3,3,2,maxres)
2619       dimension uyt(3,maxres),uzt(3,maxres)
2620       dimension uygradn(3,3,2),uzgradn(3,3,2),erij(3)
2621       double precision delta /1.0d-7/
2622       call vec_and_deriv
2623 cd      do i=1,nres
2624 crc          write(iout,'(2i5,2(3f10.5,5x))') i,1,dc_norm(:,i)
2625 crc          write(iout,'(2i5,2(3f10.5,5x))') i,2,uy(:,i)
2626 crc          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,uz(:,i)
2627 cd          write(iout,'(2i5,2(3f10.5,5x))') i,1,
2628 cd     &     (dc_norm(if90,i),if90=1,3)
2629 cd          write(iout,'(2i5,2(3f10.5,5x))') i,2,(uy(if90,i),if90=1,3)
2630 cd          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,(uz(if90,i),if90=1,3)
2631 cd          write(iout,'(a)')
2632 cd      enddo
2633       do i=1,nres
2634         do j=1,2
2635           do k=1,3
2636             do l=1,3
2637               uygradt(l,k,j,i)=uygrad(l,k,j,i)
2638               uzgradt(l,k,j,i)=uzgrad(l,k,j,i)
2639             enddo
2640           enddo
2641         enddo
2642       enddo
2643       call vec_and_deriv
2644       do i=1,nres
2645         do j=1,3
2646           uyt(j,i)=uy(j,i)
2647           uzt(j,i)=uz(j,i)
2648         enddo
2649       enddo
2650       do i=1,nres
2651 cd        write (iout,*) 'i=',i
2652         do k=1,3
2653           erij(k)=dc_norm(k,i)
2654         enddo
2655         do j=1,3
2656           do k=1,3
2657             dc_norm(k,i)=erij(k)
2658           enddo
2659           dc_norm(j,i)=dc_norm(j,i)+delta
2660 c          fac=dsqrt(scalar(dc_norm(1,i),dc_norm(1,i)))
2661 c          do k=1,3
2662 c            dc_norm(k,i)=dc_norm(k,i)/fac
2663 c          enddo
2664 c          write (iout,*) (dc_norm(k,i),k=1,3)
2665 c          write (iout,*) (erij(k),k=1,3)
2666           call vec_and_deriv
2667           do k=1,3
2668             uygradn(k,j,1)=(uy(k,i)-uyt(k,i))/delta
2669             uygradn(k,j,2)=(uy(k,i-1)-uyt(k,i-1))/delta
2670             uzgradn(k,j,1)=(uz(k,i)-uzt(k,i))/delta
2671             uzgradn(k,j,2)=(uz(k,i-1)-uzt(k,i-1))/delta
2672           enddo
2673 c          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2674 c     &      j,(uzgradt(k,j,1,i),k=1,3),(uzgradn(k,j,1),k=1,3),
2675 c     &      (uzgradt(k,j,2,i-1),k=1,3),(uzgradn(k,j,2),k=1,3)
2676         enddo
2677         do k=1,3
2678           dc_norm(k,i)=erij(k)
2679         enddo
2680 cd        do k=1,3
2681 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2682 cd     &      k,(uygradt(k,l,1,i),l=1,3),(uygradn(k,l,1),l=1,3),
2683 cd     &      (uygradt(k,l,2,i-1),l=1,3),(uygradn(k,l,2),l=1,3)
2684 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2685 cd     &      k,(uzgradt(k,l,1,i),l=1,3),(uzgradn(k,l,1),l=1,3),
2686 cd     &      (uzgradt(k,l,2,i-1),l=1,3),(uzgradn(k,l,2),l=1,3)
2687 cd          write (iout,'(a)')
2688 cd        enddo
2689       enddo
2690       return
2691       end
2692 C--------------------------------------------------------------------------
2693       subroutine set_matrices
2694       implicit real*8 (a-h,o-z)
2695       include 'DIMENSIONS'
2696 #ifdef MPI
2697       include "mpif.h"
2698       include "COMMON.SETUP"
2699       integer IERR
2700       integer status(MPI_STATUS_SIZE)
2701 #endif
2702       include 'COMMON.IOUNITS'
2703       include 'COMMON.GEO'
2704       include 'COMMON.VAR'
2705       include 'COMMON.LOCAL'
2706       include 'COMMON.CHAIN'
2707       include 'COMMON.DERIV'
2708       include 'COMMON.INTERACT'
2709       include 'COMMON.CONTACTS'
2710       include 'COMMON.TORSION'
2711       include 'COMMON.VECTORS'
2712       include 'COMMON.FFIELD'
2713       double precision auxvec(2),auxmat(2,2)
2714 C
2715 C Compute the virtual-bond-torsional-angle dependent quantities needed
2716 C to calculate the el-loc multibody terms of various order.
2717 C
2718 c      write(iout,*) 'nphi=',nphi,nres
2719 #ifdef PARMAT
2720       do i=ivec_start+2,ivec_end+2
2721 #else
2722       do i=3,nres+1
2723 #endif
2724 #ifdef NEWCORR
2725         if (i.gt. nnt+2 .and. i.lt.nct+2) then
2726           iti = itortyp(itype(i-2))
2727         else
2728           iti=ntortyp+1
2729         endif
2730 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2731         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2732           iti1 = itortyp(itype(i-1))
2733         else
2734           iti1=ntortyp+1
2735         endif
2736 c        write(iout,*),i
2737         b1(1,i-2)=bnew1(1,1,iti)*dsin(theta(i-1)/2.0)
2738      &           +bnew1(2,1,iti)*dsin(theta(i-1))
2739      &           +bnew1(3,1,iti)*dcos(theta(i-1)/2.0)
2740         gtb1(1,i-2)=bnew1(1,1,iti)*dcos(theta(i-1)/2.0d0)/2.0d0
2741      &             +bnew1(2,1,iti)*dcos(theta(i-1))
2742      &             -bnew1(3,1,iti)*dsin(theta(i-1)/2.0d0)/2.0d0
2743 c     &           +bnew1(3,1,iti)*sin(alpha(i))*cos(beta(i))
2744 c     &*(cos(theta(i)/2.0)
2745         b2(1,i-2)=bnew2(1,1,iti)*dsin(theta(i-1)/2.0)
2746      &           +bnew2(2,1,iti)*dsin(theta(i-1))
2747      &           +bnew2(3,1,iti)*dcos(theta(i-1)/2.0)
2748 c     &           +bnew2(3,1,iti)*sin(alpha(i))*cos(beta(i))
2749 c     &*(cos(theta(i)/2.0)
2750         gtb2(1,i-2)=bnew2(1,1,iti)*dcos(theta(i-1)/2.0d0)/2.0d0
2751      &             +bnew2(2,1,iti)*dcos(theta(i-1))
2752      &             -bnew2(3,1,iti)*dsin(theta(i-1)/2.0d0)/2.0d0
2753 c        if (ggb1(1,i).eq.0.0d0) then
2754 c        write(iout,*) 'i=',i,ggb1(1,i),
2755 c     &bnew1(1,1,iti)*cos(theta(i)/2.0)/2.0,
2756 c     &bnew1(2,1,iti)*cos(theta(i)),
2757 c     &bnew1(3,1,iti)*sin(theta(i)/2.0)/2.0
2758 c        endif
2759         b1(2,i-2)=bnew1(1,2,iti)
2760         gtb1(2,i-2)=0.0
2761         b2(2,i-2)=bnew2(1,2,iti)
2762         gtb2(2,i-2)=0.0
2763         EE(1,1,i-2)=eenew(1,iti)*dcos(theta(i-1))
2764         EE(1,2,i-2)=eeold(1,2,iti)
2765         EE(2,1,i-2)=eeold(2,1,iti)
2766         EE(2,2,i-2)=eeold(2,2,iti)
2767         gtEE(1,1,i-2)=-eenew(1,iti)*dsin(theta(i-1))
2768         gtEE(1,2,i-2)=0.0d0
2769         gtEE(2,2,i-2)=0.0d0
2770         gtEE(2,1,i-2)=0.0d0
2771 c        EE(2,2,iti)=0.0d0
2772 c        EE(1,2,iti)=0.5d0*eenew(1,iti)
2773 c        EE(2,1,iti)=0.5d0*eenew(1,iti)
2774 c        b1(2,iti)=bnew1(1,2,iti)*sin(alpha(i))*sin(beta(i))
2775 c        b2(2,iti)=bnew2(1,2,iti)*sin(alpha(i))*sin(beta(i))
2776        b1tilde(1,i-2)=b1(1,i-2)
2777        b1tilde(2,i-2)=-b1(2,i-2)
2778        b2tilde(1,i-2)=b2(1,i-2)
2779        b2tilde(2,i-2)=-b2(2,i-2)
2780 c       write (iout,*) 'i=',i-2,gtb1(2,i-2),gtb1(1,i-2)
2781 c       write(iout,*)  'b1=',b1(1,i-2)
2782 c       write (iout,*) 'theta=', theta(i-1)
2783         enddo
2784 #else
2785         if (i.gt. nnt+2 .and. i.lt.nct+2) then
2786           iti = itortyp(itype(i-2))
2787         else
2788           iti=ntortyp+1
2789         endif
2790 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2791         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2792           iti1 = itortyp(itype(i-1))
2793         else
2794           iti1=ntortyp+1
2795         endif
2796         b1(1,i-2)=b(3,iti)
2797         b1(2,i-2)=b(5,iti)
2798         b2(1,i-2)=b(2,iti)
2799         b2(2,i-2)=b(4,iti)
2800         b1tilde(1,i-2)= b1(1,i-2)
2801         b1tilde(2,i-2)=-b1(2,i-2)
2802         b2tilde(1,i-2)= b2(1,i-2)
2803         b2tilde(2,i-2)=-b2(2,i-2)
2804         EE(1,2,i-2)=eeold(1,2,iti)
2805         EE(2,1,i-2)=eeold(2,1,iti)
2806         EE(2,2,i-2)=eeold(2,2,iti)
2807         EE(1,1,i-2)=eeold(1,1,iti)
2808       enddo
2809 #endif
2810 #ifdef PARMAT
2811       do i=ivec_start+2,ivec_end+2
2812 #else
2813       do i=3,nres+1
2814 #endif
2815         if (i .lt. nres+1) then
2816           sin1=dsin(phi(i))
2817           cos1=dcos(phi(i))
2818           sintab(i-2)=sin1
2819           costab(i-2)=cos1
2820           obrot(1,i-2)=cos1
2821           obrot(2,i-2)=sin1
2822           sin2=dsin(2*phi(i))
2823           cos2=dcos(2*phi(i))
2824           sintab2(i-2)=sin2
2825           costab2(i-2)=cos2
2826           obrot2(1,i-2)=cos2
2827           obrot2(2,i-2)=sin2
2828           Ug(1,1,i-2)=-cos1
2829           Ug(1,2,i-2)=-sin1
2830           Ug(2,1,i-2)=-sin1
2831           Ug(2,2,i-2)= cos1
2832           Ug2(1,1,i-2)=-cos2
2833           Ug2(1,2,i-2)=-sin2
2834           Ug2(2,1,i-2)=-sin2
2835           Ug2(2,2,i-2)= cos2
2836         else
2837           costab(i-2)=1.0d0
2838           sintab(i-2)=0.0d0
2839           obrot(1,i-2)=1.0d0
2840           obrot(2,i-2)=0.0d0
2841           obrot2(1,i-2)=0.0d0
2842           obrot2(2,i-2)=0.0d0
2843           Ug(1,1,i-2)=1.0d0
2844           Ug(1,2,i-2)=0.0d0
2845           Ug(2,1,i-2)=0.0d0
2846           Ug(2,2,i-2)=1.0d0
2847           Ug2(1,1,i-2)=0.0d0
2848           Ug2(1,2,i-2)=0.0d0
2849           Ug2(2,1,i-2)=0.0d0
2850           Ug2(2,2,i-2)=0.0d0
2851         endif
2852         if (i .gt. 3 .and. i .lt. nres+1) then
2853           obrot_der(1,i-2)=-sin1
2854           obrot_der(2,i-2)= cos1
2855           Ugder(1,1,i-2)= sin1
2856           Ugder(1,2,i-2)=-cos1
2857           Ugder(2,1,i-2)=-cos1
2858           Ugder(2,2,i-2)=-sin1
2859           dwacos2=cos2+cos2
2860           dwasin2=sin2+sin2
2861           obrot2_der(1,i-2)=-dwasin2
2862           obrot2_der(2,i-2)= dwacos2
2863           Ug2der(1,1,i-2)= dwasin2
2864           Ug2der(1,2,i-2)=-dwacos2
2865           Ug2der(2,1,i-2)=-dwacos2
2866           Ug2der(2,2,i-2)=-dwasin2
2867         else
2868           obrot_der(1,i-2)=0.0d0
2869           obrot_der(2,i-2)=0.0d0
2870           Ugder(1,1,i-2)=0.0d0
2871           Ugder(1,2,i-2)=0.0d0
2872           Ugder(2,1,i-2)=0.0d0
2873           Ugder(2,2,i-2)=0.0d0
2874           obrot2_der(1,i-2)=0.0d0
2875           obrot2_der(2,i-2)=0.0d0
2876           Ug2der(1,1,i-2)=0.0d0
2877           Ug2der(1,2,i-2)=0.0d0
2878           Ug2der(2,1,i-2)=0.0d0
2879           Ug2der(2,2,i-2)=0.0d0
2880         endif
2881 c        if (i.gt. iatel_s+2 .and. i.lt.iatel_e+5) then
2882         if (i.gt. nnt+2 .and. i.lt.nct+2) then
2883           iti = itortyp(itype(i-2))
2884         else
2885           iti=ntortyp
2886         endif
2887 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2888         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2889           iti1 = itortyp(itype(i-1))
2890         else
2891           iti1=ntortyp
2892         endif
2893 cd        write (iout,*) '*******i',i,' iti1',iti
2894 cd        write (iout,*) 'b1',b1(:,iti)
2895 cd        write (iout,*) 'b2',b2(:,iti)
2896 cd         write (iout,*) "phi(",i,")=",phi(i)," sin1",sin1," cos1",cos1
2897 cd        write (iout,*) 'Ug',Ug(:,:,i-2)
2898 c        if (i .gt. iatel_s+2) then
2899         if (i .gt. nnt+2) then
2900           call matvec2(Ug(1,1,i-2),b2(1,i-2),Ub2(1,i-2))
2901 #ifdef NEWCORR
2902           call matvec2(Ug(1,1,i-2),gtb2(1,i-2),gUb2(1,i-2))
2903 c          write (iout,*) Ug(1,1,i-2),gtb2(1,i-2),gUb2(1,i-2),"chuj"
2904 #endif
2905 c          write(iout,*) "co jest kurwa", iti, EE(1,1,iti),EE(2,1,iti),
2906 c     &    EE(1,2,iti),EE(2,2,iti)
2907           call matmat2(EE(1,1,i-2),Ug(1,1,i-2),EUg(1,1,i-2))
2908           call matmat2(gtEE(1,1,i-2),Ug(1,1,i-2),gtEUg(1,1,i-2))
2909 c          write(iout,*) "Macierz EUG",
2910 c     &    eug(1,1,i-2),eug(1,2,i-2),eug(2,1,i-2),
2911 c     &    eug(2,2,i-2)
2912           if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2913      &    then
2914           call matmat2(CC(1,1,iti),Ug(1,1,i-2),CUg(1,1,i-2))
2915           call matmat2(DD(1,1,iti),Ug(1,1,i-2),DUg(1,1,i-2))
2916           call matmat2(Dtilde(1,1,iti),Ug2(1,1,i-2),DtUg2(1,1,i-2))
2917           call matvec2(Ctilde(1,1,iti1),obrot(1,i-2),Ctobr(1,i-2))
2918           call matvec2(Dtilde(1,1,iti),obrot2(1,i-2),Dtobr2(1,i-2))
2919           endif
2920         else
2921           do k=1,2
2922             Ub2(k,i-2)=0.0d0
2923             Ctobr(k,i-2)=0.0d0
2924             Dtobr2(k,i-2)=0.0d0
2925             do l=1,2
2926               EUg(l,k,i-2)=0.0d0
2927               CUg(l,k,i-2)=0.0d0
2928               DUg(l,k,i-2)=0.0d0
2929               DtUg2(l,k,i-2)=0.0d0
2930             enddo
2931           enddo
2932         endif
2933         call matvec2(Ugder(1,1,i-2),b2(1,i-2),Ub2der(1,i-2))
2934         call matmat2(EE(1,1,i-2),Ugder(1,1,i-2),EUgder(1,1,i-2))
2935         do k=1,2
2936           muder(k,i-2)=Ub2der(k,i-2)
2937         enddo
2938 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2939         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2940           if (itype(i-1).le.ntyp) then
2941             iti1 = itortyp(itype(i-1))
2942           else
2943             iti1=ntortyp
2944           endif
2945         else
2946           iti1=ntortyp
2947         endif
2948         do k=1,2
2949           mu(k,i-2)=Ub2(k,i-2)+b1(k,i-1)
2950         enddo
2951 C        write (iout,*) 'mumu',i,b1(1,i-1),Ub2(1,i-2)
2952 cd        write (iout,*) 'mu  ',mu(:,i-2),i-2
2953 cd        write (iout,*) 'b1  ',b1(:,i-1),i-2
2954 cd        write (iout,*) 'Ub2 ',Ub2(:,i-2),i-2
2955 cd        write (iout,*) 'Ug  ',Ug(:,:,i-2),i-2
2956 cd        write (iout,*) 'b2  ',b2(:,i-2),i-2
2957 cd        write (iout,*) 'mu1',mu1(:,i-2)
2958 cd        write (iout,*) 'mu2',mu2(:,i-2)
2959         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
2960      &  then
2961         call matmat2(CC(1,1,iti1),Ugder(1,1,i-2),CUgder(1,1,i-2))
2962         call matmat2(DD(1,1,iti),Ugder(1,1,i-2),DUgder(1,1,i-2))
2963         call matmat2(Dtilde(1,1,iti),Ug2der(1,1,i-2),DtUg2der(1,1,i-2))
2964         call matvec2(Ctilde(1,1,iti1),obrot_der(1,i-2),Ctobrder(1,i-2))
2965         call matvec2(Dtilde(1,1,iti),obrot2_der(1,i-2),Dtobr2der(1,i-2))
2966 C Vectors and matrices dependent on a single virtual-bond dihedral.
2967         call matvec2(DD(1,1,iti),b1tilde(1,i-1),auxvec(1))
2968         call matvec2(Ug2(1,1,i-2),auxvec(1),Ug2Db1t(1,i-2))
2969         call matvec2(Ug2der(1,1,i-2),auxvec(1),Ug2Db1tder(1,i-2))
2970         call matvec2(CC(1,1,iti1),Ub2(1,i-2),CUgb2(1,i-2))
2971         call matvec2(CC(1,1,iti1),Ub2der(1,i-2),CUgb2der(1,i-2))
2972         call matmat2(EUg(1,1,i-2),CC(1,1,iti1),EUgC(1,1,i-2))
2973         call matmat2(EUgder(1,1,i-2),CC(1,1,iti1),EUgCder(1,1,i-2))
2974         call matmat2(EUg(1,1,i-2),DD(1,1,iti1),EUgD(1,1,i-2))
2975         call matmat2(EUgder(1,1,i-2),DD(1,1,iti1),EUgDder(1,1,i-2))
2976         endif
2977       enddo
2978 C Matrices dependent on two consecutive virtual-bond dihedrals.
2979 C The order of matrices is from left to right.
2980       if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
2981      &then
2982 c      do i=max0(ivec_start,2),ivec_end
2983       do i=2,nres-1
2984         call matmat2(DtUg2(1,1,i-1),EUg(1,1,i),DtUg2EUg(1,1,i))
2985         call matmat2(DtUg2der(1,1,i-1),EUg(1,1,i),DtUg2EUgder(1,1,1,i))
2986         call matmat2(DtUg2(1,1,i-1),EUgder(1,1,i),DtUg2EUgder(1,1,2,i))
2987         call transpose2(DtUg2(1,1,i-1),auxmat(1,1))
2988         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUg(1,1,i))
2989         call matmat2(auxmat(1,1),EUgder(1,1,i),Ug2DtEUgder(1,1,2,i))
2990         call transpose2(DtUg2der(1,1,i-1),auxmat(1,1))
2991         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUgder(1,1,1,i))
2992       enddo
2993       endif
2994 #if defined(MPI) && defined(PARMAT)
2995 #ifdef DEBUG
2996 c      if (fg_rank.eq.0) then
2997         write (iout,*) "Arrays UG and UGDER before GATHER"
2998         do i=1,nres-1
2999           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3000      &     ((ug(l,k,i),l=1,2),k=1,2),
3001      &     ((ugder(l,k,i),l=1,2),k=1,2)
3002         enddo
3003         write (iout,*) "Arrays UG2 and UG2DER"
3004         do i=1,nres-1
3005           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3006      &     ((ug2(l,k,i),l=1,2),k=1,2),
3007      &     ((ug2der(l,k,i),l=1,2),k=1,2)
3008         enddo
3009         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
3010         do i=1,nres-1
3011           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3012      &     (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
3013      &     (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
3014         enddo
3015         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
3016         do i=1,nres-1
3017           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3018      &     costab(i),sintab(i),costab2(i),sintab2(i)
3019         enddo
3020         write (iout,*) "Array MUDER"
3021         do i=1,nres-1
3022           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
3023         enddo
3024 c      endif
3025 #endif
3026       if (nfgtasks.gt.1) then
3027         time00=MPI_Wtime()
3028 c        write(iout,*)"Processor",fg_rank,kolor," ivec_start",ivec_start,
3029 c     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks-1),
3030 c     &   " ivec_count",(ivec_count(i),i=0,nfgtasks-1)
3031 #ifdef MATGATHER
3032         call MPI_Allgatherv(Ub2(1,ivec_start),ivec_count(fg_rank1),
3033      &   MPI_MU,Ub2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3034      &   FG_COMM1,IERR)
3035         call MPI_Allgatherv(Ub2der(1,ivec_start),ivec_count(fg_rank1),
3036      &   MPI_MU,Ub2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3037      &   FG_COMM1,IERR)
3038         call MPI_Allgatherv(mu(1,ivec_start),ivec_count(fg_rank1),
3039      &   MPI_MU,mu(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3040      &   FG_COMM1,IERR)
3041         call MPI_Allgatherv(muder(1,ivec_start),ivec_count(fg_rank1),
3042      &   MPI_MU,muder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3043      &   FG_COMM1,IERR)
3044         call MPI_Allgatherv(Eug(1,1,ivec_start),ivec_count(fg_rank1),
3045      &   MPI_MAT1,Eug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3046      &   FG_COMM1,IERR)
3047         call MPI_Allgatherv(Eugder(1,1,ivec_start),ivec_count(fg_rank1),
3048      &   MPI_MAT1,Eugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3049      &   FG_COMM1,IERR)
3050         call MPI_Allgatherv(costab(ivec_start),ivec_count(fg_rank1),
3051      &   MPI_DOUBLE_PRECISION,costab(1),ivec_count(0),ivec_displ(0),
3052      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3053         call MPI_Allgatherv(sintab(ivec_start),ivec_count(fg_rank1),
3054      &   MPI_DOUBLE_PRECISION,sintab(1),ivec_count(0),ivec_displ(0),
3055      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3056         call MPI_Allgatherv(costab2(ivec_start),ivec_count(fg_rank1),
3057      &   MPI_DOUBLE_PRECISION,costab2(1),ivec_count(0),ivec_displ(0),
3058      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3059         call MPI_Allgatherv(sintab2(ivec_start),ivec_count(fg_rank1),
3060      &   MPI_DOUBLE_PRECISION,sintab2(1),ivec_count(0),ivec_displ(0),
3061      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3062         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
3063      &  then
3064         call MPI_Allgatherv(Ctobr(1,ivec_start),ivec_count(fg_rank1),
3065      &   MPI_MU,Ctobr(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3066      &   FG_COMM1,IERR)
3067         call MPI_Allgatherv(Ctobrder(1,ivec_start),ivec_count(fg_rank1),
3068      &   MPI_MU,Ctobrder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3069      &   FG_COMM1,IERR)
3070         call MPI_Allgatherv(Dtobr2(1,ivec_start),ivec_count(fg_rank1),
3071      &   MPI_MU,Dtobr2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3072      &   FG_COMM1,IERR)
3073        call MPI_Allgatherv(Dtobr2der(1,ivec_start),ivec_count(fg_rank1),
3074      &   MPI_MU,Dtobr2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3075      &   FG_COMM1,IERR)
3076         call MPI_Allgatherv(Ug2Db1t(1,ivec_start),ivec_count(fg_rank1),
3077      &   MPI_MU,Ug2Db1t(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3078      &   FG_COMM1,IERR)
3079         call MPI_Allgatherv(Ug2Db1tder(1,ivec_start),
3080      &   ivec_count(fg_rank1),
3081      &   MPI_MU,Ug2Db1tder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3082      &   FG_COMM1,IERR)
3083         call MPI_Allgatherv(CUgb2(1,ivec_start),ivec_count(fg_rank1),
3084      &   MPI_MU,CUgb2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3085      &   FG_COMM1,IERR)
3086         call MPI_Allgatherv(CUgb2der(1,ivec_start),ivec_count(fg_rank1),
3087      &   MPI_MU,CUgb2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3088      &   FG_COMM1,IERR)
3089         call MPI_Allgatherv(Cug(1,1,ivec_start),ivec_count(fg_rank1),
3090      &   MPI_MAT1,Cug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3091      &   FG_COMM1,IERR)
3092         call MPI_Allgatherv(Cugder(1,1,ivec_start),ivec_count(fg_rank1),
3093      &   MPI_MAT1,Cugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3094      &   FG_COMM1,IERR)
3095         call MPI_Allgatherv(Dug(1,1,ivec_start),ivec_count(fg_rank1),
3096      &   MPI_MAT1,Dug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3097      &   FG_COMM1,IERR)
3098         call MPI_Allgatherv(Dugder(1,1,ivec_start),ivec_count(fg_rank1),
3099      &   MPI_MAT1,Dugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3100      &   FG_COMM1,IERR)
3101         call MPI_Allgatherv(Dtug2(1,1,ivec_start),ivec_count(fg_rank1),
3102      &   MPI_MAT1,Dtug2(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3103      &   FG_COMM1,IERR)
3104         call MPI_Allgatherv(Dtug2der(1,1,ivec_start),
3105      &   ivec_count(fg_rank1),
3106      &   MPI_MAT1,Dtug2der(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3107      &   FG_COMM1,IERR)
3108         call MPI_Allgatherv(EugC(1,1,ivec_start),ivec_count(fg_rank1),
3109      &   MPI_MAT1,EugC(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3110      &   FG_COMM1,IERR)
3111        call MPI_Allgatherv(EugCder(1,1,ivec_start),ivec_count(fg_rank1),
3112      &   MPI_MAT1,EugCder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3113      &   FG_COMM1,IERR)
3114         call MPI_Allgatherv(EugD(1,1,ivec_start),ivec_count(fg_rank1),
3115      &   MPI_MAT1,EugD(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3116      &   FG_COMM1,IERR)
3117        call MPI_Allgatherv(EugDder(1,1,ivec_start),ivec_count(fg_rank1),
3118      &   MPI_MAT1,EugDder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3119      &   FG_COMM1,IERR)
3120         call MPI_Allgatherv(DtUg2EUg(1,1,ivec_start),
3121      &   ivec_count(fg_rank1),
3122      &   MPI_MAT1,DtUg2EUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3123      &   FG_COMM1,IERR)
3124         call MPI_Allgatherv(Ug2DtEUg(1,1,ivec_start),
3125      &   ivec_count(fg_rank1),
3126      &   MPI_MAT1,Ug2DtEUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3127      &   FG_COMM1,IERR)
3128         call MPI_Allgatherv(DtUg2EUgder(1,1,1,ivec_start),
3129      &   ivec_count(fg_rank1),
3130      &   MPI_MAT2,DtUg2EUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
3131      &   MPI_MAT2,FG_COMM1,IERR)
3132         call MPI_Allgatherv(Ug2DtEUgder(1,1,1,ivec_start),
3133      &   ivec_count(fg_rank1),
3134      &   MPI_MAT2,Ug2DtEUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
3135      &   MPI_MAT2,FG_COMM1,IERR)
3136         endif
3137 #else
3138 c Passes matrix info through the ring
3139       isend=fg_rank1
3140       irecv=fg_rank1-1
3141       if (irecv.lt.0) irecv=nfgtasks1-1
3142       iprev=irecv
3143       inext=fg_rank1+1
3144       if (inext.ge.nfgtasks1) inext=0
3145       do i=1,nfgtasks1-1
3146 c        write (iout,*) "isend",isend," irecv",irecv
3147 c        call flush(iout)
3148         lensend=lentyp(isend)
3149         lenrecv=lentyp(irecv)
3150 c        write (iout,*) "lensend",lensend," lenrecv",lenrecv
3151 c        call MPI_SENDRECV(ug(1,1,ivec_displ(isend)+1),1,
3152 c     &   MPI_ROTAT1(lensend),inext,2200+isend,
3153 c     &   ug(1,1,ivec_displ(irecv)+1),1,MPI_ROTAT1(lenrecv),
3154 c     &   iprev,2200+irecv,FG_COMM,status,IERR)
3155 c        write (iout,*) "Gather ROTAT1"
3156 c        call flush(iout)
3157 c        call MPI_SENDRECV(obrot(1,ivec_displ(isend)+1),1,
3158 c     &   MPI_ROTAT2(lensend),inext,3300+isend,
3159 c     &   obrot(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
3160 c     &   iprev,3300+irecv,FG_COMM,status,IERR)
3161 c        write (iout,*) "Gather ROTAT2"
3162 c        call flush(iout)
3163         call MPI_SENDRECV(costab(ivec_displ(isend)+1),1,
3164      &   MPI_ROTAT_OLD(lensend),inext,4400+isend,
3165      &   costab(ivec_displ(irecv)+1),1,MPI_ROTAT_OLD(lenrecv),
3166      &   iprev,4400+irecv,FG_COMM,status,IERR)
3167 c        write (iout,*) "Gather ROTAT_OLD"
3168 c        call flush(iout)
3169         call MPI_SENDRECV(mu(1,ivec_displ(isend)+1),1,
3170      &   MPI_PRECOMP11(lensend),inext,5500+isend,
3171      &   mu(1,ivec_displ(irecv)+1),1,MPI_PRECOMP11(lenrecv),
3172      &   iprev,5500+irecv,FG_COMM,status,IERR)
3173 c        write (iout,*) "Gather PRECOMP11"
3174 c        call flush(iout)
3175         call MPI_SENDRECV(Eug(1,1,ivec_displ(isend)+1),1,
3176      &   MPI_PRECOMP12(lensend),inext,6600+isend,
3177      &   Eug(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP12(lenrecv),
3178      &   iprev,6600+irecv,FG_COMM,status,IERR)
3179 c        write (iout,*) "Gather PRECOMP12"
3180 c        call flush(iout)
3181         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
3182      &  then
3183         call MPI_SENDRECV(ug2db1t(1,ivec_displ(isend)+1),1,
3184      &   MPI_ROTAT2(lensend),inext,7700+isend,
3185      &   ug2db1t(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
3186      &   iprev,7700+irecv,FG_COMM,status,IERR)
3187 c        write (iout,*) "Gather PRECOMP21"
3188 c        call flush(iout)
3189         call MPI_SENDRECV(EUgC(1,1,ivec_displ(isend)+1),1,
3190      &   MPI_PRECOMP22(lensend),inext,8800+isend,
3191      &   EUgC(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP22(lenrecv),
3192      &   iprev,8800+irecv,FG_COMM,status,IERR)
3193 c        write (iout,*) "Gather PRECOMP22"
3194 c        call flush(iout)
3195         call MPI_SENDRECV(Ug2DtEUgder(1,1,1,ivec_displ(isend)+1),1,
3196      &   MPI_PRECOMP23(lensend),inext,9900+isend,
3197      &   Ug2DtEUgder(1,1,1,ivec_displ(irecv)+1),1,
3198      &   MPI_PRECOMP23(lenrecv),
3199      &   iprev,9900+irecv,FG_COMM,status,IERR)
3200 c        write (iout,*) "Gather PRECOMP23"
3201 c        call flush(iout)
3202         endif
3203         isend=irecv
3204         irecv=irecv-1
3205         if (irecv.lt.0) irecv=nfgtasks1-1
3206       enddo
3207 #endif
3208         time_gather=time_gather+MPI_Wtime()-time00
3209       endif
3210 #ifdef DEBUG
3211 c      if (fg_rank.eq.0) then
3212         write (iout,*) "Arrays UG and UGDER"
3213         do i=1,nres-1
3214           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3215      &     ((ug(l,k,i),l=1,2),k=1,2),
3216      &     ((ugder(l,k,i),l=1,2),k=1,2)
3217         enddo
3218         write (iout,*) "Arrays UG2 and UG2DER"
3219         do i=1,nres-1
3220           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3221      &     ((ug2(l,k,i),l=1,2),k=1,2),
3222      &     ((ug2der(l,k,i),l=1,2),k=1,2)
3223         enddo
3224         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
3225         do i=1,nres-1
3226           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3227      &     (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
3228      &     (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
3229         enddo
3230         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
3231         do i=1,nres-1
3232           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3233      &     costab(i),sintab(i),costab2(i),sintab2(i)
3234         enddo
3235         write (iout,*) "Array MUDER"
3236         do i=1,nres-1
3237           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
3238         enddo
3239 c      endif
3240 #endif
3241 #endif
3242 cd      do i=1,nres
3243 cd        iti = itortyp(itype(i))
3244 cd        write (iout,*) i
3245 cd        do j=1,2
3246 cd        write (iout,'(2f10.5,5x,2f10.5,5x,2f10.5)')
3247 cd     &  (EE(j,k,iti),k=1,2),(Ug(j,k,i),k=1,2),(EUg(j,k,i),k=1,2)
3248 cd        enddo
3249 cd      enddo
3250       return
3251       end
3252 C--------------------------------------------------------------------------
3253       subroutine eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
3254 C
3255 C This subroutine calculates the average interaction energy and its gradient
3256 C in the virtual-bond vectors between non-adjacent peptide groups, based on
3257 C the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
3258 C The potential depends both on the distance of peptide-group centers and on
3259 C the orientation of the CA-CA virtual bonds.
3260 C
3261       implicit real*8 (a-h,o-z)
3262 #ifdef MPI
3263       include 'mpif.h'
3264 #endif
3265       include 'DIMENSIONS'
3266       include 'COMMON.CONTROL'
3267       include 'COMMON.SETUP'
3268       include 'COMMON.IOUNITS'
3269       include 'COMMON.GEO'
3270       include 'COMMON.VAR'
3271       include 'COMMON.LOCAL'
3272       include 'COMMON.CHAIN'
3273       include 'COMMON.DERIV'
3274       include 'COMMON.INTERACT'
3275       include 'COMMON.CONTACTS'
3276       include 'COMMON.TORSION'
3277       include 'COMMON.VECTORS'
3278       include 'COMMON.FFIELD'
3279       include 'COMMON.TIME1'
3280       include 'COMMON.SPLITELE'
3281       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
3282      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
3283       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
3284      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4),gmuij(4)
3285       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3286      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3287      &    num_conti,j1,j2
3288 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
3289 #ifdef MOMENT
3290       double precision scal_el /1.0d0/
3291 #else
3292       double precision scal_el /0.5d0/
3293 #endif
3294 C 12/13/98
3295 C 13-go grudnia roku pamietnego...
3296       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
3297      &                   0.0d0,1.0d0,0.0d0,
3298      &                   0.0d0,0.0d0,1.0d0/
3299 cd      write(iout,*) 'In EELEC'
3300 cd      do i=1,nloctyp
3301 cd        write(iout,*) 'Type',i
3302 cd        write(iout,*) 'B1',B1(:,i)
3303 cd        write(iout,*) 'B2',B2(:,i)
3304 cd        write(iout,*) 'CC',CC(:,:,i)
3305 cd        write(iout,*) 'DD',DD(:,:,i)
3306 cd        write(iout,*) 'EE',EE(:,:,i)
3307 cd      enddo
3308 cd      call check_vecgrad
3309 cd      stop
3310       if (icheckgrad.eq.1) then
3311         do i=1,nres-1
3312           fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
3313           do k=1,3
3314             dc_norm(k,i)=dc(k,i)*fac
3315           enddo
3316 c          write (iout,*) 'i',i,' fac',fac
3317         enddo
3318       endif
3319       if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
3320      &    .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or.
3321      &    wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
3322 c        call vec_and_deriv
3323 #ifdef TIMING
3324         time01=MPI_Wtime()
3325 #endif
3326         call set_matrices
3327 #ifdef TIMING
3328         time_mat=time_mat+MPI_Wtime()-time01
3329 #endif
3330       endif
3331 cd      do i=1,nres-1
3332 cd        write (iout,*) 'i=',i
3333 cd        do k=1,3
3334 cd        write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
3335 cd        enddo
3336 cd        do k=1,3
3337 cd          write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
3338 cd     &     uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
3339 cd        enddo
3340 cd      enddo
3341       t_eelecij=0.0d0
3342       ees=0.0D0
3343       evdw1=0.0D0
3344       eel_loc=0.0d0
3345       eello_turn3=0.0d0
3346       eello_turn4=0.0d0
3347       ind=0
3348       do i=1,nres
3349         num_cont_hb(i)=0
3350       enddo
3351 cd      print '(a)','Enter EELEC'
3352 cd      write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
3353       do i=1,nres
3354         gel_loc_loc(i)=0.0d0
3355         gcorr_loc(i)=0.0d0
3356       enddo
3357 c
3358 c
3359 c 9/27/08 AL Split the interaction loop to ensure load balancing of turn terms
3360 C
3361 C Loop over i,i+2 and i,i+3 pairs of the peptide groups
3362 C
3363 C 14/01/2014 TURN3,TUNR4 does no go under periodic boundry condition
3364       do i=iturn3_start,iturn3_end
3365 CAna        if (i.le.1) cycle
3366 C        write(iout,*) "tu jest i",i
3367         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
3368 C changes suggested by Ana to avoid out of bounds
3369 CAna     & .or.((i+4).gt.nres)
3370 CAna     & .or.((i-1).le.0)
3371 C end of changes by Ana
3372      &  .or. itype(i+2).eq.ntyp1
3373      &  .or. itype(i+3).eq.ntyp1) cycle
3374 CAna        if(i.gt.1)then
3375 CAna          if(itype(i-1).eq.ntyp1)cycle
3376 CAna        end if
3377 CAna        if(i.LT.nres-3)then
3378 CAna          if (itype(i+4).eq.ntyp1) cycle
3379 CAna        end if
3380         dxi=dc(1,i)
3381         dyi=dc(2,i)
3382         dzi=dc(3,i)
3383         dx_normi=dc_norm(1,i)
3384         dy_normi=dc_norm(2,i)
3385         dz_normi=dc_norm(3,i)
3386         xmedi=c(1,i)+0.5d0*dxi
3387         ymedi=c(2,i)+0.5d0*dyi
3388         zmedi=c(3,i)+0.5d0*dzi
3389           xmedi=mod(xmedi,boxxsize)
3390           if (xmedi.lt.0) xmedi=xmedi+boxxsize
3391           ymedi=mod(ymedi,boxysize)
3392           if (ymedi.lt.0) ymedi=ymedi+boxysize
3393           zmedi=mod(zmedi,boxzsize)
3394           if (zmedi.lt.0) zmedi=zmedi+boxzsize
3395         num_conti=0
3396         call eelecij(i,i+2,ees,evdw1,eel_loc)
3397         if (wturn3.gt.0.0d0) call eturn3(i,eello_turn3)
3398         num_cont_hb(i)=num_conti
3399       enddo
3400       do i=iturn4_start,iturn4_end
3401 cAna        if (i.le.1) cycle
3402         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
3403 C changes suggested by Ana to avoid out of bounds
3404 cAna     & .or.((i+5).gt.nres)
3405 cAna     & .or.((i-1).le.0)
3406 C end of changes suggested by Ana
3407      &    .or. itype(i+3).eq.ntyp1
3408      &    .or. itype(i+4).eq.ntyp1
3409 cAna     &    .or. itype(i+5).eq.ntyp1
3410 cAna     &    .or. itype(i).eq.ntyp1
3411 cAna     &    .or. itype(i-1).eq.ntyp1
3412      &                             ) cycle
3413         dxi=dc(1,i)
3414         dyi=dc(2,i)
3415         dzi=dc(3,i)
3416         dx_normi=dc_norm(1,i)
3417         dy_normi=dc_norm(2,i)
3418         dz_normi=dc_norm(3,i)
3419         xmedi=c(1,i)+0.5d0*dxi
3420         ymedi=c(2,i)+0.5d0*dyi
3421         zmedi=c(3,i)+0.5d0*dzi
3422 C Return atom into box, boxxsize is size of box in x dimension
3423 c  194   continue
3424 c        if (xmedi.gt.((0.5d0)*boxxsize)) xmedi=xmedi-boxxsize
3425 c        if (xmedi.lt.((-0.5d0)*boxxsize)) xmedi=xmedi+boxxsize
3426 C Condition for being inside the proper box
3427 c        if ((xmedi.gt.((0.5d0)*boxxsize)).or.
3428 c     &       (xmedi.lt.((-0.5d0)*boxxsize))) then
3429 c        go to 194
3430 c        endif
3431 c  195   continue
3432 c        if (ymedi.gt.((0.5d0)*boxysize)) ymedi=ymedi-boxysize
3433 c        if (ymedi.lt.((-0.5d0)*boxysize)) ymedi=ymedi+boxysize
3434 C Condition for being inside the proper box
3435 c        if ((ymedi.gt.((0.5d0)*boxysize)).or.
3436 c     &       (ymedi.lt.((-0.5d0)*boxysize))) then
3437 c        go to 195
3438 c        endif
3439 c  196   continue
3440 c        if (zmedi.gt.((0.5d0)*boxzsize)) zmedi=zmedi-boxzsize
3441 c        if (zmedi.lt.((-0.5d0)*boxzsize)) zmedi=zmedi+boxzsize
3442 C Condition for being inside the proper box
3443 c        if ((zmedi.gt.((0.5d0)*boxzsize)).or.
3444 c     &       (zmedi.lt.((-0.5d0)*boxzsize))) then
3445 c        go to 196
3446 c        endif
3447           xmedi=mod(xmedi,boxxsize)
3448           if (xmedi.lt.0) xmedi=xmedi+boxxsize
3449           ymedi=mod(ymedi,boxysize)
3450           if (ymedi.lt.0) ymedi=ymedi+boxysize
3451           zmedi=mod(zmedi,boxzsize)
3452           if (zmedi.lt.0) zmedi=zmedi+boxzsize
3453
3454         num_conti=num_cont_hb(i)
3455 c        write(iout,*) "JESTEM W PETLI"
3456         call eelecij(i,i+3,ees,evdw1,eel_loc)
3457         if (wturn4.gt.0.0d0 .and. itype(i+2).ne.ntyp1)
3458      &   call eturn4(i,eello_turn4)
3459         num_cont_hb(i)=num_conti
3460       enddo   ! i
3461 C Loop over all neighbouring boxes
3462 C      do xshift=-1,1
3463 C      do yshift=-1,1
3464 C      do zshift=-1,1
3465 c
3466 c Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
3467 c
3468       do i=iatel_s,iatel_e
3469 cAna        if (i.le.1) cycle
3470         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
3471 C changes suggested by Ana to avoid out of bounds
3472 cAna     & .or.((i+2).gt.nres)
3473 cAna     & .or.((i-1).le.0)
3474 C end of changes by Ana
3475 cAna     &  .or. itype(i+2).eq.ntyp1
3476 cAna     &  .or. itype(i-1).eq.ntyp1
3477      &                ) cycle
3478         dxi=dc(1,i)
3479         dyi=dc(2,i)
3480         dzi=dc(3,i)
3481         dx_normi=dc_norm(1,i)
3482         dy_normi=dc_norm(2,i)
3483         dz_normi=dc_norm(3,i)
3484         xmedi=c(1,i)+0.5d0*dxi
3485         ymedi=c(2,i)+0.5d0*dyi
3486         zmedi=c(3,i)+0.5d0*dzi
3487           xmedi=mod(xmedi,boxxsize)
3488           if (xmedi.lt.0) xmedi=xmedi+boxxsize
3489           ymedi=mod(ymedi,boxysize)
3490           if (ymedi.lt.0) ymedi=ymedi+boxysize
3491           zmedi=mod(zmedi,boxzsize)
3492           if (zmedi.lt.0) zmedi=zmedi+boxzsize
3493 C          xmedi=xmedi+xshift*boxxsize
3494 C          ymedi=ymedi+yshift*boxysize
3495 C          zmedi=zmedi+zshift*boxzsize
3496
3497 C Return tom into box, boxxsize is size of box in x dimension
3498 c  164   continue
3499 c        if (xmedi.gt.((xshift+0.5d0)*boxxsize)) xmedi=xmedi-boxxsize
3500 c        if (xmedi.lt.((xshift-0.5d0)*boxxsize)) xmedi=xmedi+boxxsize
3501 C Condition for being inside the proper box
3502 c        if ((xmedi.gt.((xshift+0.5d0)*boxxsize)).or.
3503 c     &       (xmedi.lt.((xshift-0.5d0)*boxxsize))) then
3504 c        go to 164
3505 c        endif
3506 c  165   continue
3507 c        if (ymedi.gt.((yshift+0.5d0)*boxysize)) ymedi=ymedi-boxysize
3508 c        if (ymedi.lt.((yshift-0.5d0)*boxysize)) ymedi=ymedi+boxysize
3509 C Condition for being inside the proper box
3510 c        if ((ymedi.gt.((yshift+0.5d0)*boxysize)).or.
3511 c     &       (ymedi.lt.((yshift-0.5d0)*boxysize))) then
3512 c        go to 165
3513 c        endif
3514 c  166   continue
3515 c        if (zmedi.gt.((zshift+0.5d0)*boxzsize)) zmedi=zmedi-boxzsize
3516 c        if (zmedi.lt.((zshift-0.5d0)*boxzsize)) zmedi=zmedi+boxzsize
3517 cC Condition for being inside the proper box
3518 c        if ((zmedi.gt.((zshift+0.5d0)*boxzsize)).or.
3519 c     &       (zmedi.lt.((zshift-0.5d0)*boxzsize))) then
3520 c        go to 166
3521 c        endif
3522
3523 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
3524         num_conti=num_cont_hb(i)
3525         do j=ielstart(i),ielend(i)
3526 C          write (iout,*) i,j
3527 cAna         if (j.le.1) cycle
3528           if (itype(j).eq.ntyp1.or. itype(j+1).eq.ntyp1
3529 C changes suggested by Ana to avoid out of bounds
3530 cAna     & .or.((j+2).gt.nres)
3531 cAna     & .or.((j-1).le.0)
3532 C end of changes by Ana
3533 cAna     & .or.itype(j+2).eq.ntyp1
3534 cAna     & .or.itype(j-1).eq.ntyp1
3535      &) cycle
3536           call eelecij(i,j,ees,evdw1,eel_loc)
3537         enddo ! j
3538         num_cont_hb(i)=num_conti
3539       enddo   ! i
3540 C     enddo   ! zshift
3541 C      enddo   ! yshift
3542 C      enddo   ! xshift
3543
3544 c      write (iout,*) "Number of loop steps in EELEC:",ind
3545 cd      do i=1,nres
3546 cd        write (iout,'(i3,3f10.5,5x,3f10.5)')
3547 cd     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
3548 cd      enddo
3549 c 12/7/99 Adam eello_turn3 will be considered as a separate energy term
3550 ccc      eel_loc=eel_loc+eello_turn3
3551 cd      print *,"Processor",fg_rank," t_eelecij",t_eelecij
3552       return
3553       end
3554 C-------------------------------------------------------------------------------
3555       subroutine eelecij(i,j,ees,evdw1,eel_loc)
3556       implicit real*8 (a-h,o-z)
3557       include 'DIMENSIONS'
3558 #ifdef MPI
3559       include "mpif.h"
3560 #endif
3561       include 'COMMON.CONTROL'
3562       include 'COMMON.IOUNITS'
3563       include 'COMMON.GEO'
3564       include 'COMMON.VAR'
3565       include 'COMMON.LOCAL'
3566       include 'COMMON.CHAIN'
3567       include 'COMMON.DERIV'
3568       include 'COMMON.INTERACT'
3569       include 'COMMON.CONTACTS'
3570       include 'COMMON.TORSION'
3571       include 'COMMON.VECTORS'
3572       include 'COMMON.FFIELD'
3573       include 'COMMON.TIME1'
3574       include 'COMMON.SPLITELE'
3575       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
3576      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
3577       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
3578      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4),gmuij1(4),gmuji1(4),
3579      &    gmuij2(4),gmuji2(4)
3580       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3581      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3582      &    num_conti,j1,j2
3583 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
3584 #ifdef MOMENT
3585       double precision scal_el /1.0d0/
3586 #else
3587       double precision scal_el /0.5d0/
3588 #endif
3589 C 12/13/98
3590 C 13-go grudnia roku pamietnego...
3591       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
3592      &                   0.0d0,1.0d0,0.0d0,
3593      &                   0.0d0,0.0d0,1.0d0/
3594 c          time00=MPI_Wtime()
3595 cd      write (iout,*) "eelecij",i,j
3596 c          ind=ind+1
3597           iteli=itel(i)
3598           itelj=itel(j)
3599           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
3600           aaa=app(iteli,itelj)
3601           bbb=bpp(iteli,itelj)
3602           ael6i=ael6(iteli,itelj)
3603           ael3i=ael3(iteli,itelj)
3604           dxj=dc(1,j)
3605           dyj=dc(2,j)
3606           dzj=dc(3,j)
3607           dx_normj=dc_norm(1,j)
3608           dy_normj=dc_norm(2,j)
3609           dz_normj=dc_norm(3,j)
3610 C          xj=c(1,j)+0.5D0*dxj-xmedi
3611 C          yj=c(2,j)+0.5D0*dyj-ymedi
3612 C          zj=c(3,j)+0.5D0*dzj-zmedi
3613           xj=c(1,j)+0.5D0*dxj
3614           yj=c(2,j)+0.5D0*dyj
3615           zj=c(3,j)+0.5D0*dzj
3616           xj=mod(xj,boxxsize)
3617           if (xj.lt.0) xj=xj+boxxsize
3618           yj=mod(yj,boxysize)
3619           if (yj.lt.0) yj=yj+boxysize
3620           zj=mod(zj,boxzsize)
3621           if (zj.lt.0) zj=zj+boxzsize
3622           if ((zj.lt.0).or.(xj.lt.0).or.(yj.lt.0)) write (*,*) "CHUJ"
3623       dist_init=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
3624       xj_safe=xj
3625       yj_safe=yj
3626       zj_safe=zj
3627       isubchap=0
3628       do xshift=-1,1
3629       do yshift=-1,1
3630       do zshift=-1,1
3631           xj=xj_safe+xshift*boxxsize
3632           yj=yj_safe+yshift*boxysize
3633           zj=zj_safe+zshift*boxzsize
3634           dist_temp=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
3635           if(dist_temp.lt.dist_init) then
3636             dist_init=dist_temp
3637             xj_temp=xj
3638             yj_temp=yj
3639             zj_temp=zj
3640             isubchap=1
3641           endif
3642        enddo
3643        enddo
3644        enddo
3645        if (isubchap.eq.1) then
3646           xj=xj_temp-xmedi
3647           yj=yj_temp-ymedi
3648           zj=zj_temp-zmedi
3649        else
3650           xj=xj_safe-xmedi
3651           yj=yj_safe-ymedi
3652           zj=zj_safe-zmedi
3653        endif
3654 C        if ((i+3).lt.j) then !this condition keeps for turn3 and turn4 not subject to PBC
3655 c  174   continue
3656 c        if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
3657 c        if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
3658 C Condition for being inside the proper box
3659 c        if ((xj.gt.((0.5d0)*boxxsize)).or.
3660 c     &       (xj.lt.((-0.5d0)*boxxsize))) then
3661 c        go to 174
3662 c        endif
3663 c  175   continue
3664 c        if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
3665 c        if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
3666 C Condition for being inside the proper box
3667 c        if ((yj.gt.((0.5d0)*boxysize)).or.
3668 c     &       (yj.lt.((-0.5d0)*boxysize))) then
3669 c        go to 175
3670 c        endif
3671 c  176   continue
3672 c        if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
3673 c        if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
3674 C Condition for being inside the proper box
3675 c        if ((zj.gt.((0.5d0)*boxzsize)).or.
3676 c     &       (zj.lt.((-0.5d0)*boxzsize))) then
3677 c        go to 176
3678 c        endif
3679 C        endif !endPBC condintion
3680 C        xj=xj-xmedi
3681 C        yj=yj-ymedi
3682 C        zj=zj-zmedi
3683           rij=xj*xj+yj*yj+zj*zj
3684
3685             sss=sscale(sqrt(rij))
3686             sssgrad=sscagrad(sqrt(rij))
3687 c            if (sss.gt.0.0d0) then
3688           rrmij=1.0D0/rij
3689           rij=dsqrt(rij)
3690           rmij=1.0D0/rij
3691           r3ij=rrmij*rmij
3692           r6ij=r3ij*r3ij
3693           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
3694           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
3695           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
3696           fac=cosa-3.0D0*cosb*cosg
3697           ev1=aaa*r6ij*r6ij
3698 c 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
3699           if (j.eq.i+2) ev1=scal_el*ev1
3700           ev2=bbb*r6ij
3701           fac3=ael6i*r6ij
3702           fac4=ael3i*r3ij
3703           evdwij=(ev1+ev2)
3704           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
3705           el2=fac4*fac
3706 C MARYSIA
3707           eesij=(el1+el2)
3708 C 12/26/95 - for the evaluation of multi-body H-bonding interactions
3709           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
3710           ees=ees+eesij
3711           evdw1=evdw1+evdwij*sss
3712 cd          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
3713 cd     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
3714 cd     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
3715 cd     &      xmedi,ymedi,zmedi,xj,yj,zj
3716
3717           if (energy_dec) then
3718               write (iout,'(a6,2i5,0pf7.3,2i5,2e11.3)')
3719      &'evdw1',i,j,evdwij
3720 c     &,iteli,itelj,aaa,evdw1
3721               write (iout,'(a6,2i5,0pf7.3)') 'ees',i,j,eesij
3722           endif
3723
3724 C
3725 C Calculate contributions to the Cartesian gradient.
3726 C
3727 #ifdef SPLITELE
3728           facvdw=-6*rrmij*(ev1+evdwij)*sss
3729           facel=-3*rrmij*(el1+eesij)
3730           fac1=fac
3731           erij(1)=xj*rmij
3732           erij(2)=yj*rmij
3733           erij(3)=zj*rmij
3734
3735 *
3736 * Radial derivatives. First process both termini of the fragment (i,j)
3737 *
3738           ggg(1)=facel*xj
3739           ggg(2)=facel*yj
3740           ggg(3)=facel*zj
3741 c          do k=1,3
3742 c            ghalf=0.5D0*ggg(k)
3743 c            gelc(k,i)=gelc(k,i)+ghalf
3744 c            gelc(k,j)=gelc(k,j)+ghalf
3745 c          enddo
3746 c 9/28/08 AL Gradient compotents will be summed only at the end
3747           do k=1,3
3748             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
3749             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
3750           enddo
3751 *
3752 * Loop over residues i+1 thru j-1.
3753 *
3754 cgrad          do k=i+1,j-1
3755 cgrad            do l=1,3
3756 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3757 cgrad            enddo
3758 cgrad          enddo
3759           if (sss.gt.0.0) then
3760           ggg(1)=facvdw*xj+sssgrad*rmij*evdwij*xj
3761           ggg(2)=facvdw*yj+sssgrad*rmij*evdwij*yj
3762           ggg(3)=facvdw*zj+sssgrad*rmij*evdwij*zj
3763           else
3764           ggg(1)=0.0
3765           ggg(2)=0.0
3766           ggg(3)=0.0
3767           endif
3768 c          do k=1,3
3769 c            ghalf=0.5D0*ggg(k)
3770 c            gvdwpp(k,i)=gvdwpp(k,i)+ghalf
3771 c            gvdwpp(k,j)=gvdwpp(k,j)+ghalf
3772 c          enddo
3773 c 9/28/08 AL Gradient compotents will be summed only at the end
3774           do k=1,3
3775             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
3776             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
3777           enddo
3778 *
3779 * Loop over residues i+1 thru j-1.
3780 *
3781 cgrad          do k=i+1,j-1
3782 cgrad            do l=1,3
3783 cgrad              gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
3784 cgrad            enddo
3785 cgrad          enddo
3786 #else
3787 C MARYSIA
3788           facvdw=(ev1+evdwij)*sss
3789           facel=(el1+eesij)
3790           fac1=fac
3791           fac=-3*rrmij*(facvdw+facvdw+facel)
3792           erij(1)=xj*rmij
3793           erij(2)=yj*rmij
3794           erij(3)=zj*rmij
3795 *
3796 * Radial derivatives. First process both termini of the fragment (i,j)
3797 *
3798           ggg(1)=fac*xj
3799           ggg(2)=fac*yj
3800           ggg(3)=fac*zj
3801 c          do k=1,3
3802 c            ghalf=0.5D0*ggg(k)
3803 c            gelc(k,i)=gelc(k,i)+ghalf
3804 c            gelc(k,j)=gelc(k,j)+ghalf
3805 c          enddo
3806 c 9/28/08 AL Gradient compotents will be summed only at the end
3807           do k=1,3
3808             gelc_long(k,j)=gelc(k,j)+ggg(k)
3809             gelc_long(k,i)=gelc(k,i)-ggg(k)
3810           enddo
3811 *
3812 * Loop over residues i+1 thru j-1.
3813 *
3814 cgrad          do k=i+1,j-1
3815 cgrad            do l=1,3
3816 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3817 cgrad            enddo
3818 cgrad          enddo
3819 c 9/28/08 AL Gradient compotents will be summed only at the end
3820           ggg(1)=facvdw*xj+sssgrad*rmij*evdwij*xj
3821           ggg(2)=facvdw*yj+sssgrad*rmij*evdwij*yj
3822           ggg(3)=facvdw*zj+sssgrad*rmij*evdwij*zj
3823           do k=1,3
3824             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
3825             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
3826           enddo
3827 #endif
3828 *
3829 * Angular part
3830 *
3831           ecosa=2.0D0*fac3*fac1+fac4
3832           fac4=-3.0D0*fac4
3833           fac3=-6.0D0*fac3
3834           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
3835           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
3836           do k=1,3
3837             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
3838             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
3839           enddo
3840 cd        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
3841 cd   &          (dcosg(k),k=1,3)
3842           do k=1,3
3843             ggg(k)=ecosb*dcosb(k)+ecosg*dcosg(k)
3844           enddo
3845 c          do k=1,3
3846 c            ghalf=0.5D0*ggg(k)
3847 c            gelc(k,i)=gelc(k,i)+ghalf
3848 c     &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
3849 c     &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3850 c            gelc(k,j)=gelc(k,j)+ghalf
3851 c     &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
3852 c     &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3853 c          enddo
3854 cgrad          do k=i+1,j-1
3855 cgrad            do l=1,3
3856 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3857 cgrad            enddo
3858 cgrad          enddo
3859           do k=1,3
3860             gelc(k,i)=gelc(k,i)
3861      &           +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
3862      &           + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3863             gelc(k,j)=gelc(k,j)
3864      &           +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
3865      &           + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3866             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
3867             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
3868           enddo
3869 C MARYSIA
3870 c          endif !sscale
3871           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
3872      &        .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0
3873      &        .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
3874 C
3875 C 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
3876 C   energy of a peptide unit is assumed in the form of a second-order
3877 C   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
3878 C   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
3879 C   are computed for EVERY pair of non-contiguous peptide groups.
3880 C
3881
3882           if (j.lt.nres-1) then
3883             j1=j+1
3884             j2=j-1
3885           else
3886             j1=j-1
3887             j2=j-2
3888           endif
3889           kkk=0
3890           lll=0
3891           do k=1,2
3892             do l=1,2
3893               kkk=kkk+1
3894               muij(kkk)=mu(k,i)*mu(l,j)
3895 c              write(iout,*) 'mumu=', mu(k,i),mu(l,j),i,j,k,l
3896 #ifdef NEWCORR
3897              gmuij1(kkk)=gtb1(k,i+1)*mu(l,j)
3898 c             write(iout,*) 'k=',k,i,gtb1(k,i+1),gtb1(k,i+1)*mu(l,j)
3899              gmuij2(kkk)=gUb2(k,i)*mu(l,j)
3900              gmuji1(kkk)=mu(k,i)*gtb1(l,j+1)
3901 c             write(iout,*) 'l=',l,j,gtb1(l,j+1),gtb1(l,j+1)*mu(k,i)
3902              gmuji2(kkk)=mu(k,i)*gUb2(l,j)
3903 #endif
3904             enddo
3905           enddo
3906 cd         write (iout,*) 'EELEC: i',i,' j',j
3907 cd          write (iout,*) 'j',j,' j1',j1,' j2',j2
3908 cd          write(iout,*) 'muij',muij
3909           ury=scalar(uy(1,i),erij)
3910           urz=scalar(uz(1,i),erij)
3911           vry=scalar(uy(1,j),erij)
3912           vrz=scalar(uz(1,j),erij)
3913           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
3914           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
3915           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
3916           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
3917           fac=dsqrt(-ael6i)*r3ij
3918           a22=a22*fac
3919           a23=a23*fac
3920           a32=a32*fac
3921           a33=a33*fac
3922 cd          write (iout,'(4i5,4f10.5)')
3923 cd     &     i,itortyp(itype(i)),j,itortyp(itype(j)),a22,a23,a32,a33
3924 cd          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
3925 cd          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') uy(:,i),uz(:,i),
3926 cd     &      uy(:,j),uz(:,j)
3927 cd          write (iout,'(4f10.5)')
3928 cd     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
3929 cd     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
3930 cd          write (iout,'(4f10.5)') ury,urz,vry,vrz
3931 cd           write (iout,'(9f10.5/)')
3932 cd     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
3933 C Derivatives of the elements of A in virtual-bond vectors
3934           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
3935           do k=1,3
3936             uryg(k,1)=scalar(erder(1,k),uy(1,i))
3937             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
3938             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
3939             urzg(k,1)=scalar(erder(1,k),uz(1,i))
3940             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
3941             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
3942             vryg(k,1)=scalar(erder(1,k),uy(1,j))
3943             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
3944             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
3945             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
3946             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
3947             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
3948           enddo
3949 C Compute radial contributions to the gradient
3950           facr=-3.0d0*rrmij
3951           a22der=a22*facr
3952           a23der=a23*facr
3953           a32der=a32*facr
3954           a33der=a33*facr
3955           agg(1,1)=a22der*xj
3956           agg(2,1)=a22der*yj
3957           agg(3,1)=a22der*zj
3958           agg(1,2)=a23der*xj
3959           agg(2,2)=a23der*yj
3960           agg(3,2)=a23der*zj
3961           agg(1,3)=a32der*xj
3962           agg(2,3)=a32der*yj
3963           agg(3,3)=a32der*zj
3964           agg(1,4)=a33der*xj
3965           agg(2,4)=a33der*yj
3966           agg(3,4)=a33der*zj
3967 C Add the contributions coming from er
3968           fac3=-3.0d0*fac
3969           do k=1,3
3970             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
3971             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
3972             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
3973             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
3974           enddo
3975           do k=1,3
3976 C Derivatives in DC(i)
3977 cgrad            ghalf1=0.5d0*agg(k,1)
3978 cgrad            ghalf2=0.5d0*agg(k,2)
3979 cgrad            ghalf3=0.5d0*agg(k,3)
3980 cgrad            ghalf4=0.5d0*agg(k,4)
3981             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j))
3982      &      -3.0d0*uryg(k,2)*vry)!+ghalf1
3983             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j))
3984      &      -3.0d0*uryg(k,2)*vrz)!+ghalf2
3985             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j))
3986      &      -3.0d0*urzg(k,2)*vry)!+ghalf3
3987             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j))
3988      &      -3.0d0*urzg(k,2)*vrz)!+ghalf4
3989 C Derivatives in DC(i+1)
3990             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j))
3991      &      -3.0d0*uryg(k,3)*vry)!+agg(k,1)
3992             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j))
3993      &      -3.0d0*uryg(k,3)*vrz)!+agg(k,2)
3994             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j))
3995      &      -3.0d0*urzg(k,3)*vry)!+agg(k,3)
3996             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j))
3997      &      -3.0d0*urzg(k,3)*vrz)!+agg(k,4)
3998 C Derivatives in DC(j)
3999             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i))
4000      &      -3.0d0*vryg(k,2)*ury)!+ghalf1
4001             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i))
4002      &      -3.0d0*vrzg(k,2)*ury)!+ghalf2
4003             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i))
4004      &      -3.0d0*vryg(k,2)*urz)!+ghalf3
4005             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i))
4006      &      -3.0d0*vrzg(k,2)*urz)!+ghalf4
4007 C Derivatives in DC(j+1) or DC(nres-1)
4008             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i))
4009      &      -3.0d0*vryg(k,3)*ury)
4010             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i))
4011      &      -3.0d0*vrzg(k,3)*ury)
4012             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i))
4013      &      -3.0d0*vryg(k,3)*urz)
4014             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i))
4015      &      -3.0d0*vrzg(k,3)*urz)
4016 cgrad            if (j.eq.nres-1 .and. i.lt.j-2) then
4017 cgrad              do l=1,4
4018 cgrad                aggj1(k,l)=aggj1(k,l)+agg(k,l)
4019 cgrad              enddo
4020 cgrad            endif
4021           enddo
4022           acipa(1,1)=a22
4023           acipa(1,2)=a23
4024           acipa(2,1)=a32
4025           acipa(2,2)=a33
4026           a22=-a22
4027           a23=-a23
4028           do l=1,2
4029             do k=1,3
4030               agg(k,l)=-agg(k,l)
4031               aggi(k,l)=-aggi(k,l)
4032               aggi1(k,l)=-aggi1(k,l)
4033               aggj(k,l)=-aggj(k,l)
4034               aggj1(k,l)=-aggj1(k,l)
4035             enddo
4036           enddo
4037           if (j.lt.nres-1) then
4038             a22=-a22
4039             a32=-a32
4040             do l=1,3,2
4041               do k=1,3
4042                 agg(k,l)=-agg(k,l)
4043                 aggi(k,l)=-aggi(k,l)
4044                 aggi1(k,l)=-aggi1(k,l)
4045                 aggj(k,l)=-aggj(k,l)
4046                 aggj1(k,l)=-aggj1(k,l)
4047               enddo
4048             enddo
4049           else
4050             a22=-a22
4051             a23=-a23
4052             a32=-a32
4053             a33=-a33
4054             do l=1,4
4055               do k=1,3
4056                 agg(k,l)=-agg(k,l)
4057                 aggi(k,l)=-aggi(k,l)
4058                 aggi1(k,l)=-aggi1(k,l)
4059                 aggj(k,l)=-aggj(k,l)
4060                 aggj1(k,l)=-aggj1(k,l)
4061               enddo
4062             enddo
4063           endif
4064           ENDIF ! WCORR
4065           IF (wel_loc.gt.0.0d0) THEN
4066 C Contribution to the local-electrostatic energy coming from the i-j pair
4067           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3)
4068      &     +a33*muij(4)
4069 c          write (iout,*) 'i',i,' j',j,itype(i),itype(j),
4070 c     &                     ' eel_loc_ij',eel_loc_ij
4071 C          write(iout,*) 'muije=',i,j,muij(1),muij(2),muij(3),muij(4)
4072 C Calculate patrial derivative for theta angle
4073 #ifdef NEWCORR
4074          geel_loc_ij=a22*gmuij1(1)
4075      &     +a23*gmuij1(2)
4076      &     +a32*gmuij1(3)
4077      &     +a33*gmuij1(4)
4078 c         write(iout,*) "derivative over thatai"
4079 c         write(iout,*) a22*gmuij1(1), a23*gmuij1(2) ,a32*gmuij1(3),
4080 c     &   a33*gmuij1(4)
4081          gloc(nphi+i,icg)=gloc(nphi+i,icg)+
4082      &      geel_loc_ij*wel_loc
4083 c         write(iout,*) "derivative over thatai-1"
4084 c         write(iout,*) a22*gmuij2(1), a23*gmuij2(2) ,a32*gmuij2(3),
4085 c     &   a33*gmuij2(4)
4086          geel_loc_ij=
4087      &     a22*gmuij2(1)
4088      &     +a23*gmuij2(2)
4089      &     +a32*gmuij2(3)
4090      &     +a33*gmuij2(4)
4091          gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
4092      &      geel_loc_ij*wel_loc
4093 c  Derivative over j residue
4094          geel_loc_ji=a22*gmuji1(1)
4095      &     +a23*gmuji1(2)
4096      &     +a32*gmuji1(3)
4097      &     +a33*gmuji1(4)
4098 c         write(iout,*) "derivative over thataj"
4099 c         write(iout,*) a22*gmuji1(1), a23*gmuji1(2) ,a32*gmuji1(3),
4100 c     &   a33*gmuji1(4)
4101
4102         gloc(nphi+j,icg)=gloc(nphi+j,icg)+
4103      &      geel_loc_ji*wel_loc
4104          geel_loc_ji=
4105      &     +a22*gmuji2(1)
4106      &     +a23*gmuji2(2)
4107      &     +a32*gmuji2(3)
4108      &     +a33*gmuji2(4)
4109 c         write(iout,*) "derivative over thataj-1"
4110 c         write(iout,*) a22*gmuji2(1), a23*gmuji2(2) ,a32*gmuji2(3),
4111 c     &   a33*gmuji2(4)
4112          gloc(nphi+j-1,icg)=gloc(nphi+j-1,icg)+
4113      &      geel_loc_ji*wel_loc
4114 #endif
4115 cd          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
4116
4117           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
4118      &            'eelloc',i,j,eel_loc_ij
4119 c           if (eel_loc_ij.ne.0)
4120 c     &      write (iout,'(a4,2i4,8f9.5)')'chuj',
4121 c     &     i,j,a22,muij(1),a23,muij(2),a32,muij(3),a33,muij(4)
4122
4123           eel_loc=eel_loc+eel_loc_ij
4124 C Partial derivatives in virtual-bond dihedral angles gamma
4125           if (i.gt.1)
4126      &    gel_loc_loc(i-1)=gel_loc_loc(i-1)+
4127      &            a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j)
4128      &           +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j)
4129           gel_loc_loc(j-1)=gel_loc_loc(j-1)+
4130      &            a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j)
4131      &           +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j)
4132 C Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
4133           do l=1,3
4134             ggg(l)=agg(l,1)*muij(1)+
4135      &          agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4)
4136             gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l)
4137             gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l)
4138 cgrad            ghalf=0.5d0*ggg(l)
4139 cgrad            gel_loc(l,i)=gel_loc(l,i)+ghalf
4140 cgrad            gel_loc(l,j)=gel_loc(l,j)+ghalf
4141           enddo
4142 cgrad          do k=i+1,j2
4143 cgrad            do l=1,3
4144 cgrad              gel_loc(l,k)=gel_loc(l,k)+ggg(l)
4145 cgrad            enddo
4146 cgrad          enddo
4147 C Remaining derivatives of eello
4148           do l=1,3
4149             gel_loc(l,i)=gel_loc(l,i)+(aggi(l,1)*muij(1)+
4150      &        aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4))
4151             gel_loc(l,i+1)=gel_loc(l,i+1)+(aggi1(l,1)*muij(1)+
4152      &     aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4))
4153             gel_loc(l,j)=gel_loc(l,j)+(aggj(l,1)*muij(1)+
4154      &       aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4))
4155             gel_loc(l,j1)=gel_loc(l,j1)+(aggj1(l,1)*muij(1)+
4156      &     aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4))
4157           enddo
4158           ENDIF
4159 C Change 12/26/95 to calculate four-body contributions to H-bonding energy
4160 c          if (j.gt.i+1 .and. num_conti.le.maxconts) then
4161           if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0
4162      &       .and. num_conti.le.maxconts) then
4163 c            write (iout,*) i,j," entered corr"
4164 C
4165 C Calculate the contact function. The ith column of the array JCONT will
4166 C contain the numbers of atoms that make contacts with the atom I (of numbers
4167 C greater than I). The arrays FACONT and GACONT will contain the values of
4168 C the contact function and its derivative.
4169 c           r0ij=1.02D0*rpp(iteli,itelj)
4170 c           r0ij=1.11D0*rpp(iteli,itelj)
4171             r0ij=2.20D0*rpp(iteli,itelj)
4172 c           r0ij=1.55D0*rpp(iteli,itelj)
4173             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
4174             if (fcont.gt.0.0D0) then
4175               num_conti=num_conti+1
4176               if (num_conti.gt.maxconts) then
4177                 write (iout,*) 'WARNING - max. # of contacts exceeded;',
4178      &                         ' will skip next contacts for this conf.'
4179               else
4180                 jcont_hb(num_conti,i)=j
4181 cd                write (iout,*) "i",i," j",j," num_conti",num_conti,
4182 cd     &           " jcont_hb",jcont_hb(num_conti,i)
4183                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.
4184      &          wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
4185 C 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
4186 C  terms.
4187                 d_cont(num_conti,i)=rij
4188 cd                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
4189 C     --- Electrostatic-interaction matrix ---
4190                 a_chuj(1,1,num_conti,i)=a22
4191                 a_chuj(1,2,num_conti,i)=a23
4192                 a_chuj(2,1,num_conti,i)=a32
4193                 a_chuj(2,2,num_conti,i)=a33
4194 C     --- Gradient of rij
4195                 do kkk=1,3
4196                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
4197                 enddo
4198                 kkll=0
4199                 do k=1,2
4200                   do l=1,2
4201                     kkll=kkll+1
4202                     do m=1,3
4203                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
4204                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
4205                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
4206                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
4207                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
4208                     enddo
4209                   enddo
4210                 enddo
4211                 ENDIF
4212                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
4213 C Calculate contact energies
4214                 cosa4=4.0D0*cosa
4215                 wij=cosa-3.0D0*cosb*cosg
4216                 cosbg1=cosb+cosg
4217                 cosbg2=cosb-cosg
4218 c               fac3=dsqrt(-ael6i)/r0ij**3
4219                 fac3=dsqrt(-ael6i)*r3ij
4220 c                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
4221                 ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
4222                 if (ees0tmp.gt.0) then
4223                   ees0pij=dsqrt(ees0tmp)
4224                 else
4225                   ees0pij=0
4226                 endif
4227 c                ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
4228                 ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
4229                 if (ees0tmp.gt.0) then
4230                   ees0mij=dsqrt(ees0tmp)
4231                 else
4232                   ees0mij=0
4233                 endif
4234 c               ees0mij=0.0D0
4235                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij)
4236                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij)
4237 C Diagnostics. Comment out or remove after debugging!
4238 c               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
4239 c               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
4240 c               ees0m(num_conti,i)=0.0D0
4241 C End diagnostics.
4242 c               write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
4243 c    & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
4244 C Angular derivatives of the contact function
4245                 ees0pij1=fac3/ees0pij
4246                 ees0mij1=fac3/ees0mij
4247                 fac3p=-3.0D0*fac3*rrmij
4248                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
4249                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
4250 c               ees0mij1=0.0D0
4251                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
4252                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
4253                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
4254                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
4255                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
4256                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
4257                 ecosap=ecosa1+ecosa2
4258                 ecosbp=ecosb1+ecosb2
4259                 ecosgp=ecosg1+ecosg2
4260                 ecosam=ecosa1-ecosa2
4261                 ecosbm=ecosb1-ecosb2
4262                 ecosgm=ecosg1-ecosg2
4263 C Diagnostics
4264 c               ecosap=ecosa1
4265 c               ecosbp=ecosb1
4266 c               ecosgp=ecosg1
4267 c               ecosam=0.0D0
4268 c               ecosbm=0.0D0
4269 c               ecosgm=0.0D0
4270 C End diagnostics
4271                 facont_hb(num_conti,i)=fcont
4272                 fprimcont=fprimcont/rij
4273 cd              facont_hb(num_conti,i)=1.0D0
4274 C Following line is for diagnostics.
4275 cd              fprimcont=0.0D0
4276                 do k=1,3
4277                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
4278                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
4279                 enddo
4280                 do k=1,3
4281                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
4282                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
4283                 enddo
4284                 gggp(1)=gggp(1)+ees0pijp*xj
4285                 gggp(2)=gggp(2)+ees0pijp*yj
4286                 gggp(3)=gggp(3)+ees0pijp*zj
4287                 gggm(1)=gggm(1)+ees0mijp*xj
4288                 gggm(2)=gggm(2)+ees0mijp*yj
4289                 gggm(3)=gggm(3)+ees0mijp*zj
4290 C Derivatives due to the contact function
4291                 gacont_hbr(1,num_conti,i)=fprimcont*xj
4292                 gacont_hbr(2,num_conti,i)=fprimcont*yj
4293                 gacont_hbr(3,num_conti,i)=fprimcont*zj
4294                 do k=1,3
4295 c
4296 c 10/24/08 cgrad and ! comments indicate the parts of the code removed
4297 c          following the change of gradient-summation algorithm.
4298 c
4299 cgrad                  ghalfp=0.5D0*gggp(k)
4300 cgrad                  ghalfm=0.5D0*gggm(k)
4301                   gacontp_hb1(k,num_conti,i)=!ghalfp
4302      &              +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i))
4303      &              + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
4304                   gacontp_hb2(k,num_conti,i)=!ghalfp
4305      &              +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j))
4306      &              + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
4307                   gacontp_hb3(k,num_conti,i)=gggp(k)
4308                   gacontm_hb1(k,num_conti,i)=!ghalfm
4309      &              +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i))
4310      &              + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
4311                   gacontm_hb2(k,num_conti,i)=!ghalfm
4312      &              +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j))
4313      &              + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
4314                   gacontm_hb3(k,num_conti,i)=gggm(k)
4315                 enddo
4316 C Diagnostics. Comment out or remove after debugging!
4317 cdiag           do k=1,3
4318 cdiag             gacontp_hb1(k,num_conti,i)=0.0D0
4319 cdiag             gacontp_hb2(k,num_conti,i)=0.0D0
4320 cdiag             gacontp_hb3(k,num_conti,i)=0.0D0
4321 cdiag             gacontm_hb1(k,num_conti,i)=0.0D0
4322 cdiag             gacontm_hb2(k,num_conti,i)=0.0D0
4323 cdiag             gacontm_hb3(k,num_conti,i)=0.0D0
4324 cdiag           enddo
4325               ENDIF ! wcorr
4326               endif  ! num_conti.le.maxconts
4327             endif  ! fcont.gt.0
4328           endif    ! j.gt.i+1
4329           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
4330             do k=1,4
4331               do l=1,3
4332                 ghalf=0.5d0*agg(l,k)
4333                 aggi(l,k)=aggi(l,k)+ghalf
4334                 aggi1(l,k)=aggi1(l,k)+agg(l,k)
4335                 aggj(l,k)=aggj(l,k)+ghalf
4336               enddo
4337             enddo
4338             if (j.eq.nres-1 .and. i.lt.j-2) then
4339               do k=1,4
4340                 do l=1,3
4341                   aggj1(l,k)=aggj1(l,k)+agg(l,k)
4342                 enddo
4343               enddo
4344             endif
4345           endif
4346 c          t_eelecij=t_eelecij+MPI_Wtime()-time00
4347       return
4348       end
4349 C-----------------------------------------------------------------------------
4350       subroutine eturn3(i,eello_turn3)
4351 C Third- and fourth-order contributions from turns
4352       implicit real*8 (a-h,o-z)
4353       include 'DIMENSIONS'
4354       include 'COMMON.IOUNITS'
4355       include 'COMMON.GEO'
4356       include 'COMMON.VAR'
4357       include 'COMMON.LOCAL'
4358       include 'COMMON.CHAIN'
4359       include 'COMMON.DERIV'
4360       include 'COMMON.INTERACT'
4361       include 'COMMON.CONTACTS'
4362       include 'COMMON.TORSION'
4363       include 'COMMON.VECTORS'
4364       include 'COMMON.FFIELD'
4365       include 'COMMON.CONTROL'
4366       dimension ggg(3)
4367       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
4368      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
4369      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2),gpizda1(2,2),
4370      &  gpizda2(2,2),auxgmat1(2,2),auxgmatt1(2,2),
4371      &  auxgmat2(2,2),auxgmatt2(2,2)
4372       double precision agg(3,4),aggi(3,4),aggi1(3,4),
4373      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
4374       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
4375      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
4376      &    num_conti,j1,j2
4377       j=i+2
4378 c      write (iout,*) "eturn3",i,j,j1,j2
4379       a_temp(1,1)=a22
4380       a_temp(1,2)=a23
4381       a_temp(2,1)=a32
4382       a_temp(2,2)=a33
4383 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4384 C
4385 C               Third-order contributions
4386 C
4387 C                 (i+2)o----(i+3)
4388 C                      | |
4389 C                      | |
4390 C                 (i+1)o----i
4391 C
4392 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4393 cd        call checkint_turn3(i,a_temp,eello_turn3_num)
4394         call matmat2(EUg(1,1,i+1),EUg(1,1,i+2),auxmat(1,1))
4395 c auxalary matices for theta gradient
4396 c auxalary matrix for i+1 and constant i+2
4397         call matmat2(gtEUg(1,1,i+1),EUg(1,1,i+2),auxgmat1(1,1))
4398 c auxalary matrix for i+2 and constant i+1
4399         call matmat2(EUg(1,1,i+1),gtEUg(1,1,i+2),auxgmat2(1,1))
4400         call transpose2(auxmat(1,1),auxmat1(1,1))
4401         call transpose2(auxgmat1(1,1),auxgmatt1(1,1))
4402         call transpose2(auxgmat2(1,1),auxgmatt2(1,1))
4403         call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4404         call matmat2(a_temp(1,1),auxgmatt1(1,1),gpizda1(1,1))
4405         call matmat2(a_temp(1,1),auxgmatt2(1,1),gpizda2(1,1))
4406         eello_turn3=eello_turn3+0.5d0*(pizda(1,1)+pizda(2,2))
4407 C Derivatives in theta
4408         gloc(nphi+i,icg)=gloc(nphi+i,icg)
4409      &  +0.5d0*(gpizda1(1,1)+gpizda1(2,2))*wturn3
4410         gloc(nphi+i+1,icg)=gloc(nphi+i+1,icg)
4411      &  +0.5d0*(gpizda2(1,1)+gpizda2(2,2))*wturn3
4412
4413         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
4414      &          'eturn3',i,j,0.5d0*(pizda(1,1)+pizda(2,2))
4415 cd        write (2,*) 'i,',i,' j',j,'eello_turn3',
4416 cd     &    0.5d0*(pizda(1,1)+pizda(2,2)),
4417 cd     &    ' eello_turn3_num',4*eello_turn3_num
4418 C Derivatives in gamma(i)
4419         call matmat2(EUgder(1,1,i+1),EUg(1,1,i+2),auxmat2(1,1))
4420         call transpose2(auxmat2(1,1),auxmat3(1,1))
4421         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
4422         gel_loc_turn3(i)=gel_loc_turn3(i)+0.5d0*(pizda(1,1)+pizda(2,2))
4423 C Derivatives in gamma(i+1)
4424         call matmat2(EUg(1,1,i+1),EUgder(1,1,i+2),auxmat2(1,1))
4425         call transpose2(auxmat2(1,1),auxmat3(1,1))
4426         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
4427         gel_loc_turn3(i+1)=gel_loc_turn3(i+1)
4428      &    +0.5d0*(pizda(1,1)+pizda(2,2))
4429 C Cartesian derivatives
4430 !DIR$ UNROLL(0)
4431         do l=1,3
4432 c            ghalf1=0.5d0*agg(l,1)
4433 c            ghalf2=0.5d0*agg(l,2)
4434 c            ghalf3=0.5d0*agg(l,3)
4435 c            ghalf4=0.5d0*agg(l,4)
4436           a_temp(1,1)=aggi(l,1)!+ghalf1
4437           a_temp(1,2)=aggi(l,2)!+ghalf2
4438           a_temp(2,1)=aggi(l,3)!+ghalf3
4439           a_temp(2,2)=aggi(l,4)!+ghalf4
4440           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4441           gcorr3_turn(l,i)=gcorr3_turn(l,i)
4442      &      +0.5d0*(pizda(1,1)+pizda(2,2))
4443           a_temp(1,1)=aggi1(l,1)!+agg(l,1)
4444           a_temp(1,2)=aggi1(l,2)!+agg(l,2)
4445           a_temp(2,1)=aggi1(l,3)!+agg(l,3)
4446           a_temp(2,2)=aggi1(l,4)!+agg(l,4)
4447           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4448           gcorr3_turn(l,i+1)=gcorr3_turn(l,i+1)
4449      &      +0.5d0*(pizda(1,1)+pizda(2,2))
4450           a_temp(1,1)=aggj(l,1)!+ghalf1
4451           a_temp(1,2)=aggj(l,2)!+ghalf2
4452           a_temp(2,1)=aggj(l,3)!+ghalf3
4453           a_temp(2,2)=aggj(l,4)!+ghalf4
4454           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4455           gcorr3_turn(l,j)=gcorr3_turn(l,j)
4456      &      +0.5d0*(pizda(1,1)+pizda(2,2))
4457           a_temp(1,1)=aggj1(l,1)
4458           a_temp(1,2)=aggj1(l,2)
4459           a_temp(2,1)=aggj1(l,3)
4460           a_temp(2,2)=aggj1(l,4)
4461           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4462           gcorr3_turn(l,j1)=gcorr3_turn(l,j1)
4463      &      +0.5d0*(pizda(1,1)+pizda(2,2))
4464         enddo
4465       return
4466       end
4467 C-------------------------------------------------------------------------------
4468       subroutine eturn4(i,eello_turn4)
4469 C Third- and fourth-order contributions from turns
4470       implicit real*8 (a-h,o-z)
4471       include 'DIMENSIONS'
4472       include 'COMMON.IOUNITS'
4473       include 'COMMON.GEO'
4474       include 'COMMON.VAR'
4475       include 'COMMON.LOCAL'
4476       include 'COMMON.CHAIN'
4477       include 'COMMON.DERIV'
4478       include 'COMMON.INTERACT'
4479       include 'COMMON.CONTACTS'
4480       include 'COMMON.TORSION'
4481       include 'COMMON.VECTORS'
4482       include 'COMMON.FFIELD'
4483       include 'COMMON.CONTROL'
4484       dimension ggg(3)
4485       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
4486      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
4487      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2),auxgvec(2),
4488      &  auxgEvec1(2),auxgEvec2(2),auxgEvec3(2),
4489      &  gte1t(2,2),gte2t(2,2),gte3t(2,2),
4490      &  gte1a(2,2),gtae3(2,2),gtae3e2(2,2), ae3gte2(2,2),
4491      &  gtEpizda1(2,2),gtEpizda2(2,2),gtEpizda3(2,2)
4492       double precision agg(3,4),aggi(3,4),aggi1(3,4),
4493      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
4494       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
4495      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
4496      &    num_conti,j1,j2
4497       j=i+3
4498 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4499 C
4500 C               Fourth-order contributions
4501 C
4502 C                 (i+3)o----(i+4)
4503 C                     /  |
4504 C               (i+2)o   |
4505 C                     \  |
4506 C                 (i+1)o----i
4507 C
4508 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4509 cd        call checkint_turn4(i,a_temp,eello_turn4_num)
4510 c        write (iout,*) "eturn4 i",i," j",j," j1",j1," j2",j2
4511 c        write(iout,*)"WCHODZE W PROGRAM"
4512         a_temp(1,1)=a22
4513         a_temp(1,2)=a23
4514         a_temp(2,1)=a32
4515         a_temp(2,2)=a33
4516         iti1=itortyp(itype(i+1))
4517         iti2=itortyp(itype(i+2))
4518         iti3=itortyp(itype(i+3))
4519 c        write(iout,*) "iti1",iti1," iti2",iti2," iti3",iti3
4520         call transpose2(EUg(1,1,i+1),e1t(1,1))
4521         call transpose2(Eug(1,1,i+2),e2t(1,1))
4522         call transpose2(Eug(1,1,i+3),e3t(1,1))
4523 C Ematrix derivative in theta
4524         call transpose2(gtEUg(1,1,i+1),gte1t(1,1))
4525         call transpose2(gtEug(1,1,i+2),gte2t(1,1))
4526         call transpose2(gtEug(1,1,i+3),gte3t(1,1))
4527         call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4528 c       eta1 in derivative theta
4529         call matmat2(gte1t(1,1),a_temp(1,1),gte1a(1,1))
4530         call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4531 c       auxgvec is derivative of Ub2 so i+3 theta
4532         call matvec2(e1a(1,1),gUb2(1,i+3),auxgvec(1))
4533 c       auxalary matrix of E i+1
4534         call matvec2(gte1a(1,1),Ub2(1,i+3),auxgEvec1(1))
4535 c        s1=0.0
4536 c        gs1=0.0
4537         s1=scalar2(b1(1,i+2),auxvec(1))
4538 c derivative of theta i+2 with constant i+3
4539         gs23=scalar2(gtb1(1,i+2),auxvec(1))
4540 c derivative of theta i+2 with constant i+2
4541         gs32=scalar2(b1(1,i+2),auxgvec(1))
4542 c derivative of E matix in theta of i+1
4543         gsE13=scalar2(b1(1,i+2),auxgEvec1(1))
4544
4545         call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4546 c       ea31 in derivative theta
4547         call matmat2(a_temp(1,1),gte3t(1,1),gtae3(1,1))
4548         call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4549 c auxilary matrix auxgvec of Ub2 with constant E matirx
4550         call matvec2(ae3(1,1),gUb2(1,i+2),auxgvec(1))
4551 c auxilary matrix auxgEvec1 of E matix with Ub2 constant
4552         call matvec2(gtae3(1,1),Ub2(1,i+2),auxgEvec3(1))
4553
4554 c        s2=0.0
4555 c        gs2=0.0
4556         s2=scalar2(b1(1,i+1),auxvec(1))
4557 c derivative of theta i+1 with constant i+3
4558         gs13=scalar2(gtb1(1,i+1),auxvec(1))
4559 c derivative of theta i+2 with constant i+1
4560         gs21=scalar2(b1(1,i+1),auxgvec(1))
4561 c derivative of theta i+3 with constant i+1
4562         gsE31=scalar2(b1(1,i+1),auxgEvec3(1))
4563 c        write(iout,*) gs1,gs2,'i=',i,auxgvec(1),gUb2(1,i+2),gtb1(1,i+2),
4564 c     &  gtb1(1,i+1)
4565         call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4566 c two derivatives over diffetent matrices
4567 c gtae3e2 is derivative over i+3
4568         call matmat2(gtae3(1,1),e2t(1,1),gtae3e2(1,1))
4569 c ae3gte2 is derivative over i+2
4570         call matmat2(ae3(1,1),gte2t(1,1),ae3gte2(1,1))
4571         call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4572 c three possible derivative over theta E matices
4573 c i+1
4574         call matmat2(ae3e2(1,1),gte1t(1,1),gtEpizda1(1,1))
4575 c i+2
4576         call matmat2(ae3gte2(1,1),e1t(1,1),gtEpizda2(1,1))
4577 c i+3
4578         call matmat2(gtae3e2(1,1),e1t(1,1),gtEpizda3(1,1))
4579         s3=0.5d0*(pizda(1,1)+pizda(2,2))
4580
4581         gsEE1=0.5d0*(gtEpizda1(1,1)+gtEpizda1(2,2))
4582         gsEE2=0.5d0*(gtEpizda2(1,1)+gtEpizda2(2,2))
4583         gsEE3=0.5d0*(gtEpizda3(1,1)+gtEpizda3(2,2))
4584
4585         eello_turn4=eello_turn4-(s1+s2+s3)
4586 c             write(iout,*)'chujOWO', auxvec(1),b1(1,iti2)
4587 c        if (energy_dec) write (iout,'(a6,2i5,0pf7.3,3f7.3)')
4588 c     &      'eturn4',i,j,-(s1+s2+s3),s1,s2,s3
4589 cd        write (2,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
4590 cd     &    ' eello_turn4_num',8*eello_turn4_num
4591 #ifdef NEWCORR
4592         gloc(nphi+i,icg)=gloc(nphi+i,icg)
4593      &                  -(gs13+gsE13+gsEE1)*wturn4
4594         gloc(nphi+i+1,icg)= gloc(nphi+i+1,icg)
4595      &                    -(gs23+gs21+gsEE2)*wturn4
4596         gloc(nphi+i+2,icg)= gloc(nphi+i+2,icg)
4597      &                    -(gs32+gsE31+gsEE3)*wturn4
4598 c         gloc(nphi+i+1,icg)=gloc(nphi+i+1,icg)-
4599 c     &   gs2
4600 #endif
4601         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
4602      &      'eturn4',i,j,-(s1+s2+s3)
4603 c        write (iout,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
4604 c     &    ' eello_turn4_num',8*eello_turn4_num
4605 C Derivatives in gamma(i)
4606         call transpose2(EUgder(1,1,i+1),e1tder(1,1))
4607         call matmat2(e1tder(1,1),a_temp(1,1),auxmat(1,1))
4608         call matvec2(auxmat(1,1),Ub2(1,i+3),auxvec(1))
4609         s1=scalar2(b1(1,i+2),auxvec(1))
4610         call matmat2(ae3e2(1,1),e1tder(1,1),pizda(1,1))
4611         s3=0.5d0*(pizda(1,1)+pizda(2,2))
4612         gel_loc_turn4(i)=gel_loc_turn4(i)-(s1+s3)
4613 C Derivatives in gamma(i+1)
4614         call transpose2(EUgder(1,1,i+2),e2tder(1,1))
4615         call matvec2(ae3(1,1),Ub2der(1,i+2),auxvec(1))
4616         s2=scalar2(b1(1,i+1),auxvec(1))
4617         call matmat2(ae3(1,1),e2tder(1,1),auxmat(1,1))
4618         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
4619         s3=0.5d0*(pizda(1,1)+pizda(2,2))
4620         gel_loc_turn4(i+1)=gel_loc_turn4(i+1)-(s2+s3)
4621 C Derivatives in gamma(i+2)
4622         call transpose2(EUgder(1,1,i+3),e3tder(1,1))
4623         call matvec2(e1a(1,1),Ub2der(1,i+3),auxvec(1))
4624         s1=scalar2(b1(1,i+2),auxvec(1))
4625         call matmat2(a_temp(1,1),e3tder(1,1),auxmat(1,1))
4626         call matvec2(auxmat(1,1),Ub2(1,i+2),auxvec(1))
4627         s2=scalar2(b1(1,i+1),auxvec(1))
4628         call matmat2(auxmat(1,1),e2t(1,1),auxmat3(1,1))
4629         call matmat2(auxmat3(1,1),e1t(1,1),pizda(1,1))
4630         s3=0.5d0*(pizda(1,1)+pizda(2,2))
4631         gel_loc_turn4(i+2)=gel_loc_turn4(i+2)-(s1+s2+s3)
4632 C Cartesian derivatives
4633 C Derivatives of this turn contributions in DC(i+2)
4634         if (j.lt.nres-1) then
4635           do l=1,3
4636             a_temp(1,1)=agg(l,1)
4637             a_temp(1,2)=agg(l,2)
4638             a_temp(2,1)=agg(l,3)
4639             a_temp(2,2)=agg(l,4)
4640             call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4641             call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4642             s1=scalar2(b1(1,i+2),auxvec(1))
4643             call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4644             call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4645             s2=scalar2(b1(1,i+1),auxvec(1))
4646             call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4647             call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4648             s3=0.5d0*(pizda(1,1)+pizda(2,2))
4649             ggg(l)=-(s1+s2+s3)
4650             gcorr4_turn(l,i+2)=gcorr4_turn(l,i+2)-(s1+s2+s3)
4651           enddo
4652         endif
4653 C Remaining derivatives of this turn contribution
4654         do l=1,3
4655           a_temp(1,1)=aggi(l,1)
4656           a_temp(1,2)=aggi(l,2)
4657           a_temp(2,1)=aggi(l,3)
4658           a_temp(2,2)=aggi(l,4)
4659           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4660           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4661           s1=scalar2(b1(1,i+2),auxvec(1))
4662           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4663           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4664           s2=scalar2(b1(1,i+1),auxvec(1))
4665           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4666           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4667           s3=0.5d0*(pizda(1,1)+pizda(2,2))
4668           gcorr4_turn(l,i)=gcorr4_turn(l,i)-(s1+s2+s3)
4669           a_temp(1,1)=aggi1(l,1)
4670           a_temp(1,2)=aggi1(l,2)
4671           a_temp(2,1)=aggi1(l,3)
4672           a_temp(2,2)=aggi1(l,4)
4673           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4674           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4675           s1=scalar2(b1(1,i+2),auxvec(1))
4676           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4677           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4678           s2=scalar2(b1(1,i+1),auxvec(1))
4679           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4680           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4681           s3=0.5d0*(pizda(1,1)+pizda(2,2))
4682           gcorr4_turn(l,i+1)=gcorr4_turn(l,i+1)-(s1+s2+s3)
4683           a_temp(1,1)=aggj(l,1)
4684           a_temp(1,2)=aggj(l,2)
4685           a_temp(2,1)=aggj(l,3)
4686           a_temp(2,2)=aggj(l,4)
4687           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4688           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4689           s1=scalar2(b1(1,i+2),auxvec(1))
4690           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4691           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4692           s2=scalar2(b1(1,i+1),auxvec(1))
4693           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4694           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4695           s3=0.5d0*(pizda(1,1)+pizda(2,2))
4696           gcorr4_turn(l,j)=gcorr4_turn(l,j)-(s1+s2+s3)
4697           a_temp(1,1)=aggj1(l,1)
4698           a_temp(1,2)=aggj1(l,2)
4699           a_temp(2,1)=aggj1(l,3)
4700           a_temp(2,2)=aggj1(l,4)
4701           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4702           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4703           s1=scalar2(b1(1,i+2),auxvec(1))
4704           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4705           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4706           s2=scalar2(b1(1,i+1),auxvec(1))
4707           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4708           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4709           s3=0.5d0*(pizda(1,1)+pizda(2,2))
4710 c          write (iout,*) "s1",s1," s2",s2," s3",s3," s1+s2+s3",s1+s2+s3
4711           gcorr4_turn(l,j1)=gcorr4_turn(l,j1)-(s1+s2+s3)
4712         enddo
4713       return
4714       end
4715 C-----------------------------------------------------------------------------
4716       subroutine vecpr(u,v,w)
4717       implicit real*8(a-h,o-z)
4718       dimension u(3),v(3),w(3)
4719       w(1)=u(2)*v(3)-u(3)*v(2)
4720       w(2)=-u(1)*v(3)+u(3)*v(1)
4721       w(3)=u(1)*v(2)-u(2)*v(1)
4722       return
4723       end
4724 C-----------------------------------------------------------------------------
4725       subroutine unormderiv(u,ugrad,unorm,ungrad)
4726 C This subroutine computes the derivatives of a normalized vector u, given
4727 C the derivatives computed without normalization conditions, ugrad. Returns
4728 C ungrad.
4729       implicit none
4730       double precision u(3),ugrad(3,3),unorm,ungrad(3,3)
4731       double precision vec(3)
4732       double precision scalar
4733       integer i,j
4734 c      write (2,*) 'ugrad',ugrad
4735 c      write (2,*) 'u',u
4736       do i=1,3
4737         vec(i)=scalar(ugrad(1,i),u(1))
4738       enddo
4739 c      write (2,*) 'vec',vec
4740       do i=1,3
4741         do j=1,3
4742           ungrad(j,i)=(ugrad(j,i)-u(j)*vec(i))*unorm
4743         enddo
4744       enddo
4745 c      write (2,*) 'ungrad',ungrad
4746       return
4747       end
4748 C-----------------------------------------------------------------------------
4749       subroutine escp_soft_sphere(evdw2,evdw2_14)
4750 C
4751 C This subroutine calculates the excluded-volume interaction energy between
4752 C peptide-group centers and side chains and its gradient in virtual-bond and
4753 C side-chain vectors.
4754 C
4755       implicit real*8 (a-h,o-z)
4756       include 'DIMENSIONS'
4757       include 'COMMON.GEO'
4758       include 'COMMON.VAR'
4759       include 'COMMON.LOCAL'
4760       include 'COMMON.CHAIN'
4761       include 'COMMON.DERIV'
4762       include 'COMMON.INTERACT'
4763       include 'COMMON.FFIELD'
4764       include 'COMMON.IOUNITS'
4765       include 'COMMON.CONTROL'
4766       dimension ggg(3)
4767       evdw2=0.0D0
4768       evdw2_14=0.0d0
4769       r0_scp=4.5d0
4770 cd    print '(a)','Enter ESCP'
4771 cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
4772 C      do xshift=-1,1
4773 C      do yshift=-1,1
4774 C      do zshift=-1,1
4775       do i=iatscp_s,iatscp_e
4776         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
4777         iteli=itel(i)
4778         xi=0.5D0*(c(1,i)+c(1,i+1))
4779         yi=0.5D0*(c(2,i)+c(2,i+1))
4780         zi=0.5D0*(c(3,i)+c(3,i+1))
4781 C Return atom into box, boxxsize is size of box in x dimension
4782 c  134   continue
4783 c        if (xi.gt.((xshift+0.5d0)*boxxsize)) xi=xi-boxxsize
4784 c        if (xi.lt.((xshift-0.5d0)*boxxsize)) xi=xi+boxxsize
4785 C Condition for being inside the proper box
4786 c        if ((xi.gt.((xshift+0.5d0)*boxxsize)).or.
4787 c     &       (xi.lt.((xshift-0.5d0)*boxxsize))) then
4788 c        go to 134
4789 c        endif
4790 c  135   continue
4791 c        if (yi.gt.((yshift+0.5d0)*boxysize)) yi=yi-boxysize
4792 c        if (yi.lt.((yshift-0.5d0)*boxysize)) yi=yi+boxysize
4793 C Condition for being inside the proper box
4794 c        if ((yi.gt.((yshift+0.5d0)*boxysize)).or.
4795 c     &       (yi.lt.((yshift-0.5d0)*boxysize))) then
4796 c        go to 135
4797 c c       endif
4798 c  136   continue
4799 c        if (zi.gt.((zshift+0.5d0)*boxzsize)) zi=zi-boxzsize
4800 c        if (zi.lt.((zshift-0.5d0)*boxzsize)) zi=zi+boxzsize
4801 cC Condition for being inside the proper box
4802 c        if ((zi.gt.((zshift+0.5d0)*boxzsize)).or.
4803 c     &       (zi.lt.((zshift-0.5d0)*boxzsize))) then
4804 c        go to 136
4805 c        endif
4806           xi=mod(xi,boxxsize)
4807           if (xi.lt.0) xi=xi+boxxsize
4808           yi=mod(yi,boxysize)
4809           if (yi.lt.0) yi=yi+boxysize
4810           zi=mod(zi,boxzsize)
4811           if (zi.lt.0) zi=zi+boxzsize
4812 C          xi=xi+xshift*boxxsize
4813 C          yi=yi+yshift*boxysize
4814 C          zi=zi+zshift*boxzsize
4815         do iint=1,nscp_gr(i)
4816
4817         do j=iscpstart(i,iint),iscpend(i,iint)
4818           if (itype(j).eq.ntyp1) cycle
4819           itypj=iabs(itype(j))
4820 C Uncomment following three lines for SC-p interactions
4821 c         xj=c(1,nres+j)-xi
4822 c         yj=c(2,nres+j)-yi
4823 c         zj=c(3,nres+j)-zi
4824 C Uncomment following three lines for Ca-p interactions
4825           xj=c(1,j)
4826           yj=c(2,j)
4827           zj=c(3,j)
4828 c  174   continue
4829 c        if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
4830 c        if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
4831 C Condition for being inside the proper box
4832 c        if ((xj.gt.((0.5d0)*boxxsize)).or.
4833 c     &       (xj.lt.((-0.5d0)*boxxsize))) then
4834 c        go to 174
4835 c        endif
4836 c  175   continue
4837 c        if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
4838 c        if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
4839 cC Condition for being inside the proper box
4840 c        if ((yj.gt.((0.5d0)*boxysize)).or.
4841 c     &       (yj.lt.((-0.5d0)*boxysize))) then
4842 c        go to 175
4843 c        endif
4844 c  176   continue
4845 c        if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
4846 c        if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
4847 C Condition for being inside the proper box
4848 c        if ((zj.gt.((0.5d0)*boxzsize)).or.
4849 c     &       (zj.lt.((-0.5d0)*boxzsize))) then
4850 c        go to 176
4851           xj=mod(xj,boxxsize)
4852           if (xj.lt.0) xj=xj+boxxsize
4853           yj=mod(yj,boxysize)
4854           if (yj.lt.0) yj=yj+boxysize
4855           zj=mod(zj,boxzsize)
4856           if (zj.lt.0) zj=zj+boxzsize
4857       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
4858       xj_safe=xj
4859       yj_safe=yj
4860       zj_safe=zj
4861       subchap=0
4862       do xshift=-1,1
4863       do yshift=-1,1
4864       do zshift=-1,1
4865           xj=xj_safe+xshift*boxxsize
4866           yj=yj_safe+yshift*boxysize
4867           zj=zj_safe+zshift*boxzsize
4868           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
4869           if(dist_temp.lt.dist_init) then
4870             dist_init=dist_temp
4871             xj_temp=xj
4872             yj_temp=yj
4873             zj_temp=zj
4874             subchap=1
4875           endif
4876        enddo
4877        enddo
4878        enddo
4879        if (subchap.eq.1) then
4880           xj=xj_temp-xi
4881           yj=yj_temp-yi
4882           zj=zj_temp-zi
4883        else
4884           xj=xj_safe-xi
4885           yj=yj_safe-yi
4886           zj=zj_safe-zi
4887        endif
4888 c c       endif
4889 C          xj=xj-xi
4890 C          yj=yj-yi
4891 C          zj=zj-zi
4892           rij=xj*xj+yj*yj+zj*zj
4893
4894           r0ij=r0_scp
4895           r0ijsq=r0ij*r0ij
4896           if (rij.lt.r0ijsq) then
4897             evdwij=0.25d0*(rij-r0ijsq)**2
4898             fac=rij-r0ijsq
4899           else
4900             evdwij=0.0d0
4901             fac=0.0d0
4902           endif
4903           evdw2=evdw2+evdwij
4904 C
4905 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
4906 C
4907           ggg(1)=xj*fac
4908           ggg(2)=yj*fac
4909           ggg(3)=zj*fac
4910 cgrad          if (j.lt.i) then
4911 cd          write (iout,*) 'j<i'
4912 C Uncomment following three lines for SC-p interactions
4913 c           do k=1,3
4914 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
4915 c           enddo
4916 cgrad          else
4917 cd          write (iout,*) 'j>i'
4918 cgrad            do k=1,3
4919 cgrad              ggg(k)=-ggg(k)
4920 C Uncomment following line for SC-p interactions
4921 c             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
4922 cgrad            enddo
4923 cgrad          endif
4924 cgrad          do k=1,3
4925 cgrad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
4926 cgrad          enddo
4927 cgrad          kstart=min0(i+1,j)
4928 cgrad          kend=max0(i-1,j-1)
4929 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
4930 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
4931 cgrad          do k=kstart,kend
4932 cgrad            do l=1,3
4933 cgrad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
4934 cgrad            enddo
4935 cgrad          enddo
4936           do k=1,3
4937             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
4938             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
4939           enddo
4940         enddo
4941
4942         enddo ! iint
4943       enddo ! i
4944 C      enddo !zshift
4945 C      enddo !yshift
4946 C      enddo !xshift
4947       return
4948       end
4949 C-----------------------------------------------------------------------------
4950       subroutine escp(evdw2,evdw2_14)
4951 C
4952 C This subroutine calculates the excluded-volume interaction energy between
4953 C peptide-group centers and side chains and its gradient in virtual-bond and
4954 C side-chain vectors.
4955 C
4956       implicit real*8 (a-h,o-z)
4957       include 'DIMENSIONS'
4958       include 'COMMON.GEO'
4959       include 'COMMON.VAR'
4960       include 'COMMON.LOCAL'
4961       include 'COMMON.CHAIN'
4962       include 'COMMON.DERIV'
4963       include 'COMMON.INTERACT'
4964       include 'COMMON.FFIELD'
4965       include 'COMMON.IOUNITS'
4966       include 'COMMON.CONTROL'
4967       include 'COMMON.SPLITELE'
4968       dimension ggg(3)
4969       evdw2=0.0D0
4970       evdw2_14=0.0d0
4971 c        print *,boxxsize,boxysize,boxzsize,'wymiary pudla'
4972 cd    print '(a)','Enter ESCP'
4973 cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
4974 C      do xshift=-1,1
4975 C      do yshift=-1,1
4976 C      do zshift=-1,1
4977       do i=iatscp_s,iatscp_e
4978         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
4979         iteli=itel(i)
4980         xi=0.5D0*(c(1,i)+c(1,i+1))
4981         yi=0.5D0*(c(2,i)+c(2,i+1))
4982         zi=0.5D0*(c(3,i)+c(3,i+1))
4983           xi=mod(xi,boxxsize)
4984           if (xi.lt.0) xi=xi+boxxsize
4985           yi=mod(yi,boxysize)
4986           if (yi.lt.0) yi=yi+boxysize
4987           zi=mod(zi,boxzsize)
4988           if (zi.lt.0) zi=zi+boxzsize
4989 c          xi=xi+xshift*boxxsize
4990 c          yi=yi+yshift*boxysize
4991 c          zi=zi+zshift*boxzsize
4992 c        print *,xi,yi,zi,'polozenie i'
4993 C Return atom into box, boxxsize is size of box in x dimension
4994 c  134   continue
4995 c        if (xi.gt.((xshift+0.5d0)*boxxsize)) xi=xi-boxxsize
4996 c        if (xi.lt.((xshift-0.5d0)*boxxsize)) xi=xi+boxxsize
4997 C Condition for being inside the proper box
4998 c        if ((xi.gt.((xshift+0.5d0)*boxxsize)).or.
4999 c     &       (xi.lt.((xshift-0.5d0)*boxxsize))) then
5000 c        go to 134
5001 c        endif
5002 c  135   continue
5003 c          print *,xi,boxxsize,"pierwszy"
5004
5005 c        if (yi.gt.((yshift+0.5d0)*boxysize)) yi=yi-boxysize
5006 c        if (yi.lt.((yshift-0.5d0)*boxysize)) yi=yi+boxysize
5007 C Condition for being inside the proper box
5008 c        if ((yi.gt.((yshift+0.5d0)*boxysize)).or.
5009 c     &       (yi.lt.((yshift-0.5d0)*boxysize))) then
5010 c        go to 135
5011 c        endif
5012 c  136   continue
5013 c        if (zi.gt.((zshift+0.5d0)*boxzsize)) zi=zi-boxzsize
5014 c        if (zi.lt.((zshift-0.5d0)*boxzsize)) zi=zi+boxzsize
5015 C Condition for being inside the proper box
5016 c        if ((zi.gt.((zshift+0.5d0)*boxzsize)).or.
5017 c     &       (zi.lt.((zshift-0.5d0)*boxzsize))) then
5018 c        go to 136
5019 c        endif
5020         do iint=1,nscp_gr(i)
5021
5022         do j=iscpstart(i,iint),iscpend(i,iint)
5023           itypj=iabs(itype(j))
5024           if (itypj.eq.ntyp1) cycle
5025 C Uncomment following three lines for SC-p interactions
5026 c         xj=c(1,nres+j)-xi
5027 c         yj=c(2,nres+j)-yi
5028 c         zj=c(3,nres+j)-zi
5029 C Uncomment following three lines for Ca-p interactions
5030           xj=c(1,j)
5031           yj=c(2,j)
5032           zj=c(3,j)
5033           xj=mod(xj,boxxsize)
5034           if (xj.lt.0) xj=xj+boxxsize
5035           yj=mod(yj,boxysize)
5036           if (yj.lt.0) yj=yj+boxysize
5037           zj=mod(zj,boxzsize)
5038           if (zj.lt.0) zj=zj+boxzsize
5039 c  174   continue
5040 c        if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
5041 c        if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
5042 C Condition for being inside the proper box
5043 c        if ((xj.gt.((0.5d0)*boxxsize)).or.
5044 c     &       (xj.lt.((-0.5d0)*boxxsize))) then
5045 c        go to 174
5046 c        endif
5047 c  175   continue
5048 c        if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
5049 c        if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
5050 cC Condition for being inside the proper box
5051 c        if ((yj.gt.((0.5d0)*boxysize)).or.
5052 c     &       (yj.lt.((-0.5d0)*boxysize))) then
5053 c        go to 175
5054 c        endif
5055 c  176   continue
5056 c        if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
5057 c        if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
5058 C Condition for being inside the proper box
5059 c        if ((zj.gt.((0.5d0)*boxzsize)).or.
5060 c     &       (zj.lt.((-0.5d0)*boxzsize))) then
5061 c        go to 176
5062 c        endif
5063 CHERE IS THE CALCULATION WHICH MIRROR IMAGE IS THE CLOSEST ONE
5064       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
5065       xj_safe=xj
5066       yj_safe=yj
5067       zj_safe=zj
5068       subchap=0
5069       do xshift=-1,1
5070       do yshift=-1,1
5071       do zshift=-1,1
5072           xj=xj_safe+xshift*boxxsize
5073           yj=yj_safe+yshift*boxysize
5074           zj=zj_safe+zshift*boxzsize
5075           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
5076           if(dist_temp.lt.dist_init) then
5077             dist_init=dist_temp
5078             xj_temp=xj
5079             yj_temp=yj
5080             zj_temp=zj
5081             subchap=1
5082           endif
5083        enddo
5084        enddo
5085        enddo
5086        if (subchap.eq.1) then
5087           xj=xj_temp-xi
5088           yj=yj_temp-yi
5089           zj=zj_temp-zi
5090        else
5091           xj=xj_safe-xi
5092           yj=yj_safe-yi
5093           zj=zj_safe-zi
5094        endif
5095 c          print *,xj,yj,zj,'polozenie j'
5096           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
5097 c          print *,rrij
5098           sss=sscale(1.0d0/(dsqrt(rrij)))
5099 c          print *,r_cut,1.0d0/dsqrt(rrij),sss,'tu patrz'
5100 c          if (sss.eq.0) print *,'czasem jest OK'
5101           if (sss.le.0.0d0) cycle
5102           sssgrad=sscagrad(1.0d0/(dsqrt(rrij)))
5103           fac=rrij**expon2
5104           e1=fac*fac*aad(itypj,iteli)
5105           e2=fac*bad(itypj,iteli)
5106           if (iabs(j-i) .le. 2) then
5107             e1=scal14*e1
5108             e2=scal14*e2
5109             evdw2_14=evdw2_14+(e1+e2)*sss
5110           endif
5111           evdwij=e1+e2
5112           evdw2=evdw2+evdwij*sss
5113           if (energy_dec) write (iout,'(a6,2i5,0pf7.3,2i3,3e11.3)')
5114      &        'evdw2',i,j,evdwij
5115 c     &        ,iteli,itypj,fac,aad(itypj,iteli),bad(itypj,iteli)
5116 C
5117 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
5118 C
5119           fac=-(evdwij+e1)*rrij*sss
5120           fac=fac+(evdwij)*sssgrad*dsqrt(rrij)/expon
5121           ggg(1)=xj*fac
5122           ggg(2)=yj*fac
5123           ggg(3)=zj*fac
5124 cgrad          if (j.lt.i) then
5125 cd          write (iout,*) 'j<i'
5126 C Uncomment following three lines for SC-p interactions
5127 c           do k=1,3
5128 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
5129 c           enddo
5130 cgrad          else
5131 cd          write (iout,*) 'j>i'
5132 cgrad            do k=1,3
5133 cgrad              ggg(k)=-ggg(k)
5134 C Uncomment following line for SC-p interactions
5135 ccgrad             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
5136 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
5137 cgrad            enddo
5138 cgrad          endif
5139 cgrad          do k=1,3
5140 cgrad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
5141 cgrad          enddo
5142 cgrad          kstart=min0(i+1,j)
5143 cgrad          kend=max0(i-1,j-1)
5144 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
5145 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
5146 cgrad          do k=kstart,kend
5147 cgrad            do l=1,3
5148 cgrad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
5149 cgrad            enddo
5150 cgrad          enddo
5151           do k=1,3
5152             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
5153             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
5154           enddo
5155 c        endif !endif for sscale cutoff
5156         enddo ! j
5157
5158         enddo ! iint
5159       enddo ! i
5160 c      enddo !zshift
5161 c      enddo !yshift
5162 c      enddo !xshift
5163       do i=1,nct
5164         do j=1,3
5165           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
5166           gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
5167           gradx_scp(j,i)=expon*gradx_scp(j,i)
5168         enddo
5169       enddo
5170 C******************************************************************************
5171 C
5172 C                              N O T E !!!
5173 C
5174 C To save time the factor EXPON has been extracted from ALL components
5175 C of GVDWC and GRADX. Remember to multiply them by this factor before further
5176 C use!
5177 C
5178 C******************************************************************************
5179       return
5180       end
5181 C--------------------------------------------------------------------------
5182       subroutine edis(ehpb)
5183 C
5184 C Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors.
5185 C
5186       implicit real*8 (a-h,o-z)
5187       include 'DIMENSIONS'
5188       include 'COMMON.SBRIDGE'
5189       include 'COMMON.CHAIN'
5190       include 'COMMON.DERIV'
5191       include 'COMMON.VAR'
5192       include 'COMMON.INTERACT'
5193       include 'COMMON.IOUNITS'
5194       include 'COMMON.CONTROL'
5195       dimension ggg(3),ggg_peak(3,20)
5196       ehpb=0.0D0
5197       do i=1,3
5198        ggg(i)=0.0d0
5199       enddo
5200 C      write (iout,*) ,"link_end",link_end,constr_dist
5201 cd      write(iout,*)'edis: nhpb=',nhpb,' fbr=',fbr
5202 c      write(iout,*)'link_start=',link_start,' link_end=',link_end,
5203 c     &  " constr_dist",constr_dist," link_start_peak",link_start_peak,
5204 c     &  " link_end_peak",link_end_peak
5205       if (link_end.eq.0.and.link_end_peak.eq.0) return
5206       do i=link_start_peak,link_end_peak
5207         ehpb_peak=0.0d0
5208 c        print *,"i",i," link_end_peak",link_end_peak," ipeak",
5209 c     &   ipeak(1,i),ipeak(2,i)
5210         do ip=ipeak(1,i),ipeak(2,i)
5211           ii=ihpb_peak(ip)
5212           jj=jhpb_peak(ip)
5213           dd=dist(ii,jj)
5214           iip=ip-ipeak(1,i)+1
5215 C iii and jjj point to the residues for which the distance is assigned.
5216           if (ii.gt.nres) then
5217             iii=ii-nres
5218             jjj=jj-nres
5219           else
5220             iii=ii
5221             jjj=jj
5222           endif
5223           aux=rlornmr1(dd,dhpb_peak(ip),dhpb1_peak(ip),forcon_peak(ip))
5224           aux=dexp(-scal_peak*aux)
5225           ehpb_peak=ehpb_peak+aux
5226           fac=rlornmr1prim(dd,dhpb_peak(ip),dhpb1_peak(ip),
5227      &      forcon_peak(ip))*aux/dd
5228           do j=1,3
5229             ggg_peak(j,iip)=fac*(c(j,jj)-c(j,ii))
5230           enddo
5231           if (energy_dec) write (iout,'(a6,3i5,6f10.3,i5)')
5232      &      "edisL",i,ii,jj,dd,dhpb_peak(ip),dhpb1_peak(ip),
5233      &      forcon_peak(ip),fordepth_peak(ip),ehpb_peak
5234         enddo
5235 c        write (iout,*) "ehpb_peak",ehpb_peak," scal_peak",scal_peak
5236         ehpb=ehpb-fordepth_peak(ipeak(1,i))*dlog(ehpb_peak)/scal_peak
5237         do ip=ipeak(1,i),ipeak(2,i)
5238           iip=ip-ipeak(1,i)+1
5239           do j=1,3
5240             ggg(j)=ggg_peak(j,iip)/ehpb_peak
5241           enddo
5242           ii=ihpb_peak(ip)
5243           jj=jhpb_peak(ip)
5244 C iii and jjj point to the residues for which the distance is assigned.
5245           if (ii.gt.nres) then
5246             iii=ii-nres
5247             jjj=jj-nres
5248           else
5249             iii=ii
5250             jjj=jj
5251           endif
5252           if (iii.lt.ii) then
5253             do j=1,3
5254               ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
5255               ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
5256             enddo
5257           endif
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         enddo
5263       enddo
5264       do i=link_start,link_end
5265 C If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a
5266 C CA-CA distance used in regularization of structure.
5267         ii=ihpb(i)
5268         jj=jhpb(i)
5269 C iii and jjj point to the residues for which the distance is assigned.
5270         if (ii.gt.nres) then
5271           iii=ii-nres
5272           jjj=jj-nres
5273         else
5274           iii=ii
5275           jjj=jj
5276         endif
5277 c        write (iout,*) "i",i," ii",ii," iii",iii," jj",jj," jjj",jjj,
5278 c     &    dhpb(i),dhpb1(i),forcon(i)
5279 C 24/11/03 AL: SS bridges handled separately because of introducing a specific
5280 C    distance and angle dependent SS bond potential.
5281 C        if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and.
5282 C     & iabs(itype(jjj)).eq.1) then
5283 cmc        if (ii.gt.nres .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then
5284 C 18/07/06 MC: Use the convention that the first nss pairs are SS bonds
5285         if (.not.dyn_ss .and. i.le.nss) then
5286 C 15/02/13 CC dynamic SSbond - additional check
5287           if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and.
5288      &        iabs(itype(jjj)).eq.1) then
5289            call ssbond_ene(iii,jjj,eij)
5290            ehpb=ehpb+2*eij
5291          endif
5292 cd          write (iout,*) "eij",eij
5293 cd   &   ' waga=',waga,' fac=',fac
5294 !        else if (ii.gt.nres .and. jj.gt.nres) then
5295         else
5296 C Calculate the distance between the two points and its difference from the
5297 C target distance.
5298           dd=dist(ii,jj)
5299           if (irestr_type(i).eq.11) then
5300             ehpb=ehpb+fordepth(i)!**4.0d0
5301      &           *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i))
5302             fac=fordepth(i)!**4.0d0
5303      &           *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd
5304             if (energy_dec) write (iout,'(a6,2i5,6f10.3,i5)')
5305      &        "edisL",ii,jj,dd,dhpb(i),dhpb1(i),forcon(i),fordepth(i),
5306      &        ehpb,irestr_type(i)
5307           else if (irestr_type(i).eq.10) then
5308 c AL 6//19/2018 cross-link restraints
5309             xdis = 0.5d0*(dd/forcon(i))**2
5310             expdis = dexp(-xdis)
5311 c            aux=(dhpb(i)+dhpb1(i)*xdis)*expdis+fordepth(i)
5312             aux=(dhpb(i)+dhpb1(i)*xdis*xdis)*expdis+fordepth(i)
5313 c            write (iout,*)"HERE: xdis",xdis," expdis",expdis," aux",aux,
5314 c     &          " wboltzd",wboltzd
5315             ehpb=ehpb-wboltzd*xlscore(i)*dlog(aux)
5316 c            fac=-wboltzd*(dhpb1(i)*(1.0d0-xdis)-dhpb(i))
5317             fac=-wboltzd*xlscore(i)*(dhpb1(i)*(2.0d0-xdis)*xdis-dhpb(i))
5318      &           *expdis/(aux*forcon(i)**2)
5319             if (energy_dec) write(iout,'(a6,2i5,6f10.3,i5)')
5320      &        "edisX",ii,jj,dd,dhpb(i),dhpb1(i),forcon(i),fordepth(i),
5321      &        -wboltzd*xlscore(i)*dlog(aux),irestr_type(i)
5322           else if (irestr_type(i).eq.2) then
5323 c Quartic restraints
5324             ehpb=ehpb+forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
5325             if (energy_dec) write(iout,'(a6,2i5,5f10.3,i5)')
5326      &      "edisQ",ii,jj,dd,dhpb(i),dhpb1(i),forcon(i),
5327      &      forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i)),irestr_type(i)
5328             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
5329           else
5330 c Quadratic restraints
5331             rdis=dd-dhpb(i)
5332 C Get the force constant corresponding to this distance.
5333             waga=forcon(i)
5334 C Calculate the contribution to energy.
5335             ehpb=ehpb+0.5d0*waga*rdis*rdis
5336             if (energy_dec) write(iout,'(a6,2i5,5f10.3,i5)')
5337      &      "edisS",ii,jj,dd,dhpb(i),dhpb1(i),forcon(i),
5338      &       0.5d0*waga*rdis*rdis,irestr_type(i)
5339 C
5340 C Evaluate gradient.
5341 C
5342             fac=waga*rdis/dd
5343           endif
5344 c Calculate Cartesian gradient
5345           do j=1,3
5346             ggg(j)=fac*(c(j,jj)-c(j,ii))
5347           enddo
5348 cd      print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
5349 C If this is a SC-SC distance, we need to calculate the contributions to the
5350 C Cartesian gradient in the SC vectors (ghpbx).
5351           if (iii.lt.ii) then
5352             do j=1,3
5353               ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
5354               ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
5355             enddo
5356           endif
5357 cgrad        do j=iii,jjj-1
5358 cgrad          do k=1,3
5359 cgrad            ghpbc(k,j)=ghpbc(k,j)+ggg(k)
5360 cgrad          enddo
5361 cgrad        enddo
5362           do k=1,3
5363             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
5364             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
5365           enddo
5366         endif
5367       enddo
5368       return
5369       end
5370 C--------------------------------------------------------------------------
5371       subroutine ssbond_ene(i,j,eij)
5372 C
5373 C Calculate the distance and angle dependent SS-bond potential energy
5374 C using a free-energy function derived based on RHF/6-31G** ab initio
5375 C calculations of diethyl disulfide.
5376 C
5377 C A. Liwo and U. Kozlowska, 11/24/03
5378 C
5379       implicit real*8 (a-h,o-z)
5380       include 'DIMENSIONS'
5381       include 'COMMON.SBRIDGE'
5382       include 'COMMON.CHAIN'
5383       include 'COMMON.DERIV'
5384       include 'COMMON.LOCAL'
5385       include 'COMMON.INTERACT'
5386       include 'COMMON.VAR'
5387       include 'COMMON.IOUNITS'
5388       double precision erij(3),dcosom1(3),dcosom2(3),gg(3)
5389       itypi=iabs(itype(i))
5390       xi=c(1,nres+i)
5391       yi=c(2,nres+i)
5392       zi=c(3,nres+i)
5393       dxi=dc_norm(1,nres+i)
5394       dyi=dc_norm(2,nres+i)
5395       dzi=dc_norm(3,nres+i)
5396 c      dsci_inv=dsc_inv(itypi)
5397       dsci_inv=vbld_inv(nres+i)
5398       itypj=iabs(itype(j))
5399 c      dscj_inv=dsc_inv(itypj)
5400       dscj_inv=vbld_inv(nres+j)
5401       xj=c(1,nres+j)-xi
5402       yj=c(2,nres+j)-yi
5403       zj=c(3,nres+j)-zi
5404       dxj=dc_norm(1,nres+j)
5405       dyj=dc_norm(2,nres+j)
5406       dzj=dc_norm(3,nres+j)
5407       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
5408       rij=dsqrt(rrij)
5409       erij(1)=xj*rij
5410       erij(2)=yj*rij
5411       erij(3)=zj*rij
5412       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
5413       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
5414       om12=dxi*dxj+dyi*dyj+dzi*dzj
5415       do k=1,3
5416         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
5417         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
5418       enddo
5419       rij=1.0d0/rij
5420       deltad=rij-d0cm
5421       deltat1=1.0d0-om1
5422       deltat2=1.0d0+om2
5423       deltat12=om2-om1+2.0d0
5424       cosphi=om12-om1*om2
5425       eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2)
5426      &  +akct*deltad*deltat12
5427      &  +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi+ebr
5428 c      write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth,
5429 c     &  " akct",akct," deltad",deltad," deltat",deltat1,deltat2,
5430 c     &  " deltat12",deltat12," eij",eij
5431       ed=2*akcm*deltad+akct*deltat12
5432       pom1=akct*deltad
5433       pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
5434       eom1=-2*akth*deltat1-pom1-om2*pom2
5435       eom2= 2*akth*deltat2+pom1-om1*pom2
5436       eom12=pom2
5437       do k=1,3
5438         ggk=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
5439         ghpbx(k,i)=ghpbx(k,i)-ggk
5440      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
5441      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
5442         ghpbx(k,j)=ghpbx(k,j)+ggk
5443      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
5444      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
5445         ghpbc(k,i)=ghpbc(k,i)-ggk
5446         ghpbc(k,j)=ghpbc(k,j)+ggk
5447       enddo
5448 C
5449 C Calculate the components of the gradient in DC and X
5450 C
5451 cgrad      do k=i,j-1
5452 cgrad        do l=1,3
5453 cgrad          ghpbc(l,k)=ghpbc(l,k)+gg(l)
5454 cgrad        enddo
5455 cgrad      enddo
5456       return
5457       end
5458 C--------------------------------------------------------------------------
5459       subroutine ebond(estr)
5460 c
5461 c Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
5462 c
5463       implicit real*8 (a-h,o-z)
5464       include 'DIMENSIONS'
5465       include 'COMMON.LOCAL'
5466       include 'COMMON.GEO'
5467       include 'COMMON.INTERACT'
5468       include 'COMMON.DERIV'
5469       include 'COMMON.VAR'
5470       include 'COMMON.CHAIN'
5471       include 'COMMON.IOUNITS'
5472       include 'COMMON.NAMES'
5473       include 'COMMON.FFIELD'
5474       include 'COMMON.CONTROL'
5475       include 'COMMON.SETUP'
5476       double precision u(3),ud(3)
5477       estr=0.0d0
5478       estr1=0.0d0
5479       do i=ibondp_start,ibondp_end
5480         if (itype(i-1).eq.ntyp1 .and. itype(i).eq.ntyp1) cycle
5481 c          estr1=estr1+gnmr1(vbld(i),-1.0d0,distchainmax)
5482 c          do j=1,3
5483 c          gradb(j,i-1)=gnmr1prim(vbld(i),-1.0d0,distchainmax)
5484 c     &      *dc(j,i-1)/vbld(i)
5485 c          enddo
5486 c          if (energy_dec) write(iout,*)
5487 c     &       "estr1",i,gnmr1(vbld(i),-1.0d0,distchainmax)
5488 c        else
5489 C       Checking if it involves dummy (NH3+ or COO-) group
5490          if (itype(i-1).eq.ntyp1 .or. itype(i).eq.ntyp1) then
5491 C YES   vbldpDUM is the equlibrium length of spring for Dummy atom
5492         diff = vbld(i)-vbldpDUM
5493          else
5494 C NO    vbldp0 is the equlibrium lenght of spring for peptide group
5495         diff = vbld(i)-vbldp0
5496          endif
5497         if (energy_dec)    write (iout,'(a7,i5,4f7.3)')
5498      &     "estr bb",i,vbld(i),vbldp0,diff,AKP*diff*diff
5499         estr=estr+diff*diff
5500         do j=1,3
5501           gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)
5502         enddo
5503 c        write (iout,'(i5,3f10.5)') i,(gradb(j,i-1),j=1,3)
5504 c        endif
5505       enddo
5506
5507       estr=0.5d0*AKP*estr+estr1
5508 c
5509 c 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included
5510 c
5511       do i=ibond_start,ibond_end
5512         iti=iabs(itype(i))
5513         if (iti.ne.10 .and. iti.ne.ntyp1) then
5514           nbi=nbondterm(iti)
5515           if (nbi.eq.1) then
5516             diff=vbld(i+nres)-vbldsc0(1,iti)
5517             if (energy_dec)  write (iout,*)
5518      &      "estr sc",i,iti,vbld(i+nres),vbldsc0(1,iti),diff,
5519      &      AKSC(1,iti),AKSC(1,iti)*diff*diff
5520             estr=estr+0.5d0*AKSC(1,iti)*diff*diff
5521             do j=1,3
5522               gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
5523             enddo
5524           else
5525             do j=1,nbi
5526               diff=vbld(i+nres)-vbldsc0(j,iti)
5527               ud(j)=aksc(j,iti)*diff
5528               u(j)=abond0(j,iti)+0.5d0*ud(j)*diff
5529             enddo
5530             uprod=u(1)
5531             do j=2,nbi
5532               uprod=uprod*u(j)
5533             enddo
5534             usum=0.0d0
5535             usumsqder=0.0d0
5536             do j=1,nbi
5537               uprod1=1.0d0
5538               uprod2=1.0d0
5539               do k=1,nbi
5540                 if (k.ne.j) then
5541                   uprod1=uprod1*u(k)
5542                   uprod2=uprod2*u(k)*u(k)
5543                 endif
5544               enddo
5545               usum=usum+uprod1
5546               usumsqder=usumsqder+ud(j)*uprod2
5547             enddo
5548             estr=estr+uprod/usum
5549             do j=1,3
5550              gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
5551             enddo
5552           endif
5553         endif
5554       enddo
5555       return
5556       end
5557 #ifdef CRYST_THETA
5558 C--------------------------------------------------------------------------
5559       subroutine ebend(etheta)
5560 C
5561 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
5562 C angles gamma and its derivatives in consecutive thetas and gammas.
5563 C
5564       implicit real*8 (a-h,o-z)
5565       include 'DIMENSIONS'
5566       include 'COMMON.LOCAL'
5567       include 'COMMON.GEO'
5568       include 'COMMON.INTERACT'
5569       include 'COMMON.DERIV'
5570       include 'COMMON.VAR'
5571       include 'COMMON.CHAIN'
5572       include 'COMMON.IOUNITS'
5573       include 'COMMON.NAMES'
5574       include 'COMMON.FFIELD'
5575       include 'COMMON.CONTROL'
5576       common /calcthet/ term1,term2,termm,diffak,ratak,
5577      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
5578      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
5579       double precision y(2),z(2)
5580       delta=0.02d0*pi
5581 c      time11=dexp(-2*time)
5582 c      time12=1.0d0
5583       etheta=0.0D0
5584 c     write (*,'(a,i2)') 'EBEND ICG=',icg
5585       do i=ithet_start,ithet_end
5586         if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
5587      &  .or.itype(i).eq.ntyp1) cycle
5588 C Zero the energy function and its derivative at 0 or pi.
5589         call splinthet(theta(i),0.5d0*delta,ss,ssd)
5590         it=itype(i-1)
5591         ichir1=isign(1,itype(i-2))
5592         ichir2=isign(1,itype(i))
5593          if (itype(i-2).eq.10) ichir1=isign(1,itype(i-1))
5594          if (itype(i).eq.10) ichir2=isign(1,itype(i-1))
5595          if (itype(i-1).eq.10) then
5596           itype1=isign(10,itype(i-2))
5597           ichir11=isign(1,itype(i-2))
5598           ichir12=isign(1,itype(i-2))
5599           itype2=isign(10,itype(i))
5600           ichir21=isign(1,itype(i))
5601           ichir22=isign(1,itype(i))
5602          endif
5603
5604         if (i.gt.3 .and. itype(i-3).ne.ntyp1) then
5605 #ifdef OSF
5606           phii=phi(i)
5607           if (phii.ne.phii) phii=150.0
5608 #else
5609           phii=phi(i)
5610 #endif
5611           y(1)=dcos(phii)
5612           y(2)=dsin(phii)
5613         else
5614           y(1)=0.0D0
5615           y(2)=0.0D0
5616         endif
5617         if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
5618 #ifdef OSF
5619           phii1=phi(i+1)
5620           if (phii1.ne.phii1) phii1=150.0
5621           phii1=pinorm(phii1)
5622           z(1)=cos(phii1)
5623 #else
5624           phii1=phi(i+1)
5625 #endif
5626           z(1)=dcos(phii1)
5627           z(2)=dsin(phii1)
5628         else
5629           z(1)=0.0D0
5630           z(2)=0.0D0
5631         endif
5632 C Calculate the "mean" value of theta from the part of the distribution
5633 C dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2).
5634 C In following comments this theta will be referred to as t_c.
5635         thet_pred_mean=0.0d0
5636         do k=1,2
5637             athetk=athet(k,it,ichir1,ichir2)
5638             bthetk=bthet(k,it,ichir1,ichir2)
5639           if (it.eq.10) then
5640              athetk=athet(k,itype1,ichir11,ichir12)
5641              bthetk=bthet(k,itype2,ichir21,ichir22)
5642           endif
5643          thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k)
5644 c         write(iout,*) 'chuj tu', y(k),z(k)
5645         enddo
5646         dthett=thet_pred_mean*ssd
5647         thet_pred_mean=thet_pred_mean*ss+a0thet(it)
5648 C Derivatives of the "mean" values in gamma1 and gamma2.
5649         dthetg1=(-athet(1,it,ichir1,ichir2)*y(2)
5650      &+athet(2,it,ichir1,ichir2)*y(1))*ss
5651          dthetg2=(-bthet(1,it,ichir1,ichir2)*z(2)
5652      &          +bthet(2,it,ichir1,ichir2)*z(1))*ss
5653          if (it.eq.10) then
5654       dthetg1=(-athet(1,itype1,ichir11,ichir12)*y(2)
5655      &+athet(2,itype1,ichir11,ichir12)*y(1))*ss
5656         dthetg2=(-bthet(1,itype2,ichir21,ichir22)*z(2)
5657      &         +bthet(2,itype2,ichir21,ichir22)*z(1))*ss
5658          endif
5659         if (theta(i).gt.pi-delta) then
5660           call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,
5661      &         E_tc0)
5662           call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0)
5663           call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
5664           call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,
5665      &        E_theta)
5666           call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,
5667      &        E_tc)
5668         else if (theta(i).lt.delta) then
5669           call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0)
5670           call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
5671           call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,
5672      &        E_theta)
5673           call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0)
5674           call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,
5675      &        E_tc)
5676         else
5677           call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,
5678      &        E_theta,E_tc)
5679         endif
5680         etheta=etheta+ethetai
5681         if (energy_dec) write (iout,'(a6,i5,0pf7.3,f7.3,i5)')
5682      &      'ebend',i,ethetai,theta(i),itype(i)
5683         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1
5684         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2
5685         gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)+gloc(nphi+i-2,icg)
5686       enddo
5687
5688 C Ufff.... We've done all this!!!
5689       return
5690       end
5691 C---------------------------------------------------------------------------
5692       subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,
5693      &     E_tc)
5694       implicit real*8 (a-h,o-z)
5695       include 'DIMENSIONS'
5696       include 'COMMON.LOCAL'
5697       include 'COMMON.IOUNITS'
5698       common /calcthet/ term1,term2,termm,diffak,ratak,
5699      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
5700      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
5701 C Calculate the contributions to both Gaussian lobes.
5702 C 6/6/97 - Deform the Gaussians using the factor of 1/(1+time)
5703 C The "polynomial part" of the "standard deviation" of this part of
5704 C the distributioni.
5705 ccc        write (iout,*) thetai,thet_pred_mean
5706         sig=polthet(3,it)
5707         do j=2,0,-1
5708           sig=sig*thet_pred_mean+polthet(j,it)
5709         enddo
5710 C Derivative of the "interior part" of the "standard deviation of the"
5711 C gamma-dependent Gaussian lobe in t_c.
5712         sigtc=3*polthet(3,it)
5713         do j=2,1,-1
5714           sigtc=sigtc*thet_pred_mean+j*polthet(j,it)
5715         enddo
5716         sigtc=sig*sigtc
5717 C Set the parameters of both Gaussian lobes of the distribution.
5718 C "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc)
5719         fac=sig*sig+sigc0(it)
5720         sigcsq=fac+fac
5721         sigc=1.0D0/sigcsq
5722 C Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c
5723         sigsqtc=-4.0D0*sigcsq*sigtc
5724 c       print *,i,sig,sigtc,sigsqtc
5725 C Following variable (sigtc) is d[sigma(t_c)]/dt_c
5726         sigtc=-sigtc/(fac*fac)
5727 C Following variable is sigma(t_c)**(-2)
5728         sigcsq=sigcsq*sigcsq
5729         sig0i=sig0(it)
5730         sig0inv=1.0D0/sig0i**2
5731         delthec=thetai-thet_pred_mean
5732         delthe0=thetai-theta0i
5733         term1=-0.5D0*sigcsq*delthec*delthec
5734         term2=-0.5D0*sig0inv*delthe0*delthe0
5735 C        write (iout,*)'term1',term1,term2,sigcsq,delthec,sig0inv,delthe0
5736 C Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and
5737 C NaNs in taking the logarithm. We extract the largest exponent which is added
5738 C to the energy (this being the log of the distribution) at the end of energy
5739 C term evaluation for this virtual-bond angle.
5740         if (term1.gt.term2) then
5741           termm=term1
5742           term2=dexp(term2-termm)
5743           term1=1.0d0
5744         else
5745           termm=term2
5746           term1=dexp(term1-termm)
5747           term2=1.0d0
5748         endif
5749 C The ratio between the gamma-independent and gamma-dependent lobes of
5750 C the distribution is a Gaussian function of thet_pred_mean too.
5751         diffak=gthet(2,it)-thet_pred_mean
5752         ratak=diffak/gthet(3,it)**2
5753         ak=dexp(gthet(1,it)-0.5D0*diffak*ratak)
5754 C Let's differentiate it in thet_pred_mean NOW.
5755         aktc=ak*ratak
5756 C Now put together the distribution terms to make complete distribution.
5757         termexp=term1+ak*term2
5758         termpre=sigc+ak*sig0i
5759 C Contribution of the bending energy from this theta is just the -log of
5760 C the sum of the contributions from the two lobes and the pre-exponential
5761 C factor. Simple enough, isn't it?
5762         ethetai=(-dlog(termexp)-termm+dlog(termpre))
5763 C       write (iout,*) 'termexp',termexp,termm,termpre,i
5764 C NOW the derivatives!!!
5765 C 6/6/97 Take into account the deformation.
5766         E_theta=(delthec*sigcsq*term1
5767      &       +ak*delthe0*sig0inv*term2)/termexp
5768         E_tc=((sigtc+aktc*sig0i)/termpre
5769      &      -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+
5770      &       aktc*term2)/termexp)
5771       return
5772       end
5773 c-----------------------------------------------------------------------------
5774       subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)
5775       implicit real*8 (a-h,o-z)
5776       include 'DIMENSIONS'
5777       include 'COMMON.LOCAL'
5778       include 'COMMON.IOUNITS'
5779       common /calcthet/ term1,term2,termm,diffak,ratak,
5780      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
5781      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
5782       delthec=thetai-thet_pred_mean
5783       delthe0=thetai-theta0i
5784 C "Thank you" to MAPLE (probably spared one day of hand-differentiation).
5785       t3 = thetai-thet_pred_mean
5786       t6 = t3**2
5787       t9 = term1
5788       t12 = t3*sigcsq
5789       t14 = t12+t6*sigsqtc
5790       t16 = 1.0d0
5791       t21 = thetai-theta0i
5792       t23 = t21**2
5793       t26 = term2
5794       t27 = t21*t26
5795       t32 = termexp
5796       t40 = t32**2
5797       E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9
5798      & -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40
5799      & *(-t12*t9-ak*sig0inv*t27)
5800       return
5801       end
5802 #else
5803 C--------------------------------------------------------------------------
5804       subroutine ebend(etheta)
5805 C
5806 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
5807 C angles gamma and its derivatives in consecutive thetas and gammas.
5808 C ab initio-derived potentials from
5809 c Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203
5810 C
5811       implicit real*8 (a-h,o-z)
5812       include 'DIMENSIONS'
5813       include 'COMMON.LOCAL'
5814       include 'COMMON.GEO'
5815       include 'COMMON.INTERACT'
5816       include 'COMMON.DERIV'
5817       include 'COMMON.VAR'
5818       include 'COMMON.CHAIN'
5819       include 'COMMON.IOUNITS'
5820       include 'COMMON.NAMES'
5821       include 'COMMON.FFIELD'
5822       include 'COMMON.CONTROL'
5823       double precision coskt(mmaxtheterm),sinkt(mmaxtheterm),
5824      & cosph1(maxsingle),sinph1(maxsingle),cosph2(maxsingle),
5825      & sinph2(maxsingle),cosph1ph2(maxdouble,maxdouble),
5826      & sinph1ph2(maxdouble,maxdouble)
5827       logical lprn /.false./, lprn1 /.false./
5828       etheta=0.0D0
5829       do i=ithet_start,ithet_end
5830 c        if (i.eq.2) cycle
5831 c        print *,i,itype(i-1),itype(i),itype(i-2)
5832         if ((itype(i-1).eq.ntyp1).or.(itype(i-2).eq.ntyp1)
5833      &  .or.(itype(i).eq.ntyp1)) cycle
5834 C In current verion the ALL DUMMY ATOM POTENTIALS ARE OFF
5835
5836         if (iabs(itype(i+1)).eq.20) iblock=2
5837         if (iabs(itype(i+1)).ne.20) iblock=1
5838         dethetai=0.0d0
5839         dephii=0.0d0
5840         dephii1=0.0d0
5841         theti2=0.5d0*theta(i)
5842         ityp2=ithetyp((itype(i-1)))
5843         do k=1,nntheterm
5844           coskt(k)=dcos(k*theti2)
5845           sinkt(k)=dsin(k*theti2)
5846         enddo
5847         if (i.gt.3 .and. itype(max0(i-3,1)).ne.ntyp1) then
5848 #ifdef OSF
5849           phii=phi(i)
5850           if (phii.ne.phii) phii=150.0
5851 #else
5852           phii=phi(i)
5853 #endif
5854           ityp1=ithetyp((itype(i-2)))
5855 C propagation of chirality for glycine type
5856           do k=1,nsingle
5857             cosph1(k)=dcos(k*phii)
5858             sinph1(k)=dsin(k*phii)
5859           enddo
5860         else
5861           phii=0.0d0
5862           ityp1=ithetyp(itype(i-2))
5863           do k=1,nsingle
5864             cosph1(k)=0.0d0
5865             sinph1(k)=0.0d0
5866           enddo
5867         endif
5868         if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
5869 #ifdef OSF
5870           phii1=phi(i+1)
5871           if (phii1.ne.phii1) phii1=150.0
5872           phii1=pinorm(phii1)
5873 #else
5874           phii1=phi(i+1)
5875 #endif
5876           ityp3=ithetyp((itype(i)))
5877           do k=1,nsingle
5878             cosph2(k)=dcos(k*phii1)
5879             sinph2(k)=dsin(k*phii1)
5880           enddo
5881         else
5882           phii1=0.0d0
5883           ityp3=ithetyp(itype(i))
5884           do k=1,nsingle
5885             cosph2(k)=0.0d0
5886             sinph2(k)=0.0d0
5887           enddo
5888         endif
5889         ethetai=aa0thet(ityp1,ityp2,ityp3,iblock)
5890         do k=1,ndouble
5891           do l=1,k-1
5892             ccl=cosph1(l)*cosph2(k-l)
5893             ssl=sinph1(l)*sinph2(k-l)
5894             scl=sinph1(l)*cosph2(k-l)
5895             csl=cosph1(l)*sinph2(k-l)
5896             cosph1ph2(l,k)=ccl-ssl
5897             cosph1ph2(k,l)=ccl+ssl
5898             sinph1ph2(l,k)=scl+csl
5899             sinph1ph2(k,l)=scl-csl
5900           enddo
5901         enddo
5902         if (lprn) then
5903         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,
5904      &    " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
5905         write (iout,*) "coskt and sinkt"
5906         do k=1,nntheterm
5907           write (iout,*) k,coskt(k),sinkt(k)
5908         enddo
5909         endif
5910         do k=1,ntheterm
5911           ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3,iblock)*sinkt(k)
5912           dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3,iblock)
5913      &      *coskt(k)
5914           if (lprn)
5915      &    write (iout,*) "k",k,"
5916      &     aathet",aathet(k,ityp1,ityp2,ityp3,iblock),
5917      &     " ethetai",ethetai
5918         enddo
5919         if (lprn) then
5920         write (iout,*) "cosph and sinph"
5921         do k=1,nsingle
5922           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
5923         enddo
5924         write (iout,*) "cosph1ph2 and sinph2ph2"
5925         do k=2,ndouble
5926           do l=1,k-1
5927             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),
5928      &         sinph1ph2(l,k),sinph1ph2(k,l)
5929           enddo
5930         enddo
5931         write(iout,*) "ethetai",ethetai
5932         endif
5933         do m=1,ntheterm2
5934           do k=1,nsingle
5935             aux=bbthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)
5936      &         +ccthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k)
5937      &         +ddthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)
5938      &         +eethet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k)
5939             ethetai=ethetai+sinkt(m)*aux
5940             dethetai=dethetai+0.5d0*m*aux*coskt(m)
5941             dephii=dephii+k*sinkt(m)*(
5942      &          ccthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)-
5943      &          bbthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k))
5944             dephii1=dephii1+k*sinkt(m)*(
5945      &          eethet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)-
5946      &          ddthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k))
5947             if (lprn)
5948      &      write (iout,*) "m",m," k",k," bbthet",
5949      &         bbthet(k,m,ityp1,ityp2,ityp3,iblock)," ccthet",
5950      &         ccthet(k,m,ityp1,ityp2,ityp3,iblock)," ddthet",
5951      &         ddthet(k,m,ityp1,ityp2,ityp3,iblock)," eethet",
5952      &         eethet(k,m,ityp1,ityp2,ityp3,iblock)," ethetai",ethetai
5953           enddo
5954         enddo
5955         if (lprn)
5956      &  write(iout,*) "ethetai",ethetai
5957         do m=1,ntheterm3
5958           do k=2,ndouble
5959             do l=1,k-1
5960               aux=ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
5961      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l)+
5962      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
5963      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)
5964               ethetai=ethetai+sinkt(m)*aux
5965               dethetai=dethetai+0.5d0*m*coskt(m)*aux
5966               dephii=dephii+l*sinkt(m)*(
5967      &           -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)-
5968      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
5969      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
5970      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
5971               dephii1=dephii1+(k-l)*sinkt(m)*(
5972      &           -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
5973      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
5974      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)-
5975      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
5976               if (lprn) then
5977               write (iout,*) "m",m," k",k," l",l," ffthet",
5978      &            ffthet(l,k,m,ityp1,ityp2,ityp3,iblock),
5979      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)," ggthet",
5980      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock),
5981      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock),
5982      &            " ethetai",ethetai
5983               write (iout,*) cosph1ph2(l,k)*sinkt(m),
5984      &            cosph1ph2(k,l)*sinkt(m),
5985      &            sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
5986               endif
5987             enddo
5988           enddo
5989         enddo
5990 10      continue
5991 c        lprn1=.true.
5992         if (lprn1)
5993      &    write (iout,'(i2,3f8.1,9h ethetai ,f10.5)')
5994      &   i,theta(i)*rad2deg,phii*rad2deg,
5995      &   phii1*rad2deg,ethetai
5996 c        lprn1=.false.
5997         etheta=etheta+ethetai
5998         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
5999      &      'ebend',i,ethetai
6000         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
6001         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
6002         gloc(nphi+i-2,icg)=wang*dethetai+gloc(nphi+i-2,icg)
6003       enddo
6004
6005       return
6006       end
6007 #endif
6008 #ifdef CRYST_SC
6009 c-----------------------------------------------------------------------------
6010       subroutine esc(escloc)
6011 C Calculate the local energy of a side chain and its derivatives in the
6012 C corresponding virtual-bond valence angles THETA and the spherical angles
6013 C ALPHA and OMEGA.
6014       implicit real*8 (a-h,o-z)
6015       include 'DIMENSIONS'
6016       include 'COMMON.GEO'
6017       include 'COMMON.LOCAL'
6018       include 'COMMON.VAR'
6019       include 'COMMON.INTERACT'
6020       include 'COMMON.DERIV'
6021       include 'COMMON.CHAIN'
6022       include 'COMMON.IOUNITS'
6023       include 'COMMON.NAMES'
6024       include 'COMMON.FFIELD'
6025       include 'COMMON.CONTROL'
6026       double precision x(3),dersc(3),xemp(3),dersc0(3),dersc1(3),
6027      &     ddersc0(3),ddummy(3),xtemp(3),temp(3)
6028       common /sccalc/ time11,time12,time112,theti,it,nlobit
6029       delta=0.02d0*pi
6030       escloc=0.0D0
6031 c     write (iout,'(a)') 'ESC'
6032       do i=loc_start,loc_end
6033         it=itype(i)
6034         if (it.eq.ntyp1) cycle
6035         if (it.eq.10) goto 1
6036         nlobit=nlob(iabs(it))
6037 c       print *,'i=',i,' it=',it,' nlobit=',nlobit
6038 c       write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
6039         theti=theta(i+1)-pipol
6040         x(1)=dtan(theti)
6041         x(2)=alph(i)
6042         x(3)=omeg(i)
6043
6044         if (x(2).gt.pi-delta) then
6045           xtemp(1)=x(1)
6046           xtemp(2)=pi-delta
6047           xtemp(3)=x(3)
6048           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
6049           xtemp(2)=pi
6050           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
6051           call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),
6052      &        escloci,dersc(2))
6053           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
6054      &        ddersc0(1),dersc(1))
6055           call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),
6056      &        ddersc0(3),dersc(3))
6057           xtemp(2)=pi-delta
6058           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
6059           xtemp(2)=pi
6060           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
6061           call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,
6062      &            dersc0(2),esclocbi,dersc02)
6063           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
6064      &            dersc12,dersc01)
6065           call splinthet(x(2),0.5d0*delta,ss,ssd)
6066           dersc0(1)=dersc01
6067           dersc0(2)=dersc02
6068           dersc0(3)=0.0d0
6069           do k=1,3
6070             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
6071           enddo
6072           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
6073 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
6074 c    &             esclocbi,ss,ssd
6075           escloci=ss*escloci+(1.0d0-ss)*esclocbi
6076 c         escloci=esclocbi
6077 c         write (iout,*) escloci
6078         else if (x(2).lt.delta) then
6079           xtemp(1)=x(1)
6080           xtemp(2)=delta
6081           xtemp(3)=x(3)
6082           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
6083           xtemp(2)=0.0d0
6084           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
6085           call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),
6086      &        escloci,dersc(2))
6087           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
6088      &        ddersc0(1),dersc(1))
6089           call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),
6090      &        ddersc0(3),dersc(3))
6091           xtemp(2)=delta
6092           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
6093           xtemp(2)=0.0d0
6094           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
6095           call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,
6096      &            dersc0(2),esclocbi,dersc02)
6097           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
6098      &            dersc12,dersc01)
6099           dersc0(1)=dersc01
6100           dersc0(2)=dersc02
6101           dersc0(3)=0.0d0
6102           call splinthet(x(2),0.5d0*delta,ss,ssd)
6103           do k=1,3
6104             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
6105           enddo
6106           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
6107 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
6108 c    &             esclocbi,ss,ssd
6109           escloci=ss*escloci+(1.0d0-ss)*esclocbi
6110 c         write (iout,*) escloci
6111         else
6112           call enesc(x,escloci,dersc,ddummy,.false.)
6113         endif
6114
6115         escloc=escloc+escloci
6116         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
6117      &     'escloc',i,escloci
6118 c       write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
6119
6120         gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
6121      &   wscloc*dersc(1)
6122         gloc(ialph(i,1),icg)=wscloc*dersc(2)
6123         gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
6124     1   continue
6125       enddo
6126       return
6127       end
6128 C---------------------------------------------------------------------------
6129       subroutine enesc(x,escloci,dersc,ddersc,mixed)
6130       implicit real*8 (a-h,o-z)
6131       include 'DIMENSIONS'
6132       include 'COMMON.GEO'
6133       include 'COMMON.LOCAL'
6134       include 'COMMON.IOUNITS'
6135       common /sccalc/ time11,time12,time112,theti,it,nlobit
6136       double precision x(3),z(3),Ax(3,maxlob,-1:1),dersc(3),ddersc(3)
6137       double precision contr(maxlob,-1:1)
6138       logical mixed
6139 c       write (iout,*) 'it=',it,' nlobit=',nlobit
6140         escloc_i=0.0D0
6141         do j=1,3
6142           dersc(j)=0.0D0
6143           if (mixed) ddersc(j)=0.0d0
6144         enddo
6145         x3=x(3)
6146
6147 C Because of periodicity of the dependence of the SC energy in omega we have
6148 C to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
6149 C To avoid underflows, first compute & store the exponents.
6150
6151         do iii=-1,1
6152
6153           x(3)=x3+iii*dwapi
6154
6155           do j=1,nlobit
6156             do k=1,3
6157               z(k)=x(k)-censc(k,j,it)
6158             enddo
6159             do k=1,3
6160               Axk=0.0D0
6161               do l=1,3
6162                 Axk=Axk+gaussc(l,k,j,it)*z(l)
6163               enddo
6164               Ax(k,j,iii)=Axk
6165             enddo
6166             expfac=0.0D0
6167             do k=1,3
6168               expfac=expfac+Ax(k,j,iii)*z(k)
6169             enddo
6170             contr(j,iii)=expfac
6171           enddo ! j
6172
6173         enddo ! iii
6174
6175         x(3)=x3
6176 C As in the case of ebend, we want to avoid underflows in exponentiation and
6177 C subsequent NaNs and INFs in energy calculation.
6178 C Find the largest exponent
6179         emin=contr(1,-1)
6180         do iii=-1,1
6181           do j=1,nlobit
6182             if (emin.gt.contr(j,iii)) emin=contr(j,iii)
6183           enddo
6184         enddo
6185         emin=0.5D0*emin
6186 cd      print *,'it=',it,' emin=',emin
6187
6188 C Compute the contribution to SC energy and derivatives
6189         do iii=-1,1
6190
6191           do j=1,nlobit
6192 #ifdef OSF
6193             adexp=bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin
6194             if(adexp.ne.adexp) adexp=1.0
6195             expfac=dexp(adexp)
6196 #else
6197             expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin)
6198 #endif
6199 cd          print *,'j=',j,' expfac=',expfac
6200             escloc_i=escloc_i+expfac
6201             do k=1,3
6202               dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
6203             enddo
6204             if (mixed) then
6205               do k=1,3,2
6206                 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii)
6207      &            +gaussc(k,2,j,it))*expfac
6208               enddo
6209             endif
6210           enddo
6211
6212         enddo ! iii
6213
6214         dersc(1)=dersc(1)/cos(theti)**2
6215         ddersc(1)=ddersc(1)/cos(theti)**2
6216         ddersc(3)=ddersc(3)
6217
6218         escloci=-(dlog(escloc_i)-emin)
6219         do j=1,3
6220           dersc(j)=dersc(j)/escloc_i
6221         enddo
6222         if (mixed) then
6223           do j=1,3,2
6224             ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
6225           enddo
6226         endif
6227       return
6228       end
6229 C------------------------------------------------------------------------------
6230       subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
6231       implicit real*8 (a-h,o-z)
6232       include 'DIMENSIONS'
6233       include 'COMMON.GEO'
6234       include 'COMMON.LOCAL'
6235       include 'COMMON.IOUNITS'
6236       common /sccalc/ time11,time12,time112,theti,it,nlobit
6237       double precision x(3),z(3),Ax(3,maxlob),dersc(3)
6238       double precision contr(maxlob)
6239       logical mixed
6240
6241       escloc_i=0.0D0
6242
6243       do j=1,3
6244         dersc(j)=0.0D0
6245       enddo
6246
6247       do j=1,nlobit
6248         do k=1,2
6249           z(k)=x(k)-censc(k,j,it)
6250         enddo
6251         z(3)=dwapi
6252         do k=1,3
6253           Axk=0.0D0
6254           do l=1,3
6255             Axk=Axk+gaussc(l,k,j,it)*z(l)
6256           enddo
6257           Ax(k,j)=Axk
6258         enddo
6259         expfac=0.0D0
6260         do k=1,3
6261           expfac=expfac+Ax(k,j)*z(k)
6262         enddo
6263         contr(j)=expfac
6264       enddo ! j
6265
6266 C As in the case of ebend, we want to avoid underflows in exponentiation and
6267 C subsequent NaNs and INFs in energy calculation.
6268 C Find the largest exponent
6269       emin=contr(1)
6270       do j=1,nlobit
6271         if (emin.gt.contr(j)) emin=contr(j)
6272       enddo
6273       emin=0.5D0*emin
6274
6275 C Compute the contribution to SC energy and derivatives
6276
6277       dersc12=0.0d0
6278       do j=1,nlobit
6279         expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j)+emin)
6280         escloc_i=escloc_i+expfac
6281         do k=1,2
6282           dersc(k)=dersc(k)+Ax(k,j)*expfac
6283         enddo
6284         if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j)
6285      &            +gaussc(1,2,j,it))*expfac
6286         dersc(3)=0.0d0
6287       enddo
6288
6289       dersc(1)=dersc(1)/cos(theti)**2
6290       dersc12=dersc12/cos(theti)**2
6291       escloci=-(dlog(escloc_i)-emin)
6292       do j=1,2
6293         dersc(j)=dersc(j)/escloc_i
6294       enddo
6295       if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
6296       return
6297       end
6298 #else
6299 c----------------------------------------------------------------------------------
6300       subroutine esc(escloc)
6301 C Calculate the local energy of a side chain and its derivatives in the
6302 C corresponding virtual-bond valence angles THETA and the spherical angles
6303 C ALPHA and OMEGA derived from AM1 all-atom calculations.
6304 C added by Urszula Kozlowska. 07/11/2007
6305 C
6306       implicit real*8 (a-h,o-z)
6307       include 'DIMENSIONS'
6308       include 'COMMON.GEO'
6309       include 'COMMON.LOCAL'
6310       include 'COMMON.VAR'
6311       include 'COMMON.SCROT'
6312       include 'COMMON.INTERACT'
6313       include 'COMMON.DERIV'
6314       include 'COMMON.CHAIN'
6315       include 'COMMON.IOUNITS'
6316       include 'COMMON.NAMES'
6317       include 'COMMON.FFIELD'
6318       include 'COMMON.CONTROL'
6319       include 'COMMON.VECTORS'
6320       double precision x_prime(3),y_prime(3),z_prime(3)
6321      &    , sumene,dsc_i,dp2_i,x(65),
6322      &     xx,yy,zz,sumene1,sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6,
6323      &    de_dxx,de_dyy,de_dzz,de_dt
6324       double precision s1_t,s1_6_t,s2_t,s2_6_t
6325       double precision
6326      & dXX_Ci1(3),dYY_Ci1(3),dZZ_Ci1(3),dXX_Ci(3),
6327      & dYY_Ci(3),dZZ_Ci(3),dXX_XYZ(3),dYY_XYZ(3),dZZ_XYZ(3),
6328      & dt_dCi(3),dt_dCi1(3)
6329       common /sccalc/ time11,time12,time112,theti,it,nlobit
6330       delta=0.02d0*pi
6331       escloc=0.0D0
6332       do i=loc_start,loc_end
6333         if (itype(i).eq.ntyp1) cycle
6334         costtab(i+1) =dcos(theta(i+1))
6335         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
6336         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
6337         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
6338         cosfac2=0.5d0/(1.0d0+costtab(i+1))
6339         cosfac=dsqrt(cosfac2)
6340         sinfac2=0.5d0/(1.0d0-costtab(i+1))
6341         sinfac=dsqrt(sinfac2)
6342         it=iabs(itype(i))
6343         if (it.eq.10) goto 1
6344 c
6345 C  Compute the axes of tghe local cartesian coordinates system; store in
6346 c   x_prime, y_prime and z_prime
6347 c
6348         do j=1,3
6349           x_prime(j) = 0.00
6350           y_prime(j) = 0.00
6351           z_prime(j) = 0.00
6352         enddo
6353 C        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
6354 C     &   dc_norm(3,i+nres)
6355         do j = 1,3
6356           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
6357           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
6358         enddo
6359         do j = 1,3
6360           z_prime(j) = -uz(j,i-1)*dsign(1.0d0,dfloat(itype(i)))
6361         enddo
6362 c       write (2,*) "i",i
6363 c       write (2,*) "x_prime",(x_prime(j),j=1,3)
6364 c       write (2,*) "y_prime",(y_prime(j),j=1,3)
6365 c       write (2,*) "z_prime",(z_prime(j),j=1,3)
6366 c       write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
6367 c      & " xy",scalar(x_prime(1),y_prime(1)),
6368 c      & " xz",scalar(x_prime(1),z_prime(1)),
6369 c      & " yy",scalar(y_prime(1),y_prime(1)),
6370 c      & " yz",scalar(y_prime(1),z_prime(1)),
6371 c      & " zz",scalar(z_prime(1),z_prime(1))
6372 c
6373 C Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
6374 C to local coordinate system. Store in xx, yy, zz.
6375 c
6376         xx=0.0d0
6377         yy=0.0d0
6378         zz=0.0d0
6379         do j = 1,3
6380           xx = xx + x_prime(j)*dc_norm(j,i+nres)
6381           yy = yy + y_prime(j)*dc_norm(j,i+nres)
6382           zz = zz + z_prime(j)*dc_norm(j,i+nres)
6383         enddo
6384
6385         xxtab(i)=xx
6386         yytab(i)=yy
6387         zztab(i)=zz
6388 C
6389 C Compute the energy of the ith side cbain
6390 C
6391 c        write (2,*) "xx",xx," yy",yy," zz",zz
6392         it=iabs(itype(i))
6393         do j = 1,65
6394           x(j) = sc_parmin(j,it)
6395         enddo
6396 #ifdef CHECK_COORD
6397 Cc diagnostics - remove later
6398         xx1 = dcos(alph(2))
6399         yy1 = dsin(alph(2))*dcos(omeg(2))
6400         zz1 = -dsign(1.0,dfloat(itype(i)))*dsin(alph(2))*dsin(omeg(2))
6401         write(2,'(3f8.1,3f9.3,1x,3f9.3)')
6402      &    alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,
6403      &    xx1,yy1,zz1
6404 C,"  --- ", xx_w,yy_w,zz_w
6405 c end diagnostics
6406 #endif
6407         sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
6408      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
6409      &   + x(10)*yy*zz
6410         sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
6411      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
6412      & + x(20)*yy*zz
6413         sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
6414      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
6415      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
6416      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
6417      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
6418      &  +x(40)*xx*yy*zz
6419         sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
6420      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
6421      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
6422      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
6423      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
6424      &  +x(60)*xx*yy*zz
6425         dsc_i   = 0.743d0+x(61)
6426         dp2_i   = 1.9d0+x(62)
6427         dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
6428      &          *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
6429         dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
6430      &          *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
6431         s1=(1+x(63))/(0.1d0 + dscp1)
6432         s1_6=(1+x(64))/(0.1d0 + dscp1**6)
6433         s2=(1+x(65))/(0.1d0 + dscp2)
6434         s2_6=(1+x(65))/(0.1d0 + dscp2**6)
6435         sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6)
6436      & + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
6437 c        write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
6438 c     &   sumene4,
6439 c     &   dscp1,dscp2,sumene
6440 c        sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6441         escloc = escloc + sumene
6442         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
6443      &     'escloc',i,sumene
6444 c        write (2,*) "i",i," escloc",sumene,escloc,it,itype(i)
6445 c     & ,zz,xx,yy
6446 c#define DEBUG
6447 #ifdef DEBUG
6448 C
6449 C This section to check the numerical derivatives of the energy of ith side
6450 C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
6451 C #define DEBUG in the code to turn it on.
6452 C
6453         write (2,*) "sumene               =",sumene
6454         aincr=1.0d-7
6455         xxsave=xx
6456         xx=xx+aincr
6457         write (2,*) xx,yy,zz
6458         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6459         de_dxx_num=(sumenep-sumene)/aincr
6460         xx=xxsave
6461         write (2,*) "xx+ sumene from enesc=",sumenep
6462         yysave=yy
6463         yy=yy+aincr
6464         write (2,*) xx,yy,zz
6465         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6466         de_dyy_num=(sumenep-sumene)/aincr
6467         yy=yysave
6468         write (2,*) "yy+ sumene from enesc=",sumenep
6469         zzsave=zz
6470         zz=zz+aincr
6471         write (2,*) xx,yy,zz
6472         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6473         de_dzz_num=(sumenep-sumene)/aincr
6474         zz=zzsave
6475         write (2,*) "zz+ sumene from enesc=",sumenep
6476         costsave=cost2tab(i+1)
6477         sintsave=sint2tab(i+1)
6478         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
6479         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
6480         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6481         de_dt_num=(sumenep-sumene)/aincr
6482         write (2,*) " t+ sumene from enesc=",sumenep
6483         cost2tab(i+1)=costsave
6484         sint2tab(i+1)=sintsave
6485 C End of diagnostics section.
6486 #endif
6487 C
6488 C Compute the gradient of esc
6489 C
6490 c        zz=zz*dsign(1.0,dfloat(itype(i)))
6491         pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
6492         pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
6493         pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
6494         pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
6495         pom_dx=dsc_i*dp2_i*cost2tab(i+1)
6496         pom_dy=dsc_i*dp2_i*sint2tab(i+1)
6497         pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
6498         pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
6499         pom1=(sumene3*sint2tab(i+1)+sumene1)
6500      &     *(pom_s1/dscp1+pom_s16*dscp1**4)
6501         pom2=(sumene4*cost2tab(i+1)+sumene2)
6502      &     *(pom_s2/dscp2+pom_s26*dscp2**4)
6503         sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
6504         sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2
6505      &  +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2)
6506      &  +x(40)*yy*zz
6507         sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
6508         sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2
6509      &  +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2)
6510      &  +x(60)*yy*zz
6511         de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6)
6512      &        +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6)
6513      &        +(pom1+pom2)*pom_dx
6514 #ifdef DEBUG
6515         write(2,*), "de_dxx = ", de_dxx,de_dxx_num,itype(i)
6516 #endif
6517 C
6518         sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
6519         sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2
6520      &  +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2)
6521      &  +x(40)*xx*zz
6522         sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
6523         sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz
6524      &  +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz
6525      &  +x(59)*zz**2 +x(60)*xx*zz
6526         de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6)
6527      &        +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6)
6528      &        +(pom1-pom2)*pom_dy
6529 #ifdef DEBUG
6530         write(2,*), "de_dyy = ", de_dyy,de_dyy_num,itype(i)
6531 #endif
6532 C
6533         de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy
6534      &  +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx
6535      &  +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6)
6536      &  +(x(4) + 2*x(7)*zz+  x(8)*xx + x(10)*yy)*(s1+s1_6)
6537      &  +(x(44)+2*x(47)*zz +x(48)*xx   +x(50)*yy  +3*x(53)*zz**2
6538      &  +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy
6539      &  +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6)
6540      &  + ( x(14) + 2*x(17)*zz+  x(18)*xx + x(20)*yy)*(s2+s2_6)
6541 #ifdef DEBUG
6542         write(2,*), "de_dzz = ", de_dzz,de_dzz_num,itype(i)
6543 #endif
6544 C
6545         de_dt =  0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6)
6546      &  -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6)
6547      &  +pom1*pom_dt1+pom2*pom_dt2
6548 #ifdef DEBUG
6549         write(2,*), "de_dt = ", de_dt,de_dt_num,itype(i)
6550 #endif
6551 c#undef DEBUG
6552 c
6553 C
6554        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
6555        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
6556        cosfac2xx=cosfac2*xx
6557        sinfac2yy=sinfac2*yy
6558        do k = 1,3
6559          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))*
6560      &      vbld_inv(i+1)
6561          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))*
6562      &      vbld_inv(i)
6563          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
6564          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
6565 c         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
6566 c     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
6567 c         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
6568 c     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
6569          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
6570          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
6571          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
6572          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
6573          dZZ_Ci1(k)=0.0d0
6574          dZZ_Ci(k)=0.0d0
6575          do j=1,3
6576            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)
6577      &     *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
6578            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)
6579      &     *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
6580          enddo
6581
6582          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
6583          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
6584          dZZ_XYZ(k)=vbld_inv(i+nres)*
6585      &   (z_prime(k)-zz*dC_norm(k,i+nres))
6586 c
6587          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
6588          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
6589        enddo
6590
6591        do k=1,3
6592          dXX_Ctab(k,i)=dXX_Ci(k)
6593          dXX_C1tab(k,i)=dXX_Ci1(k)
6594          dYY_Ctab(k,i)=dYY_Ci(k)
6595          dYY_C1tab(k,i)=dYY_Ci1(k)
6596          dZZ_Ctab(k,i)=dZZ_Ci(k)
6597          dZZ_C1tab(k,i)=dZZ_Ci1(k)
6598          dXX_XYZtab(k,i)=dXX_XYZ(k)
6599          dYY_XYZtab(k,i)=dYY_XYZ(k)
6600          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
6601        enddo
6602
6603        do k = 1,3
6604 c         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
6605 c     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
6606 c         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
6607 c     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
6608 c         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
6609 c     &    dt_dci(k)
6610 c         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
6611 c     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
6612          gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k)
6613      &    +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
6614          gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k)
6615      &    +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
6616          gsclocx(k,i)=                 de_dxx*dxx_XYZ(k)
6617      &    +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
6618        enddo
6619 c       write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
6620 c     &  (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
6621
6622 C to check gradient call subroutine check_grad
6623
6624     1 continue
6625       enddo
6626       return
6627       end
6628 c------------------------------------------------------------------------------
6629       double precision function enesc(x,xx,yy,zz,cost2,sint2)
6630       implicit none
6631       double precision x(65),xx,yy,zz,cost2,sint2,sumene1,sumene2,
6632      & sumene3,sumene4,sumene,dsc_i,dp2_i,dscp1,dscp2,s1,s1_6,s2,s2_6
6633       sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
6634      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
6635      &   + x(10)*yy*zz
6636       sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
6637      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
6638      & + x(20)*yy*zz
6639       sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
6640      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
6641      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
6642      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
6643      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
6644      &  +x(40)*xx*yy*zz
6645       sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
6646      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
6647      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
6648      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
6649      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
6650      &  +x(60)*xx*yy*zz
6651       dsc_i   = 0.743d0+x(61)
6652       dp2_i   = 1.9d0+x(62)
6653       dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
6654      &          *(xx*cost2+yy*sint2))
6655       dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
6656      &          *(xx*cost2-yy*sint2))
6657       s1=(1+x(63))/(0.1d0 + dscp1)
6658       s1_6=(1+x(64))/(0.1d0 + dscp1**6)
6659       s2=(1+x(65))/(0.1d0 + dscp2)
6660       s2_6=(1+x(65))/(0.1d0 + dscp2**6)
6661       sumene = ( sumene3*sint2 + sumene1)*(s1+s1_6)
6662      & + (sumene4*cost2 +sumene2)*(s2+s2_6)
6663       enesc=sumene
6664       return
6665       end
6666 #endif
6667 c------------------------------------------------------------------------------
6668       subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
6669 C
6670 C This procedure calculates two-body contact function g(rij) and its derivative:
6671 C
6672 C           eps0ij                                     !       x < -1
6673 C g(rij) =  esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5)  ! -1 =< x =< 1
6674 C            0                                         !       x > 1
6675 C
6676 C where x=(rij-r0ij)/delta
6677 C
6678 C rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
6679 C
6680       implicit none
6681       double precision rij,r0ij,eps0ij,fcont,fprimcont
6682       double precision x,x2,x4,delta
6683 c     delta=0.02D0*r0ij
6684 c      delta=0.2D0*r0ij
6685       x=(rij-r0ij)/delta
6686       if (x.lt.-1.0D0) then
6687         fcont=eps0ij
6688         fprimcont=0.0D0
6689       else if (x.le.1.0D0) then
6690         x2=x*x
6691         x4=x2*x2
6692         fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
6693         fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
6694       else
6695         fcont=0.0D0
6696         fprimcont=0.0D0
6697       endif
6698       return
6699       end
6700 c------------------------------------------------------------------------------
6701       subroutine splinthet(theti,delta,ss,ssder)
6702       implicit real*8 (a-h,o-z)
6703       include 'DIMENSIONS'
6704       include 'COMMON.VAR'
6705       include 'COMMON.GEO'
6706       thetup=pi-delta
6707       thetlow=delta
6708       if (theti.gt.pipol) then
6709         call gcont(theti,thetup,1.0d0,delta,ss,ssder)
6710       else
6711         call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
6712         ssder=-ssder
6713       endif
6714       return
6715       end
6716 c------------------------------------------------------------------------------
6717       subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
6718       implicit none
6719       double precision x,x0,delta,f0,f1,fprim0,f,fprim
6720       double precision ksi,ksi2,ksi3,a1,a2,a3
6721       a1=fprim0*delta/(f1-f0)
6722       a2=3.0d0-2.0d0*a1
6723       a3=a1-2.0d0
6724       ksi=(x-x0)/delta
6725       ksi2=ksi*ksi
6726       ksi3=ksi2*ksi
6727       f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
6728       fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
6729       return
6730       end
6731 c------------------------------------------------------------------------------
6732       subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
6733       implicit none
6734       double precision x,x0,delta,f0x,f1x,fprim0x,fx
6735       double precision ksi,ksi2,ksi3,a1,a2,a3
6736       ksi=(x-x0)/delta
6737       ksi2=ksi*ksi
6738       ksi3=ksi2*ksi
6739       a1=fprim0x*delta
6740       a2=3*(f1x-f0x)-2*fprim0x*delta
6741       a3=fprim0x*delta-2*(f1x-f0x)
6742       fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
6743       return
6744       end
6745 C-----------------------------------------------------------------------------
6746 #ifdef CRYST_TOR
6747 C-----------------------------------------------------------------------------
6748       subroutine etor(etors,edihcnstr)
6749       implicit real*8 (a-h,o-z)
6750       include 'DIMENSIONS'
6751       include 'COMMON.VAR'
6752       include 'COMMON.GEO'
6753       include 'COMMON.LOCAL'
6754       include 'COMMON.TORSION'
6755       include 'COMMON.INTERACT'
6756       include 'COMMON.DERIV'
6757       include 'COMMON.CHAIN'
6758       include 'COMMON.NAMES'
6759       include 'COMMON.IOUNITS'
6760       include 'COMMON.FFIELD'
6761       include 'COMMON.TORCNSTR'
6762       include 'COMMON.CONTROL'
6763       logical lprn
6764 C Set lprn=.true. for debugging
6765       lprn=.false.
6766 c      lprn=.true.
6767       etors=0.0D0
6768       do i=iphi_start,iphi_end
6769       etors_ii=0.0D0
6770         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
6771      &      .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
6772         itori=itortyp(itype(i-2))
6773         itori1=itortyp(itype(i-1))
6774         phii=phi(i)
6775         gloci=0.0D0
6776 C Proline-Proline pair is a special case...
6777         if (itori.eq.3 .and. itori1.eq.3) then
6778           if (phii.gt.-dwapi3) then
6779             cosphi=dcos(3*phii)
6780             fac=1.0D0/(1.0D0-cosphi)
6781             etorsi=v1(1,3,3)*fac
6782             etorsi=etorsi+etorsi
6783             etors=etors+etorsi-v1(1,3,3)
6784             if (energy_dec) etors_ii=etors_ii+etorsi-v1(1,3,3)
6785             gloci=gloci-3*fac*etorsi*dsin(3*phii)
6786           endif
6787           do j=1,3
6788             v1ij=v1(j+1,itori,itori1)
6789             v2ij=v2(j+1,itori,itori1)
6790             cosphi=dcos(j*phii)
6791             sinphi=dsin(j*phii)
6792             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
6793             if (energy_dec) etors_ii=etors_ii+
6794      &                              v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
6795             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
6796           enddo
6797         else
6798           do j=1,nterm_old
6799             v1ij=v1(j,itori,itori1)
6800             v2ij=v2(j,itori,itori1)
6801             cosphi=dcos(j*phii)
6802             sinphi=dsin(j*phii)
6803             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
6804             if (energy_dec) etors_ii=etors_ii+
6805      &                  v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
6806             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
6807           enddo
6808         endif
6809         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
6810              'etor',i,etors_ii
6811         if (lprn)
6812      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
6813      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
6814      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
6815         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
6816 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
6817       enddo
6818 ! 6/20/98 - dihedral angle constraints
6819       edihcnstr=0.0d0
6820       do i=1,ndih_constr
6821         itori=idih_constr(i)
6822         phii=phi(itori)
6823         difi=phii-phi0(i)
6824         if (difi.gt.drange(i)) then
6825           difi=difi-drange(i)
6826           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
6827           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
6828         else if (difi.lt.-drange(i)) then
6829           difi=difi+drange(i)
6830           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
6831           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
6832         endif
6833 !        write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii,
6834 !     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
6835       enddo
6836 !      write (iout,*) 'edihcnstr',edihcnstr
6837       return
6838       end
6839 c------------------------------------------------------------------------------
6840 c LICZENIE WIEZOW Z ROWNANIA ENERGII MODELLERA
6841       subroutine e_modeller(ehomology_constr)
6842       ehomology_constr=0.0d0
6843       write (iout,*) "!!!!!UWAGA, JESTEM W DZIWNEJ PETLI, TEST!!!!!"
6844       return
6845       end
6846 C !!!!!!!! NIE CZYTANE !!!!!!!!!!!
6847
6848 c------------------------------------------------------------------------------
6849       subroutine etor_d(etors_d)
6850       etors_d=0.0d0
6851       return
6852       end
6853 c----------------------------------------------------------------------------
6854 #else
6855       subroutine etor(etors,edihcnstr)
6856       implicit real*8 (a-h,o-z)
6857       include 'DIMENSIONS'
6858       include 'COMMON.VAR'
6859       include 'COMMON.GEO'
6860       include 'COMMON.LOCAL'
6861       include 'COMMON.TORSION'
6862       include 'COMMON.INTERACT'
6863       include 'COMMON.DERIV'
6864       include 'COMMON.CHAIN'
6865       include 'COMMON.NAMES'
6866       include 'COMMON.IOUNITS'
6867       include 'COMMON.FFIELD'
6868       include 'COMMON.TORCNSTR'
6869       include 'COMMON.CONTROL'
6870       logical lprn
6871 C Set lprn=.true. for debugging
6872       lprn=.false.
6873 c     lprn=.true.
6874       etors=0.0D0
6875       do i=iphi_start,iphi_end
6876 C ANY TWO ARE DUMMY ATOMS in row CYCLE
6877 c        if (((itype(i-3).eq.ntyp1).and.(itype(i-2).eq.ntyp1)).or.
6878 c     &      ((itype(i-2).eq.ntyp1).and.(itype(i-1).eq.ntyp1))  .or.
6879 c     &      ((itype(i-1).eq.ntyp1).and.(itype(i).eq.ntyp1))) cycle
6880         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
6881      &      .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
6882 C In current verion the ALL DUMMY ATOM POTENTIALS ARE OFF
6883 C For introducing the NH3+ and COO- group please check the etor_d for reference
6884 C and guidance
6885         etors_ii=0.0D0
6886          if (iabs(itype(i)).eq.20) then
6887          iblock=2
6888          else
6889          iblock=1
6890          endif
6891         itori=itortyp(itype(i-2))
6892         itori1=itortyp(itype(i-1))
6893         phii=phi(i)
6894         gloci=0.0D0
6895 C Regular cosine and sine terms
6896         do j=1,nterm(itori,itori1,iblock)
6897           v1ij=v1(j,itori,itori1,iblock)
6898           v2ij=v2(j,itori,itori1,iblock)
6899           cosphi=dcos(j*phii)
6900           sinphi=dsin(j*phii)
6901           etors=etors+v1ij*cosphi+v2ij*sinphi
6902           if (energy_dec) etors_ii=etors_ii+
6903      &                v1ij*cosphi+v2ij*sinphi
6904           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
6905         enddo
6906 C Lorentz terms
6907 C                         v1
6908 C  E = SUM ----------------------------------- - v1
6909 C          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
6910 C
6911         cosphi=dcos(0.5d0*phii)
6912         sinphi=dsin(0.5d0*phii)
6913         do j=1,nlor(itori,itori1,iblock)
6914           vl1ij=vlor1(j,itori,itori1)
6915           vl2ij=vlor2(j,itori,itori1)
6916           vl3ij=vlor3(j,itori,itori1)
6917           pom=vl2ij*cosphi+vl3ij*sinphi
6918           pom1=1.0d0/(pom*pom+1.0d0)
6919           etors=etors+vl1ij*pom1
6920           if (energy_dec) etors_ii=etors_ii+
6921      &                vl1ij*pom1
6922           pom=-pom*pom1*pom1
6923           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
6924         enddo
6925 C Subtract the constant term
6926         etors=etors-v0(itori,itori1,iblock)
6927           if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
6928      &         'etor',i,etors_ii-v0(itori,itori1,iblock)
6929         if (lprn)
6930      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
6931      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
6932      &  (v1(j,itori,itori1,iblock),j=1,6),
6933      &  (v2(j,itori,itori1,iblock),j=1,6)
6934         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
6935 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
6936       enddo
6937 ! 6/20/98 - dihedral angle constraints
6938       edihcnstr=0.0d0
6939 c      do i=1,ndih_constr
6940       do i=idihconstr_start,idihconstr_end
6941         itori=idih_constr(i)
6942         phii=phi(itori)
6943         difi=pinorm(phii-phi0(i))
6944         if (difi.gt.drange(i)) then
6945           difi=difi-drange(i)
6946           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
6947           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
6948         else if (difi.lt.-drange(i)) then
6949           difi=difi+drange(i)
6950           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
6951           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
6952         else
6953           difi=0.0
6954         endif
6955 cd        write (iout,'(2i5,4f8.3,2e14.5)') i,itori,rad2deg*phii,
6956 cd     &    rad2deg*phi0(i),  rad2deg*drange(i),
6957 cd     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
6958       enddo
6959 cd       write (iout,*) 'edihcnstr',edihcnstr
6960       return
6961       end
6962 c----------------------------------------------------------------------------
6963 c MODELLER restraint function
6964       subroutine e_modeller(ehomology_constr)
6965       implicit real*8 (a-h,o-z)
6966       include 'DIMENSIONS'
6967
6968       integer nnn, i, j, k, ki, irec, l
6969       integer katy, odleglosci, test7
6970       real*8 odleg, odleg2, odleg3, kat, kat2, kat3, gdih(max_template)
6971       real*8 Eval,Erot
6972       real*8 distance(max_template),distancek(max_template),
6973      &    min_odl,godl(max_template),dih_diff(max_template)
6974
6975 c
6976 c     FP - 30/10/2014 Temporary specifications for homology restraints
6977 c
6978       double precision utheta_i,gutheta_i,sum_gtheta,sum_sgtheta,
6979      &                 sgtheta
6980       double precision, dimension (maxres) :: guscdiff,usc_diff
6981       double precision, dimension (max_template) ::
6982      &           gtheta,dscdiff,uscdiffk,guscdiff2,guscdiff3,
6983      &           theta_diff
6984 c
6985
6986       include 'COMMON.SBRIDGE'
6987       include 'COMMON.CHAIN'
6988       include 'COMMON.GEO'
6989       include 'COMMON.DERIV'
6990       include 'COMMON.LOCAL'
6991       include 'COMMON.INTERACT'
6992       include 'COMMON.VAR'
6993       include 'COMMON.IOUNITS'
6994       include 'COMMON.MD'
6995       include 'COMMON.CONTROL'
6996 c
6997 c     From subroutine Econstr_back
6998 c
6999       include 'COMMON.NAMES'
7000       include 'COMMON.TIME1'
7001 c
7002
7003
7004       do i=1,max_template
7005         distancek(i)=9999999.9
7006       enddo
7007
7008
7009       odleg=0.0d0
7010
7011 c Pseudo-energy and gradient from homology restraints (MODELLER-like
7012 c function)
7013 C AL 5/2/14 - Introduce list of restraints
7014 c     write(iout,*) "waga_theta",waga_theta,"waga_d",waga_d
7015 #ifdef DEBUG
7016       write(iout,*) "------- dist restrs start -------"
7017 #endif
7018       do ii = link_start_homo,link_end_homo
7019          i = ires_homo(ii)
7020          j = jres_homo(ii)
7021          dij=dist(i,j)
7022 c        write (iout,*) "dij(",i,j,") =",dij
7023          nexl=0
7024          do k=1,constr_homology
7025 c           write(iout,*) ii,k,i,j,l_homo(k,ii),dij,odl(k,ii)
7026            if(.not.l_homo(k,ii)) then
7027              nexl=nexl+1
7028              cycle
7029            endif
7030            distance(k)=odl(k,ii)-dij
7031 c          write (iout,*) "distance(",k,") =",distance(k)
7032 c
7033 c          For Gaussian-type Urestr
7034 c
7035            distancek(k)=0.5d0*distance(k)**2*sigma_odl(k,ii) ! waga_dist rmvd from Gaussian argument
7036 c          write (iout,*) "sigma_odl(",k,ii,") =",sigma_odl(k,ii)
7037 c          write (iout,*) "distancek(",k,") =",distancek(k)
7038 c          distancek(k)=0.5d0*waga_dist*distance(k)**2*sigma_odl(k,ii)
7039 c
7040 c          For Lorentzian-type Urestr
7041 c
7042            if (waga_dist.lt.0.0d0) then
7043               sigma_odlir(k,ii)=dsqrt(1/sigma_odl(k,ii))
7044               distancek(k)=distance(k)**2/(sigma_odlir(k,ii)*
7045      &                     (distance(k)**2+sigma_odlir(k,ii)**2))
7046            endif
7047          enddo
7048
7049 c         min_odl=minval(distancek)
7050          do kk=1,constr_homology
7051           if(l_homo(kk,ii)) then
7052             min_odl=distancek(kk)
7053             exit
7054           endif
7055          enddo
7056          do kk=1,constr_homology
7057           if(l_homo(kk,ii) .and. distancek(kk).lt.min_odl)
7058      &              min_odl=distancek(kk)
7059          enddo
7060
7061 c        write (iout,* )"min_odl",min_odl
7062 #ifdef DEBUG
7063          write (iout,*) "ij dij",i,j,dij
7064          write (iout,*) "distance",(distance(k),k=1,constr_homology)
7065          write (iout,*) "distancek",(distancek(k),k=1,constr_homology)
7066          write (iout,* )"min_odl",min_odl
7067 #endif
7068 #ifdef OLDRESTR
7069          odleg2=0.0d0
7070 #else
7071          if (waga_dist.ge.0.0d0) then
7072            odleg2=nexl
7073          else
7074            odleg2=0.0d0
7075          endif
7076 #endif
7077          do k=1,constr_homology
7078 c Nie wiem po co to liczycie jeszcze raz!
7079 c            odleg3=-waga_dist(iset)*((distance(i,j,k)**2)/
7080 c     &              (2*(sigma_odl(i,j,k))**2))
7081            if(.not.l_homo(k,ii)) cycle
7082            if (waga_dist.ge.0.0d0) then
7083 c
7084 c          For Gaussian-type Urestr
7085 c
7086             godl(k)=dexp(-distancek(k)+min_odl)
7087             odleg2=odleg2+godl(k)
7088 c
7089 c          For Lorentzian-type Urestr
7090 c
7091            else
7092             odleg2=odleg2+distancek(k)
7093            endif
7094
7095 ccc       write(iout,779) i,j,k, "odleg2=",odleg2, "odleg3=", odleg3,
7096 ccc     & "dEXP(odleg3)=", dEXP(odleg3),"distance(i,j,k)^2=",
7097 ccc     & distance(i,j,k)**2, "dist(i+1,j+1)=", dist(i+1,j+1),
7098 ccc     & "sigma_odl(i,j,k)=", sigma_odl(i,j,k)
7099
7100          enddo
7101 c        write (iout,*) "godl",(godl(k),k=1,constr_homology) ! exponents
7102 c        write (iout,*) "ii i j",ii,i,j," odleg2",odleg2 ! sum of exps
7103 #ifdef DEBUG
7104          write (iout,*) "godl",(godl(k),k=1,constr_homology) ! exponents
7105          write (iout,*) "ii i j",ii,i,j," odleg2",odleg2 ! sum of exps
7106 #endif
7107            if (waga_dist.ge.0.0d0) then
7108 c
7109 c          For Gaussian-type Urestr
7110 c
7111               odleg=odleg-dLOG(odleg2/constr_homology)+min_odl
7112 c
7113 c          For Lorentzian-type Urestr
7114 c
7115            else
7116               odleg=odleg+odleg2/constr_homology
7117            endif
7118 c
7119 c        write (iout,*) "odleg",odleg ! sum of -ln-s
7120 c Gradient
7121 c
7122 c          For Gaussian-type Urestr
7123 c
7124          if (waga_dist.ge.0.0d0) sum_godl=odleg2
7125          sum_sgodl=0.0d0
7126          do k=1,constr_homology
7127 c            godl=dexp(((-(distance(i,j,k)**2)/(2*(sigma_odl(i,j,k))**2))
7128 c     &           *waga_dist)+min_odl
7129 c          sgodl=-godl(k)*distance(k)*sigma_odl(k,ii)*waga_dist
7130 c
7131          if(.not.l_homo(k,ii)) cycle
7132          if (waga_dist.ge.0.0d0) then
7133 c          For Gaussian-type Urestr
7134 c
7135            sgodl=-godl(k)*distance(k)*sigma_odl(k,ii) ! waga_dist rmvd
7136 c
7137 c          For Lorentzian-type Urestr
7138 c
7139          else
7140            sgodl=-2*sigma_odlir(k,ii)*(distance(k)/(distance(k)**2+
7141      &           sigma_odlir(k,ii)**2)**2)
7142          endif
7143            sum_sgodl=sum_sgodl+sgodl
7144
7145 c            sgodl2=sgodl2+sgodl
7146 c      write(iout,*) i, j, k, distance(i,j,k), "W GRADIENCIE1"
7147 c      write(iout,*) "constr_homology=",constr_homology
7148 c      write(iout,*) i, j, k, "TEST K"
7149          enddo
7150          if (waga_dist.ge.0.0d0) then
7151 c
7152 c          For Gaussian-type Urestr
7153 c
7154             grad_odl3=waga_homology(iset)*waga_dist
7155      &                *sum_sgodl/(sum_godl*dij)
7156 c
7157 c          For Lorentzian-type Urestr
7158 c
7159          else
7160 c Original grad expr modified by analogy w Gaussian-type Urestr grad
7161 c           grad_odl3=-waga_homology(iset)*waga_dist*sum_sgodl
7162             grad_odl3=-waga_homology(iset)*waga_dist*
7163      &                sum_sgodl/(constr_homology*dij)
7164          endif
7165 c
7166 c        grad_odl3=sum_sgodl/(sum_godl*dij)
7167
7168
7169 c      write(iout,*) i, j, k, distance(i,j,k), "W GRADIENCIE2"
7170 c      write(iout,*) (distance(i,j,k)**2), (2*(sigma_odl(i,j,k))**2),
7171 c     &              (-(distance(i,j,k)**2)/(2*(sigma_odl(i,j,k))**2))
7172
7173 ccc      write(iout,*) godl, sgodl, grad_odl3
7174
7175 c          grad_odl=grad_odl+grad_odl3
7176
7177          do jik=1,3
7178             ggodl=grad_odl3*(c(jik,i)-c(jik,j))
7179 ccc      write(iout,*) c(jik,i+1), c(jik,j+1), (c(jik,i+1)-c(jik,j+1))
7180 ccc      write(iout,746) "GRAD_ODL_1", i, j, jik, ggodl,
7181 ccc     &              ghpbc(jik,i+1), ghpbc(jik,j+1)
7182             ghpbc(jik,i)=ghpbc(jik,i)+ggodl
7183             ghpbc(jik,j)=ghpbc(jik,j)-ggodl
7184 ccc      write(iout,746) "GRAD_ODL_2", i, j, jik, ggodl,
7185 ccc     &              ghpbc(jik,i+1), ghpbc(jik,j+1)
7186 c         if (i.eq.25.and.j.eq.27) then
7187 c         write(iout,*) "jik",jik,"i",i,"j",j
7188 c         write(iout,*) "sum_sgodl",sum_sgodl,"sgodl",sgodl
7189 c         write(iout,*) "grad_odl3",grad_odl3
7190 c         write(iout,*) "c(",jik,i,")",c(jik,i),"c(",jik,j,")",c(jik,j)
7191 c         write(iout,*) "ggodl",ggodl
7192 c         write(iout,*) "ghpbc(",jik,i,")",
7193 c     &                 ghpbc(jik,i),"ghpbc(",jik,j,")",
7194 c     &                 ghpbc(jik,j)
7195 c         endif
7196          enddo
7197 ccc       write(iout,778)"TEST: odleg2=", odleg2, "DLOG(odleg2)=",
7198 ccc     & dLOG(odleg2),"-odleg=", -odleg
7199
7200       enddo ! ii-loop for dist
7201 #ifdef DEBUG
7202       write(iout,*) "------- dist restrs end -------"
7203 c     if (waga_angle.eq.1.0d0 .or. waga_theta.eq.1.0d0 .or.
7204 c    &     waga_d.eq.1.0d0) call sum_gradient
7205 #endif
7206 c Pseudo-energy and gradient from dihedral-angle restraints from
7207 c homology templates
7208 c      write (iout,*) "End of distance loop"
7209 c      call flush(iout)
7210       kat=0.0d0
7211 c      write (iout,*) idihconstr_start_homo,idihconstr_end_homo
7212 #ifdef DEBUG
7213       write(iout,*) "------- dih restrs start -------"
7214       do i=idihconstr_start_homo,idihconstr_end_homo
7215         write (iout,*) "gloc_init(",i,icg,")",gloc(i,icg)
7216       enddo
7217 #endif
7218       do i=idihconstr_start_homo,idihconstr_end_homo
7219         kat2=0.0d0
7220 c        betai=beta(i,i+1,i+2,i+3)
7221         betai = phi(i)
7222 c       write (iout,*) "betai =",betai
7223         do k=1,constr_homology
7224           dih_diff(k)=pinorm(dih(k,i)-betai)
7225 cd          write (iout,'(a8,2i4,2f15.8)') "dih_diff",i,k,dih_diff(k)
7226 cd     &                  ,sigma_dih(k,i)
7227 c          if (dih_diff(i,k).gt.3.14159) dih_diff(i,k)=
7228 c     &                                   -(6.28318-dih_diff(i,k))
7229 c          if (dih_diff(i,k).lt.-3.14159) dih_diff(i,k)=
7230 c     &                                   6.28318+dih_diff(i,k)
7231 #ifdef OLD_DIHED
7232           kat3=-0.5d0*dih_diff(k)**2*sigma_dih(k,i) ! waga_angle rmvd from Gaussian argument
7233 #else
7234           kat3=(dcos(dih_diff(k))-1)*sigma_dih(k,i) ! waga_angle rmvd from Gaussian argument
7235 #endif
7236 c         kat3=-0.5d0*waga_angle*dih_diff(k)**2*sigma_dih(k,i)
7237           gdih(k)=dexp(kat3)
7238           kat2=kat2+gdih(k)
7239 c          write(iout,*) "kat2=", kat2, "exp(kat3)=", exp(kat3)
7240 c          write(*,*)""
7241         enddo
7242 c       write (iout,*) "gdih",(gdih(k),k=1,constr_homology) ! exps
7243 c       write (iout,*) "i",i," betai",betai," kat2",kat2 ! sum of exps
7244 #ifdef DEBUG
7245         write (iout,*) "i",i," betai",betai," kat2",kat2
7246         write (iout,*) "gdih",(gdih(k),k=1,constr_homology)
7247 #endif
7248         if (kat2.le.1.0d-14) cycle
7249         kat=kat-dLOG(kat2/constr_homology)
7250 c       write (iout,*) "kat",kat ! sum of -ln-s
7251
7252 ccc       write(iout,778)"TEST: kat2=", kat2, "DLOG(kat2)=",
7253 ccc     & dLOG(kat2), "-kat=", -kat
7254
7255 c ----------------------------------------------------------------------
7256 c Gradient
7257 c ----------------------------------------------------------------------
7258
7259         sum_gdih=kat2
7260         sum_sgdih=0.0d0
7261         do k=1,constr_homology
7262 #ifdef OLD_DIHED
7263           sgdih=-gdih(k)*dih_diff(k)*sigma_dih(k,i)  ! waga_angle rmvd
7264 #else
7265           sgdih=-gdih(k)*dsin(dih_diff(k))*sigma_dih(k,i)  ! waga_angle rmvd
7266 #endif
7267 c         sgdih=-gdih(k)*dih_diff(k)*sigma_dih(k,i)*waga_angle
7268           sum_sgdih=sum_sgdih+sgdih
7269         enddo
7270 c       grad_dih3=sum_sgdih/sum_gdih
7271         grad_dih3=waga_homology(iset)*waga_angle*sum_sgdih/sum_gdih
7272
7273 c      write(iout,*)i,k,gdih,sgdih,beta(i+1,i+2,i+3,i+4),grad_dih3
7274 ccc      write(iout,747) "GRAD_KAT_1", i, nphi, icg, grad_dih3,
7275 ccc     & gloc(nphi+i-3,icg)
7276         gloc(i-3,icg)=gloc(i-3,icg)+grad_dih3
7277 c        if (i.eq.25) then
7278 c        write(iout,*) "i",i,"icg",icg,"gloc(",i,icg,")",gloc(i,icg)
7279 c        endif
7280 ccc      write(iout,747) "GRAD_KAT_2", i, nphi, icg, grad_dih3,
7281 ccc     & gloc(nphi+i-3,icg)
7282
7283       enddo ! i-loop for dih
7284 #ifdef DEBUG
7285       write(iout,*) "------- dih restrs end -------"
7286 #endif
7287
7288 c Pseudo-energy and gradient for theta angle restraints from
7289 c homology templates
7290 c FP 01/15 - inserted from econstr_local_test.F, loop structure
7291 c adapted
7292
7293 c
7294 c     For constr_homology reference structures (FP)
7295 c
7296 c     Uconst_back_tot=0.0d0
7297       Eval=0.0d0
7298       Erot=0.0d0
7299 c     Econstr_back legacy
7300       do i=1,nres
7301 c     do i=ithet_start,ithet_end
7302        dutheta(i)=0.0d0
7303 c     enddo
7304 c     do i=loc_start,loc_end
7305         do j=1,3
7306           duscdiff(j,i)=0.0d0
7307           duscdiffx(j,i)=0.0d0
7308         enddo
7309       enddo
7310 c
7311 c     do iref=1,nref
7312 c     write (iout,*) "ithet_start =",ithet_start,"ithet_end =",ithet_end
7313 c     write (iout,*) "waga_theta",waga_theta
7314       if (waga_theta.gt.0.0d0) then
7315 #ifdef DEBUG
7316       write (iout,*) "usampl",usampl
7317       write(iout,*) "------- theta restrs start -------"
7318 c     do i=ithet_start,ithet_end
7319 c       write (iout,*) "gloc_init(",nphi+i,icg,")",gloc(nphi+i,icg)
7320 c     enddo
7321 #endif
7322 c     write (iout,*) "maxres",maxres,"nres",nres
7323
7324       do i=ithet_start,ithet_end
7325 c
7326 c     do i=1,nfrag_back
7327 c       ii = ifrag_back(2,i,iset)-ifrag_back(1,i,iset)
7328 c
7329 c Deviation of theta angles wrt constr_homology ref structures
7330 c
7331         utheta_i=0.0d0 ! argument of Gaussian for single k
7332         gutheta_i=0.0d0 ! Sum of Gaussians over constr_homology ref structures
7333 c       do j=ifrag_back(1,i,iset)+2,ifrag_back(2,i,iset) ! original loop
7334 c       over residues in a fragment
7335 c       write (iout,*) "theta(",i,")=",theta(i)
7336         do k=1,constr_homology
7337 c
7338 c         dtheta_i=theta(j)-thetaref(j,iref)
7339 c         dtheta_i=thetaref(k,i)-theta(i) ! original form without indexing
7340           theta_diff(k)=thetatpl(k,i)-theta(i)
7341 cd          write (iout,'(a8,2i4,2f15.8)') "theta_diff",i,k,theta_diff(k)
7342 cd     &                  ,sigma_theta(k,i)
7343
7344 c
7345           utheta_i=-0.5d0*theta_diff(k)**2*sigma_theta(k,i) ! waga_theta rmvd from Gaussian argument
7346 c         utheta_i=-0.5d0*waga_theta*theta_diff(k)**2*sigma_theta(k,i) ! waga_theta?
7347           gtheta(k)=dexp(utheta_i) ! + min_utheta_i?
7348           gutheta_i=gutheta_i+gtheta(k)  ! Sum of Gaussians (pk)
7349 c         Gradient for single Gaussian restraint in subr Econstr_back
7350 c         dutheta(j-2)=dutheta(j-2)+wfrag_back(1,i,iset)*dtheta_i/(ii-1)
7351 c
7352         enddo
7353 c       write (iout,*) "gtheta",(gtheta(k),k=1,constr_homology) ! exps
7354 c       write (iout,*) "i",i," gutheta_i",gutheta_i ! sum of exps
7355
7356 c
7357 c         Gradient for multiple Gaussian restraint
7358         sum_gtheta=gutheta_i
7359         sum_sgtheta=0.0d0
7360         do k=1,constr_homology
7361 c        New generalized expr for multiple Gaussian from Econstr_back
7362          sgtheta=-gtheta(k)*theta_diff(k)*sigma_theta(k,i) ! waga_theta rmvd
7363 c
7364 c        sgtheta=-gtheta(k)*theta_diff(k)*sigma_theta(k,i)*waga_theta ! right functional form?
7365           sum_sgtheta=sum_sgtheta+sgtheta ! cum variable
7366         enddo
7367 c       Final value of gradient using same var as in Econstr_back
7368         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)
7369      &      +sum_sgtheta/sum_gtheta*waga_theta
7370      &               *waga_homology(iset)
7371 c        dutheta(i-2)=sum_sgtheta/sum_gtheta*waga_theta
7372 c     &               *waga_homology(iset)
7373 c       dutheta(i)=sum_sgtheta/sum_gtheta
7374 c
7375 c       Uconst_back=Uconst_back+waga_theta*utheta(i) ! waga_theta added as weight
7376         Eval=Eval-dLOG(gutheta_i/constr_homology)
7377 c       write (iout,*) "utheta(",i,")=",utheta(i) ! -ln of sum of exps
7378 c       write (iout,*) "Uconst_back",Uconst_back ! sum of -ln-s
7379 c       Uconst_back=Uconst_back+utheta(i)
7380       enddo ! (i-loop for theta)
7381 #ifdef DEBUG
7382       write(iout,*) "------- theta restrs end -------"
7383 #endif
7384       endif
7385 c
7386 c Deviation of local SC geometry
7387 c
7388 c Separation of two i-loops (instructed by AL - 11/3/2014)
7389 c
7390 c     write (iout,*) "loc_start =",loc_start,"loc_end =",loc_end
7391 c     write (iout,*) "waga_d",waga_d
7392
7393 #ifdef DEBUG
7394       write(iout,*) "------- SC restrs start -------"
7395       write (iout,*) "Initial duscdiff,duscdiffx"
7396       do i=loc_start,loc_end
7397         write (iout,*) i,(duscdiff(jik,i),jik=1,3),
7398      &                 (duscdiffx(jik,i),jik=1,3)
7399       enddo
7400 #endif
7401       do i=loc_start,loc_end
7402         usc_diff_i=0.0d0 ! argument of Gaussian for single k
7403         guscdiff(i)=0.0d0 ! Sum of Gaussians over constr_homology ref structures
7404 c       do j=ifrag_back(1,i,iset)+1,ifrag_back(2,i,iset)-1 ! Econstr_back legacy
7405 c       write(iout,*) "xxtab, yytab, zztab"
7406 c       write(iout,'(i5,3f8.2)') i,xxtab(i),yytab(i),zztab(i)
7407         do k=1,constr_homology
7408 c
7409           dxx=-xxtpl(k,i)+xxtab(i) ! Diff b/w x component of ith SC vector in model and kth ref str?
7410 c                                    Original sign inverted for calc of gradients (s. Econstr_back)
7411           dyy=-yytpl(k,i)+yytab(i) ! ibid y
7412           dzz=-zztpl(k,i)+zztab(i) ! ibid z
7413 c         write(iout,*) "dxx, dyy, dzz"
7414 cd          write(iout,'(2i5,4f8.2)') k,i,dxx,dyy,dzz,sigma_d(k,i)
7415 c
7416           usc_diff_i=-0.5d0*(dxx**2+dyy**2+dzz**2)*sigma_d(k,i)  ! waga_d rmvd from Gaussian argument
7417 c         usc_diff(i)=-0.5d0*waga_d*(dxx**2+dyy**2+dzz**2)*sigma_d(k,i) ! waga_d?
7418 c         uscdiffk(k)=usc_diff(i)
7419           guscdiff2(k)=dexp(usc_diff_i) ! without min_scdiff
7420 c          write(iout,*) "i",i," k",k," sigma_d",sigma_d(k,i),
7421 c     &       " guscdiff2",guscdiff2(k)
7422           guscdiff(i)=guscdiff(i)+guscdiff2(k)  !Sum of Gaussians (pk)
7423 c          write (iout,'(i5,6f10.5)') j,xxtab(j),yytab(j),zztab(j),
7424 c     &      xxref(j),yyref(j),zzref(j)
7425         enddo
7426 c
7427 c       Gradient
7428 c
7429 c       Generalized expression for multiple Gaussian acc to that for a single
7430 c       Gaussian in Econstr_back as instructed by AL (FP - 03/11/2014)
7431 c
7432 c       Original implementation
7433 c       sum_guscdiff=guscdiff(i)
7434 c
7435 c       sum_sguscdiff=0.0d0
7436 c       do k=1,constr_homology
7437 c          sguscdiff=-guscdiff2(k)*dscdiff(k)*sigma_d(k,i)*waga_d !waga_d?
7438 c          sguscdiff=-guscdiff3(k)*dscdiff(k)*sigma_d(k,i)*waga_d ! w min_uscdiff
7439 c          sum_sguscdiff=sum_sguscdiff+sguscdiff
7440 c       enddo
7441 c
7442 c       Implementation of new expressions for gradient (Jan. 2015)
7443 c
7444 c       grad_uscdiff=sum_sguscdiff/(sum_guscdiff*dtab) !?
7445         do k=1,constr_homology
7446 c
7447 c       New calculation of dxx, dyy, and dzz corrected by AL (07/11), was missing and wrong
7448 c       before. Now the drivatives should be correct
7449 c
7450           dxx=-xxtpl(k,i)+xxtab(i) ! Diff b/w x component of ith SC vector in model and kth ref str?
7451 c                                  Original sign inverted for calc of gradients (s. Econstr_back)
7452           dyy=-yytpl(k,i)+yytab(i) ! ibid y
7453           dzz=-zztpl(k,i)+zztab(i) ! ibid z
7454 c
7455 c         New implementation
7456 c
7457           sum_guscdiff=guscdiff2(k)*!(dsqrt(dxx*dxx+dyy*dyy+dzz*dzz))* -> wrong!
7458      &                 sigma_d(k,i) ! for the grad wrt r'
7459 c         sum_sguscdiff=sum_sguscdiff+sum_guscdiff
7460 c
7461 c
7462 c        New implementation
7463          sum_guscdiff = waga_homology(iset)*waga_d*sum_guscdiff
7464          do jik=1,3
7465             duscdiff(jik,i-1)=duscdiff(jik,i-1)+
7466      &      sum_guscdiff*(dXX_C1tab(jik,i)*dxx+
7467      &      dYY_C1tab(jik,i)*dyy+dZZ_C1tab(jik,i)*dzz)/guscdiff(i)
7468             duscdiff(jik,i)=duscdiff(jik,i)+
7469      &      sum_guscdiff*(dXX_Ctab(jik,i)*dxx+
7470      &      dYY_Ctab(jik,i)*dyy+dZZ_Ctab(jik,i)*dzz)/guscdiff(i)
7471             duscdiffx(jik,i)=duscdiffx(jik,i)+
7472      &      sum_guscdiff*(dXX_XYZtab(jik,i)*dxx+
7473      &      dYY_XYZtab(jik,i)*dyy+dZZ_XYZtab(jik,i)*dzz)/guscdiff(i)
7474 c
7475 #ifdef DEBUG
7476              write(iout,*) "jik",jik,"i",i
7477              write(iout,*) "dxx, dyy, dzz"
7478              write(iout,'(2i5,3f8.2)') k,i,dxx,dyy,dzz
7479              write(iout,*) "guscdiff2(",k,")",guscdiff2(k)
7480 c            write(iout,*) "sum_sguscdiff",sum_sguscdiff
7481 cc           write(iout,*) "dXX_Ctab(",jik,i,")",dXX_Ctab(jik,i)
7482 c            write(iout,*) "dYY_Ctab(",jik,i,")",dYY_Ctab(jik,i)
7483 c            write(iout,*) "dZZ_Ctab(",jik,i,")",dZZ_Ctab(jik,i)
7484 c            write(iout,*) "dXX_C1tab(",jik,i,")",dXX_C1tab(jik,i)
7485 c            write(iout,*) "dYY_C1tab(",jik,i,")",dYY_C1tab(jik,i)
7486 c            write(iout,*) "dZZ_C1tab(",jik,i,")",dZZ_C1tab(jik,i)
7487 c            write(iout,*) "dXX_XYZtab(",jik,i,")",dXX_XYZtab(jik,i)
7488 c            write(iout,*) "dYY_XYZtab(",jik,i,")",dYY_XYZtab(jik,i)
7489 c            write(iout,*) "dZZ_XYZtab(",jik,i,")",dZZ_XYZtab(jik,i)
7490 c            write(iout,*) "duscdiff(",jik,i-1,")",duscdiff(jik,i-1)
7491 c            write(iout,*) "duscdiff(",jik,i,")",duscdiff(jik,i)
7492 c            write(iout,*) "duscdiffx(",jik,i,")",duscdiffx(jik,i)
7493 c            endif
7494 #endif
7495          enddo
7496         enddo
7497 c
7498 c       uscdiff(i)=-dLOG(guscdiff(i)/(ii-1))      ! Weighting by (ii-1) required?
7499 c        usc_diff(i)=-dLOG(guscdiff(i)/constr_homology) ! + min_uscdiff ?
7500 c
7501 c        write (iout,*) i," uscdiff",uscdiff(i)
7502 c
7503 c Put together deviations from local geometry
7504
7505 c       Uconst_back=Uconst_back+wfrag_back(1,i,iset)*utheta(i)+
7506 c      &            wfrag_back(3,i,iset)*uscdiff(i)
7507         Erot=Erot-dLOG(guscdiff(i)/constr_homology)
7508 c       write (iout,*) "usc_diff(",i,")=",usc_diff(i) ! -ln of sum of exps
7509 c       write (iout,*) "Uconst_back",Uconst_back ! cum sum of -ln-s
7510 c       Uconst_back=Uconst_back+usc_diff(i)
7511 c
7512 c     Gradient of multiple Gaussian restraint (FP - 04/11/2014 - right?)
7513 c
7514 c     New implment: multiplied by sum_sguscdiff
7515 c
7516
7517       enddo ! (i-loop for dscdiff)
7518
7519 c      endif
7520
7521 #ifdef DEBUG
7522       write(iout,*) "------- SC restrs end -------"
7523         write (iout,*) "------ After SC loop in e_modeller ------"
7524         do i=loc_start,loc_end
7525          write (iout,*) "i",i," gradc",(gradc(j,i,icg),j=1,3)
7526          write (iout,*) "i",i," gradx",(gradx(j,i,icg),j=1,3)
7527         enddo
7528       if (waga_theta.eq.1.0d0) then
7529       write (iout,*) "in e_modeller after SC restr end: dutheta"
7530       do i=ithet_start,ithet_end
7531         write (iout,*) i,dutheta(i)
7532       enddo
7533       endif
7534       if (waga_d.eq.1.0d0) then
7535       write (iout,*) "e_modeller after SC loop: duscdiff/x"
7536       do i=1,nres
7537         write (iout,*) i,(duscdiff(j,i),j=1,3)
7538         write (iout,*) i,(duscdiffx(j,i),j=1,3)
7539       enddo
7540       endif
7541 #endif
7542
7543 c Total energy from homology restraints
7544 #ifdef DEBUG
7545       write (iout,*) "odleg",odleg," kat",kat
7546 #endif
7547 c
7548 c Addition of energy of theta angle and SC local geom over constr_homologs ref strs
7549 c
7550 c     ehomology_constr=odleg+kat
7551 c
7552 c     For Lorentzian-type Urestr
7553 c
7554
7555       if (waga_dist.ge.0.0d0) then
7556 c
7557 c          For Gaussian-type Urestr
7558 c
7559         ehomology_constr=(waga_dist*odleg+waga_angle*kat+
7560      &              waga_theta*Eval+waga_d*Erot)*waga_homology(iset)
7561 c     write (iout,*) "ehomology_constr=",ehomology_constr
7562       else
7563 c
7564 c          For Lorentzian-type Urestr
7565 c
7566         ehomology_constr=(-waga_dist*odleg+waga_angle*kat+
7567      &              waga_theta*Eval+waga_d*Erot)*waga_homology(iset)
7568 c     write (iout,*) "ehomology_constr=",ehomology_constr
7569       endif
7570 #ifdef DEBUG
7571       write (iout,*) "odleg",waga_dist,odleg," kat",waga_angle,kat,
7572      & "Eval",waga_theta,eval,
7573      &   "Erot",waga_d,Erot
7574       write (iout,*) "ehomology_constr",ehomology_constr
7575 #endif
7576       return
7577 c
7578 c FP 01/15 end
7579 c
7580   748 format(a8,f12.3,a6,f12.3,a7,f12.3)
7581   747 format(a12,i4,i4,i4,f8.3,f8.3)
7582   746 format(a12,i4,i4,i4,f8.3,f8.3,f8.3)
7583   778 format(a7,1X,f10.3,1X,a4,1X,f10.3,1X,a5,1X,f10.3)
7584   779 format(i3,1X,i3,1X,i2,1X,a7,1X,f7.3,1X,a7,1X,f7.3,1X,a13,1X,
7585      &       f7.3,1X,a17,1X,f9.3,1X,a10,1X,f8.3,1X,a10,1X,f8.3)
7586       end
7587
7588 c------------------------------------------------------------------------------
7589       subroutine etor_d(etors_d)
7590 C 6/23/01 Compute double torsional energy
7591       implicit real*8 (a-h,o-z)
7592       include 'DIMENSIONS'
7593       include 'COMMON.VAR'
7594       include 'COMMON.GEO'
7595       include 'COMMON.LOCAL'
7596       include 'COMMON.TORSION'
7597       include 'COMMON.INTERACT'
7598       include 'COMMON.DERIV'
7599       include 'COMMON.CHAIN'
7600       include 'COMMON.NAMES'
7601       include 'COMMON.IOUNITS'
7602       include 'COMMON.FFIELD'
7603       include 'COMMON.TORCNSTR'
7604       include 'COMMON.CONTROL'
7605       logical lprn
7606 C Set lprn=.true. for debugging
7607       lprn=.false.
7608 c     lprn=.true.
7609       etors_d=0.0D0
7610 c      write(iout,*) "a tu??"
7611       do i=iphid_start,iphid_end
7612 C ANY TWO ARE DUMMY ATOMS in row CYCLE
7613 C        if (((itype(i-3).eq.ntyp1).and.(itype(i-2).eq.ntyp1)).or.
7614 C     &      ((itype(i-2).eq.ntyp1).and.(itype(i-1).eq.ntyp1)).or.
7615 C     &      ((itype(i-1).eq.ntyp1).and.(itype(i).eq.ntyp1))  .or.
7616 C     &      ((itype(i).eq.ntyp1).and.(itype(i+1).eq.ntyp1))) cycle
7617          if ((itype(i-2).eq.ntyp1).or.itype(i-3).eq.ntyp1.or.
7618      &  (itype(i-1).eq.ntyp1).or.(itype(i).eq.ntyp1).or.
7619      &  (itype(i+1).eq.ntyp1)) cycle
7620 C In current verion the ALL DUMMY ATOM POTENTIALS ARE OFF
7621         etors_d_ii=0.0D0
7622         itori=itortyp(itype(i-2))
7623         itori1=itortyp(itype(i-1))
7624         itori2=itortyp(itype(i))
7625         phii=phi(i)
7626         phii1=phi(i+1)
7627         gloci1=0.0D0
7628         gloci2=0.0D0
7629         iblock=1
7630         if (iabs(itype(i+1)).eq.20) iblock=2
7631 C Iblock=2 Proline type
7632 C ADASKO: WHEN PARAMETERS FOR THIS TYPE OF BLOCKING GROUP IS READY UNCOMMENT
7633 C CHECK WEATHER THERE IS NECCESITY FOR iblock=3 for COO-
7634 C        if (itype(i+1).eq.ntyp1) iblock=3
7635 C The problem of NH3+ group can be resolved by adding new parameters please note if there
7636 C IS or IS NOT need for this
7637 C IF Yes uncomment below and add to parmread.F appropriate changes and to v1cij and so on
7638 C        is (itype(i-3).eq.ntyp1) ntblock=2
7639 C        ntblock is N-terminal blocking group
7640
7641 C Regular cosine and sine terms
7642         do j=1,ntermd_1(itori,itori1,itori2,iblock)
7643 C Example of changes for NH3+ blocking group
7644 C       do j=1,ntermd_1(itori,itori1,itori2,iblock,ntblock)
7645 C          v1cij=v1c(1,j,itori,itori1,itori2,iblock,ntblock)
7646           v1cij=v1c(1,j,itori,itori1,itori2,iblock)
7647           v1sij=v1s(1,j,itori,itori1,itori2,iblock)
7648           v2cij=v1c(2,j,itori,itori1,itori2,iblock)
7649           v2sij=v1s(2,j,itori,itori1,itori2,iblock)
7650           cosphi1=dcos(j*phii)
7651           sinphi1=dsin(j*phii)
7652           cosphi2=dcos(j*phii1)
7653           sinphi2=dsin(j*phii1)
7654           etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+
7655      &     v2cij*cosphi2+v2sij*sinphi2
7656           if (energy_dec) etors_d_ii=etors_d_ii+
7657      &     v1cij*cosphi1+v1sij*sinphi1+v2cij*cosphi2+v2sij*sinphi2
7658           gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
7659           gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
7660         enddo
7661         do k=2,ntermd_2(itori,itori1,itori2,iblock)
7662           do l=1,k-1
7663             v1cdij = v2c(k,l,itori,itori1,itori2,iblock)
7664             v2cdij = v2c(l,k,itori,itori1,itori2,iblock)
7665             v1sdij = v2s(k,l,itori,itori1,itori2,iblock)
7666             v2sdij = v2s(l,k,itori,itori1,itori2,iblock)
7667             cosphi1p2=dcos(l*phii+(k-l)*phii1)
7668             cosphi1m2=dcos(l*phii-(k-l)*phii1)
7669             sinphi1p2=dsin(l*phii+(k-l)*phii1)
7670             sinphi1m2=dsin(l*phii-(k-l)*phii1)
7671             etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+
7672      &        v1sdij*sinphi1p2+v2sdij*sinphi1m2
7673             if (energy_dec) etors_d_ii=etors_d_ii+
7674      &        v1cdij*cosphi1p2+v2cdij*cosphi1m2+
7675      &        v1sdij*sinphi1p2+v2sdij*sinphi1m2
7676             gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2
7677      &        -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
7678             gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2
7679      &        -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
7680           enddo
7681         enddo
7682           if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
7683      &         'etor_d',i,etors_d_ii
7684         gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*gloci1
7685         gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*gloci2
7686       enddo
7687       return
7688       end
7689 #endif
7690 c------------------------------------------------------------------------------
7691       subroutine eback_sc_corr(esccor)
7692 c 7/21/2007 Correlations between the backbone-local and side-chain-local
7693 c        conformational states; temporarily implemented as differences
7694 c        between UNRES torsional potentials (dependent on three types of
7695 c        residues) and the torsional potentials dependent on all 20 types
7696 c        of residues computed from AM1  energy surfaces of terminally-blocked
7697 c        amino-acid residues.
7698       implicit real*8 (a-h,o-z)
7699       include 'DIMENSIONS'
7700       include 'COMMON.VAR'
7701       include 'COMMON.GEO'
7702       include 'COMMON.LOCAL'
7703       include 'COMMON.TORSION'
7704       include 'COMMON.SCCOR'
7705       include 'COMMON.INTERACT'
7706       include 'COMMON.DERIV'
7707       include 'COMMON.CHAIN'
7708       include 'COMMON.NAMES'
7709       include 'COMMON.IOUNITS'
7710       include 'COMMON.FFIELD'
7711       include 'COMMON.CONTROL'
7712       logical lprn
7713 C Set lprn=.true. for debugging
7714       lprn=.false.
7715 c      lprn=.true.
7716 c      write (iout,*) "EBACK_SC_COR",itau_start,itau_end
7717       esccor=0.0D0
7718       do i=itau_start,itau_end
7719         if ((itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)) cycle
7720         isccori=isccortyp(itype(i-2))
7721         isccori1=isccortyp(itype(i-1))
7722 c      write (iout,*) "EBACK_SC_COR",i,nterm_sccor(isccori,isccori1)
7723         phii=phi(i)
7724         do intertyp=1,3 !intertyp
7725          esccor_ii=0.0D0
7726 cc Added 09 May 2012 (Adasko)
7727 cc  Intertyp means interaction type of backbone mainchain correlation:
7728 c   1 = SC...Ca...Ca...Ca
7729 c   2 = Ca...Ca...Ca...SC
7730 c   3 = SC...Ca...Ca...SCi
7731         gloci=0.0D0
7732         if (((intertyp.eq.3).and.((itype(i-2).eq.10).or.
7733      &      (itype(i-1).eq.10).or.(itype(i-2).eq.ntyp1).or.
7734      &      (itype(i-1).eq.ntyp1)))
7735      &    .or. ((intertyp.eq.1).and.((itype(i-2).eq.10)
7736      &     .or.(itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)
7737      &     .or.(itype(i).eq.ntyp1)))
7738      &    .or.((intertyp.eq.2).and.((itype(i-1).eq.10).or.
7739      &      (itype(i-1).eq.ntyp1).or.(itype(i-2).eq.ntyp1).or.
7740      &      (itype(i-3).eq.ntyp1)))) cycle
7741         if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1).eq.ntyp1)) cycle
7742         if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres).eq.ntyp1))
7743      & cycle
7744        do j=1,nterm_sccor(isccori,isccori1)
7745           v1ij=v1sccor(j,intertyp,isccori,isccori1)
7746           v2ij=v2sccor(j,intertyp,isccori,isccori1)
7747           cosphi=dcos(j*tauangle(intertyp,i))
7748           sinphi=dsin(j*tauangle(intertyp,i))
7749           if (energy_dec) esccor_ii=esccor_ii+v1ij*cosphi+v2ij*sinphi
7750           esccor=esccor+v1ij*cosphi+v2ij*sinphi
7751           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7752         enddo
7753          if (energy_dec) write (iout,'(a6,i5,i2,0pf7.3)')
7754      &         'esccor',i,intertyp,esccor_ii
7755 c      write (iout,*) "EBACK_SC_COR",i,v1ij*cosphi+v2ij*sinphi,intertyp
7756         gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci
7757         if (lprn)
7758      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
7759      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,isccori,isccori1,
7760      &  (v1sccor(j,intertyp,isccori,isccori1),j=1,6)
7761      & ,(v2sccor(j,intertyp,isccori,isccori1),j=1,6)
7762         gsccor_loc(i-3)=gsccor_loc(i-3)+gloci
7763        enddo !intertyp
7764       enddo
7765
7766       return
7767       end
7768 c----------------------------------------------------------------------------
7769       subroutine multibody(ecorr)
7770 C This subroutine calculates multi-body contributions to energy following
7771 C the idea of Skolnick et al. If side chains I and J make a contact and
7772 C at the same time side chains I+1 and J+1 make a contact, an extra
7773 C contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
7774       implicit real*8 (a-h,o-z)
7775       include 'DIMENSIONS'
7776       include 'COMMON.IOUNITS'
7777       include 'COMMON.DERIV'
7778       include 'COMMON.INTERACT'
7779       include 'COMMON.CONTACTS'
7780       double precision gx(3),gx1(3)
7781       logical lprn
7782
7783 C Set lprn=.true. for debugging
7784       lprn=.false.
7785
7786       if (lprn) then
7787         write (iout,'(a)') 'Contact function values:'
7788         do i=nnt,nct-2
7789           write (iout,'(i2,20(1x,i2,f10.5))')
7790      &        i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
7791         enddo
7792       endif
7793       ecorr=0.0D0
7794       do i=nnt,nct
7795         do j=1,3
7796           gradcorr(j,i)=0.0D0
7797           gradxorr(j,i)=0.0D0
7798         enddo
7799       enddo
7800       do i=nnt,nct-2
7801
7802         DO ISHIFT = 3,4
7803
7804         i1=i+ishift
7805         num_conti=num_cont(i)
7806         num_conti1=num_cont(i1)
7807         do jj=1,num_conti
7808           j=jcont(jj,i)
7809           do kk=1,num_conti1
7810             j1=jcont(kk,i1)
7811             if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
7812 cd          write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
7813 cd   &                   ' ishift=',ishift
7814 C Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
7815 C The system gains extra energy.
7816               ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
7817             endif   ! j1==j+-ishift
7818           enddo     ! kk
7819         enddo       ! jj
7820
7821         ENDDO ! ISHIFT
7822
7823       enddo         ! i
7824       return
7825       end
7826 c------------------------------------------------------------------------------
7827       double precision function esccorr(i,j,k,l,jj,kk)
7828       implicit real*8 (a-h,o-z)
7829       include 'DIMENSIONS'
7830       include 'COMMON.IOUNITS'
7831       include 'COMMON.DERIV'
7832       include 'COMMON.INTERACT'
7833       include 'COMMON.CONTACTS'
7834       double precision gx(3),gx1(3)
7835       logical lprn
7836       lprn=.false.
7837       eij=facont(jj,i)
7838       ekl=facont(kk,k)
7839 cd    write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
7840 C Calculate the multi-body contribution to energy.
7841 C Calculate multi-body contributions to the gradient.
7842 cd    write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
7843 cd   & k,l,(gacont(m,kk,k),m=1,3)
7844       do m=1,3
7845         gx(m) =ekl*gacont(m,jj,i)
7846         gx1(m)=eij*gacont(m,kk,k)
7847         gradxorr(m,i)=gradxorr(m,i)-gx(m)
7848         gradxorr(m,j)=gradxorr(m,j)+gx(m)
7849         gradxorr(m,k)=gradxorr(m,k)-gx1(m)
7850         gradxorr(m,l)=gradxorr(m,l)+gx1(m)
7851       enddo
7852       do m=i,j-1
7853         do ll=1,3
7854           gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
7855         enddo
7856       enddo
7857       do m=k,l-1
7858         do ll=1,3
7859           gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
7860         enddo
7861       enddo
7862       esccorr=-eij*ekl
7863       return
7864       end
7865 c------------------------------------------------------------------------------
7866       subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
7867 C This subroutine calculates multi-body contributions to hydrogen-bonding
7868       implicit real*8 (a-h,o-z)
7869       include 'DIMENSIONS'
7870       include 'COMMON.IOUNITS'
7871 #ifdef MPI
7872       include "mpif.h"
7873       parameter (max_cont=maxconts)
7874       parameter (max_dim=26)
7875       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
7876       double precision zapas(max_dim,maxconts,max_fg_procs),
7877      &  zapas_recv(max_dim,maxconts,max_fg_procs)
7878       common /przechowalnia/ zapas
7879       integer status(MPI_STATUS_SIZE),req(maxconts*2),
7880      &  status_array(MPI_STATUS_SIZE,maxconts*2)
7881 #endif
7882       include 'COMMON.SETUP'
7883       include 'COMMON.FFIELD'
7884       include 'COMMON.DERIV'
7885       include 'COMMON.INTERACT'
7886       include 'COMMON.CONTACTS'
7887       include 'COMMON.CONTROL'
7888       include 'COMMON.LOCAL'
7889       double precision gx(3),gx1(3),time00
7890       logical lprn,ldone
7891
7892 C Set lprn=.true. for debugging
7893       lprn=.false.
7894 #ifdef MPI
7895       n_corr=0
7896       n_corr1=0
7897       if (nfgtasks.le.1) goto 30
7898       if (lprn) then
7899         write (iout,'(a)') 'Contact function values before RECEIVE:'
7900         do i=nnt,nct-2
7901           write (iout,'(2i3,50(1x,i2,f5.2))')
7902      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
7903      &    j=1,num_cont_hb(i))
7904         enddo
7905       endif
7906       call flush(iout)
7907       do i=1,ntask_cont_from
7908         ncont_recv(i)=0
7909       enddo
7910       do i=1,ntask_cont_to
7911         ncont_sent(i)=0
7912       enddo
7913 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
7914 c     & ntask_cont_to
7915 C Make the list of contacts to send to send to other procesors
7916 c      write (iout,*) "limits",max0(iturn4_end-1,iatel_s),iturn3_end
7917 c      call flush(iout)
7918       do i=iturn3_start,iturn3_end
7919 c        write (iout,*) "make contact list turn3",i," num_cont",
7920 c     &    num_cont_hb(i)
7921         call add_hb_contact(i,i+2,iturn3_sent_local(1,i))
7922       enddo
7923       do i=iturn4_start,iturn4_end
7924 c        write (iout,*) "make contact list turn4",i," num_cont",
7925 c     &   num_cont_hb(i)
7926         call add_hb_contact(i,i+3,iturn4_sent_local(1,i))
7927       enddo
7928       do ii=1,nat_sent
7929         i=iat_sent(ii)
7930 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
7931 c     &    num_cont_hb(i)
7932         do j=1,num_cont_hb(i)
7933         do k=1,4
7934           jjc=jcont_hb(j,i)
7935           iproc=iint_sent_local(k,jjc,ii)
7936 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
7937           if (iproc.gt.0) then
7938             ncont_sent(iproc)=ncont_sent(iproc)+1
7939             nn=ncont_sent(iproc)
7940             zapas(1,nn,iproc)=i
7941             zapas(2,nn,iproc)=jjc
7942             zapas(3,nn,iproc)=facont_hb(j,i)
7943             zapas(4,nn,iproc)=ees0p(j,i)
7944             zapas(5,nn,iproc)=ees0m(j,i)
7945             zapas(6,nn,iproc)=gacont_hbr(1,j,i)
7946             zapas(7,nn,iproc)=gacont_hbr(2,j,i)
7947             zapas(8,nn,iproc)=gacont_hbr(3,j,i)
7948             zapas(9,nn,iproc)=gacontm_hb1(1,j,i)
7949             zapas(10,nn,iproc)=gacontm_hb1(2,j,i)
7950             zapas(11,nn,iproc)=gacontm_hb1(3,j,i)
7951             zapas(12,nn,iproc)=gacontp_hb1(1,j,i)
7952             zapas(13,nn,iproc)=gacontp_hb1(2,j,i)
7953             zapas(14,nn,iproc)=gacontp_hb1(3,j,i)
7954             zapas(15,nn,iproc)=gacontm_hb2(1,j,i)
7955             zapas(16,nn,iproc)=gacontm_hb2(2,j,i)
7956             zapas(17,nn,iproc)=gacontm_hb2(3,j,i)
7957             zapas(18,nn,iproc)=gacontp_hb2(1,j,i)
7958             zapas(19,nn,iproc)=gacontp_hb2(2,j,i)
7959             zapas(20,nn,iproc)=gacontp_hb2(3,j,i)
7960             zapas(21,nn,iproc)=gacontm_hb3(1,j,i)
7961             zapas(22,nn,iproc)=gacontm_hb3(2,j,i)
7962             zapas(23,nn,iproc)=gacontm_hb3(3,j,i)
7963             zapas(24,nn,iproc)=gacontp_hb3(1,j,i)
7964             zapas(25,nn,iproc)=gacontp_hb3(2,j,i)
7965             zapas(26,nn,iproc)=gacontp_hb3(3,j,i)
7966           endif
7967         enddo
7968         enddo
7969       enddo
7970       if (lprn) then
7971       write (iout,*)
7972      &  "Numbers of contacts to be sent to other processors",
7973      &  (ncont_sent(i),i=1,ntask_cont_to)
7974       write (iout,*) "Contacts sent"
7975       do ii=1,ntask_cont_to
7976         nn=ncont_sent(ii)
7977         iproc=itask_cont_to(ii)
7978         write (iout,*) nn," contacts to processor",iproc,
7979      &   " of CONT_TO_COMM group"
7980         do i=1,nn
7981           write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
7982         enddo
7983       enddo
7984       call flush(iout)
7985       endif
7986       CorrelType=477
7987       CorrelID=fg_rank+1
7988       CorrelType1=478
7989       CorrelID1=nfgtasks+fg_rank+1
7990       ireq=0
7991 C Receive the numbers of needed contacts from other processors
7992       do ii=1,ntask_cont_from
7993         iproc=itask_cont_from(ii)
7994         ireq=ireq+1
7995         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
7996      &    FG_COMM,req(ireq),IERR)
7997       enddo
7998 c      write (iout,*) "IRECV ended"
7999 c      call flush(iout)
8000 C Send the number of contacts needed by other processors
8001       do ii=1,ntask_cont_to
8002         iproc=itask_cont_to(ii)
8003         ireq=ireq+1
8004         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
8005      &    FG_COMM,req(ireq),IERR)
8006       enddo
8007 c      write (iout,*) "ISEND ended"
8008 c      write (iout,*) "number of requests (nn)",ireq
8009       call flush(iout)
8010       if (ireq.gt.0)
8011      &  call MPI_Waitall(ireq,req,status_array,ierr)
8012 c      write (iout,*)
8013 c     &  "Numbers of contacts to be received from other processors",
8014 c     &  (ncont_recv(i),i=1,ntask_cont_from)
8015 c      call flush(iout)
8016 C Receive contacts
8017       ireq=0
8018       do ii=1,ntask_cont_from
8019         iproc=itask_cont_from(ii)
8020         nn=ncont_recv(ii)
8021 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
8022 c     &   " of CONT_TO_COMM group"
8023         call flush(iout)
8024         if (nn.gt.0) then
8025           ireq=ireq+1
8026           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
8027      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
8028 c          write (iout,*) "ireq,req",ireq,req(ireq)
8029         endif
8030       enddo
8031 C Send the contacts to processors that need them
8032       do ii=1,ntask_cont_to
8033         iproc=itask_cont_to(ii)
8034         nn=ncont_sent(ii)
8035 c        write (iout,*) nn," contacts to processor",iproc,
8036 c     &   " of CONT_TO_COMM group"
8037         if (nn.gt.0) then
8038           ireq=ireq+1
8039           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
8040      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
8041 c          write (iout,*) "ireq,req",ireq,req(ireq)
8042 c          do i=1,nn
8043 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
8044 c          enddo
8045         endif
8046       enddo
8047 c      write (iout,*) "number of requests (contacts)",ireq
8048 c      write (iout,*) "req",(req(i),i=1,4)
8049 c      call flush(iout)
8050       if (ireq.gt.0)
8051      & call MPI_Waitall(ireq,req,status_array,ierr)
8052       do iii=1,ntask_cont_from
8053         iproc=itask_cont_from(iii)
8054         nn=ncont_recv(iii)
8055         if (lprn) then
8056         write (iout,*) "Received",nn," contacts from processor",iproc,
8057      &   " of CONT_FROM_COMM group"
8058         call flush(iout)
8059         do i=1,nn
8060           write(iout,'(2f5.0,4f10.5)')(zapas_recv(j,i,iii),j=1,5)
8061         enddo
8062         call flush(iout)
8063         endif
8064         do i=1,nn
8065           ii=zapas_recv(1,i,iii)
8066 c Flag the received contacts to prevent double-counting
8067           jj=-zapas_recv(2,i,iii)
8068 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
8069 c          call flush(iout)
8070           nnn=num_cont_hb(ii)+1
8071           num_cont_hb(ii)=nnn
8072           jcont_hb(nnn,ii)=jj
8073           facont_hb(nnn,ii)=zapas_recv(3,i,iii)
8074           ees0p(nnn,ii)=zapas_recv(4,i,iii)
8075           ees0m(nnn,ii)=zapas_recv(5,i,iii)
8076           gacont_hbr(1,nnn,ii)=zapas_recv(6,i,iii)
8077           gacont_hbr(2,nnn,ii)=zapas_recv(7,i,iii)
8078           gacont_hbr(3,nnn,ii)=zapas_recv(8,i,iii)
8079           gacontm_hb1(1,nnn,ii)=zapas_recv(9,i,iii)
8080           gacontm_hb1(2,nnn,ii)=zapas_recv(10,i,iii)
8081           gacontm_hb1(3,nnn,ii)=zapas_recv(11,i,iii)
8082           gacontp_hb1(1,nnn,ii)=zapas_recv(12,i,iii)
8083           gacontp_hb1(2,nnn,ii)=zapas_recv(13,i,iii)
8084           gacontp_hb1(3,nnn,ii)=zapas_recv(14,i,iii)
8085           gacontm_hb2(1,nnn,ii)=zapas_recv(15,i,iii)
8086           gacontm_hb2(2,nnn,ii)=zapas_recv(16,i,iii)
8087           gacontm_hb2(3,nnn,ii)=zapas_recv(17,i,iii)
8088           gacontp_hb2(1,nnn,ii)=zapas_recv(18,i,iii)
8089           gacontp_hb2(2,nnn,ii)=zapas_recv(19,i,iii)
8090           gacontp_hb2(3,nnn,ii)=zapas_recv(20,i,iii)
8091           gacontm_hb3(1,nnn,ii)=zapas_recv(21,i,iii)
8092           gacontm_hb3(2,nnn,ii)=zapas_recv(22,i,iii)
8093           gacontm_hb3(3,nnn,ii)=zapas_recv(23,i,iii)
8094           gacontp_hb3(1,nnn,ii)=zapas_recv(24,i,iii)
8095           gacontp_hb3(2,nnn,ii)=zapas_recv(25,i,iii)
8096           gacontp_hb3(3,nnn,ii)=zapas_recv(26,i,iii)
8097         enddo
8098       enddo
8099       call flush(iout)
8100       if (lprn) then
8101         write (iout,'(a)') 'Contact function values after receive:'
8102         do i=nnt,nct-2
8103           write (iout,'(2i3,50(1x,i3,f5.2))')
8104      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
8105      &    j=1,num_cont_hb(i))
8106         enddo
8107         call flush(iout)
8108       endif
8109    30 continue
8110 #endif
8111       if (lprn) then
8112         write (iout,'(a)') 'Contact function values:'
8113         do i=nnt,nct-2
8114           write (iout,'(2i3,50(1x,i3,f5.2))')
8115      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
8116      &    j=1,num_cont_hb(i))
8117         enddo
8118       endif
8119       ecorr=0.0D0
8120 C Remove the loop below after debugging !!!
8121       do i=nnt,nct
8122         do j=1,3
8123           gradcorr(j,i)=0.0D0
8124           gradxorr(j,i)=0.0D0
8125         enddo
8126       enddo
8127 C Calculate the local-electrostatic correlation terms
8128       do i=min0(iatel_s,iturn4_start),max0(iatel_e,iturn3_end)
8129         i1=i+1
8130         num_conti=num_cont_hb(i)
8131         num_conti1=num_cont_hb(i+1)
8132         do jj=1,num_conti
8133           j=jcont_hb(jj,i)
8134           jp=iabs(j)
8135           do kk=1,num_conti1
8136             j1=jcont_hb(kk,i1)
8137             jp1=iabs(j1)
8138 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
8139 c     &         ' jj=',jj,' kk=',kk
8140             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
8141      &          .or. j.lt.0 .and. j1.gt.0) .and.
8142      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
8143 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
8144 C The system gains extra energy.
8145               ecorr=ecorr+ehbcorr(i,jp,i+1,jp1,jj,kk,0.72D0,0.32D0)
8146               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
8147      &            'ecorrh',i,j,ehbcorr(i,j,i+1,j1,jj,kk,0.72D0,0.32D0)
8148               n_corr=n_corr+1
8149             else if (j1.eq.j) then
8150 C Contacts I-J and I-(J+1) occur simultaneously.
8151 C The system loses extra energy.
8152 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
8153             endif
8154           enddo ! kk
8155           do kk=1,num_conti
8156             j1=jcont_hb(kk,i)
8157 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
8158 c    &         ' jj=',jj,' kk=',kk
8159             if (j1.eq.j+1) then
8160 C Contacts I-J and (I+1)-J occur simultaneously.
8161 C The system loses extra energy.
8162 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
8163             endif ! j1==j+1
8164           enddo ! kk
8165         enddo ! jj
8166       enddo ! i
8167       return
8168       end
8169 c------------------------------------------------------------------------------
8170       subroutine add_hb_contact(ii,jj,itask)
8171       implicit real*8 (a-h,o-z)
8172       include "DIMENSIONS"
8173       include "COMMON.IOUNITS"
8174       integer max_cont
8175       integer max_dim
8176       parameter (max_cont=maxconts)
8177       parameter (max_dim=26)
8178       include "COMMON.CONTACTS"
8179       double precision zapas(max_dim,maxconts,max_fg_procs),
8180      &  zapas_recv(max_dim,maxconts,max_fg_procs)
8181       common /przechowalnia/ zapas
8182       integer i,j,ii,jj,iproc,itask(4),nn
8183 c      write (iout,*) "itask",itask
8184       do i=1,2
8185         iproc=itask(i)
8186         if (iproc.gt.0) then
8187           do j=1,num_cont_hb(ii)
8188             jjc=jcont_hb(j,ii)
8189 c            write (iout,*) "i",ii," j",jj," jjc",jjc
8190             if (jjc.eq.jj) then
8191               ncont_sent(iproc)=ncont_sent(iproc)+1
8192               nn=ncont_sent(iproc)
8193               zapas(1,nn,iproc)=ii
8194               zapas(2,nn,iproc)=jjc
8195               zapas(3,nn,iproc)=facont_hb(j,ii)
8196               zapas(4,nn,iproc)=ees0p(j,ii)
8197               zapas(5,nn,iproc)=ees0m(j,ii)
8198               zapas(6,nn,iproc)=gacont_hbr(1,j,ii)
8199               zapas(7,nn,iproc)=gacont_hbr(2,j,ii)
8200               zapas(8,nn,iproc)=gacont_hbr(3,j,ii)
8201               zapas(9,nn,iproc)=gacontm_hb1(1,j,ii)
8202               zapas(10,nn,iproc)=gacontm_hb1(2,j,ii)
8203               zapas(11,nn,iproc)=gacontm_hb1(3,j,ii)
8204               zapas(12,nn,iproc)=gacontp_hb1(1,j,ii)
8205               zapas(13,nn,iproc)=gacontp_hb1(2,j,ii)
8206               zapas(14,nn,iproc)=gacontp_hb1(3,j,ii)
8207               zapas(15,nn,iproc)=gacontm_hb2(1,j,ii)
8208               zapas(16,nn,iproc)=gacontm_hb2(2,j,ii)
8209               zapas(17,nn,iproc)=gacontm_hb2(3,j,ii)
8210               zapas(18,nn,iproc)=gacontp_hb2(1,j,ii)
8211               zapas(19,nn,iproc)=gacontp_hb2(2,j,ii)
8212               zapas(20,nn,iproc)=gacontp_hb2(3,j,ii)
8213               zapas(21,nn,iproc)=gacontm_hb3(1,j,ii)
8214               zapas(22,nn,iproc)=gacontm_hb3(2,j,ii)
8215               zapas(23,nn,iproc)=gacontm_hb3(3,j,ii)
8216               zapas(24,nn,iproc)=gacontp_hb3(1,j,ii)
8217               zapas(25,nn,iproc)=gacontp_hb3(2,j,ii)
8218               zapas(26,nn,iproc)=gacontp_hb3(3,j,ii)
8219               exit
8220             endif
8221           enddo
8222         endif
8223       enddo
8224       return
8225       end
8226 c------------------------------------------------------------------------------
8227       subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,
8228      &  n_corr1)
8229 C This subroutine calculates multi-body contributions to hydrogen-bonding
8230       implicit real*8 (a-h,o-z)
8231       include 'DIMENSIONS'
8232       include 'COMMON.IOUNITS'
8233 #ifdef MPI
8234       include "mpif.h"
8235       parameter (max_cont=maxconts)
8236       parameter (max_dim=70)
8237       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
8238       double precision zapas(max_dim,maxconts,max_fg_procs),
8239      &  zapas_recv(max_dim,maxconts,max_fg_procs)
8240       common /przechowalnia/ zapas
8241       integer status(MPI_STATUS_SIZE),req(maxconts*2),
8242      &  status_array(MPI_STATUS_SIZE,maxconts*2)
8243 #endif
8244       include 'COMMON.SETUP'
8245       include 'COMMON.FFIELD'
8246       include 'COMMON.DERIV'
8247       include 'COMMON.LOCAL'
8248       include 'COMMON.INTERACT'
8249       include 'COMMON.CONTACTS'
8250       include 'COMMON.CHAIN'
8251       include 'COMMON.CONTROL'
8252       double precision gx(3),gx1(3)
8253       integer num_cont_hb_old(maxres)
8254       logical lprn,ldone
8255       double precision eello4,eello5,eelo6,eello_turn6
8256       external eello4,eello5,eello6,eello_turn6
8257 C Set lprn=.true. for debugging
8258       lprn=.false.
8259       eturn6=0.0d0
8260 #ifdef MPI
8261       do i=1,nres
8262         num_cont_hb_old(i)=num_cont_hb(i)
8263       enddo
8264       n_corr=0
8265       n_corr1=0
8266       if (nfgtasks.le.1) goto 30
8267       if (lprn) then
8268         write (iout,'(a)') 'Contact function values before RECEIVE:'
8269         do i=nnt,nct-2
8270           write (iout,'(2i3,50(1x,i2,f5.2))')
8271      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
8272      &    j=1,num_cont_hb(i))
8273         enddo
8274       endif
8275       call flush(iout)
8276       do i=1,ntask_cont_from
8277         ncont_recv(i)=0
8278       enddo
8279       do i=1,ntask_cont_to
8280         ncont_sent(i)=0
8281       enddo
8282 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
8283 c     & ntask_cont_to
8284 C Make the list of contacts to send to send to other procesors
8285       do i=iturn3_start,iturn3_end
8286 c        write (iout,*) "make contact list turn3",i," num_cont",
8287 c     &    num_cont_hb(i)
8288         call add_hb_contact_eello(i,i+2,iturn3_sent_local(1,i))
8289       enddo
8290       do i=iturn4_start,iturn4_end
8291 c        write (iout,*) "make contact list turn4",i," num_cont",
8292 c     &   num_cont_hb(i)
8293         call add_hb_contact_eello(i,i+3,iturn4_sent_local(1,i))
8294       enddo
8295       do ii=1,nat_sent
8296         i=iat_sent(ii)
8297 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
8298 c     &    num_cont_hb(i)
8299         do j=1,num_cont_hb(i)
8300         do k=1,4
8301           jjc=jcont_hb(j,i)
8302           iproc=iint_sent_local(k,jjc,ii)
8303 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
8304           if (iproc.ne.0) then
8305             ncont_sent(iproc)=ncont_sent(iproc)+1
8306             nn=ncont_sent(iproc)
8307             zapas(1,nn,iproc)=i
8308             zapas(2,nn,iproc)=jjc
8309             zapas(3,nn,iproc)=d_cont(j,i)
8310             ind=3
8311             do kk=1,3
8312               ind=ind+1
8313               zapas(ind,nn,iproc)=grij_hb_cont(kk,j,i)
8314             enddo
8315             do kk=1,2
8316               do ll=1,2
8317                 ind=ind+1
8318                 zapas(ind,nn,iproc)=a_chuj(ll,kk,j,i)
8319               enddo
8320             enddo
8321             do jj=1,5
8322               do kk=1,3
8323                 do ll=1,2
8324                   do mm=1,2
8325                     ind=ind+1
8326                     zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,i)
8327                   enddo
8328                 enddo
8329               enddo
8330             enddo
8331           endif
8332         enddo
8333         enddo
8334       enddo
8335       if (lprn) then
8336       write (iout,*)
8337      &  "Numbers of contacts to be sent to other processors",
8338      &  (ncont_sent(i),i=1,ntask_cont_to)
8339       write (iout,*) "Contacts sent"
8340       do ii=1,ntask_cont_to
8341         nn=ncont_sent(ii)
8342         iproc=itask_cont_to(ii)
8343         write (iout,*) nn," contacts to processor",iproc,
8344      &   " of CONT_TO_COMM group"
8345         do i=1,nn
8346           write(iout,'(2f5.0,10f10.5)')(zapas(j,i,ii),j=1,10)
8347         enddo
8348       enddo
8349       call flush(iout)
8350       endif
8351       CorrelType=477
8352       CorrelID=fg_rank+1
8353       CorrelType1=478
8354       CorrelID1=nfgtasks+fg_rank+1
8355       ireq=0
8356 C Receive the numbers of needed contacts from other processors
8357       do ii=1,ntask_cont_from
8358         iproc=itask_cont_from(ii)
8359         ireq=ireq+1
8360         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
8361      &    FG_COMM,req(ireq),IERR)
8362       enddo
8363 c      write (iout,*) "IRECV ended"
8364 c      call flush(iout)
8365 C Send the number of contacts needed by other processors
8366       do ii=1,ntask_cont_to
8367         iproc=itask_cont_to(ii)
8368         ireq=ireq+1
8369         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
8370      &    FG_COMM,req(ireq),IERR)
8371       enddo
8372 c      write (iout,*) "ISEND ended"
8373 c      write (iout,*) "number of requests (nn)",ireq
8374       call flush(iout)
8375       if (ireq.gt.0)
8376      &  call MPI_Waitall(ireq,req,status_array,ierr)
8377 c      write (iout,*)
8378 c     &  "Numbers of contacts to be received from other processors",
8379 c     &  (ncont_recv(i),i=1,ntask_cont_from)
8380 c      call flush(iout)
8381 C Receive contacts
8382       ireq=0
8383       do ii=1,ntask_cont_from
8384         iproc=itask_cont_from(ii)
8385         nn=ncont_recv(ii)
8386 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
8387 c     &   " of CONT_TO_COMM group"
8388         call flush(iout)
8389         if (nn.gt.0) then
8390           ireq=ireq+1
8391           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
8392      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
8393 c          write (iout,*) "ireq,req",ireq,req(ireq)
8394         endif
8395       enddo
8396 C Send the contacts to processors that need them
8397       do ii=1,ntask_cont_to
8398         iproc=itask_cont_to(ii)
8399         nn=ncont_sent(ii)
8400 c        write (iout,*) nn," contacts to processor",iproc,
8401 c     &   " of CONT_TO_COMM group"
8402         if (nn.gt.0) then
8403           ireq=ireq+1
8404           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
8405      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
8406 c          write (iout,*) "ireq,req",ireq,req(ireq)
8407 c          do i=1,nn
8408 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
8409 c          enddo
8410         endif
8411       enddo
8412 c      write (iout,*) "number of requests (contacts)",ireq
8413 c      write (iout,*) "req",(req(i),i=1,4)
8414 c      call flush(iout)
8415       if (ireq.gt.0)
8416      & call MPI_Waitall(ireq,req,status_array,ierr)
8417       do iii=1,ntask_cont_from
8418         iproc=itask_cont_from(iii)
8419         nn=ncont_recv(iii)
8420         if (lprn) then
8421         write (iout,*) "Received",nn," contacts from processor",iproc,
8422      &   " of CONT_FROM_COMM group"
8423         call flush(iout)
8424         do i=1,nn
8425           write(iout,'(2f5.0,10f10.5)')(zapas_recv(j,i,iii),j=1,10)
8426         enddo
8427         call flush(iout)
8428         endif
8429         do i=1,nn
8430           ii=zapas_recv(1,i,iii)
8431 c Flag the received contacts to prevent double-counting
8432           jj=-zapas_recv(2,i,iii)
8433 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
8434 c          call flush(iout)
8435           nnn=num_cont_hb(ii)+1
8436           num_cont_hb(ii)=nnn
8437           jcont_hb(nnn,ii)=jj
8438           d_cont(nnn,ii)=zapas_recv(3,i,iii)
8439           ind=3
8440           do kk=1,3
8441             ind=ind+1
8442             grij_hb_cont(kk,nnn,ii)=zapas_recv(ind,i,iii)
8443           enddo
8444           do kk=1,2
8445             do ll=1,2
8446               ind=ind+1
8447               a_chuj(ll,kk,nnn,ii)=zapas_recv(ind,i,iii)
8448             enddo
8449           enddo
8450           do jj=1,5
8451             do kk=1,3
8452               do ll=1,2
8453                 do mm=1,2
8454                   ind=ind+1
8455                   a_chuj_der(mm,ll,kk,jj,nnn,ii)=zapas_recv(ind,i,iii)
8456                 enddo
8457               enddo
8458             enddo
8459           enddo
8460         enddo
8461       enddo
8462       call flush(iout)
8463       if (lprn) then
8464         write (iout,'(a)') 'Contact function values after receive:'
8465         do i=nnt,nct-2
8466           write (iout,'(2i3,50(1x,i3,5f6.3))')
8467      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
8468      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
8469         enddo
8470         call flush(iout)
8471       endif
8472    30 continue
8473 #endif
8474       if (lprn) then
8475         write (iout,'(a)') 'Contact function values:'
8476         do i=nnt,nct-2
8477           write (iout,'(2i3,50(1x,i2,5f6.3))')
8478      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
8479      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
8480         enddo
8481       endif
8482       ecorr=0.0D0
8483       ecorr5=0.0d0
8484       ecorr6=0.0d0
8485 C Remove the loop below after debugging !!!
8486       do i=nnt,nct
8487         do j=1,3
8488           gradcorr(j,i)=0.0D0
8489           gradxorr(j,i)=0.0D0
8490         enddo
8491       enddo
8492 C Calculate the dipole-dipole interaction energies
8493       if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
8494       do i=iatel_s,iatel_e+1
8495         num_conti=num_cont_hb(i)
8496         do jj=1,num_conti
8497           j=jcont_hb(jj,i)
8498 #ifdef MOMENT
8499           call dipole(i,j,jj)
8500 #endif
8501         enddo
8502       enddo
8503       endif
8504 C Calculate the local-electrostatic correlation terms
8505 c                write (iout,*) "gradcorr5 in eello5 before loop"
8506 c                do iii=1,nres
8507 c                  write (iout,'(i5,3f10.5)')
8508 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
8509 c                enddo
8510       do i=min0(iatel_s,iturn4_start),max0(iatel_e+1,iturn3_end+1)
8511 c        write (iout,*) "corr loop i",i
8512         i1=i+1
8513         num_conti=num_cont_hb(i)
8514         num_conti1=num_cont_hb(i+1)
8515         do jj=1,num_conti
8516           j=jcont_hb(jj,i)
8517           jp=iabs(j)
8518           do kk=1,num_conti1
8519             j1=jcont_hb(kk,i1)
8520             jp1=iabs(j1)
8521 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
8522 c     &         ' jj=',jj,' kk=',kk
8523 c            if (j1.eq.j+1 .or. j1.eq.j-1) then
8524             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
8525      &          .or. j.lt.0 .and. j1.gt.0) .and.
8526      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
8527 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
8528 C The system gains extra energy.
8529               n_corr=n_corr+1
8530               sqd1=dsqrt(d_cont(jj,i))
8531               sqd2=dsqrt(d_cont(kk,i1))
8532               sred_geom = sqd1*sqd2
8533               IF (sred_geom.lt.cutoff_corr) THEN
8534                 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,
8535      &            ekont,fprimcont)
8536 cd               write (iout,*) 'i=',i,' j=',jp,' i1=',i1,' j1=',jp1,
8537 cd     &         ' jj=',jj,' kk=',kk
8538                 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
8539                 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
8540                 do l=1,3
8541                   g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
8542                   g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
8543                 enddo
8544                 n_corr1=n_corr1+1
8545 cd               write (iout,*) 'sred_geom=',sred_geom,
8546 cd     &          ' ekont=',ekont,' fprim=',fprimcont,
8547 cd     &          ' fac_prim1',fac_prim1,' fac_prim2',fac_prim2
8548 cd               write (iout,*) "g_contij",g_contij
8549 cd               write (iout,*) "grij_hb_cont i",grij_hb_cont(:,jj,i)
8550 cd               write (iout,*) "grij_hb_cont i1",grij_hb_cont(:,jj,i1)
8551                 call calc_eello(i,jp,i+1,jp1,jj,kk)
8552                 if (wcorr4.gt.0.0d0)
8553      &            ecorr=ecorr+eello4(i,jp,i+1,jp1,jj,kk)
8554                   if (energy_dec.and.wcorr4.gt.0.0d0)
8555      1                 write (iout,'(a6,4i5,0pf7.3)')
8556      2                'ecorr4',i,j,i+1,j1,eello4(i,jp,i+1,jp1,jj,kk)
8557 c                write (iout,*) "gradcorr5 before eello5"
8558 c                do iii=1,nres
8559 c                  write (iout,'(i5,3f10.5)')
8560 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
8561 c                enddo
8562                 if (wcorr5.gt.0.0d0)
8563      &            ecorr5=ecorr5+eello5(i,jp,i+1,jp1,jj,kk)
8564 c                write (iout,*) "gradcorr5 after eello5"
8565 c                do iii=1,nres
8566 c                  write (iout,'(i5,3f10.5)')
8567 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
8568 c                enddo
8569                   if (energy_dec.and.wcorr5.gt.0.0d0)
8570      1                 write (iout,'(a6,4i5,0pf7.3)')
8571      2                'ecorr5',i,j,i+1,j1,eello5(i,jp,i+1,jp1,jj,kk)
8572 cd                write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
8573 cd                write(2,*)'ijkl',i,jp,i+1,jp1
8574                 if (wcorr6.gt.0.0d0 .and. (jp.ne.i+4 .or. jp1.ne.i+3
8575      &               .or. wturn6.eq.0.0d0))then
8576 cd                  write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
8577                   ecorr6=ecorr6+eello6(i,jp,i+1,jp1,jj,kk)
8578                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
8579      1                'ecorr6',i,j,i+1,j1,eello6(i,jp,i+1,jp1,jj,kk)
8580 cd                write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
8581 cd     &            'ecorr6=',ecorr6
8582 cd                write (iout,'(4e15.5)') sred_geom,
8583 cd     &          dabs(eello4(i,jp,i+1,jp1,jj,kk)),
8584 cd     &          dabs(eello5(i,jp,i+1,jp1,jj,kk)),
8585 cd     &          dabs(eello6(i,jp,i+1,jp1,jj,kk))
8586                 else if (wturn6.gt.0.0d0
8587      &            .and. (jp.eq.i+4 .and. jp1.eq.i+3)) then
8588 cd                  write (iout,*) '******eturn6: i,j,i+1,j1',i,jip,i+1,jp1
8589                   eturn6=eturn6+eello_turn6(i,jj,kk)
8590                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
8591      1                 'eturn6',i,j,i+1,j1,eello_turn6(i,jj,kk)
8592 cd                  write (2,*) 'multibody_eello:eturn6',eturn6
8593                 endif
8594               ENDIF
8595 1111          continue
8596             endif
8597           enddo ! kk
8598         enddo ! jj
8599       enddo ! i
8600       do i=1,nres
8601         num_cont_hb(i)=num_cont_hb_old(i)
8602       enddo
8603 c                write (iout,*) "gradcorr5 in eello5"
8604 c                do iii=1,nres
8605 c                  write (iout,'(i5,3f10.5)')
8606 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
8607 c                enddo
8608       return
8609       end
8610 c------------------------------------------------------------------------------
8611       subroutine add_hb_contact_eello(ii,jj,itask)
8612       implicit real*8 (a-h,o-z)
8613       include "DIMENSIONS"
8614       include "COMMON.IOUNITS"
8615       integer max_cont
8616       integer max_dim
8617       parameter (max_cont=maxconts)
8618       parameter (max_dim=70)
8619       include "COMMON.CONTACTS"
8620       double precision zapas(max_dim,maxconts,max_fg_procs),
8621      &  zapas_recv(max_dim,maxconts,max_fg_procs)
8622       common /przechowalnia/ zapas
8623       integer i,j,ii,jj,iproc,itask(4),nn
8624 c      write (iout,*) "itask",itask
8625       do i=1,2
8626         iproc=itask(i)
8627         if (iproc.gt.0) then
8628           do j=1,num_cont_hb(ii)
8629             jjc=jcont_hb(j,ii)
8630 c            write (iout,*) "send turns i",ii," j",jj," jjc",jjc
8631             if (jjc.eq.jj) then
8632               ncont_sent(iproc)=ncont_sent(iproc)+1
8633               nn=ncont_sent(iproc)
8634               zapas(1,nn,iproc)=ii
8635               zapas(2,nn,iproc)=jjc
8636               zapas(3,nn,iproc)=d_cont(j,ii)
8637               ind=3
8638               do kk=1,3
8639                 ind=ind+1
8640                 zapas(ind,nn,iproc)=grij_hb_cont(kk,j,ii)
8641               enddo
8642               do kk=1,2
8643                 do ll=1,2
8644                   ind=ind+1
8645                   zapas(ind,nn,iproc)=a_chuj(ll,kk,j,ii)
8646                 enddo
8647               enddo
8648               do jj=1,5
8649                 do kk=1,3
8650                   do ll=1,2
8651                     do mm=1,2
8652                       ind=ind+1
8653                       zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,ii)
8654                     enddo
8655                   enddo
8656                 enddo
8657               enddo
8658               exit
8659             endif
8660           enddo
8661         endif
8662       enddo
8663       return
8664       end
8665 c------------------------------------------------------------------------------
8666       double precision function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
8667       implicit real*8 (a-h,o-z)
8668       include 'DIMENSIONS'
8669       include 'COMMON.IOUNITS'
8670       include 'COMMON.DERIV'
8671       include 'COMMON.INTERACT'
8672       include 'COMMON.CONTACTS'
8673       double precision gx(3),gx1(3)
8674       logical lprn
8675       lprn=.false.
8676       eij=facont_hb(jj,i)
8677       ekl=facont_hb(kk,k)
8678       ees0pij=ees0p(jj,i)
8679       ees0pkl=ees0p(kk,k)
8680       ees0mij=ees0m(jj,i)
8681       ees0mkl=ees0m(kk,k)
8682       ekont=eij*ekl
8683       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
8684 cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
8685 C Following 4 lines for diagnostics.
8686 cd    ees0pkl=0.0D0
8687 cd    ees0pij=1.0D0
8688 cd    ees0mkl=0.0D0
8689 cd    ees0mij=1.0D0
8690 c      write (iout,'(2(a,2i3,a,f10.5,a,2f10.5),a,f10.5,a,$)')
8691 c     & 'Contacts ',i,j,
8692 c     & ' eij',eij,' eesij',ees0pij,ees0mij,' and ',k,l
8693 c     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' energy=',ekont*ees,
8694 c     & 'gradcorr_long'
8695 C Calculate the multi-body contribution to energy.
8696 C      ecorr=ecorr+ekont*ees
8697 C Calculate multi-body contributions to the gradient.
8698       coeffpees0pij=coeffp*ees0pij
8699       coeffmees0mij=coeffm*ees0mij
8700       coeffpees0pkl=coeffp*ees0pkl
8701       coeffmees0mkl=coeffm*ees0mkl
8702       do ll=1,3
8703 cgrad        ghalfi=ees*ekl*gacont_hbr(ll,jj,i)
8704         gradcorr(ll,i)=gradcorr(ll,i)!+0.5d0*ghalfi
8705      &  -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+
8706      &  coeffmees0mkl*gacontm_hb1(ll,jj,i))
8707         gradcorr(ll,j)=gradcorr(ll,j)!+0.5d0*ghalfi
8708      &  -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+
8709      &  coeffmees0mkl*gacontm_hb2(ll,jj,i))
8710 cgrad        ghalfk=ees*eij*gacont_hbr(ll,kk,k)
8711         gradcorr(ll,k)=gradcorr(ll,k)!+0.5d0*ghalfk
8712      &  -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+
8713      &  coeffmees0mij*gacontm_hb1(ll,kk,k))
8714         gradcorr(ll,l)=gradcorr(ll,l)!+0.5d0*ghalfk
8715      &  -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+
8716      &  coeffmees0mij*gacontm_hb2(ll,kk,k))
8717         gradlongij=ees*ekl*gacont_hbr(ll,jj,i)-
8718      &     ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+
8719      &     coeffmees0mkl*gacontm_hb3(ll,jj,i))
8720         gradcorr_long(ll,j)=gradcorr_long(ll,j)+gradlongij
8721         gradcorr_long(ll,i)=gradcorr_long(ll,i)-gradlongij
8722         gradlongkl=ees*eij*gacont_hbr(ll,kk,k)-
8723      &     ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+
8724      &     coeffmees0mij*gacontm_hb3(ll,kk,k))
8725         gradcorr_long(ll,l)=gradcorr_long(ll,l)+gradlongkl
8726         gradcorr_long(ll,k)=gradcorr_long(ll,k)-gradlongkl
8727 c        write (iout,'(2f10.5,2x,$)') gradlongij,gradlongkl
8728       enddo
8729 c      write (iout,*)
8730 cgrad      do m=i+1,j-1
8731 cgrad        do ll=1,3
8732 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
8733 cgrad     &     ees*ekl*gacont_hbr(ll,jj,i)-
8734 cgrad     &     ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
8735 cgrad     &     coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
8736 cgrad        enddo
8737 cgrad      enddo
8738 cgrad      do m=k+1,l-1
8739 cgrad        do ll=1,3
8740 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
8741 cgrad     &     ees*eij*gacont_hbr(ll,kk,k)-
8742 cgrad     &     ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
8743 cgrad     &     coeffm*ees0mij*gacontm_hb3(ll,kk,k))
8744 cgrad        enddo
8745 cgrad      enddo
8746 c      write (iout,*) "ehbcorr",ekont*ees
8747       ehbcorr=ekont*ees
8748       return
8749       end
8750 #ifdef MOMENT
8751 C---------------------------------------------------------------------------
8752       subroutine dipole(i,j,jj)
8753       implicit real*8 (a-h,o-z)
8754       include 'DIMENSIONS'
8755       include 'COMMON.IOUNITS'
8756       include 'COMMON.CHAIN'
8757       include 'COMMON.FFIELD'
8758       include 'COMMON.DERIV'
8759       include 'COMMON.INTERACT'
8760       include 'COMMON.CONTACTS'
8761       include 'COMMON.TORSION'
8762       include 'COMMON.VAR'
8763       include 'COMMON.GEO'
8764       dimension dipi(2,2),dipj(2,2),dipderi(2),dipderj(2),auxvec(2),
8765      &  auxmat(2,2)
8766       iti1 = itortyp(itype(i+1))
8767       if (j.lt.nres-1) then
8768         itj1 = itortyp(itype(j+1))
8769       else
8770         itj1=ntortyp
8771       endif
8772       do iii=1,2
8773         dipi(iii,1)=Ub2(iii,i)
8774         dipderi(iii)=Ub2der(iii,i)
8775         dipi(iii,2)=b1(iii,i+1)
8776         dipj(iii,1)=Ub2(iii,j)
8777         dipderj(iii)=Ub2der(iii,j)
8778         dipj(iii,2)=b1(iii,j+1)
8779       enddo
8780       kkk=0
8781       do iii=1,2
8782         call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
8783         do jjj=1,2
8784           kkk=kkk+1
8785           dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
8786         enddo
8787       enddo
8788       do kkk=1,5
8789         do lll=1,3
8790           mmm=0
8791           do iii=1,2
8792             call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),
8793      &        auxvec(1))
8794             do jjj=1,2
8795               mmm=mmm+1
8796               dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
8797             enddo
8798           enddo
8799         enddo
8800       enddo
8801       call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
8802       call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
8803       do iii=1,2
8804         dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
8805       enddo
8806       call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
8807       do iii=1,2
8808         dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
8809       enddo
8810       return
8811       end
8812 #endif
8813 C---------------------------------------------------------------------------
8814       subroutine calc_eello(i,j,k,l,jj,kk)
8815 C
8816 C This subroutine computes matrices and vectors needed to calculate
8817 C the fourth-, fifth-, and sixth-order local-electrostatic terms.
8818 C
8819       implicit real*8 (a-h,o-z)
8820       include 'DIMENSIONS'
8821       include 'COMMON.IOUNITS'
8822       include 'COMMON.CHAIN'
8823       include 'COMMON.DERIV'
8824       include 'COMMON.INTERACT'
8825       include 'COMMON.CONTACTS'
8826       include 'COMMON.TORSION'
8827       include 'COMMON.VAR'
8828       include 'COMMON.GEO'
8829       include 'COMMON.FFIELD'
8830       double precision aa1(2,2),aa2(2,2),aa1t(2,2),aa2t(2,2),
8831      &  aa1tder(2,2,3,5),aa2tder(2,2,3,5),auxmat(2,2)
8832       logical lprn
8833       common /kutas/ lprn
8834 cd      write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
8835 cd     & ' jj=',jj,' kk=',kk
8836 cd      if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
8837 cd      write (iout,*) "a_chujij",((a_chuj(iii,jjj,jj,i),iii=1,2),jjj=1,2)
8838 cd      write (iout,*) "a_chujkl",((a_chuj(iii,jjj,kk,k),iii=1,2),jjj=1,2)
8839       do iii=1,2
8840         do jjj=1,2
8841           aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
8842           aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
8843         enddo
8844       enddo
8845       call transpose2(aa1(1,1),aa1t(1,1))
8846       call transpose2(aa2(1,1),aa2t(1,1))
8847       do kkk=1,5
8848         do lll=1,3
8849           call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),
8850      &      aa1tder(1,1,lll,kkk))
8851           call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),
8852      &      aa2tder(1,1,lll,kkk))
8853         enddo
8854       enddo
8855       if (l.eq.j+1) then
8856 C parallel orientation of the two CA-CA-CA frames.
8857         if (i.gt.1) then
8858           iti=itortyp(itype(i))
8859         else
8860           iti=ntortyp
8861         endif
8862         itk1=itortyp(itype(k+1))
8863         itj=itortyp(itype(j))
8864         if (l.lt.nres-1) then
8865           itl1=itortyp(itype(l+1))
8866         else
8867           itl1=ntortyp
8868         endif
8869 C A1 kernel(j+1) A2T
8870 cd        do iii=1,2
8871 cd          write (iout,'(3f10.5,5x,3f10.5)')
8872 cd     &     (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
8873 cd        enddo
8874         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
8875      &   aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),
8876      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
8877 C Following matrices are needed only for 6-th order cumulants
8878         IF (wcorr6.gt.0.0d0) THEN
8879         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
8880      &   aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),
8881      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
8882         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
8883      &   aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),
8884      &   Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
8885      &   ADtEAderx(1,1,1,1,1,1))
8886         lprn=.false.
8887         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
8888      &   aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),
8889      &   DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
8890      &   ADtEA1derx(1,1,1,1,1,1))
8891         ENDIF
8892 C End 6-th order cumulants
8893 cd        lprn=.false.
8894 cd        if (lprn) then
8895 cd        write (2,*) 'In calc_eello6'
8896 cd        do iii=1,2
8897 cd          write (2,*) 'iii=',iii
8898 cd          do kkk=1,5
8899 cd            write (2,*) 'kkk=',kkk
8900 cd            do jjj=1,2
8901 cd              write (2,'(3(2f10.5),5x)')
8902 cd     &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
8903 cd            enddo
8904 cd          enddo
8905 cd        enddo
8906 cd        endif
8907         call transpose2(EUgder(1,1,k),auxmat(1,1))
8908         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
8909         call transpose2(EUg(1,1,k),auxmat(1,1))
8910         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
8911         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
8912         do iii=1,2
8913           do kkk=1,5
8914             do lll=1,3
8915               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
8916      &          EAEAderx(1,1,lll,kkk,iii,1))
8917             enddo
8918           enddo
8919         enddo
8920 C A1T kernel(i+1) A2
8921         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
8922      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),
8923      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
8924 C Following matrices are needed only for 6-th order cumulants
8925         IF (wcorr6.gt.0.0d0) THEN
8926         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
8927      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),
8928      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
8929         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
8930      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),
8931      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
8932      &   ADtEAderx(1,1,1,1,1,2))
8933         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
8934      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),
8935      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
8936      &   ADtEA1derx(1,1,1,1,1,2))
8937         ENDIF
8938 C End 6-th order cumulants
8939         call transpose2(EUgder(1,1,l),auxmat(1,1))
8940         call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
8941         call transpose2(EUg(1,1,l),auxmat(1,1))
8942         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
8943         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
8944         do iii=1,2
8945           do kkk=1,5
8946             do lll=1,3
8947               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
8948      &          EAEAderx(1,1,lll,kkk,iii,2))
8949             enddo
8950           enddo
8951         enddo
8952 C AEAb1 and AEAb2
8953 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
8954 C They are needed only when the fifth- or the sixth-order cumulants are
8955 C indluded.
8956         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
8957         call transpose2(AEA(1,1,1),auxmat(1,1))
8958         call matvec2(auxmat(1,1),b1(1,i),AEAb1(1,1,1))
8959         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
8960         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
8961         call transpose2(AEAderg(1,1,1),auxmat(1,1))
8962         call matvec2(auxmat(1,1),b1(1,i),AEAb1derg(1,1,1))
8963         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
8964         call matvec2(AEA(1,1,1),b1(1,k+1),AEAb1(1,2,1))
8965         call matvec2(AEAderg(1,1,1),b1(1,k+1),AEAb1derg(1,2,1))
8966         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
8967         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
8968         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
8969         call transpose2(AEA(1,1,2),auxmat(1,1))
8970         call matvec2(auxmat(1,1),b1(1,j),AEAb1(1,1,2))
8971         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
8972         call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
8973         call transpose2(AEAderg(1,1,2),auxmat(1,1))
8974         call matvec2(auxmat(1,1),b1(1,j),AEAb1derg(1,1,2))
8975         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
8976         call matvec2(AEA(1,1,2),b1(1,l+1),AEAb1(1,2,2))
8977         call matvec2(AEAderg(1,1,2),b1(1,l+1),AEAb1derg(1,2,2))
8978         call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
8979         call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
8980         call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
8981 C Calculate the Cartesian derivatives of the vectors.
8982         do iii=1,2
8983           do kkk=1,5
8984             do lll=1,3
8985               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
8986               call matvec2(auxmat(1,1),b1(1,i),
8987      &          AEAb1derx(1,lll,kkk,iii,1,1))
8988               call matvec2(auxmat(1,1),Ub2(1,i),
8989      &          AEAb2derx(1,lll,kkk,iii,1,1))
8990               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
8991      &          AEAb1derx(1,lll,kkk,iii,2,1))
8992               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
8993      &          AEAb2derx(1,lll,kkk,iii,2,1))
8994               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
8995               call matvec2(auxmat(1,1),b1(1,j),
8996      &          AEAb1derx(1,lll,kkk,iii,1,2))
8997               call matvec2(auxmat(1,1),Ub2(1,j),
8998      &          AEAb2derx(1,lll,kkk,iii,1,2))
8999               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,l+1),
9000      &          AEAb1derx(1,lll,kkk,iii,2,2))
9001               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),
9002      &          AEAb2derx(1,lll,kkk,iii,2,2))
9003             enddo
9004           enddo
9005         enddo
9006         ENDIF
9007 C End vectors
9008       else
9009 C Antiparallel orientation of the two CA-CA-CA frames.
9010         if (i.gt.1) then
9011           iti=itortyp(itype(i))
9012         else
9013           iti=ntortyp
9014         endif
9015         itk1=itortyp(itype(k+1))
9016         itl=itortyp(itype(l))
9017         itj=itortyp(itype(j))
9018         if (j.lt.nres-1) then
9019           itj1=itortyp(itype(j+1))
9020         else
9021           itj1=ntortyp
9022         endif
9023 C A2 kernel(j-1)T A1T
9024         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9025      &   aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),
9026      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
9027 C Following matrices are needed only for 6-th order cumulants
9028         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
9029      &     j.eq.i+4 .and. l.eq.i+3)) THEN
9030         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9031      &   aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),
9032      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
9033         call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9034      &   aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),
9035      &   Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
9036      &   ADtEAderx(1,1,1,1,1,1))
9037         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9038      &   aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),
9039      &   DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
9040      &   ADtEA1derx(1,1,1,1,1,1))
9041         ENDIF
9042 C End 6-th order cumulants
9043         call transpose2(EUgder(1,1,k),auxmat(1,1))
9044         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
9045         call transpose2(EUg(1,1,k),auxmat(1,1))
9046         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
9047         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
9048         do iii=1,2
9049           do kkk=1,5
9050             do lll=1,3
9051               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
9052      &          EAEAderx(1,1,lll,kkk,iii,1))
9053             enddo
9054           enddo
9055         enddo
9056 C A2T kernel(i+1)T A1
9057         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
9058      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),
9059      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
9060 C Following matrices are needed only for 6-th order cumulants
9061         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
9062      &     j.eq.i+4 .and. l.eq.i+3)) THEN
9063         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
9064      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),
9065      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
9066         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
9067      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),
9068      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
9069      &   ADtEAderx(1,1,1,1,1,2))
9070         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
9071      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),
9072      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
9073      &   ADtEA1derx(1,1,1,1,1,2))
9074         ENDIF
9075 C End 6-th order cumulants
9076         call transpose2(EUgder(1,1,j),auxmat(1,1))
9077         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
9078         call transpose2(EUg(1,1,j),auxmat(1,1))
9079         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
9080         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
9081         do iii=1,2
9082           do kkk=1,5
9083             do lll=1,3
9084               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
9085      &          EAEAderx(1,1,lll,kkk,iii,2))
9086             enddo
9087           enddo
9088         enddo
9089 C AEAb1 and AEAb2
9090 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
9091 C They are needed only when the fifth- or the sixth-order cumulants are
9092 C indluded.
9093         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or.
9094      &    (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
9095         call transpose2(AEA(1,1,1),auxmat(1,1))
9096         call matvec2(auxmat(1,1),b1(1,i),AEAb1(1,1,1))
9097         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
9098         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
9099         call transpose2(AEAderg(1,1,1),auxmat(1,1))
9100         call matvec2(auxmat(1,1),b1(1,i),AEAb1derg(1,1,1))
9101         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
9102         call matvec2(AEA(1,1,1),b1(1,k+1),AEAb1(1,2,1))
9103         call matvec2(AEAderg(1,1,1),b1(1,k+1),AEAb1derg(1,2,1))
9104         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
9105         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
9106         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
9107         call transpose2(AEA(1,1,2),auxmat(1,1))
9108         call matvec2(auxmat(1,1),b1(1,j+1),AEAb1(1,1,2))
9109         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
9110         call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
9111         call transpose2(AEAderg(1,1,2),auxmat(1,1))
9112         call matvec2(auxmat(1,1),b1(1,l),AEAb1(1,1,2))
9113         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
9114         call matvec2(AEA(1,1,2),b1(1,j+1),AEAb1(1,2,2))
9115         call matvec2(AEAderg(1,1,2),b1(1,j+1),AEAb1derg(1,2,2))
9116         call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
9117         call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
9118         call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
9119 C Calculate the Cartesian derivatives of the vectors.
9120         do iii=1,2
9121           do kkk=1,5
9122             do lll=1,3
9123               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
9124               call matvec2(auxmat(1,1),b1(1,i),
9125      &          AEAb1derx(1,lll,kkk,iii,1,1))
9126               call matvec2(auxmat(1,1),Ub2(1,i),
9127      &          AEAb2derx(1,lll,kkk,iii,1,1))
9128               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
9129      &          AEAb1derx(1,lll,kkk,iii,2,1))
9130               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
9131      &          AEAb2derx(1,lll,kkk,iii,2,1))
9132               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
9133               call matvec2(auxmat(1,1),b1(1,l),
9134      &          AEAb1derx(1,lll,kkk,iii,1,2))
9135               call matvec2(auxmat(1,1),Ub2(1,l),
9136      &          AEAb2derx(1,lll,kkk,iii,1,2))
9137               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,j+1),
9138      &          AEAb1derx(1,lll,kkk,iii,2,2))
9139               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),
9140      &          AEAb2derx(1,lll,kkk,iii,2,2))
9141             enddo
9142           enddo
9143         enddo
9144         ENDIF
9145 C End vectors
9146       endif
9147       return
9148       end
9149 C---------------------------------------------------------------------------
9150       subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,
9151      &  KK,KKderg,AKA,AKAderg,AKAderx)
9152       implicit none
9153       integer nderg
9154       logical transp
9155       double precision aa1(2,2),aa2t(2,2),aa1derx(2,2,3,5),
9156      &  aa2tderx(2,2,3,5),KK(2,2),KKderg(2,2,nderg),AKA(2,2),
9157      &  AKAderg(2,2,nderg),AKAderx(2,2,3,5,2)
9158       integer iii,kkk,lll
9159       integer jjj,mmm
9160       logical lprn
9161       common /kutas/ lprn
9162       call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
9163       do iii=1,nderg
9164         call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,
9165      &    AKAderg(1,1,iii))
9166       enddo
9167 cd      if (lprn) write (2,*) 'In kernel'
9168       do kkk=1,5
9169 cd        if (lprn) write (2,*) 'kkk=',kkk
9170         do lll=1,3
9171           call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),
9172      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
9173 cd          if (lprn) then
9174 cd            write (2,*) 'lll=',lll
9175 cd            write (2,*) 'iii=1'
9176 cd            do jjj=1,2
9177 cd              write (2,'(3(2f10.5),5x)')
9178 cd     &        (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
9179 cd            enddo
9180 cd          endif
9181           call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),
9182      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
9183 cd          if (lprn) then
9184 cd            write (2,*) 'lll=',lll
9185 cd            write (2,*) 'iii=2'
9186 cd            do jjj=1,2
9187 cd              write (2,'(3(2f10.5),5x)')
9188 cd     &        (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
9189 cd            enddo
9190 cd          endif
9191         enddo
9192       enddo
9193       return
9194       end
9195 C---------------------------------------------------------------------------
9196       double precision function eello4(i,j,k,l,jj,kk)
9197       implicit real*8 (a-h,o-z)
9198       include 'DIMENSIONS'
9199       include 'COMMON.IOUNITS'
9200       include 'COMMON.CHAIN'
9201       include 'COMMON.DERIV'
9202       include 'COMMON.INTERACT'
9203       include 'COMMON.CONTACTS'
9204       include 'COMMON.TORSION'
9205       include 'COMMON.VAR'
9206       include 'COMMON.GEO'
9207       double precision pizda(2,2),ggg1(3),ggg2(3)
9208 cd      if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
9209 cd        eello4=0.0d0
9210 cd        return
9211 cd      endif
9212 cd      print *,'eello4:',i,j,k,l,jj,kk
9213 cd      write (2,*) 'i',i,' j',j,' k',k,' l',l
9214 cd      call checkint4(i,j,k,l,jj,kk,eel4_num)
9215 cold      eij=facont_hb(jj,i)
9216 cold      ekl=facont_hb(kk,k)
9217 cold      ekont=eij*ekl
9218       eel4=-EAEA(1,1,1)-EAEA(2,2,1)
9219 cd      eel41=-EAEA(1,1,2)-EAEA(2,2,2)
9220       gcorr_loc(k-1)=gcorr_loc(k-1)
9221      &   -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
9222       if (l.eq.j+1) then
9223         gcorr_loc(l-1)=gcorr_loc(l-1)
9224      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
9225       else
9226         gcorr_loc(j-1)=gcorr_loc(j-1)
9227      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
9228       endif
9229       do iii=1,2
9230         do kkk=1,5
9231           do lll=1,3
9232             derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1)
9233      &                        -EAEAderx(2,2,lll,kkk,iii,1)
9234 cd            derx(lll,kkk,iii)=0.0d0
9235           enddo
9236         enddo
9237       enddo
9238 cd      gcorr_loc(l-1)=0.0d0
9239 cd      gcorr_loc(j-1)=0.0d0
9240 cd      gcorr_loc(k-1)=0.0d0
9241 cd      eel4=1.0d0
9242 cd      write (iout,*)'Contacts have occurred for peptide groups',
9243 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l,
9244 cd     &  ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
9245       if (j.lt.nres-1) then
9246         j1=j+1
9247         j2=j-1
9248       else
9249         j1=j-1
9250         j2=j-2
9251       endif
9252       if (l.lt.nres-1) then
9253         l1=l+1
9254         l2=l-1
9255       else
9256         l1=l-1
9257         l2=l-2
9258       endif
9259       do ll=1,3
9260 cgrad        ggg1(ll)=eel4*g_contij(ll,1)
9261 cgrad        ggg2(ll)=eel4*g_contij(ll,2)
9262         glongij=eel4*g_contij(ll,1)+ekont*derx(ll,1,1)
9263         glongkl=eel4*g_contij(ll,2)+ekont*derx(ll,1,2)
9264 cgrad        ghalf=0.5d0*ggg1(ll)
9265         gradcorr(ll,i)=gradcorr(ll,i)+ekont*derx(ll,2,1)
9266         gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
9267         gradcorr(ll,j)=gradcorr(ll,j)+ekont*derx(ll,4,1)
9268         gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
9269         gradcorr_long(ll,j)=gradcorr_long(ll,j)+glongij
9270         gradcorr_long(ll,i)=gradcorr_long(ll,i)-glongij
9271 cgrad        ghalf=0.5d0*ggg2(ll)
9272         gradcorr(ll,k)=gradcorr(ll,k)+ekont*derx(ll,2,2)
9273         gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
9274         gradcorr(ll,l)=gradcorr(ll,l)+ekont*derx(ll,4,2)
9275         gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
9276         gradcorr_long(ll,l)=gradcorr_long(ll,l)+glongkl
9277         gradcorr_long(ll,k)=gradcorr_long(ll,k)-glongkl
9278       enddo
9279 cgrad      do m=i+1,j-1
9280 cgrad        do ll=1,3
9281 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
9282 cgrad        enddo
9283 cgrad      enddo
9284 cgrad      do m=k+1,l-1
9285 cgrad        do ll=1,3
9286 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
9287 cgrad        enddo
9288 cgrad      enddo
9289 cgrad      do m=i+2,j2
9290 cgrad        do ll=1,3
9291 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
9292 cgrad        enddo
9293 cgrad      enddo
9294 cgrad      do m=k+2,l2
9295 cgrad        do ll=1,3
9296 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
9297 cgrad        enddo
9298 cgrad      enddo
9299 cd      do iii=1,nres-3
9300 cd        write (2,*) iii,gcorr_loc(iii)
9301 cd      enddo
9302       eello4=ekont*eel4
9303 cd      write (2,*) 'ekont',ekont
9304 cd      write (iout,*) 'eello4',ekont*eel4
9305       return
9306       end
9307 C---------------------------------------------------------------------------
9308       double precision function eello5(i,j,k,l,jj,kk)
9309       implicit real*8 (a-h,o-z)
9310       include 'DIMENSIONS'
9311       include 'COMMON.IOUNITS'
9312       include 'COMMON.CHAIN'
9313       include 'COMMON.DERIV'
9314       include 'COMMON.INTERACT'
9315       include 'COMMON.CONTACTS'
9316       include 'COMMON.TORSION'
9317       include 'COMMON.VAR'
9318       include 'COMMON.GEO'
9319       double precision pizda(2,2),auxmat(2,2),auxmat1(2,2),vv(2)
9320       double precision ggg1(3),ggg2(3)
9321 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9322 C                                                                              C
9323 C                            Parallel chains                                   C
9324 C                                                                              C
9325 C          o             o                   o             o                   C
9326 C         /l\           / \             \   / \           / \   /              C
9327 C        /   \         /   \             \ /   \         /   \ /               C
9328 C       j| o |l1       | o |              o| o |         | o |o                C
9329 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
9330 C      \i/   \         /   \ /             /   \         /   \                 C
9331 C       o    k1             o                                                  C
9332 C         (I)          (II)                (III)          (IV)                 C
9333 C                                                                              C
9334 C      eello5_1        eello5_2            eello5_3       eello5_4             C
9335 C                                                                              C
9336 C                            Antiparallel chains                               C
9337 C                                                                              C
9338 C          o             o                   o             o                   C
9339 C         /j\           / \             \   / \           / \   /              C
9340 C        /   \         /   \             \ /   \         /   \ /               C
9341 C      j1| o |l        | o |              o| o |         | o |o                C
9342 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
9343 C      \i/   \         /   \ /             /   \         /   \                 C
9344 C       o     k1            o                                                  C
9345 C         (I)          (II)                (III)          (IV)                 C
9346 C                                                                              C
9347 C      eello5_1        eello5_2            eello5_3       eello5_4             C
9348 C                                                                              C
9349 C o denotes a local interaction, vertical lines an electrostatic interaction.  C
9350 C                                                                              C
9351 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9352 cd      if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
9353 cd        eello5=0.0d0
9354 cd        return
9355 cd      endif
9356 cd      write (iout,*)
9357 cd     &   'EELLO5: Contacts have occurred for peptide groups',i,j,
9358 cd     &   ' and',k,l
9359       itk=itortyp(itype(k))
9360       itl=itortyp(itype(l))
9361       itj=itortyp(itype(j))
9362       eello5_1=0.0d0
9363       eello5_2=0.0d0
9364       eello5_3=0.0d0
9365       eello5_4=0.0d0
9366 cd      call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
9367 cd     &   eel5_3_num,eel5_4_num)
9368       do iii=1,2
9369         do kkk=1,5
9370           do lll=1,3
9371             derx(lll,kkk,iii)=0.0d0
9372           enddo
9373         enddo
9374       enddo
9375 cd      eij=facont_hb(jj,i)
9376 cd      ekl=facont_hb(kk,k)
9377 cd      ekont=eij*ekl
9378 cd      write (iout,*)'Contacts have occurred for peptide groups',
9379 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l
9380 cd      goto 1111
9381 C Contribution from the graph I.
9382 cd      write (2,*) 'AEA  ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
9383 cd      write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
9384       call transpose2(EUg(1,1,k),auxmat(1,1))
9385       call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
9386       vv(1)=pizda(1,1)-pizda(2,2)
9387       vv(2)=pizda(1,2)+pizda(2,1)
9388       eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k))
9389      & +0.5d0*scalar2(vv(1),Dtobr2(1,i))
9390 C Explicit gradient in virtual-dihedral angles.
9391       if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1)
9392      & +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k))
9393      & +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
9394       call transpose2(EUgder(1,1,k),auxmat1(1,1))
9395       call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
9396       vv(1)=pizda(1,1)-pizda(2,2)
9397       vv(2)=pizda(1,2)+pizda(2,1)
9398       g_corr5_loc(k-1)=g_corr5_loc(k-1)
9399      & +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k))
9400      & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
9401       call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
9402       vv(1)=pizda(1,1)-pizda(2,2)
9403       vv(2)=pizda(1,2)+pizda(2,1)
9404       if (l.eq.j+1) then
9405         if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1)
9406      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
9407      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
9408       else
9409         if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1)
9410      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
9411      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
9412       endif
9413 C Cartesian gradient
9414       do iii=1,2
9415         do kkk=1,5
9416           do lll=1,3
9417             call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),
9418      &        pizda(1,1))
9419             vv(1)=pizda(1,1)-pizda(2,2)
9420             vv(2)=pizda(1,2)+pizda(2,1)
9421             derx(lll,kkk,iii)=derx(lll,kkk,iii)
9422      &       +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k))
9423      &       +0.5d0*scalar2(vv(1),Dtobr2(1,i))
9424           enddo
9425         enddo
9426       enddo
9427 c      goto 1112
9428 c1111  continue
9429 C Contribution from graph II
9430       call transpose2(EE(1,1,itk),auxmat(1,1))
9431       call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
9432       vv(1)=pizda(1,1)+pizda(2,2)
9433       vv(2)=pizda(2,1)-pizda(1,2)
9434       eello5_2=scalar2(AEAb1(1,2,1),b1(1,k))
9435      & -0.5d0*scalar2(vv(1),Ctobr(1,k))
9436 C Explicit gradient in virtual-dihedral angles.
9437       g_corr5_loc(k-1)=g_corr5_loc(k-1)
9438      & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
9439       call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
9440       vv(1)=pizda(1,1)+pizda(2,2)
9441       vv(2)=pizda(2,1)-pizda(1,2)
9442       if (l.eq.j+1) then
9443         g_corr5_loc(l-1)=g_corr5_loc(l-1)
9444      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,k))
9445      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
9446       else
9447         g_corr5_loc(j-1)=g_corr5_loc(j-1)
9448      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,k))
9449      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
9450       endif
9451 C Cartesian gradient
9452       do iii=1,2
9453         do kkk=1,5
9454           do lll=1,3
9455             call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
9456      &        pizda(1,1))
9457             vv(1)=pizda(1,1)+pizda(2,2)
9458             vv(2)=pizda(2,1)-pizda(1,2)
9459             derx(lll,kkk,iii)=derx(lll,kkk,iii)
9460      &       +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,k))
9461      &       -0.5d0*scalar2(vv(1),Ctobr(1,k))
9462           enddo
9463         enddo
9464       enddo
9465 cd      goto 1112
9466 cd1111  continue
9467       if (l.eq.j+1) then
9468 cd        goto 1110
9469 C Parallel orientation
9470 C Contribution from graph III
9471         call transpose2(EUg(1,1,l),auxmat(1,1))
9472         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
9473         vv(1)=pizda(1,1)-pizda(2,2)
9474         vv(2)=pizda(1,2)+pizda(2,1)
9475         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l))
9476      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j))
9477 C Explicit gradient in virtual-dihedral angles.
9478         g_corr5_loc(j-1)=g_corr5_loc(j-1)
9479      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l))
9480      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
9481         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
9482         vv(1)=pizda(1,1)-pizda(2,2)
9483         vv(2)=pizda(1,2)+pizda(2,1)
9484         g_corr5_loc(k-1)=g_corr5_loc(k-1)
9485      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l))
9486      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
9487         call transpose2(EUgder(1,1,l),auxmat1(1,1))
9488         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
9489         vv(1)=pizda(1,1)-pizda(2,2)
9490         vv(2)=pizda(1,2)+pizda(2,1)
9491         g_corr5_loc(l-1)=g_corr5_loc(l-1)
9492      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l))
9493      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
9494 C Cartesian gradient
9495         do iii=1,2
9496           do kkk=1,5
9497             do lll=1,3
9498               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
9499      &          pizda(1,1))
9500               vv(1)=pizda(1,1)-pizda(2,2)
9501               vv(2)=pizda(1,2)+pizda(2,1)
9502               derx(lll,kkk,iii)=derx(lll,kkk,iii)
9503      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l))
9504      &         +0.5d0*scalar2(vv(1),Dtobr2(1,j))
9505             enddo
9506           enddo
9507         enddo
9508 cd        goto 1112
9509 C Contribution from graph IV
9510 cd1110    continue
9511         call transpose2(EE(1,1,itl),auxmat(1,1))
9512         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
9513         vv(1)=pizda(1,1)+pizda(2,2)
9514         vv(2)=pizda(2,1)-pizda(1,2)
9515         eello5_4=scalar2(AEAb1(1,2,2),b1(1,l))
9516      &   -0.5d0*scalar2(vv(1),Ctobr(1,l))
9517 C Explicit gradient in virtual-dihedral angles.
9518         g_corr5_loc(l-1)=g_corr5_loc(l-1)
9519      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
9520         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
9521         vv(1)=pizda(1,1)+pizda(2,2)
9522         vv(2)=pizda(2,1)-pizda(1,2)
9523         g_corr5_loc(k-1)=g_corr5_loc(k-1)
9524      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,l))
9525      &   -0.5d0*scalar2(vv(1),Ctobr(1,l)))
9526 C Cartesian gradient
9527         do iii=1,2
9528           do kkk=1,5
9529             do lll=1,3
9530               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
9531      &          pizda(1,1))
9532               vv(1)=pizda(1,1)+pizda(2,2)
9533               vv(2)=pizda(2,1)-pizda(1,2)
9534               derx(lll,kkk,iii)=derx(lll,kkk,iii)
9535      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,l))
9536      &         -0.5d0*scalar2(vv(1),Ctobr(1,l))
9537             enddo
9538           enddo
9539         enddo
9540       else
9541 C Antiparallel orientation
9542 C Contribution from graph III
9543 c        goto 1110
9544         call transpose2(EUg(1,1,j),auxmat(1,1))
9545         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
9546         vv(1)=pizda(1,1)-pizda(2,2)
9547         vv(2)=pizda(1,2)+pizda(2,1)
9548         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j))
9549      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l))
9550 C Explicit gradient in virtual-dihedral angles.
9551         g_corr5_loc(l-1)=g_corr5_loc(l-1)
9552      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j))
9553      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
9554         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
9555         vv(1)=pizda(1,1)-pizda(2,2)
9556         vv(2)=pizda(1,2)+pizda(2,1)
9557         g_corr5_loc(k-1)=g_corr5_loc(k-1)
9558      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j))
9559      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
9560         call transpose2(EUgder(1,1,j),auxmat1(1,1))
9561         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
9562         vv(1)=pizda(1,1)-pizda(2,2)
9563         vv(2)=pizda(1,2)+pizda(2,1)
9564         g_corr5_loc(j-1)=g_corr5_loc(j-1)
9565      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j))
9566      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
9567 C Cartesian gradient
9568         do iii=1,2
9569           do kkk=1,5
9570             do lll=1,3
9571               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
9572      &          pizda(1,1))
9573               vv(1)=pizda(1,1)-pizda(2,2)
9574               vv(2)=pizda(1,2)+pizda(2,1)
9575               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
9576      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j))
9577      &         +0.5d0*scalar2(vv(1),Dtobr2(1,l))
9578             enddo
9579           enddo
9580         enddo
9581 cd        goto 1112
9582 C Contribution from graph IV
9583 1110    continue
9584         call transpose2(EE(1,1,itj),auxmat(1,1))
9585         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
9586         vv(1)=pizda(1,1)+pizda(2,2)
9587         vv(2)=pizda(2,1)-pizda(1,2)
9588         eello5_4=scalar2(AEAb1(1,2,2),b1(1,j))
9589      &   -0.5d0*scalar2(vv(1),Ctobr(1,j))
9590 C Explicit gradient in virtual-dihedral angles.
9591         g_corr5_loc(j-1)=g_corr5_loc(j-1)
9592      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
9593         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
9594         vv(1)=pizda(1,1)+pizda(2,2)
9595         vv(2)=pizda(2,1)-pizda(1,2)
9596         g_corr5_loc(k-1)=g_corr5_loc(k-1)
9597      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,j))
9598      &   -0.5d0*scalar2(vv(1),Ctobr(1,j)))
9599 C Cartesian gradient
9600         do iii=1,2
9601           do kkk=1,5
9602             do lll=1,3
9603               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
9604      &          pizda(1,1))
9605               vv(1)=pizda(1,1)+pizda(2,2)
9606               vv(2)=pizda(2,1)-pizda(1,2)
9607               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
9608      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,j))
9609      &         -0.5d0*scalar2(vv(1),Ctobr(1,j))
9610             enddo
9611           enddo
9612         enddo
9613       endif
9614 1112  continue
9615       eel5=eello5_1+eello5_2+eello5_3+eello5_4
9616 cd      if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
9617 cd        write (2,*) 'ijkl',i,j,k,l
9618 cd        write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
9619 cd     &     ' eello5_3',eello5_3,' eello5_4',eello5_4
9620 cd      endif
9621 cd      write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
9622 cd      write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
9623 cd      write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
9624 cd      write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
9625       if (j.lt.nres-1) then
9626         j1=j+1
9627         j2=j-1
9628       else
9629         j1=j-1
9630         j2=j-2
9631       endif
9632       if (l.lt.nres-1) then
9633         l1=l+1
9634         l2=l-1
9635       else
9636         l1=l-1
9637         l2=l-2
9638       endif
9639 cd      eij=1.0d0
9640 cd      ekl=1.0d0
9641 cd      ekont=1.0d0
9642 cd      write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
9643 C 2/11/08 AL Gradients over DC's connecting interacting sites will be
9644 C        summed up outside the subrouine as for the other subroutines
9645 C        handling long-range interactions. The old code is commented out
9646 C        with "cgrad" to keep track of changes.
9647       do ll=1,3
9648 cgrad        ggg1(ll)=eel5*g_contij(ll,1)
9649 cgrad        ggg2(ll)=eel5*g_contij(ll,2)
9650         gradcorr5ij=eel5*g_contij(ll,1)+ekont*derx(ll,1,1)
9651         gradcorr5kl=eel5*g_contij(ll,2)+ekont*derx(ll,1,2)
9652 c        write (iout,'(a,3i3,a,5f8.3,2i3,a,5f8.3,a,f8.3)')
9653 c     &   "ecorr5",ll,i,j," derx",derx(ll,2,1),derx(ll,3,1),derx(ll,4,1),
9654 c     &   derx(ll,5,1),k,l," derx",derx(ll,2,2),derx(ll,3,2),
9655 c     &   derx(ll,4,2),derx(ll,5,2)," ekont",ekont
9656 c        write (iout,'(a,3i3,a,3f8.3,2i3,a,3f8.3)')
9657 c     &   "ecorr5",ll,i,j," gradcorr5",g_contij(ll,1),derx(ll,1,1),
9658 c     &   gradcorr5ij,
9659 c     &   k,l," gradcorr5",g_contij(ll,2),derx(ll,1,2),gradcorr5kl
9660 cold        ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
9661 cgrad        ghalf=0.5d0*ggg1(ll)
9662 cd        ghalf=0.0d0
9663         gradcorr5(ll,i)=gradcorr5(ll,i)+ekont*derx(ll,2,1)
9664         gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
9665         gradcorr5(ll,j)=gradcorr5(ll,j)+ekont*derx(ll,4,1)
9666         gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
9667         gradcorr5_long(ll,j)=gradcorr5_long(ll,j)+gradcorr5ij
9668         gradcorr5_long(ll,i)=gradcorr5_long(ll,i)-gradcorr5ij
9669 cold        ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
9670 cgrad        ghalf=0.5d0*ggg2(ll)
9671 cd        ghalf=0.0d0
9672         gradcorr5(ll,k)=gradcorr5(ll,k)+ghalf+ekont*derx(ll,2,2)
9673         gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
9674         gradcorr5(ll,l)=gradcorr5(ll,l)+ghalf+ekont*derx(ll,4,2)
9675         gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
9676         gradcorr5_long(ll,l)=gradcorr5_long(ll,l)+gradcorr5kl
9677         gradcorr5_long(ll,k)=gradcorr5_long(ll,k)-gradcorr5kl
9678       enddo
9679 cd      goto 1112
9680 cgrad      do m=i+1,j-1
9681 cgrad        do ll=1,3
9682 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
9683 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
9684 cgrad        enddo
9685 cgrad      enddo
9686 cgrad      do m=k+1,l-1
9687 cgrad        do ll=1,3
9688 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
9689 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
9690 cgrad        enddo
9691 cgrad      enddo
9692 c1112  continue
9693 cgrad      do m=i+2,j2
9694 cgrad        do ll=1,3
9695 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
9696 cgrad        enddo
9697 cgrad      enddo
9698 cgrad      do m=k+2,l2
9699 cgrad        do ll=1,3
9700 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
9701 cgrad        enddo
9702 cgrad      enddo
9703 cd      do iii=1,nres-3
9704 cd        write (2,*) iii,g_corr5_loc(iii)
9705 cd      enddo
9706       eello5=ekont*eel5
9707 cd      write (2,*) 'ekont',ekont
9708 cd      write (iout,*) 'eello5',ekont*eel5
9709       return
9710       end
9711 c--------------------------------------------------------------------------
9712       double precision function eello6(i,j,k,l,jj,kk)
9713       implicit real*8 (a-h,o-z)
9714       include 'DIMENSIONS'
9715       include 'COMMON.IOUNITS'
9716       include 'COMMON.CHAIN'
9717       include 'COMMON.DERIV'
9718       include 'COMMON.INTERACT'
9719       include 'COMMON.CONTACTS'
9720       include 'COMMON.TORSION'
9721       include 'COMMON.VAR'
9722       include 'COMMON.GEO'
9723       include 'COMMON.FFIELD'
9724       double precision ggg1(3),ggg2(3)
9725 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
9726 cd        eello6=0.0d0
9727 cd        return
9728 cd      endif
9729 cd      write (iout,*)
9730 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
9731 cd     &   ' and',k,l
9732       eello6_1=0.0d0
9733       eello6_2=0.0d0
9734       eello6_3=0.0d0
9735       eello6_4=0.0d0
9736       eello6_5=0.0d0
9737       eello6_6=0.0d0
9738 cd      call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
9739 cd     &   eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
9740       do iii=1,2
9741         do kkk=1,5
9742           do lll=1,3
9743             derx(lll,kkk,iii)=0.0d0
9744           enddo
9745         enddo
9746       enddo
9747 cd      eij=facont_hb(jj,i)
9748 cd      ekl=facont_hb(kk,k)
9749 cd      ekont=eij*ekl
9750 cd      eij=1.0d0
9751 cd      ekl=1.0d0
9752 cd      ekont=1.0d0
9753       if (l.eq.j+1) then
9754         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
9755         eello6_2=eello6_graph1(j,i,l,k,2,.false.)
9756         eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
9757         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
9758         eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
9759         eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
9760       else
9761         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
9762         eello6_2=eello6_graph1(l,k,j,i,2,.true.)
9763         eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
9764         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
9765         if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
9766           eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
9767         else
9768           eello6_5=0.0d0
9769         endif
9770         eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
9771       endif
9772 C If turn contributions are considered, they will be handled separately.
9773       eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
9774 cd      write(iout,*) 'eello6_1',eello6_1!,' eel6_1_num',16*eel6_1_num
9775 cd      write(iout,*) 'eello6_2',eello6_2!,' eel6_2_num',16*eel6_2_num
9776 cd      write(iout,*) 'eello6_3',eello6_3!,' eel6_3_num',16*eel6_3_num
9777 cd      write(iout,*) 'eello6_4',eello6_4!,' eel6_4_num',16*eel6_4_num
9778 cd      write(iout,*) 'eello6_5',eello6_5!,' eel6_5_num',16*eel6_5_num
9779 cd      write(iout,*) 'eello6_6',eello6_6!,' eel6_6_num',16*eel6_6_num
9780 cd      goto 1112
9781       if (j.lt.nres-1) then
9782         j1=j+1
9783         j2=j-1
9784       else
9785         j1=j-1
9786         j2=j-2
9787       endif
9788       if (l.lt.nres-1) then
9789         l1=l+1
9790         l2=l-1
9791       else
9792         l1=l-1
9793         l2=l-2
9794       endif
9795       do ll=1,3
9796 cgrad        ggg1(ll)=eel6*g_contij(ll,1)
9797 cgrad        ggg2(ll)=eel6*g_contij(ll,2)
9798 cold        ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
9799 cgrad        ghalf=0.5d0*ggg1(ll)
9800 cd        ghalf=0.0d0
9801         gradcorr6ij=eel6*g_contij(ll,1)+ekont*derx(ll,1,1)
9802         gradcorr6kl=eel6*g_contij(ll,2)+ekont*derx(ll,1,2)
9803         gradcorr6(ll,i)=gradcorr6(ll,i)+ekont*derx(ll,2,1)
9804         gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
9805         gradcorr6(ll,j)=gradcorr6(ll,j)+ekont*derx(ll,4,1)
9806         gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
9807         gradcorr6_long(ll,j)=gradcorr6_long(ll,j)+gradcorr6ij
9808         gradcorr6_long(ll,i)=gradcorr6_long(ll,i)-gradcorr6ij
9809 cgrad        ghalf=0.5d0*ggg2(ll)
9810 cold        ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
9811 cd        ghalf=0.0d0
9812         gradcorr6(ll,k)=gradcorr6(ll,k)+ekont*derx(ll,2,2)
9813         gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
9814         gradcorr6(ll,l)=gradcorr6(ll,l)+ekont*derx(ll,4,2)
9815         gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
9816         gradcorr6_long(ll,l)=gradcorr6_long(ll,l)+gradcorr6kl
9817         gradcorr6_long(ll,k)=gradcorr6_long(ll,k)-gradcorr6kl
9818       enddo
9819 cd      goto 1112
9820 cgrad      do m=i+1,j-1
9821 cgrad        do ll=1,3
9822 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
9823 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
9824 cgrad        enddo
9825 cgrad      enddo
9826 cgrad      do m=k+1,l-1
9827 cgrad        do ll=1,3
9828 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
9829 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
9830 cgrad        enddo
9831 cgrad      enddo
9832 cgrad1112  continue
9833 cgrad      do m=i+2,j2
9834 cgrad        do ll=1,3
9835 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
9836 cgrad        enddo
9837 cgrad      enddo
9838 cgrad      do m=k+2,l2
9839 cgrad        do ll=1,3
9840 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
9841 cgrad        enddo
9842 cgrad      enddo
9843 cd      do iii=1,nres-3
9844 cd        write (2,*) iii,g_corr6_loc(iii)
9845 cd      enddo
9846       eello6=ekont*eel6
9847 cd      write (2,*) 'ekont',ekont
9848 cd      write (iout,*) 'eello6',ekont*eel6
9849       return
9850       end
9851 c--------------------------------------------------------------------------
9852       double precision function eello6_graph1(i,j,k,l,imat,swap)
9853       implicit real*8 (a-h,o-z)
9854       include 'DIMENSIONS'
9855       include 'COMMON.IOUNITS'
9856       include 'COMMON.CHAIN'
9857       include 'COMMON.DERIV'
9858       include 'COMMON.INTERACT'
9859       include 'COMMON.CONTACTS'
9860       include 'COMMON.TORSION'
9861       include 'COMMON.VAR'
9862       include 'COMMON.GEO'
9863       double precision vv(2),vv1(2),pizda(2,2),auxmat(2,2),pizda1(2,2)
9864       logical swap
9865       logical lprn
9866       common /kutas/ lprn
9867 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9868 C                                                                              C
9869 C      Parallel       Antiparallel                                             C
9870 C                                                                              C
9871 C          o             o                                                     C
9872 C         /l\           /j\                                                    C
9873 C        /   \         /   \                                                   C
9874 C       /| o |         | o |\                                                  C
9875 C     \ j|/k\|  /   \  |/k\|l /                                                C
9876 C      \ /   \ /     \ /   \ /                                                 C
9877 C       o     o       o     o                                                  C
9878 C       i             i                                                        C
9879 C                                                                              C
9880 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9881       itk=itortyp(itype(k))
9882       s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
9883       s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
9884       s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
9885       call transpose2(EUgC(1,1,k),auxmat(1,1))
9886       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
9887       vv1(1)=pizda1(1,1)-pizda1(2,2)
9888       vv1(2)=pizda1(1,2)+pizda1(2,1)
9889       s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
9890       vv(1)=AEAb1(1,2,imat)*b1(1,k)-AEAb1(2,2,imat)*b1(2,k)
9891       vv(2)=AEAb1(1,2,imat)*b1(2,k)+AEAb1(2,2,imat)*b1(1,k)
9892       s5=scalar2(vv(1),Dtobr2(1,i))
9893 cd      write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
9894       eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
9895       if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1)
9896      & -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i))
9897      & -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k))
9898      & +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k))
9899      & +0.5d0*scalar2(vv1(1),Dtobr2der(1,i))
9900      & +scalar2(vv(1),Dtobr2der(1,i)))
9901       call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
9902       vv1(1)=pizda1(1,1)-pizda1(2,2)
9903       vv1(2)=pizda1(1,2)+pizda1(2,1)
9904       vv(1)=AEAb1derg(1,2,imat)*b1(1,k)-AEAb1derg(2,2,imat)*b1(2,k)
9905       vv(2)=AEAb1derg(1,2,imat)*b1(2,k)+AEAb1derg(2,2,imat)*b1(1,k)
9906       if (l.eq.j+1) then
9907         g_corr6_loc(l-1)=g_corr6_loc(l-1)
9908      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
9909      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
9910      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
9911      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
9912       else
9913         g_corr6_loc(j-1)=g_corr6_loc(j-1)
9914      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
9915      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
9916      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
9917      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
9918       endif
9919       call transpose2(EUgCder(1,1,k),auxmat(1,1))
9920       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
9921       vv1(1)=pizda1(1,1)-pizda1(2,2)
9922       vv1(2)=pizda1(1,2)+pizda1(2,1)
9923       if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1)
9924      & +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k))
9925      & +scalar2(AEAb2(1,1,imat),CUgb2der(1,k))
9926      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
9927       do iii=1,2
9928         if (swap) then
9929           ind=3-iii
9930         else
9931           ind=iii
9932         endif
9933         do kkk=1,5
9934           do lll=1,3
9935             s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
9936             s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
9937             s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
9938             call transpose2(EUgC(1,1,k),auxmat(1,1))
9939             call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
9940      &        pizda1(1,1))
9941             vv1(1)=pizda1(1,1)-pizda1(2,2)
9942             vv1(2)=pizda1(1,2)+pizda1(2,1)
9943             s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
9944             vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,k)
9945      &       -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,k)
9946             vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,k)
9947      &       +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,k)
9948             s5=scalar2(vv(1),Dtobr2(1,i))
9949             derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
9950           enddo
9951         enddo
9952       enddo
9953       return
9954       end
9955 c----------------------------------------------------------------------------
9956       double precision function eello6_graph2(i,j,k,l,jj,kk,swap)
9957       implicit real*8 (a-h,o-z)
9958       include 'DIMENSIONS'
9959       include 'COMMON.IOUNITS'
9960       include 'COMMON.CHAIN'
9961       include 'COMMON.DERIV'
9962       include 'COMMON.INTERACT'
9963       include 'COMMON.CONTACTS'
9964       include 'COMMON.TORSION'
9965       include 'COMMON.VAR'
9966       include 'COMMON.GEO'
9967       logical swap
9968       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
9969      & auxvec1(2),auxvec2(2),auxmat1(2,2)
9970       logical lprn
9971       common /kutas/ lprn
9972 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9973 C                                                                              C
9974 C      Parallel       Antiparallel                                             C
9975 C                                                                              C
9976 C          o             o                                                     C
9977 C     \   /l\           /j\   /                                                C
9978 C      \ /   \         /   \ /                                                 C
9979 C       o| o |         | o |o                                                  C
9980 C     \ j|/k\|      \  |/k\|l                                                  C
9981 C      \ /   \       \ /   \                                                   C
9982 C       o             o                                                        C
9983 C       i             i                                                        C
9984 C                                                                              C
9985 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9986 cd      write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
9987 C AL 7/4/01 s1 would occur in the sixth-order moment,
9988 C           but not in a cluster cumulant
9989 #ifdef MOMENT
9990       s1=dip(1,jj,i)*dip(1,kk,k)
9991 #endif
9992       call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
9993       s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
9994       call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
9995       s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
9996       call transpose2(EUg(1,1,k),auxmat(1,1))
9997       call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
9998       vv(1)=pizda(1,1)-pizda(2,2)
9999       vv(2)=pizda(1,2)+pizda(2,1)
10000       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
10001 cd      write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
10002 #ifdef MOMENT
10003       eello6_graph2=-(s1+s2+s3+s4)
10004 #else
10005       eello6_graph2=-(s2+s3+s4)
10006 #endif
10007 c      eello6_graph2=-s3
10008 C Derivatives in gamma(i-1)
10009       if (i.gt.1) then
10010 #ifdef MOMENT
10011         s1=dipderg(1,jj,i)*dip(1,kk,k)
10012 #endif
10013         s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
10014         call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
10015         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
10016         s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
10017 #ifdef MOMENT
10018         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
10019 #else
10020         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
10021 #endif
10022 c        g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
10023       endif
10024 C Derivatives in gamma(k-1)
10025 #ifdef MOMENT
10026       s1=dip(1,jj,i)*dipderg(1,kk,k)
10027 #endif
10028       call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
10029       s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
10030       call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
10031       s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
10032       call transpose2(EUgder(1,1,k),auxmat1(1,1))
10033       call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
10034       vv(1)=pizda(1,1)-pizda(2,2)
10035       vv(2)=pizda(1,2)+pizda(2,1)
10036       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
10037 #ifdef MOMENT
10038       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
10039 #else
10040       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
10041 #endif
10042 c      g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
10043 C Derivatives in gamma(j-1) or gamma(l-1)
10044       if (j.gt.1) then
10045 #ifdef MOMENT
10046         s1=dipderg(3,jj,i)*dip(1,kk,k)
10047 #endif
10048         call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
10049         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
10050         s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
10051         call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
10052         vv(1)=pizda(1,1)-pizda(2,2)
10053         vv(2)=pizda(1,2)+pizda(2,1)
10054         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
10055 #ifdef MOMENT
10056         if (swap) then
10057           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
10058         else
10059           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
10060         endif
10061 #endif
10062         g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
10063 c        g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
10064       endif
10065 C Derivatives in gamma(l-1) or gamma(j-1)
10066       if (l.gt.1) then
10067 #ifdef MOMENT
10068         s1=dip(1,jj,i)*dipderg(3,kk,k)
10069 #endif
10070         call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
10071         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
10072         call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
10073         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
10074         call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
10075         vv(1)=pizda(1,1)-pizda(2,2)
10076         vv(2)=pizda(1,2)+pizda(2,1)
10077         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
10078 #ifdef MOMENT
10079         if (swap) then
10080           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
10081         else
10082           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
10083         endif
10084 #endif
10085         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
10086 c        g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
10087       endif
10088 C Cartesian derivatives.
10089       if (lprn) then
10090         write (2,*) 'In eello6_graph2'
10091         do iii=1,2
10092           write (2,*) 'iii=',iii
10093           do kkk=1,5
10094             write (2,*) 'kkk=',kkk
10095             do jjj=1,2
10096               write (2,'(3(2f10.5),5x)')
10097      &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
10098             enddo
10099           enddo
10100         enddo
10101       endif
10102       do iii=1,2
10103         do kkk=1,5
10104           do lll=1,3
10105 #ifdef MOMENT
10106             if (iii.eq.1) then
10107               s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
10108             else
10109               s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
10110             endif
10111 #endif
10112             call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),
10113      &        auxvec(1))
10114             s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
10115             call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),
10116      &        auxvec(1))
10117             s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
10118             call transpose2(EUg(1,1,k),auxmat(1,1))
10119             call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),
10120      &        pizda(1,1))
10121             vv(1)=pizda(1,1)-pizda(2,2)
10122             vv(2)=pizda(1,2)+pizda(2,1)
10123             s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
10124 cd            write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
10125 #ifdef MOMENT
10126             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
10127 #else
10128             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
10129 #endif
10130             if (swap) then
10131               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
10132             else
10133               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
10134             endif
10135           enddo
10136         enddo
10137       enddo
10138       return
10139       end
10140 c----------------------------------------------------------------------------
10141       double precision function eello6_graph3(i,j,k,l,jj,kk,swap)
10142       implicit real*8 (a-h,o-z)
10143       include 'DIMENSIONS'
10144       include 'COMMON.IOUNITS'
10145       include 'COMMON.CHAIN'
10146       include 'COMMON.DERIV'
10147       include 'COMMON.INTERACT'
10148       include 'COMMON.CONTACTS'
10149       include 'COMMON.TORSION'
10150       include 'COMMON.VAR'
10151       include 'COMMON.GEO'
10152       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2)
10153       logical swap
10154 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10155 C                                                                              C
10156 C      Parallel       Antiparallel                                             C
10157 C                                                                              C
10158 C          o             o                                                     C
10159 C         /l\   /   \   /j\                                                    C
10160 C        /   \ /     \ /   \                                                   C
10161 C       /| o |o       o| o |\                                                  C
10162 C       j|/k\|  /      |/k\|l /                                                C
10163 C        /   \ /       /   \ /                                                 C
10164 C       /     o       /     o                                                  C
10165 C       i             i                                                        C
10166 C                                                                              C
10167 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10168 C
10169 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
10170 C           energy moment and not to the cluster cumulant.
10171       iti=itortyp(itype(i))
10172       if (j.lt.nres-1) then
10173         itj1=itortyp(itype(j+1))
10174       else
10175         itj1=ntortyp
10176       endif
10177       itk=itortyp(itype(k))
10178       itk1=itortyp(itype(k+1))
10179       if (l.lt.nres-1) then
10180         itl1=itortyp(itype(l+1))
10181       else
10182         itl1=ntortyp
10183       endif
10184 #ifdef MOMENT
10185       s1=dip(4,jj,i)*dip(4,kk,k)
10186 #endif
10187       call matvec2(AECA(1,1,1),b1(1,k+1),auxvec(1))
10188       s2=0.5d0*scalar2(b1(1,k),auxvec(1))
10189       call matvec2(AECA(1,1,2),b1(1,l+1),auxvec(1))
10190       s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
10191       call transpose2(EE(1,1,itk),auxmat(1,1))
10192       call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
10193       vv(1)=pizda(1,1)+pizda(2,2)
10194       vv(2)=pizda(2,1)-pizda(1,2)
10195       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
10196 cd      write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4,
10197 cd     & "sum",-(s2+s3+s4)
10198 #ifdef MOMENT
10199       eello6_graph3=-(s1+s2+s3+s4)
10200 #else
10201       eello6_graph3=-(s2+s3+s4)
10202 #endif
10203 c      eello6_graph3=-s4
10204 C Derivatives in gamma(k-1)
10205       call matvec2(AECAderg(1,1,2),b1(1,l+1),auxvec(1))
10206       s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
10207       s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
10208       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
10209 C Derivatives in gamma(l-1)
10210       call matvec2(AECAderg(1,1,1),b1(1,k+1),auxvec(1))
10211       s2=0.5d0*scalar2(b1(1,k),auxvec(1))
10212       call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
10213       vv(1)=pizda(1,1)+pizda(2,2)
10214       vv(2)=pizda(2,1)-pizda(1,2)
10215       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
10216       g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
10217 C Cartesian derivatives.
10218       do iii=1,2
10219         do kkk=1,5
10220           do lll=1,3
10221 #ifdef MOMENT
10222             if (iii.eq.1) then
10223               s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
10224             else
10225               s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
10226             endif
10227 #endif
10228             call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
10229      &        auxvec(1))
10230             s2=0.5d0*scalar2(b1(1,k),auxvec(1))
10231             call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,l+1),
10232      &        auxvec(1))
10233             s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
10234             call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),
10235      &        pizda(1,1))
10236             vv(1)=pizda(1,1)+pizda(2,2)
10237             vv(2)=pizda(2,1)-pizda(1,2)
10238             s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
10239 #ifdef MOMENT
10240             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
10241 #else
10242             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
10243 #endif
10244             if (swap) then
10245               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
10246             else
10247               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
10248             endif
10249 c            derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
10250           enddo
10251         enddo
10252       enddo
10253       return
10254       end
10255 c----------------------------------------------------------------------------
10256       double precision function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
10257       implicit real*8 (a-h,o-z)
10258       include 'DIMENSIONS'
10259       include 'COMMON.IOUNITS'
10260       include 'COMMON.CHAIN'
10261       include 'COMMON.DERIV'
10262       include 'COMMON.INTERACT'
10263       include 'COMMON.CONTACTS'
10264       include 'COMMON.TORSION'
10265       include 'COMMON.VAR'
10266       include 'COMMON.GEO'
10267       include 'COMMON.FFIELD'
10268       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
10269      & auxvec1(2),auxmat1(2,2)
10270       logical swap
10271 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10272 C                                                                              C
10273 C      Parallel       Antiparallel                                             C
10274 C                                                                              C
10275 C          o             o                                                     C
10276 C         /l\   /   \   /j\                                                    C
10277 C        /   \ /     \ /   \                                                   C
10278 C       /| o |o       o| o |\                                                  C
10279 C     \ j|/k\|      \  |/k\|l                                                  C
10280 C      \ /   \       \ /   \                                                   C
10281 C       o     \       o     \                                                  C
10282 C       i             i                                                        C
10283 C                                                                              C
10284 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10285 C
10286 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
10287 C           energy moment and not to the cluster cumulant.
10288 cd      write (2,*) 'eello_graph4: wturn6',wturn6
10289       iti=itortyp(itype(i))
10290       itj=itortyp(itype(j))
10291       if (j.lt.nres-1) then
10292         itj1=itortyp(itype(j+1))
10293       else
10294         itj1=ntortyp
10295       endif
10296       itk=itortyp(itype(k))
10297       if (k.lt.nres-1) then
10298         itk1=itortyp(itype(k+1))
10299       else
10300         itk1=ntortyp
10301       endif
10302       itl=itortyp(itype(l))
10303       if (l.lt.nres-1) then
10304         itl1=itortyp(itype(l+1))
10305       else
10306         itl1=ntortyp
10307       endif
10308 cd      write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
10309 cd      write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
10310 cd     & ' itl',itl,' itl1',itl1
10311 #ifdef MOMENT
10312       if (imat.eq.1) then
10313         s1=dip(3,jj,i)*dip(3,kk,k)
10314       else
10315         s1=dip(2,jj,j)*dip(2,kk,l)
10316       endif
10317 #endif
10318       call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
10319       s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
10320       if (j.eq.l+1) then
10321         call matvec2(ADtEA1(1,1,3-imat),b1(1,j+1),auxvec1(1))
10322         s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
10323       else
10324         call matvec2(ADtEA1(1,1,3-imat),b1(1,l+1),auxvec1(1))
10325         s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
10326       endif
10327       call transpose2(EUg(1,1,k),auxmat(1,1))
10328       call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
10329       vv(1)=pizda(1,1)-pizda(2,2)
10330       vv(2)=pizda(2,1)+pizda(1,2)
10331       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
10332 cd      write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
10333 #ifdef MOMENT
10334       eello6_graph4=-(s1+s2+s3+s4)
10335 #else
10336       eello6_graph4=-(s2+s3+s4)
10337 #endif
10338 C Derivatives in gamma(i-1)
10339       if (i.gt.1) then
10340 #ifdef MOMENT
10341         if (imat.eq.1) then
10342           s1=dipderg(2,jj,i)*dip(3,kk,k)
10343         else
10344           s1=dipderg(4,jj,j)*dip(2,kk,l)
10345         endif
10346 #endif
10347         s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
10348         if (j.eq.l+1) then
10349           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,j+1),auxvec1(1))
10350           s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
10351         else
10352           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,l+1),auxvec1(1))
10353           s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
10354         endif
10355         s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
10356         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
10357 cd          write (2,*) 'turn6 derivatives'
10358 #ifdef MOMENT
10359           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
10360 #else
10361           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
10362 #endif
10363         else
10364 #ifdef MOMENT
10365           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
10366 #else
10367           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
10368 #endif
10369         endif
10370       endif
10371 C Derivatives in gamma(k-1)
10372 #ifdef MOMENT
10373       if (imat.eq.1) then
10374         s1=dip(3,jj,i)*dipderg(2,kk,k)
10375       else
10376         s1=dip(2,jj,j)*dipderg(4,kk,l)
10377       endif
10378 #endif
10379       call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
10380       s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
10381       if (j.eq.l+1) then
10382         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,j+1),auxvec1(1))
10383         s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
10384       else
10385         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,l+1),auxvec1(1))
10386         s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
10387       endif
10388       call transpose2(EUgder(1,1,k),auxmat1(1,1))
10389       call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
10390       vv(1)=pizda(1,1)-pizda(2,2)
10391       vv(2)=pizda(2,1)+pizda(1,2)
10392       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
10393       if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
10394 #ifdef MOMENT
10395         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
10396 #else
10397         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
10398 #endif
10399       else
10400 #ifdef MOMENT
10401         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
10402 #else
10403         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
10404 #endif
10405       endif
10406 C Derivatives in gamma(j-1) or gamma(l-1)
10407       if (l.eq.j+1 .and. l.gt.1) then
10408         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
10409         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
10410         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
10411         vv(1)=pizda(1,1)-pizda(2,2)
10412         vv(2)=pizda(2,1)+pizda(1,2)
10413         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
10414         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
10415       else if (j.gt.1) then
10416         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
10417         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
10418         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
10419         vv(1)=pizda(1,1)-pizda(2,2)
10420         vv(2)=pizda(2,1)+pizda(1,2)
10421         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
10422         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
10423           gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
10424         else
10425           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
10426         endif
10427       endif
10428 C Cartesian derivatives.
10429       do iii=1,2
10430         do kkk=1,5
10431           do lll=1,3
10432 #ifdef MOMENT
10433             if (iii.eq.1) then
10434               if (imat.eq.1) then
10435                 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
10436               else
10437                 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
10438               endif
10439             else
10440               if (imat.eq.1) then
10441                 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
10442               else
10443                 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
10444               endif
10445             endif
10446 #endif
10447             call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),
10448      &        auxvec(1))
10449             s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
10450             if (j.eq.l+1) then
10451               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
10452      &          b1(1,j+1),auxvec(1))
10453               s3=-0.5d0*scalar2(b1(1,j),auxvec(1))
10454             else
10455               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
10456      &          b1(1,l+1),auxvec(1))
10457               s3=-0.5d0*scalar2(b1(1,l),auxvec(1))
10458             endif
10459             call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
10460      &        pizda(1,1))
10461             vv(1)=pizda(1,1)-pizda(2,2)
10462             vv(2)=pizda(2,1)+pizda(1,2)
10463             s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
10464             if (swap) then
10465               if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
10466 #ifdef MOMENT
10467                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
10468      &             -(s1+s2+s4)
10469 #else
10470                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
10471      &             -(s2+s4)
10472 #endif
10473                 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
10474               else
10475 #ifdef MOMENT
10476                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
10477 #else
10478                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
10479 #endif
10480                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
10481               endif
10482             else
10483 #ifdef MOMENT
10484               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
10485 #else
10486               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
10487 #endif
10488               if (l.eq.j+1) then
10489                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
10490               else
10491                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
10492               endif
10493             endif
10494           enddo
10495         enddo
10496       enddo
10497       return
10498       end
10499 c----------------------------------------------------------------------------
10500       double precision function eello_turn6(i,jj,kk)
10501       implicit real*8 (a-h,o-z)
10502       include 'DIMENSIONS'
10503       include 'COMMON.IOUNITS'
10504       include 'COMMON.CHAIN'
10505       include 'COMMON.DERIV'
10506       include 'COMMON.INTERACT'
10507       include 'COMMON.CONTACTS'
10508       include 'COMMON.TORSION'
10509       include 'COMMON.VAR'
10510       include 'COMMON.GEO'
10511       double precision vtemp1(2),vtemp2(2),vtemp3(2),vtemp4(2),
10512      &  atemp(2,2),auxmat(2,2),achuj_temp(2,2),gtemp(2,2),gvec(2),
10513      &  ggg1(3),ggg2(3)
10514       double precision vtemp1d(2),vtemp2d(2),vtemp3d(2),vtemp4d(2),
10515      &  atempd(2,2),auxmatd(2,2),achuj_tempd(2,2),gtempd(2,2),gvecd(2)
10516 C 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
10517 C           the respective energy moment and not to the cluster cumulant.
10518       s1=0.0d0
10519       s8=0.0d0
10520       s13=0.0d0
10521 c
10522       eello_turn6=0.0d0
10523       j=i+4
10524       k=i+1
10525       l=i+3
10526       iti=itortyp(itype(i))
10527       itk=itortyp(itype(k))
10528       itk1=itortyp(itype(k+1))
10529       itl=itortyp(itype(l))
10530       itj=itortyp(itype(j))
10531 cd      write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
10532 cd      write (2,*) 'i',i,' k',k,' j',j,' l',l
10533 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
10534 cd        eello6=0.0d0
10535 cd        return
10536 cd      endif
10537 cd      write (iout,*)
10538 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
10539 cd     &   ' and',k,l
10540 cd      call checkint_turn6(i,jj,kk,eel_turn6_num)
10541       do iii=1,2
10542         do kkk=1,5
10543           do lll=1,3
10544             derx_turn(lll,kkk,iii)=0.0d0
10545           enddo
10546         enddo
10547       enddo
10548 cd      eij=1.0d0
10549 cd      ekl=1.0d0
10550 cd      ekont=1.0d0
10551       eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
10552 cd      eello6_5=0.0d0
10553 cd      write (2,*) 'eello6_5',eello6_5
10554 #ifdef MOMENT
10555       call transpose2(AEA(1,1,1),auxmat(1,1))
10556       call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
10557       ss1=scalar2(Ub2(1,i+2),b1(1,l))
10558       s1 = (auxmat(1,1)+auxmat(2,2))*ss1
10559 #endif
10560       call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1(1))
10561       call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
10562       s2 = scalar2(b1(1,k),vtemp1(1))
10563 #ifdef MOMENT
10564       call transpose2(AEA(1,1,2),atemp(1,1))
10565       call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
10566       call matvec2(Ug2(1,1,i+2),dd(1,1,itk1),vtemp2(1))
10567       s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
10568 #endif
10569       call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
10570       call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
10571       s12 = scalar2(Ub2(1,i+2),vtemp3(1))
10572 #ifdef MOMENT
10573       call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
10574       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
10575       call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
10576       call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
10577       ss13 = scalar2(b1(1,k),vtemp4(1))
10578       s13 = (gtemp(1,1)+gtemp(2,2))*ss13
10579 #endif
10580 c      write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
10581 c      s1=0.0d0
10582 c      s2=0.0d0
10583 c      s8=0.0d0
10584 c      s12=0.0d0
10585 c      s13=0.0d0
10586       eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
10587 C Derivatives in gamma(i+2)
10588       s1d =0.0d0
10589       s8d =0.0d0
10590 #ifdef MOMENT
10591       call transpose2(AEA(1,1,1),auxmatd(1,1))
10592       call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
10593       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
10594       call transpose2(AEAderg(1,1,2),atempd(1,1))
10595       call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
10596       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
10597 #endif
10598       call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
10599       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
10600       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
10601 c      s1d=0.0d0
10602 c      s2d=0.0d0
10603 c      s8d=0.0d0
10604 c      s12d=0.0d0
10605 c      s13d=0.0d0
10606       gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
10607 C Derivatives in gamma(i+3)
10608 #ifdef MOMENT
10609       call transpose2(AEA(1,1,1),auxmatd(1,1))
10610       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
10611       ss1d=scalar2(Ub2der(1,i+2),b1(1,l))
10612       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
10613 #endif
10614       call matvec2(EUgder(1,1,i+2),b1(1,l),vtemp1d(1))
10615       call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
10616       s2d = scalar2(b1(1,k),vtemp1d(1))
10617 #ifdef MOMENT
10618       call matvec2(Ug2der(1,1,i+2),dd(1,1,itk1),vtemp2d(1))
10619       s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2d(1))
10620 #endif
10621       s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
10622 #ifdef MOMENT
10623       call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
10624       call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
10625       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
10626 #endif
10627 c      s1d=0.0d0
10628 c      s2d=0.0d0
10629 c      s8d=0.0d0
10630 c      s12d=0.0d0
10631 c      s13d=0.0d0
10632 #ifdef MOMENT
10633       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
10634      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
10635 #else
10636       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
10637      &               -0.5d0*ekont*(s2d+s12d)
10638 #endif
10639 C Derivatives in gamma(i+4)
10640       call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
10641       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
10642       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
10643 #ifdef MOMENT
10644       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
10645       call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
10646       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
10647 #endif
10648 c      s1d=0.0d0
10649 c      s2d=0.0d0
10650 c      s8d=0.0d0
10651 C      s12d=0.0d0
10652 c      s13d=0.0d0
10653 #ifdef MOMENT
10654       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
10655 #else
10656       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
10657 #endif
10658 C Derivatives in gamma(i+5)
10659 #ifdef MOMENT
10660       call transpose2(AEAderg(1,1,1),auxmatd(1,1))
10661       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
10662       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
10663 #endif
10664       call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1d(1))
10665       call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
10666       s2d = scalar2(b1(1,k),vtemp1d(1))
10667 #ifdef MOMENT
10668       call transpose2(AEA(1,1,2),atempd(1,1))
10669       call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
10670       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
10671 #endif
10672       call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
10673       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
10674 #ifdef MOMENT
10675       call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
10676       ss13d = scalar2(b1(1,k),vtemp4d(1))
10677       s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
10678 #endif
10679 c      s1d=0.0d0
10680 c      s2d=0.0d0
10681 c      s8d=0.0d0
10682 c      s12d=0.0d0
10683 c      s13d=0.0d0
10684 #ifdef MOMENT
10685       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
10686      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
10687 #else
10688       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
10689      &               -0.5d0*ekont*(s2d+s12d)
10690 #endif
10691 C Cartesian derivatives
10692       do iii=1,2
10693         do kkk=1,5
10694           do lll=1,3
10695 #ifdef MOMENT
10696             call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
10697             call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
10698             s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
10699 #endif
10700             call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1(1))
10701             call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),
10702      &          vtemp1d(1))
10703             s2d = scalar2(b1(1,k),vtemp1d(1))
10704 #ifdef MOMENT
10705             call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
10706             call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
10707             s8d = -(atempd(1,1)+atempd(2,2))*
10708      &           scalar2(cc(1,1,itl),vtemp2(1))
10709 #endif
10710             call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),
10711      &           auxmatd(1,1))
10712             call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
10713             s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
10714 c      s1d=0.0d0
10715 c      s2d=0.0d0
10716 c      s8d=0.0d0
10717 c      s12d=0.0d0
10718 c      s13d=0.0d0
10719 #ifdef MOMENT
10720             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
10721      &        - 0.5d0*(s1d+s2d)
10722 #else
10723             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
10724      &        - 0.5d0*s2d
10725 #endif
10726 #ifdef MOMENT
10727             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
10728      &        - 0.5d0*(s8d+s12d)
10729 #else
10730             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
10731      &        - 0.5d0*s12d
10732 #endif
10733           enddo
10734         enddo
10735       enddo
10736 #ifdef MOMENT
10737       do kkk=1,5
10738         do lll=1,3
10739           call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),
10740      &      achuj_tempd(1,1))
10741           call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
10742           call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
10743           s13d=(gtempd(1,1)+gtempd(2,2))*ss13
10744           derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
10745           call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),
10746      &      vtemp4d(1))
10747           ss13d = scalar2(b1(1,k),vtemp4d(1))
10748           s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
10749           derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
10750         enddo
10751       enddo
10752 #endif
10753 cd      write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
10754 cd     &  16*eel_turn6_num
10755 cd      goto 1112
10756       if (j.lt.nres-1) then
10757         j1=j+1
10758         j2=j-1
10759       else
10760         j1=j-1
10761         j2=j-2
10762       endif
10763       if (l.lt.nres-1) then
10764         l1=l+1
10765         l2=l-1
10766       else
10767         l1=l-1
10768         l2=l-2
10769       endif
10770       do ll=1,3
10771 cgrad        ggg1(ll)=eel_turn6*g_contij(ll,1)
10772 cgrad        ggg2(ll)=eel_turn6*g_contij(ll,2)
10773 cgrad        ghalf=0.5d0*ggg1(ll)
10774 cd        ghalf=0.0d0
10775         gturn6ij=eel_turn6*g_contij(ll,1)+ekont*derx_turn(ll,1,1)
10776         gturn6kl=eel_turn6*g_contij(ll,2)+ekont*derx_turn(ll,1,2)
10777         gcorr6_turn(ll,i)=gcorr6_turn(ll,i)!+ghalf
10778      &    +ekont*derx_turn(ll,2,1)
10779         gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
10780         gcorr6_turn(ll,j)=gcorr6_turn(ll,j)!+ghalf
10781      &    +ekont*derx_turn(ll,4,1)
10782         gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
10783         gcorr6_turn_long(ll,j)=gcorr6_turn_long(ll,j)+gturn6ij
10784         gcorr6_turn_long(ll,i)=gcorr6_turn_long(ll,i)-gturn6ij
10785 cgrad        ghalf=0.5d0*ggg2(ll)
10786 cd        ghalf=0.0d0
10787         gcorr6_turn(ll,k)=gcorr6_turn(ll,k)!+ghalf
10788      &    +ekont*derx_turn(ll,2,2)
10789         gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
10790         gcorr6_turn(ll,l)=gcorr6_turn(ll,l)!+ghalf
10791      &    +ekont*derx_turn(ll,4,2)
10792         gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
10793         gcorr6_turn_long(ll,l)=gcorr6_turn_long(ll,l)+gturn6kl
10794         gcorr6_turn_long(ll,k)=gcorr6_turn_long(ll,k)-gturn6kl
10795       enddo
10796 cd      goto 1112
10797 cgrad      do m=i+1,j-1
10798 cgrad        do ll=1,3
10799 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
10800 cgrad        enddo
10801 cgrad      enddo
10802 cgrad      do m=k+1,l-1
10803 cgrad        do ll=1,3
10804 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
10805 cgrad        enddo
10806 cgrad      enddo
10807 cgrad1112  continue
10808 cgrad      do m=i+2,j2
10809 cgrad        do ll=1,3
10810 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
10811 cgrad        enddo
10812 cgrad      enddo
10813 cgrad      do m=k+2,l2
10814 cgrad        do ll=1,3
10815 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
10816 cgrad        enddo
10817 cgrad      enddo
10818 cd      do iii=1,nres-3
10819 cd        write (2,*) iii,g_corr6_loc(iii)
10820 cd      enddo
10821       eello_turn6=ekont*eel_turn6
10822 cd      write (2,*) 'ekont',ekont
10823 cd      write (2,*) 'eel_turn6',ekont*eel_turn6
10824       return
10825       end
10826
10827 C-----------------------------------------------------------------------------
10828       double precision function scalar(u,v)
10829 !DIR$ INLINEALWAYS scalar
10830 #ifndef OSF
10831 cDEC$ ATTRIBUTES FORCEINLINE::scalar
10832 #endif
10833       implicit none
10834       double precision u(3),v(3)
10835 cd      double precision sc
10836 cd      integer i
10837 cd      sc=0.0d0
10838 cd      do i=1,3
10839 cd        sc=sc+u(i)*v(i)
10840 cd      enddo
10841 cd      scalar=sc
10842
10843       scalar=u(1)*v(1)+u(2)*v(2)+u(3)*v(3)
10844       return
10845       end
10846 crc-------------------------------------------------
10847       SUBROUTINE MATVEC2(A1,V1,V2)
10848 !DIR$ INLINEALWAYS MATVEC2
10849 #ifndef OSF
10850 cDEC$ ATTRIBUTES FORCEINLINE::MATVEC2
10851 #endif
10852       implicit real*8 (a-h,o-z)
10853       include 'DIMENSIONS'
10854       DIMENSION A1(2,2),V1(2),V2(2)
10855 c      DO 1 I=1,2
10856 c        VI=0.0
10857 c        DO 3 K=1,2
10858 c    3     VI=VI+A1(I,K)*V1(K)
10859 c        Vaux(I)=VI
10860 c    1 CONTINUE
10861
10862       vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
10863       vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
10864
10865       v2(1)=vaux1
10866       v2(2)=vaux2
10867       END
10868 C---------------------------------------
10869       SUBROUTINE MATMAT2(A1,A2,A3)
10870 #ifndef OSF
10871 cDEC$ ATTRIBUTES FORCEINLINE::MATMAT2
10872 #endif
10873       implicit real*8 (a-h,o-z)
10874       include 'DIMENSIONS'
10875       DIMENSION A1(2,2),A2(2,2),A3(2,2)
10876 c      DIMENSION AI3(2,2)
10877 c        DO  J=1,2
10878 c          A3IJ=0.0
10879 c          DO K=1,2
10880 c           A3IJ=A3IJ+A1(I,K)*A2(K,J)
10881 c          enddo
10882 c          A3(I,J)=A3IJ
10883 c       enddo
10884 c      enddo
10885
10886       ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
10887       ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
10888       ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
10889       ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
10890
10891       A3(1,1)=AI3_11
10892       A3(2,1)=AI3_21
10893       A3(1,2)=AI3_12
10894       A3(2,2)=AI3_22
10895       END
10896
10897 c-------------------------------------------------------------------------
10898       double precision function scalar2(u,v)
10899 !DIR$ INLINEALWAYS scalar2
10900       implicit none
10901       double precision u(2),v(2)
10902       double precision sc
10903       integer i
10904       scalar2=u(1)*v(1)+u(2)*v(2)
10905       return
10906       end
10907
10908 C-----------------------------------------------------------------------------
10909
10910       subroutine transpose2(a,at)
10911 !DIR$ INLINEALWAYS transpose2
10912 #ifndef OSF
10913 cDEC$ ATTRIBUTES FORCEINLINE::transpose2
10914 #endif
10915       implicit none
10916       double precision a(2,2),at(2,2)
10917       at(1,1)=a(1,1)
10918       at(1,2)=a(2,1)
10919       at(2,1)=a(1,2)
10920       at(2,2)=a(2,2)
10921       return
10922       end
10923 c--------------------------------------------------------------------------
10924       subroutine transpose(n,a,at)
10925       implicit none
10926       integer n,i,j
10927       double precision a(n,n),at(n,n)
10928       do i=1,n
10929         do j=1,n
10930           at(j,i)=a(i,j)
10931         enddo
10932       enddo
10933       return
10934       end
10935 C---------------------------------------------------------------------------
10936       subroutine prodmat3(a1,a2,kk,transp,prod)
10937 !DIR$ INLINEALWAYS prodmat3
10938 #ifndef OSF
10939 cDEC$ ATTRIBUTES FORCEINLINE::prodmat3
10940 #endif
10941       implicit none
10942       integer i,j
10943       double precision a1(2,2),a2(2,2),a2t(2,2),kk(2,2),prod(2,2)
10944       logical transp
10945 crc      double precision auxmat(2,2),prod_(2,2)
10946
10947       if (transp) then
10948 crc        call transpose2(kk(1,1),auxmat(1,1))
10949 crc        call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
10950 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
10951
10952            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1)
10953      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
10954            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2)
10955      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
10956            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1)
10957      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
10958            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2)
10959      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
10960
10961       else
10962 crc        call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
10963 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
10964
10965            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1)
10966      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
10967            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2)
10968      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
10969            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1)
10970      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
10971            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2)
10972      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
10973
10974       endif
10975 c      call transpose2(a2(1,1),a2t(1,1))
10976
10977 crc      print *,transp
10978 crc      print *,((prod_(i,j),i=1,2),j=1,2)
10979 crc      print *,((prod(i,j),i=1,2),j=1,2)
10980
10981       return
10982       end
10983 CCC----------------------------------------------
10984       subroutine Eliptransfer(eliptran)
10985       implicit real*8 (a-h,o-z)
10986       include 'DIMENSIONS'
10987       include 'COMMON.GEO'
10988       include 'COMMON.VAR'
10989       include 'COMMON.LOCAL'
10990       include 'COMMON.CHAIN'
10991       include 'COMMON.DERIV'
10992       include 'COMMON.NAMES'
10993       include 'COMMON.INTERACT'
10994       include 'COMMON.IOUNITS'
10995       include 'COMMON.CALC'
10996       include 'COMMON.CONTROL'
10997       include 'COMMON.SPLITELE'
10998       include 'COMMON.SBRIDGE'
10999 C this is done by Adasko
11000 C      print *,"wchodze"
11001 C structure of box:
11002 C      water
11003 C--bordliptop-- buffore starts
11004 C--bufliptop--- here true lipid starts
11005 C      lipid
11006 C--buflipbot--- lipid ends buffore starts
11007 C--bordlipbot--buffore ends
11008       eliptran=0.0
11009       do i=ilip_start,ilip_end
11010 C       do i=1,1
11011         if (itype(i).eq.ntyp1) cycle
11012
11013         positi=(mod(((c(3,i)+c(3,i+1))/2.0d0),boxzsize))
11014         if (positi.le.0) positi=positi+boxzsize
11015 C        print *,i
11016 C first for peptide groups
11017 c for each residue check if it is in lipid or lipid water border area
11018        if ((positi.gt.bordlipbot)
11019      &.and.(positi.lt.bordliptop)) then
11020 C the energy transfer exist
11021         if (positi.lt.buflipbot) then
11022 C what fraction I am in
11023          fracinbuf=1.0d0-
11024      &        ((positi-bordlipbot)/lipbufthick)
11025 C lipbufthick is thickenes of lipid buffore
11026          sslip=sscalelip(fracinbuf)
11027          ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
11028          eliptran=eliptran+sslip*pepliptran
11029          gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
11030          gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
11031 C         gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
11032
11033 C        print *,"doing sccale for lower part"
11034 C         print *,i,sslip,fracinbuf,ssgradlip
11035         elseif (positi.gt.bufliptop) then
11036          fracinbuf=1.0d0-((bordliptop-positi)/lipbufthick)
11037          sslip=sscalelip(fracinbuf)
11038          ssgradlip=sscagradlip(fracinbuf)/lipbufthick
11039          eliptran=eliptran+sslip*pepliptran
11040          gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
11041          gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
11042 C         gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
11043 C          print *, "doing sscalefor top part"
11044 C         print *,i,sslip,fracinbuf,ssgradlip
11045         else
11046          eliptran=eliptran+pepliptran
11047 C         print *,"I am in true lipid"
11048         endif
11049 C       else
11050 C       eliptran=elpitran+0.0 ! I am in water
11051        endif
11052        enddo
11053 C       print *, "nic nie bylo w lipidzie?"
11054 C now multiply all by the peptide group transfer factor
11055 C       eliptran=eliptran*pepliptran
11056 C now the same for side chains
11057 CV       do i=1,1
11058        do i=ilip_start,ilip_end
11059         if (itype(i).eq.ntyp1) cycle
11060         positi=(mod(c(3,i+nres),boxzsize))
11061         if (positi.le.0) positi=positi+boxzsize
11062 C       print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop
11063 c for each residue check if it is in lipid or lipid water border area
11064 C       respos=mod(c(3,i+nres),boxzsize)
11065 C       print *,positi,bordlipbot,buflipbot
11066        if ((positi.gt.bordlipbot)
11067      & .and.(positi.lt.bordliptop)) then
11068 C the energy transfer exist
11069         if (positi.lt.buflipbot) then
11070          fracinbuf=1.0d0-
11071      &     ((positi-bordlipbot)/lipbufthick)
11072 C lipbufthick is thickenes of lipid buffore
11073          sslip=sscalelip(fracinbuf)
11074          ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
11075          eliptran=eliptran+sslip*liptranene(itype(i))
11076          gliptranx(3,i)=gliptranx(3,i)
11077      &+ssgradlip*liptranene(itype(i))
11078          gliptranc(3,i-1)= gliptranc(3,i-1)
11079      &+ssgradlip*liptranene(itype(i))
11080 C         print *,"doing sccale for lower part"
11081         elseif (positi.gt.bufliptop) then
11082          fracinbuf=1.0d0-
11083      &((bordliptop-positi)/lipbufthick)
11084          sslip=sscalelip(fracinbuf)
11085          ssgradlip=sscagradlip(fracinbuf)/lipbufthick
11086          eliptran=eliptran+sslip*liptranene(itype(i))
11087          gliptranx(3,i)=gliptranx(3,i)
11088      &+ssgradlip*liptranene(itype(i))
11089          gliptranc(3,i-1)= gliptranc(3,i-1)
11090      &+ssgradlip*liptranene(itype(i))
11091 C          print *, "doing sscalefor top part",sslip,fracinbuf
11092         else
11093          eliptran=eliptran+liptranene(itype(i))
11094 C         print *,"I am in true lipid"
11095         endif
11096         endif ! if in lipid or buffor
11097 C       else
11098 C       eliptran=elpitran+0.0 ! I am in water
11099        enddo
11100        return
11101        end
11102 C---------------------------------------------------------
11103 C AFM soubroutine for constant force
11104        subroutine AFMforce(Eafmforce)
11105        implicit real*8 (a-h,o-z)
11106       include 'DIMENSIONS'
11107       include 'COMMON.GEO'
11108       include 'COMMON.VAR'
11109       include 'COMMON.LOCAL'
11110       include 'COMMON.CHAIN'
11111       include 'COMMON.DERIV'
11112       include 'COMMON.NAMES'
11113       include 'COMMON.INTERACT'
11114       include 'COMMON.IOUNITS'
11115       include 'COMMON.CALC'
11116       include 'COMMON.CONTROL'
11117       include 'COMMON.SPLITELE'
11118       include 'COMMON.SBRIDGE'
11119       real*8 diffafm(3)
11120       dist=0.0d0
11121       Eafmforce=0.0d0
11122       do i=1,3
11123       diffafm(i)=c(i,afmend)-c(i,afmbeg)
11124       dist=dist+diffafm(i)**2
11125       enddo
11126       dist=dsqrt(dist)
11127       Eafmforce=-forceAFMconst*(dist-distafminit)
11128       do i=1,3
11129       gradafm(i,afmend-1)=-forceAFMconst*diffafm(i)/dist
11130       gradafm(i,afmbeg-1)=forceAFMconst*diffafm(i)/dist
11131       enddo
11132 C      print *,'AFM',Eafmforce
11133       return
11134       end
11135 C---------------------------------------------------------
11136 C AFM subroutine with pseudoconstant velocity
11137        subroutine AFMvel(Eafmforce)
11138        implicit real*8 (a-h,o-z)
11139       include 'DIMENSIONS'
11140       include 'COMMON.GEO'
11141       include 'COMMON.VAR'
11142       include 'COMMON.LOCAL'
11143       include 'COMMON.CHAIN'
11144       include 'COMMON.DERIV'
11145       include 'COMMON.NAMES'
11146       include 'COMMON.INTERACT'
11147       include 'COMMON.IOUNITS'
11148       include 'COMMON.CALC'
11149       include 'COMMON.CONTROL'
11150       include 'COMMON.SPLITELE'
11151       include 'COMMON.SBRIDGE'
11152       real*8 diffafm(3)
11153 C Only for check grad COMMENT if not used for checkgrad
11154 C      totT=3.0d0
11155 C--------------------------------------------------------
11156 C      print *,"wchodze"
11157       dist=0.0d0
11158       Eafmforce=0.0d0
11159       do i=1,3
11160       diffafm(i)=c(i,afmend)-c(i,afmbeg)
11161       dist=dist+diffafm(i)**2
11162       enddo
11163       dist=dsqrt(dist)
11164       Eafmforce=0.5d0*forceAFMconst
11165      & *(distafminit+totTafm*velAFMconst-dist)**2
11166 C      Eafmforce=-forceAFMconst*(dist-distafminit)
11167       do i=1,3
11168       gradafm(i,afmend-1)=-forceAFMconst*
11169      &(distafminit+totTafm*velAFMconst-dist)
11170      &*diffafm(i)/dist
11171       gradafm(i,afmbeg-1)=forceAFMconst*
11172      &(distafminit+totTafm*velAFMconst-dist)
11173      &*diffafm(i)/dist
11174       enddo
11175 C      print *,'AFM',Eafmforce,totTafm*velAFMconst,dist
11176       return
11177       end
11178
11179 c----------------------------------------------------------------------------
11180       double precision function sscale2(r,r_cut,r0,rlamb)
11181       implicit none
11182       double precision r,gamm,r_cut,r0,rlamb,rr
11183       rr = dabs(r-r0)
11184 c      write (2,*) "r",r," r_cut",r_cut," r0",r0," rlamb",rlamb
11185 c      write (2,*) "rr",rr
11186       if(rr.lt.r_cut-rlamb) then
11187         sscale2=1.0d0
11188       else if(rr.le.r_cut.and.rr.ge.r_cut-rlamb) then
11189         gamm=(rr-(r_cut-rlamb))/rlamb
11190         sscale2=1.0d0+gamm*gamm*(2*gamm-3.0d0)
11191         else
11192         sscale2=0d0
11193       endif
11194         return
11195         end
11196 C-----------------------------------------------------------------------
11197       double precision function sscalgrad2(r,r_cut,r0,rlamb)
11198       implicit none
11199       double precision r,gamm,r_cut,r0,rlamb,rr
11200       rr = dabs(r-r0)
11201       if(rr.lt.r_cut-rlamb) then
11202         sscalgrad2=0.0d0
11203       else if(rr.le.r_cut.and.rr.ge.r_cut-rlamb) then
11204         gamm=(rr-(r_cut-rlamb))/rlamb
11205         if (r.ge.r0) then
11206           sscalgrad2=gamm*(6*gamm-6.0d0)/rlamb
11207         else
11208           sscalgrad2=-gamm*(6*gamm-6.0d0)/rlamb
11209         endif
11210         else
11211         sscalgrad2=0.0d0
11212       endif
11213         return
11214         end
11215 c----------------------------------------------------------------------------
11216       subroutine e_saxs(Esaxs_constr)
11217       implicit none
11218       include 'DIMENSIONS'
11219 #ifdef MPI
11220       include "mpif.h"
11221       include "COMMON.SETUP"
11222       integer IERR
11223 #endif
11224       include 'COMMON.SBRIDGE'
11225       include 'COMMON.CHAIN'
11226       include 'COMMON.GEO'
11227       include 'COMMON.DERIV'
11228       include 'COMMON.LOCAL'
11229       include 'COMMON.INTERACT'
11230       include 'COMMON.VAR'
11231       include 'COMMON.IOUNITS'
11232       include 'COMMON.MD'
11233       include 'COMMON.CONTROL'
11234       include 'COMMON.NAMES'
11235       include 'COMMON.TIME1'
11236       include 'COMMON.FFIELD'
11237 c
11238       double precision Esaxs_constr
11239       integer i,iint,j,k,l
11240       double precision PgradC(maxSAXS,3,maxres),
11241      &  PgradX(maxSAXS,3,maxres),Pcalc(maxSAXS)
11242 #ifdef MPI
11243       double precision PgradC_(maxSAXS,3,maxres),
11244      &  PgradX_(maxSAXS,3,maxres),Pcalc_(maxSAXS)
11245 #endif
11246       double precision dk,dijCACA,dijCASC,dijSCCA,dijSCSC,
11247      & sigma2CACA,sigma2CASC,sigma2SCCA,sigma2SCSC,expCACA,expCASC,
11248      & expSCCA,expSCSC,CASCgrad,SCCAgrad,SCSCgrad,aux,auxC,auxC1,
11249      & auxX,auxX1,CACAgrad,Cnorm
11250       double precision sss2,ssgrad2,rrr,sscalgrad2,sscale2
11251       double precision dist
11252       external dist
11253 c  SAXS restraint penalty function
11254 #ifdef DEBUG
11255       write(iout,*) "------- SAXS penalty function start -------"
11256       write (iout,*) "nsaxs",nsaxs
11257       write (iout,*) "Esaxs: iatsc_s",iatsc_s," iatsc_e",iatsc_e
11258       write (iout,*) "Psaxs"
11259       do i=1,nsaxs
11260         write (iout,'(i5,e15.5)') i, Psaxs(i)
11261       enddo
11262 #endif
11263       Esaxs_constr = 0.0d0
11264       do k=1,nsaxs
11265         Pcalc(k)=0.0d0
11266         do j=1,nres
11267           do l=1,3
11268             PgradC(k,l,j)=0.0d0
11269             PgradX(k,l,j)=0.0d0
11270           enddo
11271         enddo
11272       enddo
11273       do i=iatsc_s,iatsc_e
11274        if (itype(i).eq.ntyp1) cycle
11275        do iint=1,nint_gr(i)
11276          do j=istart(i,iint),iend(i,iint)
11277            if (itype(j).eq.ntyp1) cycle
11278 #ifdef ALLSAXS
11279            dijCACA=dist(i,j)
11280            dijCASC=dist(i,j+nres)
11281            dijSCCA=dist(i+nres,j)
11282            dijSCSC=dist(i+nres,j+nres)
11283            sigma2CACA=2.0d0/(pstok**2)
11284            sigma2CASC=4.0d0/(pstok**2+restok(itype(j))**2)
11285            sigma2SCCA=4.0d0/(pstok**2+restok(itype(i))**2)
11286            sigma2SCSC=4.0d0/(restok(itype(j))**2+restok(itype(i))**2)
11287            do k=1,nsaxs
11288              dk = distsaxs(k)
11289              expCACA = dexp(-0.5d0*sigma2CACA*(dijCACA-dk)**2)
11290              if (itype(j).ne.10) then
11291              expCASC = dexp(-0.5d0*sigma2CASC*(dijCASC-dk)**2)
11292              else
11293              endif
11294              expCASC = 0.0d0
11295              if (itype(i).ne.10) then
11296              expSCCA = dexp(-0.5d0*sigma2SCCA*(dijSCCA-dk)**2)
11297              else
11298              expSCCA = 0.0d0
11299              endif
11300              if (itype(i).ne.10 .and. itype(j).ne.10) then
11301              expSCSC = dexp(-0.5d0*sigma2SCSC*(dijSCSC-dk)**2)
11302              else
11303              expSCSC = 0.0d0
11304              endif
11305              Pcalc(k) = Pcalc(k)+expCACA+expCASC+expSCCA+expSCSC
11306 #ifdef DEBUG
11307              write(iout,*) "i j k Pcalc",i,j,Pcalc(k)
11308 #endif
11309              CACAgrad = sigma2CACA*(dijCACA-dk)*expCACA
11310              CASCgrad = sigma2CASC*(dijCASC-dk)*expCASC
11311              SCCAgrad = sigma2SCCA*(dijSCCA-dk)*expSCCA
11312              SCSCgrad = sigma2SCSC*(dijSCSC-dk)*expSCSC
11313              do l=1,3
11314 c CA CA
11315                aux = CACAgrad*(C(l,j)-C(l,i))/dijCACA
11316                PgradC(k,l,i) = PgradC(k,l,i)-aux
11317                PgradC(k,l,j) = PgradC(k,l,j)+aux
11318 c CA SC
11319                if (itype(j).ne.10) then
11320                aux = CASCgrad*(C(l,j+nres)-C(l,i))/dijCASC
11321                PgradC(k,l,i) = PgradC(k,l,i)-aux
11322                PgradC(k,l,j) = PgradC(k,l,j)+aux
11323                PgradX(k,l,j) = PgradX(k,l,j)+aux
11324                endif
11325 c SC CA
11326                if (itype(i).ne.10) then
11327                aux = SCCAgrad*(C(l,j)-C(l,i+nres))/dijSCCA
11328                PgradX(k,l,i) = PgradX(k,l,i)-aux
11329                PgradC(k,l,i) = PgradC(k,l,i)-aux
11330                PgradC(k,l,j) = PgradC(k,l,j)+aux
11331                endif
11332 c SC SC
11333                if (itype(i).ne.10 .and. itype(j).ne.10) then
11334                aux = SCSCgrad*(C(l,j+nres)-C(l,i+nres))/dijSCSC
11335                PgradC(k,l,i) = PgradC(k,l,i)-aux
11336                PgradC(k,l,j) = PgradC(k,l,j)+aux
11337                PgradX(k,l,i) = PgradX(k,l,i)-aux
11338                PgradX(k,l,j) = PgradX(k,l,j)+aux
11339                endif
11340              enddo ! l
11341            enddo ! k
11342 #else
11343            dijCACA=dist(i,j)
11344            sigma2CACA=scal_rad**2*0.25d0/
11345      &        (restok(itype(j))**2+restok(itype(i))**2)
11346
11347            IF (saxs_cutoff.eq.0) THEN
11348            do k=1,nsaxs
11349              dk = distsaxs(k)
11350              expCACA = dexp(-0.5d0*sigma2CACA*(dijCACA-dk)**2)
11351              Pcalc(k) = Pcalc(k)+expCACA
11352              CACAgrad = sigma2CACA*(dijCACA-dk)*expCACA
11353              do l=1,3
11354                aux = CACAgrad*(C(l,j)-C(l,i))/dijCACA
11355                PgradC(k,l,i) = PgradC(k,l,i)-aux
11356                PgradC(k,l,j) = PgradC(k,l,j)+aux
11357              enddo ! l
11358            enddo ! k
11359            ELSE
11360            rrr = saxs_cutoff*2.0d0/dsqrt(sigma2CACA)
11361            do k=1,nsaxs
11362              dk = distsaxs(k)
11363 c             write (2,*) "ijk",i,j,k
11364              sss2 = sscale2(dijCACA,rrr,dk,0.3d0)
11365              if (sss2.eq.0.0d0) cycle
11366              ssgrad2 = sscalgrad2(dijCACA,rrr,dk,0.3d0)
11367              if (energy_dec) write(iout,'(a4,3i5,5f10.4)')
11368      &          'saxs',i,j,k,dijCACA,rrr,dk,sss2,ssgrad2
11369              expCACA = dexp(-0.5d0*sigma2CACA*(dijCACA-dk)**2)*sss2
11370              Pcalc(k) = Pcalc(k)+expCACA
11371 #ifdef DEBUG
11372              write(iout,*) "i j k Pcalc",i,j,Pcalc(k)
11373 #endif
11374              CACAgrad = -sigma2CACA*(dijCACA-dk)*expCACA+
11375      &             ssgrad2*expCACA/sss2
11376              do l=1,3
11377 c CA CA
11378                aux = CACAgrad*(C(l,j)-C(l,i))/dijCACA
11379                PgradC(k,l,i) = PgradC(k,l,i)+aux
11380                PgradC(k,l,j) = PgradC(k,l,j)-aux
11381              enddo ! l
11382            enddo ! k
11383            ENDIF
11384 #endif
11385          enddo ! j
11386        enddo ! iint
11387       enddo ! i
11388 #ifdef MPI
11389       if (nfgtasks.gt.1) then
11390        call MPI_AllReduce(Pcalc(1),Pcalc_(1),nsaxs,MPI_DOUBLE_PRECISION,
11391      &    MPI_SUM,FG_COMM,IERR)
11392 c        if (fg_rank.eq.king) then
11393           do k=1,nsaxs
11394             Pcalc(k) = Pcalc_(k)
11395           enddo
11396 c        endif
11397 c        call MPI_AllReduce(PgradC(k,1,1),PgradC_(k,1,1),3*maxsaxs*nres,
11398 c     &    MPI_DOUBLE_PRECISION,MPI_SUM,FG_COMM,IERR)
11399 c        if (fg_rank.eq.king) then
11400 c          do i=1,nres
11401 c            do l=1,3
11402 c              do k=1,nsaxs
11403 c                PgradC(k,l,i) = PgradC_(k,l,i)
11404 c              enddo
11405 c            enddo
11406 c          enddo
11407 c        endif
11408 #ifdef ALLSAXS
11409 c        call MPI_AllReduce(PgradX(k,1,1),PgradX_(k,1,1),3*maxsaxs*nres,
11410 c     &    MPI_DOUBLE_PRECISION,MPI_SUM,FG_COMM,IERR)
11411 c        if (fg_rank.eq.king) then
11412 c          do i=1,nres
11413 c            do l=1,3
11414 c              do k=1,nsaxs
11415 c                PgradX(k,l,i) = PgradX_(k,l,i)
11416 c              enddo
11417 c            enddo
11418 c          enddo
11419 c        endif
11420 #endif
11421       endif
11422 #endif
11423       Cnorm = 0.0d0
11424       do k=1,nsaxs
11425         Cnorm = Cnorm + Pcalc(k)
11426       enddo
11427 #ifdef MPI
11428       if (fg_rank.eq.king) then
11429 #endif
11430       Esaxs_constr = dlog(Cnorm)-wsaxs0
11431       do k=1,nsaxs
11432         if (Pcalc(k).gt.0.0d0)
11433      &  Esaxs_constr = Esaxs_constr - Psaxs(k)*dlog(Pcalc(k))
11434 #ifdef DEBUG
11435         write (iout,*) "k",k," Esaxs_constr",Esaxs_constr
11436 #endif
11437       enddo
11438 #ifdef DEBUG
11439       write (iout,*) "Cnorm",Cnorm," Esaxs_constr",Esaxs_constr
11440 #endif
11441 #ifdef MPI
11442       endif
11443 #endif
11444       gsaxsC=0.0d0
11445       gsaxsX=0.0d0
11446       do i=nnt,nct
11447         do l=1,3
11448           auxC=0.0d0
11449           auxC1=0.0d0
11450           auxX=0.0d0
11451           auxX1=0.d0
11452           do k=1,nsaxs
11453             if (Pcalc(k).gt.0)
11454      &      auxC  = auxC +Psaxs(k)*PgradC(k,l,i)/Pcalc(k)
11455             auxC1 = auxC1+PgradC(k,l,i)
11456 #ifdef ALLSAXS
11457             auxX  = auxX +Psaxs(k)*PgradX(k,l,i)/Pcalc(k)
11458             auxX1 = auxX1+PgradX(k,l,i)
11459 #endif
11460           enddo
11461           gsaxsC(l,i) = auxC - auxC1/Cnorm
11462 #ifdef ALLSAXS
11463           gsaxsX(l,i) = auxX - auxX1/Cnorm
11464 #endif
11465 c          write (iout,*) "l i",l,i," gradC",wsaxs*(auxC - auxC1/Cnorm),
11466 c     *     " gradX",wsaxs*(auxX - auxX1/Cnorm)
11467         enddo
11468       enddo
11469 #ifdef MPI
11470 c      endif
11471 #endif
11472       return
11473       end
11474 c----------------------------------------------------------------------------
11475       subroutine e_saxsC(Esaxs_constr)
11476       implicit none
11477       include 'DIMENSIONS'
11478 #ifdef MPI
11479       include "mpif.h"
11480       include "COMMON.SETUP"
11481       integer IERR
11482 #endif
11483       include 'COMMON.SBRIDGE'
11484       include 'COMMON.CHAIN'
11485       include 'COMMON.GEO'
11486       include 'COMMON.DERIV'
11487       include 'COMMON.LOCAL'
11488       include 'COMMON.INTERACT'
11489       include 'COMMON.VAR'
11490       include 'COMMON.IOUNITS'
11491       include 'COMMON.MD'
11492       include 'COMMON.CONTROL'
11493       include 'COMMON.NAMES'
11494       include 'COMMON.TIME1'
11495       include 'COMMON.FFIELD'
11496 c
11497       double precision Esaxs_constr
11498       integer i,iint,j,k,l
11499       double precision PgradC(3,maxres),PgradX(3,maxres),Pcalc,logPtot
11500 #ifdef MPI
11501       double precision gsaxsc_(3,maxres),gsaxsx_(3,maxres),logPtot_
11502 #endif
11503       double precision dk,dijCASPH,dijSCSPH,
11504      & sigma2CA,sigma2SC,expCASPH,expSCSPH,
11505      & CASPHgrad,SCSPHgrad,aux,auxC,auxC1,
11506      & auxX,auxX1,Cnorm
11507 c  SAXS restraint penalty function
11508 #ifdef DEBUG
11509       write(iout,*) "------- SAXS penalty function start -------"
11510       write (iout,*) "nsaxs",nsaxs
11511
11512       do i=nnt,nct
11513         print *,MyRank,"C",i,(C(j,i),j=1,3)
11514       enddo
11515       do i=nnt,nct
11516         print *,MyRank,"CSaxs",i,(Csaxs(j,i),j=1,3)
11517       enddo
11518 #endif
11519       Esaxs_constr = 0.0d0
11520       logPtot=0.0d0
11521       do j=isaxs_start,isaxs_end
11522         Pcalc=0.0d0
11523         do i=1,nres
11524           do l=1,3
11525             PgradC(l,i)=0.0d0
11526             PgradX(l,i)=0.0d0
11527           enddo
11528         enddo
11529         do i=nnt,nct
11530           if (itype(i).eq.ntyp1) cycle
11531           dijCASPH=0.0d0
11532           dijSCSPH=0.0d0
11533           do l=1,3
11534             dijCASPH=dijCASPH+(C(l,i)-Csaxs(l,j))**2
11535           enddo
11536           if (itype(i).ne.10) then
11537           do l=1,3
11538             dijSCSPH=dijSCSPH+(C(l,i+nres)-Csaxs(l,j))**2
11539           enddo
11540           endif
11541           sigma2CA=2.0d0/pstok**2
11542           sigma2SC=4.0d0/restok(itype(i))**2
11543           expCASPH = dexp(-0.5d0*sigma2CA*dijCASPH)
11544           expSCSPH = dexp(-0.5d0*sigma2SC*dijSCSPH)
11545           Pcalc = Pcalc+expCASPH+expSCSPH
11546 #ifdef DEBUG
11547           write(*,*) "processor i j Pcalc",
11548      &       MyRank,i,j,dijCASPH,dijSCSPH, Pcalc
11549 #endif
11550           CASPHgrad = sigma2CA*expCASPH
11551           SCSPHgrad = sigma2SC*expSCSPH
11552           do l=1,3
11553             aux = (C(l,i+nres)-Csaxs(l,j))*SCSPHgrad
11554             PgradX(l,i) = PgradX(l,i) + aux
11555             PgradC(l,i) = PgradC(l,i)+(C(l,i)-Csaxs(l,j))*CASPHgrad+aux
11556           enddo ! l
11557         enddo ! i
11558         do i=nnt,nct
11559           do l=1,3
11560             gsaxsc(l,i)=gsaxsc(l,i)+PgradC(l,i)/Pcalc
11561             gsaxsx(l,i)=gsaxsx(l,i)+PgradX(l,i)/Pcalc
11562           enddo
11563         enddo
11564         logPtot = logPtot - dlog(Pcalc)
11565 c        print *,"me",me,MyRank," j",j," logPcalc",-dlog(Pcalc),
11566 c     &    " logPtot",logPtot
11567       enddo ! j
11568 #ifdef MPI
11569       if (nfgtasks.gt.1) then
11570 c        write (iout,*) "logPtot before reduction",logPtot
11571         call MPI_Reduce(logPtot,logPtot_,1,MPI_DOUBLE_PRECISION,
11572      &    MPI_SUM,king,FG_COMM,IERR)
11573         logPtot = logPtot_
11574 c        write (iout,*) "logPtot after reduction",logPtot
11575         call MPI_Reduce(gsaxsC(1,1),gsaxsC_(1,1),3*nres,
11576      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
11577         if (fg_rank.eq.king) then
11578           do i=1,nres
11579             do l=1,3
11580               gsaxsC(l,i) = gsaxsC_(l,i)
11581             enddo
11582           enddo
11583         endif
11584         call MPI_Reduce(gsaxsX(1,1),gsaxsX_(1,1),3*nres,
11585      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
11586         if (fg_rank.eq.king) then
11587           do i=1,nres
11588             do l=1,3
11589               gsaxsX(l,i) = gsaxsX_(l,i)
11590             enddo
11591           enddo
11592         endif
11593       endif
11594 #endif
11595       Esaxs_constr = logPtot
11596       return
11597       end