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       if (link_end_peak.ne.0) then
5207       do i=link_start_peak,link_end_peak
5208         ehpb_peak=0.0d0
5209 c        print *,"i",i," link_end_peak",link_end_peak," ipeak",
5210 c     &   ipeak(1,i),ipeak(2,i)
5211         do ip=ipeak(1,i),ipeak(2,i)
5212           ii=ihpb_peak(ip)
5213           jj=jhpb_peak(ip)
5214           dd=dist(ii,jj)
5215           iip=ip-ipeak(1,i)+1
5216 C iii and jjj point to the residues for which the distance is assigned.
5217           if (ii.gt.nres) then
5218             iii=ii-nres
5219             jjj=jj-nres
5220           else
5221             iii=ii
5222             jjj=jj
5223           endif
5224           aux=rlornmr1(dd,dhpb_peak(ip),dhpb1_peak(ip),forcon_peak(ip))
5225           aux=dexp(-scal_peak*aux)
5226           ehpb_peak=ehpb_peak+aux
5227           fac=rlornmr1prim(dd,dhpb_peak(ip),dhpb1_peak(ip),
5228      &      forcon_peak(ip))*aux/dd
5229           do j=1,3
5230             ggg_peak(j,iip)=fac*(c(j,jj)-c(j,ii))
5231           enddo
5232           if (energy_dec) write (iout,'(a6,3i5,6f10.3,i5)')
5233      &      "edisL",i,ii,jj,dd,dhpb_peak(ip),dhpb1_peak(ip),
5234      &      forcon_peak(ip),fordepth_peak(ip),ehpb_peak
5235         enddo
5236 c        write (iout,*) "ehpb_peak",ehpb_peak," scal_peak",scal_peak
5237         ehpb=ehpb-fordepth_peak(ipeak(1,i))*dlog(ehpb_peak)/scal_peak
5238         do ip=ipeak(1,i),ipeak(2,i)
5239           iip=ip-ipeak(1,i)+1
5240           do j=1,3
5241             ggg(j)=ggg_peak(j,iip)/ehpb_peak
5242           enddo
5243           ii=ihpb_peak(ip)
5244           jj=jhpb_peak(ip)
5245 C iii and jjj point to the residues for which the distance is assigned.
5246           if (ii.gt.nres) then
5247             iii=ii-nres
5248             jjj=jj-nres
5249           else
5250             iii=ii
5251             jjj=jj
5252           endif
5253           if (iii.lt.ii) then
5254             do j=1,3
5255               ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
5256               ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
5257             enddo
5258           endif
5259           do k=1,3
5260             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
5261             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
5262           enddo
5263         enddo
5264       enddo
5265       endif
5266       do i=link_start,link_end
5267 C If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a
5268 C CA-CA distance used in regularization of structure.
5269         ii=ihpb(i)
5270         jj=jhpb(i)
5271 C iii and jjj point to the residues for which the distance is assigned.
5272         if (ii.gt.nres) then
5273           iii=ii-nres
5274           jjj=jj-nres
5275         else
5276           iii=ii
5277           jjj=jj
5278         endif
5279 c        write (iout,*) "i",i," ii",ii," iii",iii," jj",jj," jjj",jjj,
5280 c     &    dhpb(i),dhpb1(i),forcon(i)
5281 C 24/11/03 AL: SS bridges handled separately because of introducing a specific
5282 C    distance and angle dependent SS bond potential.
5283 C        if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and.
5284 C     & iabs(itype(jjj)).eq.1) then
5285 cmc        if (ii.gt.nres .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then
5286 C 18/07/06 MC: Use the convention that the first nss pairs are SS bonds
5287         if (.not.dyn_ss .and. i.le.nss) then
5288 C 15/02/13 CC dynamic SSbond - additional check
5289           if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and.
5290      &        iabs(itype(jjj)).eq.1) then
5291            call ssbond_ene(iii,jjj,eij)
5292            ehpb=ehpb+eij
5293          endif
5294 cd          write (iout,*) "eij",eij
5295 cd   &   ' waga=',waga,' fac=',fac
5296 !        else if (ii.gt.nres .and. jj.gt.nres) then
5297         else
5298 C Calculate the distance between the two points and its difference from the
5299 C target distance.
5300           dd=dist(ii,jj)
5301           if (irestr_type(i).eq.11) then
5302             ehpb=ehpb+fordepth(i)!**4.0d0
5303      &           *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i))
5304             fac=fordepth(i)!**4.0d0
5305      &           *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd
5306             if (energy_dec) write (iout,'(a6,2i5,6f10.3,i5)')
5307      &        "edisL",ii,jj,dd,dhpb(i),dhpb1(i),forcon(i),fordepth(i),
5308      &        ehpb,irestr_type(i)
5309           else if (irestr_type(i).eq.10) then
5310 c AL 6//19/2018 cross-link restraints
5311             xdis = 0.5d0*(dd/forcon(i))**2
5312             expdis = dexp(-xdis)
5313 c            aux=(dhpb(i)+dhpb1(i)*xdis)*expdis+fordepth(i)
5314             aux=(dhpb(i)+dhpb1(i)*xdis*xdis)*expdis+fordepth(i)
5315 c            write (iout,*)"HERE: xdis",xdis," expdis",expdis," aux",aux,
5316 c     &          " wboltzd",wboltzd
5317             ehpb=ehpb-wboltzd*xlscore(i)*dlog(aux)
5318 c            fac=-wboltzd*(dhpb1(i)*(1.0d0-xdis)-dhpb(i))
5319             fac=-wboltzd*xlscore(i)*(dhpb1(i)*(2.0d0-xdis)*xdis-dhpb(i))
5320      &           *expdis/(aux*forcon(i)**2)
5321             if (energy_dec) write(iout,'(a6,2i5,6f10.3,i5)')
5322      &        "edisX",ii,jj,dd,dhpb(i),dhpb1(i),forcon(i),fordepth(i),
5323      &        -wboltzd*xlscore(i)*dlog(aux),irestr_type(i)
5324           else if (irestr_type(i).eq.2) then
5325 c Quartic restraints
5326             ehpb=ehpb+forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
5327             if (energy_dec) write(iout,'(a6,2i5,5f10.3,i5)')
5328      &      "edisQ",ii,jj,dd,dhpb(i),dhpb1(i),forcon(i),
5329      &      forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i)),irestr_type(i)
5330             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
5331           else
5332 c Quadratic restraints
5333             rdis=dd-dhpb(i)
5334 C Get the force constant corresponding to this distance.
5335             waga=forcon(i)
5336 C Calculate the contribution to energy.
5337             ehpb=ehpb+0.5d0*waga*rdis*rdis
5338             if (energy_dec) write(iout,'(a6,2i5,5f10.3,i5)')
5339      &      "edisS",ii,jj,dd,dhpb(i),dhpb1(i),forcon(i),
5340      &       0.5d0*waga*rdis*rdis,irestr_type(i)
5341 C
5342 C Evaluate gradient.
5343 C
5344             fac=waga*rdis/dd
5345           endif
5346 c Calculate Cartesian gradient
5347           do j=1,3
5348             ggg(j)=fac*(c(j,jj)-c(j,ii))
5349           enddo
5350 cd      print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
5351 C If this is a SC-SC distance, we need to calculate the contributions to the
5352 C Cartesian gradient in the SC vectors (ghpbx).
5353           if (iii.lt.ii) then
5354             do j=1,3
5355               ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
5356               ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
5357             enddo
5358           endif
5359 cgrad        do j=iii,jjj-1
5360 cgrad          do k=1,3
5361 cgrad            ghpbc(k,j)=ghpbc(k,j)+ggg(k)
5362 cgrad          enddo
5363 cgrad        enddo
5364           do k=1,3
5365             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
5366             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
5367           enddo
5368         endif
5369       enddo
5370       return
5371       end
5372 C--------------------------------------------------------------------------
5373       subroutine ssbond_ene(i,j,eij)
5374 C
5375 C Calculate the distance and angle dependent SS-bond potential energy
5376 C using a free-energy function derived based on RHF/6-31G** ab initio
5377 C calculations of diethyl disulfide.
5378 C
5379 C A. Liwo and U. Kozlowska, 11/24/03
5380 C
5381       implicit real*8 (a-h,o-z)
5382       include 'DIMENSIONS'
5383       include 'COMMON.SBRIDGE'
5384       include 'COMMON.CHAIN'
5385       include 'COMMON.DERIV'
5386       include 'COMMON.LOCAL'
5387       include 'COMMON.INTERACT'
5388       include 'COMMON.VAR'
5389       include 'COMMON.IOUNITS'
5390       double precision erij(3),dcosom1(3),dcosom2(3),gg(3)
5391       itypi=iabs(itype(i))
5392       xi=c(1,nres+i)
5393       yi=c(2,nres+i)
5394       zi=c(3,nres+i)
5395       dxi=dc_norm(1,nres+i)
5396       dyi=dc_norm(2,nres+i)
5397       dzi=dc_norm(3,nres+i)
5398 c      dsci_inv=dsc_inv(itypi)
5399       dsci_inv=vbld_inv(nres+i)
5400       itypj=iabs(itype(j))
5401 c      dscj_inv=dsc_inv(itypj)
5402       dscj_inv=vbld_inv(nres+j)
5403       xj=c(1,nres+j)-xi
5404       yj=c(2,nres+j)-yi
5405       zj=c(3,nres+j)-zi
5406       dxj=dc_norm(1,nres+j)
5407       dyj=dc_norm(2,nres+j)
5408       dzj=dc_norm(3,nres+j)
5409       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
5410       rij=dsqrt(rrij)
5411       erij(1)=xj*rij
5412       erij(2)=yj*rij
5413       erij(3)=zj*rij
5414       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
5415       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
5416       om12=dxi*dxj+dyi*dyj+dzi*dzj
5417       do k=1,3
5418         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
5419         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
5420       enddo
5421       rij=1.0d0/rij
5422       deltad=rij-d0cm
5423       deltat1=1.0d0-om1
5424       deltat2=1.0d0+om2
5425       deltat12=om2-om1+2.0d0
5426       cosphi=om12-om1*om2
5427       eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2)
5428      &  +akct*deltad*deltat12
5429      &  +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi+ebr
5430 c      write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth,
5431 c     &  " akct",akct," deltad",deltad," deltat",deltat1,deltat2,
5432 c     &  " deltat12",deltat12," eij",eij
5433       ed=2*akcm*deltad+akct*deltat12
5434       pom1=akct*deltad
5435       pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
5436       eom1=-2*akth*deltat1-pom1-om2*pom2
5437       eom2= 2*akth*deltat2+pom1-om1*pom2
5438       eom12=pom2
5439       do k=1,3
5440         ggk=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
5441         ghpbx(k,i)=ghpbx(k,i)-ggk
5442      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
5443      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
5444         ghpbx(k,j)=ghpbx(k,j)+ggk
5445      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
5446      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
5447         ghpbc(k,i)=ghpbc(k,i)-ggk
5448         ghpbc(k,j)=ghpbc(k,j)+ggk
5449       enddo
5450 C
5451 C Calculate the components of the gradient in DC and X
5452 C
5453 cgrad      do k=i,j-1
5454 cgrad        do l=1,3
5455 cgrad          ghpbc(l,k)=ghpbc(l,k)+gg(l)
5456 cgrad        enddo
5457 cgrad      enddo
5458       return
5459       end
5460 C--------------------------------------------------------------------------
5461       subroutine ebond(estr)
5462 c
5463 c Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
5464 c
5465       implicit real*8 (a-h,o-z)
5466       include 'DIMENSIONS'
5467       include 'COMMON.LOCAL'
5468       include 'COMMON.GEO'
5469       include 'COMMON.INTERACT'
5470       include 'COMMON.DERIV'
5471       include 'COMMON.VAR'
5472       include 'COMMON.CHAIN'
5473       include 'COMMON.IOUNITS'
5474       include 'COMMON.NAMES'
5475       include 'COMMON.FFIELD'
5476       include 'COMMON.CONTROL'
5477       include 'COMMON.SETUP'
5478       double precision u(3),ud(3)
5479       estr=0.0d0
5480       estr1=0.0d0
5481       do i=ibondp_start,ibondp_end
5482         if (itype(i-1).eq.ntyp1 .and. itype(i).eq.ntyp1) cycle
5483 c          estr1=estr1+gnmr1(vbld(i),-1.0d0,distchainmax)
5484 c          do j=1,3
5485 c          gradb(j,i-1)=gnmr1prim(vbld(i),-1.0d0,distchainmax)
5486 c     &      *dc(j,i-1)/vbld(i)
5487 c          enddo
5488 c          if (energy_dec) write(iout,*)
5489 c     &       "estr1",i,gnmr1(vbld(i),-1.0d0,distchainmax)
5490 c        else
5491 C       Checking if it involves dummy (NH3+ or COO-) group
5492          if (itype(i-1).eq.ntyp1 .or. itype(i).eq.ntyp1) then
5493 C YES   vbldpDUM is the equlibrium length of spring for Dummy atom
5494         diff = vbld(i)-vbldpDUM
5495          else
5496 C NO    vbldp0 is the equlibrium lenght of spring for peptide group
5497         diff = vbld(i)-vbldp0
5498          endif
5499         if (energy_dec)    write (iout,'(a7,i5,4f7.3)')
5500      &     "estr bb",i,vbld(i),vbldp0,diff,AKP*diff*diff
5501         estr=estr+diff*diff
5502         do j=1,3
5503           gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)
5504         enddo
5505 c        write (iout,'(i5,3f10.5)') i,(gradb(j,i-1),j=1,3)
5506 c        endif
5507       enddo
5508
5509       estr=0.5d0*AKP*estr+estr1
5510 c
5511 c 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included
5512 c
5513       do i=ibond_start,ibond_end
5514         iti=iabs(itype(i))
5515         if (iti.ne.10 .and. iti.ne.ntyp1) then
5516           nbi=nbondterm(iti)
5517           if (nbi.eq.1) then
5518             diff=vbld(i+nres)-vbldsc0(1,iti)
5519             if (energy_dec)  write (iout,*)
5520      &      "estr sc",i,iti,vbld(i+nres),vbldsc0(1,iti),diff,
5521      &      AKSC(1,iti),AKSC(1,iti)*diff*diff
5522             estr=estr+0.5d0*AKSC(1,iti)*diff*diff
5523             do j=1,3
5524               gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
5525             enddo
5526           else
5527             do j=1,nbi
5528               diff=vbld(i+nres)-vbldsc0(j,iti)
5529               ud(j)=aksc(j,iti)*diff
5530               u(j)=abond0(j,iti)+0.5d0*ud(j)*diff
5531             enddo
5532             uprod=u(1)
5533             do j=2,nbi
5534               uprod=uprod*u(j)
5535             enddo
5536             usum=0.0d0
5537             usumsqder=0.0d0
5538             do j=1,nbi
5539               uprod1=1.0d0
5540               uprod2=1.0d0
5541               do k=1,nbi
5542                 if (k.ne.j) then
5543                   uprod1=uprod1*u(k)
5544                   uprod2=uprod2*u(k)*u(k)
5545                 endif
5546               enddo
5547               usum=usum+uprod1
5548               usumsqder=usumsqder+ud(j)*uprod2
5549             enddo
5550             estr=estr+uprod/usum
5551             do j=1,3
5552              gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
5553             enddo
5554           endif
5555         endif
5556       enddo
5557       return
5558       end
5559 #ifdef CRYST_THETA
5560 C--------------------------------------------------------------------------
5561       subroutine ebend(etheta)
5562 C
5563 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
5564 C angles gamma and its derivatives in consecutive thetas and gammas.
5565 C
5566       implicit real*8 (a-h,o-z)
5567       include 'DIMENSIONS'
5568       include 'COMMON.LOCAL'
5569       include 'COMMON.GEO'
5570       include 'COMMON.INTERACT'
5571       include 'COMMON.DERIV'
5572       include 'COMMON.VAR'
5573       include 'COMMON.CHAIN'
5574       include 'COMMON.IOUNITS'
5575       include 'COMMON.NAMES'
5576       include 'COMMON.FFIELD'
5577       include 'COMMON.CONTROL'
5578       common /calcthet/ term1,term2,termm,diffak,ratak,
5579      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
5580      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
5581       double precision y(2),z(2)
5582       delta=0.02d0*pi
5583 c      time11=dexp(-2*time)
5584 c      time12=1.0d0
5585       etheta=0.0D0
5586 c     write (*,'(a,i2)') 'EBEND ICG=',icg
5587       do i=ithet_start,ithet_end
5588         if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
5589      &  .or.itype(i).eq.ntyp1) cycle
5590 C Zero the energy function and its derivative at 0 or pi.
5591         call splinthet(theta(i),0.5d0*delta,ss,ssd)
5592         it=itype(i-1)
5593         ichir1=isign(1,itype(i-2))
5594         ichir2=isign(1,itype(i))
5595          if (itype(i-2).eq.10) ichir1=isign(1,itype(i-1))
5596          if (itype(i).eq.10) ichir2=isign(1,itype(i-1))
5597          if (itype(i-1).eq.10) then
5598           itype1=isign(10,itype(i-2))
5599           ichir11=isign(1,itype(i-2))
5600           ichir12=isign(1,itype(i-2))
5601           itype2=isign(10,itype(i))
5602           ichir21=isign(1,itype(i))
5603           ichir22=isign(1,itype(i))
5604          endif
5605
5606         if (i.gt.3 .and. itype(i-3).ne.ntyp1) then
5607 #ifdef OSF
5608           phii=phi(i)
5609           if (phii.ne.phii) phii=150.0
5610 #else
5611           phii=phi(i)
5612 #endif
5613           y(1)=dcos(phii)
5614           y(2)=dsin(phii)
5615         else
5616           y(1)=0.0D0
5617           y(2)=0.0D0
5618         endif
5619         if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
5620 #ifdef OSF
5621           phii1=phi(i+1)
5622           if (phii1.ne.phii1) phii1=150.0
5623           phii1=pinorm(phii1)
5624           z(1)=cos(phii1)
5625 #else
5626           phii1=phi(i+1)
5627 #endif
5628           z(1)=dcos(phii1)
5629           z(2)=dsin(phii1)
5630         else
5631           z(1)=0.0D0
5632           z(2)=0.0D0
5633         endif
5634 C Calculate the "mean" value of theta from the part of the distribution
5635 C dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2).
5636 C In following comments this theta will be referred to as t_c.
5637         thet_pred_mean=0.0d0
5638         do k=1,2
5639             athetk=athet(k,it,ichir1,ichir2)
5640             bthetk=bthet(k,it,ichir1,ichir2)
5641           if (it.eq.10) then
5642              athetk=athet(k,itype1,ichir11,ichir12)
5643              bthetk=bthet(k,itype2,ichir21,ichir22)
5644           endif
5645          thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k)
5646 c         write(iout,*) 'chuj tu', y(k),z(k)
5647         enddo
5648         dthett=thet_pred_mean*ssd
5649         thet_pred_mean=thet_pred_mean*ss+a0thet(it)
5650 C Derivatives of the "mean" values in gamma1 and gamma2.
5651         dthetg1=(-athet(1,it,ichir1,ichir2)*y(2)
5652      &+athet(2,it,ichir1,ichir2)*y(1))*ss
5653          dthetg2=(-bthet(1,it,ichir1,ichir2)*z(2)
5654      &          +bthet(2,it,ichir1,ichir2)*z(1))*ss
5655          if (it.eq.10) then
5656       dthetg1=(-athet(1,itype1,ichir11,ichir12)*y(2)
5657      &+athet(2,itype1,ichir11,ichir12)*y(1))*ss
5658         dthetg2=(-bthet(1,itype2,ichir21,ichir22)*z(2)
5659      &         +bthet(2,itype2,ichir21,ichir22)*z(1))*ss
5660          endif
5661         if (theta(i).gt.pi-delta) then
5662           call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,
5663      &         E_tc0)
5664           call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0)
5665           call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
5666           call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,
5667      &        E_theta)
5668           call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,
5669      &        E_tc)
5670         else if (theta(i).lt.delta) then
5671           call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0)
5672           call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
5673           call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,
5674      &        E_theta)
5675           call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0)
5676           call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,
5677      &        E_tc)
5678         else
5679           call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,
5680      &        E_theta,E_tc)
5681         endif
5682         etheta=etheta+ethetai
5683         if (energy_dec) write (iout,'(a6,i5,0pf7.3,f7.3,i5)')
5684      &      'ebend',i,ethetai,theta(i),itype(i)
5685         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1
5686         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2
5687         gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)+gloc(nphi+i-2,icg)
5688       enddo
5689
5690 C Ufff.... We've done all this!!!
5691       return
5692       end
5693 C---------------------------------------------------------------------------
5694       subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,
5695      &     E_tc)
5696       implicit real*8 (a-h,o-z)
5697       include 'DIMENSIONS'
5698       include 'COMMON.LOCAL'
5699       include 'COMMON.IOUNITS'
5700       common /calcthet/ term1,term2,termm,diffak,ratak,
5701      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
5702      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
5703 C Calculate the contributions to both Gaussian lobes.
5704 C 6/6/97 - Deform the Gaussians using the factor of 1/(1+time)
5705 C The "polynomial part" of the "standard deviation" of this part of
5706 C the distributioni.
5707 ccc        write (iout,*) thetai,thet_pred_mean
5708         sig=polthet(3,it)
5709         do j=2,0,-1
5710           sig=sig*thet_pred_mean+polthet(j,it)
5711         enddo
5712 C Derivative of the "interior part" of the "standard deviation of the"
5713 C gamma-dependent Gaussian lobe in t_c.
5714         sigtc=3*polthet(3,it)
5715         do j=2,1,-1
5716           sigtc=sigtc*thet_pred_mean+j*polthet(j,it)
5717         enddo
5718         sigtc=sig*sigtc
5719 C Set the parameters of both Gaussian lobes of the distribution.
5720 C "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc)
5721         fac=sig*sig+sigc0(it)
5722         sigcsq=fac+fac
5723         sigc=1.0D0/sigcsq
5724 C Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c
5725         sigsqtc=-4.0D0*sigcsq*sigtc
5726 c       print *,i,sig,sigtc,sigsqtc
5727 C Following variable (sigtc) is d[sigma(t_c)]/dt_c
5728         sigtc=-sigtc/(fac*fac)
5729 C Following variable is sigma(t_c)**(-2)
5730         sigcsq=sigcsq*sigcsq
5731         sig0i=sig0(it)
5732         sig0inv=1.0D0/sig0i**2
5733         delthec=thetai-thet_pred_mean
5734         delthe0=thetai-theta0i
5735         term1=-0.5D0*sigcsq*delthec*delthec
5736         term2=-0.5D0*sig0inv*delthe0*delthe0
5737 C        write (iout,*)'term1',term1,term2,sigcsq,delthec,sig0inv,delthe0
5738 C Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and
5739 C NaNs in taking the logarithm. We extract the largest exponent which is added
5740 C to the energy (this being the log of the distribution) at the end of energy
5741 C term evaluation for this virtual-bond angle.
5742         if (term1.gt.term2) then
5743           termm=term1
5744           term2=dexp(term2-termm)
5745           term1=1.0d0
5746         else
5747           termm=term2
5748           term1=dexp(term1-termm)
5749           term2=1.0d0
5750         endif
5751 C The ratio between the gamma-independent and gamma-dependent lobes of
5752 C the distribution is a Gaussian function of thet_pred_mean too.
5753         diffak=gthet(2,it)-thet_pred_mean
5754         ratak=diffak/gthet(3,it)**2
5755         ak=dexp(gthet(1,it)-0.5D0*diffak*ratak)
5756 C Let's differentiate it in thet_pred_mean NOW.
5757         aktc=ak*ratak
5758 C Now put together the distribution terms to make complete distribution.
5759         termexp=term1+ak*term2
5760         termpre=sigc+ak*sig0i
5761 C Contribution of the bending energy from this theta is just the -log of
5762 C the sum of the contributions from the two lobes and the pre-exponential
5763 C factor. Simple enough, isn't it?
5764         ethetai=(-dlog(termexp)-termm+dlog(termpre))
5765 C       write (iout,*) 'termexp',termexp,termm,termpre,i
5766 C NOW the derivatives!!!
5767 C 6/6/97 Take into account the deformation.
5768         E_theta=(delthec*sigcsq*term1
5769      &       +ak*delthe0*sig0inv*term2)/termexp
5770         E_tc=((sigtc+aktc*sig0i)/termpre
5771      &      -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+
5772      &       aktc*term2)/termexp)
5773       return
5774       end
5775 c-----------------------------------------------------------------------------
5776       subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)
5777       implicit real*8 (a-h,o-z)
5778       include 'DIMENSIONS'
5779       include 'COMMON.LOCAL'
5780       include 'COMMON.IOUNITS'
5781       common /calcthet/ term1,term2,termm,diffak,ratak,
5782      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
5783      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
5784       delthec=thetai-thet_pred_mean
5785       delthe0=thetai-theta0i
5786 C "Thank you" to MAPLE (probably spared one day of hand-differentiation).
5787       t3 = thetai-thet_pred_mean
5788       t6 = t3**2
5789       t9 = term1
5790       t12 = t3*sigcsq
5791       t14 = t12+t6*sigsqtc
5792       t16 = 1.0d0
5793       t21 = thetai-theta0i
5794       t23 = t21**2
5795       t26 = term2
5796       t27 = t21*t26
5797       t32 = termexp
5798       t40 = t32**2
5799       E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9
5800      & -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40
5801      & *(-t12*t9-ak*sig0inv*t27)
5802       return
5803       end
5804 #else
5805 C--------------------------------------------------------------------------
5806       subroutine ebend(etheta)
5807 C
5808 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
5809 C angles gamma and its derivatives in consecutive thetas and gammas.
5810 C ab initio-derived potentials from
5811 c Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203
5812 C
5813       implicit real*8 (a-h,o-z)
5814       include 'DIMENSIONS'
5815       include 'COMMON.LOCAL'
5816       include 'COMMON.GEO'
5817       include 'COMMON.INTERACT'
5818       include 'COMMON.DERIV'
5819       include 'COMMON.VAR'
5820       include 'COMMON.CHAIN'
5821       include 'COMMON.IOUNITS'
5822       include 'COMMON.NAMES'
5823       include 'COMMON.FFIELD'
5824       include 'COMMON.CONTROL'
5825       double precision coskt(mmaxtheterm),sinkt(mmaxtheterm),
5826      & cosph1(maxsingle),sinph1(maxsingle),cosph2(maxsingle),
5827      & sinph2(maxsingle),cosph1ph2(maxdouble,maxdouble),
5828      & sinph1ph2(maxdouble,maxdouble)
5829       logical lprn /.false./, lprn1 /.false./
5830       etheta=0.0D0
5831       do i=ithet_start,ithet_end
5832 c        if (i.eq.2) cycle
5833 c        print *,i,itype(i-1),itype(i),itype(i-2)
5834         if ((itype(i-1).eq.ntyp1).or.(itype(i-2).eq.ntyp1)
5835      &  .or.(itype(i).eq.ntyp1)) cycle
5836 C In current verion the ALL DUMMY ATOM POTENTIALS ARE OFF
5837
5838         if (iabs(itype(i+1)).eq.20) iblock=2
5839         if (iabs(itype(i+1)).ne.20) iblock=1
5840         dethetai=0.0d0
5841         dephii=0.0d0
5842         dephii1=0.0d0
5843         theti2=0.5d0*theta(i)
5844         ityp2=ithetyp((itype(i-1)))
5845         do k=1,nntheterm
5846           coskt(k)=dcos(k*theti2)
5847           sinkt(k)=dsin(k*theti2)
5848         enddo
5849         if (i.gt.3 .and. itype(max0(i-3,1)).ne.ntyp1) then
5850 #ifdef OSF
5851           phii=phi(i)
5852           if (phii.ne.phii) phii=150.0
5853 #else
5854           phii=phi(i)
5855 #endif
5856           ityp1=ithetyp((itype(i-2)))
5857 C propagation of chirality for glycine type
5858           do k=1,nsingle
5859             cosph1(k)=dcos(k*phii)
5860             sinph1(k)=dsin(k*phii)
5861           enddo
5862         else
5863           phii=0.0d0
5864           ityp1=ithetyp(itype(i-2))
5865           do k=1,nsingle
5866             cosph1(k)=0.0d0
5867             sinph1(k)=0.0d0
5868           enddo
5869         endif
5870         if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
5871 #ifdef OSF
5872           phii1=phi(i+1)
5873           if (phii1.ne.phii1) phii1=150.0
5874           phii1=pinorm(phii1)
5875 #else
5876           phii1=phi(i+1)
5877 #endif
5878           ityp3=ithetyp((itype(i)))
5879           do k=1,nsingle
5880             cosph2(k)=dcos(k*phii1)
5881             sinph2(k)=dsin(k*phii1)
5882           enddo
5883         else
5884           phii1=0.0d0
5885           ityp3=ithetyp(itype(i))
5886           do k=1,nsingle
5887             cosph2(k)=0.0d0
5888             sinph2(k)=0.0d0
5889           enddo
5890         endif
5891         ethetai=aa0thet(ityp1,ityp2,ityp3,iblock)
5892         do k=1,ndouble
5893           do l=1,k-1
5894             ccl=cosph1(l)*cosph2(k-l)
5895             ssl=sinph1(l)*sinph2(k-l)
5896             scl=sinph1(l)*cosph2(k-l)
5897             csl=cosph1(l)*sinph2(k-l)
5898             cosph1ph2(l,k)=ccl-ssl
5899             cosph1ph2(k,l)=ccl+ssl
5900             sinph1ph2(l,k)=scl+csl
5901             sinph1ph2(k,l)=scl-csl
5902           enddo
5903         enddo
5904         if (lprn) then
5905         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,
5906      &    " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
5907         write (iout,*) "coskt and sinkt"
5908         do k=1,nntheterm
5909           write (iout,*) k,coskt(k),sinkt(k)
5910         enddo
5911         endif
5912         do k=1,ntheterm
5913           ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3,iblock)*sinkt(k)
5914           dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3,iblock)
5915      &      *coskt(k)
5916           if (lprn)
5917      &    write (iout,*) "k",k,"
5918      &     aathet",aathet(k,ityp1,ityp2,ityp3,iblock),
5919      &     " ethetai",ethetai
5920         enddo
5921         if (lprn) then
5922         write (iout,*) "cosph and sinph"
5923         do k=1,nsingle
5924           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
5925         enddo
5926         write (iout,*) "cosph1ph2 and sinph2ph2"
5927         do k=2,ndouble
5928           do l=1,k-1
5929             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),
5930      &         sinph1ph2(l,k),sinph1ph2(k,l)
5931           enddo
5932         enddo
5933         write(iout,*) "ethetai",ethetai
5934         endif
5935         do m=1,ntheterm2
5936           do k=1,nsingle
5937             aux=bbthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)
5938      &         +ccthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k)
5939      &         +ddthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)
5940      &         +eethet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k)
5941             ethetai=ethetai+sinkt(m)*aux
5942             dethetai=dethetai+0.5d0*m*aux*coskt(m)
5943             dephii=dephii+k*sinkt(m)*(
5944      &          ccthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)-
5945      &          bbthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k))
5946             dephii1=dephii1+k*sinkt(m)*(
5947      &          eethet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)-
5948      &          ddthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k))
5949             if (lprn)
5950      &      write (iout,*) "m",m," k",k," bbthet",
5951      &         bbthet(k,m,ityp1,ityp2,ityp3,iblock)," ccthet",
5952      &         ccthet(k,m,ityp1,ityp2,ityp3,iblock)," ddthet",
5953      &         ddthet(k,m,ityp1,ityp2,ityp3,iblock)," eethet",
5954      &         eethet(k,m,ityp1,ityp2,ityp3,iblock)," ethetai",ethetai
5955           enddo
5956         enddo
5957         if (lprn)
5958      &  write(iout,*) "ethetai",ethetai
5959         do m=1,ntheterm3
5960           do k=2,ndouble
5961             do l=1,k-1
5962               aux=ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
5963      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l)+
5964      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
5965      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)
5966               ethetai=ethetai+sinkt(m)*aux
5967               dethetai=dethetai+0.5d0*m*coskt(m)*aux
5968               dephii=dephii+l*sinkt(m)*(
5969      &           -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)-
5970      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
5971      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
5972      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
5973               dephii1=dephii1+(k-l)*sinkt(m)*(
5974      &           -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
5975      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
5976      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)-
5977      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
5978               if (lprn) then
5979               write (iout,*) "m",m," k",k," l",l," ffthet",
5980      &            ffthet(l,k,m,ityp1,ityp2,ityp3,iblock),
5981      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)," ggthet",
5982      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock),
5983      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock),
5984      &            " ethetai",ethetai
5985               write (iout,*) cosph1ph2(l,k)*sinkt(m),
5986      &            cosph1ph2(k,l)*sinkt(m),
5987      &            sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
5988               endif
5989             enddo
5990           enddo
5991         enddo
5992 10      continue
5993 c        lprn1=.true.
5994         if (lprn1)
5995      &    write (iout,'(i2,3f8.1,9h ethetai ,f10.5)')
5996      &   i,theta(i)*rad2deg,phii*rad2deg,
5997      &   phii1*rad2deg,ethetai
5998 c        lprn1=.false.
5999         etheta=etheta+ethetai
6000         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
6001      &      'ebend',i,ethetai
6002         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
6003         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
6004         gloc(nphi+i-2,icg)=wang*dethetai+gloc(nphi+i-2,icg)
6005       enddo
6006
6007       return
6008       end
6009 #endif
6010 #ifdef CRYST_SC
6011 c-----------------------------------------------------------------------------
6012       subroutine esc(escloc)
6013 C Calculate the local energy of a side chain and its derivatives in the
6014 C corresponding virtual-bond valence angles THETA and the spherical angles
6015 C ALPHA and OMEGA.
6016       implicit real*8 (a-h,o-z)
6017       include 'DIMENSIONS'
6018       include 'COMMON.GEO'
6019       include 'COMMON.LOCAL'
6020       include 'COMMON.VAR'
6021       include 'COMMON.INTERACT'
6022       include 'COMMON.DERIV'
6023       include 'COMMON.CHAIN'
6024       include 'COMMON.IOUNITS'
6025       include 'COMMON.NAMES'
6026       include 'COMMON.FFIELD'
6027       include 'COMMON.CONTROL'
6028       double precision x(3),dersc(3),xemp(3),dersc0(3),dersc1(3),
6029      &     ddersc0(3),ddummy(3),xtemp(3),temp(3)
6030       common /sccalc/ time11,time12,time112,theti,it,nlobit
6031       delta=0.02d0*pi
6032       escloc=0.0D0
6033 c     write (iout,'(a)') 'ESC'
6034       do i=loc_start,loc_end
6035         it=itype(i)
6036         if (it.eq.ntyp1) cycle
6037         if (it.eq.10) goto 1
6038         nlobit=nlob(iabs(it))
6039 c       print *,'i=',i,' it=',it,' nlobit=',nlobit
6040 c       write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
6041         theti=theta(i+1)-pipol
6042         x(1)=dtan(theti)
6043         x(2)=alph(i)
6044         x(3)=omeg(i)
6045
6046         if (x(2).gt.pi-delta) then
6047           xtemp(1)=x(1)
6048           xtemp(2)=pi-delta
6049           xtemp(3)=x(3)
6050           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
6051           xtemp(2)=pi
6052           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
6053           call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),
6054      &        escloci,dersc(2))
6055           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
6056      &        ddersc0(1),dersc(1))
6057           call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),
6058      &        ddersc0(3),dersc(3))
6059           xtemp(2)=pi-delta
6060           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
6061           xtemp(2)=pi
6062           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
6063           call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,
6064      &            dersc0(2),esclocbi,dersc02)
6065           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
6066      &            dersc12,dersc01)
6067           call splinthet(x(2),0.5d0*delta,ss,ssd)
6068           dersc0(1)=dersc01
6069           dersc0(2)=dersc02
6070           dersc0(3)=0.0d0
6071           do k=1,3
6072             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
6073           enddo
6074           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
6075 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
6076 c    &             esclocbi,ss,ssd
6077           escloci=ss*escloci+(1.0d0-ss)*esclocbi
6078 c         escloci=esclocbi
6079 c         write (iout,*) escloci
6080         else if (x(2).lt.delta) then
6081           xtemp(1)=x(1)
6082           xtemp(2)=delta
6083           xtemp(3)=x(3)
6084           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
6085           xtemp(2)=0.0d0
6086           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
6087           call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),
6088      &        escloci,dersc(2))
6089           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
6090      &        ddersc0(1),dersc(1))
6091           call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),
6092      &        ddersc0(3),dersc(3))
6093           xtemp(2)=delta
6094           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
6095           xtemp(2)=0.0d0
6096           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
6097           call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,
6098      &            dersc0(2),esclocbi,dersc02)
6099           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
6100      &            dersc12,dersc01)
6101           dersc0(1)=dersc01
6102           dersc0(2)=dersc02
6103           dersc0(3)=0.0d0
6104           call splinthet(x(2),0.5d0*delta,ss,ssd)
6105           do k=1,3
6106             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
6107           enddo
6108           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
6109 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
6110 c    &             esclocbi,ss,ssd
6111           escloci=ss*escloci+(1.0d0-ss)*esclocbi
6112 c         write (iout,*) escloci
6113         else
6114           call enesc(x,escloci,dersc,ddummy,.false.)
6115         endif
6116
6117         escloc=escloc+escloci
6118         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
6119      &     'escloc',i,escloci
6120 c       write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
6121
6122         gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
6123      &   wscloc*dersc(1)
6124         gloc(ialph(i,1),icg)=wscloc*dersc(2)
6125         gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
6126     1   continue
6127       enddo
6128       return
6129       end
6130 C---------------------------------------------------------------------------
6131       subroutine enesc(x,escloci,dersc,ddersc,mixed)
6132       implicit real*8 (a-h,o-z)
6133       include 'DIMENSIONS'
6134       include 'COMMON.GEO'
6135       include 'COMMON.LOCAL'
6136       include 'COMMON.IOUNITS'
6137       common /sccalc/ time11,time12,time112,theti,it,nlobit
6138       double precision x(3),z(3),Ax(3,maxlob,-1:1),dersc(3),ddersc(3)
6139       double precision contr(maxlob,-1:1)
6140       logical mixed
6141 c       write (iout,*) 'it=',it,' nlobit=',nlobit
6142         escloc_i=0.0D0
6143         do j=1,3
6144           dersc(j)=0.0D0
6145           if (mixed) ddersc(j)=0.0d0
6146         enddo
6147         x3=x(3)
6148
6149 C Because of periodicity of the dependence of the SC energy in omega we have
6150 C to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
6151 C To avoid underflows, first compute & store the exponents.
6152
6153         do iii=-1,1
6154
6155           x(3)=x3+iii*dwapi
6156
6157           do j=1,nlobit
6158             do k=1,3
6159               z(k)=x(k)-censc(k,j,it)
6160             enddo
6161             do k=1,3
6162               Axk=0.0D0
6163               do l=1,3
6164                 Axk=Axk+gaussc(l,k,j,it)*z(l)
6165               enddo
6166               Ax(k,j,iii)=Axk
6167             enddo
6168             expfac=0.0D0
6169             do k=1,3
6170               expfac=expfac+Ax(k,j,iii)*z(k)
6171             enddo
6172             contr(j,iii)=expfac
6173           enddo ! j
6174
6175         enddo ! iii
6176
6177         x(3)=x3
6178 C As in the case of ebend, we want to avoid underflows in exponentiation and
6179 C subsequent NaNs and INFs in energy calculation.
6180 C Find the largest exponent
6181         emin=contr(1,-1)
6182         do iii=-1,1
6183           do j=1,nlobit
6184             if (emin.gt.contr(j,iii)) emin=contr(j,iii)
6185           enddo
6186         enddo
6187         emin=0.5D0*emin
6188 cd      print *,'it=',it,' emin=',emin
6189
6190 C Compute the contribution to SC energy and derivatives
6191         do iii=-1,1
6192
6193           do j=1,nlobit
6194 #ifdef OSF
6195             adexp=bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin
6196             if(adexp.ne.adexp) adexp=1.0
6197             expfac=dexp(adexp)
6198 #else
6199             expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin)
6200 #endif
6201 cd          print *,'j=',j,' expfac=',expfac
6202             escloc_i=escloc_i+expfac
6203             do k=1,3
6204               dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
6205             enddo
6206             if (mixed) then
6207               do k=1,3,2
6208                 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii)
6209      &            +gaussc(k,2,j,it))*expfac
6210               enddo
6211             endif
6212           enddo
6213
6214         enddo ! iii
6215
6216         dersc(1)=dersc(1)/cos(theti)**2
6217         ddersc(1)=ddersc(1)/cos(theti)**2
6218         ddersc(3)=ddersc(3)
6219
6220         escloci=-(dlog(escloc_i)-emin)
6221         do j=1,3
6222           dersc(j)=dersc(j)/escloc_i
6223         enddo
6224         if (mixed) then
6225           do j=1,3,2
6226             ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
6227           enddo
6228         endif
6229       return
6230       end
6231 C------------------------------------------------------------------------------
6232       subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
6233       implicit real*8 (a-h,o-z)
6234       include 'DIMENSIONS'
6235       include 'COMMON.GEO'
6236       include 'COMMON.LOCAL'
6237       include 'COMMON.IOUNITS'
6238       common /sccalc/ time11,time12,time112,theti,it,nlobit
6239       double precision x(3),z(3),Ax(3,maxlob),dersc(3)
6240       double precision contr(maxlob)
6241       logical mixed
6242
6243       escloc_i=0.0D0
6244
6245       do j=1,3
6246         dersc(j)=0.0D0
6247       enddo
6248
6249       do j=1,nlobit
6250         do k=1,2
6251           z(k)=x(k)-censc(k,j,it)
6252         enddo
6253         z(3)=dwapi
6254         do k=1,3
6255           Axk=0.0D0
6256           do l=1,3
6257             Axk=Axk+gaussc(l,k,j,it)*z(l)
6258           enddo
6259           Ax(k,j)=Axk
6260         enddo
6261         expfac=0.0D0
6262         do k=1,3
6263           expfac=expfac+Ax(k,j)*z(k)
6264         enddo
6265         contr(j)=expfac
6266       enddo ! j
6267
6268 C As in the case of ebend, we want to avoid underflows in exponentiation and
6269 C subsequent NaNs and INFs in energy calculation.
6270 C Find the largest exponent
6271       emin=contr(1)
6272       do j=1,nlobit
6273         if (emin.gt.contr(j)) emin=contr(j)
6274       enddo
6275       emin=0.5D0*emin
6276
6277 C Compute the contribution to SC energy and derivatives
6278
6279       dersc12=0.0d0
6280       do j=1,nlobit
6281         expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j)+emin)
6282         escloc_i=escloc_i+expfac
6283         do k=1,2
6284           dersc(k)=dersc(k)+Ax(k,j)*expfac
6285         enddo
6286         if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j)
6287      &            +gaussc(1,2,j,it))*expfac
6288         dersc(3)=0.0d0
6289       enddo
6290
6291       dersc(1)=dersc(1)/cos(theti)**2
6292       dersc12=dersc12/cos(theti)**2
6293       escloci=-(dlog(escloc_i)-emin)
6294       do j=1,2
6295         dersc(j)=dersc(j)/escloc_i
6296       enddo
6297       if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
6298       return
6299       end
6300 #else
6301 c----------------------------------------------------------------------------------
6302       subroutine esc(escloc)
6303 C Calculate the local energy of a side chain and its derivatives in the
6304 C corresponding virtual-bond valence angles THETA and the spherical angles
6305 C ALPHA and OMEGA derived from AM1 all-atom calculations.
6306 C added by Urszula Kozlowska. 07/11/2007
6307 C
6308       implicit real*8 (a-h,o-z)
6309       include 'DIMENSIONS'
6310       include 'COMMON.GEO'
6311       include 'COMMON.LOCAL'
6312       include 'COMMON.VAR'
6313       include 'COMMON.SCROT'
6314       include 'COMMON.INTERACT'
6315       include 'COMMON.DERIV'
6316       include 'COMMON.CHAIN'
6317       include 'COMMON.IOUNITS'
6318       include 'COMMON.NAMES'
6319       include 'COMMON.FFIELD'
6320       include 'COMMON.CONTROL'
6321       include 'COMMON.VECTORS'
6322       double precision x_prime(3),y_prime(3),z_prime(3)
6323      &    , sumene,dsc_i,dp2_i,x(65),
6324      &     xx,yy,zz,sumene1,sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6,
6325      &    de_dxx,de_dyy,de_dzz,de_dt
6326       double precision s1_t,s1_6_t,s2_t,s2_6_t
6327       double precision
6328      & dXX_Ci1(3),dYY_Ci1(3),dZZ_Ci1(3),dXX_Ci(3),
6329      & dYY_Ci(3),dZZ_Ci(3),dXX_XYZ(3),dYY_XYZ(3),dZZ_XYZ(3),
6330      & dt_dCi(3),dt_dCi1(3)
6331       common /sccalc/ time11,time12,time112,theti,it,nlobit
6332       delta=0.02d0*pi
6333       escloc=0.0D0
6334       do i=loc_start,loc_end
6335         if (itype(i).eq.ntyp1) cycle
6336         costtab(i+1) =dcos(theta(i+1))
6337         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
6338         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
6339         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
6340         cosfac2=0.5d0/(1.0d0+costtab(i+1))
6341         cosfac=dsqrt(cosfac2)
6342         sinfac2=0.5d0/(1.0d0-costtab(i+1))
6343         sinfac=dsqrt(sinfac2)
6344         it=iabs(itype(i))
6345         if (it.eq.10) goto 1
6346 c
6347 C  Compute the axes of tghe local cartesian coordinates system; store in
6348 c   x_prime, y_prime and z_prime
6349 c
6350         do j=1,3
6351           x_prime(j) = 0.00
6352           y_prime(j) = 0.00
6353           z_prime(j) = 0.00
6354         enddo
6355 C        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
6356 C     &   dc_norm(3,i+nres)
6357         do j = 1,3
6358           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
6359           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
6360         enddo
6361         do j = 1,3
6362           z_prime(j) = -uz(j,i-1)*dsign(1.0d0,dfloat(itype(i)))
6363         enddo
6364 c       write (2,*) "i",i
6365 c       write (2,*) "x_prime",(x_prime(j),j=1,3)
6366 c       write (2,*) "y_prime",(y_prime(j),j=1,3)
6367 c       write (2,*) "z_prime",(z_prime(j),j=1,3)
6368 c       write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
6369 c      & " xy",scalar(x_prime(1),y_prime(1)),
6370 c      & " xz",scalar(x_prime(1),z_prime(1)),
6371 c      & " yy",scalar(y_prime(1),y_prime(1)),
6372 c      & " yz",scalar(y_prime(1),z_prime(1)),
6373 c      & " zz",scalar(z_prime(1),z_prime(1))
6374 c
6375 C Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
6376 C to local coordinate system. Store in xx, yy, zz.
6377 c
6378         xx=0.0d0
6379         yy=0.0d0
6380         zz=0.0d0
6381         do j = 1,3
6382           xx = xx + x_prime(j)*dc_norm(j,i+nres)
6383           yy = yy + y_prime(j)*dc_norm(j,i+nres)
6384           zz = zz + z_prime(j)*dc_norm(j,i+nres)
6385         enddo
6386
6387         xxtab(i)=xx
6388         yytab(i)=yy
6389         zztab(i)=zz
6390 C
6391 C Compute the energy of the ith side cbain
6392 C
6393 c        write (2,*) "xx",xx," yy",yy," zz",zz
6394         it=iabs(itype(i))
6395         do j = 1,65
6396           x(j) = sc_parmin(j,it)
6397         enddo
6398 #ifdef CHECK_COORD
6399 Cc diagnostics - remove later
6400         xx1 = dcos(alph(2))
6401         yy1 = dsin(alph(2))*dcos(omeg(2))
6402         zz1 = -dsign(1.0,dfloat(itype(i)))*dsin(alph(2))*dsin(omeg(2))
6403         write(2,'(3f8.1,3f9.3,1x,3f9.3)')
6404      &    alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,
6405      &    xx1,yy1,zz1
6406 C,"  --- ", xx_w,yy_w,zz_w
6407 c end diagnostics
6408 #endif
6409         sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
6410      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
6411      &   + x(10)*yy*zz
6412         sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
6413      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
6414      & + x(20)*yy*zz
6415         sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
6416      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
6417      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
6418      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
6419      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
6420      &  +x(40)*xx*yy*zz
6421         sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
6422      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
6423      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
6424      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
6425      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
6426      &  +x(60)*xx*yy*zz
6427         dsc_i   = 0.743d0+x(61)
6428         dp2_i   = 1.9d0+x(62)
6429         dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
6430      &          *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
6431         dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
6432      &          *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
6433         s1=(1+x(63))/(0.1d0 + dscp1)
6434         s1_6=(1+x(64))/(0.1d0 + dscp1**6)
6435         s2=(1+x(65))/(0.1d0 + dscp2)
6436         s2_6=(1+x(65))/(0.1d0 + dscp2**6)
6437         sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6)
6438      & + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
6439 c        write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
6440 c     &   sumene4,
6441 c     &   dscp1,dscp2,sumene
6442 c        sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6443         escloc = escloc + sumene
6444         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
6445      &     'escloc',i,sumene
6446 c        write (2,*) "i",i," escloc",sumene,escloc,it,itype(i)
6447 c     & ,zz,xx,yy
6448 c#define DEBUG
6449 #ifdef DEBUG
6450 C
6451 C This section to check the numerical derivatives of the energy of ith side
6452 C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
6453 C #define DEBUG in the code to turn it on.
6454 C
6455         write (2,*) "sumene               =",sumene
6456         aincr=1.0d-7
6457         xxsave=xx
6458         xx=xx+aincr
6459         write (2,*) xx,yy,zz
6460         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6461         de_dxx_num=(sumenep-sumene)/aincr
6462         xx=xxsave
6463         write (2,*) "xx+ sumene from enesc=",sumenep
6464         yysave=yy
6465         yy=yy+aincr
6466         write (2,*) xx,yy,zz
6467         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6468         de_dyy_num=(sumenep-sumene)/aincr
6469         yy=yysave
6470         write (2,*) "yy+ sumene from enesc=",sumenep
6471         zzsave=zz
6472         zz=zz+aincr
6473         write (2,*) xx,yy,zz
6474         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6475         de_dzz_num=(sumenep-sumene)/aincr
6476         zz=zzsave
6477         write (2,*) "zz+ sumene from enesc=",sumenep
6478         costsave=cost2tab(i+1)
6479         sintsave=sint2tab(i+1)
6480         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
6481         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
6482         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6483         de_dt_num=(sumenep-sumene)/aincr
6484         write (2,*) " t+ sumene from enesc=",sumenep
6485         cost2tab(i+1)=costsave
6486         sint2tab(i+1)=sintsave
6487 C End of diagnostics section.
6488 #endif
6489 C
6490 C Compute the gradient of esc
6491 C
6492 c        zz=zz*dsign(1.0,dfloat(itype(i)))
6493         pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
6494         pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
6495         pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
6496         pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
6497         pom_dx=dsc_i*dp2_i*cost2tab(i+1)
6498         pom_dy=dsc_i*dp2_i*sint2tab(i+1)
6499         pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
6500         pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
6501         pom1=(sumene3*sint2tab(i+1)+sumene1)
6502      &     *(pom_s1/dscp1+pom_s16*dscp1**4)
6503         pom2=(sumene4*cost2tab(i+1)+sumene2)
6504      &     *(pom_s2/dscp2+pom_s26*dscp2**4)
6505         sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
6506         sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2
6507      &  +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2)
6508      &  +x(40)*yy*zz
6509         sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
6510         sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2
6511      &  +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2)
6512      &  +x(60)*yy*zz
6513         de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6)
6514      &        +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6)
6515      &        +(pom1+pom2)*pom_dx
6516 #ifdef DEBUG
6517         write(2,*), "de_dxx = ", de_dxx,de_dxx_num,itype(i)
6518 #endif
6519 C
6520         sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
6521         sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2
6522      &  +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2)
6523      &  +x(40)*xx*zz
6524         sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
6525         sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz
6526      &  +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz
6527      &  +x(59)*zz**2 +x(60)*xx*zz
6528         de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6)
6529      &        +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6)
6530      &        +(pom1-pom2)*pom_dy
6531 #ifdef DEBUG
6532         write(2,*), "de_dyy = ", de_dyy,de_dyy_num,itype(i)
6533 #endif
6534 C
6535         de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy
6536      &  +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx
6537      &  +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6)
6538      &  +(x(4) + 2*x(7)*zz+  x(8)*xx + x(10)*yy)*(s1+s1_6)
6539      &  +(x(44)+2*x(47)*zz +x(48)*xx   +x(50)*yy  +3*x(53)*zz**2
6540      &  +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy
6541      &  +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6)
6542      &  + ( x(14) + 2*x(17)*zz+  x(18)*xx + x(20)*yy)*(s2+s2_6)
6543 #ifdef DEBUG
6544         write(2,*), "de_dzz = ", de_dzz,de_dzz_num,itype(i)
6545 #endif
6546 C
6547         de_dt =  0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6)
6548      &  -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6)
6549      &  +pom1*pom_dt1+pom2*pom_dt2
6550 #ifdef DEBUG
6551         write(2,*), "de_dt = ", de_dt,de_dt_num,itype(i)
6552 #endif
6553 c#undef DEBUG
6554 c
6555 C
6556        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
6557        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
6558        cosfac2xx=cosfac2*xx
6559        sinfac2yy=sinfac2*yy
6560        do k = 1,3
6561          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))*
6562      &      vbld_inv(i+1)
6563          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))*
6564      &      vbld_inv(i)
6565          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
6566          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
6567 c         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
6568 c     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
6569 c         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
6570 c     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
6571          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
6572          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
6573          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
6574          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
6575          dZZ_Ci1(k)=0.0d0
6576          dZZ_Ci(k)=0.0d0
6577          do j=1,3
6578            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)
6579      &     *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
6580            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)
6581      &     *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
6582          enddo
6583
6584          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
6585          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
6586          dZZ_XYZ(k)=vbld_inv(i+nres)*
6587      &   (z_prime(k)-zz*dC_norm(k,i+nres))
6588 c
6589          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
6590          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
6591        enddo
6592
6593        do k=1,3
6594          dXX_Ctab(k,i)=dXX_Ci(k)
6595          dXX_C1tab(k,i)=dXX_Ci1(k)
6596          dYY_Ctab(k,i)=dYY_Ci(k)
6597          dYY_C1tab(k,i)=dYY_Ci1(k)
6598          dZZ_Ctab(k,i)=dZZ_Ci(k)
6599          dZZ_C1tab(k,i)=dZZ_Ci1(k)
6600          dXX_XYZtab(k,i)=dXX_XYZ(k)
6601          dYY_XYZtab(k,i)=dYY_XYZ(k)
6602          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
6603        enddo
6604
6605        do k = 1,3
6606 c         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
6607 c     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
6608 c         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
6609 c     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
6610 c         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
6611 c     &    dt_dci(k)
6612 c         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
6613 c     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
6614          gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k)
6615      &    +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
6616          gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k)
6617      &    +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
6618          gsclocx(k,i)=                 de_dxx*dxx_XYZ(k)
6619      &    +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
6620        enddo
6621 c       write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
6622 c     &  (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
6623
6624 C to check gradient call subroutine check_grad
6625
6626     1 continue
6627       enddo
6628       return
6629       end
6630 c------------------------------------------------------------------------------
6631       double precision function enesc(x,xx,yy,zz,cost2,sint2)
6632       implicit none
6633       double precision x(65),xx,yy,zz,cost2,sint2,sumene1,sumene2,
6634      & sumene3,sumene4,sumene,dsc_i,dp2_i,dscp1,dscp2,s1,s1_6,s2,s2_6
6635       sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
6636      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
6637      &   + x(10)*yy*zz
6638       sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
6639      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
6640      & + x(20)*yy*zz
6641       sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
6642      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
6643      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
6644      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
6645      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
6646      &  +x(40)*xx*yy*zz
6647       sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
6648      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
6649      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
6650      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
6651      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
6652      &  +x(60)*xx*yy*zz
6653       dsc_i   = 0.743d0+x(61)
6654       dp2_i   = 1.9d0+x(62)
6655       dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
6656      &          *(xx*cost2+yy*sint2))
6657       dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
6658      &          *(xx*cost2-yy*sint2))
6659       s1=(1+x(63))/(0.1d0 + dscp1)
6660       s1_6=(1+x(64))/(0.1d0 + dscp1**6)
6661       s2=(1+x(65))/(0.1d0 + dscp2)
6662       s2_6=(1+x(65))/(0.1d0 + dscp2**6)
6663       sumene = ( sumene3*sint2 + sumene1)*(s1+s1_6)
6664      & + (sumene4*cost2 +sumene2)*(s2+s2_6)
6665       enesc=sumene
6666       return
6667       end
6668 #endif
6669 c------------------------------------------------------------------------------
6670       subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
6671 C
6672 C This procedure calculates two-body contact function g(rij) and its derivative:
6673 C
6674 C           eps0ij                                     !       x < -1
6675 C g(rij) =  esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5)  ! -1 =< x =< 1
6676 C            0                                         !       x > 1
6677 C
6678 C where x=(rij-r0ij)/delta
6679 C
6680 C rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
6681 C
6682       implicit none
6683       double precision rij,r0ij,eps0ij,fcont,fprimcont
6684       double precision x,x2,x4,delta
6685 c     delta=0.02D0*r0ij
6686 c      delta=0.2D0*r0ij
6687       x=(rij-r0ij)/delta
6688       if (x.lt.-1.0D0) then
6689         fcont=eps0ij
6690         fprimcont=0.0D0
6691       else if (x.le.1.0D0) then
6692         x2=x*x
6693         x4=x2*x2
6694         fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
6695         fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
6696       else
6697         fcont=0.0D0
6698         fprimcont=0.0D0
6699       endif
6700       return
6701       end
6702 c------------------------------------------------------------------------------
6703       subroutine splinthet(theti,delta,ss,ssder)
6704       implicit real*8 (a-h,o-z)
6705       include 'DIMENSIONS'
6706       include 'COMMON.VAR'
6707       include 'COMMON.GEO'
6708       thetup=pi-delta
6709       thetlow=delta
6710       if (theti.gt.pipol) then
6711         call gcont(theti,thetup,1.0d0,delta,ss,ssder)
6712       else
6713         call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
6714         ssder=-ssder
6715       endif
6716       return
6717       end
6718 c------------------------------------------------------------------------------
6719       subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
6720       implicit none
6721       double precision x,x0,delta,f0,f1,fprim0,f,fprim
6722       double precision ksi,ksi2,ksi3,a1,a2,a3
6723       a1=fprim0*delta/(f1-f0)
6724       a2=3.0d0-2.0d0*a1
6725       a3=a1-2.0d0
6726       ksi=(x-x0)/delta
6727       ksi2=ksi*ksi
6728       ksi3=ksi2*ksi
6729       f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
6730       fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
6731       return
6732       end
6733 c------------------------------------------------------------------------------
6734       subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
6735       implicit none
6736       double precision x,x0,delta,f0x,f1x,fprim0x,fx
6737       double precision ksi,ksi2,ksi3,a1,a2,a3
6738       ksi=(x-x0)/delta
6739       ksi2=ksi*ksi
6740       ksi3=ksi2*ksi
6741       a1=fprim0x*delta
6742       a2=3*(f1x-f0x)-2*fprim0x*delta
6743       a3=fprim0x*delta-2*(f1x-f0x)
6744       fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
6745       return
6746       end
6747 C-----------------------------------------------------------------------------
6748 #ifdef CRYST_TOR
6749 C-----------------------------------------------------------------------------
6750       subroutine etor(etors,edihcnstr)
6751       implicit real*8 (a-h,o-z)
6752       include 'DIMENSIONS'
6753       include 'COMMON.VAR'
6754       include 'COMMON.GEO'
6755       include 'COMMON.LOCAL'
6756       include 'COMMON.TORSION'
6757       include 'COMMON.INTERACT'
6758       include 'COMMON.DERIV'
6759       include 'COMMON.CHAIN'
6760       include 'COMMON.NAMES'
6761       include 'COMMON.IOUNITS'
6762       include 'COMMON.FFIELD'
6763       include 'COMMON.TORCNSTR'
6764       include 'COMMON.CONTROL'
6765       logical lprn
6766 C Set lprn=.true. for debugging
6767       lprn=.false.
6768 c      lprn=.true.
6769       etors=0.0D0
6770       do i=iphi_start,iphi_end
6771       etors_ii=0.0D0
6772         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
6773      &      .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
6774         itori=itortyp(itype(i-2))
6775         itori1=itortyp(itype(i-1))
6776         phii=phi(i)
6777         gloci=0.0D0
6778 C Proline-Proline pair is a special case...
6779         if (itori.eq.3 .and. itori1.eq.3) then
6780           if (phii.gt.-dwapi3) then
6781             cosphi=dcos(3*phii)
6782             fac=1.0D0/(1.0D0-cosphi)
6783             etorsi=v1(1,3,3)*fac
6784             etorsi=etorsi+etorsi
6785             etors=etors+etorsi-v1(1,3,3)
6786             if (energy_dec) etors_ii=etors_ii+etorsi-v1(1,3,3)
6787             gloci=gloci-3*fac*etorsi*dsin(3*phii)
6788           endif
6789           do j=1,3
6790             v1ij=v1(j+1,itori,itori1)
6791             v2ij=v2(j+1,itori,itori1)
6792             cosphi=dcos(j*phii)
6793             sinphi=dsin(j*phii)
6794             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
6795             if (energy_dec) etors_ii=etors_ii+
6796      &                              v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
6797             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
6798           enddo
6799         else
6800           do j=1,nterm_old
6801             v1ij=v1(j,itori,itori1)
6802             v2ij=v2(j,itori,itori1)
6803             cosphi=dcos(j*phii)
6804             sinphi=dsin(j*phii)
6805             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
6806             if (energy_dec) etors_ii=etors_ii+
6807      &                  v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
6808             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
6809           enddo
6810         endif
6811         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
6812              'etor',i,etors_ii
6813         if (lprn)
6814      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
6815      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
6816      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
6817         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
6818 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
6819       enddo
6820 ! 6/20/98 - dihedral angle constraints
6821       edihcnstr=0.0d0
6822       do i=1,ndih_constr
6823         itori=idih_constr(i)
6824         phii=phi(itori)
6825         difi=phii-phi0(i)
6826         if (difi.gt.drange(i)) then
6827           difi=difi-drange(i)
6828           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
6829           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
6830         else if (difi.lt.-drange(i)) then
6831           difi=difi+drange(i)
6832           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
6833           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
6834         endif
6835 !        write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii,
6836 !     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
6837       enddo
6838 !      write (iout,*) 'edihcnstr',edihcnstr
6839       return
6840       end
6841 c------------------------------------------------------------------------------
6842 c LICZENIE WIEZOW Z ROWNANIA ENERGII MODELLERA
6843       subroutine e_modeller(ehomology_constr)
6844       ehomology_constr=0.0d0
6845       write (iout,*) "!!!!!UWAGA, JESTEM W DZIWNEJ PETLI, TEST!!!!!"
6846       return
6847       end
6848 C !!!!!!!! NIE CZYTANE !!!!!!!!!!!
6849
6850 c------------------------------------------------------------------------------
6851       subroutine etor_d(etors_d)
6852       etors_d=0.0d0
6853       return
6854       end
6855 c----------------------------------------------------------------------------
6856 #else
6857       subroutine etor(etors,edihcnstr)
6858       implicit real*8 (a-h,o-z)
6859       include 'DIMENSIONS'
6860       include 'COMMON.VAR'
6861       include 'COMMON.GEO'
6862       include 'COMMON.LOCAL'
6863       include 'COMMON.TORSION'
6864       include 'COMMON.INTERACT'
6865       include 'COMMON.DERIV'
6866       include 'COMMON.CHAIN'
6867       include 'COMMON.NAMES'
6868       include 'COMMON.IOUNITS'
6869       include 'COMMON.FFIELD'
6870       include 'COMMON.TORCNSTR'
6871       include 'COMMON.CONTROL'
6872       logical lprn
6873 C Set lprn=.true. for debugging
6874       lprn=.false.
6875 c     lprn=.true.
6876       etors=0.0D0
6877       do i=iphi_start,iphi_end
6878 C ANY TWO ARE DUMMY ATOMS in row CYCLE
6879 c        if (((itype(i-3).eq.ntyp1).and.(itype(i-2).eq.ntyp1)).or.
6880 c     &      ((itype(i-2).eq.ntyp1).and.(itype(i-1).eq.ntyp1))  .or.
6881 c     &      ((itype(i-1).eq.ntyp1).and.(itype(i).eq.ntyp1))) cycle
6882         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
6883      &      .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
6884 C In current verion the ALL DUMMY ATOM POTENTIALS ARE OFF
6885 C For introducing the NH3+ and COO- group please check the etor_d for reference
6886 C and guidance
6887         etors_ii=0.0D0
6888          if (iabs(itype(i)).eq.20) then
6889          iblock=2
6890          else
6891          iblock=1
6892          endif
6893         itori=itortyp(itype(i-2))
6894         itori1=itortyp(itype(i-1))
6895         phii=phi(i)
6896         gloci=0.0D0
6897 C Regular cosine and sine terms
6898         do j=1,nterm(itori,itori1,iblock)
6899           v1ij=v1(j,itori,itori1,iblock)
6900           v2ij=v2(j,itori,itori1,iblock)
6901           cosphi=dcos(j*phii)
6902           sinphi=dsin(j*phii)
6903           etors=etors+v1ij*cosphi+v2ij*sinphi
6904           if (energy_dec) etors_ii=etors_ii+
6905      &                v1ij*cosphi+v2ij*sinphi
6906           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
6907         enddo
6908 C Lorentz terms
6909 C                         v1
6910 C  E = SUM ----------------------------------- - v1
6911 C          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
6912 C
6913         cosphi=dcos(0.5d0*phii)
6914         sinphi=dsin(0.5d0*phii)
6915         do j=1,nlor(itori,itori1,iblock)
6916           vl1ij=vlor1(j,itori,itori1)
6917           vl2ij=vlor2(j,itori,itori1)
6918           vl3ij=vlor3(j,itori,itori1)
6919           pom=vl2ij*cosphi+vl3ij*sinphi
6920           pom1=1.0d0/(pom*pom+1.0d0)
6921           etors=etors+vl1ij*pom1
6922           if (energy_dec) etors_ii=etors_ii+
6923      &                vl1ij*pom1
6924           pom=-pom*pom1*pom1
6925           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
6926         enddo
6927 C Subtract the constant term
6928         etors=etors-v0(itori,itori1,iblock)
6929           if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
6930      &         'etor',i,etors_ii-v0(itori,itori1,iblock)
6931         if (lprn)
6932      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
6933      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
6934      &  (v1(j,itori,itori1,iblock),j=1,6),
6935      &  (v2(j,itori,itori1,iblock),j=1,6)
6936         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
6937 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
6938       enddo
6939 ! 6/20/98 - dihedral angle constraints
6940       edihcnstr=0.0d0
6941 c      do i=1,ndih_constr
6942       do i=idihconstr_start,idihconstr_end
6943         itori=idih_constr(i)
6944         phii=phi(itori)
6945         difi=pinorm(phii-phi0(i))
6946         if (difi.gt.drange(i)) then
6947           difi=difi-drange(i)
6948           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
6949           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
6950         else if (difi.lt.-drange(i)) then
6951           difi=difi+drange(i)
6952           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
6953           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
6954         else
6955           difi=0.0
6956         endif
6957 cd        write (iout,'(2i5,4f8.3,2e14.5)') i,itori,rad2deg*phii,
6958 cd     &    rad2deg*phi0(i),  rad2deg*drange(i),
6959 cd     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
6960       enddo
6961 cd       write (iout,*) 'edihcnstr',edihcnstr
6962       return
6963       end
6964 c----------------------------------------------------------------------------
6965 c MODELLER restraint function
6966       subroutine e_modeller(ehomology_constr)
6967       implicit real*8 (a-h,o-z)
6968       include 'DIMENSIONS'
6969
6970       integer nnn, i, j, k, ki, irec, l
6971       integer katy, odleglosci, test7
6972       real*8 odleg, odleg2, odleg3, kat, kat2, kat3, gdih(max_template)
6973       real*8 Eval,Erot
6974       real*8 distance(max_template),distancek(max_template),
6975      &    min_odl,godl(max_template),dih_diff(max_template)
6976
6977 c
6978 c     FP - 30/10/2014 Temporary specifications for homology restraints
6979 c
6980       double precision utheta_i,gutheta_i,sum_gtheta,sum_sgtheta,
6981      &                 sgtheta
6982       double precision, dimension (maxres) :: guscdiff,usc_diff
6983       double precision, dimension (max_template) ::
6984      &           gtheta,dscdiff,uscdiffk,guscdiff2,guscdiff3,
6985      &           theta_diff
6986 c
6987
6988       include 'COMMON.SBRIDGE'
6989       include 'COMMON.CHAIN'
6990       include 'COMMON.GEO'
6991       include 'COMMON.DERIV'
6992       include 'COMMON.LOCAL'
6993       include 'COMMON.INTERACT'
6994       include 'COMMON.VAR'
6995       include 'COMMON.IOUNITS'
6996       include 'COMMON.MD'
6997       include 'COMMON.CONTROL'
6998 c
6999 c     From subroutine Econstr_back
7000 c
7001       include 'COMMON.NAMES'
7002       include 'COMMON.TIME1'
7003 c
7004
7005
7006       do i=1,max_template
7007         distancek(i)=9999999.9
7008       enddo
7009
7010
7011       odleg=0.0d0
7012
7013 c Pseudo-energy and gradient from homology restraints (MODELLER-like
7014 c function)
7015 C AL 5/2/14 - Introduce list of restraints
7016 c     write(iout,*) "waga_theta",waga_theta,"waga_d",waga_d
7017 #ifdef DEBUG
7018       write(iout,*) "------- dist restrs start -------"
7019 #endif
7020       do ii = link_start_homo,link_end_homo
7021          i = ires_homo(ii)
7022          j = jres_homo(ii)
7023          dij=dist(i,j)
7024 c        write (iout,*) "dij(",i,j,") =",dij
7025          nexl=0
7026          do k=1,constr_homology
7027 c           write(iout,*) ii,k,i,j,l_homo(k,ii),dij,odl(k,ii)
7028            if(.not.l_homo(k,ii)) then
7029              nexl=nexl+1
7030              cycle
7031            endif
7032            distance(k)=odl(k,ii)-dij
7033 c          write (iout,*) "distance(",k,") =",distance(k)
7034 c
7035 c          For Gaussian-type Urestr
7036 c
7037            distancek(k)=0.5d0*distance(k)**2*sigma_odl(k,ii) ! waga_dist rmvd from Gaussian argument
7038 c          write (iout,*) "sigma_odl(",k,ii,") =",sigma_odl(k,ii)
7039 c          write (iout,*) "distancek(",k,") =",distancek(k)
7040 c          distancek(k)=0.5d0*waga_dist*distance(k)**2*sigma_odl(k,ii)
7041 c
7042 c          For Lorentzian-type Urestr
7043 c
7044            if (waga_dist.lt.0.0d0) then
7045               sigma_odlir(k,ii)=dsqrt(1/sigma_odl(k,ii))
7046               distancek(k)=distance(k)**2/(sigma_odlir(k,ii)*
7047      &                     (distance(k)**2+sigma_odlir(k,ii)**2))
7048            endif
7049          enddo
7050
7051 c         min_odl=minval(distancek)
7052          do kk=1,constr_homology
7053           if(l_homo(kk,ii)) then
7054             min_odl=distancek(kk)
7055             exit
7056           endif
7057          enddo
7058          do kk=1,constr_homology
7059           if(l_homo(kk,ii) .and. distancek(kk).lt.min_odl)
7060      &              min_odl=distancek(kk)
7061          enddo
7062
7063 c        write (iout,* )"min_odl",min_odl
7064 #ifdef DEBUG
7065          write (iout,*) "ij dij",i,j,dij
7066          write (iout,*) "distance",(distance(k),k=1,constr_homology)
7067          write (iout,*) "distancek",(distancek(k),k=1,constr_homology)
7068          write (iout,* )"min_odl",min_odl
7069 #endif
7070 #ifdef OLDRESTR
7071          odleg2=0.0d0
7072 #else
7073          if (waga_dist.ge.0.0d0) then
7074            odleg2=nexl
7075          else
7076            odleg2=0.0d0
7077          endif
7078 #endif
7079          do k=1,constr_homology
7080 c Nie wiem po co to liczycie jeszcze raz!
7081 c            odleg3=-waga_dist(iset)*((distance(i,j,k)**2)/
7082 c     &              (2*(sigma_odl(i,j,k))**2))
7083            if(.not.l_homo(k,ii)) cycle
7084            if (waga_dist.ge.0.0d0) then
7085 c
7086 c          For Gaussian-type Urestr
7087 c
7088             godl(k)=dexp(-distancek(k)+min_odl)
7089             odleg2=odleg2+godl(k)
7090 c
7091 c          For Lorentzian-type Urestr
7092 c
7093            else
7094             odleg2=odleg2+distancek(k)
7095            endif
7096
7097 ccc       write(iout,779) i,j,k, "odleg2=",odleg2, "odleg3=", odleg3,
7098 ccc     & "dEXP(odleg3)=", dEXP(odleg3),"distance(i,j,k)^2=",
7099 ccc     & distance(i,j,k)**2, "dist(i+1,j+1)=", dist(i+1,j+1),
7100 ccc     & "sigma_odl(i,j,k)=", sigma_odl(i,j,k)
7101
7102          enddo
7103 c        write (iout,*) "godl",(godl(k),k=1,constr_homology) ! exponents
7104 c        write (iout,*) "ii i j",ii,i,j," odleg2",odleg2 ! sum of exps
7105 #ifdef DEBUG
7106          write (iout,*) "godl",(godl(k),k=1,constr_homology) ! exponents
7107          write (iout,*) "ii i j",ii,i,j," odleg2",odleg2 ! sum of exps
7108 #endif
7109            if (waga_dist.ge.0.0d0) then
7110 c
7111 c          For Gaussian-type Urestr
7112 c
7113               odleg=odleg-dLOG(odleg2/constr_homology)+min_odl
7114 c
7115 c          For Lorentzian-type Urestr
7116 c
7117            else
7118               odleg=odleg+odleg2/constr_homology
7119            endif
7120 c
7121 c        write (iout,*) "odleg",odleg ! sum of -ln-s
7122 c Gradient
7123 c
7124 c          For Gaussian-type Urestr
7125 c
7126          if (waga_dist.ge.0.0d0) sum_godl=odleg2
7127          sum_sgodl=0.0d0
7128          do k=1,constr_homology
7129 c            godl=dexp(((-(distance(i,j,k)**2)/(2*(sigma_odl(i,j,k))**2))
7130 c     &           *waga_dist)+min_odl
7131 c          sgodl=-godl(k)*distance(k)*sigma_odl(k,ii)*waga_dist
7132 c
7133          if(.not.l_homo(k,ii)) cycle
7134          if (waga_dist.ge.0.0d0) then
7135 c          For Gaussian-type Urestr
7136 c
7137            sgodl=-godl(k)*distance(k)*sigma_odl(k,ii) ! waga_dist rmvd
7138 c
7139 c          For Lorentzian-type Urestr
7140 c
7141          else
7142            sgodl=-2*sigma_odlir(k,ii)*(distance(k)/(distance(k)**2+
7143      &           sigma_odlir(k,ii)**2)**2)
7144          endif
7145            sum_sgodl=sum_sgodl+sgodl
7146
7147 c            sgodl2=sgodl2+sgodl
7148 c      write(iout,*) i, j, k, distance(i,j,k), "W GRADIENCIE1"
7149 c      write(iout,*) "constr_homology=",constr_homology
7150 c      write(iout,*) i, j, k, "TEST K"
7151          enddo
7152          if (waga_dist.ge.0.0d0) then
7153 c
7154 c          For Gaussian-type Urestr
7155 c
7156             grad_odl3=waga_homology(iset)*waga_dist
7157      &                *sum_sgodl/(sum_godl*dij)
7158 c
7159 c          For Lorentzian-type Urestr
7160 c
7161          else
7162 c Original grad expr modified by analogy w Gaussian-type Urestr grad
7163 c           grad_odl3=-waga_homology(iset)*waga_dist*sum_sgodl
7164             grad_odl3=-waga_homology(iset)*waga_dist*
7165      &                sum_sgodl/(constr_homology*dij)
7166          endif
7167 c
7168 c        grad_odl3=sum_sgodl/(sum_godl*dij)
7169
7170
7171 c      write(iout,*) i, j, k, distance(i,j,k), "W GRADIENCIE2"
7172 c      write(iout,*) (distance(i,j,k)**2), (2*(sigma_odl(i,j,k))**2),
7173 c     &              (-(distance(i,j,k)**2)/(2*(sigma_odl(i,j,k))**2))
7174
7175 ccc      write(iout,*) godl, sgodl, grad_odl3
7176
7177 c          grad_odl=grad_odl+grad_odl3
7178
7179          do jik=1,3
7180             ggodl=grad_odl3*(c(jik,i)-c(jik,j))
7181 ccc      write(iout,*) c(jik,i+1), c(jik,j+1), (c(jik,i+1)-c(jik,j+1))
7182 ccc      write(iout,746) "GRAD_ODL_1", i, j, jik, ggodl,
7183 ccc     &              ghpbc(jik,i+1), ghpbc(jik,j+1)
7184             ghpbc(jik,i)=ghpbc(jik,i)+ggodl
7185             ghpbc(jik,j)=ghpbc(jik,j)-ggodl
7186 ccc      write(iout,746) "GRAD_ODL_2", i, j, jik, ggodl,
7187 ccc     &              ghpbc(jik,i+1), ghpbc(jik,j+1)
7188 c         if (i.eq.25.and.j.eq.27) then
7189 c         write(iout,*) "jik",jik,"i",i,"j",j
7190 c         write(iout,*) "sum_sgodl",sum_sgodl,"sgodl",sgodl
7191 c         write(iout,*) "grad_odl3",grad_odl3
7192 c         write(iout,*) "c(",jik,i,")",c(jik,i),"c(",jik,j,")",c(jik,j)
7193 c         write(iout,*) "ggodl",ggodl
7194 c         write(iout,*) "ghpbc(",jik,i,")",
7195 c     &                 ghpbc(jik,i),"ghpbc(",jik,j,")",
7196 c     &                 ghpbc(jik,j)
7197 c         endif
7198          enddo
7199 ccc       write(iout,778)"TEST: odleg2=", odleg2, "DLOG(odleg2)=",
7200 ccc     & dLOG(odleg2),"-odleg=", -odleg
7201
7202       enddo ! ii-loop for dist
7203 #ifdef DEBUG
7204       write(iout,*) "------- dist restrs end -------"
7205 c     if (waga_angle.eq.1.0d0 .or. waga_theta.eq.1.0d0 .or.
7206 c    &     waga_d.eq.1.0d0) call sum_gradient
7207 #endif
7208 c Pseudo-energy and gradient from dihedral-angle restraints from
7209 c homology templates
7210 c      write (iout,*) "End of distance loop"
7211 c      call flush(iout)
7212       kat=0.0d0
7213 c      write (iout,*) idihconstr_start_homo,idihconstr_end_homo
7214 #ifdef DEBUG
7215       write(iout,*) "------- dih restrs start -------"
7216       do i=idihconstr_start_homo,idihconstr_end_homo
7217         write (iout,*) "gloc_init(",i,icg,")",gloc(i,icg)
7218       enddo
7219 #endif
7220       do i=idihconstr_start_homo,idihconstr_end_homo
7221         kat2=0.0d0
7222 c        betai=beta(i,i+1,i+2,i+3)
7223         betai = phi(i)
7224 c       write (iout,*) "betai =",betai
7225         do k=1,constr_homology
7226           dih_diff(k)=pinorm(dih(k,i)-betai)
7227 cd          write (iout,'(a8,2i4,2f15.8)') "dih_diff",i,k,dih_diff(k)
7228 cd     &                  ,sigma_dih(k,i)
7229 c          if (dih_diff(i,k).gt.3.14159) dih_diff(i,k)=
7230 c     &                                   -(6.28318-dih_diff(i,k))
7231 c          if (dih_diff(i,k).lt.-3.14159) dih_diff(i,k)=
7232 c     &                                   6.28318+dih_diff(i,k)
7233 #ifdef OLD_DIHED
7234           kat3=-0.5d0*dih_diff(k)**2*sigma_dih(k,i) ! waga_angle rmvd from Gaussian argument
7235 #else
7236           kat3=(dcos(dih_diff(k))-1)*sigma_dih(k,i) ! waga_angle rmvd from Gaussian argument
7237 #endif
7238 c         kat3=-0.5d0*waga_angle*dih_diff(k)**2*sigma_dih(k,i)
7239           gdih(k)=dexp(kat3)
7240           kat2=kat2+gdih(k)
7241 c          write(iout,*) "kat2=", kat2, "exp(kat3)=", exp(kat3)
7242 c          write(*,*)""
7243         enddo
7244 c       write (iout,*) "gdih",(gdih(k),k=1,constr_homology) ! exps
7245 c       write (iout,*) "i",i," betai",betai," kat2",kat2 ! sum of exps
7246 #ifdef DEBUG
7247         write (iout,*) "i",i," betai",betai," kat2",kat2
7248         write (iout,*) "gdih",(gdih(k),k=1,constr_homology)
7249 #endif
7250         if (kat2.le.1.0d-14) cycle
7251         kat=kat-dLOG(kat2/constr_homology)
7252 c       write (iout,*) "kat",kat ! sum of -ln-s
7253
7254 ccc       write(iout,778)"TEST: kat2=", kat2, "DLOG(kat2)=",
7255 ccc     & dLOG(kat2), "-kat=", -kat
7256
7257 c ----------------------------------------------------------------------
7258 c Gradient
7259 c ----------------------------------------------------------------------
7260
7261         sum_gdih=kat2
7262         sum_sgdih=0.0d0
7263         do k=1,constr_homology
7264 #ifdef OLD_DIHED
7265           sgdih=-gdih(k)*dih_diff(k)*sigma_dih(k,i)  ! waga_angle rmvd
7266 #else
7267           sgdih=-gdih(k)*dsin(dih_diff(k))*sigma_dih(k,i)  ! waga_angle rmvd
7268 #endif
7269 c         sgdih=-gdih(k)*dih_diff(k)*sigma_dih(k,i)*waga_angle
7270           sum_sgdih=sum_sgdih+sgdih
7271         enddo
7272 c       grad_dih3=sum_sgdih/sum_gdih
7273         grad_dih3=waga_homology(iset)*waga_angle*sum_sgdih/sum_gdih
7274
7275 c      write(iout,*)i,k,gdih,sgdih,beta(i+1,i+2,i+3,i+4),grad_dih3
7276 ccc      write(iout,747) "GRAD_KAT_1", i, nphi, icg, grad_dih3,
7277 ccc     & gloc(nphi+i-3,icg)
7278         gloc(i-3,icg)=gloc(i-3,icg)+grad_dih3
7279 c        if (i.eq.25) then
7280 c        write(iout,*) "i",i,"icg",icg,"gloc(",i,icg,")",gloc(i,icg)
7281 c        endif
7282 ccc      write(iout,747) "GRAD_KAT_2", i, nphi, icg, grad_dih3,
7283 ccc     & gloc(nphi+i-3,icg)
7284
7285       enddo ! i-loop for dih
7286 #ifdef DEBUG
7287       write(iout,*) "------- dih restrs end -------"
7288 #endif
7289
7290 c Pseudo-energy and gradient for theta angle restraints from
7291 c homology templates
7292 c FP 01/15 - inserted from econstr_local_test.F, loop structure
7293 c adapted
7294
7295 c
7296 c     For constr_homology reference structures (FP)
7297 c
7298 c     Uconst_back_tot=0.0d0
7299       Eval=0.0d0
7300       Erot=0.0d0
7301 c     Econstr_back legacy
7302       do i=1,nres
7303 c     do i=ithet_start,ithet_end
7304        dutheta(i)=0.0d0
7305 c     enddo
7306 c     do i=loc_start,loc_end
7307         do j=1,3
7308           duscdiff(j,i)=0.0d0
7309           duscdiffx(j,i)=0.0d0
7310         enddo
7311       enddo
7312 c
7313 c     do iref=1,nref
7314 c     write (iout,*) "ithet_start =",ithet_start,"ithet_end =",ithet_end
7315 c     write (iout,*) "waga_theta",waga_theta
7316       if (waga_theta.gt.0.0d0) then
7317 #ifdef DEBUG
7318       write (iout,*) "usampl",usampl
7319       write(iout,*) "------- theta restrs start -------"
7320 c     do i=ithet_start,ithet_end
7321 c       write (iout,*) "gloc_init(",nphi+i,icg,")",gloc(nphi+i,icg)
7322 c     enddo
7323 #endif
7324 c     write (iout,*) "maxres",maxres,"nres",nres
7325
7326       do i=ithet_start,ithet_end
7327 c
7328 c     do i=1,nfrag_back
7329 c       ii = ifrag_back(2,i,iset)-ifrag_back(1,i,iset)
7330 c
7331 c Deviation of theta angles wrt constr_homology ref structures
7332 c
7333         utheta_i=0.0d0 ! argument of Gaussian for single k
7334         gutheta_i=0.0d0 ! Sum of Gaussians over constr_homology ref structures
7335 c       do j=ifrag_back(1,i,iset)+2,ifrag_back(2,i,iset) ! original loop
7336 c       over residues in a fragment
7337 c       write (iout,*) "theta(",i,")=",theta(i)
7338         do k=1,constr_homology
7339 c
7340 c         dtheta_i=theta(j)-thetaref(j,iref)
7341 c         dtheta_i=thetaref(k,i)-theta(i) ! original form without indexing
7342           theta_diff(k)=thetatpl(k,i)-theta(i)
7343 cd          write (iout,'(a8,2i4,2f15.8)') "theta_diff",i,k,theta_diff(k)
7344 cd     &                  ,sigma_theta(k,i)
7345
7346 c
7347           utheta_i=-0.5d0*theta_diff(k)**2*sigma_theta(k,i) ! waga_theta rmvd from Gaussian argument
7348 c         utheta_i=-0.5d0*waga_theta*theta_diff(k)**2*sigma_theta(k,i) ! waga_theta?
7349           gtheta(k)=dexp(utheta_i) ! + min_utheta_i?
7350           gutheta_i=gutheta_i+gtheta(k)  ! Sum of Gaussians (pk)
7351 c         Gradient for single Gaussian restraint in subr Econstr_back
7352 c         dutheta(j-2)=dutheta(j-2)+wfrag_back(1,i,iset)*dtheta_i/(ii-1)
7353 c
7354         enddo
7355 c       write (iout,*) "gtheta",(gtheta(k),k=1,constr_homology) ! exps
7356 c       write (iout,*) "i",i," gutheta_i",gutheta_i ! sum of exps
7357
7358 c
7359 c         Gradient for multiple Gaussian restraint
7360         sum_gtheta=gutheta_i
7361         sum_sgtheta=0.0d0
7362         do k=1,constr_homology
7363 c        New generalized expr for multiple Gaussian from Econstr_back
7364          sgtheta=-gtheta(k)*theta_diff(k)*sigma_theta(k,i) ! waga_theta rmvd
7365 c
7366 c        sgtheta=-gtheta(k)*theta_diff(k)*sigma_theta(k,i)*waga_theta ! right functional form?
7367           sum_sgtheta=sum_sgtheta+sgtheta ! cum variable
7368         enddo
7369 c       Final value of gradient using same var as in Econstr_back
7370         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)
7371      &      +sum_sgtheta/sum_gtheta*waga_theta
7372      &               *waga_homology(iset)
7373 c        dutheta(i-2)=sum_sgtheta/sum_gtheta*waga_theta
7374 c     &               *waga_homology(iset)
7375 c       dutheta(i)=sum_sgtheta/sum_gtheta
7376 c
7377 c       Uconst_back=Uconst_back+waga_theta*utheta(i) ! waga_theta added as weight
7378         Eval=Eval-dLOG(gutheta_i/constr_homology)
7379 c       write (iout,*) "utheta(",i,")=",utheta(i) ! -ln of sum of exps
7380 c       write (iout,*) "Uconst_back",Uconst_back ! sum of -ln-s
7381 c       Uconst_back=Uconst_back+utheta(i)
7382       enddo ! (i-loop for theta)
7383 #ifdef DEBUG
7384       write(iout,*) "------- theta restrs end -------"
7385 #endif
7386       endif
7387 c
7388 c Deviation of local SC geometry
7389 c
7390 c Separation of two i-loops (instructed by AL - 11/3/2014)
7391 c
7392 c     write (iout,*) "loc_start =",loc_start,"loc_end =",loc_end
7393 c     write (iout,*) "waga_d",waga_d
7394
7395 #ifdef DEBUG
7396       write(iout,*) "------- SC restrs start -------"
7397       write (iout,*) "Initial duscdiff,duscdiffx"
7398       do i=loc_start,loc_end
7399         write (iout,*) i,(duscdiff(jik,i),jik=1,3),
7400      &                 (duscdiffx(jik,i),jik=1,3)
7401       enddo
7402 #endif
7403       do i=loc_start,loc_end
7404         usc_diff_i=0.0d0 ! argument of Gaussian for single k
7405         guscdiff(i)=0.0d0 ! Sum of Gaussians over constr_homology ref structures
7406 c       do j=ifrag_back(1,i,iset)+1,ifrag_back(2,i,iset)-1 ! Econstr_back legacy
7407 c       write(iout,*) "xxtab, yytab, zztab"
7408 c       write(iout,'(i5,3f8.2)') i,xxtab(i),yytab(i),zztab(i)
7409         do k=1,constr_homology
7410 c
7411           dxx=-xxtpl(k,i)+xxtab(i) ! Diff b/w x component of ith SC vector in model and kth ref str?
7412 c                                    Original sign inverted for calc of gradients (s. Econstr_back)
7413           dyy=-yytpl(k,i)+yytab(i) ! ibid y
7414           dzz=-zztpl(k,i)+zztab(i) ! ibid z
7415 c         write(iout,*) "dxx, dyy, dzz"
7416 cd          write(iout,'(2i5,4f8.2)') k,i,dxx,dyy,dzz,sigma_d(k,i)
7417 c
7418           usc_diff_i=-0.5d0*(dxx**2+dyy**2+dzz**2)*sigma_d(k,i)  ! waga_d rmvd from Gaussian argument
7419 c         usc_diff(i)=-0.5d0*waga_d*(dxx**2+dyy**2+dzz**2)*sigma_d(k,i) ! waga_d?
7420 c         uscdiffk(k)=usc_diff(i)
7421           guscdiff2(k)=dexp(usc_diff_i) ! without min_scdiff
7422 c          write(iout,*) "i",i," k",k," sigma_d",sigma_d(k,i),
7423 c     &       " guscdiff2",guscdiff2(k)
7424           guscdiff(i)=guscdiff(i)+guscdiff2(k)  !Sum of Gaussians (pk)
7425 c          write (iout,'(i5,6f10.5)') j,xxtab(j),yytab(j),zztab(j),
7426 c     &      xxref(j),yyref(j),zzref(j)
7427         enddo
7428 c
7429 c       Gradient
7430 c
7431 c       Generalized expression for multiple Gaussian acc to that for a single
7432 c       Gaussian in Econstr_back as instructed by AL (FP - 03/11/2014)
7433 c
7434 c       Original implementation
7435 c       sum_guscdiff=guscdiff(i)
7436 c
7437 c       sum_sguscdiff=0.0d0
7438 c       do k=1,constr_homology
7439 c          sguscdiff=-guscdiff2(k)*dscdiff(k)*sigma_d(k,i)*waga_d !waga_d?
7440 c          sguscdiff=-guscdiff3(k)*dscdiff(k)*sigma_d(k,i)*waga_d ! w min_uscdiff
7441 c          sum_sguscdiff=sum_sguscdiff+sguscdiff
7442 c       enddo
7443 c
7444 c       Implementation of new expressions for gradient (Jan. 2015)
7445 c
7446 c       grad_uscdiff=sum_sguscdiff/(sum_guscdiff*dtab) !?
7447         do k=1,constr_homology
7448 c
7449 c       New calculation of dxx, dyy, and dzz corrected by AL (07/11), was missing and wrong
7450 c       before. Now the drivatives should be correct
7451 c
7452           dxx=-xxtpl(k,i)+xxtab(i) ! Diff b/w x component of ith SC vector in model and kth ref str?
7453 c                                  Original sign inverted for calc of gradients (s. Econstr_back)
7454           dyy=-yytpl(k,i)+yytab(i) ! ibid y
7455           dzz=-zztpl(k,i)+zztab(i) ! ibid z
7456 c
7457 c         New implementation
7458 c
7459           sum_guscdiff=guscdiff2(k)*!(dsqrt(dxx*dxx+dyy*dyy+dzz*dzz))* -> wrong!
7460      &                 sigma_d(k,i) ! for the grad wrt r'
7461 c         sum_sguscdiff=sum_sguscdiff+sum_guscdiff
7462 c
7463 c
7464 c        New implementation
7465          sum_guscdiff = waga_homology(iset)*waga_d*sum_guscdiff
7466          do jik=1,3
7467             duscdiff(jik,i-1)=duscdiff(jik,i-1)+
7468      &      sum_guscdiff*(dXX_C1tab(jik,i)*dxx+
7469      &      dYY_C1tab(jik,i)*dyy+dZZ_C1tab(jik,i)*dzz)/guscdiff(i)
7470             duscdiff(jik,i)=duscdiff(jik,i)+
7471      &      sum_guscdiff*(dXX_Ctab(jik,i)*dxx+
7472      &      dYY_Ctab(jik,i)*dyy+dZZ_Ctab(jik,i)*dzz)/guscdiff(i)
7473             duscdiffx(jik,i)=duscdiffx(jik,i)+
7474      &      sum_guscdiff*(dXX_XYZtab(jik,i)*dxx+
7475      &      dYY_XYZtab(jik,i)*dyy+dZZ_XYZtab(jik,i)*dzz)/guscdiff(i)
7476 c
7477 #ifdef DEBUG
7478              write(iout,*) "jik",jik,"i",i
7479              write(iout,*) "dxx, dyy, dzz"
7480              write(iout,'(2i5,3f8.2)') k,i,dxx,dyy,dzz
7481              write(iout,*) "guscdiff2(",k,")",guscdiff2(k)
7482 c            write(iout,*) "sum_sguscdiff",sum_sguscdiff
7483 cc           write(iout,*) "dXX_Ctab(",jik,i,")",dXX_Ctab(jik,i)
7484 c            write(iout,*) "dYY_Ctab(",jik,i,")",dYY_Ctab(jik,i)
7485 c            write(iout,*) "dZZ_Ctab(",jik,i,")",dZZ_Ctab(jik,i)
7486 c            write(iout,*) "dXX_C1tab(",jik,i,")",dXX_C1tab(jik,i)
7487 c            write(iout,*) "dYY_C1tab(",jik,i,")",dYY_C1tab(jik,i)
7488 c            write(iout,*) "dZZ_C1tab(",jik,i,")",dZZ_C1tab(jik,i)
7489 c            write(iout,*) "dXX_XYZtab(",jik,i,")",dXX_XYZtab(jik,i)
7490 c            write(iout,*) "dYY_XYZtab(",jik,i,")",dYY_XYZtab(jik,i)
7491 c            write(iout,*) "dZZ_XYZtab(",jik,i,")",dZZ_XYZtab(jik,i)
7492 c            write(iout,*) "duscdiff(",jik,i-1,")",duscdiff(jik,i-1)
7493 c            write(iout,*) "duscdiff(",jik,i,")",duscdiff(jik,i)
7494 c            write(iout,*) "duscdiffx(",jik,i,")",duscdiffx(jik,i)
7495 c            endif
7496 #endif
7497          enddo
7498         enddo
7499 c
7500 c       uscdiff(i)=-dLOG(guscdiff(i)/(ii-1))      ! Weighting by (ii-1) required?
7501 c        usc_diff(i)=-dLOG(guscdiff(i)/constr_homology) ! + min_uscdiff ?
7502 c
7503 c        write (iout,*) i," uscdiff",uscdiff(i)
7504 c
7505 c Put together deviations from local geometry
7506
7507 c       Uconst_back=Uconst_back+wfrag_back(1,i,iset)*utheta(i)+
7508 c      &            wfrag_back(3,i,iset)*uscdiff(i)
7509         Erot=Erot-dLOG(guscdiff(i)/constr_homology)
7510 c       write (iout,*) "usc_diff(",i,")=",usc_diff(i) ! -ln of sum of exps
7511 c       write (iout,*) "Uconst_back",Uconst_back ! cum sum of -ln-s
7512 c       Uconst_back=Uconst_back+usc_diff(i)
7513 c
7514 c     Gradient of multiple Gaussian restraint (FP - 04/11/2014 - right?)
7515 c
7516 c     New implment: multiplied by sum_sguscdiff
7517 c
7518
7519       enddo ! (i-loop for dscdiff)
7520
7521 c      endif
7522
7523 #ifdef DEBUG
7524       write(iout,*) "------- SC restrs end -------"
7525         write (iout,*) "------ After SC loop in e_modeller ------"
7526         do i=loc_start,loc_end
7527          write (iout,*) "i",i," gradc",(gradc(j,i,icg),j=1,3)
7528          write (iout,*) "i",i," gradx",(gradx(j,i,icg),j=1,3)
7529         enddo
7530       if (waga_theta.eq.1.0d0) then
7531       write (iout,*) "in e_modeller after SC restr end: dutheta"
7532       do i=ithet_start,ithet_end
7533         write (iout,*) i,dutheta(i)
7534       enddo
7535       endif
7536       if (waga_d.eq.1.0d0) then
7537       write (iout,*) "e_modeller after SC loop: duscdiff/x"
7538       do i=1,nres
7539         write (iout,*) i,(duscdiff(j,i),j=1,3)
7540         write (iout,*) i,(duscdiffx(j,i),j=1,3)
7541       enddo
7542       endif
7543 #endif
7544
7545 c Total energy from homology restraints
7546 #ifdef DEBUG
7547       write (iout,*) "odleg",odleg," kat",kat
7548 #endif
7549 c
7550 c Addition of energy of theta angle and SC local geom over constr_homologs ref strs
7551 c
7552 c     ehomology_constr=odleg+kat
7553 c
7554 c     For Lorentzian-type Urestr
7555 c
7556
7557       if (waga_dist.ge.0.0d0) then
7558 c
7559 c          For Gaussian-type Urestr
7560 c
7561         ehomology_constr=(waga_dist*odleg+waga_angle*kat+
7562      &              waga_theta*Eval+waga_d*Erot)*waga_homology(iset)
7563 c     write (iout,*) "ehomology_constr=",ehomology_constr
7564       else
7565 c
7566 c          For Lorentzian-type Urestr
7567 c
7568         ehomology_constr=(-waga_dist*odleg+waga_angle*kat+
7569      &              waga_theta*Eval+waga_d*Erot)*waga_homology(iset)
7570 c     write (iout,*) "ehomology_constr=",ehomology_constr
7571       endif
7572 #ifdef DEBUG
7573       write (iout,*) "odleg",waga_dist,odleg," kat",waga_angle,kat,
7574      & "Eval",waga_theta,eval,
7575      &   "Erot",waga_d,Erot
7576       write (iout,*) "ehomology_constr",ehomology_constr
7577 #endif
7578       return
7579 c
7580 c FP 01/15 end
7581 c
7582   748 format(a8,f12.3,a6,f12.3,a7,f12.3)
7583   747 format(a12,i4,i4,i4,f8.3,f8.3)
7584   746 format(a12,i4,i4,i4,f8.3,f8.3,f8.3)
7585   778 format(a7,1X,f10.3,1X,a4,1X,f10.3,1X,a5,1X,f10.3)
7586   779 format(i3,1X,i3,1X,i2,1X,a7,1X,f7.3,1X,a7,1X,f7.3,1X,a13,1X,
7587      &       f7.3,1X,a17,1X,f9.3,1X,a10,1X,f8.3,1X,a10,1X,f8.3)
7588       end
7589
7590 c------------------------------------------------------------------------------
7591       subroutine etor_d(etors_d)
7592 C 6/23/01 Compute double torsional energy
7593       implicit real*8 (a-h,o-z)
7594       include 'DIMENSIONS'
7595       include 'COMMON.VAR'
7596       include 'COMMON.GEO'
7597       include 'COMMON.LOCAL'
7598       include 'COMMON.TORSION'
7599       include 'COMMON.INTERACT'
7600       include 'COMMON.DERIV'
7601       include 'COMMON.CHAIN'
7602       include 'COMMON.NAMES'
7603       include 'COMMON.IOUNITS'
7604       include 'COMMON.FFIELD'
7605       include 'COMMON.TORCNSTR'
7606       include 'COMMON.CONTROL'
7607       logical lprn
7608 C Set lprn=.true. for debugging
7609       lprn=.false.
7610 c     lprn=.true.
7611       etors_d=0.0D0
7612 c      write(iout,*) "a tu??"
7613       do i=iphid_start,iphid_end
7614 C ANY TWO ARE DUMMY ATOMS in row CYCLE
7615 C        if (((itype(i-3).eq.ntyp1).and.(itype(i-2).eq.ntyp1)).or.
7616 C     &      ((itype(i-2).eq.ntyp1).and.(itype(i-1).eq.ntyp1)).or.
7617 C     &      ((itype(i-1).eq.ntyp1).and.(itype(i).eq.ntyp1))  .or.
7618 C     &      ((itype(i).eq.ntyp1).and.(itype(i+1).eq.ntyp1))) cycle
7619          if ((itype(i-2).eq.ntyp1).or.itype(i-3).eq.ntyp1.or.
7620      &  (itype(i-1).eq.ntyp1).or.(itype(i).eq.ntyp1).or.
7621      &  (itype(i+1).eq.ntyp1)) cycle
7622 C In current verion the ALL DUMMY ATOM POTENTIALS ARE OFF
7623         etors_d_ii=0.0D0
7624         itori=itortyp(itype(i-2))
7625         itori1=itortyp(itype(i-1))
7626         itori2=itortyp(itype(i))
7627         phii=phi(i)
7628         phii1=phi(i+1)
7629         gloci1=0.0D0
7630         gloci2=0.0D0
7631         iblock=1
7632         if (iabs(itype(i+1)).eq.20) iblock=2
7633 C Iblock=2 Proline type
7634 C ADASKO: WHEN PARAMETERS FOR THIS TYPE OF BLOCKING GROUP IS READY UNCOMMENT
7635 C CHECK WEATHER THERE IS NECCESITY FOR iblock=3 for COO-
7636 C        if (itype(i+1).eq.ntyp1) iblock=3
7637 C The problem of NH3+ group can be resolved by adding new parameters please note if there
7638 C IS or IS NOT need for this
7639 C IF Yes uncomment below and add to parmread.F appropriate changes and to v1cij and so on
7640 C        is (itype(i-3).eq.ntyp1) ntblock=2
7641 C        ntblock is N-terminal blocking group
7642
7643 C Regular cosine and sine terms
7644         do j=1,ntermd_1(itori,itori1,itori2,iblock)
7645 C Example of changes for NH3+ blocking group
7646 C       do j=1,ntermd_1(itori,itori1,itori2,iblock,ntblock)
7647 C          v1cij=v1c(1,j,itori,itori1,itori2,iblock,ntblock)
7648           v1cij=v1c(1,j,itori,itori1,itori2,iblock)
7649           v1sij=v1s(1,j,itori,itori1,itori2,iblock)
7650           v2cij=v1c(2,j,itori,itori1,itori2,iblock)
7651           v2sij=v1s(2,j,itori,itori1,itori2,iblock)
7652           cosphi1=dcos(j*phii)
7653           sinphi1=dsin(j*phii)
7654           cosphi2=dcos(j*phii1)
7655           sinphi2=dsin(j*phii1)
7656           etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+
7657      &     v2cij*cosphi2+v2sij*sinphi2
7658           if (energy_dec) etors_d_ii=etors_d_ii+
7659      &     v1cij*cosphi1+v1sij*sinphi1+v2cij*cosphi2+v2sij*sinphi2
7660           gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
7661           gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
7662         enddo
7663         do k=2,ntermd_2(itori,itori1,itori2,iblock)
7664           do l=1,k-1
7665             v1cdij = v2c(k,l,itori,itori1,itori2,iblock)
7666             v2cdij = v2c(l,k,itori,itori1,itori2,iblock)
7667             v1sdij = v2s(k,l,itori,itori1,itori2,iblock)
7668             v2sdij = v2s(l,k,itori,itori1,itori2,iblock)
7669             cosphi1p2=dcos(l*phii+(k-l)*phii1)
7670             cosphi1m2=dcos(l*phii-(k-l)*phii1)
7671             sinphi1p2=dsin(l*phii+(k-l)*phii1)
7672             sinphi1m2=dsin(l*phii-(k-l)*phii1)
7673             etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+
7674      &        v1sdij*sinphi1p2+v2sdij*sinphi1m2
7675             if (energy_dec) etors_d_ii=etors_d_ii+
7676      &        v1cdij*cosphi1p2+v2cdij*cosphi1m2+
7677      &        v1sdij*sinphi1p2+v2sdij*sinphi1m2
7678             gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2
7679      &        -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
7680             gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2
7681      &        -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
7682           enddo
7683         enddo
7684           if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
7685      &         'etor_d',i,etors_d_ii
7686         gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*gloci1
7687         gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*gloci2
7688       enddo
7689       return
7690       end
7691 #endif
7692 c------------------------------------------------------------------------------
7693       subroutine eback_sc_corr(esccor)
7694 c 7/21/2007 Correlations between the backbone-local and side-chain-local
7695 c        conformational states; temporarily implemented as differences
7696 c        between UNRES torsional potentials (dependent on three types of
7697 c        residues) and the torsional potentials dependent on all 20 types
7698 c        of residues computed from AM1  energy surfaces of terminally-blocked
7699 c        amino-acid residues.
7700       implicit real*8 (a-h,o-z)
7701       include 'DIMENSIONS'
7702       include 'COMMON.VAR'
7703       include 'COMMON.GEO'
7704       include 'COMMON.LOCAL'
7705       include 'COMMON.TORSION'
7706       include 'COMMON.SCCOR'
7707       include 'COMMON.INTERACT'
7708       include 'COMMON.DERIV'
7709       include 'COMMON.CHAIN'
7710       include 'COMMON.NAMES'
7711       include 'COMMON.IOUNITS'
7712       include 'COMMON.FFIELD'
7713       include 'COMMON.CONTROL'
7714       logical lprn
7715 C Set lprn=.true. for debugging
7716       lprn=.false.
7717 c      lprn=.true.
7718 c      write (iout,*) "EBACK_SC_COR",itau_start,itau_end
7719       esccor=0.0D0
7720       do i=itau_start,itau_end
7721         if ((itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)) cycle
7722         isccori=isccortyp(itype(i-2))
7723         isccori1=isccortyp(itype(i-1))
7724 c      write (iout,*) "EBACK_SC_COR",i,nterm_sccor(isccori,isccori1)
7725         phii=phi(i)
7726         do intertyp=1,3 !intertyp
7727          esccor_ii=0.0D0
7728 cc Added 09 May 2012 (Adasko)
7729 cc  Intertyp means interaction type of backbone mainchain correlation:
7730 c   1 = SC...Ca...Ca...Ca
7731 c   2 = Ca...Ca...Ca...SC
7732 c   3 = SC...Ca...Ca...SCi
7733         gloci=0.0D0
7734         if (((intertyp.eq.3).and.((itype(i-2).eq.10).or.
7735      &      (itype(i-1).eq.10).or.(itype(i-2).eq.ntyp1).or.
7736      &      (itype(i-1).eq.ntyp1)))
7737      &    .or. ((intertyp.eq.1).and.((itype(i-2).eq.10)
7738      &     .or.(itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)
7739      &     .or.(itype(i).eq.ntyp1)))
7740      &    .or.((intertyp.eq.2).and.((itype(i-1).eq.10).or.
7741      &      (itype(i-1).eq.ntyp1).or.(itype(i-2).eq.ntyp1).or.
7742      &      (itype(i-3).eq.ntyp1)))) cycle
7743         if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1).eq.ntyp1)) cycle
7744         if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres).eq.ntyp1))
7745      & cycle
7746        do j=1,nterm_sccor(isccori,isccori1)
7747           v1ij=v1sccor(j,intertyp,isccori,isccori1)
7748           v2ij=v2sccor(j,intertyp,isccori,isccori1)
7749           cosphi=dcos(j*tauangle(intertyp,i))
7750           sinphi=dsin(j*tauangle(intertyp,i))
7751           if (energy_dec) esccor_ii=esccor_ii+v1ij*cosphi+v2ij*sinphi
7752           esccor=esccor+v1ij*cosphi+v2ij*sinphi
7753           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7754         enddo
7755          if (energy_dec) write (iout,'(a6,i5,i2,0pf7.3)')
7756      &         'esccor',i,intertyp,esccor_ii
7757 c      write (iout,*) "EBACK_SC_COR",i,v1ij*cosphi+v2ij*sinphi,intertyp
7758         gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci
7759         if (lprn)
7760      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
7761      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,isccori,isccori1,
7762      &  (v1sccor(j,intertyp,isccori,isccori1),j=1,6)
7763      & ,(v2sccor(j,intertyp,isccori,isccori1),j=1,6)
7764         gsccor_loc(i-3)=gsccor_loc(i-3)+gloci
7765        enddo !intertyp
7766       enddo
7767
7768       return
7769       end
7770 c----------------------------------------------------------------------------
7771       subroutine multibody(ecorr)
7772 C This subroutine calculates multi-body contributions to energy following
7773 C the idea of Skolnick et al. If side chains I and J make a contact and
7774 C at the same time side chains I+1 and J+1 make a contact, an extra
7775 C contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
7776       implicit real*8 (a-h,o-z)
7777       include 'DIMENSIONS'
7778       include 'COMMON.IOUNITS'
7779       include 'COMMON.DERIV'
7780       include 'COMMON.INTERACT'
7781       include 'COMMON.CONTACTS'
7782       double precision gx(3),gx1(3)
7783       logical lprn
7784
7785 C Set lprn=.true. for debugging
7786       lprn=.false.
7787
7788       if (lprn) then
7789         write (iout,'(a)') 'Contact function values:'
7790         do i=nnt,nct-2
7791           write (iout,'(i2,20(1x,i2,f10.5))')
7792      &        i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
7793         enddo
7794       endif
7795       ecorr=0.0D0
7796       do i=nnt,nct
7797         do j=1,3
7798           gradcorr(j,i)=0.0D0
7799           gradxorr(j,i)=0.0D0
7800         enddo
7801       enddo
7802       do i=nnt,nct-2
7803
7804         DO ISHIFT = 3,4
7805
7806         i1=i+ishift
7807         num_conti=num_cont(i)
7808         num_conti1=num_cont(i1)
7809         do jj=1,num_conti
7810           j=jcont(jj,i)
7811           do kk=1,num_conti1
7812             j1=jcont(kk,i1)
7813             if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
7814 cd          write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
7815 cd   &                   ' ishift=',ishift
7816 C Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
7817 C The system gains extra energy.
7818               ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
7819             endif   ! j1==j+-ishift
7820           enddo     ! kk
7821         enddo       ! jj
7822
7823         ENDDO ! ISHIFT
7824
7825       enddo         ! i
7826       return
7827       end
7828 c------------------------------------------------------------------------------
7829       double precision function esccorr(i,j,k,l,jj,kk)
7830       implicit real*8 (a-h,o-z)
7831       include 'DIMENSIONS'
7832       include 'COMMON.IOUNITS'
7833       include 'COMMON.DERIV'
7834       include 'COMMON.INTERACT'
7835       include 'COMMON.CONTACTS'
7836       double precision gx(3),gx1(3)
7837       logical lprn
7838       lprn=.false.
7839       eij=facont(jj,i)
7840       ekl=facont(kk,k)
7841 cd    write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
7842 C Calculate the multi-body contribution to energy.
7843 C Calculate multi-body contributions to the gradient.
7844 cd    write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
7845 cd   & k,l,(gacont(m,kk,k),m=1,3)
7846       do m=1,3
7847         gx(m) =ekl*gacont(m,jj,i)
7848         gx1(m)=eij*gacont(m,kk,k)
7849         gradxorr(m,i)=gradxorr(m,i)-gx(m)
7850         gradxorr(m,j)=gradxorr(m,j)+gx(m)
7851         gradxorr(m,k)=gradxorr(m,k)-gx1(m)
7852         gradxorr(m,l)=gradxorr(m,l)+gx1(m)
7853       enddo
7854       do m=i,j-1
7855         do ll=1,3
7856           gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
7857         enddo
7858       enddo
7859       do m=k,l-1
7860         do ll=1,3
7861           gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
7862         enddo
7863       enddo
7864       esccorr=-eij*ekl
7865       return
7866       end
7867 c------------------------------------------------------------------------------
7868       subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
7869 C This subroutine calculates multi-body contributions to hydrogen-bonding
7870       implicit real*8 (a-h,o-z)
7871       include 'DIMENSIONS'
7872       include 'COMMON.IOUNITS'
7873 #ifdef MPI
7874       include "mpif.h"
7875       parameter (max_cont=maxconts)
7876       parameter (max_dim=26)
7877       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
7878       double precision zapas(max_dim,maxconts,max_fg_procs),
7879      &  zapas_recv(max_dim,maxconts,max_fg_procs)
7880       common /przechowalnia/ zapas
7881       integer status(MPI_STATUS_SIZE),req(maxconts*2),
7882      &  status_array(MPI_STATUS_SIZE,maxconts*2)
7883 #endif
7884       include 'COMMON.SETUP'
7885       include 'COMMON.FFIELD'
7886       include 'COMMON.DERIV'
7887       include 'COMMON.INTERACT'
7888       include 'COMMON.CONTACTS'
7889       include 'COMMON.CONTROL'
7890       include 'COMMON.LOCAL'
7891       double precision gx(3),gx1(3),time00
7892       logical lprn,ldone
7893
7894 C Set lprn=.true. for debugging
7895       lprn=.false.
7896 #ifdef MPI
7897       n_corr=0
7898       n_corr1=0
7899       if (nfgtasks.le.1) goto 30
7900       if (lprn) then
7901         write (iout,'(a)') 'Contact function values before RECEIVE:'
7902         do i=nnt,nct-2
7903           write (iout,'(2i3,50(1x,i2,f5.2))')
7904      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
7905      &    j=1,num_cont_hb(i))
7906         enddo
7907       endif
7908       call flush(iout)
7909       do i=1,ntask_cont_from
7910         ncont_recv(i)=0
7911       enddo
7912       do i=1,ntask_cont_to
7913         ncont_sent(i)=0
7914       enddo
7915 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
7916 c     & ntask_cont_to
7917 C Make the list of contacts to send to send to other procesors
7918 c      write (iout,*) "limits",max0(iturn4_end-1,iatel_s),iturn3_end
7919 c      call flush(iout)
7920       do i=iturn3_start,iturn3_end
7921 c        write (iout,*) "make contact list turn3",i," num_cont",
7922 c     &    num_cont_hb(i)
7923         call add_hb_contact(i,i+2,iturn3_sent_local(1,i))
7924       enddo
7925       do i=iturn4_start,iturn4_end
7926 c        write (iout,*) "make contact list turn4",i," num_cont",
7927 c     &   num_cont_hb(i)
7928         call add_hb_contact(i,i+3,iturn4_sent_local(1,i))
7929       enddo
7930       do ii=1,nat_sent
7931         i=iat_sent(ii)
7932 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
7933 c     &    num_cont_hb(i)
7934         do j=1,num_cont_hb(i)
7935         do k=1,4
7936           jjc=jcont_hb(j,i)
7937           iproc=iint_sent_local(k,jjc,ii)
7938 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
7939           if (iproc.gt.0) then
7940             ncont_sent(iproc)=ncont_sent(iproc)+1
7941             nn=ncont_sent(iproc)
7942             zapas(1,nn,iproc)=i
7943             zapas(2,nn,iproc)=jjc
7944             zapas(3,nn,iproc)=facont_hb(j,i)
7945             zapas(4,nn,iproc)=ees0p(j,i)
7946             zapas(5,nn,iproc)=ees0m(j,i)
7947             zapas(6,nn,iproc)=gacont_hbr(1,j,i)
7948             zapas(7,nn,iproc)=gacont_hbr(2,j,i)
7949             zapas(8,nn,iproc)=gacont_hbr(3,j,i)
7950             zapas(9,nn,iproc)=gacontm_hb1(1,j,i)
7951             zapas(10,nn,iproc)=gacontm_hb1(2,j,i)
7952             zapas(11,nn,iproc)=gacontm_hb1(3,j,i)
7953             zapas(12,nn,iproc)=gacontp_hb1(1,j,i)
7954             zapas(13,nn,iproc)=gacontp_hb1(2,j,i)
7955             zapas(14,nn,iproc)=gacontp_hb1(3,j,i)
7956             zapas(15,nn,iproc)=gacontm_hb2(1,j,i)
7957             zapas(16,nn,iproc)=gacontm_hb2(2,j,i)
7958             zapas(17,nn,iproc)=gacontm_hb2(3,j,i)
7959             zapas(18,nn,iproc)=gacontp_hb2(1,j,i)
7960             zapas(19,nn,iproc)=gacontp_hb2(2,j,i)
7961             zapas(20,nn,iproc)=gacontp_hb2(3,j,i)
7962             zapas(21,nn,iproc)=gacontm_hb3(1,j,i)
7963             zapas(22,nn,iproc)=gacontm_hb3(2,j,i)
7964             zapas(23,nn,iproc)=gacontm_hb3(3,j,i)
7965             zapas(24,nn,iproc)=gacontp_hb3(1,j,i)
7966             zapas(25,nn,iproc)=gacontp_hb3(2,j,i)
7967             zapas(26,nn,iproc)=gacontp_hb3(3,j,i)
7968           endif
7969         enddo
7970         enddo
7971       enddo
7972       if (lprn) then
7973       write (iout,*)
7974      &  "Numbers of contacts to be sent to other processors",
7975      &  (ncont_sent(i),i=1,ntask_cont_to)
7976       write (iout,*) "Contacts sent"
7977       do ii=1,ntask_cont_to
7978         nn=ncont_sent(ii)
7979         iproc=itask_cont_to(ii)
7980         write (iout,*) nn," contacts to processor",iproc,
7981      &   " of CONT_TO_COMM group"
7982         do i=1,nn
7983           write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
7984         enddo
7985       enddo
7986       call flush(iout)
7987       endif
7988       CorrelType=477
7989       CorrelID=fg_rank+1
7990       CorrelType1=478
7991       CorrelID1=nfgtasks+fg_rank+1
7992       ireq=0
7993 C Receive the numbers of needed contacts from other processors
7994       do ii=1,ntask_cont_from
7995         iproc=itask_cont_from(ii)
7996         ireq=ireq+1
7997         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
7998      &    FG_COMM,req(ireq),IERR)
7999       enddo
8000 c      write (iout,*) "IRECV ended"
8001 c      call flush(iout)
8002 C Send the number of contacts needed by other processors
8003       do ii=1,ntask_cont_to
8004         iproc=itask_cont_to(ii)
8005         ireq=ireq+1
8006         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
8007      &    FG_COMM,req(ireq),IERR)
8008       enddo
8009 c      write (iout,*) "ISEND ended"
8010 c      write (iout,*) "number of requests (nn)",ireq
8011       call flush(iout)
8012       if (ireq.gt.0)
8013      &  call MPI_Waitall(ireq,req,status_array,ierr)
8014 c      write (iout,*)
8015 c     &  "Numbers of contacts to be received from other processors",
8016 c     &  (ncont_recv(i),i=1,ntask_cont_from)
8017 c      call flush(iout)
8018 C Receive contacts
8019       ireq=0
8020       do ii=1,ntask_cont_from
8021         iproc=itask_cont_from(ii)
8022         nn=ncont_recv(ii)
8023 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
8024 c     &   " of CONT_TO_COMM group"
8025         call flush(iout)
8026         if (nn.gt.0) then
8027           ireq=ireq+1
8028           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
8029      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
8030 c          write (iout,*) "ireq,req",ireq,req(ireq)
8031         endif
8032       enddo
8033 C Send the contacts to processors that need them
8034       do ii=1,ntask_cont_to
8035         iproc=itask_cont_to(ii)
8036         nn=ncont_sent(ii)
8037 c        write (iout,*) nn," contacts to processor",iproc,
8038 c     &   " of CONT_TO_COMM group"
8039         if (nn.gt.0) then
8040           ireq=ireq+1
8041           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
8042      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
8043 c          write (iout,*) "ireq,req",ireq,req(ireq)
8044 c          do i=1,nn
8045 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
8046 c          enddo
8047         endif
8048       enddo
8049 c      write (iout,*) "number of requests (contacts)",ireq
8050 c      write (iout,*) "req",(req(i),i=1,4)
8051 c      call flush(iout)
8052       if (ireq.gt.0)
8053      & call MPI_Waitall(ireq,req,status_array,ierr)
8054       do iii=1,ntask_cont_from
8055         iproc=itask_cont_from(iii)
8056         nn=ncont_recv(iii)
8057         if (lprn) then
8058         write (iout,*) "Received",nn," contacts from processor",iproc,
8059      &   " of CONT_FROM_COMM group"
8060         call flush(iout)
8061         do i=1,nn
8062           write(iout,'(2f5.0,4f10.5)')(zapas_recv(j,i,iii),j=1,5)
8063         enddo
8064         call flush(iout)
8065         endif
8066         do i=1,nn
8067           ii=zapas_recv(1,i,iii)
8068 c Flag the received contacts to prevent double-counting
8069           jj=-zapas_recv(2,i,iii)
8070 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
8071 c          call flush(iout)
8072           nnn=num_cont_hb(ii)+1
8073           num_cont_hb(ii)=nnn
8074           jcont_hb(nnn,ii)=jj
8075           facont_hb(nnn,ii)=zapas_recv(3,i,iii)
8076           ees0p(nnn,ii)=zapas_recv(4,i,iii)
8077           ees0m(nnn,ii)=zapas_recv(5,i,iii)
8078           gacont_hbr(1,nnn,ii)=zapas_recv(6,i,iii)
8079           gacont_hbr(2,nnn,ii)=zapas_recv(7,i,iii)
8080           gacont_hbr(3,nnn,ii)=zapas_recv(8,i,iii)
8081           gacontm_hb1(1,nnn,ii)=zapas_recv(9,i,iii)
8082           gacontm_hb1(2,nnn,ii)=zapas_recv(10,i,iii)
8083           gacontm_hb1(3,nnn,ii)=zapas_recv(11,i,iii)
8084           gacontp_hb1(1,nnn,ii)=zapas_recv(12,i,iii)
8085           gacontp_hb1(2,nnn,ii)=zapas_recv(13,i,iii)
8086           gacontp_hb1(3,nnn,ii)=zapas_recv(14,i,iii)
8087           gacontm_hb2(1,nnn,ii)=zapas_recv(15,i,iii)
8088           gacontm_hb2(2,nnn,ii)=zapas_recv(16,i,iii)
8089           gacontm_hb2(3,nnn,ii)=zapas_recv(17,i,iii)
8090           gacontp_hb2(1,nnn,ii)=zapas_recv(18,i,iii)
8091           gacontp_hb2(2,nnn,ii)=zapas_recv(19,i,iii)
8092           gacontp_hb2(3,nnn,ii)=zapas_recv(20,i,iii)
8093           gacontm_hb3(1,nnn,ii)=zapas_recv(21,i,iii)
8094           gacontm_hb3(2,nnn,ii)=zapas_recv(22,i,iii)
8095           gacontm_hb3(3,nnn,ii)=zapas_recv(23,i,iii)
8096           gacontp_hb3(1,nnn,ii)=zapas_recv(24,i,iii)
8097           gacontp_hb3(2,nnn,ii)=zapas_recv(25,i,iii)
8098           gacontp_hb3(3,nnn,ii)=zapas_recv(26,i,iii)
8099         enddo
8100       enddo
8101       call flush(iout)
8102       if (lprn) then
8103         write (iout,'(a)') 'Contact function values after receive:'
8104         do i=nnt,nct-2
8105           write (iout,'(2i3,50(1x,i3,f5.2))')
8106      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
8107      &    j=1,num_cont_hb(i))
8108         enddo
8109         call flush(iout)
8110       endif
8111    30 continue
8112 #endif
8113       if (lprn) then
8114         write (iout,'(a)') 'Contact function values:'
8115         do i=nnt,nct-2
8116           write (iout,'(2i3,50(1x,i3,f5.2))')
8117      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
8118      &    j=1,num_cont_hb(i))
8119         enddo
8120       endif
8121       ecorr=0.0D0
8122 C Remove the loop below after debugging !!!
8123       do i=nnt,nct
8124         do j=1,3
8125           gradcorr(j,i)=0.0D0
8126           gradxorr(j,i)=0.0D0
8127         enddo
8128       enddo
8129 C Calculate the local-electrostatic correlation terms
8130       do i=min0(iatel_s,iturn4_start),max0(iatel_e,iturn3_end)
8131         i1=i+1
8132         num_conti=num_cont_hb(i)
8133         num_conti1=num_cont_hb(i+1)
8134         do jj=1,num_conti
8135           j=jcont_hb(jj,i)
8136           jp=iabs(j)
8137           do kk=1,num_conti1
8138             j1=jcont_hb(kk,i1)
8139             jp1=iabs(j1)
8140 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
8141 c     &         ' jj=',jj,' kk=',kk
8142             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
8143      &          .or. j.lt.0 .and. j1.gt.0) .and.
8144      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
8145 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
8146 C The system gains extra energy.
8147               ecorr=ecorr+ehbcorr(i,jp,i+1,jp1,jj,kk,0.72D0,0.32D0)
8148               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
8149      &            'ecorrh',i,j,ehbcorr(i,j,i+1,j1,jj,kk,0.72D0,0.32D0)
8150               n_corr=n_corr+1
8151             else if (j1.eq.j) then
8152 C Contacts I-J and I-(J+1) occur simultaneously.
8153 C The system loses extra energy.
8154 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
8155             endif
8156           enddo ! kk
8157           do kk=1,num_conti
8158             j1=jcont_hb(kk,i)
8159 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
8160 c    &         ' jj=',jj,' kk=',kk
8161             if (j1.eq.j+1) then
8162 C Contacts I-J and (I+1)-J occur simultaneously.
8163 C The system loses extra energy.
8164 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
8165             endif ! j1==j+1
8166           enddo ! kk
8167         enddo ! jj
8168       enddo ! i
8169       return
8170       end
8171 c------------------------------------------------------------------------------
8172       subroutine add_hb_contact(ii,jj,itask)
8173       implicit real*8 (a-h,o-z)
8174       include "DIMENSIONS"
8175       include "COMMON.IOUNITS"
8176       integer max_cont
8177       integer max_dim
8178       parameter (max_cont=maxconts)
8179       parameter (max_dim=26)
8180       include "COMMON.CONTACTS"
8181       double precision zapas(max_dim,maxconts,max_fg_procs),
8182      &  zapas_recv(max_dim,maxconts,max_fg_procs)
8183       common /przechowalnia/ zapas
8184       integer i,j,ii,jj,iproc,itask(4),nn
8185 c      write (iout,*) "itask",itask
8186       do i=1,2
8187         iproc=itask(i)
8188         if (iproc.gt.0) then
8189           do j=1,num_cont_hb(ii)
8190             jjc=jcont_hb(j,ii)
8191 c            write (iout,*) "i",ii," j",jj," jjc",jjc
8192             if (jjc.eq.jj) then
8193               ncont_sent(iproc)=ncont_sent(iproc)+1
8194               nn=ncont_sent(iproc)
8195               zapas(1,nn,iproc)=ii
8196               zapas(2,nn,iproc)=jjc
8197               zapas(3,nn,iproc)=facont_hb(j,ii)
8198               zapas(4,nn,iproc)=ees0p(j,ii)
8199               zapas(5,nn,iproc)=ees0m(j,ii)
8200               zapas(6,nn,iproc)=gacont_hbr(1,j,ii)
8201               zapas(7,nn,iproc)=gacont_hbr(2,j,ii)
8202               zapas(8,nn,iproc)=gacont_hbr(3,j,ii)
8203               zapas(9,nn,iproc)=gacontm_hb1(1,j,ii)
8204               zapas(10,nn,iproc)=gacontm_hb1(2,j,ii)
8205               zapas(11,nn,iproc)=gacontm_hb1(3,j,ii)
8206               zapas(12,nn,iproc)=gacontp_hb1(1,j,ii)
8207               zapas(13,nn,iproc)=gacontp_hb1(2,j,ii)
8208               zapas(14,nn,iproc)=gacontp_hb1(3,j,ii)
8209               zapas(15,nn,iproc)=gacontm_hb2(1,j,ii)
8210               zapas(16,nn,iproc)=gacontm_hb2(2,j,ii)
8211               zapas(17,nn,iproc)=gacontm_hb2(3,j,ii)
8212               zapas(18,nn,iproc)=gacontp_hb2(1,j,ii)
8213               zapas(19,nn,iproc)=gacontp_hb2(2,j,ii)
8214               zapas(20,nn,iproc)=gacontp_hb2(3,j,ii)
8215               zapas(21,nn,iproc)=gacontm_hb3(1,j,ii)
8216               zapas(22,nn,iproc)=gacontm_hb3(2,j,ii)
8217               zapas(23,nn,iproc)=gacontm_hb3(3,j,ii)
8218               zapas(24,nn,iproc)=gacontp_hb3(1,j,ii)
8219               zapas(25,nn,iproc)=gacontp_hb3(2,j,ii)
8220               zapas(26,nn,iproc)=gacontp_hb3(3,j,ii)
8221               exit
8222             endif
8223           enddo
8224         endif
8225       enddo
8226       return
8227       end
8228 c------------------------------------------------------------------------------
8229       subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,
8230      &  n_corr1)
8231 C This subroutine calculates multi-body contributions to hydrogen-bonding
8232       implicit real*8 (a-h,o-z)
8233       include 'DIMENSIONS'
8234       include 'COMMON.IOUNITS'
8235 #ifdef MPI
8236       include "mpif.h"
8237       parameter (max_cont=maxconts)
8238       parameter (max_dim=70)
8239       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
8240       double precision zapas(max_dim,maxconts,max_fg_procs),
8241      &  zapas_recv(max_dim,maxconts,max_fg_procs)
8242       common /przechowalnia/ zapas
8243       integer status(MPI_STATUS_SIZE),req(maxconts*2),
8244      &  status_array(MPI_STATUS_SIZE,maxconts*2)
8245 #endif
8246       include 'COMMON.SETUP'
8247       include 'COMMON.FFIELD'
8248       include 'COMMON.DERIV'
8249       include 'COMMON.LOCAL'
8250       include 'COMMON.INTERACT'
8251       include 'COMMON.CONTACTS'
8252       include 'COMMON.CHAIN'
8253       include 'COMMON.CONTROL'
8254       double precision gx(3),gx1(3)
8255       integer num_cont_hb_old(maxres)
8256       logical lprn,ldone
8257       double precision eello4,eello5,eelo6,eello_turn6
8258       external eello4,eello5,eello6,eello_turn6
8259 C Set lprn=.true. for debugging
8260       lprn=.false.
8261       eturn6=0.0d0
8262 #ifdef MPI
8263       do i=1,nres
8264         num_cont_hb_old(i)=num_cont_hb(i)
8265       enddo
8266       n_corr=0
8267       n_corr1=0
8268       if (nfgtasks.le.1) goto 30
8269       if (lprn) then
8270         write (iout,'(a)') 'Contact function values before RECEIVE:'
8271         do i=nnt,nct-2
8272           write (iout,'(2i3,50(1x,i2,f5.2))')
8273      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
8274      &    j=1,num_cont_hb(i))
8275         enddo
8276       endif
8277       call flush(iout)
8278       do i=1,ntask_cont_from
8279         ncont_recv(i)=0
8280       enddo
8281       do i=1,ntask_cont_to
8282         ncont_sent(i)=0
8283       enddo
8284 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
8285 c     & ntask_cont_to
8286 C Make the list of contacts to send to send to other procesors
8287       do i=iturn3_start,iturn3_end
8288 c        write (iout,*) "make contact list turn3",i," num_cont",
8289 c     &    num_cont_hb(i)
8290         call add_hb_contact_eello(i,i+2,iturn3_sent_local(1,i))
8291       enddo
8292       do i=iturn4_start,iturn4_end
8293 c        write (iout,*) "make contact list turn4",i," num_cont",
8294 c     &   num_cont_hb(i)
8295         call add_hb_contact_eello(i,i+3,iturn4_sent_local(1,i))
8296       enddo
8297       do ii=1,nat_sent
8298         i=iat_sent(ii)
8299 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
8300 c     &    num_cont_hb(i)
8301         do j=1,num_cont_hb(i)
8302         do k=1,4
8303           jjc=jcont_hb(j,i)
8304           iproc=iint_sent_local(k,jjc,ii)
8305 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
8306           if (iproc.ne.0) then
8307             ncont_sent(iproc)=ncont_sent(iproc)+1
8308             nn=ncont_sent(iproc)
8309             zapas(1,nn,iproc)=i
8310             zapas(2,nn,iproc)=jjc
8311             zapas(3,nn,iproc)=d_cont(j,i)
8312             ind=3
8313             do kk=1,3
8314               ind=ind+1
8315               zapas(ind,nn,iproc)=grij_hb_cont(kk,j,i)
8316             enddo
8317             do kk=1,2
8318               do ll=1,2
8319                 ind=ind+1
8320                 zapas(ind,nn,iproc)=a_chuj(ll,kk,j,i)
8321               enddo
8322             enddo
8323             do jj=1,5
8324               do kk=1,3
8325                 do ll=1,2
8326                   do mm=1,2
8327                     ind=ind+1
8328                     zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,i)
8329                   enddo
8330                 enddo
8331               enddo
8332             enddo
8333           endif
8334         enddo
8335         enddo
8336       enddo
8337       if (lprn) then
8338       write (iout,*)
8339      &  "Numbers of contacts to be sent to other processors",
8340      &  (ncont_sent(i),i=1,ntask_cont_to)
8341       write (iout,*) "Contacts sent"
8342       do ii=1,ntask_cont_to
8343         nn=ncont_sent(ii)
8344         iproc=itask_cont_to(ii)
8345         write (iout,*) nn," contacts to processor",iproc,
8346      &   " of CONT_TO_COMM group"
8347         do i=1,nn
8348           write(iout,'(2f5.0,10f10.5)')(zapas(j,i,ii),j=1,10)
8349         enddo
8350       enddo
8351       call flush(iout)
8352       endif
8353       CorrelType=477
8354       CorrelID=fg_rank+1
8355       CorrelType1=478
8356       CorrelID1=nfgtasks+fg_rank+1
8357       ireq=0
8358 C Receive the numbers of needed contacts from other processors
8359       do ii=1,ntask_cont_from
8360         iproc=itask_cont_from(ii)
8361         ireq=ireq+1
8362         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
8363      &    FG_COMM,req(ireq),IERR)
8364       enddo
8365 c      write (iout,*) "IRECV ended"
8366 c      call flush(iout)
8367 C Send the number of contacts needed by other processors
8368       do ii=1,ntask_cont_to
8369         iproc=itask_cont_to(ii)
8370         ireq=ireq+1
8371         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
8372      &    FG_COMM,req(ireq),IERR)
8373       enddo
8374 c      write (iout,*) "ISEND ended"
8375 c      write (iout,*) "number of requests (nn)",ireq
8376       call flush(iout)
8377       if (ireq.gt.0)
8378      &  call MPI_Waitall(ireq,req,status_array,ierr)
8379 c      write (iout,*)
8380 c     &  "Numbers of contacts to be received from other processors",
8381 c     &  (ncont_recv(i),i=1,ntask_cont_from)
8382 c      call flush(iout)
8383 C Receive contacts
8384       ireq=0
8385       do ii=1,ntask_cont_from
8386         iproc=itask_cont_from(ii)
8387         nn=ncont_recv(ii)
8388 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
8389 c     &   " of CONT_TO_COMM group"
8390         call flush(iout)
8391         if (nn.gt.0) then
8392           ireq=ireq+1
8393           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
8394      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
8395 c          write (iout,*) "ireq,req",ireq,req(ireq)
8396         endif
8397       enddo
8398 C Send the contacts to processors that need them
8399       do ii=1,ntask_cont_to
8400         iproc=itask_cont_to(ii)
8401         nn=ncont_sent(ii)
8402 c        write (iout,*) nn," contacts to processor",iproc,
8403 c     &   " of CONT_TO_COMM group"
8404         if (nn.gt.0) then
8405           ireq=ireq+1
8406           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
8407      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
8408 c          write (iout,*) "ireq,req",ireq,req(ireq)
8409 c          do i=1,nn
8410 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
8411 c          enddo
8412         endif
8413       enddo
8414 c      write (iout,*) "number of requests (contacts)",ireq
8415 c      write (iout,*) "req",(req(i),i=1,4)
8416 c      call flush(iout)
8417       if (ireq.gt.0)
8418      & call MPI_Waitall(ireq,req,status_array,ierr)
8419       do iii=1,ntask_cont_from
8420         iproc=itask_cont_from(iii)
8421         nn=ncont_recv(iii)
8422         if (lprn) then
8423         write (iout,*) "Received",nn," contacts from processor",iproc,
8424      &   " of CONT_FROM_COMM group"
8425         call flush(iout)
8426         do i=1,nn
8427           write(iout,'(2f5.0,10f10.5)')(zapas_recv(j,i,iii),j=1,10)
8428         enddo
8429         call flush(iout)
8430         endif
8431         do i=1,nn
8432           ii=zapas_recv(1,i,iii)
8433 c Flag the received contacts to prevent double-counting
8434           jj=-zapas_recv(2,i,iii)
8435 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
8436 c          call flush(iout)
8437           nnn=num_cont_hb(ii)+1
8438           num_cont_hb(ii)=nnn
8439           jcont_hb(nnn,ii)=jj
8440           d_cont(nnn,ii)=zapas_recv(3,i,iii)
8441           ind=3
8442           do kk=1,3
8443             ind=ind+1
8444             grij_hb_cont(kk,nnn,ii)=zapas_recv(ind,i,iii)
8445           enddo
8446           do kk=1,2
8447             do ll=1,2
8448               ind=ind+1
8449               a_chuj(ll,kk,nnn,ii)=zapas_recv(ind,i,iii)
8450             enddo
8451           enddo
8452           do jj=1,5
8453             do kk=1,3
8454               do ll=1,2
8455                 do mm=1,2
8456                   ind=ind+1
8457                   a_chuj_der(mm,ll,kk,jj,nnn,ii)=zapas_recv(ind,i,iii)
8458                 enddo
8459               enddo
8460             enddo
8461           enddo
8462         enddo
8463       enddo
8464       call flush(iout)
8465       if (lprn) then
8466         write (iout,'(a)') 'Contact function values after receive:'
8467         do i=nnt,nct-2
8468           write (iout,'(2i3,50(1x,i3,5f6.3))')
8469      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
8470      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
8471         enddo
8472         call flush(iout)
8473       endif
8474    30 continue
8475 #endif
8476       if (lprn) then
8477         write (iout,'(a)') 'Contact function values:'
8478         do i=nnt,nct-2
8479           write (iout,'(2i3,50(1x,i2,5f6.3))')
8480      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
8481      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
8482         enddo
8483       endif
8484       ecorr=0.0D0
8485       ecorr5=0.0d0
8486       ecorr6=0.0d0
8487 C Remove the loop below after debugging !!!
8488       do i=nnt,nct
8489         do j=1,3
8490           gradcorr(j,i)=0.0D0
8491           gradxorr(j,i)=0.0D0
8492         enddo
8493       enddo
8494 C Calculate the dipole-dipole interaction energies
8495       if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
8496       do i=iatel_s,iatel_e+1
8497         num_conti=num_cont_hb(i)
8498         do jj=1,num_conti
8499           j=jcont_hb(jj,i)
8500 #ifdef MOMENT
8501           call dipole(i,j,jj)
8502 #endif
8503         enddo
8504       enddo
8505       endif
8506 C Calculate the local-electrostatic correlation terms
8507 c                write (iout,*) "gradcorr5 in eello5 before loop"
8508 c                do iii=1,nres
8509 c                  write (iout,'(i5,3f10.5)')
8510 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
8511 c                enddo
8512       do i=min0(iatel_s,iturn4_start),max0(iatel_e+1,iturn3_end+1)
8513 c        write (iout,*) "corr loop i",i
8514         i1=i+1
8515         num_conti=num_cont_hb(i)
8516         num_conti1=num_cont_hb(i+1)
8517         do jj=1,num_conti
8518           j=jcont_hb(jj,i)
8519           jp=iabs(j)
8520           do kk=1,num_conti1
8521             j1=jcont_hb(kk,i1)
8522             jp1=iabs(j1)
8523 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
8524 c     &         ' jj=',jj,' kk=',kk
8525 c            if (j1.eq.j+1 .or. j1.eq.j-1) then
8526             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
8527      &          .or. j.lt.0 .and. j1.gt.0) .and.
8528      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
8529 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
8530 C The system gains extra energy.
8531               n_corr=n_corr+1
8532               sqd1=dsqrt(d_cont(jj,i))
8533               sqd2=dsqrt(d_cont(kk,i1))
8534               sred_geom = sqd1*sqd2
8535               IF (sred_geom.lt.cutoff_corr) THEN
8536                 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,
8537      &            ekont,fprimcont)
8538 cd               write (iout,*) 'i=',i,' j=',jp,' i1=',i1,' j1=',jp1,
8539 cd     &         ' jj=',jj,' kk=',kk
8540                 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
8541                 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
8542                 do l=1,3
8543                   g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
8544                   g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
8545                 enddo
8546                 n_corr1=n_corr1+1
8547 cd               write (iout,*) 'sred_geom=',sred_geom,
8548 cd     &          ' ekont=',ekont,' fprim=',fprimcont,
8549 cd     &          ' fac_prim1',fac_prim1,' fac_prim2',fac_prim2
8550 cd               write (iout,*) "g_contij",g_contij
8551 cd               write (iout,*) "grij_hb_cont i",grij_hb_cont(:,jj,i)
8552 cd               write (iout,*) "grij_hb_cont i1",grij_hb_cont(:,jj,i1)
8553                 call calc_eello(i,jp,i+1,jp1,jj,kk)
8554                 if (wcorr4.gt.0.0d0)
8555      &            ecorr=ecorr+eello4(i,jp,i+1,jp1,jj,kk)
8556                   if (energy_dec.and.wcorr4.gt.0.0d0)
8557      1                 write (iout,'(a6,4i5,0pf7.3)')
8558      2                'ecorr4',i,j,i+1,j1,eello4(i,jp,i+1,jp1,jj,kk)
8559 c                write (iout,*) "gradcorr5 before eello5"
8560 c                do iii=1,nres
8561 c                  write (iout,'(i5,3f10.5)')
8562 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
8563 c                enddo
8564                 if (wcorr5.gt.0.0d0)
8565      &            ecorr5=ecorr5+eello5(i,jp,i+1,jp1,jj,kk)
8566 c                write (iout,*) "gradcorr5 after eello5"
8567 c                do iii=1,nres
8568 c                  write (iout,'(i5,3f10.5)')
8569 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
8570 c                enddo
8571                   if (energy_dec.and.wcorr5.gt.0.0d0)
8572      1                 write (iout,'(a6,4i5,0pf7.3)')
8573      2                'ecorr5',i,j,i+1,j1,eello5(i,jp,i+1,jp1,jj,kk)
8574 cd                write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
8575 cd                write(2,*)'ijkl',i,jp,i+1,jp1
8576                 if (wcorr6.gt.0.0d0 .and. (jp.ne.i+4 .or. jp1.ne.i+3
8577      &               .or. wturn6.eq.0.0d0))then
8578 cd                  write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
8579                   ecorr6=ecorr6+eello6(i,jp,i+1,jp1,jj,kk)
8580                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
8581      1                'ecorr6',i,j,i+1,j1,eello6(i,jp,i+1,jp1,jj,kk)
8582 cd                write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
8583 cd     &            'ecorr6=',ecorr6
8584 cd                write (iout,'(4e15.5)') sred_geom,
8585 cd     &          dabs(eello4(i,jp,i+1,jp1,jj,kk)),
8586 cd     &          dabs(eello5(i,jp,i+1,jp1,jj,kk)),
8587 cd     &          dabs(eello6(i,jp,i+1,jp1,jj,kk))
8588                 else if (wturn6.gt.0.0d0
8589      &            .and. (jp.eq.i+4 .and. jp1.eq.i+3)) then
8590 cd                  write (iout,*) '******eturn6: i,j,i+1,j1',i,jip,i+1,jp1
8591                   eturn6=eturn6+eello_turn6(i,jj,kk)
8592                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
8593      1                 'eturn6',i,j,i+1,j1,eello_turn6(i,jj,kk)
8594 cd                  write (2,*) 'multibody_eello:eturn6',eturn6
8595                 endif
8596               ENDIF
8597 1111          continue
8598             endif
8599           enddo ! kk
8600         enddo ! jj
8601       enddo ! i
8602       do i=1,nres
8603         num_cont_hb(i)=num_cont_hb_old(i)
8604       enddo
8605 c                write (iout,*) "gradcorr5 in eello5"
8606 c                do iii=1,nres
8607 c                  write (iout,'(i5,3f10.5)')
8608 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
8609 c                enddo
8610       return
8611       end
8612 c------------------------------------------------------------------------------
8613       subroutine add_hb_contact_eello(ii,jj,itask)
8614       implicit real*8 (a-h,o-z)
8615       include "DIMENSIONS"
8616       include "COMMON.IOUNITS"
8617       integer max_cont
8618       integer max_dim
8619       parameter (max_cont=maxconts)
8620       parameter (max_dim=70)
8621       include "COMMON.CONTACTS"
8622       double precision zapas(max_dim,maxconts,max_fg_procs),
8623      &  zapas_recv(max_dim,maxconts,max_fg_procs)
8624       common /przechowalnia/ zapas
8625       integer i,j,ii,jj,iproc,itask(4),nn
8626 c      write (iout,*) "itask",itask
8627       do i=1,2
8628         iproc=itask(i)
8629         if (iproc.gt.0) then
8630           do j=1,num_cont_hb(ii)
8631             jjc=jcont_hb(j,ii)
8632 c            write (iout,*) "send turns i",ii," j",jj," jjc",jjc
8633             if (jjc.eq.jj) then
8634               ncont_sent(iproc)=ncont_sent(iproc)+1
8635               nn=ncont_sent(iproc)
8636               zapas(1,nn,iproc)=ii
8637               zapas(2,nn,iproc)=jjc
8638               zapas(3,nn,iproc)=d_cont(j,ii)
8639               ind=3
8640               do kk=1,3
8641                 ind=ind+1
8642                 zapas(ind,nn,iproc)=grij_hb_cont(kk,j,ii)
8643               enddo
8644               do kk=1,2
8645                 do ll=1,2
8646                   ind=ind+1
8647                   zapas(ind,nn,iproc)=a_chuj(ll,kk,j,ii)
8648                 enddo
8649               enddo
8650               do jj=1,5
8651                 do kk=1,3
8652                   do ll=1,2
8653                     do mm=1,2
8654                       ind=ind+1
8655                       zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,ii)
8656                     enddo
8657                   enddo
8658                 enddo
8659               enddo
8660               exit
8661             endif
8662           enddo
8663         endif
8664       enddo
8665       return
8666       end
8667 c------------------------------------------------------------------------------
8668       double precision function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
8669       implicit real*8 (a-h,o-z)
8670       include 'DIMENSIONS'
8671       include 'COMMON.IOUNITS'
8672       include 'COMMON.DERIV'
8673       include 'COMMON.INTERACT'
8674       include 'COMMON.CONTACTS'
8675       double precision gx(3),gx1(3)
8676       logical lprn
8677       lprn=.false.
8678       eij=facont_hb(jj,i)
8679       ekl=facont_hb(kk,k)
8680       ees0pij=ees0p(jj,i)
8681       ees0pkl=ees0p(kk,k)
8682       ees0mij=ees0m(jj,i)
8683       ees0mkl=ees0m(kk,k)
8684       ekont=eij*ekl
8685       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
8686 cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
8687 C Following 4 lines for diagnostics.
8688 cd    ees0pkl=0.0D0
8689 cd    ees0pij=1.0D0
8690 cd    ees0mkl=0.0D0
8691 cd    ees0mij=1.0D0
8692 c      write (iout,'(2(a,2i3,a,f10.5,a,2f10.5),a,f10.5,a,$)')
8693 c     & 'Contacts ',i,j,
8694 c     & ' eij',eij,' eesij',ees0pij,ees0mij,' and ',k,l
8695 c     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' energy=',ekont*ees,
8696 c     & 'gradcorr_long'
8697 C Calculate the multi-body contribution to energy.
8698 C      ecorr=ecorr+ekont*ees
8699 C Calculate multi-body contributions to the gradient.
8700       coeffpees0pij=coeffp*ees0pij
8701       coeffmees0mij=coeffm*ees0mij
8702       coeffpees0pkl=coeffp*ees0pkl
8703       coeffmees0mkl=coeffm*ees0mkl
8704       do ll=1,3
8705 cgrad        ghalfi=ees*ekl*gacont_hbr(ll,jj,i)
8706         gradcorr(ll,i)=gradcorr(ll,i)!+0.5d0*ghalfi
8707      &  -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+
8708      &  coeffmees0mkl*gacontm_hb1(ll,jj,i))
8709         gradcorr(ll,j)=gradcorr(ll,j)!+0.5d0*ghalfi
8710      &  -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+
8711      &  coeffmees0mkl*gacontm_hb2(ll,jj,i))
8712 cgrad        ghalfk=ees*eij*gacont_hbr(ll,kk,k)
8713         gradcorr(ll,k)=gradcorr(ll,k)!+0.5d0*ghalfk
8714      &  -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+
8715      &  coeffmees0mij*gacontm_hb1(ll,kk,k))
8716         gradcorr(ll,l)=gradcorr(ll,l)!+0.5d0*ghalfk
8717      &  -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+
8718      &  coeffmees0mij*gacontm_hb2(ll,kk,k))
8719         gradlongij=ees*ekl*gacont_hbr(ll,jj,i)-
8720      &     ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+
8721      &     coeffmees0mkl*gacontm_hb3(ll,jj,i))
8722         gradcorr_long(ll,j)=gradcorr_long(ll,j)+gradlongij
8723         gradcorr_long(ll,i)=gradcorr_long(ll,i)-gradlongij
8724         gradlongkl=ees*eij*gacont_hbr(ll,kk,k)-
8725      &     ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+
8726      &     coeffmees0mij*gacontm_hb3(ll,kk,k))
8727         gradcorr_long(ll,l)=gradcorr_long(ll,l)+gradlongkl
8728         gradcorr_long(ll,k)=gradcorr_long(ll,k)-gradlongkl
8729 c        write (iout,'(2f10.5,2x,$)') gradlongij,gradlongkl
8730       enddo
8731 c      write (iout,*)
8732 cgrad      do m=i+1,j-1
8733 cgrad        do ll=1,3
8734 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
8735 cgrad     &     ees*ekl*gacont_hbr(ll,jj,i)-
8736 cgrad     &     ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
8737 cgrad     &     coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
8738 cgrad        enddo
8739 cgrad      enddo
8740 cgrad      do m=k+1,l-1
8741 cgrad        do ll=1,3
8742 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
8743 cgrad     &     ees*eij*gacont_hbr(ll,kk,k)-
8744 cgrad     &     ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
8745 cgrad     &     coeffm*ees0mij*gacontm_hb3(ll,kk,k))
8746 cgrad        enddo
8747 cgrad      enddo
8748 c      write (iout,*) "ehbcorr",ekont*ees
8749       ehbcorr=ekont*ees
8750       return
8751       end
8752 #ifdef MOMENT
8753 C---------------------------------------------------------------------------
8754       subroutine dipole(i,j,jj)
8755       implicit real*8 (a-h,o-z)
8756       include 'DIMENSIONS'
8757       include 'COMMON.IOUNITS'
8758       include 'COMMON.CHAIN'
8759       include 'COMMON.FFIELD'
8760       include 'COMMON.DERIV'
8761       include 'COMMON.INTERACT'
8762       include 'COMMON.CONTACTS'
8763       include 'COMMON.TORSION'
8764       include 'COMMON.VAR'
8765       include 'COMMON.GEO'
8766       dimension dipi(2,2),dipj(2,2),dipderi(2),dipderj(2),auxvec(2),
8767      &  auxmat(2,2)
8768       iti1 = itortyp(itype(i+1))
8769       if (j.lt.nres-1) then
8770         itj1 = itortyp(itype(j+1))
8771       else
8772         itj1=ntortyp
8773       endif
8774       do iii=1,2
8775         dipi(iii,1)=Ub2(iii,i)
8776         dipderi(iii)=Ub2der(iii,i)
8777         dipi(iii,2)=b1(iii,i+1)
8778         dipj(iii,1)=Ub2(iii,j)
8779         dipderj(iii)=Ub2der(iii,j)
8780         dipj(iii,2)=b1(iii,j+1)
8781       enddo
8782       kkk=0
8783       do iii=1,2
8784         call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
8785         do jjj=1,2
8786           kkk=kkk+1
8787           dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
8788         enddo
8789       enddo
8790       do kkk=1,5
8791         do lll=1,3
8792           mmm=0
8793           do iii=1,2
8794             call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),
8795      &        auxvec(1))
8796             do jjj=1,2
8797               mmm=mmm+1
8798               dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
8799             enddo
8800           enddo
8801         enddo
8802       enddo
8803       call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
8804       call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
8805       do iii=1,2
8806         dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
8807       enddo
8808       call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
8809       do iii=1,2
8810         dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
8811       enddo
8812       return
8813       end
8814 #endif
8815 C---------------------------------------------------------------------------
8816       subroutine calc_eello(i,j,k,l,jj,kk)
8817 C
8818 C This subroutine computes matrices and vectors needed to calculate
8819 C the fourth-, fifth-, and sixth-order local-electrostatic terms.
8820 C
8821       implicit real*8 (a-h,o-z)
8822       include 'DIMENSIONS'
8823       include 'COMMON.IOUNITS'
8824       include 'COMMON.CHAIN'
8825       include 'COMMON.DERIV'
8826       include 'COMMON.INTERACT'
8827       include 'COMMON.CONTACTS'
8828       include 'COMMON.TORSION'
8829       include 'COMMON.VAR'
8830       include 'COMMON.GEO'
8831       include 'COMMON.FFIELD'
8832       double precision aa1(2,2),aa2(2,2),aa1t(2,2),aa2t(2,2),
8833      &  aa1tder(2,2,3,5),aa2tder(2,2,3,5),auxmat(2,2)
8834       logical lprn
8835       common /kutas/ lprn
8836 cd      write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
8837 cd     & ' jj=',jj,' kk=',kk
8838 cd      if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
8839 cd      write (iout,*) "a_chujij",((a_chuj(iii,jjj,jj,i),iii=1,2),jjj=1,2)
8840 cd      write (iout,*) "a_chujkl",((a_chuj(iii,jjj,kk,k),iii=1,2),jjj=1,2)
8841       do iii=1,2
8842         do jjj=1,2
8843           aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
8844           aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
8845         enddo
8846       enddo
8847       call transpose2(aa1(1,1),aa1t(1,1))
8848       call transpose2(aa2(1,1),aa2t(1,1))
8849       do kkk=1,5
8850         do lll=1,3
8851           call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),
8852      &      aa1tder(1,1,lll,kkk))
8853           call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),
8854      &      aa2tder(1,1,lll,kkk))
8855         enddo
8856       enddo
8857       if (l.eq.j+1) then
8858 C parallel orientation of the two CA-CA-CA frames.
8859         if (i.gt.1) then
8860           iti=itortyp(itype(i))
8861         else
8862           iti=ntortyp
8863         endif
8864         itk1=itortyp(itype(k+1))
8865         itj=itortyp(itype(j))
8866         if (l.lt.nres-1) then
8867           itl1=itortyp(itype(l+1))
8868         else
8869           itl1=ntortyp
8870         endif
8871 C A1 kernel(j+1) A2T
8872 cd        do iii=1,2
8873 cd          write (iout,'(3f10.5,5x,3f10.5)')
8874 cd     &     (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
8875 cd        enddo
8876         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
8877      &   aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),
8878      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
8879 C Following matrices are needed only for 6-th order cumulants
8880         IF (wcorr6.gt.0.0d0) THEN
8881         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
8882      &   aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),
8883      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
8884         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
8885      &   aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),
8886      &   Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
8887      &   ADtEAderx(1,1,1,1,1,1))
8888         lprn=.false.
8889         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
8890      &   aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),
8891      &   DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
8892      &   ADtEA1derx(1,1,1,1,1,1))
8893         ENDIF
8894 C End 6-th order cumulants
8895 cd        lprn=.false.
8896 cd        if (lprn) then
8897 cd        write (2,*) 'In calc_eello6'
8898 cd        do iii=1,2
8899 cd          write (2,*) 'iii=',iii
8900 cd          do kkk=1,5
8901 cd            write (2,*) 'kkk=',kkk
8902 cd            do jjj=1,2
8903 cd              write (2,'(3(2f10.5),5x)')
8904 cd     &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
8905 cd            enddo
8906 cd          enddo
8907 cd        enddo
8908 cd        endif
8909         call transpose2(EUgder(1,1,k),auxmat(1,1))
8910         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
8911         call transpose2(EUg(1,1,k),auxmat(1,1))
8912         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
8913         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
8914         do iii=1,2
8915           do kkk=1,5
8916             do lll=1,3
8917               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
8918      &          EAEAderx(1,1,lll,kkk,iii,1))
8919             enddo
8920           enddo
8921         enddo
8922 C A1T kernel(i+1) A2
8923         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
8924      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),
8925      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
8926 C Following matrices are needed only for 6-th order cumulants
8927         IF (wcorr6.gt.0.0d0) THEN
8928         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
8929      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),
8930      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
8931         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
8932      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),
8933      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
8934      &   ADtEAderx(1,1,1,1,1,2))
8935         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
8936      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),
8937      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
8938      &   ADtEA1derx(1,1,1,1,1,2))
8939         ENDIF
8940 C End 6-th order cumulants
8941         call transpose2(EUgder(1,1,l),auxmat(1,1))
8942         call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
8943         call transpose2(EUg(1,1,l),auxmat(1,1))
8944         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
8945         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
8946         do iii=1,2
8947           do kkk=1,5
8948             do lll=1,3
8949               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
8950      &          EAEAderx(1,1,lll,kkk,iii,2))
8951             enddo
8952           enddo
8953         enddo
8954 C AEAb1 and AEAb2
8955 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
8956 C They are needed only when the fifth- or the sixth-order cumulants are
8957 C indluded.
8958         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
8959         call transpose2(AEA(1,1,1),auxmat(1,1))
8960         call matvec2(auxmat(1,1),b1(1,i),AEAb1(1,1,1))
8961         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
8962         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
8963         call transpose2(AEAderg(1,1,1),auxmat(1,1))
8964         call matvec2(auxmat(1,1),b1(1,i),AEAb1derg(1,1,1))
8965         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
8966         call matvec2(AEA(1,1,1),b1(1,k+1),AEAb1(1,2,1))
8967         call matvec2(AEAderg(1,1,1),b1(1,k+1),AEAb1derg(1,2,1))
8968         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
8969         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
8970         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
8971         call transpose2(AEA(1,1,2),auxmat(1,1))
8972         call matvec2(auxmat(1,1),b1(1,j),AEAb1(1,1,2))
8973         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
8974         call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
8975         call transpose2(AEAderg(1,1,2),auxmat(1,1))
8976         call matvec2(auxmat(1,1),b1(1,j),AEAb1derg(1,1,2))
8977         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
8978         call matvec2(AEA(1,1,2),b1(1,l+1),AEAb1(1,2,2))
8979         call matvec2(AEAderg(1,1,2),b1(1,l+1),AEAb1derg(1,2,2))
8980         call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
8981         call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
8982         call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
8983 C Calculate the Cartesian derivatives of the vectors.
8984         do iii=1,2
8985           do kkk=1,5
8986             do lll=1,3
8987               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
8988               call matvec2(auxmat(1,1),b1(1,i),
8989      &          AEAb1derx(1,lll,kkk,iii,1,1))
8990               call matvec2(auxmat(1,1),Ub2(1,i),
8991      &          AEAb2derx(1,lll,kkk,iii,1,1))
8992               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
8993      &          AEAb1derx(1,lll,kkk,iii,2,1))
8994               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
8995      &          AEAb2derx(1,lll,kkk,iii,2,1))
8996               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
8997               call matvec2(auxmat(1,1),b1(1,j),
8998      &          AEAb1derx(1,lll,kkk,iii,1,2))
8999               call matvec2(auxmat(1,1),Ub2(1,j),
9000      &          AEAb2derx(1,lll,kkk,iii,1,2))
9001               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,l+1),
9002      &          AEAb1derx(1,lll,kkk,iii,2,2))
9003               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),
9004      &          AEAb2derx(1,lll,kkk,iii,2,2))
9005             enddo
9006           enddo
9007         enddo
9008         ENDIF
9009 C End vectors
9010       else
9011 C Antiparallel orientation of the two CA-CA-CA frames.
9012         if (i.gt.1) then
9013           iti=itortyp(itype(i))
9014         else
9015           iti=ntortyp
9016         endif
9017         itk1=itortyp(itype(k+1))
9018         itl=itortyp(itype(l))
9019         itj=itortyp(itype(j))
9020         if (j.lt.nres-1) then
9021           itj1=itortyp(itype(j+1))
9022         else
9023           itj1=ntortyp
9024         endif
9025 C A2 kernel(j-1)T A1T
9026         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9027      &   aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),
9028      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
9029 C Following matrices are needed only for 6-th order cumulants
9030         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
9031      &     j.eq.i+4 .and. l.eq.i+3)) THEN
9032         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9033      &   aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),
9034      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
9035         call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9036      &   aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),
9037      &   Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
9038      &   ADtEAderx(1,1,1,1,1,1))
9039         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9040      &   aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),
9041      &   DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
9042      &   ADtEA1derx(1,1,1,1,1,1))
9043         ENDIF
9044 C End 6-th order cumulants
9045         call transpose2(EUgder(1,1,k),auxmat(1,1))
9046         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
9047         call transpose2(EUg(1,1,k),auxmat(1,1))
9048         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
9049         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
9050         do iii=1,2
9051           do kkk=1,5
9052             do lll=1,3
9053               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
9054      &          EAEAderx(1,1,lll,kkk,iii,1))
9055             enddo
9056           enddo
9057         enddo
9058 C A2T kernel(i+1)T A1
9059         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
9060      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),
9061      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
9062 C Following matrices are needed only for 6-th order cumulants
9063         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
9064      &     j.eq.i+4 .and. l.eq.i+3)) THEN
9065         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
9066      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),
9067      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
9068         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
9069      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),
9070      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
9071      &   ADtEAderx(1,1,1,1,1,2))
9072         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
9073      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),
9074      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
9075      &   ADtEA1derx(1,1,1,1,1,2))
9076         ENDIF
9077 C End 6-th order cumulants
9078         call transpose2(EUgder(1,1,j),auxmat(1,1))
9079         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
9080         call transpose2(EUg(1,1,j),auxmat(1,1))
9081         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
9082         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
9083         do iii=1,2
9084           do kkk=1,5
9085             do lll=1,3
9086               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
9087      &          EAEAderx(1,1,lll,kkk,iii,2))
9088             enddo
9089           enddo
9090         enddo
9091 C AEAb1 and AEAb2
9092 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
9093 C They are needed only when the fifth- or the sixth-order cumulants are
9094 C indluded.
9095         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or.
9096      &    (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
9097         call transpose2(AEA(1,1,1),auxmat(1,1))
9098         call matvec2(auxmat(1,1),b1(1,i),AEAb1(1,1,1))
9099         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
9100         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
9101         call transpose2(AEAderg(1,1,1),auxmat(1,1))
9102         call matvec2(auxmat(1,1),b1(1,i),AEAb1derg(1,1,1))
9103         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
9104         call matvec2(AEA(1,1,1),b1(1,k+1),AEAb1(1,2,1))
9105         call matvec2(AEAderg(1,1,1),b1(1,k+1),AEAb1derg(1,2,1))
9106         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
9107         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
9108         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
9109         call transpose2(AEA(1,1,2),auxmat(1,1))
9110         call matvec2(auxmat(1,1),b1(1,j+1),AEAb1(1,1,2))
9111         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
9112         call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
9113         call transpose2(AEAderg(1,1,2),auxmat(1,1))
9114         call matvec2(auxmat(1,1),b1(1,l),AEAb1(1,1,2))
9115         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
9116         call matvec2(AEA(1,1,2),b1(1,j+1),AEAb1(1,2,2))
9117         call matvec2(AEAderg(1,1,2),b1(1,j+1),AEAb1derg(1,2,2))
9118         call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
9119         call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
9120         call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
9121 C Calculate the Cartesian derivatives of the vectors.
9122         do iii=1,2
9123           do kkk=1,5
9124             do lll=1,3
9125               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
9126               call matvec2(auxmat(1,1),b1(1,i),
9127      &          AEAb1derx(1,lll,kkk,iii,1,1))
9128               call matvec2(auxmat(1,1),Ub2(1,i),
9129      &          AEAb2derx(1,lll,kkk,iii,1,1))
9130               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
9131      &          AEAb1derx(1,lll,kkk,iii,2,1))
9132               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
9133      &          AEAb2derx(1,lll,kkk,iii,2,1))
9134               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
9135               call matvec2(auxmat(1,1),b1(1,l),
9136      &          AEAb1derx(1,lll,kkk,iii,1,2))
9137               call matvec2(auxmat(1,1),Ub2(1,l),
9138      &          AEAb2derx(1,lll,kkk,iii,1,2))
9139               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,j+1),
9140      &          AEAb1derx(1,lll,kkk,iii,2,2))
9141               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),
9142      &          AEAb2derx(1,lll,kkk,iii,2,2))
9143             enddo
9144           enddo
9145         enddo
9146         ENDIF
9147 C End vectors
9148       endif
9149       return
9150       end
9151 C---------------------------------------------------------------------------
9152       subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,
9153      &  KK,KKderg,AKA,AKAderg,AKAderx)
9154       implicit none
9155       integer nderg
9156       logical transp
9157       double precision aa1(2,2),aa2t(2,2),aa1derx(2,2,3,5),
9158      &  aa2tderx(2,2,3,5),KK(2,2),KKderg(2,2,nderg),AKA(2,2),
9159      &  AKAderg(2,2,nderg),AKAderx(2,2,3,5,2)
9160       integer iii,kkk,lll
9161       integer jjj,mmm
9162       logical lprn
9163       common /kutas/ lprn
9164       call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
9165       do iii=1,nderg
9166         call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,
9167      &    AKAderg(1,1,iii))
9168       enddo
9169 cd      if (lprn) write (2,*) 'In kernel'
9170       do kkk=1,5
9171 cd        if (lprn) write (2,*) 'kkk=',kkk
9172         do lll=1,3
9173           call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),
9174      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
9175 cd          if (lprn) then
9176 cd            write (2,*) 'lll=',lll
9177 cd            write (2,*) 'iii=1'
9178 cd            do jjj=1,2
9179 cd              write (2,'(3(2f10.5),5x)')
9180 cd     &        (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
9181 cd            enddo
9182 cd          endif
9183           call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),
9184      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
9185 cd          if (lprn) then
9186 cd            write (2,*) 'lll=',lll
9187 cd            write (2,*) 'iii=2'
9188 cd            do jjj=1,2
9189 cd              write (2,'(3(2f10.5),5x)')
9190 cd     &        (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
9191 cd            enddo
9192 cd          endif
9193         enddo
9194       enddo
9195       return
9196       end
9197 C---------------------------------------------------------------------------
9198       double precision function eello4(i,j,k,l,jj,kk)
9199       implicit real*8 (a-h,o-z)
9200       include 'DIMENSIONS'
9201       include 'COMMON.IOUNITS'
9202       include 'COMMON.CHAIN'
9203       include 'COMMON.DERIV'
9204       include 'COMMON.INTERACT'
9205       include 'COMMON.CONTACTS'
9206       include 'COMMON.TORSION'
9207       include 'COMMON.VAR'
9208       include 'COMMON.GEO'
9209       double precision pizda(2,2),ggg1(3),ggg2(3)
9210 cd      if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
9211 cd        eello4=0.0d0
9212 cd        return
9213 cd      endif
9214 cd      print *,'eello4:',i,j,k,l,jj,kk
9215 cd      write (2,*) 'i',i,' j',j,' k',k,' l',l
9216 cd      call checkint4(i,j,k,l,jj,kk,eel4_num)
9217 cold      eij=facont_hb(jj,i)
9218 cold      ekl=facont_hb(kk,k)
9219 cold      ekont=eij*ekl
9220       eel4=-EAEA(1,1,1)-EAEA(2,2,1)
9221 cd      eel41=-EAEA(1,1,2)-EAEA(2,2,2)
9222       gcorr_loc(k-1)=gcorr_loc(k-1)
9223      &   -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
9224       if (l.eq.j+1) then
9225         gcorr_loc(l-1)=gcorr_loc(l-1)
9226      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
9227       else
9228         gcorr_loc(j-1)=gcorr_loc(j-1)
9229      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
9230       endif
9231       do iii=1,2
9232         do kkk=1,5
9233           do lll=1,3
9234             derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1)
9235      &                        -EAEAderx(2,2,lll,kkk,iii,1)
9236 cd            derx(lll,kkk,iii)=0.0d0
9237           enddo
9238         enddo
9239       enddo
9240 cd      gcorr_loc(l-1)=0.0d0
9241 cd      gcorr_loc(j-1)=0.0d0
9242 cd      gcorr_loc(k-1)=0.0d0
9243 cd      eel4=1.0d0
9244 cd      write (iout,*)'Contacts have occurred for peptide groups',
9245 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l,
9246 cd     &  ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
9247       if (j.lt.nres-1) then
9248         j1=j+1
9249         j2=j-1
9250       else
9251         j1=j-1
9252         j2=j-2
9253       endif
9254       if (l.lt.nres-1) then
9255         l1=l+1
9256         l2=l-1
9257       else
9258         l1=l-1
9259         l2=l-2
9260       endif
9261       do ll=1,3
9262 cgrad        ggg1(ll)=eel4*g_contij(ll,1)
9263 cgrad        ggg2(ll)=eel4*g_contij(ll,2)
9264         glongij=eel4*g_contij(ll,1)+ekont*derx(ll,1,1)
9265         glongkl=eel4*g_contij(ll,2)+ekont*derx(ll,1,2)
9266 cgrad        ghalf=0.5d0*ggg1(ll)
9267         gradcorr(ll,i)=gradcorr(ll,i)+ekont*derx(ll,2,1)
9268         gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
9269         gradcorr(ll,j)=gradcorr(ll,j)+ekont*derx(ll,4,1)
9270         gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
9271         gradcorr_long(ll,j)=gradcorr_long(ll,j)+glongij
9272         gradcorr_long(ll,i)=gradcorr_long(ll,i)-glongij
9273 cgrad        ghalf=0.5d0*ggg2(ll)
9274         gradcorr(ll,k)=gradcorr(ll,k)+ekont*derx(ll,2,2)
9275         gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
9276         gradcorr(ll,l)=gradcorr(ll,l)+ekont*derx(ll,4,2)
9277         gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
9278         gradcorr_long(ll,l)=gradcorr_long(ll,l)+glongkl
9279         gradcorr_long(ll,k)=gradcorr_long(ll,k)-glongkl
9280       enddo
9281 cgrad      do m=i+1,j-1
9282 cgrad        do ll=1,3
9283 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
9284 cgrad        enddo
9285 cgrad      enddo
9286 cgrad      do m=k+1,l-1
9287 cgrad        do ll=1,3
9288 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
9289 cgrad        enddo
9290 cgrad      enddo
9291 cgrad      do m=i+2,j2
9292 cgrad        do ll=1,3
9293 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
9294 cgrad        enddo
9295 cgrad      enddo
9296 cgrad      do m=k+2,l2
9297 cgrad        do ll=1,3
9298 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
9299 cgrad        enddo
9300 cgrad      enddo
9301 cd      do iii=1,nres-3
9302 cd        write (2,*) iii,gcorr_loc(iii)
9303 cd      enddo
9304       eello4=ekont*eel4
9305 cd      write (2,*) 'ekont',ekont
9306 cd      write (iout,*) 'eello4',ekont*eel4
9307       return
9308       end
9309 C---------------------------------------------------------------------------
9310       double precision function eello5(i,j,k,l,jj,kk)
9311       implicit real*8 (a-h,o-z)
9312       include 'DIMENSIONS'
9313       include 'COMMON.IOUNITS'
9314       include 'COMMON.CHAIN'
9315       include 'COMMON.DERIV'
9316       include 'COMMON.INTERACT'
9317       include 'COMMON.CONTACTS'
9318       include 'COMMON.TORSION'
9319       include 'COMMON.VAR'
9320       include 'COMMON.GEO'
9321       double precision pizda(2,2),auxmat(2,2),auxmat1(2,2),vv(2)
9322       double precision ggg1(3),ggg2(3)
9323 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9324 C                                                                              C
9325 C                            Parallel chains                                   C
9326 C                                                                              C
9327 C          o             o                   o             o                   C
9328 C         /l\           / \             \   / \           / \   /              C
9329 C        /   \         /   \             \ /   \         /   \ /               C
9330 C       j| o |l1       | o |              o| o |         | o |o                C
9331 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
9332 C      \i/   \         /   \ /             /   \         /   \                 C
9333 C       o    k1             o                                                  C
9334 C         (I)          (II)                (III)          (IV)                 C
9335 C                                                                              C
9336 C      eello5_1        eello5_2            eello5_3       eello5_4             C
9337 C                                                                              C
9338 C                            Antiparallel chains                               C
9339 C                                                                              C
9340 C          o             o                   o             o                   C
9341 C         /j\           / \             \   / \           / \   /              C
9342 C        /   \         /   \             \ /   \         /   \ /               C
9343 C      j1| o |l        | o |              o| o |         | o |o                C
9344 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
9345 C      \i/   \         /   \ /             /   \         /   \                 C
9346 C       o     k1            o                                                  C
9347 C         (I)          (II)                (III)          (IV)                 C
9348 C                                                                              C
9349 C      eello5_1        eello5_2            eello5_3       eello5_4             C
9350 C                                                                              C
9351 C o denotes a local interaction, vertical lines an electrostatic interaction.  C
9352 C                                                                              C
9353 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9354 cd      if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
9355 cd        eello5=0.0d0
9356 cd        return
9357 cd      endif
9358 cd      write (iout,*)
9359 cd     &   'EELLO5: Contacts have occurred for peptide groups',i,j,
9360 cd     &   ' and',k,l
9361       itk=itortyp(itype(k))
9362       itl=itortyp(itype(l))
9363       itj=itortyp(itype(j))
9364       eello5_1=0.0d0
9365       eello5_2=0.0d0
9366       eello5_3=0.0d0
9367       eello5_4=0.0d0
9368 cd      call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
9369 cd     &   eel5_3_num,eel5_4_num)
9370       do iii=1,2
9371         do kkk=1,5
9372           do lll=1,3
9373             derx(lll,kkk,iii)=0.0d0
9374           enddo
9375         enddo
9376       enddo
9377 cd      eij=facont_hb(jj,i)
9378 cd      ekl=facont_hb(kk,k)
9379 cd      ekont=eij*ekl
9380 cd      write (iout,*)'Contacts have occurred for peptide groups',
9381 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l
9382 cd      goto 1111
9383 C Contribution from the graph I.
9384 cd      write (2,*) 'AEA  ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
9385 cd      write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
9386       call transpose2(EUg(1,1,k),auxmat(1,1))
9387       call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
9388       vv(1)=pizda(1,1)-pizda(2,2)
9389       vv(2)=pizda(1,2)+pizda(2,1)
9390       eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k))
9391      & +0.5d0*scalar2(vv(1),Dtobr2(1,i))
9392 C Explicit gradient in virtual-dihedral angles.
9393       if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1)
9394      & +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k))
9395      & +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
9396       call transpose2(EUgder(1,1,k),auxmat1(1,1))
9397       call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
9398       vv(1)=pizda(1,1)-pizda(2,2)
9399       vv(2)=pizda(1,2)+pizda(2,1)
9400       g_corr5_loc(k-1)=g_corr5_loc(k-1)
9401      & +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k))
9402      & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
9403       call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
9404       vv(1)=pizda(1,1)-pizda(2,2)
9405       vv(2)=pizda(1,2)+pizda(2,1)
9406       if (l.eq.j+1) then
9407         if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1)
9408      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
9409      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
9410       else
9411         if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1)
9412      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
9413      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
9414       endif
9415 C Cartesian gradient
9416       do iii=1,2
9417         do kkk=1,5
9418           do lll=1,3
9419             call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),
9420      &        pizda(1,1))
9421             vv(1)=pizda(1,1)-pizda(2,2)
9422             vv(2)=pizda(1,2)+pizda(2,1)
9423             derx(lll,kkk,iii)=derx(lll,kkk,iii)
9424      &       +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k))
9425      &       +0.5d0*scalar2(vv(1),Dtobr2(1,i))
9426           enddo
9427         enddo
9428       enddo
9429 c      goto 1112
9430 c1111  continue
9431 C Contribution from graph II
9432       call transpose2(EE(1,1,itk),auxmat(1,1))
9433       call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
9434       vv(1)=pizda(1,1)+pizda(2,2)
9435       vv(2)=pizda(2,1)-pizda(1,2)
9436       eello5_2=scalar2(AEAb1(1,2,1),b1(1,k))
9437      & -0.5d0*scalar2(vv(1),Ctobr(1,k))
9438 C Explicit gradient in virtual-dihedral angles.
9439       g_corr5_loc(k-1)=g_corr5_loc(k-1)
9440      & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
9441       call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
9442       vv(1)=pizda(1,1)+pizda(2,2)
9443       vv(2)=pizda(2,1)-pizda(1,2)
9444       if (l.eq.j+1) then
9445         g_corr5_loc(l-1)=g_corr5_loc(l-1)
9446      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,k))
9447      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
9448       else
9449         g_corr5_loc(j-1)=g_corr5_loc(j-1)
9450      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,k))
9451      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
9452       endif
9453 C Cartesian gradient
9454       do iii=1,2
9455         do kkk=1,5
9456           do lll=1,3
9457             call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
9458      &        pizda(1,1))
9459             vv(1)=pizda(1,1)+pizda(2,2)
9460             vv(2)=pizda(2,1)-pizda(1,2)
9461             derx(lll,kkk,iii)=derx(lll,kkk,iii)
9462      &       +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,k))
9463      &       -0.5d0*scalar2(vv(1),Ctobr(1,k))
9464           enddo
9465         enddo
9466       enddo
9467 cd      goto 1112
9468 cd1111  continue
9469       if (l.eq.j+1) then
9470 cd        goto 1110
9471 C Parallel orientation
9472 C Contribution from graph III
9473         call transpose2(EUg(1,1,l),auxmat(1,1))
9474         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
9475         vv(1)=pizda(1,1)-pizda(2,2)
9476         vv(2)=pizda(1,2)+pizda(2,1)
9477         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l))
9478      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j))
9479 C Explicit gradient in virtual-dihedral angles.
9480         g_corr5_loc(j-1)=g_corr5_loc(j-1)
9481      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l))
9482      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
9483         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
9484         vv(1)=pizda(1,1)-pizda(2,2)
9485         vv(2)=pizda(1,2)+pizda(2,1)
9486         g_corr5_loc(k-1)=g_corr5_loc(k-1)
9487      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l))
9488      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
9489         call transpose2(EUgder(1,1,l),auxmat1(1,1))
9490         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
9491         vv(1)=pizda(1,1)-pizda(2,2)
9492         vv(2)=pizda(1,2)+pizda(2,1)
9493         g_corr5_loc(l-1)=g_corr5_loc(l-1)
9494      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l))
9495      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
9496 C Cartesian gradient
9497         do iii=1,2
9498           do kkk=1,5
9499             do lll=1,3
9500               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
9501      &          pizda(1,1))
9502               vv(1)=pizda(1,1)-pizda(2,2)
9503               vv(2)=pizda(1,2)+pizda(2,1)
9504               derx(lll,kkk,iii)=derx(lll,kkk,iii)
9505      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l))
9506      &         +0.5d0*scalar2(vv(1),Dtobr2(1,j))
9507             enddo
9508           enddo
9509         enddo
9510 cd        goto 1112
9511 C Contribution from graph IV
9512 cd1110    continue
9513         call transpose2(EE(1,1,itl),auxmat(1,1))
9514         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
9515         vv(1)=pizda(1,1)+pizda(2,2)
9516         vv(2)=pizda(2,1)-pizda(1,2)
9517         eello5_4=scalar2(AEAb1(1,2,2),b1(1,l))
9518      &   -0.5d0*scalar2(vv(1),Ctobr(1,l))
9519 C Explicit gradient in virtual-dihedral angles.
9520         g_corr5_loc(l-1)=g_corr5_loc(l-1)
9521      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
9522         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
9523         vv(1)=pizda(1,1)+pizda(2,2)
9524         vv(2)=pizda(2,1)-pizda(1,2)
9525         g_corr5_loc(k-1)=g_corr5_loc(k-1)
9526      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,l))
9527      &   -0.5d0*scalar2(vv(1),Ctobr(1,l)))
9528 C Cartesian gradient
9529         do iii=1,2
9530           do kkk=1,5
9531             do lll=1,3
9532               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
9533      &          pizda(1,1))
9534               vv(1)=pizda(1,1)+pizda(2,2)
9535               vv(2)=pizda(2,1)-pizda(1,2)
9536               derx(lll,kkk,iii)=derx(lll,kkk,iii)
9537      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,l))
9538      &         -0.5d0*scalar2(vv(1),Ctobr(1,l))
9539             enddo
9540           enddo
9541         enddo
9542       else
9543 C Antiparallel orientation
9544 C Contribution from graph III
9545 c        goto 1110
9546         call transpose2(EUg(1,1,j),auxmat(1,1))
9547         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
9548         vv(1)=pizda(1,1)-pizda(2,2)
9549         vv(2)=pizda(1,2)+pizda(2,1)
9550         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j))
9551      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l))
9552 C Explicit gradient in virtual-dihedral angles.
9553         g_corr5_loc(l-1)=g_corr5_loc(l-1)
9554      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j))
9555      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
9556         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
9557         vv(1)=pizda(1,1)-pizda(2,2)
9558         vv(2)=pizda(1,2)+pizda(2,1)
9559         g_corr5_loc(k-1)=g_corr5_loc(k-1)
9560      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j))
9561      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
9562         call transpose2(EUgder(1,1,j),auxmat1(1,1))
9563         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
9564         vv(1)=pizda(1,1)-pizda(2,2)
9565         vv(2)=pizda(1,2)+pizda(2,1)
9566         g_corr5_loc(j-1)=g_corr5_loc(j-1)
9567      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j))
9568      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
9569 C Cartesian gradient
9570         do iii=1,2
9571           do kkk=1,5
9572             do lll=1,3
9573               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
9574      &          pizda(1,1))
9575               vv(1)=pizda(1,1)-pizda(2,2)
9576               vv(2)=pizda(1,2)+pizda(2,1)
9577               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
9578      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j))
9579      &         +0.5d0*scalar2(vv(1),Dtobr2(1,l))
9580             enddo
9581           enddo
9582         enddo
9583 cd        goto 1112
9584 C Contribution from graph IV
9585 1110    continue
9586         call transpose2(EE(1,1,itj),auxmat(1,1))
9587         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
9588         vv(1)=pizda(1,1)+pizda(2,2)
9589         vv(2)=pizda(2,1)-pizda(1,2)
9590         eello5_4=scalar2(AEAb1(1,2,2),b1(1,j))
9591      &   -0.5d0*scalar2(vv(1),Ctobr(1,j))
9592 C Explicit gradient in virtual-dihedral angles.
9593         g_corr5_loc(j-1)=g_corr5_loc(j-1)
9594      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
9595         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
9596         vv(1)=pizda(1,1)+pizda(2,2)
9597         vv(2)=pizda(2,1)-pizda(1,2)
9598         g_corr5_loc(k-1)=g_corr5_loc(k-1)
9599      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,j))
9600      &   -0.5d0*scalar2(vv(1),Ctobr(1,j)))
9601 C Cartesian gradient
9602         do iii=1,2
9603           do kkk=1,5
9604             do lll=1,3
9605               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
9606      &          pizda(1,1))
9607               vv(1)=pizda(1,1)+pizda(2,2)
9608               vv(2)=pizda(2,1)-pizda(1,2)
9609               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
9610      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,j))
9611      &         -0.5d0*scalar2(vv(1),Ctobr(1,j))
9612             enddo
9613           enddo
9614         enddo
9615       endif
9616 1112  continue
9617       eel5=eello5_1+eello5_2+eello5_3+eello5_4
9618 cd      if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
9619 cd        write (2,*) 'ijkl',i,j,k,l
9620 cd        write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
9621 cd     &     ' eello5_3',eello5_3,' eello5_4',eello5_4
9622 cd      endif
9623 cd      write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
9624 cd      write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
9625 cd      write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
9626 cd      write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
9627       if (j.lt.nres-1) then
9628         j1=j+1
9629         j2=j-1
9630       else
9631         j1=j-1
9632         j2=j-2
9633       endif
9634       if (l.lt.nres-1) then
9635         l1=l+1
9636         l2=l-1
9637       else
9638         l1=l-1
9639         l2=l-2
9640       endif
9641 cd      eij=1.0d0
9642 cd      ekl=1.0d0
9643 cd      ekont=1.0d0
9644 cd      write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
9645 C 2/11/08 AL Gradients over DC's connecting interacting sites will be
9646 C        summed up outside the subrouine as for the other subroutines
9647 C        handling long-range interactions. The old code is commented out
9648 C        with "cgrad" to keep track of changes.
9649       do ll=1,3
9650 cgrad        ggg1(ll)=eel5*g_contij(ll,1)
9651 cgrad        ggg2(ll)=eel5*g_contij(ll,2)
9652         gradcorr5ij=eel5*g_contij(ll,1)+ekont*derx(ll,1,1)
9653         gradcorr5kl=eel5*g_contij(ll,2)+ekont*derx(ll,1,2)
9654 c        write (iout,'(a,3i3,a,5f8.3,2i3,a,5f8.3,a,f8.3)')
9655 c     &   "ecorr5",ll,i,j," derx",derx(ll,2,1),derx(ll,3,1),derx(ll,4,1),
9656 c     &   derx(ll,5,1),k,l," derx",derx(ll,2,2),derx(ll,3,2),
9657 c     &   derx(ll,4,2),derx(ll,5,2)," ekont",ekont
9658 c        write (iout,'(a,3i3,a,3f8.3,2i3,a,3f8.3)')
9659 c     &   "ecorr5",ll,i,j," gradcorr5",g_contij(ll,1),derx(ll,1,1),
9660 c     &   gradcorr5ij,
9661 c     &   k,l," gradcorr5",g_contij(ll,2),derx(ll,1,2),gradcorr5kl
9662 cold        ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
9663 cgrad        ghalf=0.5d0*ggg1(ll)
9664 cd        ghalf=0.0d0
9665         gradcorr5(ll,i)=gradcorr5(ll,i)+ekont*derx(ll,2,1)
9666         gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
9667         gradcorr5(ll,j)=gradcorr5(ll,j)+ekont*derx(ll,4,1)
9668         gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
9669         gradcorr5_long(ll,j)=gradcorr5_long(ll,j)+gradcorr5ij
9670         gradcorr5_long(ll,i)=gradcorr5_long(ll,i)-gradcorr5ij
9671 cold        ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
9672 cgrad        ghalf=0.5d0*ggg2(ll)
9673 cd        ghalf=0.0d0
9674         gradcorr5(ll,k)=gradcorr5(ll,k)+ghalf+ekont*derx(ll,2,2)
9675         gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
9676         gradcorr5(ll,l)=gradcorr5(ll,l)+ghalf+ekont*derx(ll,4,2)
9677         gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
9678         gradcorr5_long(ll,l)=gradcorr5_long(ll,l)+gradcorr5kl
9679         gradcorr5_long(ll,k)=gradcorr5_long(ll,k)-gradcorr5kl
9680       enddo
9681 cd      goto 1112
9682 cgrad      do m=i+1,j-1
9683 cgrad        do ll=1,3
9684 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
9685 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
9686 cgrad        enddo
9687 cgrad      enddo
9688 cgrad      do m=k+1,l-1
9689 cgrad        do ll=1,3
9690 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
9691 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
9692 cgrad        enddo
9693 cgrad      enddo
9694 c1112  continue
9695 cgrad      do m=i+2,j2
9696 cgrad        do ll=1,3
9697 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
9698 cgrad        enddo
9699 cgrad      enddo
9700 cgrad      do m=k+2,l2
9701 cgrad        do ll=1,3
9702 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
9703 cgrad        enddo
9704 cgrad      enddo
9705 cd      do iii=1,nres-3
9706 cd        write (2,*) iii,g_corr5_loc(iii)
9707 cd      enddo
9708       eello5=ekont*eel5
9709 cd      write (2,*) 'ekont',ekont
9710 cd      write (iout,*) 'eello5',ekont*eel5
9711       return
9712       end
9713 c--------------------------------------------------------------------------
9714       double precision function eello6(i,j,k,l,jj,kk)
9715       implicit real*8 (a-h,o-z)
9716       include 'DIMENSIONS'
9717       include 'COMMON.IOUNITS'
9718       include 'COMMON.CHAIN'
9719       include 'COMMON.DERIV'
9720       include 'COMMON.INTERACT'
9721       include 'COMMON.CONTACTS'
9722       include 'COMMON.TORSION'
9723       include 'COMMON.VAR'
9724       include 'COMMON.GEO'
9725       include 'COMMON.FFIELD'
9726       double precision ggg1(3),ggg2(3)
9727 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
9728 cd        eello6=0.0d0
9729 cd        return
9730 cd      endif
9731 cd      write (iout,*)
9732 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
9733 cd     &   ' and',k,l
9734       eello6_1=0.0d0
9735       eello6_2=0.0d0
9736       eello6_3=0.0d0
9737       eello6_4=0.0d0
9738       eello6_5=0.0d0
9739       eello6_6=0.0d0
9740 cd      call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
9741 cd     &   eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
9742       do iii=1,2
9743         do kkk=1,5
9744           do lll=1,3
9745             derx(lll,kkk,iii)=0.0d0
9746           enddo
9747         enddo
9748       enddo
9749 cd      eij=facont_hb(jj,i)
9750 cd      ekl=facont_hb(kk,k)
9751 cd      ekont=eij*ekl
9752 cd      eij=1.0d0
9753 cd      ekl=1.0d0
9754 cd      ekont=1.0d0
9755       if (l.eq.j+1) then
9756         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
9757         eello6_2=eello6_graph1(j,i,l,k,2,.false.)
9758         eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
9759         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
9760         eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
9761         eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
9762       else
9763         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
9764         eello6_2=eello6_graph1(l,k,j,i,2,.true.)
9765         eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
9766         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
9767         if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
9768           eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
9769         else
9770           eello6_5=0.0d0
9771         endif
9772         eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
9773       endif
9774 C If turn contributions are considered, they will be handled separately.
9775       eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
9776 cd      write(iout,*) 'eello6_1',eello6_1!,' eel6_1_num',16*eel6_1_num
9777 cd      write(iout,*) 'eello6_2',eello6_2!,' eel6_2_num',16*eel6_2_num
9778 cd      write(iout,*) 'eello6_3',eello6_3!,' eel6_3_num',16*eel6_3_num
9779 cd      write(iout,*) 'eello6_4',eello6_4!,' eel6_4_num',16*eel6_4_num
9780 cd      write(iout,*) 'eello6_5',eello6_5!,' eel6_5_num',16*eel6_5_num
9781 cd      write(iout,*) 'eello6_6',eello6_6!,' eel6_6_num',16*eel6_6_num
9782 cd      goto 1112
9783       if (j.lt.nres-1) then
9784         j1=j+1
9785         j2=j-1
9786       else
9787         j1=j-1
9788         j2=j-2
9789       endif
9790       if (l.lt.nres-1) then
9791         l1=l+1
9792         l2=l-1
9793       else
9794         l1=l-1
9795         l2=l-2
9796       endif
9797       do ll=1,3
9798 cgrad        ggg1(ll)=eel6*g_contij(ll,1)
9799 cgrad        ggg2(ll)=eel6*g_contij(ll,2)
9800 cold        ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
9801 cgrad        ghalf=0.5d0*ggg1(ll)
9802 cd        ghalf=0.0d0
9803         gradcorr6ij=eel6*g_contij(ll,1)+ekont*derx(ll,1,1)
9804         gradcorr6kl=eel6*g_contij(ll,2)+ekont*derx(ll,1,2)
9805         gradcorr6(ll,i)=gradcorr6(ll,i)+ekont*derx(ll,2,1)
9806         gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
9807         gradcorr6(ll,j)=gradcorr6(ll,j)+ekont*derx(ll,4,1)
9808         gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
9809         gradcorr6_long(ll,j)=gradcorr6_long(ll,j)+gradcorr6ij
9810         gradcorr6_long(ll,i)=gradcorr6_long(ll,i)-gradcorr6ij
9811 cgrad        ghalf=0.5d0*ggg2(ll)
9812 cold        ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
9813 cd        ghalf=0.0d0
9814         gradcorr6(ll,k)=gradcorr6(ll,k)+ekont*derx(ll,2,2)
9815         gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
9816         gradcorr6(ll,l)=gradcorr6(ll,l)+ekont*derx(ll,4,2)
9817         gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
9818         gradcorr6_long(ll,l)=gradcorr6_long(ll,l)+gradcorr6kl
9819         gradcorr6_long(ll,k)=gradcorr6_long(ll,k)-gradcorr6kl
9820       enddo
9821 cd      goto 1112
9822 cgrad      do m=i+1,j-1
9823 cgrad        do ll=1,3
9824 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
9825 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
9826 cgrad        enddo
9827 cgrad      enddo
9828 cgrad      do m=k+1,l-1
9829 cgrad        do ll=1,3
9830 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
9831 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
9832 cgrad        enddo
9833 cgrad      enddo
9834 cgrad1112  continue
9835 cgrad      do m=i+2,j2
9836 cgrad        do ll=1,3
9837 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
9838 cgrad        enddo
9839 cgrad      enddo
9840 cgrad      do m=k+2,l2
9841 cgrad        do ll=1,3
9842 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
9843 cgrad        enddo
9844 cgrad      enddo
9845 cd      do iii=1,nres-3
9846 cd        write (2,*) iii,g_corr6_loc(iii)
9847 cd      enddo
9848       eello6=ekont*eel6
9849 cd      write (2,*) 'ekont',ekont
9850 cd      write (iout,*) 'eello6',ekont*eel6
9851       return
9852       end
9853 c--------------------------------------------------------------------------
9854       double precision function eello6_graph1(i,j,k,l,imat,swap)
9855       implicit real*8 (a-h,o-z)
9856       include 'DIMENSIONS'
9857       include 'COMMON.IOUNITS'
9858       include 'COMMON.CHAIN'
9859       include 'COMMON.DERIV'
9860       include 'COMMON.INTERACT'
9861       include 'COMMON.CONTACTS'
9862       include 'COMMON.TORSION'
9863       include 'COMMON.VAR'
9864       include 'COMMON.GEO'
9865       double precision vv(2),vv1(2),pizda(2,2),auxmat(2,2),pizda1(2,2)
9866       logical swap
9867       logical lprn
9868       common /kutas/ lprn
9869 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9870 C                                                                              C
9871 C      Parallel       Antiparallel                                             C
9872 C                                                                              C
9873 C          o             o                                                     C
9874 C         /l\           /j\                                                    C
9875 C        /   \         /   \                                                   C
9876 C       /| o |         | o |\                                                  C
9877 C     \ j|/k\|  /   \  |/k\|l /                                                C
9878 C      \ /   \ /     \ /   \ /                                                 C
9879 C       o     o       o     o                                                  C
9880 C       i             i                                                        C
9881 C                                                                              C
9882 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9883       itk=itortyp(itype(k))
9884       s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
9885       s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
9886       s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
9887       call transpose2(EUgC(1,1,k),auxmat(1,1))
9888       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
9889       vv1(1)=pizda1(1,1)-pizda1(2,2)
9890       vv1(2)=pizda1(1,2)+pizda1(2,1)
9891       s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
9892       vv(1)=AEAb1(1,2,imat)*b1(1,k)-AEAb1(2,2,imat)*b1(2,k)
9893       vv(2)=AEAb1(1,2,imat)*b1(2,k)+AEAb1(2,2,imat)*b1(1,k)
9894       s5=scalar2(vv(1),Dtobr2(1,i))
9895 cd      write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
9896       eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
9897       if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1)
9898      & -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i))
9899      & -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k))
9900      & +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k))
9901      & +0.5d0*scalar2(vv1(1),Dtobr2der(1,i))
9902      & +scalar2(vv(1),Dtobr2der(1,i)))
9903       call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
9904       vv1(1)=pizda1(1,1)-pizda1(2,2)
9905       vv1(2)=pizda1(1,2)+pizda1(2,1)
9906       vv(1)=AEAb1derg(1,2,imat)*b1(1,k)-AEAb1derg(2,2,imat)*b1(2,k)
9907       vv(2)=AEAb1derg(1,2,imat)*b1(2,k)+AEAb1derg(2,2,imat)*b1(1,k)
9908       if (l.eq.j+1) then
9909         g_corr6_loc(l-1)=g_corr6_loc(l-1)
9910      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
9911      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
9912      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
9913      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
9914       else
9915         g_corr6_loc(j-1)=g_corr6_loc(j-1)
9916      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
9917      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
9918      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
9919      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
9920       endif
9921       call transpose2(EUgCder(1,1,k),auxmat(1,1))
9922       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
9923       vv1(1)=pizda1(1,1)-pizda1(2,2)
9924       vv1(2)=pizda1(1,2)+pizda1(2,1)
9925       if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1)
9926      & +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k))
9927      & +scalar2(AEAb2(1,1,imat),CUgb2der(1,k))
9928      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
9929       do iii=1,2
9930         if (swap) then
9931           ind=3-iii
9932         else
9933           ind=iii
9934         endif
9935         do kkk=1,5
9936           do lll=1,3
9937             s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
9938             s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
9939             s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
9940             call transpose2(EUgC(1,1,k),auxmat(1,1))
9941             call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
9942      &        pizda1(1,1))
9943             vv1(1)=pizda1(1,1)-pizda1(2,2)
9944             vv1(2)=pizda1(1,2)+pizda1(2,1)
9945             s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
9946             vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,k)
9947      &       -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,k)
9948             vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,k)
9949      &       +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,k)
9950             s5=scalar2(vv(1),Dtobr2(1,i))
9951             derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
9952           enddo
9953         enddo
9954       enddo
9955       return
9956       end
9957 c----------------------------------------------------------------------------
9958       double precision function eello6_graph2(i,j,k,l,jj,kk,swap)
9959       implicit real*8 (a-h,o-z)
9960       include 'DIMENSIONS'
9961       include 'COMMON.IOUNITS'
9962       include 'COMMON.CHAIN'
9963       include 'COMMON.DERIV'
9964       include 'COMMON.INTERACT'
9965       include 'COMMON.CONTACTS'
9966       include 'COMMON.TORSION'
9967       include 'COMMON.VAR'
9968       include 'COMMON.GEO'
9969       logical swap
9970       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
9971      & auxvec1(2),auxvec2(2),auxmat1(2,2)
9972       logical lprn
9973       common /kutas/ lprn
9974 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9975 C                                                                              C
9976 C      Parallel       Antiparallel                                             C
9977 C                                                                              C
9978 C          o             o                                                     C
9979 C     \   /l\           /j\   /                                                C
9980 C      \ /   \         /   \ /                                                 C
9981 C       o| o |         | o |o                                                  C
9982 C     \ j|/k\|      \  |/k\|l                                                  C
9983 C      \ /   \       \ /   \                                                   C
9984 C       o             o                                                        C
9985 C       i             i                                                        C
9986 C                                                                              C
9987 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9988 cd      write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
9989 C AL 7/4/01 s1 would occur in the sixth-order moment,
9990 C           but not in a cluster cumulant
9991 #ifdef MOMENT
9992       s1=dip(1,jj,i)*dip(1,kk,k)
9993 #endif
9994       call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
9995       s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
9996       call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
9997       s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
9998       call transpose2(EUg(1,1,k),auxmat(1,1))
9999       call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
10000       vv(1)=pizda(1,1)-pizda(2,2)
10001       vv(2)=pizda(1,2)+pizda(2,1)
10002       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
10003 cd      write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
10004 #ifdef MOMENT
10005       eello6_graph2=-(s1+s2+s3+s4)
10006 #else
10007       eello6_graph2=-(s2+s3+s4)
10008 #endif
10009 c      eello6_graph2=-s3
10010 C Derivatives in gamma(i-1)
10011       if (i.gt.1) then
10012 #ifdef MOMENT
10013         s1=dipderg(1,jj,i)*dip(1,kk,k)
10014 #endif
10015         s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
10016         call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
10017         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
10018         s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
10019 #ifdef MOMENT
10020         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
10021 #else
10022         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
10023 #endif
10024 c        g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
10025       endif
10026 C Derivatives in gamma(k-1)
10027 #ifdef MOMENT
10028       s1=dip(1,jj,i)*dipderg(1,kk,k)
10029 #endif
10030       call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
10031       s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
10032       call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
10033       s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
10034       call transpose2(EUgder(1,1,k),auxmat1(1,1))
10035       call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
10036       vv(1)=pizda(1,1)-pizda(2,2)
10037       vv(2)=pizda(1,2)+pizda(2,1)
10038       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
10039 #ifdef MOMENT
10040       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
10041 #else
10042       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
10043 #endif
10044 c      g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
10045 C Derivatives in gamma(j-1) or gamma(l-1)
10046       if (j.gt.1) then
10047 #ifdef MOMENT
10048         s1=dipderg(3,jj,i)*dip(1,kk,k)
10049 #endif
10050         call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
10051         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
10052         s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
10053         call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
10054         vv(1)=pizda(1,1)-pizda(2,2)
10055         vv(2)=pizda(1,2)+pizda(2,1)
10056         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
10057 #ifdef MOMENT
10058         if (swap) then
10059           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
10060         else
10061           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
10062         endif
10063 #endif
10064         g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
10065 c        g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
10066       endif
10067 C Derivatives in gamma(l-1) or gamma(j-1)
10068       if (l.gt.1) then
10069 #ifdef MOMENT
10070         s1=dip(1,jj,i)*dipderg(3,kk,k)
10071 #endif
10072         call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
10073         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
10074         call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
10075         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
10076         call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
10077         vv(1)=pizda(1,1)-pizda(2,2)
10078         vv(2)=pizda(1,2)+pizda(2,1)
10079         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
10080 #ifdef MOMENT
10081         if (swap) then
10082           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
10083         else
10084           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
10085         endif
10086 #endif
10087         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
10088 c        g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
10089       endif
10090 C Cartesian derivatives.
10091       if (lprn) then
10092         write (2,*) 'In eello6_graph2'
10093         do iii=1,2
10094           write (2,*) 'iii=',iii
10095           do kkk=1,5
10096             write (2,*) 'kkk=',kkk
10097             do jjj=1,2
10098               write (2,'(3(2f10.5),5x)')
10099      &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
10100             enddo
10101           enddo
10102         enddo
10103       endif
10104       do iii=1,2
10105         do kkk=1,5
10106           do lll=1,3
10107 #ifdef MOMENT
10108             if (iii.eq.1) then
10109               s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
10110             else
10111               s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
10112             endif
10113 #endif
10114             call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),
10115      &        auxvec(1))
10116             s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
10117             call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),
10118      &        auxvec(1))
10119             s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
10120             call transpose2(EUg(1,1,k),auxmat(1,1))
10121             call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),
10122      &        pizda(1,1))
10123             vv(1)=pizda(1,1)-pizda(2,2)
10124             vv(2)=pizda(1,2)+pizda(2,1)
10125             s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
10126 cd            write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
10127 #ifdef MOMENT
10128             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
10129 #else
10130             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
10131 #endif
10132             if (swap) then
10133               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
10134             else
10135               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
10136             endif
10137           enddo
10138         enddo
10139       enddo
10140       return
10141       end
10142 c----------------------------------------------------------------------------
10143       double precision function eello6_graph3(i,j,k,l,jj,kk,swap)
10144       implicit real*8 (a-h,o-z)
10145       include 'DIMENSIONS'
10146       include 'COMMON.IOUNITS'
10147       include 'COMMON.CHAIN'
10148       include 'COMMON.DERIV'
10149       include 'COMMON.INTERACT'
10150       include 'COMMON.CONTACTS'
10151       include 'COMMON.TORSION'
10152       include 'COMMON.VAR'
10153       include 'COMMON.GEO'
10154       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2)
10155       logical swap
10156 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10157 C                                                                              C
10158 C      Parallel       Antiparallel                                             C
10159 C                                                                              C
10160 C          o             o                                                     C
10161 C         /l\   /   \   /j\                                                    C
10162 C        /   \ /     \ /   \                                                   C
10163 C       /| o |o       o| o |\                                                  C
10164 C       j|/k\|  /      |/k\|l /                                                C
10165 C        /   \ /       /   \ /                                                 C
10166 C       /     o       /     o                                                  C
10167 C       i             i                                                        C
10168 C                                                                              C
10169 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10170 C
10171 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
10172 C           energy moment and not to the cluster cumulant.
10173       iti=itortyp(itype(i))
10174       if (j.lt.nres-1) then
10175         itj1=itortyp(itype(j+1))
10176       else
10177         itj1=ntortyp
10178       endif
10179       itk=itortyp(itype(k))
10180       itk1=itortyp(itype(k+1))
10181       if (l.lt.nres-1) then
10182         itl1=itortyp(itype(l+1))
10183       else
10184         itl1=ntortyp
10185       endif
10186 #ifdef MOMENT
10187       s1=dip(4,jj,i)*dip(4,kk,k)
10188 #endif
10189       call matvec2(AECA(1,1,1),b1(1,k+1),auxvec(1))
10190       s2=0.5d0*scalar2(b1(1,k),auxvec(1))
10191       call matvec2(AECA(1,1,2),b1(1,l+1),auxvec(1))
10192       s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
10193       call transpose2(EE(1,1,itk),auxmat(1,1))
10194       call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
10195       vv(1)=pizda(1,1)+pizda(2,2)
10196       vv(2)=pizda(2,1)-pizda(1,2)
10197       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
10198 cd      write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4,
10199 cd     & "sum",-(s2+s3+s4)
10200 #ifdef MOMENT
10201       eello6_graph3=-(s1+s2+s3+s4)
10202 #else
10203       eello6_graph3=-(s2+s3+s4)
10204 #endif
10205 c      eello6_graph3=-s4
10206 C Derivatives in gamma(k-1)
10207       call matvec2(AECAderg(1,1,2),b1(1,l+1),auxvec(1))
10208       s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
10209       s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
10210       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
10211 C Derivatives in gamma(l-1)
10212       call matvec2(AECAderg(1,1,1),b1(1,k+1),auxvec(1))
10213       s2=0.5d0*scalar2(b1(1,k),auxvec(1))
10214       call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
10215       vv(1)=pizda(1,1)+pizda(2,2)
10216       vv(2)=pizda(2,1)-pizda(1,2)
10217       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
10218       g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
10219 C Cartesian derivatives.
10220       do iii=1,2
10221         do kkk=1,5
10222           do lll=1,3
10223 #ifdef MOMENT
10224             if (iii.eq.1) then
10225               s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
10226             else
10227               s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
10228             endif
10229 #endif
10230             call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
10231      &        auxvec(1))
10232             s2=0.5d0*scalar2(b1(1,k),auxvec(1))
10233             call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,l+1),
10234      &        auxvec(1))
10235             s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
10236             call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),
10237      &        pizda(1,1))
10238             vv(1)=pizda(1,1)+pizda(2,2)
10239             vv(2)=pizda(2,1)-pizda(1,2)
10240             s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
10241 #ifdef MOMENT
10242             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
10243 #else
10244             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
10245 #endif
10246             if (swap) then
10247               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
10248             else
10249               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
10250             endif
10251 c            derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
10252           enddo
10253         enddo
10254       enddo
10255       return
10256       end
10257 c----------------------------------------------------------------------------
10258       double precision function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
10259       implicit real*8 (a-h,o-z)
10260       include 'DIMENSIONS'
10261       include 'COMMON.IOUNITS'
10262       include 'COMMON.CHAIN'
10263       include 'COMMON.DERIV'
10264       include 'COMMON.INTERACT'
10265       include 'COMMON.CONTACTS'
10266       include 'COMMON.TORSION'
10267       include 'COMMON.VAR'
10268       include 'COMMON.GEO'
10269       include 'COMMON.FFIELD'
10270       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
10271      & auxvec1(2),auxmat1(2,2)
10272       logical swap
10273 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10274 C                                                                              C
10275 C      Parallel       Antiparallel                                             C
10276 C                                                                              C
10277 C          o             o                                                     C
10278 C         /l\   /   \   /j\                                                    C
10279 C        /   \ /     \ /   \                                                   C
10280 C       /| o |o       o| o |\                                                  C
10281 C     \ j|/k\|      \  |/k\|l                                                  C
10282 C      \ /   \       \ /   \                                                   C
10283 C       o     \       o     \                                                  C
10284 C       i             i                                                        C
10285 C                                                                              C
10286 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10287 C
10288 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
10289 C           energy moment and not to the cluster cumulant.
10290 cd      write (2,*) 'eello_graph4: wturn6',wturn6
10291       iti=itortyp(itype(i))
10292       itj=itortyp(itype(j))
10293       if (j.lt.nres-1) then
10294         itj1=itortyp(itype(j+1))
10295       else
10296         itj1=ntortyp
10297       endif
10298       itk=itortyp(itype(k))
10299       if (k.lt.nres-1) then
10300         itk1=itortyp(itype(k+1))
10301       else
10302         itk1=ntortyp
10303       endif
10304       itl=itortyp(itype(l))
10305       if (l.lt.nres-1) then
10306         itl1=itortyp(itype(l+1))
10307       else
10308         itl1=ntortyp
10309       endif
10310 cd      write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
10311 cd      write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
10312 cd     & ' itl',itl,' itl1',itl1
10313 #ifdef MOMENT
10314       if (imat.eq.1) then
10315         s1=dip(3,jj,i)*dip(3,kk,k)
10316       else
10317         s1=dip(2,jj,j)*dip(2,kk,l)
10318       endif
10319 #endif
10320       call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
10321       s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
10322       if (j.eq.l+1) then
10323         call matvec2(ADtEA1(1,1,3-imat),b1(1,j+1),auxvec1(1))
10324         s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
10325       else
10326         call matvec2(ADtEA1(1,1,3-imat),b1(1,l+1),auxvec1(1))
10327         s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
10328       endif
10329       call transpose2(EUg(1,1,k),auxmat(1,1))
10330       call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
10331       vv(1)=pizda(1,1)-pizda(2,2)
10332       vv(2)=pizda(2,1)+pizda(1,2)
10333       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
10334 cd      write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
10335 #ifdef MOMENT
10336       eello6_graph4=-(s1+s2+s3+s4)
10337 #else
10338       eello6_graph4=-(s2+s3+s4)
10339 #endif
10340 C Derivatives in gamma(i-1)
10341       if (i.gt.1) then
10342 #ifdef MOMENT
10343         if (imat.eq.1) then
10344           s1=dipderg(2,jj,i)*dip(3,kk,k)
10345         else
10346           s1=dipderg(4,jj,j)*dip(2,kk,l)
10347         endif
10348 #endif
10349         s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
10350         if (j.eq.l+1) then
10351           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,j+1),auxvec1(1))
10352           s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
10353         else
10354           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,l+1),auxvec1(1))
10355           s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
10356         endif
10357         s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
10358         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
10359 cd          write (2,*) 'turn6 derivatives'
10360 #ifdef MOMENT
10361           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
10362 #else
10363           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
10364 #endif
10365         else
10366 #ifdef MOMENT
10367           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
10368 #else
10369           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
10370 #endif
10371         endif
10372       endif
10373 C Derivatives in gamma(k-1)
10374 #ifdef MOMENT
10375       if (imat.eq.1) then
10376         s1=dip(3,jj,i)*dipderg(2,kk,k)
10377       else
10378         s1=dip(2,jj,j)*dipderg(4,kk,l)
10379       endif
10380 #endif
10381       call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
10382       s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
10383       if (j.eq.l+1) then
10384         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,j+1),auxvec1(1))
10385         s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
10386       else
10387         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,l+1),auxvec1(1))
10388         s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
10389       endif
10390       call transpose2(EUgder(1,1,k),auxmat1(1,1))
10391       call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
10392       vv(1)=pizda(1,1)-pizda(2,2)
10393       vv(2)=pizda(2,1)+pizda(1,2)
10394       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
10395       if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
10396 #ifdef MOMENT
10397         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
10398 #else
10399         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
10400 #endif
10401       else
10402 #ifdef MOMENT
10403         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
10404 #else
10405         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
10406 #endif
10407       endif
10408 C Derivatives in gamma(j-1) or gamma(l-1)
10409       if (l.eq.j+1 .and. l.gt.1) then
10410         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
10411         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
10412         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
10413         vv(1)=pizda(1,1)-pizda(2,2)
10414         vv(2)=pizda(2,1)+pizda(1,2)
10415         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
10416         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
10417       else if (j.gt.1) then
10418         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
10419         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
10420         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
10421         vv(1)=pizda(1,1)-pizda(2,2)
10422         vv(2)=pizda(2,1)+pizda(1,2)
10423         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
10424         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
10425           gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
10426         else
10427           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
10428         endif
10429       endif
10430 C Cartesian derivatives.
10431       do iii=1,2
10432         do kkk=1,5
10433           do lll=1,3
10434 #ifdef MOMENT
10435             if (iii.eq.1) then
10436               if (imat.eq.1) then
10437                 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
10438               else
10439                 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
10440               endif
10441             else
10442               if (imat.eq.1) then
10443                 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
10444               else
10445                 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
10446               endif
10447             endif
10448 #endif
10449             call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),
10450      &        auxvec(1))
10451             s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
10452             if (j.eq.l+1) then
10453               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
10454      &          b1(1,j+1),auxvec(1))
10455               s3=-0.5d0*scalar2(b1(1,j),auxvec(1))
10456             else
10457               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
10458      &          b1(1,l+1),auxvec(1))
10459               s3=-0.5d0*scalar2(b1(1,l),auxvec(1))
10460             endif
10461             call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
10462      &        pizda(1,1))
10463             vv(1)=pizda(1,1)-pizda(2,2)
10464             vv(2)=pizda(2,1)+pizda(1,2)
10465             s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
10466             if (swap) then
10467               if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
10468 #ifdef MOMENT
10469                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
10470      &             -(s1+s2+s4)
10471 #else
10472                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
10473      &             -(s2+s4)
10474 #endif
10475                 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
10476               else
10477 #ifdef MOMENT
10478                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
10479 #else
10480                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
10481 #endif
10482                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
10483               endif
10484             else
10485 #ifdef MOMENT
10486               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
10487 #else
10488               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
10489 #endif
10490               if (l.eq.j+1) then
10491                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
10492               else
10493                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
10494               endif
10495             endif
10496           enddo
10497         enddo
10498       enddo
10499       return
10500       end
10501 c----------------------------------------------------------------------------
10502       double precision function eello_turn6(i,jj,kk)
10503       implicit real*8 (a-h,o-z)
10504       include 'DIMENSIONS'
10505       include 'COMMON.IOUNITS'
10506       include 'COMMON.CHAIN'
10507       include 'COMMON.DERIV'
10508       include 'COMMON.INTERACT'
10509       include 'COMMON.CONTACTS'
10510       include 'COMMON.TORSION'
10511       include 'COMMON.VAR'
10512       include 'COMMON.GEO'
10513       double precision vtemp1(2),vtemp2(2),vtemp3(2),vtemp4(2),
10514      &  atemp(2,2),auxmat(2,2),achuj_temp(2,2),gtemp(2,2),gvec(2),
10515      &  ggg1(3),ggg2(3)
10516       double precision vtemp1d(2),vtemp2d(2),vtemp3d(2),vtemp4d(2),
10517      &  atempd(2,2),auxmatd(2,2),achuj_tempd(2,2),gtempd(2,2),gvecd(2)
10518 C 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
10519 C           the respective energy moment and not to the cluster cumulant.
10520       s1=0.0d0
10521       s8=0.0d0
10522       s13=0.0d0
10523 c
10524       eello_turn6=0.0d0
10525       j=i+4
10526       k=i+1
10527       l=i+3
10528       iti=itortyp(itype(i))
10529       itk=itortyp(itype(k))
10530       itk1=itortyp(itype(k+1))
10531       itl=itortyp(itype(l))
10532       itj=itortyp(itype(j))
10533 cd      write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
10534 cd      write (2,*) 'i',i,' k',k,' j',j,' l',l
10535 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
10536 cd        eello6=0.0d0
10537 cd        return
10538 cd      endif
10539 cd      write (iout,*)
10540 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
10541 cd     &   ' and',k,l
10542 cd      call checkint_turn6(i,jj,kk,eel_turn6_num)
10543       do iii=1,2
10544         do kkk=1,5
10545           do lll=1,3
10546             derx_turn(lll,kkk,iii)=0.0d0
10547           enddo
10548         enddo
10549       enddo
10550 cd      eij=1.0d0
10551 cd      ekl=1.0d0
10552 cd      ekont=1.0d0
10553       eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
10554 cd      eello6_5=0.0d0
10555 cd      write (2,*) 'eello6_5',eello6_5
10556 #ifdef MOMENT
10557       call transpose2(AEA(1,1,1),auxmat(1,1))
10558       call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
10559       ss1=scalar2(Ub2(1,i+2),b1(1,l))
10560       s1 = (auxmat(1,1)+auxmat(2,2))*ss1
10561 #endif
10562       call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1(1))
10563       call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
10564       s2 = scalar2(b1(1,k),vtemp1(1))
10565 #ifdef MOMENT
10566       call transpose2(AEA(1,1,2),atemp(1,1))
10567       call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
10568       call matvec2(Ug2(1,1,i+2),dd(1,1,itk1),vtemp2(1))
10569       s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
10570 #endif
10571       call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
10572       call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
10573       s12 = scalar2(Ub2(1,i+2),vtemp3(1))
10574 #ifdef MOMENT
10575       call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
10576       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
10577       call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
10578       call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
10579       ss13 = scalar2(b1(1,k),vtemp4(1))
10580       s13 = (gtemp(1,1)+gtemp(2,2))*ss13
10581 #endif
10582 c      write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
10583 c      s1=0.0d0
10584 c      s2=0.0d0
10585 c      s8=0.0d0
10586 c      s12=0.0d0
10587 c      s13=0.0d0
10588       eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
10589 C Derivatives in gamma(i+2)
10590       s1d =0.0d0
10591       s8d =0.0d0
10592 #ifdef MOMENT
10593       call transpose2(AEA(1,1,1),auxmatd(1,1))
10594       call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
10595       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
10596       call transpose2(AEAderg(1,1,2),atempd(1,1))
10597       call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
10598       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
10599 #endif
10600       call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
10601       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
10602       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
10603 c      s1d=0.0d0
10604 c      s2d=0.0d0
10605 c      s8d=0.0d0
10606 c      s12d=0.0d0
10607 c      s13d=0.0d0
10608       gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
10609 C Derivatives in gamma(i+3)
10610 #ifdef MOMENT
10611       call transpose2(AEA(1,1,1),auxmatd(1,1))
10612       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
10613       ss1d=scalar2(Ub2der(1,i+2),b1(1,l))
10614       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
10615 #endif
10616       call matvec2(EUgder(1,1,i+2),b1(1,l),vtemp1d(1))
10617       call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
10618       s2d = scalar2(b1(1,k),vtemp1d(1))
10619 #ifdef MOMENT
10620       call matvec2(Ug2der(1,1,i+2),dd(1,1,itk1),vtemp2d(1))
10621       s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2d(1))
10622 #endif
10623       s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
10624 #ifdef MOMENT
10625       call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
10626       call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
10627       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
10628 #endif
10629 c      s1d=0.0d0
10630 c      s2d=0.0d0
10631 c      s8d=0.0d0
10632 c      s12d=0.0d0
10633 c      s13d=0.0d0
10634 #ifdef MOMENT
10635       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
10636      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
10637 #else
10638       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
10639      &               -0.5d0*ekont*(s2d+s12d)
10640 #endif
10641 C Derivatives in gamma(i+4)
10642       call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
10643       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
10644       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
10645 #ifdef MOMENT
10646       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
10647       call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
10648       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
10649 #endif
10650 c      s1d=0.0d0
10651 c      s2d=0.0d0
10652 c      s8d=0.0d0
10653 C      s12d=0.0d0
10654 c      s13d=0.0d0
10655 #ifdef MOMENT
10656       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
10657 #else
10658       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
10659 #endif
10660 C Derivatives in gamma(i+5)
10661 #ifdef MOMENT
10662       call transpose2(AEAderg(1,1,1),auxmatd(1,1))
10663       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
10664       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
10665 #endif
10666       call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1d(1))
10667       call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
10668       s2d = scalar2(b1(1,k),vtemp1d(1))
10669 #ifdef MOMENT
10670       call transpose2(AEA(1,1,2),atempd(1,1))
10671       call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
10672       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
10673 #endif
10674       call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
10675       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
10676 #ifdef MOMENT
10677       call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
10678       ss13d = scalar2(b1(1,k),vtemp4d(1))
10679       s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
10680 #endif
10681 c      s1d=0.0d0
10682 c      s2d=0.0d0
10683 c      s8d=0.0d0
10684 c      s12d=0.0d0
10685 c      s13d=0.0d0
10686 #ifdef MOMENT
10687       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
10688      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
10689 #else
10690       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
10691      &               -0.5d0*ekont*(s2d+s12d)
10692 #endif
10693 C Cartesian derivatives
10694       do iii=1,2
10695         do kkk=1,5
10696           do lll=1,3
10697 #ifdef MOMENT
10698             call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
10699             call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
10700             s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
10701 #endif
10702             call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1(1))
10703             call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),
10704      &          vtemp1d(1))
10705             s2d = scalar2(b1(1,k),vtemp1d(1))
10706 #ifdef MOMENT
10707             call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
10708             call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
10709             s8d = -(atempd(1,1)+atempd(2,2))*
10710      &           scalar2(cc(1,1,itl),vtemp2(1))
10711 #endif
10712             call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),
10713      &           auxmatd(1,1))
10714             call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
10715             s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
10716 c      s1d=0.0d0
10717 c      s2d=0.0d0
10718 c      s8d=0.0d0
10719 c      s12d=0.0d0
10720 c      s13d=0.0d0
10721 #ifdef MOMENT
10722             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
10723      &        - 0.5d0*(s1d+s2d)
10724 #else
10725             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
10726      &        - 0.5d0*s2d
10727 #endif
10728 #ifdef MOMENT
10729             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
10730      &        - 0.5d0*(s8d+s12d)
10731 #else
10732             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
10733      &        - 0.5d0*s12d
10734 #endif
10735           enddo
10736         enddo
10737       enddo
10738 #ifdef MOMENT
10739       do kkk=1,5
10740         do lll=1,3
10741           call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),
10742      &      achuj_tempd(1,1))
10743           call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
10744           call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
10745           s13d=(gtempd(1,1)+gtempd(2,2))*ss13
10746           derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
10747           call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),
10748      &      vtemp4d(1))
10749           ss13d = scalar2(b1(1,k),vtemp4d(1))
10750           s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
10751           derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
10752         enddo
10753       enddo
10754 #endif
10755 cd      write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
10756 cd     &  16*eel_turn6_num
10757 cd      goto 1112
10758       if (j.lt.nres-1) then
10759         j1=j+1
10760         j2=j-1
10761       else
10762         j1=j-1
10763         j2=j-2
10764       endif
10765       if (l.lt.nres-1) then
10766         l1=l+1
10767         l2=l-1
10768       else
10769         l1=l-1
10770         l2=l-2
10771       endif
10772       do ll=1,3
10773 cgrad        ggg1(ll)=eel_turn6*g_contij(ll,1)
10774 cgrad        ggg2(ll)=eel_turn6*g_contij(ll,2)
10775 cgrad        ghalf=0.5d0*ggg1(ll)
10776 cd        ghalf=0.0d0
10777         gturn6ij=eel_turn6*g_contij(ll,1)+ekont*derx_turn(ll,1,1)
10778         gturn6kl=eel_turn6*g_contij(ll,2)+ekont*derx_turn(ll,1,2)
10779         gcorr6_turn(ll,i)=gcorr6_turn(ll,i)!+ghalf
10780      &    +ekont*derx_turn(ll,2,1)
10781         gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
10782         gcorr6_turn(ll,j)=gcorr6_turn(ll,j)!+ghalf
10783      &    +ekont*derx_turn(ll,4,1)
10784         gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
10785         gcorr6_turn_long(ll,j)=gcorr6_turn_long(ll,j)+gturn6ij
10786         gcorr6_turn_long(ll,i)=gcorr6_turn_long(ll,i)-gturn6ij
10787 cgrad        ghalf=0.5d0*ggg2(ll)
10788 cd        ghalf=0.0d0
10789         gcorr6_turn(ll,k)=gcorr6_turn(ll,k)!+ghalf
10790      &    +ekont*derx_turn(ll,2,2)
10791         gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
10792         gcorr6_turn(ll,l)=gcorr6_turn(ll,l)!+ghalf
10793      &    +ekont*derx_turn(ll,4,2)
10794         gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
10795         gcorr6_turn_long(ll,l)=gcorr6_turn_long(ll,l)+gturn6kl
10796         gcorr6_turn_long(ll,k)=gcorr6_turn_long(ll,k)-gturn6kl
10797       enddo
10798 cd      goto 1112
10799 cgrad      do m=i+1,j-1
10800 cgrad        do ll=1,3
10801 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
10802 cgrad        enddo
10803 cgrad      enddo
10804 cgrad      do m=k+1,l-1
10805 cgrad        do ll=1,3
10806 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
10807 cgrad        enddo
10808 cgrad      enddo
10809 cgrad1112  continue
10810 cgrad      do m=i+2,j2
10811 cgrad        do ll=1,3
10812 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
10813 cgrad        enddo
10814 cgrad      enddo
10815 cgrad      do m=k+2,l2
10816 cgrad        do ll=1,3
10817 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
10818 cgrad        enddo
10819 cgrad      enddo
10820 cd      do iii=1,nres-3
10821 cd        write (2,*) iii,g_corr6_loc(iii)
10822 cd      enddo
10823       eello_turn6=ekont*eel_turn6
10824 cd      write (2,*) 'ekont',ekont
10825 cd      write (2,*) 'eel_turn6',ekont*eel_turn6
10826       return
10827       end
10828
10829 C-----------------------------------------------------------------------------
10830       double precision function scalar(u,v)
10831 !DIR$ INLINEALWAYS scalar
10832 #ifndef OSF
10833 cDEC$ ATTRIBUTES FORCEINLINE::scalar
10834 #endif
10835       implicit none
10836       double precision u(3),v(3)
10837 cd      double precision sc
10838 cd      integer i
10839 cd      sc=0.0d0
10840 cd      do i=1,3
10841 cd        sc=sc+u(i)*v(i)
10842 cd      enddo
10843 cd      scalar=sc
10844
10845       scalar=u(1)*v(1)+u(2)*v(2)+u(3)*v(3)
10846       return
10847       end
10848 crc-------------------------------------------------
10849       SUBROUTINE MATVEC2(A1,V1,V2)
10850 !DIR$ INLINEALWAYS MATVEC2
10851 #ifndef OSF
10852 cDEC$ ATTRIBUTES FORCEINLINE::MATVEC2
10853 #endif
10854       implicit real*8 (a-h,o-z)
10855       include 'DIMENSIONS'
10856       DIMENSION A1(2,2),V1(2),V2(2)
10857 c      DO 1 I=1,2
10858 c        VI=0.0
10859 c        DO 3 K=1,2
10860 c    3     VI=VI+A1(I,K)*V1(K)
10861 c        Vaux(I)=VI
10862 c    1 CONTINUE
10863
10864       vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
10865       vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
10866
10867       v2(1)=vaux1
10868       v2(2)=vaux2
10869       END
10870 C---------------------------------------
10871       SUBROUTINE MATMAT2(A1,A2,A3)
10872 #ifndef OSF
10873 cDEC$ ATTRIBUTES FORCEINLINE::MATMAT2
10874 #endif
10875       implicit real*8 (a-h,o-z)
10876       include 'DIMENSIONS'
10877       DIMENSION A1(2,2),A2(2,2),A3(2,2)
10878 c      DIMENSION AI3(2,2)
10879 c        DO  J=1,2
10880 c          A3IJ=0.0
10881 c          DO K=1,2
10882 c           A3IJ=A3IJ+A1(I,K)*A2(K,J)
10883 c          enddo
10884 c          A3(I,J)=A3IJ
10885 c       enddo
10886 c      enddo
10887
10888       ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
10889       ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
10890       ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
10891       ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
10892
10893       A3(1,1)=AI3_11
10894       A3(2,1)=AI3_21
10895       A3(1,2)=AI3_12
10896       A3(2,2)=AI3_22
10897       END
10898
10899 c-------------------------------------------------------------------------
10900       double precision function scalar2(u,v)
10901 !DIR$ INLINEALWAYS scalar2
10902       implicit none
10903       double precision u(2),v(2)
10904       double precision sc
10905       integer i
10906       scalar2=u(1)*v(1)+u(2)*v(2)
10907       return
10908       end
10909
10910 C-----------------------------------------------------------------------------
10911
10912       subroutine transpose2(a,at)
10913 !DIR$ INLINEALWAYS transpose2
10914 #ifndef OSF
10915 cDEC$ ATTRIBUTES FORCEINLINE::transpose2
10916 #endif
10917       implicit none
10918       double precision a(2,2),at(2,2)
10919       at(1,1)=a(1,1)
10920       at(1,2)=a(2,1)
10921       at(2,1)=a(1,2)
10922       at(2,2)=a(2,2)
10923       return
10924       end
10925 c--------------------------------------------------------------------------
10926       subroutine transpose(n,a,at)
10927       implicit none
10928       integer n,i,j
10929       double precision a(n,n),at(n,n)
10930       do i=1,n
10931         do j=1,n
10932           at(j,i)=a(i,j)
10933         enddo
10934       enddo
10935       return
10936       end
10937 C---------------------------------------------------------------------------
10938       subroutine prodmat3(a1,a2,kk,transp,prod)
10939 !DIR$ INLINEALWAYS prodmat3
10940 #ifndef OSF
10941 cDEC$ ATTRIBUTES FORCEINLINE::prodmat3
10942 #endif
10943       implicit none
10944       integer i,j
10945       double precision a1(2,2),a2(2,2),a2t(2,2),kk(2,2),prod(2,2)
10946       logical transp
10947 crc      double precision auxmat(2,2),prod_(2,2)
10948
10949       if (transp) then
10950 crc        call transpose2(kk(1,1),auxmat(1,1))
10951 crc        call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
10952 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
10953
10954            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1)
10955      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
10956            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2)
10957      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
10958            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1)
10959      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
10960            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2)
10961      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
10962
10963       else
10964 crc        call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
10965 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
10966
10967            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1)
10968      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
10969            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2)
10970      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
10971            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1)
10972      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
10973            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2)
10974      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
10975
10976       endif
10977 c      call transpose2(a2(1,1),a2t(1,1))
10978
10979 crc      print *,transp
10980 crc      print *,((prod_(i,j),i=1,2),j=1,2)
10981 crc      print *,((prod(i,j),i=1,2),j=1,2)
10982
10983       return
10984       end
10985 CCC----------------------------------------------
10986       subroutine Eliptransfer(eliptran)
10987       implicit real*8 (a-h,o-z)
10988       include 'DIMENSIONS'
10989       include 'COMMON.GEO'
10990       include 'COMMON.VAR'
10991       include 'COMMON.LOCAL'
10992       include 'COMMON.CHAIN'
10993       include 'COMMON.DERIV'
10994       include 'COMMON.NAMES'
10995       include 'COMMON.INTERACT'
10996       include 'COMMON.IOUNITS'
10997       include 'COMMON.CALC'
10998       include 'COMMON.CONTROL'
10999       include 'COMMON.SPLITELE'
11000       include 'COMMON.SBRIDGE'
11001 C this is done by Adasko
11002 C      print *,"wchodze"
11003 C structure of box:
11004 C      water
11005 C--bordliptop-- buffore starts
11006 C--bufliptop--- here true lipid starts
11007 C      lipid
11008 C--buflipbot--- lipid ends buffore starts
11009 C--bordlipbot--buffore ends
11010       eliptran=0.0
11011       do i=ilip_start,ilip_end
11012 C       do i=1,1
11013         if (itype(i).eq.ntyp1) cycle
11014
11015         positi=(mod(((c(3,i)+c(3,i+1))/2.0d0),boxzsize))
11016         if (positi.le.0) positi=positi+boxzsize
11017 C        print *,i
11018 C first for peptide groups
11019 c for each residue check if it is in lipid or lipid water border area
11020        if ((positi.gt.bordlipbot)
11021      &.and.(positi.lt.bordliptop)) then
11022 C the energy transfer exist
11023         if (positi.lt.buflipbot) then
11024 C what fraction I am in
11025          fracinbuf=1.0d0-
11026      &        ((positi-bordlipbot)/lipbufthick)
11027 C lipbufthick is thickenes of lipid buffore
11028          sslip=sscalelip(fracinbuf)
11029          ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
11030          eliptran=eliptran+sslip*pepliptran
11031          gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
11032          gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
11033 C         gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
11034
11035 C        print *,"doing sccale for lower part"
11036 C         print *,i,sslip,fracinbuf,ssgradlip
11037         elseif (positi.gt.bufliptop) then
11038          fracinbuf=1.0d0-((bordliptop-positi)/lipbufthick)
11039          sslip=sscalelip(fracinbuf)
11040          ssgradlip=sscagradlip(fracinbuf)/lipbufthick
11041          eliptran=eliptran+sslip*pepliptran
11042          gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
11043          gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
11044 C         gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
11045 C          print *, "doing sscalefor top part"
11046 C         print *,i,sslip,fracinbuf,ssgradlip
11047         else
11048          eliptran=eliptran+pepliptran
11049 C         print *,"I am in true lipid"
11050         endif
11051 C       else
11052 C       eliptran=elpitran+0.0 ! I am in water
11053        endif
11054        enddo
11055 C       print *, "nic nie bylo w lipidzie?"
11056 C now multiply all by the peptide group transfer factor
11057 C       eliptran=eliptran*pepliptran
11058 C now the same for side chains
11059 CV       do i=1,1
11060        do i=ilip_start,ilip_end
11061         if (itype(i).eq.ntyp1) cycle
11062         positi=(mod(c(3,i+nres),boxzsize))
11063         if (positi.le.0) positi=positi+boxzsize
11064 C       print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop
11065 c for each residue check if it is in lipid or lipid water border area
11066 C       respos=mod(c(3,i+nres),boxzsize)
11067 C       print *,positi,bordlipbot,buflipbot
11068        if ((positi.gt.bordlipbot)
11069      & .and.(positi.lt.bordliptop)) then
11070 C the energy transfer exist
11071         if (positi.lt.buflipbot) then
11072          fracinbuf=1.0d0-
11073      &     ((positi-bordlipbot)/lipbufthick)
11074 C lipbufthick is thickenes of lipid buffore
11075          sslip=sscalelip(fracinbuf)
11076          ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
11077          eliptran=eliptran+sslip*liptranene(itype(i))
11078          gliptranx(3,i)=gliptranx(3,i)
11079      &+ssgradlip*liptranene(itype(i))
11080          gliptranc(3,i-1)= gliptranc(3,i-1)
11081      &+ssgradlip*liptranene(itype(i))
11082 C         print *,"doing sccale for lower part"
11083         elseif (positi.gt.bufliptop) then
11084          fracinbuf=1.0d0-
11085      &((bordliptop-positi)/lipbufthick)
11086          sslip=sscalelip(fracinbuf)
11087          ssgradlip=sscagradlip(fracinbuf)/lipbufthick
11088          eliptran=eliptran+sslip*liptranene(itype(i))
11089          gliptranx(3,i)=gliptranx(3,i)
11090      &+ssgradlip*liptranene(itype(i))
11091          gliptranc(3,i-1)= gliptranc(3,i-1)
11092      &+ssgradlip*liptranene(itype(i))
11093 C          print *, "doing sscalefor top part",sslip,fracinbuf
11094         else
11095          eliptran=eliptran+liptranene(itype(i))
11096 C         print *,"I am in true lipid"
11097         endif
11098         endif ! if in lipid or buffor
11099 C       else
11100 C       eliptran=elpitran+0.0 ! I am in water
11101        enddo
11102        return
11103        end
11104 C---------------------------------------------------------
11105 C AFM soubroutine for constant force
11106        subroutine AFMforce(Eafmforce)
11107        implicit real*8 (a-h,o-z)
11108       include 'DIMENSIONS'
11109       include 'COMMON.GEO'
11110       include 'COMMON.VAR'
11111       include 'COMMON.LOCAL'
11112       include 'COMMON.CHAIN'
11113       include 'COMMON.DERIV'
11114       include 'COMMON.NAMES'
11115       include 'COMMON.INTERACT'
11116       include 'COMMON.IOUNITS'
11117       include 'COMMON.CALC'
11118       include 'COMMON.CONTROL'
11119       include 'COMMON.SPLITELE'
11120       include 'COMMON.SBRIDGE'
11121       real*8 diffafm(3)
11122       dist=0.0d0
11123       Eafmforce=0.0d0
11124       do i=1,3
11125       diffafm(i)=c(i,afmend)-c(i,afmbeg)
11126       dist=dist+diffafm(i)**2
11127       enddo
11128       dist=dsqrt(dist)
11129       Eafmforce=-forceAFMconst*(dist-distafminit)
11130       do i=1,3
11131       gradafm(i,afmend-1)=-forceAFMconst*diffafm(i)/dist
11132       gradafm(i,afmbeg-1)=forceAFMconst*diffafm(i)/dist
11133       enddo
11134 C      print *,'AFM',Eafmforce
11135       return
11136       end
11137 C---------------------------------------------------------
11138 C AFM subroutine with pseudoconstant velocity
11139        subroutine AFMvel(Eafmforce)
11140        implicit real*8 (a-h,o-z)
11141       include 'DIMENSIONS'
11142       include 'COMMON.GEO'
11143       include 'COMMON.VAR'
11144       include 'COMMON.LOCAL'
11145       include 'COMMON.CHAIN'
11146       include 'COMMON.DERIV'
11147       include 'COMMON.NAMES'
11148       include 'COMMON.INTERACT'
11149       include 'COMMON.IOUNITS'
11150       include 'COMMON.CALC'
11151       include 'COMMON.CONTROL'
11152       include 'COMMON.SPLITELE'
11153       include 'COMMON.SBRIDGE'
11154       real*8 diffafm(3)
11155 C Only for check grad COMMENT if not used for checkgrad
11156 C      totT=3.0d0
11157 C--------------------------------------------------------
11158 C      print *,"wchodze"
11159       dist=0.0d0
11160       Eafmforce=0.0d0
11161       do i=1,3
11162       diffafm(i)=c(i,afmend)-c(i,afmbeg)
11163       dist=dist+diffafm(i)**2
11164       enddo
11165       dist=dsqrt(dist)
11166       Eafmforce=0.5d0*forceAFMconst
11167      & *(distafminit+totTafm*velAFMconst-dist)**2
11168 C      Eafmforce=-forceAFMconst*(dist-distafminit)
11169       do i=1,3
11170       gradafm(i,afmend-1)=-forceAFMconst*
11171      &(distafminit+totTafm*velAFMconst-dist)
11172      &*diffafm(i)/dist
11173       gradafm(i,afmbeg-1)=forceAFMconst*
11174      &(distafminit+totTafm*velAFMconst-dist)
11175      &*diffafm(i)/dist
11176       enddo
11177 C      print *,'AFM',Eafmforce,totTafm*velAFMconst,dist
11178       return
11179       end
11180
11181 c----------------------------------------------------------------------------
11182       double precision function sscale2(r,r_cut,r0,rlamb)
11183       implicit none
11184       double precision r,gamm,r_cut,r0,rlamb,rr
11185       rr = dabs(r-r0)
11186 c      write (2,*) "r",r," r_cut",r_cut," r0",r0," rlamb",rlamb
11187 c      write (2,*) "rr",rr
11188       if(rr.lt.r_cut-rlamb) then
11189         sscale2=1.0d0
11190       else if(rr.le.r_cut.and.rr.ge.r_cut-rlamb) then
11191         gamm=(rr-(r_cut-rlamb))/rlamb
11192         sscale2=1.0d0+gamm*gamm*(2*gamm-3.0d0)
11193         else
11194         sscale2=0d0
11195       endif
11196         return
11197         end
11198 C-----------------------------------------------------------------------
11199       double precision function sscalgrad2(r,r_cut,r0,rlamb)
11200       implicit none
11201       double precision r,gamm,r_cut,r0,rlamb,rr
11202       rr = dabs(r-r0)
11203       if(rr.lt.r_cut-rlamb) then
11204         sscalgrad2=0.0d0
11205       else if(rr.le.r_cut.and.rr.ge.r_cut-rlamb) then
11206         gamm=(rr-(r_cut-rlamb))/rlamb
11207         if (r.ge.r0) then
11208           sscalgrad2=gamm*(6*gamm-6.0d0)/rlamb
11209         else
11210           sscalgrad2=-gamm*(6*gamm-6.0d0)/rlamb
11211         endif
11212         else
11213         sscalgrad2=0.0d0
11214       endif
11215         return
11216         end
11217 c----------------------------------------------------------------------------
11218       subroutine e_saxs(Esaxs_constr)
11219       implicit none
11220       include 'DIMENSIONS'
11221 #ifdef MPI
11222       include "mpif.h"
11223       include "COMMON.SETUP"
11224       integer IERR
11225 #endif
11226       include 'COMMON.SBRIDGE'
11227       include 'COMMON.CHAIN'
11228       include 'COMMON.GEO'
11229       include 'COMMON.DERIV'
11230       include 'COMMON.LOCAL'
11231       include 'COMMON.INTERACT'
11232       include 'COMMON.VAR'
11233       include 'COMMON.IOUNITS'
11234       include 'COMMON.MD'
11235       include 'COMMON.CONTROL'
11236       include 'COMMON.NAMES'
11237       include 'COMMON.TIME1'
11238       include 'COMMON.FFIELD'
11239 c
11240       double precision Esaxs_constr
11241       integer i,iint,j,k,l
11242       double precision PgradC(maxSAXS,3,maxres),
11243      &  PgradX(maxSAXS,3,maxres),Pcalc(maxSAXS)
11244 #ifdef MPI
11245       double precision PgradC_(maxSAXS,3,maxres),
11246      &  PgradX_(maxSAXS,3,maxres),Pcalc_(maxSAXS)
11247 #endif
11248       double precision dk,dijCACA,dijCASC,dijSCCA,dijSCSC,
11249      & sigma2CACA,sigma2CASC,sigma2SCCA,sigma2SCSC,expCACA,expCASC,
11250      & expSCCA,expSCSC,CASCgrad,SCCAgrad,SCSCgrad,aux,auxC,auxC1,
11251      & auxX,auxX1,CACAgrad,Cnorm
11252       double precision sss2,ssgrad2,rrr,sscalgrad2,sscale2
11253       double precision dist
11254       external dist
11255 c  SAXS restraint penalty function
11256 #ifdef DEBUG
11257       write(iout,*) "------- SAXS penalty function start -------"
11258       write (iout,*) "nsaxs",nsaxs
11259       write (iout,*) "Esaxs: iatsc_s",iatsc_s," iatsc_e",iatsc_e
11260       write (iout,*) "Psaxs"
11261       do i=1,nsaxs
11262         write (iout,'(i5,e15.5)') i, Psaxs(i)
11263       enddo
11264 #endif
11265       Esaxs_constr = 0.0d0
11266       do k=1,nsaxs
11267         Pcalc(k)=0.0d0
11268         do j=1,nres
11269           do l=1,3
11270             PgradC(k,l,j)=0.0d0
11271             PgradX(k,l,j)=0.0d0
11272           enddo
11273         enddo
11274       enddo
11275       do i=iatsc_s,iatsc_e
11276        if (itype(i).eq.ntyp1) cycle
11277        do iint=1,nint_gr(i)
11278          do j=istart(i,iint),iend(i,iint)
11279            if (itype(j).eq.ntyp1) cycle
11280 #ifdef ALLSAXS
11281            dijCACA=dist(i,j)
11282            dijCASC=dist(i,j+nres)
11283            dijSCCA=dist(i+nres,j)
11284            dijSCSC=dist(i+nres,j+nres)
11285            sigma2CACA=2.0d0/(pstok**2)
11286            sigma2CASC=4.0d0/(pstok**2+restok(itype(j))**2)
11287            sigma2SCCA=4.0d0/(pstok**2+restok(itype(i))**2)
11288            sigma2SCSC=4.0d0/(restok(itype(j))**2+restok(itype(i))**2)
11289            do k=1,nsaxs
11290              dk = distsaxs(k)
11291              expCACA = dexp(-0.5d0*sigma2CACA*(dijCACA-dk)**2)
11292              if (itype(j).ne.10) then
11293              expCASC = dexp(-0.5d0*sigma2CASC*(dijCASC-dk)**2)
11294              else
11295              endif
11296              expCASC = 0.0d0
11297              if (itype(i).ne.10) then
11298              expSCCA = dexp(-0.5d0*sigma2SCCA*(dijSCCA-dk)**2)
11299              else
11300              expSCCA = 0.0d0
11301              endif
11302              if (itype(i).ne.10 .and. itype(j).ne.10) then
11303              expSCSC = dexp(-0.5d0*sigma2SCSC*(dijSCSC-dk)**2)
11304              else
11305              expSCSC = 0.0d0
11306              endif
11307              Pcalc(k) = Pcalc(k)+expCACA+expCASC+expSCCA+expSCSC
11308 #ifdef DEBUG
11309              write(iout,*) "i j k Pcalc",i,j,Pcalc(k)
11310 #endif
11311              CACAgrad = sigma2CACA*(dijCACA-dk)*expCACA
11312              CASCgrad = sigma2CASC*(dijCASC-dk)*expCASC
11313              SCCAgrad = sigma2SCCA*(dijSCCA-dk)*expSCCA
11314              SCSCgrad = sigma2SCSC*(dijSCSC-dk)*expSCSC
11315              do l=1,3
11316 c CA CA
11317                aux = CACAgrad*(C(l,j)-C(l,i))/dijCACA
11318                PgradC(k,l,i) = PgradC(k,l,i)-aux
11319                PgradC(k,l,j) = PgradC(k,l,j)+aux
11320 c CA SC
11321                if (itype(j).ne.10) then
11322                aux = CASCgrad*(C(l,j+nres)-C(l,i))/dijCASC
11323                PgradC(k,l,i) = PgradC(k,l,i)-aux
11324                PgradC(k,l,j) = PgradC(k,l,j)+aux
11325                PgradX(k,l,j) = PgradX(k,l,j)+aux
11326                endif
11327 c SC CA
11328                if (itype(i).ne.10) then
11329                aux = SCCAgrad*(C(l,j)-C(l,i+nres))/dijSCCA
11330                PgradX(k,l,i) = PgradX(k,l,i)-aux
11331                PgradC(k,l,i) = PgradC(k,l,i)-aux
11332                PgradC(k,l,j) = PgradC(k,l,j)+aux
11333                endif
11334 c SC SC
11335                if (itype(i).ne.10 .and. itype(j).ne.10) then
11336                aux = SCSCgrad*(C(l,j+nres)-C(l,i+nres))/dijSCSC
11337                PgradC(k,l,i) = PgradC(k,l,i)-aux
11338                PgradC(k,l,j) = PgradC(k,l,j)+aux
11339                PgradX(k,l,i) = PgradX(k,l,i)-aux
11340                PgradX(k,l,j) = PgradX(k,l,j)+aux
11341                endif
11342              enddo ! l
11343            enddo ! k
11344 #else
11345            dijCACA=dist(i,j)
11346            sigma2CACA=scal_rad**2*0.25d0/
11347      &        (restok(itype(j))**2+restok(itype(i))**2)
11348
11349            IF (saxs_cutoff.eq.0) THEN
11350            do k=1,nsaxs
11351              dk = distsaxs(k)
11352              expCACA = dexp(-0.5d0*sigma2CACA*(dijCACA-dk)**2)
11353              Pcalc(k) = Pcalc(k)+expCACA
11354              CACAgrad = sigma2CACA*(dijCACA-dk)*expCACA
11355              do l=1,3
11356                aux = CACAgrad*(C(l,j)-C(l,i))/dijCACA
11357                PgradC(k,l,i) = PgradC(k,l,i)-aux
11358                PgradC(k,l,j) = PgradC(k,l,j)+aux
11359              enddo ! l
11360            enddo ! k
11361            ELSE
11362            rrr = saxs_cutoff*2.0d0/dsqrt(sigma2CACA)
11363            do k=1,nsaxs
11364              dk = distsaxs(k)
11365 c             write (2,*) "ijk",i,j,k
11366              sss2 = sscale2(dijCACA,rrr,dk,0.3d0)
11367              if (sss2.eq.0.0d0) cycle
11368              ssgrad2 = sscalgrad2(dijCACA,rrr,dk,0.3d0)
11369              if (energy_dec) write(iout,'(a4,3i5,5f10.4)')
11370      &          'saxs',i,j,k,dijCACA,rrr,dk,sss2,ssgrad2
11371              expCACA = dexp(-0.5d0*sigma2CACA*(dijCACA-dk)**2)*sss2
11372              Pcalc(k) = Pcalc(k)+expCACA
11373 #ifdef DEBUG
11374              write(iout,*) "i j k Pcalc",i,j,Pcalc(k)
11375 #endif
11376              CACAgrad = -sigma2CACA*(dijCACA-dk)*expCACA+
11377      &             ssgrad2*expCACA/sss2
11378              do l=1,3
11379 c CA CA
11380                aux = CACAgrad*(C(l,j)-C(l,i))/dijCACA
11381                PgradC(k,l,i) = PgradC(k,l,i)+aux
11382                PgradC(k,l,j) = PgradC(k,l,j)-aux
11383              enddo ! l
11384            enddo ! k
11385            ENDIF
11386 #endif
11387          enddo ! j
11388        enddo ! iint
11389       enddo ! i
11390 #ifdef MPI
11391       if (nfgtasks.gt.1) then
11392        call MPI_AllReduce(Pcalc(1),Pcalc_(1),nsaxs,MPI_DOUBLE_PRECISION,
11393      &    MPI_SUM,FG_COMM,IERR)
11394 c        if (fg_rank.eq.king) then
11395           do k=1,nsaxs
11396             Pcalc(k) = Pcalc_(k)
11397           enddo
11398 c        endif
11399 c        call MPI_AllReduce(PgradC(k,1,1),PgradC_(k,1,1),3*maxsaxs*nres,
11400 c     &    MPI_DOUBLE_PRECISION,MPI_SUM,FG_COMM,IERR)
11401 c        if (fg_rank.eq.king) then
11402 c          do i=1,nres
11403 c            do l=1,3
11404 c              do k=1,nsaxs
11405 c                PgradC(k,l,i) = PgradC_(k,l,i)
11406 c              enddo
11407 c            enddo
11408 c          enddo
11409 c        endif
11410 #ifdef ALLSAXS
11411 c        call MPI_AllReduce(PgradX(k,1,1),PgradX_(k,1,1),3*maxsaxs*nres,
11412 c     &    MPI_DOUBLE_PRECISION,MPI_SUM,FG_COMM,IERR)
11413 c        if (fg_rank.eq.king) then
11414 c          do i=1,nres
11415 c            do l=1,3
11416 c              do k=1,nsaxs
11417 c                PgradX(k,l,i) = PgradX_(k,l,i)
11418 c              enddo
11419 c            enddo
11420 c          enddo
11421 c        endif
11422 #endif
11423       endif
11424 #endif
11425       Cnorm = 0.0d0
11426       do k=1,nsaxs
11427         Cnorm = Cnorm + Pcalc(k)
11428       enddo
11429 #ifdef MPI
11430       if (fg_rank.eq.king) then
11431 #endif
11432       Esaxs_constr = dlog(Cnorm)-wsaxs0
11433       do k=1,nsaxs
11434         if (Pcalc(k).gt.0.0d0)
11435      &  Esaxs_constr = Esaxs_constr - Psaxs(k)*dlog(Pcalc(k))
11436 #ifdef DEBUG
11437         write (iout,*) "k",k," Esaxs_constr",Esaxs_constr
11438 #endif
11439       enddo
11440 #ifdef DEBUG
11441       write (iout,*) "Cnorm",Cnorm," Esaxs_constr",Esaxs_constr
11442 #endif
11443 #ifdef MPI
11444       endif
11445 #endif
11446       gsaxsC=0.0d0
11447       gsaxsX=0.0d0
11448       do i=nnt,nct
11449         do l=1,3
11450           auxC=0.0d0
11451           auxC1=0.0d0
11452           auxX=0.0d0
11453           auxX1=0.d0
11454           do k=1,nsaxs
11455             if (Pcalc(k).gt.0)
11456      &      auxC  = auxC +Psaxs(k)*PgradC(k,l,i)/Pcalc(k)
11457             auxC1 = auxC1+PgradC(k,l,i)
11458 #ifdef ALLSAXS
11459             auxX  = auxX +Psaxs(k)*PgradX(k,l,i)/Pcalc(k)
11460             auxX1 = auxX1+PgradX(k,l,i)
11461 #endif
11462           enddo
11463           gsaxsC(l,i) = auxC - auxC1/Cnorm
11464 #ifdef ALLSAXS
11465           gsaxsX(l,i) = auxX - auxX1/Cnorm
11466 #endif
11467 c          write (iout,*) "l i",l,i," gradC",wsaxs*(auxC - auxC1/Cnorm),
11468 c     *     " gradX",wsaxs*(auxX - auxX1/Cnorm)
11469         enddo
11470       enddo
11471 #ifdef MPI
11472 c      endif
11473 #endif
11474       return
11475       end
11476 c----------------------------------------------------------------------------
11477       subroutine e_saxsC(Esaxs_constr)
11478       implicit none
11479       include 'DIMENSIONS'
11480 #ifdef MPI
11481       include "mpif.h"
11482       include "COMMON.SETUP"
11483       integer IERR
11484 #endif
11485       include 'COMMON.SBRIDGE'
11486       include 'COMMON.CHAIN'
11487       include 'COMMON.GEO'
11488       include 'COMMON.DERIV'
11489       include 'COMMON.LOCAL'
11490       include 'COMMON.INTERACT'
11491       include 'COMMON.VAR'
11492       include 'COMMON.IOUNITS'
11493       include 'COMMON.MD'
11494       include 'COMMON.CONTROL'
11495       include 'COMMON.NAMES'
11496       include 'COMMON.TIME1'
11497       include 'COMMON.FFIELD'
11498 c
11499       double precision Esaxs_constr
11500       integer i,iint,j,k,l
11501       double precision PgradC(3,maxres),PgradX(3,maxres),Pcalc,logPtot
11502 #ifdef MPI
11503       double precision gsaxsc_(3,maxres),gsaxsx_(3,maxres),logPtot_
11504 #endif
11505       double precision dk,dijCASPH,dijSCSPH,
11506      & sigma2CA,sigma2SC,expCASPH,expSCSPH,
11507      & CASPHgrad,SCSPHgrad,aux,auxC,auxC1,
11508      & auxX,auxX1,Cnorm
11509 c  SAXS restraint penalty function
11510 #ifdef DEBUG
11511       write(iout,*) "------- SAXS penalty function start -------"
11512       write (iout,*) "nsaxs",nsaxs
11513
11514       do i=nnt,nct
11515         print *,MyRank,"C",i,(C(j,i),j=1,3)
11516       enddo
11517       do i=nnt,nct
11518         print *,MyRank,"CSaxs",i,(Csaxs(j,i),j=1,3)
11519       enddo
11520 #endif
11521       Esaxs_constr = 0.0d0
11522       logPtot=0.0d0
11523       do j=isaxs_start,isaxs_end
11524         Pcalc=0.0d0
11525         do i=1,nres
11526           do l=1,3
11527             PgradC(l,i)=0.0d0
11528             PgradX(l,i)=0.0d0
11529           enddo
11530         enddo
11531         do i=nnt,nct
11532           if (itype(i).eq.ntyp1) cycle
11533           dijCASPH=0.0d0
11534           dijSCSPH=0.0d0
11535           do l=1,3
11536             dijCASPH=dijCASPH+(C(l,i)-Csaxs(l,j))**2
11537           enddo
11538           if (itype(i).ne.10) then
11539           do l=1,3
11540             dijSCSPH=dijSCSPH+(C(l,i+nres)-Csaxs(l,j))**2
11541           enddo
11542           endif
11543           sigma2CA=2.0d0/pstok**2
11544           sigma2SC=4.0d0/restok(itype(i))**2
11545           expCASPH = dexp(-0.5d0*sigma2CA*dijCASPH)
11546           expSCSPH = dexp(-0.5d0*sigma2SC*dijSCSPH)
11547           Pcalc = Pcalc+expCASPH+expSCSPH
11548 #ifdef DEBUG
11549           write(*,*) "processor i j Pcalc",
11550      &       MyRank,i,j,dijCASPH,dijSCSPH, Pcalc
11551 #endif
11552           CASPHgrad = sigma2CA*expCASPH
11553           SCSPHgrad = sigma2SC*expSCSPH
11554           do l=1,3
11555             aux = (C(l,i+nres)-Csaxs(l,j))*SCSPHgrad
11556             PgradX(l,i) = PgradX(l,i) + aux
11557             PgradC(l,i) = PgradC(l,i)+(C(l,i)-Csaxs(l,j))*CASPHgrad+aux
11558           enddo ! l
11559         enddo ! i
11560         do i=nnt,nct
11561           do l=1,3
11562             gsaxsc(l,i)=gsaxsc(l,i)+PgradC(l,i)/Pcalc
11563             gsaxsx(l,i)=gsaxsx(l,i)+PgradX(l,i)/Pcalc
11564           enddo
11565         enddo
11566         logPtot = logPtot - dlog(Pcalc)
11567 c        print *,"me",me,MyRank," j",j," logPcalc",-dlog(Pcalc),
11568 c     &    " logPtot",logPtot
11569       enddo ! j
11570 #ifdef MPI
11571       if (nfgtasks.gt.1) then
11572 c        write (iout,*) "logPtot before reduction",logPtot
11573         call MPI_Reduce(logPtot,logPtot_,1,MPI_DOUBLE_PRECISION,
11574      &    MPI_SUM,king,FG_COMM,IERR)
11575         logPtot = logPtot_
11576 c        write (iout,*) "logPtot after reduction",logPtot
11577         call MPI_Reduce(gsaxsC(1,1),gsaxsC_(1,1),3*nres,
11578      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
11579         if (fg_rank.eq.king) then
11580           do i=1,nres
11581             do l=1,3
11582               gsaxsC(l,i) = gsaxsC_(l,i)
11583             enddo
11584           enddo
11585         endif
11586         call MPI_Reduce(gsaxsX(1,1),gsaxsX_(1,1),3*nres,
11587      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
11588         if (fg_rank.eq.king) then
11589           do i=1,nres
11590             do l=1,3
11591               gsaxsX(l,i) = gsaxsX_(l,i)
11592             enddo
11593           enddo
11594         endif
11595       endif
11596 #endif
11597       Esaxs_constr = logPtot
11598       return
11599       end