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