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       else
 299         eliptran=0.0d0
 300       endif
 301 C      print *,"za lipidami"
 302       if (AFMlog.gt.0) then
 303         call AFMforce(Eafmforce)
 304       else if (selfguide.gt.0) then
 305         call AFMvel(Eafmforce)
 306       endif
 307 #ifdef TIMING
 308       time_enecalc=time_enecalc+MPI_Wtime()-time00
 309 #endif
 310 c      print *,"Processor",myrank," computed Uconstr"
 311 #ifdef TIMING
 312       time00=MPI_Wtime()
 313 #endif
 314 c
 315 C Sum the energies
 316 C
 317       energia(1)=evdw
 318 #ifdef SCP14
 319       energia(2)=evdw2-evdw2_14
 320       energia(18)=evdw2_14
 321 #else
 322       energia(2)=evdw2
 323       energia(18)=0.0d0
 324 #endif
 325 #ifdef SPLITELE
 326       energia(3)=ees
 327       energia(16)=evdw1
 328 #else
 329       energia(3)=ees+evdw1
 330       energia(16)=0.0d0
 331 #endif
 332       energia(4)=ecorr
 333       energia(5)=ecorr5
 334       energia(6)=ecorr6
 335       energia(7)=eel_loc
 336       energia(8)=eello_turn3
 337       energia(9)=eello_turn4
 338       energia(10)=eturn6
 339       energia(11)=ebe
 340       energia(12)=escloc
 341       energia(13)=etors
 342       energia(14)=etors_d
 343       energia(15)=ehpb
 344       energia(19)=edihcnstr
 345       energia(17)=estr
 346       energia(20)=Uconst+Uconst_back
 347       energia(21)=esccor
 348       energia(22)=eliptran
 349       energia(23)=Eafmforce
 350       energia(24)=ehomology_constr
 351       energia(25)=Esaxs_constr
 352 c    Here are the energies showed per procesor if the are more processors
 353 c    per molecule then we sum it up in sum_energy subroutine
 354 c      print *," Processor",myrank," calls SUM_ENERGY"
 355       call sum_energy(energia,.true.)
 356       if (dyn_ss) call dyn_set_nss
 357 c      print *," Processor",myrank," left SUM_ENERGY"
 358 #ifdef TIMING
 359       time_sumene=time_sumene+MPI_Wtime()-time00
 360 #endif
 361       return
 362       end
 363 c-------------------------------------------------------------------------------
 364       subroutine sum_energy(energia,reduce)
 365       implicit real*8 (a-h,o-z)
 366       include 'DIMENSIONS'
 367 #ifndef ISNAN
 368       external proc_proc
 369 #ifdef WINPGI
 370 cMS$ATTRIBUTES C ::  proc_proc
 371 #endif
 372 #endif
 373 #ifdef MPI
 374       include "mpif.h"
 375 #endif
 376       include 'COMMON.SETUP'
 377       include 'COMMON.IOUNITS'
 378       double precision energia(0:n_ene),enebuff(0:n_ene+1)
 379       include 'COMMON.FFIELD'
 380       include 'COMMON.DERIV'
 381       include 'COMMON.INTERACT'
 382       include 'COMMON.SBRIDGE'
 383       include 'COMMON.CHAIN'
 384       include 'COMMON.VAR'
 385       include 'COMMON.CONTROL'
 386       include 'COMMON.TIME1'
 387       logical reduce
 388 #ifdef MPI
 389       if (nfgtasks.gt.1 .and. reduce) then
 390 #ifdef DEBUG
 391         write (iout,*) "energies before REDUCE"
 392         call enerprint(energia)
 393         call flush(iout)
 394 #endif
 395         do i=0,n_ene
 396           enebuff(i)=energia(i)
 397         enddo
 398         time00=MPI_Wtime()
 399         call MPI_Barrier(FG_COMM,IERR)
 400         time_barrier_e=time_barrier_e+MPI_Wtime()-time00
 401         time00=MPI_Wtime()
 402         call MPI_Reduce(enebuff(0),energia(0),n_ene+1,
 403      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 404 #ifdef DEBUG
 405         write (iout,*) "energies after REDUCE"
 406         call enerprint(energia)
 407         call flush(iout)
 408 #endif
 409         time_Reduce=time_Reduce+MPI_Wtime()-time00
 410       endif
 411       if (fg_rank.eq.0) then
 412 #endif
 413       evdw=energia(1)
 414 #ifdef SCP14
 415       evdw2=energia(2)+energia(18)
 416       evdw2_14=energia(18)
 417 #else
 418       evdw2=energia(2)
 419 #endif
 420 #ifdef SPLITELE
 421       ees=energia(3)
 422       evdw1=energia(16)
 423 #else
 424       ees=energia(3)
 425       evdw1=0.0d0
 426 #endif
 427       ecorr=energia(4)
 428       ecorr5=energia(5)
 429       ecorr6=energia(6)
 430       eel_loc=energia(7)
 431       eello_turn3=energia(8)
 432       eello_turn4=energia(9)
 433       eturn6=energia(10)
 434       ebe=energia(11)
 435       escloc=energia(12)
 436       etors=energia(13)
 437       etors_d=energia(14)
 438       ehpb=energia(15)
 439       edihcnstr=energia(19)
 440       estr=energia(17)
 441       Uconst=energia(20)
 442       esccor=energia(21)
 443       eliptran=energia(22)
 444       Eafmforce=energia(23)
 445       ehomology_constr=energia(24)
 446       esaxs_constr=energia(25)
 447 c      write (iout,*) "sum_energy esaxs_constr",esaxs_constr,
 448 c     &  " wsaxs",wsaxs
 449 #ifdef SPLITELE
 450       etot=wsc*evdw+wscp*evdw2+welec*ees+wvdwpp*evdw1
 451      & +wang*ebe+wtor*etors+wscloc*escloc
 452      & +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5
 453      & +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3
 454      & +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d
 455      & +wbond*estr+Uconst+wsccor*esccor+ehomology_constr
 456      & +wsaxs*esaxs_constr+wliptran*eliptran+Eafmforce
 457 #else
 458       etot=wsc*evdw+wscp*evdw2+welec*(ees+evdw1)
 459      & +wang*ebe+wtor*etors+wscloc*escloc
 460      & +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5
 461      & +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3
 462      & +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d
 463      & +wbond*estr+Uconst+wsccor*esccor+ehomology_constr
 464      & +wsaxs*esaxs_constr+wliptran*eliptran
 465      & +Eafmforce
 466 #endif
 467       energia(0)=etot
 468 c detecting NaNQ
 469 #ifdef ISNAN
 470 #ifdef AIX
 471       if (isnan(etot).ne.0) energia(0)=1.0d+99
 472 #else
 473       if (isnan(etot)) energia(0)=1.0d+99
 474 #endif
 475 #else
 476       i=0
 477 #ifdef WINPGI
 478       idumm=proc_proc(etot,i)
 479 #else
 480       call proc_proc(etot,i)
 481 #endif
 482       if(i.eq.1)energia(0)=1.0d+99
 483 #endif
 484 #ifdef MPI
 485       endif
 486 #endif
 487       return
 488       end
 489 c-------------------------------------------------------------------------------
 490       subroutine sum_gradient
 491       implicit real*8 (a-h,o-z)
 492       include 'DIMENSIONS'
 493 #ifndef ISNAN
 494       external proc_proc
 495 #ifdef WINPGI
 496 cMS$ATTRIBUTES C ::  proc_proc
 497 #endif
 498 #endif
 499 #ifdef MPI
 500       include 'mpif.h'
 501 #endif
 502       double precision gradbufc(3,-1:maxres),gradbufx(3,-1:maxres),
 503      & glocbuf(4*maxres),gradbufc_sum(3,-1:maxres)
 504      & ,gloc_scbuf(3,-1:maxres)
 505       include 'COMMON.SETUP'
 506       include 'COMMON.IOUNITS'
 507       include 'COMMON.FFIELD'
 508       include 'COMMON.DERIV'
 509       include 'COMMON.INTERACT'
 510       include 'COMMON.SBRIDGE'
 511       include 'COMMON.CHAIN'
 512       include 'COMMON.VAR'
 513       include 'COMMON.CONTROL'
 514       include 'COMMON.TIME1'
 515       include 'COMMON.MAXGRAD'
 516       include 'COMMON.SCCOR'
 517       include 'COMMON.MD'
 518 #ifdef TIMING
 519       time01=MPI_Wtime()
 520 #endif
 521 #ifdef DEBUG
 522       write (iout,*) "sum_gradient gvdwc, gvdwx"
 523       do i=0,nres
 524         write (iout,'(i3,3e15.5,5x,3e15.5)')
 525      &   i,(gvdwx(j,i),j=1,3),(gvdwc(j,i),j=1,3)
 526       enddo
 527       call flush(iout)
 528 #endif
 529 #ifdef DEBUG
 530       write (iout,*) "sum_gradient gsaxsc, gsaxsx"
 531       do i=0,nres
 532         write (iout,'(i3,3e15.5,5x,3e15.5)')
 533      &   i,(gsaxsc(j,i),j=1,3),(gsaxsx(j,i),j=1,3)
 534       enddo
 535       call flush(iout)
 536 #endif
 537 #ifdef MPI
 538 C FG slaves call the following matching MPI_Bcast in ERGASTULUM
 539         if (nfgtasks.gt.1 .and. fg_rank.eq.0)
 540      &    call MPI_Bcast(1,1,MPI_INTEGER,king,FG_COMM,IERROR)
 541 #endif
 542 C
 543 C 9/29/08 AL Transform parts of gradients in site coordinates to the gradient
 544 C            in virtual-bond-vector coordinates
 545 C
 546 #ifdef DEBUG
 547 c      write (iout,*) "gel_loc gel_loc_long and gel_loc_loc"
 548 c      do i=1,nres-1
 549 c        write (iout,'(i5,3f10.5,2x,3f10.5,2x,f10.5)')
 550 c     &   i,(gel_loc(j,i),j=1,3),(gel_loc_long(j,i),j=1,3),gel_loc_loc(i)
 551 c      enddo
 552 c      write (iout,*) "gel_loc_tur3 gel_loc_turn4"
 553 c      do i=1,nres-1
 554 c        write (iout,'(i5,3f10.5,2x,f10.5)')
 555 c     &  i,(gcorr4_turn(j,i),j=1,3),gel_loc_turn4(i)
 556 c      enddo
 557       write (iout,*) "gradcorr5 gradcorr5_long gradcorr5_loc"
 558       do i=1,nres
 559         write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)')
 560      &   i,(gradcorr5(j,i),j=1,3),(gradcorr5_long(j,i),j=1,3),
 561      &   g_corr5_loc(i)
 562       enddo
 563       call flush(iout)
 564 #endif
 565 #ifdef SPLITELE
 566       do i=0,nct
 567         do j=1,3
 568           gradbufc(j,i)=wsc*gvdwc(j,i)+
 569      &                wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+
 570      &                welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+
 571      &                wel_loc*gel_loc_long(j,i)+
 572      &                wcorr*gradcorr_long(j,i)+
 573      &                wcorr5*gradcorr5_long(j,i)+
 574      &                wcorr6*gradcorr6_long(j,i)+
 575      &                wturn6*gcorr6_turn_long(j,i)+
 576      &                wstrain*ghpbc(j,i)+
 577      &                wsaxs*gsaxsc(j,i)
 578      &                +wliptran*gliptranc(j,i)
 579      &                +gradafm(j,i)
 580
 581         enddo
 582       enddo
 583 #else
 584       do i=0,nct
 585         do j=1,3
 586           gradbufc(j,i)=wsc*gvdwc(j,i)+
 587      &                wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+
 588      &                welec*gelc_long(j,i)+
 589      &                wbond*gradb(j,i)+
 590      &                wel_loc*gel_loc_long(j,i)+
 591      &                wcorr*gradcorr_long(j,i)+
 592      &                wcorr5*gradcorr5_long(j,i)+
 593      &                wcorr6*gradcorr6_long(j,i)+
 594      &                wturn6*gcorr6_turn_long(j,i)+
 595      &                wstrain*ghpbc(j,i)+
 596      &                wsaxs*gsaxsc(j,i)
 597      &                +wliptran*gliptranc(j,i)
 598      &                +gradafm(j,i)
 599
 600         enddo
 601       enddo
 602 #endif
 603 #ifdef MPI
 604       if (nfgtasks.gt.1) then
 605       time00=MPI_Wtime()
 606 #ifdef DEBUG
 607       write (iout,*) "gradbufc before allreduce"
 608       do i=1,nres
 609         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 610       enddo
 611       call flush(iout)
 612 #endif
 613       do i=0,nres
 614         do j=1,3
 615           gradbufc_sum(j,i)=gradbufc(j,i)
 616         enddo
 617       enddo
 618 c      call MPI_AllReduce(gradbufc(1,1),gradbufc_sum(1,1),3*nres,
 619 c     &    MPI_DOUBLE_PRECISION,MPI_SUM,FG_COMM,IERR)
 620 c      time_reduce=time_reduce+MPI_Wtime()-time00
 621 #ifdef DEBUG
 622 c      write (iout,*) "gradbufc_sum after allreduce"
 623 c      do i=1,nres
 624 c        write (iout,'(i3,3f10.5)') i,(gradbufc_sum(j,i),j=1,3)
 625 c      enddo
 626 c      call flush(iout)
 627 #endif
 628 #ifdef TIMING
 629 c      time_allreduce=time_allreduce+MPI_Wtime()-time00
 630 #endif
 631       do i=nnt,nres
 632         do k=1,3
 633           gradbufc(k,i)=0.0d0
 634         enddo
 635       enddo
 636 #ifdef DEBUG
 637       write (iout,*) "igrad_start",igrad_start," igrad_end",igrad_end
 638       write (iout,*) (i," jgrad_start",jgrad_start(i),
 639      &                  " jgrad_end  ",jgrad_end(i),
 640      &                  i=igrad_start,igrad_end)
 641 #endif
 642 c
 643 c Obsolete and inefficient code; we can make the effort O(n) and, therefore,
 644 c do not parallelize this part.
 645 c
 646 c      do i=igrad_start,igrad_end
 647 c        do j=jgrad_start(i),jgrad_end(i)
 648 c          do k=1,3
 649 c            gradbufc(k,i)=gradbufc(k,i)+gradbufc_sum(k,j)
 650 c          enddo
 651 c        enddo
 652 c      enddo
 653       do j=1,3
 654         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
 655       enddo
 656       do i=nres-2,0,-1
 657 c      do i=nres-2,nnt,-1
 658         do j=1,3
 659           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
 660         enddo
 661       enddo
 662 #ifdef DEBUG
 663       write (iout,*) "gradbufc after summing"
 664       do i=1,nres
 665         write (iout,'(i3,3e15.5)') i,(gradbufc(j,i),j=1,3)
 666       enddo
 667       call flush(iout)
 668 #endif
 669       else
 670 #endif
 671 #ifdef DEBUG
 672       write (iout,*) "gradbufc"
 673       do i=0,nres
 674         write (iout,'(i3,3e15.5)') i,(gradbufc(j,i),j=1,3)
 675       enddo
 676       call flush(iout)
 677 #endif
 678       do i=-1,nres
 679         do j=1,3
 680           gradbufc_sum(j,i)=gradbufc(j,i)
 681           gradbufc(j,i)=0.0d0
 682         enddo
 683       enddo
 684       do j=1,3
 685         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
 686       enddo
 687       do i=nres-2,0,-1
 688 c      do i=nres-2,nnt,-1
 689         do j=1,3
 690           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
 691         enddo
 692       enddo
 693 c      do i=nnt,nres-1
 694 c        do k=1,3
 695 c          gradbufc(k,i)=0.0d0
 696 c        enddo
 697 c        do j=i+1,nres
 698 c          do k=1,3
 699 c            gradbufc(k,i)=gradbufc(k,i)+gradbufc(k,j)
 700 c          enddo
 701 c        enddo
 702 c      enddo
 703 #ifdef DEBUG
 704       write (iout,*) "gradbufc after summing"
 705       do i=0,nres
 706         write (iout,'(i3,3e15.5)') i,(gradbufc(j,i),j=1,3)
 707       enddo
 708       call flush(iout)
 709 #endif
 710 #ifdef MPI
 711       endif
 712 #endif
 713       do k=1,3
 714         gradbufc(k,nres)=0.0d0
 715       enddo
 716       do i=-1,nct
 717         do j=1,3
 718 #ifdef SPLITELE
 719           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+
 720      &                wel_loc*gel_loc(j,i)+
 721      &                0.5d0*(wscp*gvdwc_scpp(j,i)+
 722      &                welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+
 723      &                wel_loc*gel_loc_long(j,i)+
 724      &                wcorr*gradcorr_long(j,i)+
 725      &                wcorr5*gradcorr5_long(j,i)+
 726      &                wcorr6*gradcorr6_long(j,i)+
 727      &                wturn6*gcorr6_turn_long(j,i))+
 728      &                wbond*gradb(j,i)+
 729      &                wcorr*gradcorr(j,i)+
 730      &                wturn3*gcorr3_turn(j,i)+
 731      &                wturn4*gcorr4_turn(j,i)+
 732      &                wcorr5*gradcorr5(j,i)+
 733      &                wcorr6*gradcorr6(j,i)+
 734      &                wturn6*gcorr6_turn(j,i)+
 735      &                wsccor*gsccorc(j,i)
 736      &               +wscloc*gscloc(j,i)
 737      &               +wliptran*gliptranc(j,i)
 738      &                +gradafm(j,i)
 739 #else
 740           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+
 741      &                wel_loc*gel_loc(j,i)+
 742      &                0.5d0*(wscp*gvdwc_scpp(j,i)+
 743      &                welec*gelc_long(j,i)+
 744      &                wel_loc*gel_loc_long(j,i)+
 745      &                wcorr*gcorr_long(j,i)+
 746      &                wcorr5*gradcorr5_long(j,i)+
 747      &                wcorr6*gradcorr6_long(j,i)+
 748      &                wturn6*gcorr6_turn_long(j,i))+
 749      &                wbond*gradb(j,i)+
 750      &                wcorr*gradcorr(j,i)+
 751      &                wturn3*gcorr3_turn(j,i)+
 752      &                wturn4*gcorr4_turn(j,i)+
 753      &                wcorr5*gradcorr5(j,i)+
 754      &                wcorr6*gradcorr6(j,i)+
 755      &                wturn6*gcorr6_turn(j,i)+
 756      &                wsccor*gsccorc(j,i)
 757      &               +wscloc*gscloc(j,i)
 758      &               +wliptran*gliptranc(j,i)
 759      &                +gradafm(j,i)
 760
 761 #endif
 762           gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+
 763      &                  wbond*gradbx(j,i)+
 764      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)
 765      &                 +wsaxs*gsaxsx(j,i)
 766      &                 +wsccor*gsccorx(j,i)
 767      &                 +wscloc*gsclocx(j,i)
 768      &                 +wliptran*gliptranx(j,i)
 769         enddo
 770       enddo
 771       if (constr_homology.gt.0) then
 772         do i=1,nct
 773           do j=1,3
 774             gradc(j,i,icg)=gradc(j,i,icg)+duscdiff(j,i)
 775             gradx(j,i,icg)=gradx(j,i,icg)+duscdiffx(j,i)
 776           enddo
 777         enddo
 778       endif
 779 #ifdef DEBUG
 780       write (iout,*) "gloc before adding corr"
 781       do i=1,4*nres
 782         write (iout,*) i,gloc(i,icg)
 783       enddo
 784 #endif
 785       do i=1,nres-3
 786         gloc(i,icg)=gloc(i,icg)+wcorr*gcorr_loc(i)
 787      &   +wcorr5*g_corr5_loc(i)
 788      &   +wcorr6*g_corr6_loc(i)
 789      &   +wturn4*gel_loc_turn4(i)
 790      &   +wturn3*gel_loc_turn3(i)
 791      &   +wturn6*gel_loc_turn6(i)
 792      &   +wel_loc*gel_loc_loc(i)
 793       enddo
 794 #ifdef DEBUG
 795       write (iout,*) "gloc after adding corr"
 796       do i=1,4*nres
 797         write (iout,*) i,gloc(i,icg)
 798       enddo
 799 #endif
 800 #ifdef MPI
 801       if (nfgtasks.gt.1) then
 802         do j=1,3
 803           do i=1,nres
 804             gradbufc(j,i)=gradc(j,i,icg)
 805             gradbufx(j,i)=gradx(j,i,icg)
 806           enddo
 807         enddo
 808         do i=1,4*nres
 809           glocbuf(i)=gloc(i,icg)
 810         enddo
 811 c#define DEBUG
 812 #ifdef DEBUG
 813       write (iout,*) "gloc_sc before reduce"
 814       do i=1,nres
 815        do j=1,1
 816         write (iout,*) i,j,gloc_sc(j,i,icg)
 817        enddo
 818       enddo
 819 #endif
 820 c#undef DEBUG
 821         do i=1,nres
 822          do j=1,3
 823           gloc_scbuf(j,i)=gloc_sc(j,i,icg)
 824          enddo
 825         enddo
 826         time00=MPI_Wtime()
 827         call MPI_Barrier(FG_COMM,IERR)
 828         time_barrier_g=time_barrier_g+MPI_Wtime()-time00
 829         time00=MPI_Wtime()
 830         call MPI_Reduce(gradbufc(1,1),gradc(1,1,icg),3*nres,
 831      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 832         call MPI_Reduce(gradbufx(1,1),gradx(1,1,icg),3*nres,
 833      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 834         call MPI_Reduce(glocbuf(1),gloc(1,icg),4*nres,
 835      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 836         time_reduce=time_reduce+MPI_Wtime()-time00
 837         call MPI_Reduce(gloc_scbuf(1,1),gloc_sc(1,1,icg),3*nres,
 838      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 839         time_reduce=time_reduce+MPI_Wtime()-time00
 840 c#define DEBUG
 841 #ifdef DEBUG
 842       write (iout,*) "gloc_sc after reduce"
 843       do i=1,nres
 844        do j=1,1
 845         write (iout,*) i,j,gloc_sc(j,i,icg)
 846        enddo
 847       enddo
 848 #endif
 849 c#undef DEBUG
 850 #ifdef DEBUG
 851       write (iout,*) "gloc after reduce"
 852       do i=1,4*nres
 853         write (iout,*) i,gloc(i,icg)
 854       enddo
 855 #endif
 856       endif
 857 #endif
 858       if (gnorm_check) then
 859 c
 860 c Compute the maximum elements of the gradient
 861 c
 862       gvdwc_max=0.0d0
 863       gvdwc_scp_max=0.0d0
 864       gelc_max=0.0d0
 865       gvdwpp_max=0.0d0
 866       gradb_max=0.0d0
 867       ghpbc_max=0.0d0
 868       gradcorr_max=0.0d0
 869       gel_loc_max=0.0d0
 870       gcorr3_turn_max=0.0d0
 871       gcorr4_turn_max=0.0d0
 872       gradcorr5_max=0.0d0
 873       gradcorr6_max=0.0d0
 874       gcorr6_turn_max=0.0d0
 875       gsccorc_max=0.0d0
 876       gscloc_max=0.0d0
 877       gvdwx_max=0.0d0
 878       gradx_scp_max=0.0d0
 879       ghpbx_max=0.0d0
 880       gradxorr_max=0.0d0
 881       gsccorx_max=0.0d0
 882       gsclocx_max=0.0d0
 883       do i=1,nct
 884         gvdwc_norm=dsqrt(scalar(gvdwc(1,i),gvdwc(1,i)))
 885         if (gvdwc_norm.gt.gvdwc_max) gvdwc_max=gvdwc_norm
 886         gvdwc_scp_norm=dsqrt(scalar(gvdwc_scp(1,i),gvdwc_scp(1,i)))
 887         if (gvdwc_scp_norm.gt.gvdwc_scp_max)
 888      &   gvdwc_scp_max=gvdwc_scp_norm
 889         gelc_norm=dsqrt(scalar(gelc(1,i),gelc(1,i)))
 890         if (gelc_norm.gt.gelc_max) gelc_max=gelc_norm
 891         gvdwpp_norm=dsqrt(scalar(gvdwpp(1,i),gvdwpp(1,i)))
 892         if (gvdwpp_norm.gt.gvdwpp_max) gvdwpp_max=gvdwpp_norm
 893         gradb_norm=dsqrt(scalar(gradb(1,i),gradb(1,i)))
 894         if (gradb_norm.gt.gradb_max) gradb_max=gradb_norm
 895         ghpbc_norm=dsqrt(scalar(ghpbc(1,i),ghpbc(1,i)))
 896         if (ghpbc_norm.gt.ghpbc_max) ghpbc_max=ghpbc_norm
 897         gradcorr_norm=dsqrt(scalar(gradcorr(1,i),gradcorr(1,i)))
 898         if (gradcorr_norm.gt.gradcorr_max) gradcorr_max=gradcorr_norm
 899         gel_loc_norm=dsqrt(scalar(gel_loc(1,i),gel_loc(1,i)))
 900         if (gel_loc_norm.gt.gel_loc_max) gel_loc_max=gel_loc_norm
 901         gcorr3_turn_norm=dsqrt(scalar(gcorr3_turn(1,i),
 902      &    gcorr3_turn(1,i)))
 903         if (gcorr3_turn_norm.gt.gcorr3_turn_max)
 904      &    gcorr3_turn_max=gcorr3_turn_norm
 905         gcorr4_turn_norm=dsqrt(scalar(gcorr4_turn(1,i),
 906      &    gcorr4_turn(1,i)))
 907         if (gcorr4_turn_norm.gt.gcorr4_turn_max)
 908      &    gcorr4_turn_max=gcorr4_turn_norm
 909         gradcorr5_norm=dsqrt(scalar(gradcorr5(1,i),gradcorr5(1,i)))
 910         if (gradcorr5_norm.gt.gradcorr5_max)
 911      &    gradcorr5_max=gradcorr5_norm
 912         gradcorr6_norm=dsqrt(scalar(gradcorr6(1,i),gradcorr6(1,i)))
 913         if (gradcorr6_norm.gt.gradcorr6_max) gcorr6_max=gradcorr6_norm
 914         gcorr6_turn_norm=dsqrt(scalar(gcorr6_turn(1,i),
 915      &    gcorr6_turn(1,i)))
 916         if (gcorr6_turn_norm.gt.gcorr6_turn_max)
 917      &    gcorr6_turn_max=gcorr6_turn_norm
 918         gsccorr_norm=dsqrt(scalar(gsccorc(1,i),gsccorc(1,i)))
 919         if (gsccorr_norm.gt.gsccorr_max) gsccorr_max=gsccorr_norm
 920         gscloc_norm=dsqrt(scalar(gscloc(1,i),gscloc(1,i)))
 921         if (gscloc_norm.gt.gscloc_max) gscloc_max=gscloc_norm
 922         gvdwx_norm=dsqrt(scalar(gvdwx(1,i),gvdwx(1,i)))
 923         if (gvdwx_norm.gt.gvdwx_max) gvdwx_max=gvdwx_norm
 924         gradx_scp_norm=dsqrt(scalar(gradx_scp(1,i),gradx_scp(1,i)))
 925         if (gradx_scp_norm.gt.gradx_scp_max)
 926      &    gradx_scp_max=gradx_scp_norm
 927         ghpbx_norm=dsqrt(scalar(ghpbx(1,i),ghpbx(1,i)))
 928         if (ghpbx_norm.gt.ghpbx_max) ghpbx_max=ghpbx_norm
 929         gradxorr_norm=dsqrt(scalar(gradxorr(1,i),gradxorr(1,i)))
 930         if (gradxorr_norm.gt.gradxorr_max) gradxorr_max=gradxorr_norm
 931         gsccorrx_norm=dsqrt(scalar(gsccorx(1,i),gsccorx(1,i)))
 932         if (gsccorrx_norm.gt.gsccorrx_max) gsccorrx_max=gsccorrx_norm
 933         gsclocx_norm=dsqrt(scalar(gsclocx(1,i),gsclocx(1,i)))
 934         if (gsclocx_norm.gt.gsclocx_max) gsclocx_max=gsclocx_norm
 935       enddo
 936       if (gradout) then
 937 #ifdef AIX
 938         open(istat,file=statname,position="append")
 939 #else
 940         open(istat,file=statname,access="append")
 941 #endif
 942         write (istat,'(1h#,21f10.2)') gvdwc_max,gvdwc_scp_max,
 943      &     gelc_max,gvdwpp_max,gradb_max,ghpbc_max,
 944      &     gradcorr_max,gel_loc_max,gcorr3_turn_max,gcorr4_turn_max,
 945      &     gradcorr5_max,gradcorr6_max,gcorr6_turn_max,gsccorc_max,
 946      &     gscloc_max,gvdwx_max,gradx_scp_max,ghpbx_max,gradxorr_max,
 947      &     gsccorx_max,gsclocx_max
 948         close(istat)
 949         if (gvdwc_max.gt.1.0d4) then
 950           write (iout,*) "gvdwc gvdwx gradb gradbx"
 951           do i=nnt,nct
 952             write(iout,'(i5,4(3f10.2,5x))') i,(gvdwc(j,i),gvdwx(j,i),
 953      &        gradb(j,i),gradbx(j,i),j=1,3)
 954           enddo
 955           call pdbout(0.0d0,'cipiszcze',iout)
 956           call flush(iout)
 957         endif
 958       endif
 959       endif
 960 #ifdef DEBUG
 961       write (iout,*) "gradc gradx gloc"
 962       do i=1,nres
 963         write (iout,'(i5,3e15.5,5x,3e15.5,5x,e15.5)')
 964      &   i,(gradc(j,i,icg),j=1,3),(gradx(j,i,icg),j=1,3),gloc(i,icg)
 965       enddo
 966 #endif
 967 #ifdef TIMING
 968       time_sumgradient=time_sumgradient+MPI_Wtime()-time01
 969 #endif
 970       return
 971       end
 972 c-------------------------------------------------------------------------------
 973       subroutine rescale_weights(t_bath)
 974       implicit real*8 (a-h,o-z)
 975       include 'DIMENSIONS'
 976       include 'COMMON.IOUNITS'
 977       include 'COMMON.FFIELD'
 978       include 'COMMON.SBRIDGE'
 979       double precision kfac /2.4d0/
 980       double precision x,x2,x3,x4,x5,licznik /1.12692801104297249644/
 981 c      facT=temp0/t_bath
 982 c      facT=2*temp0/(t_bath+temp0)
 983       if (rescale_mode.eq.0) then
 984         facT=1.0d0
 985         facT2=1.0d0
 986         facT3=1.0d0
 987         facT4=1.0d0
 988         facT5=1.0d0
 989       else if (rescale_mode.eq.1) then
 990         facT=kfac/(kfac-1.0d0+t_bath/temp0)
 991         facT2=kfac**2/(kfac**2-1.0d0+(t_bath/temp0)**2)
 992         facT3=kfac**3/(kfac**3-1.0d0+(t_bath/temp0)**3)
 993         facT4=kfac**4/(kfac**4-1.0d0+(t_bath/temp0)**4)
 994         facT5=kfac**5/(kfac**5-1.0d0+(t_bath/temp0)**5)
 995       else if (rescale_mode.eq.2) then
 996         x=t_bath/temp0
 997         x2=x*x
 998         x3=x2*x
 999         x4=x3*x
1000         x5=x4*x
1001         facT=licznik/dlog(dexp(x)+dexp(-x))
1002         facT2=licznik/dlog(dexp(x2)+dexp(-x2))
1003         facT3=licznik/dlog(dexp(x3)+dexp(-x3))
1004         facT4=licznik/dlog(dexp(x4)+dexp(-x4))
1005         facT5=licznik/dlog(dexp(x5)+dexp(-x5))
1006       else
1007         write (iout,*) "Wrong RESCALE_MODE",rescale_mode
1008         write (*,*) "Wrong RESCALE_MODE",rescale_mode
1009 #ifdef MPI
1010        call MPI_Finalize(MPI_COMM_WORLD,IERROR)
1011 #endif
1012        stop 555
1013       endif
1014       welec=weights(3)*fact
1015       wcorr=weights(4)*fact3
1016       wcorr5=weights(5)*fact4
1017       wcorr6=weights(6)*fact5
1018       wel_loc=weights(7)*fact2
1019       wturn3=weights(8)*fact2
1020       wturn4=weights(9)*fact3
1021       wturn6=weights(10)*fact5
1022       wtor=weights(13)*fact
1023       wtor_d=weights(14)*fact2
1024       wsccor=weights(21)*fact
1025
1026       return
1027       end
1028 C------------------------------------------------------------------------
1029       subroutine enerprint(energia)
1030       implicit real*8 (a-h,o-z)
1031       include 'DIMENSIONS'
1032       include 'COMMON.IOUNITS'
1033       include 'COMMON.FFIELD'
1034       include 'COMMON.SBRIDGE'
1035       include 'COMMON.MD'
1036       double precision energia(0:n_ene)
1037       etot=energia(0)
1038       evdw=energia(1)
1039       evdw2=energia(2)
1040 #ifdef SCP14
1041       evdw2=energia(2)+energia(18)
1042 #else
1043       evdw2=energia(2)
1044 #endif
1045       ees=energia(3)
1046 #ifdef SPLITELE
1047       evdw1=energia(16)
1048 #endif
1049       ecorr=energia(4)
1050       ecorr5=energia(5)
1051       ecorr6=energia(6)
1052       eel_loc=energia(7)
1053       eello_turn3=energia(8)
1054       eello_turn4=energia(9)
1055       eello_turn6=energia(10)
1056       ebe=energia(11)
1057       escloc=energia(12)
1058       etors=energia(13)
1059       etors_d=energia(14)
1060       ehpb=energia(15)
1061       edihcnstr=energia(19)
1062       estr=energia(17)
1063       Uconst=energia(20)
1064       esccor=energia(21)
1065       ehomology_constr=energia(24)
1066       esaxs_constr=energia(25)
1067       eliptran=energia(22)
1068       Eafmforce=energia(23)
1069 #ifdef SPLITELE
1070       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,evdw1,wvdwpp,
1071      &  estr,wbond,ebe,wang,
1072      &  escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,
1073      &  ecorr,wcorr,
1074      &  ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,
1075      &  eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccor,
1076      &  edihcnstr,ehomology_constr,esaxs_constr*wsaxs, ebr*nss,
1077      &  Uconst,eliptran,wliptran,Eafmforce,etot
1078    10 format (/'Virtual-chain energies:'//
1079      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
1080      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
1081      & 'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/
1082      & 'EVDWPP=',1pE16.6,' WEIGHT=',1pD16.6,' (p-p VDW)'/
1083      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
1084      & 'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
1085      & 'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
1086      & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
1087      & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
1088      & 'EHPB=  ',1pE16.6,' WEIGHT=',1pD16.6,
1089      & ' (SS bridges & dist. cnstr.)'/
1090      & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1091      & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1092      & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1093      & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
1094      & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
1095      & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
1096      & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
1097      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
1098      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
1099      & 'H_CONS=',1pE16.6,' (Homology model constraints energy)'/
1100      & 'E_SAXS=',1pE16.6,' (SAXS restraints)'/
1101      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
1102      & 'UCONST= ',1pE16.6,' (Constraint energy)'/
1103      & 'ELT=',1pE16.6, ' WEIGHT=',1pD16.6,' (Lipid transfer energy)'/
1104      & 'EAFM=  ',1pE16.6,' (atomic-force microscopy)'/
1105      & 'ETOT=  ',1pE16.6,' (total)')
1106
1107 #else
1108       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,
1109      &  estr,wbond,ebe,wang,
1110      &  escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,
1111      &  ecorr,wcorr,
1112      &  ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,
1113      &  eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccro,edihcnstr,
1114      &  ehomology_constr,esaxs_constr*wsaxs,ebr*nss,Uconst,
1115      &  eliptran,wliptran,Eafmforc,
1116      &  etot
1117    10 format (/'Virtual-chain energies:'//
1118      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
1119      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
1120      & 'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/
1121      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
1122      & 'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
1123      & 'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
1124      & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
1125      & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
1126      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6,
1127      & ' (SS bridges & dist. cnstr.)'/
1128      & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1129      & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1130      & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1131      & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
1132      & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
1133      & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
1134      & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
1135      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
1136      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
1137      & 'H_CONS=',1pE16.6,' (Homology model constraints energy)'/
1138      & 'E_SAXS=',1pE16.6,' (SAXS restraints)'/
1139      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
1140      & 'UCONST=',1pE16.6,' (Constraint energy)'/
1141      & 'ELT=',1pE16.6, ' WEIGHT=',1pD16.6,' (Lipid transfer energy)'/
1142      & 'EAFM=  ',1pE16.6,' (atomic-force microscopy)'/
1143      & 'ETOT=  ',1pE16.6,' (total)')
1144 #endif
1145       return
1146       end
1147 C-----------------------------------------------------------------------
1148       subroutine elj(evdw)
1149 C
1150 C This subroutine calculates the interaction energy of nonbonded side chains
1151 C assuming the LJ potential of interaction.
1152 C
1153       implicit real*8 (a-h,o-z)
1154       include 'DIMENSIONS'
1155       parameter (accur=1.0d-10)
1156       include 'COMMON.GEO'
1157       include 'COMMON.VAR'
1158       include 'COMMON.LOCAL'
1159       include 'COMMON.CHAIN'
1160       include 'COMMON.DERIV'
1161       include 'COMMON.INTERACT'
1162       include 'COMMON.TORSION'
1163       include 'COMMON.SBRIDGE'
1164       include 'COMMON.NAMES'
1165       include 'COMMON.IOUNITS'
1166       include 'COMMON.CONTACTS'
1167       dimension gg(3)
1168 c      write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
1169       evdw=0.0D0
1170       do i=iatsc_s,iatsc_e
1171         itypi=iabs(itype(i))
1172         if (itypi.eq.ntyp1) cycle
1173         itypi1=iabs(itype(i+1))
1174         xi=c(1,nres+i)
1175         yi=c(2,nres+i)
1176         zi=c(3,nres+i)
1177 C Change 12/1/95
1178         num_conti=0
1179 C
1180 C Calculate SC interaction energy.
1181 C
1182         do iint=1,nint_gr(i)
1183 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
1184 cd   &                  'iend=',iend(i,iint)
1185           do j=istart(i,iint),iend(i,iint)
1186             itypj=iabs(itype(j))
1187             if (itypj.eq.ntyp1) cycle
1188             xj=c(1,nres+j)-xi
1189             yj=c(2,nres+j)-yi
1190             zj=c(3,nres+j)-zi
1191 C Change 12/1/95 to calculate four-body interactions
1192             rij=xj*xj+yj*yj+zj*zj
1193             rrij=1.0D0/rij
1194 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
1195             eps0ij=eps(itypi,itypj)
1196             fac=rrij**expon2
1197 C have you changed here?
1198             e1=fac*fac*aa
1199             e2=fac*bb
1200             evdwij=e1+e2
1201 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1202 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1203 cd          write (iout,'(2(a3,i3,2x),6(1pd12.4)/2(3(1pd12.4),5x)/)')
1204 cd   &        restyp(itypi),i,restyp(itypj),j,a(itypi,itypj),
1205 cd   &        bb(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,epsi,sigm,
1206 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1207             evdw=evdw+evdwij
1208 C
1209 C Calculate the components of the gradient in DC and X
1210 C
1211             fac=-rrij*(e1+evdwij)
1212             gg(1)=xj*fac
1213             gg(2)=yj*fac
1214             gg(3)=zj*fac
1215             do k=1,3
1216               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1217               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1218               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1219               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1220             enddo
1221 cgrad            do k=i,j-1
1222 cgrad              do l=1,3
1223 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1224 cgrad              enddo
1225 cgrad            enddo
1226 C
1227 C 12/1/95, revised on 5/20/97
1228 C
1229 C Calculate the contact function. The ith column of the array JCONT will
1230 C contain the numbers of atoms that make contacts with the atom I (of numbers
1231 C greater than I). The arrays FACONT and GACONT will contain the values of
1232 C the contact function and its derivative.
1233 C
1234 C Uncomment next line, if the correlation interactions include EVDW explicitly.
1235 c           if (j.gt.i+1 .and. evdwij.le.0.0D0) then
1236 C Uncomment next line, if the correlation interactions are contact function only
1237             if (j.gt.i+1.and. eps0ij.gt.0.0D0) then
1238               rij=dsqrt(rij)
1239               sigij=sigma(itypi,itypj)
1240               r0ij=rs0(itypi,itypj)
1241 C
1242 C Check whether the SC's are not too far to make a contact.
1243 C
1244               rcut=1.5d0*r0ij
1245               call gcont(rij,rcut,1.0d0,0.2d0*rcut,fcont,fprimcont)
1246 C Add a new contact, if the SC's are close enough, but not too close (r<sigma).
1247 C
1248               if (fcont.gt.0.0D0) then
1249 C If the SC-SC distance if close to sigma, apply spline.
1250 cAdam           call gcont(-rij,-1.03d0*sigij,2.0d0*sigij,1.0d0,
1251 cAdam &             fcont1,fprimcont1)
1252 cAdam           fcont1=1.0d0-fcont1
1253 cAdam           if (fcont1.gt.0.0d0) then
1254 cAdam             fprimcont=fprimcont*fcont1+fcont*fprimcont1
1255 cAdam             fcont=fcont*fcont1
1256 cAdam           endif
1257 C Uncomment following 4 lines to have the geometric average of the epsilon0's
1258 cga             eps0ij=1.0d0/dsqrt(eps0ij)
1259 cga             do k=1,3
1260 cga               gg(k)=gg(k)*eps0ij
1261 cga             enddo
1262 cga             eps0ij=-evdwij*eps0ij
1263 C Uncomment for AL's type of SC correlation interactions.
1264 cadam           eps0ij=-evdwij
1265                 num_conti=num_conti+1
1266                 jcont(num_conti,i)=j
1267                 facont(num_conti,i)=fcont*eps0ij
1268                 fprimcont=eps0ij*fprimcont/rij
1269                 fcont=expon*fcont
1270 cAdam           gacont(1,num_conti,i)=-fprimcont*xj+fcont*gg(1)
1271 cAdam           gacont(2,num_conti,i)=-fprimcont*yj+fcont*gg(2)
1272 cAdam           gacont(3,num_conti,i)=-fprimcont*zj+fcont*gg(3)
1273 C Uncomment following 3 lines for Skolnick's type of SC correlation.
1274                 gacont(1,num_conti,i)=-fprimcont*xj
1275                 gacont(2,num_conti,i)=-fprimcont*yj
1276                 gacont(3,num_conti,i)=-fprimcont*zj
1277 cd              write (iout,'(2i5,2f10.5)') i,j,rij,facont(num_conti,i)
1278 cd              write (iout,'(2i3,3f10.5)')
1279 cd   &           i,j,(gacont(kk,num_conti,i),kk=1,3)
1280               endif
1281             endif
1282           enddo      ! j
1283         enddo        ! iint
1284 C Change 12/1/95
1285         num_cont(i)=num_conti
1286       enddo          ! i
1287       do i=1,nct
1288         do j=1,3
1289           gvdwc(j,i)=expon*gvdwc(j,i)
1290           gvdwx(j,i)=expon*gvdwx(j,i)
1291         enddo
1292       enddo
1293 C******************************************************************************
1294 C
1295 C                              N O T E !!!
1296 C
1297 C To save time, the factor of EXPON has been extracted from ALL components
1298 C of GVDWC and GRADX. Remember to multiply them by this factor before further
1299 C use!
1300 C
1301 C******************************************************************************
1302       return
1303       end
1304 C-----------------------------------------------------------------------------
1305       subroutine eljk(evdw)
1306 C
1307 C This subroutine calculates the interaction energy of nonbonded side chains
1308 C assuming the LJK potential of interaction.
1309 C
1310       implicit real*8 (a-h,o-z)
1311       include 'DIMENSIONS'
1312       include 'COMMON.GEO'
1313       include 'COMMON.VAR'
1314       include 'COMMON.LOCAL'
1315       include 'COMMON.CHAIN'
1316       include 'COMMON.DERIV'
1317       include 'COMMON.INTERACT'
1318       include 'COMMON.IOUNITS'
1319       include 'COMMON.NAMES'
1320       dimension gg(3)
1321       logical scheck
1322 c     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
1323       evdw=0.0D0
1324       do i=iatsc_s,iatsc_e
1325         itypi=iabs(itype(i))
1326         if (itypi.eq.ntyp1) cycle
1327         itypi1=iabs(itype(i+1))
1328         xi=c(1,nres+i)
1329         yi=c(2,nres+i)
1330         zi=c(3,nres+i)
1331 C
1332 C Calculate SC interaction energy.
1333 C
1334         do iint=1,nint_gr(i)
1335           do j=istart(i,iint),iend(i,iint)
1336             itypj=iabs(itype(j))
1337             if (itypj.eq.ntyp1) cycle
1338             xj=c(1,nres+j)-xi
1339             yj=c(2,nres+j)-yi
1340             zj=c(3,nres+j)-zi
1341             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1342             fac_augm=rrij**expon
1343             e_augm=augm(itypi,itypj)*fac_augm
1344             r_inv_ij=dsqrt(rrij)
1345             rij=1.0D0/r_inv_ij
1346             r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
1347             fac=r_shift_inv**expon
1348 C have you changed here?
1349             e1=fac*fac*aa
1350             e2=fac*bb
1351             evdwij=e_augm+e1+e2
1352 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1353 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1354 cd          write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
1355 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
1356 cd   &        bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
1357 cd   &        sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
1358 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1359             evdw=evdw+evdwij
1360 C
1361 C Calculate the components of the gradient in DC and X
1362 C
1363             fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
1364             gg(1)=xj*fac
1365             gg(2)=yj*fac
1366             gg(3)=zj*fac
1367             do k=1,3
1368               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1369               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1370               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1371               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1372             enddo
1373 cgrad            do k=i,j-1
1374 cgrad              do l=1,3
1375 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1376 cgrad              enddo
1377 cgrad            enddo
1378           enddo      ! j
1379         enddo        ! iint
1380       enddo          ! i
1381       do i=1,nct
1382         do j=1,3
1383           gvdwc(j,i)=expon*gvdwc(j,i)
1384           gvdwx(j,i)=expon*gvdwx(j,i)
1385         enddo
1386       enddo
1387       return
1388       end
1389 C-----------------------------------------------------------------------------
1390       subroutine ebp(evdw)
1391 C
1392 C This subroutine calculates the interaction energy of nonbonded side chains
1393 C assuming the Berne-Pechukas potential of interaction.
1394 C
1395       implicit real*8 (a-h,o-z)
1396       include 'DIMENSIONS'
1397       include 'COMMON.GEO'
1398       include 'COMMON.VAR'
1399       include 'COMMON.LOCAL'
1400       include 'COMMON.CHAIN'
1401       include 'COMMON.DERIV'
1402       include 'COMMON.NAMES'
1403       include 'COMMON.INTERACT'
1404       include 'COMMON.IOUNITS'
1405       include 'COMMON.CALC'
1406       common /srutu/ icall
1407 c     double precision rrsave(maxdim)
1408       logical lprn
1409       evdw=0.0D0
1410 c     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
1411       evdw=0.0D0
1412 c     if (icall.eq.0) then
1413 c       lprn=.true.
1414 c     else
1415         lprn=.false.
1416 c     endif
1417       ind=0
1418       do i=iatsc_s,iatsc_e
1419         itypi=iabs(itype(i))
1420         if (itypi.eq.ntyp1) cycle
1421         itypi1=iabs(itype(i+1))
1422         xi=c(1,nres+i)
1423         yi=c(2,nres+i)
1424         zi=c(3,nres+i)
1425         dxi=dc_norm(1,nres+i)
1426         dyi=dc_norm(2,nres+i)
1427         dzi=dc_norm(3,nres+i)
1428 c        dsci_inv=dsc_inv(itypi)
1429         dsci_inv=vbld_inv(i+nres)
1430 C
1431 C Calculate SC interaction energy.
1432 C
1433         do iint=1,nint_gr(i)
1434           do j=istart(i,iint),iend(i,iint)
1435             ind=ind+1
1436             itypj=iabs(itype(j))
1437             if (itypj.eq.ntyp1) cycle
1438 c            dscj_inv=dsc_inv(itypj)
1439             dscj_inv=vbld_inv(j+nres)
1440             chi1=chi(itypi,itypj)
1441             chi2=chi(itypj,itypi)
1442             chi12=chi1*chi2
1443             chip1=chip(itypi)
1444             chip2=chip(itypj)
1445             chip12=chip1*chip2
1446             alf1=alp(itypi)
1447             alf2=alp(itypj)
1448             alf12=0.5D0*(alf1+alf2)
1449 C For diagnostics only!!!
1450 c           chi1=0.0D0
1451 c           chi2=0.0D0
1452 c           chi12=0.0D0
1453 c           chip1=0.0D0
1454 c           chip2=0.0D0
1455 c           chip12=0.0D0
1456 c           alf1=0.0D0
1457 c           alf2=0.0D0
1458 c           alf12=0.0D0
1459             xj=c(1,nres+j)-xi
1460             yj=c(2,nres+j)-yi
1461             zj=c(3,nres+j)-zi
1462             dxj=dc_norm(1,nres+j)
1463             dyj=dc_norm(2,nres+j)
1464             dzj=dc_norm(3,nres+j)
1465             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1466 cd          if (icall.eq.0) then
1467 cd            rrsave(ind)=rrij
1468 cd          else
1469 cd            rrij=rrsave(ind)
1470 cd          endif
1471             rij=dsqrt(rrij)
1472 C Calculate the angle-dependent terms of energy & contributions to derivatives.
1473             call sc_angular
1474 C Calculate whole angle-dependent part of epsilon and contributions
1475 C to its derivatives
1476 C have you changed here?
1477             fac=(rrij*sigsq)**expon2
1478             e1=fac*fac*aa
1479             e2=fac*bb
1480             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1481             eps2der=evdwij*eps3rt
1482             eps3der=evdwij*eps2rt
1483             evdwij=evdwij*eps2rt*eps3rt
1484             evdw=evdw+evdwij
1485             if (lprn) then
1486             sigm=dabs(aa/bb)**(1.0D0/6.0D0)
1487             epsi=bb**2/aa
1488 cd            write (iout,'(2(a3,i3,2x),15(0pf7.3))')
1489 cd     &        restyp(itypi),i,restyp(itypj),j,
1490 cd     &        epsi,sigm,chi1,chi2,chip1,chip2,
1491 cd     &        eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
1492 cd     &        om1,om2,om12,1.0D0/dsqrt(rrij),
1493 cd     &        evdwij
1494             endif
1495 C Calculate gradient components.
1496             e1=e1*eps1*eps2rt**2*eps3rt**2
1497             fac=-expon*(e1+evdwij)
1498             sigder=fac/sigsq
1499             fac=rrij*fac
1500 C Calculate radial part of the gradient
1501             gg(1)=xj*fac
1502             gg(2)=yj*fac
1503             gg(3)=zj*fac
1504 C Calculate the angular part of the gradient and sum add the contributions
1505 C to the appropriate components of the Cartesian gradient.
1506             call sc_grad
1507           enddo      ! j
1508         enddo        ! iint
1509       enddo          ! i
1510 c     stop
1511       return
1512       end
1513 C-----------------------------------------------------------------------------
1514       subroutine egb(evdw)
1515 C
1516 C This subroutine calculates the interaction energy of nonbonded side chains
1517 C assuming the Gay-Berne potential of interaction.
1518 C
1519       implicit real*8 (a-h,o-z)
1520       include 'DIMENSIONS'
1521       include 'COMMON.GEO'
1522       include 'COMMON.VAR'
1523       include 'COMMON.LOCAL'
1524       include 'COMMON.CHAIN'
1525       include 'COMMON.DERIV'
1526       include 'COMMON.NAMES'
1527       include 'COMMON.INTERACT'
1528       include 'COMMON.IOUNITS'
1529       include 'COMMON.CALC'
1530       include 'COMMON.CONTROL'
1531       include 'COMMON.SPLITELE'
1532       include 'COMMON.SBRIDGE'
1533       logical lprn
1534       integer xshift,yshift,zshift
1535
1536       evdw=0.0D0
1537 ccccc      energy_dec=.false.
1538 C      print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1539       evdw=0.0D0
1540       lprn=.false.
1541 c     if (icall.eq.0) lprn=.false.
1542       ind=0
1543 C the loop over all 27 posible neigbours (for xshift=0,yshift=0,zshift=0
1544 C we have the original box)
1545 C      do xshift=-1,1
1546 C      do yshift=-1,1
1547 C      do zshift=-1,1
1548       do i=iatsc_s,iatsc_e
1549         itypi=iabs(itype(i))
1550         if (itypi.eq.ntyp1) cycle
1551         itypi1=iabs(itype(i+1))
1552         xi=c(1,nres+i)
1553         yi=c(2,nres+i)
1554         zi=c(3,nres+i)
1555 C Return atom into box, boxxsize is size of box in x dimension
1556 c  134   continue
1557 c        if (xi.gt.((xshift+0.5d0)*boxxsize)) xi=xi-boxxsize
1558 c        if (xi.lt.((xshift-0.5d0)*boxxsize)) xi=xi+boxxsize
1559 C Condition for being inside the proper box
1560 c        if ((xi.gt.((xshift+0.5d0)*boxxsize)).or.
1561 c     &       (xi.lt.((xshift-0.5d0)*boxxsize))) then
1562 c        go to 134
1563 c        endif
1564 c  135   continue
1565 c        if (yi.gt.((yshift+0.5d0)*boxysize)) yi=yi-boxysize
1566 c        if (yi.lt.((yshift-0.5d0)*boxysize)) yi=yi+boxysize
1567 C Condition for being inside the proper box
1568 c        if ((yi.gt.((yshift+0.5d0)*boxysize)).or.
1569 c     &       (yi.lt.((yshift-0.5d0)*boxysize))) then
1570 c        go to 135
1571 c        endif
1572 c  136   continue
1573 c        if (zi.gt.((zshift+0.5d0)*boxzsize)) zi=zi-boxzsize
1574 c        if (zi.lt.((zshift-0.5d0)*boxzsize)) zi=zi+boxzsize
1575 C Condition for being inside the proper box
1576 c        if ((zi.gt.((zshift+0.5d0)*boxzsize)).or.
1577 c     &       (zi.lt.((zshift-0.5d0)*boxzsize))) then
1578 c        go to 136
1579 c        endif
1580           xi=mod(xi,boxxsize)
1581           if (xi.lt.0) xi=xi+boxxsize
1582           yi=mod(yi,boxysize)
1583           if (yi.lt.0) yi=yi+boxysize
1584           zi=mod(zi,boxzsize)
1585           if (zi.lt.0) zi=zi+boxzsize
1586 C define scaling factor for lipids
1587
1588 C        if (positi.le.0) positi=positi+boxzsize
1589 C        print *,i
1590 C first for peptide groups
1591 c for each residue check if it is in lipid or lipid water border area
1592        if ((zi.gt.bordlipbot)
1593      &.and.(zi.lt.bordliptop)) then
1594 C the energy transfer exist
1595         if (zi.lt.buflipbot) then
1596 C what fraction I am in
1597          fracinbuf=1.0d0-
1598      &        ((zi-bordlipbot)/lipbufthick)
1599 C lipbufthick is thickenes of lipid buffore
1600          sslipi=sscalelip(fracinbuf)
1601          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
1602         elseif (zi.gt.bufliptop) then
1603          fracinbuf=1.0d0-((bordliptop-zi)/lipbufthick)
1604          sslipi=sscalelip(fracinbuf)
1605          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
1606         else
1607          sslipi=1.0d0
1608          ssgradlipi=0.0
1609         endif
1610        else
1611          sslipi=0.0d0
1612          ssgradlipi=0.0
1613        endif
1614
1615 C          xi=xi+xshift*boxxsize
1616 C          yi=yi+yshift*boxysize
1617 C          zi=zi+zshift*boxzsize
1618
1619         dxi=dc_norm(1,nres+i)
1620         dyi=dc_norm(2,nres+i)
1621         dzi=dc_norm(3,nres+i)
1622 c        dsci_inv=dsc_inv(itypi)
1623         dsci_inv=vbld_inv(i+nres)
1624 c        write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)
1625 c        write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi
1626 C
1627 C Calculate SC interaction energy.
1628 C
1629         do iint=1,nint_gr(i)
1630           do j=istart(i,iint),iend(i,iint)
1631             IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN
1632               call dyn_ssbond_ene(i,j,evdwij)
1633               evdw=evdw+evdwij
1634               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)')
1635      &                        'evdw',i,j,evdwij,' ss'
1636             ELSE
1637             ind=ind+1
1638             itypj=iabs(itype(j))
1639             if (itypj.eq.ntyp1) cycle
1640 c            dscj_inv=dsc_inv(itypj)
1641             dscj_inv=vbld_inv(j+nres)
1642 c            write (iout,*) "j",j,dsc_inv(itypj),dscj_inv,
1643 c     &       1.0d0/vbld(j+nres)
1644 c            write (iout,*) "i",i," j", j," itype",itype(i),itype(j)
1645             sig0ij=sigma(itypi,itypj)
1646             chi1=chi(itypi,itypj)
1647             chi2=chi(itypj,itypi)
1648             chi12=chi1*chi2
1649             chip1=chip(itypi)
1650             chip2=chip(itypj)
1651             chip12=chip1*chip2
1652             alf1=alp(itypi)
1653             alf2=alp(itypj)
1654             alf12=0.5D0*(alf1+alf2)
1655 C For diagnostics only!!!
1656 c           chi1=0.0D0
1657 c           chi2=0.0D0
1658 c           chi12=0.0D0
1659 c           chip1=0.0D0
1660 c           chip2=0.0D0
1661 c           chip12=0.0D0
1662 c           alf1=0.0D0
1663 c           alf2=0.0D0
1664 c           alf12=0.0D0
1665             xj=c(1,nres+j)
1666             yj=c(2,nres+j)
1667             zj=c(3,nres+j)
1668 C Return atom J into box the original box
1669 c  137   continue
1670 c        if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
1671 c        if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
1672 C Condition for being inside the proper box
1673 c        if ((xj.gt.((0.5d0)*boxxsize)).or.
1674 c     &       (xj.lt.((-0.5d0)*boxxsize))) then
1675 c        go to 137
1676 c        endif
1677 c  138   continue
1678 c        if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
1679 c        if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
1680 C Condition for being inside the proper box
1681 c        if ((yj.gt.((0.5d0)*boxysize)).or.
1682 c     &       (yj.lt.((-0.5d0)*boxysize))) then
1683 c        go to 138
1684 c        endif
1685 c  139   continue
1686 c        if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
1687 c        if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
1688 C Condition for being inside the proper box
1689 c        if ((zj.gt.((0.5d0)*boxzsize)).or.
1690 c     &       (zj.lt.((-0.5d0)*boxzsize))) then
1691 c        go to 139
1692 c        endif
1693           xj=mod(xj,boxxsize)
1694           if (xj.lt.0) xj=xj+boxxsize
1695           yj=mod(yj,boxysize)
1696           if (yj.lt.0) yj=yj+boxysize
1697           zj=mod(zj,boxzsize)
1698           if (zj.lt.0) zj=zj+boxzsize
1699        if ((zj.gt.bordlipbot)
1700      &.and.(zj.lt.bordliptop)) then
1701 C the energy transfer exist
1702         if (zj.lt.buflipbot) then
1703 C what fraction I am in
1704          fracinbuf=1.0d0-
1705      &        ((zj-bordlipbot)/lipbufthick)
1706 C lipbufthick is thickenes of lipid buffore
1707          sslipj=sscalelip(fracinbuf)
1708          ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
1709         elseif (zj.gt.bufliptop) then
1710          fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
1711          sslipj=sscalelip(fracinbuf)
1712          ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
1713         else
1714          sslipj=1.0d0
1715          ssgradlipj=0.0
1716         endif
1717        else
1718          sslipj=0.0d0
1719          ssgradlipj=0.0
1720        endif
1721       aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
1722      &  +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1723       bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
1724      &  +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1725 C      if (aa.ne.aa_aq(itypi,itypj)) write(63,'(2e10.5)')
1726 C     &(aa-aa_aq(itypi,itypj)),(bb-bb_aq(itypi,itypj))
1727 C      if (ssgradlipj.gt.0.0d0) print *,"??WTF??"
1728 C      print *,sslipi,sslipj,bordlipbot,zi,zj
1729       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
1730       xj_safe=xj
1731       yj_safe=yj
1732       zj_safe=zj
1733       subchap=0
1734       do xshift=-1,1
1735       do yshift=-1,1
1736       do zshift=-1,1
1737           xj=xj_safe+xshift*boxxsize
1738           yj=yj_safe+yshift*boxysize
1739           zj=zj_safe+zshift*boxzsize
1740           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
1741           if(dist_temp.lt.dist_init) then
1742             dist_init=dist_temp
1743             xj_temp=xj
1744             yj_temp=yj
1745             zj_temp=zj
1746             subchap=1
1747           endif
1748        enddo
1749        enddo
1750        enddo
1751        if (subchap.eq.1) then
1752           xj=xj_temp-xi
1753           yj=yj_temp-yi
1754           zj=zj_temp-zi
1755        else
1756           xj=xj_safe-xi
1757           yj=yj_safe-yi
1758           zj=zj_safe-zi
1759        endif
1760             dxj=dc_norm(1,nres+j)
1761             dyj=dc_norm(2,nres+j)
1762             dzj=dc_norm(3,nres+j)
1763 C            xj=xj-xi
1764 C            yj=yj-yi
1765 C            zj=zj-zi
1766 c            write (iout,*) "dcnorj",dxi*dxi+dyi*dyi+dzi*dzi
1767 c            write (iout,*) "j",j," dc_norm",
1768 c     &       dc_norm(1,nres+j),dc_norm(2,nres+j),dc_norm(3,nres+j)
1769             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1770             rij=dsqrt(rrij)
1771             sss=sscale((1.0d0/rij)/sigma(itypi,itypj))
1772             sssgrad=sscagrad((1.0d0/rij)/sigma(itypi,itypj))
1773
1774 c            write (iout,'(a7,4f8.3)')
1775 c    &      "ssscale",sss,((1.0d0/rij)/sigma(itypi,itypj)),r_cut,rlamb
1776             if (sss.gt.0.0d0) then
1777 C Calculate angle-dependent terms of energy and contributions to their
1778 C derivatives.
1779             call sc_angular
1780             sigsq=1.0D0/sigsq
1781             sig=sig0ij*dsqrt(sigsq)
1782             rij_shift=1.0D0/rij-sig+sig0ij
1783 c for diagnostics; uncomment
1784 c            rij_shift=1.2*sig0ij
1785 C I hate to put IF's in the loops, but here don't have another choice!!!!
1786             if (rij_shift.le.0.0D0) then
1787               evdw=1.0D20
1788 cd              write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1789 cd     &        restyp(itypi),i,restyp(itypj),j,
1790 cd     &        rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq)
1791               return
1792             endif
1793             sigder=-sig*sigsq
1794 c---------------------------------------------------------------
1795             rij_shift=1.0D0/rij_shift
1796             fac=rij_shift**expon
1797 C here to start with
1798 C            if (c(i,3).gt.
1799             faclip=fac
1800             e1=fac*fac*aa
1801             e2=fac*bb
1802             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1803             eps2der=evdwij*eps3rt
1804             eps3der=evdwij*eps2rt
1805 C       write(63,'(2i3,2e10.3,2f10.5)') i,j,aa,bb, evdwij,
1806 C     &((sslipi+sslipj)/2.0d0+
1807 C     &(2.0d0-sslipi-sslipj)/2.0d0)
1808 c            write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt,
1809 c     &        " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2
1810             evdwij=evdwij*eps2rt*eps3rt
1811             evdw=evdw+evdwij*sss
1812             if (lprn) then
1813             sigm=dabs(aa/bb)**(1.0D0/6.0D0)
1814             epsi=bb**2/aa
1815             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1816      &        restyp(itypi),i,restyp(itypj),j,
1817      &        epsi,sigm,chi1,chi2,chip1,chip2,
1818      &        eps1,eps2rt**2,eps3rt**2,sig,sig0ij,
1819      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1820      &        evdwij
1821             endif
1822
1823             if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
1824      &                        'evdw',i,j,evdwij
1825
1826 C Calculate gradient components.
1827             e1=e1*eps1*eps2rt**2*eps3rt**2
1828             fac=-expon*(e1+evdwij)*rij_shift
1829             sigder=fac*sigder
1830             fac=rij*fac
1831 c            print '(2i4,6f8.4)',i,j,sss,sssgrad*
1832 c     &      evdwij,fac,sigma(itypi,itypj),expon
1833             fac=fac+evdwij/sss*sssgrad/sigma(itypi,itypj)*rij
1834 c            fac=0.0d0
1835 C Calculate the radial part of the gradient
1836             gg_lipi(3)=eps1*(eps2rt*eps2rt)
1837      &*(eps3rt*eps3rt)*sss/2.0d0*(faclip*faclip*
1838      & (aa_lip(itypi,itypj)-aa_aq(itypi,itypj))
1839      &+faclip*(bb_lip(itypi,itypj)-bb_aq(itypi,itypj)))
1840             gg_lipj(3)=ssgradlipj*gg_lipi(3)
1841             gg_lipi(3)=gg_lipi(3)*ssgradlipi
1842 C            gg_lipi(3)=0.0d0
1843 C            gg_lipj(3)=0.0d0
1844             gg(1)=xj*fac
1845             gg(2)=yj*fac
1846             gg(3)=zj*fac
1847 C Calculate angular part of the gradient.
1848             call sc_grad
1849             endif
1850             ENDIF    ! dyn_ss
1851           enddo      ! j
1852         enddo        ! iint
1853       enddo          ! i
1854 C      enddo          ! zshift
1855 C      enddo          ! yshift
1856 C      enddo          ! xshift
1857 c      write (iout,*) "Number of loop steps in EGB:",ind
1858 cccc      energy_dec=.false.
1859       return
1860       end
1861 C-----------------------------------------------------------------------------
1862       subroutine egbv(evdw)
1863 C
1864 C This subroutine calculates the interaction energy of nonbonded side chains
1865 C assuming the Gay-Berne-Vorobjev potential of interaction.
1866 C
1867       implicit real*8 (a-h,o-z)
1868       include 'DIMENSIONS'
1869       include 'COMMON.GEO'
1870       include 'COMMON.VAR'
1871       include 'COMMON.LOCAL'
1872       include 'COMMON.CHAIN'
1873       include 'COMMON.DERIV'
1874       include 'COMMON.NAMES'
1875       include 'COMMON.INTERACT'
1876       include 'COMMON.IOUNITS'
1877       include 'COMMON.CALC'
1878       common /srutu/ icall
1879       logical lprn
1880       evdw=0.0D0
1881 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1882       evdw=0.0D0
1883       lprn=.false.
1884 c     if (icall.eq.0) lprn=.true.
1885       ind=0
1886       do i=iatsc_s,iatsc_e
1887         itypi=iabs(itype(i))
1888         if (itypi.eq.ntyp1) cycle
1889         itypi1=iabs(itype(i+1))
1890         xi=c(1,nres+i)
1891         yi=c(2,nres+i)
1892         zi=c(3,nres+i)
1893           xi=mod(xi,boxxsize)
1894           if (xi.lt.0) xi=xi+boxxsize
1895           yi=mod(yi,boxysize)
1896           if (yi.lt.0) yi=yi+boxysize
1897           zi=mod(zi,boxzsize)
1898           if (zi.lt.0) zi=zi+boxzsize
1899 C define scaling factor for lipids
1900
1901 C        if (positi.le.0) positi=positi+boxzsize
1902 C        print *,i
1903 C first for peptide groups
1904 c for each residue check if it is in lipid or lipid water border area
1905        if ((zi.gt.bordlipbot)
1906      &.and.(zi.lt.bordliptop)) then
1907 C the energy transfer exist
1908         if (zi.lt.buflipbot) then
1909 C what fraction I am in
1910          fracinbuf=1.0d0-
1911      &        ((zi-bordlipbot)/lipbufthick)
1912 C lipbufthick is thickenes of lipid buffore
1913          sslipi=sscalelip(fracinbuf)
1914          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
1915         elseif (zi.gt.bufliptop) then
1916          fracinbuf=1.0d0-((bordliptop-zi)/lipbufthick)
1917          sslipi=sscalelip(fracinbuf)
1918          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
1919         else
1920          sslipi=1.0d0
1921          ssgradlipi=0.0
1922         endif
1923        else
1924          sslipi=0.0d0
1925          ssgradlipi=0.0
1926        endif
1927
1928         dxi=dc_norm(1,nres+i)
1929         dyi=dc_norm(2,nres+i)
1930         dzi=dc_norm(3,nres+i)
1931 c        dsci_inv=dsc_inv(itypi)
1932         dsci_inv=vbld_inv(i+nres)
1933 C
1934 C Calculate SC interaction energy.
1935 C
1936         do iint=1,nint_gr(i)
1937           do j=istart(i,iint),iend(i,iint)
1938             ind=ind+1
1939             itypj=iabs(itype(j))
1940             if (itypj.eq.ntyp1) cycle
1941 c            dscj_inv=dsc_inv(itypj)
1942             dscj_inv=vbld_inv(j+nres)
1943             sig0ij=sigma(itypi,itypj)
1944             r0ij=r0(itypi,itypj)
1945             chi1=chi(itypi,itypj)
1946             chi2=chi(itypj,itypi)
1947             chi12=chi1*chi2
1948             chip1=chip(itypi)
1949             chip2=chip(itypj)
1950             chip12=chip1*chip2
1951             alf1=alp(itypi)
1952             alf2=alp(itypj)
1953             alf12=0.5D0*(alf1+alf2)
1954 C For diagnostics only!!!
1955 c           chi1=0.0D0
1956 c           chi2=0.0D0
1957 c           chi12=0.0D0
1958 c           chip1=0.0D0
1959 c           chip2=0.0D0
1960 c           chip12=0.0D0
1961 c           alf1=0.0D0
1962 c           alf2=0.0D0
1963 c           alf12=0.0D0
1964 C            xj=c(1,nres+j)-xi
1965 C            yj=c(2,nres+j)-yi
1966 C            zj=c(3,nres+j)-zi
1967           xj=mod(xj,boxxsize)
1968           if (xj.lt.0) xj=xj+boxxsize
1969           yj=mod(yj,boxysize)
1970           if (yj.lt.0) yj=yj+boxysize
1971           zj=mod(zj,boxzsize)
1972           if (zj.lt.0) zj=zj+boxzsize
1973        if ((zj.gt.bordlipbot)
1974      &.and.(zj.lt.bordliptop)) then
1975 C the energy transfer exist
1976         if (zj.lt.buflipbot) then
1977 C what fraction I am in
1978          fracinbuf=1.0d0-
1979      &        ((zj-bordlipbot)/lipbufthick)
1980 C lipbufthick is thickenes of lipid buffore
1981          sslipj=sscalelip(fracinbuf)
1982          ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
1983         elseif (zj.gt.bufliptop) then
1984          fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
1985          sslipj=sscalelip(fracinbuf)
1986          ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
1987         else
1988          sslipj=1.0d0
1989          ssgradlipj=0.0
1990         endif
1991        else
1992          sslipj=0.0d0
1993          ssgradlipj=0.0
1994        endif
1995       aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
1996      &  +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1997       bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
1998      &  +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1999 C      if (aa.ne.aa_aq(itypi,itypj)) write(63,'2e10.5')
2000 C     &(aa-aa_aq(itypi,itypj)),(bb-bb_aq(itypi,itypj))
2001       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
2002       xj_safe=xj
2003       yj_safe=yj
2004       zj_safe=zj
2005       subchap=0
2006       do xshift=-1,1
2007       do yshift=-1,1
2008       do zshift=-1,1
2009           xj=xj_safe+xshift*boxxsize
2010           yj=yj_safe+yshift*boxysize
2011           zj=zj_safe+zshift*boxzsize
2012           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
2013           if(dist_temp.lt.dist_init) then
2014             dist_init=dist_temp
2015             xj_temp=xj
2016             yj_temp=yj
2017             zj_temp=zj
2018             subchap=1
2019           endif
2020        enddo
2021        enddo
2022        enddo
2023        if (subchap.eq.1) then
2024           xj=xj_temp-xi
2025           yj=yj_temp-yi
2026           zj=zj_temp-zi
2027        else
2028           xj=xj_safe-xi
2029           yj=yj_safe-yi
2030           zj=zj_safe-zi
2031        endif
2032             dxj=dc_norm(1,nres+j)
2033             dyj=dc_norm(2,nres+j)
2034             dzj=dc_norm(3,nres+j)
2035             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
2036             rij=dsqrt(rrij)
2037 C Calculate angle-dependent terms of energy and contributions to their
2038 C derivatives.
2039             call sc_angular
2040             sigsq=1.0D0/sigsq
2041             sig=sig0ij*dsqrt(sigsq)
2042             rij_shift=1.0D0/rij-sig+r0ij
2043 C I hate to put IF's in the loops, but here don't have another choice!!!!
2044             if (rij_shift.le.0.0D0) then
2045               evdw=1.0D20
2046               return
2047             endif
2048             sigder=-sig*sigsq
2049 c---------------------------------------------------------------
2050             rij_shift=1.0D0/rij_shift
2051             fac=rij_shift**expon
2052             e1=fac*fac*aa
2053             e2=fac*bb
2054             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
2055             eps2der=evdwij*eps3rt
2056             eps3der=evdwij*eps2rt
2057             fac_augm=rrij**expon
2058             e_augm=augm(itypi,itypj)*fac_augm
2059             evdwij=evdwij*eps2rt*eps3rt
2060             evdw=evdw+evdwij+e_augm
2061             if (lprn) then
2062             sigm=dabs(aa/bb)**(1.0D0/6.0D0)
2063             epsi=bb**2/aa
2064             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
2065      &        restyp(itypi),i,restyp(itypj),j,
2066      &        epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),
2067      &        chi1,chi2,chip1,chip2,
2068      &        eps1,eps2rt**2,eps3rt**2,
2069      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
2070      &        evdwij+e_augm
2071             endif
2072 C Calculate gradient components.
2073             e1=e1*eps1*eps2rt**2*eps3rt**2
2074             fac=-expon*(e1+evdwij)*rij_shift
2075             sigder=fac*sigder
2076             fac=rij*fac-2*expon*rrij*e_augm
2077             fac=fac+evdwij/sss*sssgrad/sigma(itypi,itypj)*rij
2078 C Calculate the radial part of the gradient
2079             gg(1)=xj*fac
2080             gg(2)=yj*fac
2081             gg(3)=zj*fac
2082 C Calculate angular part of the gradient.
2083             call sc_grad
2084           enddo      ! j
2085         enddo        ! iint
2086       enddo          ! i
2087       end
2088 C-----------------------------------------------------------------------------
2089       subroutine sc_angular
2090 C Calculate eps1,eps2,eps3,sigma, and parts of their derivatives in om1,om2,
2091 C om12. Called by ebp, egb, and egbv.
2092       implicit none
2093       include 'COMMON.CALC'
2094       include 'COMMON.IOUNITS'
2095       erij(1)=xj*rij
2096       erij(2)=yj*rij
2097       erij(3)=zj*rij
2098       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
2099       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
2100       om12=dxi*dxj+dyi*dyj+dzi*dzj
2101       chiom12=chi12*om12
2102 C Calculate eps1(om12) and its derivative in om12
2103       faceps1=1.0D0-om12*chiom12
2104       faceps1_inv=1.0D0/faceps1
2105       eps1=dsqrt(faceps1_inv)
2106 C Following variable is eps1*deps1/dom12
2107       eps1_om12=faceps1_inv*chiom12
2108 c diagnostics only
2109 c      faceps1_inv=om12
2110 c      eps1=om12
2111 c      eps1_om12=1.0d0
2112 c      write (iout,*) "om12",om12," eps1",eps1
2113 C Calculate sigma(om1,om2,om12) and the derivatives of sigma**2 in om1,om2,
2114 C and om12.
2115       om1om2=om1*om2
2116       chiom1=chi1*om1
2117       chiom2=chi2*om2
2118       facsig=om1*chiom1+om2*chiom2-2.0D0*om1om2*chiom12
2119       sigsq=1.0D0-facsig*faceps1_inv
2120       sigsq_om1=(chiom1-chiom12*om2)*faceps1_inv
2121       sigsq_om2=(chiom2-chiom12*om1)*faceps1_inv
2122       sigsq_om12=-chi12*(om1om2*faceps1-om12*facsig)*faceps1_inv**2
2123 c diagnostics only
2124 c      sigsq=1.0d0
2125 c      sigsq_om1=0.0d0
2126 c      sigsq_om2=0.0d0
2127 c      sigsq_om12=0.0d0
2128 c      write (iout,*) "chiom1",chiom1," chiom2",chiom2," chiom12",chiom12
2129 c      write (iout,*) "faceps1",faceps1," faceps1_inv",faceps1_inv,
2130 c     &    " eps1",eps1
2131 C Calculate eps2 and its derivatives in om1, om2, and om12.
2132       chipom1=chip1*om1
2133       chipom2=chip2*om2
2134       chipom12=chip12*om12
2135       facp=1.0D0-om12*chipom12
2136       facp_inv=1.0D0/facp
2137       facp1=om1*chipom1+om2*chipom2-2.0D0*om1om2*chipom12
2138 c      write (iout,*) "chipom1",chipom1," chipom2",chipom2,
2139 c     &  " chipom12",chipom12," facp",facp," facp_inv",facp_inv
2140 C Following variable is the square root of eps2
2141       eps2rt=1.0D0-facp1*facp_inv
2142 C Following three variables are the derivatives of the square root of eps
2143 C in om1, om2, and om12.
2144       eps2rt_om1=-4.0D0*(chipom1-chipom12*om2)*facp_inv
2145       eps2rt_om2=-4.0D0*(chipom2-chipom12*om1)*facp_inv
2146       eps2rt_om12=4.0D0*chip12*(om1om2*facp-om12*facp1)*facp_inv**2
2147 C Evaluate the "asymmetric" factor in the VDW constant, eps3
2148       eps3rt=1.0D0-alf1*om1+alf2*om2-alf12*om12
2149 c      write (iout,*) "eps2rt",eps2rt," eps3rt",eps3rt
2150 c      write (iout,*) "eps2rt_om1",eps2rt_om1," eps2rt_om2",eps2rt_om2,
2151 c     &  " eps2rt_om12",eps2rt_om12
2152 C Calculate whole angle-dependent part of epsilon and contributions
2153 C to its derivatives
2154       return
2155       end
2156 C----------------------------------------------------------------------------
2157       subroutine sc_grad
2158       implicit real*8 (a-h,o-z)
2159       include 'DIMENSIONS'
2160       include 'COMMON.CHAIN'
2161       include 'COMMON.DERIV'
2162       include 'COMMON.CALC'
2163       include 'COMMON.IOUNITS'
2164       double precision dcosom1(3),dcosom2(3)
2165 cc      print *,'sss=',sss
2166       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
2167       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
2168       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12
2169      &     -2.0D0*alf12*eps3der+sigder*sigsq_om12
2170 c diagnostics only
2171 c      eom1=0.0d0
2172 c      eom2=0.0d0
2173 c      eom12=evdwij*eps1_om12
2174 c end diagnostics
2175 c      write (iout,*) "eps2der",eps2der," eps3der",eps3der,
2176 c     &  " sigder",sigder
2177 c      write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12
2178 c      write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12
2179       do k=1,3
2180         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
2181         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
2182       enddo
2183       do k=1,3
2184         gg(k)=(gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k))*sss
2185       enddo
2186 c      write (iout,*) "gg",(gg(k),k=1,3)
2187       do k=1,3
2188         gvdwx(k,i)=gvdwx(k,i)-gg(k)+gg_lipi(k)
2189      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
2190      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv*sss
2191         gvdwx(k,j)=gvdwx(k,j)+gg(k)+gg_lipj(k)
2192      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
2193      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv*sss
2194 c        write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
2195 c     &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
2196 c        write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
2197 c     &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
2198       enddo
2199 C
2200 C Calculate the components of the gradient in DC and X
2201 C
2202 cgrad      do k=i,j-1
2203 cgrad        do l=1,3
2204 cgrad          gvdwc(l,k)=gvdwc(l,k)+gg(l)
2205 cgrad        enddo
2206 cgrad      enddo
2207       do l=1,3
2208         gvdwc(l,i)=gvdwc(l,i)-gg(l)+gg_lipi(l)
2209         gvdwc(l,j)=gvdwc(l,j)+gg(l)+gg_lipj(l)
2210       enddo
2211       return
2212       end
2213 C-----------------------------------------------------------------------
2214       subroutine e_softsphere(evdw)
2215 C
2216 C This subroutine calculates the interaction energy of nonbonded side chains
2217 C assuming the LJ potential of interaction.
2218 C
2219       implicit real*8 (a-h,o-z)
2220       include 'DIMENSIONS'
2221       parameter (accur=1.0d-10)
2222       include 'COMMON.GEO'
2223       include 'COMMON.VAR'
2224       include 'COMMON.LOCAL'
2225       include 'COMMON.CHAIN'
2226       include 'COMMON.DERIV'
2227       include 'COMMON.INTERACT'
2228       include 'COMMON.TORSION'
2229       include 'COMMON.SBRIDGE'
2230       include 'COMMON.NAMES'
2231       include 'COMMON.IOUNITS'
2232       include 'COMMON.CONTACTS'
2233       dimension gg(3)
2234 cd    print *,'Entering Esoft_sphere nnt=',nnt,' nct=',nct
2235       evdw=0.0D0
2236       do i=iatsc_s,iatsc_e
2237         itypi=iabs(itype(i))
2238         if (itypi.eq.ntyp1) cycle
2239         itypi1=iabs(itype(i+1))
2240         xi=c(1,nres+i)
2241         yi=c(2,nres+i)
2242         zi=c(3,nres+i)
2243 C
2244 C Calculate SC interaction energy.
2245 C
2246         do iint=1,nint_gr(i)
2247 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
2248 cd   &                  'iend=',iend(i,iint)
2249           do j=istart(i,iint),iend(i,iint)
2250             itypj=iabs(itype(j))
2251             if (itypj.eq.ntyp1) cycle
2252             xj=c(1,nres+j)-xi
2253             yj=c(2,nres+j)-yi
2254             zj=c(3,nres+j)-zi
2255             rij=xj*xj+yj*yj+zj*zj
2256 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
2257             r0ij=r0(itypi,itypj)
2258             r0ijsq=r0ij*r0ij
2259 c            print *,i,j,r0ij,dsqrt(rij)
2260             if (rij.lt.r0ijsq) then
2261               evdwij=0.25d0*(rij-r0ijsq)**2
2262               fac=rij-r0ijsq
2263             else
2264               evdwij=0.0d0
2265               fac=0.0d0
2266             endif
2267             evdw=evdw+evdwij
2268 C
2269 C Calculate the components of the gradient in DC and X
2270 C
2271             gg(1)=xj*fac
2272             gg(2)=yj*fac
2273             gg(3)=zj*fac
2274             do k=1,3
2275               gvdwx(k,i)=gvdwx(k,i)-gg(k)
2276               gvdwx(k,j)=gvdwx(k,j)+gg(k)
2277               gvdwc(k,i)=gvdwc(k,i)-gg(k)
2278               gvdwc(k,j)=gvdwc(k,j)+gg(k)
2279             enddo
2280 cgrad            do k=i,j-1
2281 cgrad              do l=1,3
2282 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
2283 cgrad              enddo
2284 cgrad            enddo
2285           enddo ! j
2286         enddo ! iint
2287       enddo ! i
2288       return
2289       end
2290 C--------------------------------------------------------------------------
2291       subroutine eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,
2292      &              eello_turn4)
2293 C
2294 C Soft-sphere potential of p-p interaction
2295 C
2296       implicit real*8 (a-h,o-z)
2297       include 'DIMENSIONS'
2298       include 'COMMON.CONTROL'
2299       include 'COMMON.IOUNITS'
2300       include 'COMMON.GEO'
2301       include 'COMMON.VAR'
2302       include 'COMMON.LOCAL'
2303       include 'COMMON.CHAIN'
2304       include 'COMMON.DERIV'
2305       include 'COMMON.INTERACT'
2306       include 'COMMON.CONTACTS'
2307       include 'COMMON.TORSION'
2308       include 'COMMON.VECTORS'
2309       include 'COMMON.FFIELD'
2310       dimension ggg(3)
2311 C      write(iout,*) 'In EELEC_soft_sphere'
2312       ees=0.0D0
2313       evdw1=0.0D0
2314       eel_loc=0.0d0
2315       eello_turn3=0.0d0
2316       eello_turn4=0.0d0
2317       ind=0
2318       do i=iatel_s,iatel_e
2319         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
2320         dxi=dc(1,i)
2321         dyi=dc(2,i)
2322         dzi=dc(3,i)
2323         xmedi=c(1,i)+0.5d0*dxi
2324         ymedi=c(2,i)+0.5d0*dyi
2325         zmedi=c(3,i)+0.5d0*dzi
2326           xmedi=mod(xmedi,boxxsize)
2327           if (xmedi.lt.0) xmedi=xmedi+boxxsize
2328           ymedi=mod(ymedi,boxysize)
2329           if (ymedi.lt.0) ymedi=ymedi+boxysize
2330           zmedi=mod(zmedi,boxzsize)
2331           if (zmedi.lt.0) zmedi=zmedi+boxzsize
2332         num_conti=0
2333 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
2334         do j=ielstart(i),ielend(i)
2335           if (itype(j).eq.ntyp1 .or. itype(j+1).eq.ntyp1) cycle
2336           ind=ind+1
2337           iteli=itel(i)
2338           itelj=itel(j)
2339           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
2340           r0ij=rpp(iteli,itelj)
2341           r0ijsq=r0ij*r0ij
2342           dxj=dc(1,j)
2343           dyj=dc(2,j)
2344           dzj=dc(3,j)
2345           xj=c(1,j)+0.5D0*dxj
2346           yj=c(2,j)+0.5D0*dyj
2347           zj=c(3,j)+0.5D0*dzj
2348           xj=mod(xj,boxxsize)
2349           if (xj.lt.0) xj=xj+boxxsize
2350           yj=mod(yj,boxysize)
2351           if (yj.lt.0) yj=yj+boxysize
2352           zj=mod(zj,boxzsize)
2353           if (zj.lt.0) zj=zj+boxzsize
2354       dist_init=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
2355       xj_safe=xj
2356       yj_safe=yj
2357       zj_safe=zj
2358       isubchap=0
2359       do xshift=-1,1
2360       do yshift=-1,1
2361       do zshift=-1,1
2362           xj=xj_safe+xshift*boxxsize
2363           yj=yj_safe+yshift*boxysize
2364           zj=zj_safe+zshift*boxzsize
2365           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
2366           if(dist_temp.lt.dist_init) then
2367             dist_init=dist_temp
2368             xj_temp=xj
2369             yj_temp=yj
2370             zj_temp=zj
2371             isubchap=1
2372           endif
2373        enddo
2374        enddo
2375        enddo
2376        if (isubchap.eq.1) then
2377           xj=xj_temp-xmedi
2378           yj=yj_temp-ymedi
2379           zj=zj_temp-zmedi
2380        else
2381           xj=xj_safe-xmedi
2382           yj=yj_safe-ymedi
2383           zj=zj_safe-zmedi
2384        endif
2385           rij=xj*xj+yj*yj+zj*zj
2386             sss=sscale(sqrt(rij))
2387             sssgrad=sscagrad(sqrt(rij))
2388           if (rij.lt.r0ijsq) then
2389             evdw1ij=0.25d0*(rij-r0ijsq)**2
2390             fac=rij-r0ijsq
2391           else
2392             evdw1ij=0.0d0
2393             fac=0.0d0
2394           endif
2395           evdw1=evdw1+evdw1ij*sss
2396 C
2397 C Calculate contributions to the Cartesian gradient.
2398 C
2399           ggg(1)=fac*xj*sssgrad
2400           ggg(2)=fac*yj*sssgrad
2401           ggg(3)=fac*zj*sssgrad
2402           do k=1,3
2403             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
2404             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
2405           enddo
2406 *
2407 * Loop over residues i+1 thru j-1.
2408 *
2409 cgrad          do k=i+1,j-1
2410 cgrad            do l=1,3
2411 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
2412 cgrad            enddo
2413 cgrad          enddo
2414         enddo ! j
2415       enddo   ! i
2416 cgrad      do i=nnt,nct-1
2417 cgrad        do k=1,3
2418 cgrad          gelc(k,i)=gelc(k,i)+0.5d0*gelc(k,i)
2419 cgrad        enddo
2420 cgrad        do j=i+1,nct-1
2421 cgrad          do k=1,3
2422 cgrad            gelc(k,i)=gelc(k,i)+gelc(k,j)
2423 cgrad          enddo
2424 cgrad        enddo
2425 cgrad      enddo
2426       return
2427       end
2428 c------------------------------------------------------------------------------
2429       subroutine vec_and_deriv
2430       implicit real*8 (a-h,o-z)
2431       include 'DIMENSIONS'
2432 #ifdef MPI
2433       include 'mpif.h'
2434 #endif
2435       include 'COMMON.IOUNITS'
2436       include 'COMMON.GEO'
2437       include 'COMMON.VAR'
2438       include 'COMMON.LOCAL'
2439       include 'COMMON.CHAIN'
2440       include 'COMMON.VECTORS'
2441       include 'COMMON.SETUP'
2442       include 'COMMON.TIME1'
2443       dimension uyder(3,3,2),uzder(3,3,2),vbld_inv_temp(2)
2444 C Compute the local reference systems. For reference system (i), the
2445 C X-axis points from CA(i) to CA(i+1), the Y axis is in the
2446 C CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
2447 #ifdef PARVEC
2448       do i=ivec_start,ivec_end
2449 #else
2450       do i=1,nres-1
2451 #endif
2452           if (i.eq.nres-1) then
2453 C Case of the last full residue
2454 C Compute the Z-axis
2455             call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
2456             costh=dcos(pi-theta(nres))
2457             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2458             do k=1,3
2459               uz(k,i)=fac*uz(k,i)
2460             enddo
2461 C Compute the derivatives of uz
2462             uzder(1,1,1)= 0.0d0
2463             uzder(2,1,1)=-dc_norm(3,i-1)
2464             uzder(3,1,1)= dc_norm(2,i-1)
2465             uzder(1,2,1)= dc_norm(3,i-1)
2466             uzder(2,2,1)= 0.0d0
2467             uzder(3,2,1)=-dc_norm(1,i-1)
2468             uzder(1,3,1)=-dc_norm(2,i-1)
2469             uzder(2,3,1)= dc_norm(1,i-1)
2470             uzder(3,3,1)= 0.0d0
2471             uzder(1,1,2)= 0.0d0
2472             uzder(2,1,2)= dc_norm(3,i)
2473             uzder(3,1,2)=-dc_norm(2,i)
2474             uzder(1,2,2)=-dc_norm(3,i)
2475             uzder(2,2,2)= 0.0d0
2476             uzder(3,2,2)= dc_norm(1,i)
2477             uzder(1,3,2)= dc_norm(2,i)
2478             uzder(2,3,2)=-dc_norm(1,i)
2479             uzder(3,3,2)= 0.0d0
2480 C Compute the Y-axis
2481             facy=fac
2482             do k=1,3
2483               uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
2484             enddo
2485 C Compute the derivatives of uy
2486             do j=1,3
2487               do k=1,3
2488                 uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i)
2489      &                        -dc_norm(k,i)*dc_norm(j,i-1)
2490                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2491               enddo
2492               uyder(j,j,1)=uyder(j,j,1)-costh
2493               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2494             enddo
2495             do j=1,2
2496               do k=1,3
2497                 do l=1,3
2498                   uygrad(l,k,j,i)=uyder(l,k,j)
2499                   uzgrad(l,k,j,i)=uzder(l,k,j)
2500                 enddo
2501               enddo
2502             enddo
2503             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2504             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2505             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2506             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2507           else
2508 C Other residues
2509 C Compute the Z-axis
2510             call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
2511             costh=dcos(pi-theta(i+2))
2512             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2513             do k=1,3
2514               uz(k,i)=fac*uz(k,i)
2515             enddo
2516 C Compute the derivatives of uz
2517             uzder(1,1,1)= 0.0d0
2518             uzder(2,1,1)=-dc_norm(3,i+1)
2519             uzder(3,1,1)= dc_norm(2,i+1)
2520             uzder(1,2,1)= dc_norm(3,i+1)
2521             uzder(2,2,1)= 0.0d0
2522             uzder(3,2,1)=-dc_norm(1,i+1)
2523             uzder(1,3,1)=-dc_norm(2,i+1)
2524             uzder(2,3,1)= dc_norm(1,i+1)
2525             uzder(3,3,1)= 0.0d0
2526             uzder(1,1,2)= 0.0d0
2527             uzder(2,1,2)= dc_norm(3,i)
2528             uzder(3,1,2)=-dc_norm(2,i)
2529             uzder(1,2,2)=-dc_norm(3,i)
2530             uzder(2,2,2)= 0.0d0
2531             uzder(3,2,2)= dc_norm(1,i)
2532             uzder(1,3,2)= dc_norm(2,i)
2533             uzder(2,3,2)=-dc_norm(1,i)
2534             uzder(3,3,2)= 0.0d0
2535 C Compute the Y-axis
2536             facy=fac
2537             do k=1,3
2538               uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
2539             enddo
2540 C Compute the derivatives of uy
2541             do j=1,3
2542               do k=1,3
2543                 uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i)
2544      &                        -dc_norm(k,i)*dc_norm(j,i+1)
2545                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2546               enddo
2547               uyder(j,j,1)=uyder(j,j,1)-costh
2548               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2549             enddo
2550             do j=1,2
2551               do k=1,3
2552                 do l=1,3
2553                   uygrad(l,k,j,i)=uyder(l,k,j)
2554                   uzgrad(l,k,j,i)=uzder(l,k,j)
2555                 enddo
2556               enddo
2557             enddo
2558             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2559             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2560             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2561             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2562           endif
2563       enddo
2564       do i=1,nres-1
2565         vbld_inv_temp(1)=vbld_inv(i+1)
2566         if (i.lt.nres-1) then
2567           vbld_inv_temp(2)=vbld_inv(i+2)
2568           else
2569           vbld_inv_temp(2)=vbld_inv(i)
2570           endif
2571         do j=1,2
2572           do k=1,3
2573             do l=1,3
2574               uygrad(l,k,j,i)=vbld_inv_temp(j)*uygrad(l,k,j,i)
2575               uzgrad(l,k,j,i)=vbld_inv_temp(j)*uzgrad(l,k,j,i)
2576             enddo
2577           enddo
2578         enddo
2579       enddo
2580 #if defined(PARVEC) && defined(MPI)
2581       if (nfgtasks1.gt.1) then
2582         time00=MPI_Wtime()
2583 c        print *,"Processor",fg_rank1,kolor1," ivec_start",ivec_start,
2584 c     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks1-1),
2585 c     &   " ivec_count",(ivec_count(i),i=0,nfgtasks1-1)
2586         call MPI_Allgatherv(uy(1,ivec_start),ivec_count(fg_rank1),
2587      &   MPI_UYZ,uy(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
2588      &   FG_COMM1,IERR)
2589         call MPI_Allgatherv(uz(1,ivec_start),ivec_count(fg_rank1),
2590      &   MPI_UYZ,uz(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
2591      &   FG_COMM1,IERR)
2592         call MPI_Allgatherv(uygrad(1,1,1,ivec_start),
2593      &   ivec_count(fg_rank1),MPI_UYZGRAD,uygrad(1,1,1,1),ivec_count(0),
2594      &   ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2595         call MPI_Allgatherv(uzgrad(1,1,1,ivec_start),
2596      &   ivec_count(fg_rank1),MPI_UYZGRAD,uzgrad(1,1,1,1),ivec_count(0),
2597      &   ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2598         time_gather=time_gather+MPI_Wtime()-time00
2599       endif
2600 c      if (fg_rank.eq.0) then
2601 c        write (iout,*) "Arrays UY and UZ"
2602 c        do i=1,nres-1
2603 c          write (iout,'(i5,3f10.5,5x,3f10.5)') i,(uy(k,i),k=1,3),
2604 c     &     (uz(k,i),k=1,3)
2605 c        enddo
2606 c      endif
2607 #endif
2608       return
2609       end
2610 C-----------------------------------------------------------------------------
2611       subroutine check_vecgrad
2612       implicit real*8 (a-h,o-z)
2613       include 'DIMENSIONS'
2614       include 'COMMON.IOUNITS'
2615       include 'COMMON.GEO'
2616       include 'COMMON.VAR'
2617       include 'COMMON.LOCAL'
2618       include 'COMMON.CHAIN'
2619       include 'COMMON.VECTORS'
2620       dimension uygradt(3,3,2,maxres),uzgradt(3,3,2,maxres)
2621       dimension uyt(3,maxres),uzt(3,maxres)
2622       dimension uygradn(3,3,2),uzgradn(3,3,2),erij(3)
2623       double precision delta /1.0d-7/
2624       call vec_and_deriv
2625 cd      do i=1,nres
2626 crc          write(iout,'(2i5,2(3f10.5,5x))') i,1,dc_norm(:,i)
2627 crc          write(iout,'(2i5,2(3f10.5,5x))') i,2,uy(:,i)
2628 crc          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,uz(:,i)
2629 cd          write(iout,'(2i5,2(3f10.5,5x))') i,1,
2630 cd     &     (dc_norm(if90,i),if90=1,3)
2631 cd          write(iout,'(2i5,2(3f10.5,5x))') i,2,(uy(if90,i),if90=1,3)
2632 cd          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,(uz(if90,i),if90=1,3)
2633 cd          write(iout,'(a)')
2634 cd      enddo
2635       do i=1,nres
2636         do j=1,2
2637           do k=1,3
2638             do l=1,3
2639               uygradt(l,k,j,i)=uygrad(l,k,j,i)
2640               uzgradt(l,k,j,i)=uzgrad(l,k,j,i)
2641             enddo
2642           enddo
2643         enddo
2644       enddo
2645       call vec_and_deriv
2646       do i=1,nres
2647         do j=1,3
2648           uyt(j,i)=uy(j,i)
2649           uzt(j,i)=uz(j,i)
2650         enddo
2651       enddo
2652       do i=1,nres
2653 cd        write (iout,*) 'i=',i
2654         do k=1,3
2655           erij(k)=dc_norm(k,i)
2656         enddo
2657         do j=1,3
2658           do k=1,3
2659             dc_norm(k,i)=erij(k)
2660           enddo
2661           dc_norm(j,i)=dc_norm(j,i)+delta
2662 c          fac=dsqrt(scalar(dc_norm(1,i),dc_norm(1,i)))
2663 c          do k=1,3
2664 c            dc_norm(k,i)=dc_norm(k,i)/fac
2665 c          enddo
2666 c          write (iout,*) (dc_norm(k,i),k=1,3)
2667 c          write (iout,*) (erij(k),k=1,3)
2668           call vec_and_deriv
2669           do k=1,3
2670             uygradn(k,j,1)=(uy(k,i)-uyt(k,i))/delta
2671             uygradn(k,j,2)=(uy(k,i-1)-uyt(k,i-1))/delta
2672             uzgradn(k,j,1)=(uz(k,i)-uzt(k,i))/delta
2673             uzgradn(k,j,2)=(uz(k,i-1)-uzt(k,i-1))/delta
2674           enddo
2675 c          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2676 c     &      j,(uzgradt(k,j,1,i),k=1,3),(uzgradn(k,j,1),k=1,3),
2677 c     &      (uzgradt(k,j,2,i-1),k=1,3),(uzgradn(k,j,2),k=1,3)
2678         enddo
2679         do k=1,3
2680           dc_norm(k,i)=erij(k)
2681         enddo
2682 cd        do k=1,3
2683 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2684 cd     &      k,(uygradt(k,l,1,i),l=1,3),(uygradn(k,l,1),l=1,3),
2685 cd     &      (uygradt(k,l,2,i-1),l=1,3),(uygradn(k,l,2),l=1,3)
2686 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2687 cd     &      k,(uzgradt(k,l,1,i),l=1,3),(uzgradn(k,l,1),l=1,3),
2688 cd     &      (uzgradt(k,l,2,i-1),l=1,3),(uzgradn(k,l,2),l=1,3)
2689 cd          write (iout,'(a)')
2690 cd        enddo
2691       enddo
2692       return
2693       end
2694 C--------------------------------------------------------------------------
2695       subroutine set_matrices
2696       implicit real*8 (a-h,o-z)
2697       include 'DIMENSIONS'
2698 #ifdef MPI
2699       include "mpif.h"
2700       include "COMMON.SETUP"
2701       integer IERR
2702       integer status(MPI_STATUS_SIZE)
2703 #endif
2704       include 'COMMON.IOUNITS'
2705       include 'COMMON.GEO'
2706       include 'COMMON.VAR'
2707       include 'COMMON.LOCAL'
2708       include 'COMMON.CHAIN'
2709       include 'COMMON.DERIV'
2710       include 'COMMON.INTERACT'
2711       include 'COMMON.CONTACTS'
2712       include 'COMMON.TORSION'
2713       include 'COMMON.VECTORS'
2714       include 'COMMON.FFIELD'
2715       double precision auxvec(2),auxmat(2,2)
2716 C
2717 C Compute the virtual-bond-torsional-angle dependent quantities needed
2718 C to calculate the el-loc multibody terms of various order.
2719 C
2720 c      write(iout,*) 'nphi=',nphi,nres
2721 #ifdef PARMAT
2722       do i=ivec_start+2,ivec_end+2
2723 #else
2724       do i=3,nres+1
2725 #endif
2726 #ifdef NEWCORR
2727         if (i.gt. nnt+2 .and. i.lt.nct+2) then
2728           iti = itortyp(itype(i-2))
2729         else
2730           iti=ntortyp+1
2731         endif
2732 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2733         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2734           iti1 = itortyp(itype(i-1))
2735         else
2736           iti1=ntortyp+1
2737         endif
2738 c        write(iout,*),i
2739         b1(1,i-2)=bnew1(1,1,iti)*dsin(theta(i-1)/2.0)
2740      &           +bnew1(2,1,iti)*dsin(theta(i-1))
2741      &           +bnew1(3,1,iti)*dcos(theta(i-1)/2.0)
2742         gtb1(1,i-2)=bnew1(1,1,iti)*dcos(theta(i-1)/2.0d0)/2.0d0
2743      &             +bnew1(2,1,iti)*dcos(theta(i-1))
2744      &             -bnew1(3,1,iti)*dsin(theta(i-1)/2.0d0)/2.0d0
2745 c     &           +bnew1(3,1,iti)*sin(alpha(i))*cos(beta(i))
2746 c     &*(cos(theta(i)/2.0)
2747         b2(1,i-2)=bnew2(1,1,iti)*dsin(theta(i-1)/2.0)
2748      &           +bnew2(2,1,iti)*dsin(theta(i-1))
2749      &           +bnew2(3,1,iti)*dcos(theta(i-1)/2.0)
2750 c     &           +bnew2(3,1,iti)*sin(alpha(i))*cos(beta(i))
2751 c     &*(cos(theta(i)/2.0)
2752         gtb2(1,i-2)=bnew2(1,1,iti)*dcos(theta(i-1)/2.0d0)/2.0d0
2753      &             +bnew2(2,1,iti)*dcos(theta(i-1))
2754      &             -bnew2(3,1,iti)*dsin(theta(i-1)/2.0d0)/2.0d0
2755 c        if (ggb1(1,i).eq.0.0d0) then
2756 c        write(iout,*) 'i=',i,ggb1(1,i),
2757 c     &bnew1(1,1,iti)*cos(theta(i)/2.0)/2.0,
2758 c     &bnew1(2,1,iti)*cos(theta(i)),
2759 c     &bnew1(3,1,iti)*sin(theta(i)/2.0)/2.0
2760 c        endif
2761         b1(2,i-2)=bnew1(1,2,iti)
2762         gtb1(2,i-2)=0.0
2763         b2(2,i-2)=bnew2(1,2,iti)
2764         gtb2(2,i-2)=0.0
2765         EE(1,1,i-2)=eenew(1,iti)*dcos(theta(i-1))
2766         EE(1,2,i-2)=eeold(1,2,iti)
2767         EE(2,1,i-2)=eeold(2,1,iti)
2768         EE(2,2,i-2)=eeold(2,2,iti)
2769         gtEE(1,1,i-2)=-eenew(1,iti)*dsin(theta(i-1))
2770         gtEE(1,2,i-2)=0.0d0
2771         gtEE(2,2,i-2)=0.0d0
2772         gtEE(2,1,i-2)=0.0d0
2773 c        EE(2,2,iti)=0.0d0
2774 c        EE(1,2,iti)=0.5d0*eenew(1,iti)
2775 c        EE(2,1,iti)=0.5d0*eenew(1,iti)
2776 c        b1(2,iti)=bnew1(1,2,iti)*sin(alpha(i))*sin(beta(i))
2777 c        b2(2,iti)=bnew2(1,2,iti)*sin(alpha(i))*sin(beta(i))
2778        b1tilde(1,i-2)=b1(1,i-2)
2779        b1tilde(2,i-2)=-b1(2,i-2)
2780        b2tilde(1,i-2)=b2(1,i-2)
2781        b2tilde(2,i-2)=-b2(2,i-2)
2782 c       write (iout,*) 'i=',i-2,gtb1(2,i-2),gtb1(1,i-2)
2783 c       write(iout,*)  'b1=',b1(1,i-2)
2784 c       write (iout,*) 'theta=', theta(i-1)
2785         enddo
2786 #else
2787         if (i.gt. nnt+2 .and. i.lt.nct+2) then
2788           iti = itortyp(itype(i-2))
2789         else
2790           iti=ntortyp+1
2791         endif
2792 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2793         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2794           iti1 = itortyp(itype(i-1))
2795         else
2796           iti1=ntortyp+1
2797         endif
2798         b1(1,i-2)=b(3,iti)
2799         b1(2,i-2)=b(5,iti)
2800         b2(1,i-2)=b(2,iti)
2801         b2(2,i-2)=b(4,iti)
2802         b1tilde(1,i-2)= b1(1,i-2)
2803         b1tilde(2,i-2)=-b1(2,i-2)
2804         b2tilde(1,i-2)= b2(1,i-2)
2805         b2tilde(2,i-2)=-b2(2,i-2)
2806         EE(1,2,i-2)=eeold(1,2,iti)
2807         EE(2,1,i-2)=eeold(2,1,iti)
2808         EE(2,2,i-2)=eeold(2,2,iti)
2809         EE(1,1,i-2)=eeold(1,1,iti)
2810       enddo
2811 #endif
2812 #ifdef PARMAT
2813       do i=ivec_start+2,ivec_end+2
2814 #else
2815       do i=3,nres+1
2816 #endif
2817         if (i .lt. nres+1) then
2818           sin1=dsin(phi(i))
2819           cos1=dcos(phi(i))
2820           sintab(i-2)=sin1
2821           costab(i-2)=cos1
2822           obrot(1,i-2)=cos1
2823           obrot(2,i-2)=sin1
2824           sin2=dsin(2*phi(i))
2825           cos2=dcos(2*phi(i))
2826           sintab2(i-2)=sin2
2827           costab2(i-2)=cos2
2828           obrot2(1,i-2)=cos2
2829           obrot2(2,i-2)=sin2
2830           Ug(1,1,i-2)=-cos1
2831           Ug(1,2,i-2)=-sin1
2832           Ug(2,1,i-2)=-sin1
2833           Ug(2,2,i-2)= cos1
2834           Ug2(1,1,i-2)=-cos2
2835           Ug2(1,2,i-2)=-sin2
2836           Ug2(2,1,i-2)=-sin2
2837           Ug2(2,2,i-2)= cos2
2838         else
2839           costab(i-2)=1.0d0
2840           sintab(i-2)=0.0d0
2841           obrot(1,i-2)=1.0d0
2842           obrot(2,i-2)=0.0d0
2843           obrot2(1,i-2)=0.0d0
2844           obrot2(2,i-2)=0.0d0
2845           Ug(1,1,i-2)=1.0d0
2846           Ug(1,2,i-2)=0.0d0
2847           Ug(2,1,i-2)=0.0d0
2848           Ug(2,2,i-2)=1.0d0
2849           Ug2(1,1,i-2)=0.0d0
2850           Ug2(1,2,i-2)=0.0d0
2851           Ug2(2,1,i-2)=0.0d0
2852           Ug2(2,2,i-2)=0.0d0
2853         endif
2854         if (i .gt. 3 .and. i .lt. nres+1) then
2855           obrot_der(1,i-2)=-sin1
2856           obrot_der(2,i-2)= cos1
2857           Ugder(1,1,i-2)= sin1
2858           Ugder(1,2,i-2)=-cos1
2859           Ugder(2,1,i-2)=-cos1
2860           Ugder(2,2,i-2)=-sin1
2861           dwacos2=cos2+cos2
2862           dwasin2=sin2+sin2
2863           obrot2_der(1,i-2)=-dwasin2
2864           obrot2_der(2,i-2)= dwacos2
2865           Ug2der(1,1,i-2)= dwasin2
2866           Ug2der(1,2,i-2)=-dwacos2
2867           Ug2der(2,1,i-2)=-dwacos2
2868           Ug2der(2,2,i-2)=-dwasin2
2869         else
2870           obrot_der(1,i-2)=0.0d0
2871           obrot_der(2,i-2)=0.0d0
2872           Ugder(1,1,i-2)=0.0d0
2873           Ugder(1,2,i-2)=0.0d0
2874           Ugder(2,1,i-2)=0.0d0
2875           Ugder(2,2,i-2)=0.0d0
2876           obrot2_der(1,i-2)=0.0d0
2877           obrot2_der(2,i-2)=0.0d0
2878           Ug2der(1,1,i-2)=0.0d0
2879           Ug2der(1,2,i-2)=0.0d0
2880           Ug2der(2,1,i-2)=0.0d0
2881           Ug2der(2,2,i-2)=0.0d0
2882         endif
2883 c        if (i.gt. iatel_s+2 .and. i.lt.iatel_e+5) then
2884         if (i.gt. nnt+2 .and. i.lt.nct+2) then
2885           iti = itortyp(itype(i-2))
2886         else
2887           iti=ntortyp
2888         endif
2889 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2890         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2891           iti1 = itortyp(itype(i-1))
2892         else
2893           iti1=ntortyp
2894         endif
2895 cd        write (iout,*) '*******i',i,' iti1',iti
2896 cd        write (iout,*) 'b1',b1(:,iti)
2897 cd        write (iout,*) 'b2',b2(:,iti)
2898 cd         write (iout,*) "phi(",i,")=",phi(i)," sin1",sin1," cos1",cos1
2899 cd        write (iout,*) 'Ug',Ug(:,:,i-2)
2900 c        if (i .gt. iatel_s+2) then
2901         if (i .gt. nnt+2) then
2902           call matvec2(Ug(1,1,i-2),b2(1,i-2),Ub2(1,i-2))
2903 #ifdef NEWCORR
2904           call matvec2(Ug(1,1,i-2),gtb2(1,i-2),gUb2(1,i-2))
2905 c          write (iout,*) Ug(1,1,i-2),gtb2(1,i-2),gUb2(1,i-2),"chuj"
2906 #endif
2907 c          write(iout,*) "co jest kurwa", iti, EE(1,1,iti),EE(2,1,iti),
2908 c     &    EE(1,2,iti),EE(2,2,iti)
2909           call matmat2(EE(1,1,i-2),Ug(1,1,i-2),EUg(1,1,i-2))
2910           call matmat2(gtEE(1,1,i-2),Ug(1,1,i-2),gtEUg(1,1,i-2))
2911 c          write(iout,*) "Macierz EUG",
2912 c     &    eug(1,1,i-2),eug(1,2,i-2),eug(2,1,i-2),
2913 c     &    eug(2,2,i-2)
2914           if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2915      &    then
2916           call matmat2(CC(1,1,iti),Ug(1,1,i-2),CUg(1,1,i-2))
2917           call matmat2(DD(1,1,iti),Ug(1,1,i-2),DUg(1,1,i-2))
2918           call matmat2(Dtilde(1,1,iti),Ug2(1,1,i-2),DtUg2(1,1,i-2))
2919           call matvec2(Ctilde(1,1,iti1),obrot(1,i-2),Ctobr(1,i-2))
2920           call matvec2(Dtilde(1,1,iti),obrot2(1,i-2),Dtobr2(1,i-2))
2921           endif
2922         else
2923           do k=1,2
2924             Ub2(k,i-2)=0.0d0
2925             Ctobr(k,i-2)=0.0d0
2926             Dtobr2(k,i-2)=0.0d0
2927             do l=1,2
2928               EUg(l,k,i-2)=0.0d0
2929               CUg(l,k,i-2)=0.0d0
2930               DUg(l,k,i-2)=0.0d0
2931               DtUg2(l,k,i-2)=0.0d0
2932             enddo
2933           enddo
2934         endif
2935         call matvec2(Ugder(1,1,i-2),b2(1,i-2),Ub2der(1,i-2))
2936         call matmat2(EE(1,1,i-2),Ugder(1,1,i-2),EUgder(1,1,i-2))
2937         do k=1,2
2938           muder(k,i-2)=Ub2der(k,i-2)
2939         enddo
2940 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2941         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2942           if (itype(i-1).le.ntyp) then
2943             iti1 = itortyp(itype(i-1))
2944           else
2945             iti1=ntortyp
2946           endif
2947         else
2948           iti1=ntortyp
2949         endif
2950         do k=1,2
2951           mu(k,i-2)=Ub2(k,i-2)+b1(k,i-1)
2952         enddo
2953 C        write (iout,*) 'mumu',i,b1(1,i-1),Ub2(1,i-2)
2954 cd        write (iout,*) 'mu  ',mu(:,i-2),i-2
2955 cd        write (iout,*) 'b1  ',b1(:,i-1),i-2
2956 cd        write (iout,*) 'Ub2 ',Ub2(:,i-2),i-2
2957 cd        write (iout,*) 'Ug  ',Ug(:,:,i-2),i-2
2958 cd        write (iout,*) 'b2  ',b2(:,i-2),i-2
2959 cd        write (iout,*) 'mu1',mu1(:,i-2)
2960 cd        write (iout,*) 'mu2',mu2(:,i-2)
2961         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
2962      &  then
2963         call matmat2(CC(1,1,iti1),Ugder(1,1,i-2),CUgder(1,1,i-2))
2964         call matmat2(DD(1,1,iti),Ugder(1,1,i-2),DUgder(1,1,i-2))
2965         call matmat2(Dtilde(1,1,iti),Ug2der(1,1,i-2),DtUg2der(1,1,i-2))
2966         call matvec2(Ctilde(1,1,iti1),obrot_der(1,i-2),Ctobrder(1,i-2))
2967         call matvec2(Dtilde(1,1,iti),obrot2_der(1,i-2),Dtobr2der(1,i-2))
2968 C Vectors and matrices dependent on a single virtual-bond dihedral.
2969         call matvec2(DD(1,1,iti),b1tilde(1,i-1),auxvec(1))
2970         call matvec2(Ug2(1,1,i-2),auxvec(1),Ug2Db1t(1,i-2))
2971         call matvec2(Ug2der(1,1,i-2),auxvec(1),Ug2Db1tder(1,i-2))
2972         call matvec2(CC(1,1,iti1),Ub2(1,i-2),CUgb2(1,i-2))
2973         call matvec2(CC(1,1,iti1),Ub2der(1,i-2),CUgb2der(1,i-2))
2974         call matmat2(EUg(1,1,i-2),CC(1,1,iti1),EUgC(1,1,i-2))
2975         call matmat2(EUgder(1,1,i-2),CC(1,1,iti1),EUgCder(1,1,i-2))
2976         call matmat2(EUg(1,1,i-2),DD(1,1,iti1),EUgD(1,1,i-2))
2977         call matmat2(EUgder(1,1,i-2),DD(1,1,iti1),EUgDder(1,1,i-2))
2978         endif
2979       enddo
2980 C Matrices dependent on two consecutive virtual-bond dihedrals.
2981 C The order of matrices is from left to right.
2982       if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
2983      &then
2984 c      do i=max0(ivec_start,2),ivec_end
2985       do i=2,nres-1
2986         call matmat2(DtUg2(1,1,i-1),EUg(1,1,i),DtUg2EUg(1,1,i))
2987         call matmat2(DtUg2der(1,1,i-1),EUg(1,1,i),DtUg2EUgder(1,1,1,i))
2988         call matmat2(DtUg2(1,1,i-1),EUgder(1,1,i),DtUg2EUgder(1,1,2,i))
2989         call transpose2(DtUg2(1,1,i-1),auxmat(1,1))
2990         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUg(1,1,i))
2991         call matmat2(auxmat(1,1),EUgder(1,1,i),Ug2DtEUgder(1,1,2,i))
2992         call transpose2(DtUg2der(1,1,i-1),auxmat(1,1))
2993         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUgder(1,1,1,i))
2994       enddo
2995       endif
2996 #if defined(MPI) && defined(PARMAT)
2997 #ifdef DEBUG
2998 c      if (fg_rank.eq.0) then
2999         write (iout,*) "Arrays UG and UGDER before GATHER"
3000         do i=1,nres-1
3001           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3002      &     ((ug(l,k,i),l=1,2),k=1,2),
3003      &     ((ugder(l,k,i),l=1,2),k=1,2)
3004         enddo
3005         write (iout,*) "Arrays UG2 and UG2DER"
3006         do i=1,nres-1
3007           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3008      &     ((ug2(l,k,i),l=1,2),k=1,2),
3009      &     ((ug2der(l,k,i),l=1,2),k=1,2)
3010         enddo
3011         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
3012         do i=1,nres-1
3013           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3014      &     (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
3015      &     (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
3016         enddo
3017         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
3018         do i=1,nres-1
3019           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3020      &     costab(i),sintab(i),costab2(i),sintab2(i)
3021         enddo
3022         write (iout,*) "Array MUDER"
3023         do i=1,nres-1
3024           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
3025         enddo
3026 c      endif
3027 #endif
3028       if (nfgtasks.gt.1) then
3029         time00=MPI_Wtime()
3030 c        write(iout,*)"Processor",fg_rank,kolor," ivec_start",ivec_start,
3031 c     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks-1),
3032 c     &   " ivec_count",(ivec_count(i),i=0,nfgtasks-1)
3033 #ifdef MATGATHER
3034         call MPI_Allgatherv(Ub2(1,ivec_start),ivec_count(fg_rank1),
3035      &   MPI_MU,Ub2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3036      &   FG_COMM1,IERR)
3037         call MPI_Allgatherv(Ub2der(1,ivec_start),ivec_count(fg_rank1),
3038      &   MPI_MU,Ub2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3039      &   FG_COMM1,IERR)
3040         call MPI_Allgatherv(mu(1,ivec_start),ivec_count(fg_rank1),
3041      &   MPI_MU,mu(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3042      &   FG_COMM1,IERR)
3043         call MPI_Allgatherv(muder(1,ivec_start),ivec_count(fg_rank1),
3044      &   MPI_MU,muder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3045      &   FG_COMM1,IERR)
3046         call MPI_Allgatherv(Eug(1,1,ivec_start),ivec_count(fg_rank1),
3047      &   MPI_MAT1,Eug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3048      &   FG_COMM1,IERR)
3049         call MPI_Allgatherv(Eugder(1,1,ivec_start),ivec_count(fg_rank1),
3050      &   MPI_MAT1,Eugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3051      &   FG_COMM1,IERR)
3052         call MPI_Allgatherv(costab(ivec_start),ivec_count(fg_rank1),
3053      &   MPI_DOUBLE_PRECISION,costab(1),ivec_count(0),ivec_displ(0),
3054      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3055         call MPI_Allgatherv(sintab(ivec_start),ivec_count(fg_rank1),
3056      &   MPI_DOUBLE_PRECISION,sintab(1),ivec_count(0),ivec_displ(0),
3057      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3058         call MPI_Allgatherv(costab2(ivec_start),ivec_count(fg_rank1),
3059      &   MPI_DOUBLE_PRECISION,costab2(1),ivec_count(0),ivec_displ(0),
3060      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3061         call MPI_Allgatherv(sintab2(ivec_start),ivec_count(fg_rank1),
3062      &   MPI_DOUBLE_PRECISION,sintab2(1),ivec_count(0),ivec_displ(0),
3063      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3064         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
3065      &  then
3066         call MPI_Allgatherv(Ctobr(1,ivec_start),ivec_count(fg_rank1),
3067      &   MPI_MU,Ctobr(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3068      &   FG_COMM1,IERR)
3069         call MPI_Allgatherv(Ctobrder(1,ivec_start),ivec_count(fg_rank1),
3070      &   MPI_MU,Ctobrder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3071      &   FG_COMM1,IERR)
3072         call MPI_Allgatherv(Dtobr2(1,ivec_start),ivec_count(fg_rank1),
3073      &   MPI_MU,Dtobr2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3074      &   FG_COMM1,IERR)
3075        call MPI_Allgatherv(Dtobr2der(1,ivec_start),ivec_count(fg_rank1),
3076      &   MPI_MU,Dtobr2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3077      &   FG_COMM1,IERR)
3078         call MPI_Allgatherv(Ug2Db1t(1,ivec_start),ivec_count(fg_rank1),
3079      &   MPI_MU,Ug2Db1t(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3080      &   FG_COMM1,IERR)
3081         call MPI_Allgatherv(Ug2Db1tder(1,ivec_start),
3082      &   ivec_count(fg_rank1),
3083      &   MPI_MU,Ug2Db1tder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3084      &   FG_COMM1,IERR)
3085         call MPI_Allgatherv(CUgb2(1,ivec_start),ivec_count(fg_rank1),
3086      &   MPI_MU,CUgb2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3087      &   FG_COMM1,IERR)
3088         call MPI_Allgatherv(CUgb2der(1,ivec_start),ivec_count(fg_rank1),
3089      &   MPI_MU,CUgb2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3090      &   FG_COMM1,IERR)
3091         call MPI_Allgatherv(Cug(1,1,ivec_start),ivec_count(fg_rank1),
3092      &   MPI_MAT1,Cug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3093      &   FG_COMM1,IERR)
3094         call MPI_Allgatherv(Cugder(1,1,ivec_start),ivec_count(fg_rank1),
3095      &   MPI_MAT1,Cugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3096      &   FG_COMM1,IERR)
3097         call MPI_Allgatherv(Dug(1,1,ivec_start),ivec_count(fg_rank1),
3098      &   MPI_MAT1,Dug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3099      &   FG_COMM1,IERR)
3100         call MPI_Allgatherv(Dugder(1,1,ivec_start),ivec_count(fg_rank1),
3101      &   MPI_MAT1,Dugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3102      &   FG_COMM1,IERR)
3103         call MPI_Allgatherv(Dtug2(1,1,ivec_start),ivec_count(fg_rank1),
3104      &   MPI_MAT1,Dtug2(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3105      &   FG_COMM1,IERR)
3106         call MPI_Allgatherv(Dtug2der(1,1,ivec_start),
3107      &   ivec_count(fg_rank1),
3108      &   MPI_MAT1,Dtug2der(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3109      &   FG_COMM1,IERR)
3110         call MPI_Allgatherv(EugC(1,1,ivec_start),ivec_count(fg_rank1),
3111      &   MPI_MAT1,EugC(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3112      &   FG_COMM1,IERR)
3113        call MPI_Allgatherv(EugCder(1,1,ivec_start),ivec_count(fg_rank1),
3114      &   MPI_MAT1,EugCder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3115      &   FG_COMM1,IERR)
3116         call MPI_Allgatherv(EugD(1,1,ivec_start),ivec_count(fg_rank1),
3117      &   MPI_MAT1,EugD(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3118      &   FG_COMM1,IERR)
3119        call MPI_Allgatherv(EugDder(1,1,ivec_start),ivec_count(fg_rank1),
3120      &   MPI_MAT1,EugDder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3121      &   FG_COMM1,IERR)
3122         call MPI_Allgatherv(DtUg2EUg(1,1,ivec_start),
3123      &   ivec_count(fg_rank1),
3124      &   MPI_MAT1,DtUg2EUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3125      &   FG_COMM1,IERR)
3126         call MPI_Allgatherv(Ug2DtEUg(1,1,ivec_start),
3127      &   ivec_count(fg_rank1),
3128      &   MPI_MAT1,Ug2DtEUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3129      &   FG_COMM1,IERR)
3130         call MPI_Allgatherv(DtUg2EUgder(1,1,1,ivec_start),
3131      &   ivec_count(fg_rank1),
3132      &   MPI_MAT2,DtUg2EUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
3133      &   MPI_MAT2,FG_COMM1,IERR)
3134         call MPI_Allgatherv(Ug2DtEUgder(1,1,1,ivec_start),
3135      &   ivec_count(fg_rank1),
3136      &   MPI_MAT2,Ug2DtEUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
3137      &   MPI_MAT2,FG_COMM1,IERR)
3138         endif
3139 #else
3140 c Passes matrix info through the ring
3141       isend=fg_rank1
3142       irecv=fg_rank1-1
3143       if (irecv.lt.0) irecv=nfgtasks1-1
3144       iprev=irecv
3145       inext=fg_rank1+1
3146       if (inext.ge.nfgtasks1) inext=0
3147       do i=1,nfgtasks1-1
3148 c        write (iout,*) "isend",isend," irecv",irecv
3149 c        call flush(iout)
3150         lensend=lentyp(isend)
3151         lenrecv=lentyp(irecv)
3152 c        write (iout,*) "lensend",lensend," lenrecv",lenrecv
3153 c        call MPI_SENDRECV(ug(1,1,ivec_displ(isend)+1),1,
3154 c     &   MPI_ROTAT1(lensend),inext,2200+isend,
3155 c     &   ug(1,1,ivec_displ(irecv)+1),1,MPI_ROTAT1(lenrecv),
3156 c     &   iprev,2200+irecv,FG_COMM,status,IERR)
3157 c        write (iout,*) "Gather ROTAT1"
3158 c        call flush(iout)
3159 c        call MPI_SENDRECV(obrot(1,ivec_displ(isend)+1),1,
3160 c     &   MPI_ROTAT2(lensend),inext,3300+isend,
3161 c     &   obrot(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
3162 c     &   iprev,3300+irecv,FG_COMM,status,IERR)
3163 c        write (iout,*) "Gather ROTAT2"
3164 c        call flush(iout)
3165         call MPI_SENDRECV(costab(ivec_displ(isend)+1),1,
3166      &   MPI_ROTAT_OLD(lensend),inext,4400+isend,
3167      &   costab(ivec_displ(irecv)+1),1,MPI_ROTAT_OLD(lenrecv),
3168      &   iprev,4400+irecv,FG_COMM,status,IERR)
3169 c        write (iout,*) "Gather ROTAT_OLD"
3170 c        call flush(iout)
3171         call MPI_SENDRECV(mu(1,ivec_displ(isend)+1),1,
3172      &   MPI_PRECOMP11(lensend),inext,5500+isend,
3173      &   mu(1,ivec_displ(irecv)+1),1,MPI_PRECOMP11(lenrecv),
3174      &   iprev,5500+irecv,FG_COMM,status,IERR)
3175 c        write (iout,*) "Gather PRECOMP11"
3176 c        call flush(iout)
3177         call MPI_SENDRECV(Eug(1,1,ivec_displ(isend)+1),1,
3178      &   MPI_PRECOMP12(lensend),inext,6600+isend,
3179      &   Eug(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP12(lenrecv),
3180      &   iprev,6600+irecv,FG_COMM,status,IERR)
3181 c        write (iout,*) "Gather PRECOMP12"
3182 c        call flush(iout)
3183         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
3184      &  then
3185         call MPI_SENDRECV(ug2db1t(1,ivec_displ(isend)+1),1,
3186      &   MPI_ROTAT2(lensend),inext,7700+isend,
3187      &   ug2db1t(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
3188      &   iprev,7700+irecv,FG_COMM,status,IERR)
3189 c        write (iout,*) "Gather PRECOMP21"
3190 c        call flush(iout)
3191         call MPI_SENDRECV(EUgC(1,1,ivec_displ(isend)+1),1,
3192      &   MPI_PRECOMP22(lensend),inext,8800+isend,
3193      &   EUgC(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP22(lenrecv),
3194      &   iprev,8800+irecv,FG_COMM,status,IERR)
3195 c        write (iout,*) "Gather PRECOMP22"
3196 c        call flush(iout)
3197         call MPI_SENDRECV(Ug2DtEUgder(1,1,1,ivec_displ(isend)+1),1,
3198      &   MPI_PRECOMP23(lensend),inext,9900+isend,
3199      &   Ug2DtEUgder(1,1,1,ivec_displ(irecv)+1),1,
3200      &   MPI_PRECOMP23(lenrecv),
3201      &   iprev,9900+irecv,FG_COMM,status,IERR)
3202 c        write (iout,*) "Gather PRECOMP23"
3203 c        call flush(iout)
3204         endif
3205         isend=irecv
3206         irecv=irecv-1
3207         if (irecv.lt.0) irecv=nfgtasks1-1
3208       enddo
3209 #endif
3210         time_gather=time_gather+MPI_Wtime()-time00
3211       endif
3212 #ifdef DEBUG
3213 c      if (fg_rank.eq.0) then
3214         write (iout,*) "Arrays UG and UGDER"
3215         do i=1,nres-1
3216           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3217      &     ((ug(l,k,i),l=1,2),k=1,2),
3218      &     ((ugder(l,k,i),l=1,2),k=1,2)
3219         enddo
3220         write (iout,*) "Arrays UG2 and UG2DER"
3221         do i=1,nres-1
3222           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3223      &     ((ug2(l,k,i),l=1,2),k=1,2),
3224      &     ((ug2der(l,k,i),l=1,2),k=1,2)
3225         enddo
3226         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
3227         do i=1,nres-1
3228           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3229      &     (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
3230      &     (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
3231         enddo
3232         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
3233         do i=1,nres-1
3234           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3235      &     costab(i),sintab(i),costab2(i),sintab2(i)
3236         enddo
3237         write (iout,*) "Array MUDER"
3238         do i=1,nres-1
3239           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
3240         enddo
3241 c      endif
3242 #endif
3243 #endif
3244 cd      do i=1,nres
3245 cd        iti = itortyp(itype(i))
3246 cd        write (iout,*) i
3247 cd        do j=1,2
3248 cd        write (iout,'(2f10.5,5x,2f10.5,5x,2f10.5)')
3249 cd     &  (EE(j,k,iti),k=1,2),(Ug(j,k,i),k=1,2),(EUg(j,k,i),k=1,2)
3250 cd        enddo
3251 cd      enddo
3252       return
3253       end
3254 C--------------------------------------------------------------------------
3255       subroutine eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
3256 C
3257 C This subroutine calculates the average interaction energy and its gradient
3258 C in the virtual-bond vectors between non-adjacent peptide groups, based on
3259 C the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
3260 C The potential depends both on the distance of peptide-group centers and on
3261 C the orientation of the CA-CA virtual bonds.
3262 C
3263       implicit real*8 (a-h,o-z)
3264 #ifdef MPI
3265       include 'mpif.h'
3266 #endif
3267       include 'DIMENSIONS'
3268       include 'COMMON.CONTROL'
3269       include 'COMMON.SETUP'
3270       include 'COMMON.IOUNITS'
3271       include 'COMMON.GEO'
3272       include 'COMMON.VAR'
3273       include 'COMMON.LOCAL'
3274       include 'COMMON.CHAIN'
3275       include 'COMMON.DERIV'
3276       include 'COMMON.INTERACT'
3277       include 'COMMON.CONTACTS'
3278       include 'COMMON.TORSION'
3279       include 'COMMON.VECTORS'
3280       include 'COMMON.FFIELD'
3281       include 'COMMON.TIME1'
3282       include 'COMMON.SPLITELE'
3283       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
3284      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
3285       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
3286      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4),gmuij(4)
3287       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3288      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3289      &    num_conti,j1,j2
3290 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
3291 #ifdef MOMENT
3292       double precision scal_el /1.0d0/
3293 #else
3294       double precision scal_el /0.5d0/
3295 #endif
3296 C 12/13/98
3297 C 13-go grudnia roku pamietnego...
3298       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
3299      &                   0.0d0,1.0d0,0.0d0,
3300      &                   0.0d0,0.0d0,1.0d0/
3301 cd      write(iout,*) 'In EELEC'
3302 cd      do i=1,nloctyp
3303 cd        write(iout,*) 'Type',i
3304 cd        write(iout,*) 'B1',B1(:,i)
3305 cd        write(iout,*) 'B2',B2(:,i)
3306 cd        write(iout,*) 'CC',CC(:,:,i)
3307 cd        write(iout,*) 'DD',DD(:,:,i)
3308 cd        write(iout,*) 'EE',EE(:,:,i)
3309 cd      enddo
3310 cd      call check_vecgrad
3311 cd      stop
3312       if (icheckgrad.eq.1) then
3313         do i=1,nres-1
3314           fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
3315           do k=1,3
3316             dc_norm(k,i)=dc(k,i)*fac
3317           enddo
3318 c          write (iout,*) 'i',i,' fac',fac
3319         enddo
3320       endif
3321       if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
3322      &    .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or.
3323      &    wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
3324 c        call vec_and_deriv
3325 #ifdef TIMING
3326         time01=MPI_Wtime()
3327 #endif
3328         call set_matrices
3329 #ifdef TIMING
3330         time_mat=time_mat+MPI_Wtime()-time01
3331 #endif
3332       endif
3333 cd      do i=1,nres-1
3334 cd        write (iout,*) 'i=',i
3335 cd        do k=1,3
3336 cd        write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
3337 cd        enddo
3338 cd        do k=1,3
3339 cd          write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
3340 cd     &     uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
3341 cd        enddo
3342 cd      enddo
3343       t_eelecij=0.0d0
3344       ees=0.0D0
3345       evdw1=0.0D0
3346       eel_loc=0.0d0
3347       eello_turn3=0.0d0
3348       eello_turn4=0.0d0
3349       ind=0
3350       do i=1,nres
3351         num_cont_hb(i)=0
3352       enddo
3353 cd      print '(a)','Enter EELEC'
3354 cd      write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
3355       do i=1,nres
3356         gel_loc_loc(i)=0.0d0
3357         gcorr_loc(i)=0.0d0
3358       enddo
3359 c
3360 c
3361 c 9/27/08 AL Split the interaction loop to ensure load balancing of turn terms
3362 C
3363 C Loop over i,i+2 and i,i+3 pairs of the peptide groups
3364 C
3365 C 14/01/2014 TURN3,TUNR4 does no go under periodic boundry condition
3366       do i=iturn3_start,iturn3_end
3367 CAna        if (i.le.1) cycle
3368 C        write(iout,*) "tu jest i",i
3369         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
3370 C changes suggested by Ana to avoid out of bounds
3371 CAna     & .or.((i+4).gt.nres)
3372 CAna     & .or.((i-1).le.0)
3373 C end of changes by Ana
3374      &  .or. itype(i+2).eq.ntyp1
3375      &  .or. itype(i+3).eq.ntyp1) cycle
3376 CAna        if(i.gt.1)then
3377 CAna          if(itype(i-1).eq.ntyp1)cycle
3378 CAna        end if
3379 CAna        if(i.LT.nres-3)then
3380 CAna          if (itype(i+4).eq.ntyp1) cycle
3381 CAna        end if
3382         dxi=dc(1,i)
3383         dyi=dc(2,i)
3384         dzi=dc(3,i)
3385         dx_normi=dc_norm(1,i)
3386         dy_normi=dc_norm(2,i)
3387         dz_normi=dc_norm(3,i)
3388         xmedi=c(1,i)+0.5d0*dxi
3389         ymedi=c(2,i)+0.5d0*dyi
3390         zmedi=c(3,i)+0.5d0*dzi
3391           xmedi=mod(xmedi,boxxsize)
3392           if (xmedi.lt.0) xmedi=xmedi+boxxsize
3393           ymedi=mod(ymedi,boxysize)
3394           if (ymedi.lt.0) ymedi=ymedi+boxysize
3395           zmedi=mod(zmedi,boxzsize)
3396           if (zmedi.lt.0) zmedi=zmedi+boxzsize
3397         num_conti=0
3398         call eelecij(i,i+2,ees,evdw1,eel_loc)
3399         if (wturn3.gt.0.0d0) call eturn3(i,eello_turn3)
3400         num_cont_hb(i)=num_conti
3401       enddo
3402       do i=iturn4_start,iturn4_end
3403 cAna        if (i.le.1) cycle
3404         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
3405 C changes suggested by Ana to avoid out of bounds
3406 cAna     & .or.((i+5).gt.nres)
3407 cAna     & .or.((i-1).le.0)
3408 C end of changes suggested by Ana
3409      &    .or. itype(i+3).eq.ntyp1
3410      &    .or. itype(i+4).eq.ntyp1
3411 cAna     &    .or. itype(i+5).eq.ntyp1
3412 cAna     &    .or. itype(i).eq.ntyp1
3413 cAna     &    .or. itype(i-1).eq.ntyp1
3414      &                             ) cycle
3415         dxi=dc(1,i)
3416         dyi=dc(2,i)
3417         dzi=dc(3,i)
3418         dx_normi=dc_norm(1,i)
3419         dy_normi=dc_norm(2,i)
3420         dz_normi=dc_norm(3,i)
3421         xmedi=c(1,i)+0.5d0*dxi
3422         ymedi=c(2,i)+0.5d0*dyi
3423         zmedi=c(3,i)+0.5d0*dzi
3424 C Return atom into box, boxxsize is size of box in x dimension
3425 c  194   continue
3426 c        if (xmedi.gt.((0.5d0)*boxxsize)) xmedi=xmedi-boxxsize
3427 c        if (xmedi.lt.((-0.5d0)*boxxsize)) xmedi=xmedi+boxxsize
3428 C Condition for being inside the proper box
3429 c        if ((xmedi.gt.((0.5d0)*boxxsize)).or.
3430 c     &       (xmedi.lt.((-0.5d0)*boxxsize))) then
3431 c        go to 194
3432 c        endif
3433 c  195   continue
3434 c        if (ymedi.gt.((0.5d0)*boxysize)) ymedi=ymedi-boxysize
3435 c        if (ymedi.lt.((-0.5d0)*boxysize)) ymedi=ymedi+boxysize
3436 C Condition for being inside the proper box
3437 c        if ((ymedi.gt.((0.5d0)*boxysize)).or.
3438 c     &       (ymedi.lt.((-0.5d0)*boxysize))) then
3439 c        go to 195
3440 c        endif
3441 c  196   continue
3442 c        if (zmedi.gt.((0.5d0)*boxzsize)) zmedi=zmedi-boxzsize
3443 c        if (zmedi.lt.((-0.5d0)*boxzsize)) zmedi=zmedi+boxzsize
3444 C Condition for being inside the proper box
3445 c        if ((zmedi.gt.((0.5d0)*boxzsize)).or.
3446 c     &       (zmedi.lt.((-0.5d0)*boxzsize))) then
3447 c        go to 196
3448 c        endif
3449           xmedi=mod(xmedi,boxxsize)
3450           if (xmedi.lt.0) xmedi=xmedi+boxxsize
3451           ymedi=mod(ymedi,boxysize)
3452           if (ymedi.lt.0) ymedi=ymedi+boxysize
3453           zmedi=mod(zmedi,boxzsize)
3454           if (zmedi.lt.0) zmedi=zmedi+boxzsize
3455
3456         num_conti=num_cont_hb(i)
3457 c        write(iout,*) "JESTEM W PETLI"
3458         call eelecij(i,i+3,ees,evdw1,eel_loc)
3459         if (wturn4.gt.0.0d0 .and. itype(i+2).ne.ntyp1)
3460      &   call eturn4(i,eello_turn4)
3461         num_cont_hb(i)=num_conti
3462       enddo   ! i
3463 C Loop over all neighbouring boxes
3464 C      do xshift=-1,1
3465 C      do yshift=-1,1
3466 C      do zshift=-1,1
3467 c
3468 c Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
3469 c
3470       do i=iatel_s,iatel_e
3471 cAna        if (i.le.1) cycle
3472         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
3473 C changes suggested by Ana to avoid out of bounds
3474 cAna     & .or.((i+2).gt.nres)
3475 cAna     & .or.((i-1).le.0)
3476 C end of changes by Ana
3477 cAna     &  .or. itype(i+2).eq.ntyp1
3478 cAna     &  .or. itype(i-1).eq.ntyp1
3479      &                ) cycle
3480         dxi=dc(1,i)
3481         dyi=dc(2,i)
3482         dzi=dc(3,i)
3483         dx_normi=dc_norm(1,i)
3484         dy_normi=dc_norm(2,i)
3485         dz_normi=dc_norm(3,i)
3486         xmedi=c(1,i)+0.5d0*dxi
3487         ymedi=c(2,i)+0.5d0*dyi
3488         zmedi=c(3,i)+0.5d0*dzi
3489           xmedi=mod(xmedi,boxxsize)
3490           if (xmedi.lt.0) xmedi=xmedi+boxxsize
3491           ymedi=mod(ymedi,boxysize)
3492           if (ymedi.lt.0) ymedi=ymedi+boxysize
3493           zmedi=mod(zmedi,boxzsize)
3494           if (zmedi.lt.0) zmedi=zmedi+boxzsize
3495 C          xmedi=xmedi+xshift*boxxsize
3496 C          ymedi=ymedi+yshift*boxysize
3497 C          zmedi=zmedi+zshift*boxzsize
3498
3499 C Return tom into box, boxxsize is size of box in x dimension
3500 c  164   continue
3501 c        if (xmedi.gt.((xshift+0.5d0)*boxxsize)) xmedi=xmedi-boxxsize
3502 c        if (xmedi.lt.((xshift-0.5d0)*boxxsize)) xmedi=xmedi+boxxsize
3503 C Condition for being inside the proper box
3504 c        if ((xmedi.gt.((xshift+0.5d0)*boxxsize)).or.
3505 c     &       (xmedi.lt.((xshift-0.5d0)*boxxsize))) then
3506 c        go to 164
3507 c        endif
3508 c  165   continue
3509 c        if (ymedi.gt.((yshift+0.5d0)*boxysize)) ymedi=ymedi-boxysize
3510 c        if (ymedi.lt.((yshift-0.5d0)*boxysize)) ymedi=ymedi+boxysize
3511 C Condition for being inside the proper box
3512 c        if ((ymedi.gt.((yshift+0.5d0)*boxysize)).or.
3513 c     &       (ymedi.lt.((yshift-0.5d0)*boxysize))) then
3514 c        go to 165
3515 c        endif
3516 c  166   continue
3517 c        if (zmedi.gt.((zshift+0.5d0)*boxzsize)) zmedi=zmedi-boxzsize
3518 c        if (zmedi.lt.((zshift-0.5d0)*boxzsize)) zmedi=zmedi+boxzsize
3519 cC Condition for being inside the proper box
3520 c        if ((zmedi.gt.((zshift+0.5d0)*boxzsize)).or.
3521 c     &       (zmedi.lt.((zshift-0.5d0)*boxzsize))) then
3522 c        go to 166
3523 c        endif
3524
3525 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
3526         num_conti=num_cont_hb(i)
3527         do j=ielstart(i),ielend(i)
3528 C          write (iout,*) i,j
3529 cAna         if (j.le.1) cycle
3530           if (itype(j).eq.ntyp1.or. itype(j+1).eq.ntyp1
3531 C changes suggested by Ana to avoid out of bounds
3532 cAna     & .or.((j+2).gt.nres)
3533 cAna     & .or.((j-1).le.0)
3534 C end of changes by Ana
3535 cAna     & .or.itype(j+2).eq.ntyp1
3536 cAna     & .or.itype(j-1).eq.ntyp1
3537      &) cycle
3538           call eelecij(i,j,ees,evdw1,eel_loc)
3539         enddo ! j
3540         num_cont_hb(i)=num_conti
3541       enddo   ! i
3542 C     enddo   ! zshift
3543 C      enddo   ! yshift
3544 C      enddo   ! xshift
3545
3546 c      write (iout,*) "Number of loop steps in EELEC:",ind
3547 cd      do i=1,nres
3548 cd        write (iout,'(i3,3f10.5,5x,3f10.5)')
3549 cd     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
3550 cd      enddo
3551 c 12/7/99 Adam eello_turn3 will be considered as a separate energy term
3552 ccc      eel_loc=eel_loc+eello_turn3
3553 cd      print *,"Processor",fg_rank," t_eelecij",t_eelecij
3554       return
3555       end
3556 C-------------------------------------------------------------------------------
3557       subroutine eelecij(i,j,ees,evdw1,eel_loc)
3558       implicit real*8 (a-h,o-z)
3559       include 'DIMENSIONS'
3560 #ifdef MPI
3561       include "mpif.h"
3562 #endif
3563       include 'COMMON.CONTROL'
3564       include 'COMMON.IOUNITS'
3565       include 'COMMON.GEO'
3566       include 'COMMON.VAR'
3567       include 'COMMON.LOCAL'
3568       include 'COMMON.CHAIN'
3569       include 'COMMON.DERIV'
3570       include 'COMMON.INTERACT'
3571       include 'COMMON.CONTACTS'
3572       include 'COMMON.TORSION'
3573       include 'COMMON.VECTORS'
3574       include 'COMMON.FFIELD'
3575       include 'COMMON.TIME1'
3576       include 'COMMON.SPLITELE'
3577       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
3578      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
3579       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
3580      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4),gmuij1(4),gmuji1(4),
3581      &    gmuij2(4),gmuji2(4)
3582       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3583      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3584      &    num_conti,j1,j2
3585 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
3586 #ifdef MOMENT
3587       double precision scal_el /1.0d0/
3588 #else
3589       double precision scal_el /0.5d0/
3590 #endif
3591 C 12/13/98
3592 C 13-go grudnia roku pamietnego...
3593       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
3594      &                   0.0d0,1.0d0,0.0d0,
3595      &                   0.0d0,0.0d0,1.0d0/
3596 c          time00=MPI_Wtime()
3597 cd      write (iout,*) "eelecij",i,j
3598 c          ind=ind+1
3599           iteli=itel(i)
3600           itelj=itel(j)
3601           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
3602           aaa=app(iteli,itelj)
3603           bbb=bpp(iteli,itelj)
3604           ael6i=ael6(iteli,itelj)
3605           ael3i=ael3(iteli,itelj)
3606           dxj=dc(1,j)
3607           dyj=dc(2,j)
3608           dzj=dc(3,j)
3609           dx_normj=dc_norm(1,j)
3610           dy_normj=dc_norm(2,j)
3611           dz_normj=dc_norm(3,j)
3612 C          xj=c(1,j)+0.5D0*dxj-xmedi
3613 C          yj=c(2,j)+0.5D0*dyj-ymedi
3614 C          zj=c(3,j)+0.5D0*dzj-zmedi
3615           xj=c(1,j)+0.5D0*dxj
3616           yj=c(2,j)+0.5D0*dyj
3617           zj=c(3,j)+0.5D0*dzj
3618           xj=mod(xj,boxxsize)
3619           if (xj.lt.0) xj=xj+boxxsize
3620           yj=mod(yj,boxysize)
3621           if (yj.lt.0) yj=yj+boxysize
3622           zj=mod(zj,boxzsize)
3623           if (zj.lt.0) zj=zj+boxzsize
3624           if ((zj.lt.0).or.(xj.lt.0).or.(yj.lt.0)) write (*,*) "CHUJ"
3625       dist_init=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
3626       xj_safe=xj
3627       yj_safe=yj
3628       zj_safe=zj
3629       isubchap=0
3630       do xshift=-1,1
3631       do yshift=-1,1
3632       do zshift=-1,1
3633           xj=xj_safe+xshift*boxxsize
3634           yj=yj_safe+yshift*boxysize
3635           zj=zj_safe+zshift*boxzsize
3636           dist_temp=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
3637           if(dist_temp.lt.dist_init) then
3638             dist_init=dist_temp
3639             xj_temp=xj
3640             yj_temp=yj
3641             zj_temp=zj
3642             isubchap=1
3643           endif
3644        enddo
3645        enddo
3646        enddo
3647        if (isubchap.eq.1) then
3648           xj=xj_temp-xmedi
3649           yj=yj_temp-ymedi
3650           zj=zj_temp-zmedi
3651        else
3652           xj=xj_safe-xmedi
3653           yj=yj_safe-ymedi
3654           zj=zj_safe-zmedi
3655        endif
3656 C        if ((i+3).lt.j) then !this condition keeps for turn3 and turn4 not subject to PBC
3657 c  174   continue
3658 c        if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
3659 c        if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
3660 C Condition for being inside the proper box
3661 c        if ((xj.gt.((0.5d0)*boxxsize)).or.
3662 c     &       (xj.lt.((-0.5d0)*boxxsize))) then
3663 c        go to 174
3664 c        endif
3665 c  175   continue
3666 c        if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
3667 c        if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
3668 C Condition for being inside the proper box
3669 c        if ((yj.gt.((0.5d0)*boxysize)).or.
3670 c     &       (yj.lt.((-0.5d0)*boxysize))) then
3671 c        go to 175
3672 c        endif
3673 c  176   continue
3674 c        if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
3675 c        if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
3676 C Condition for being inside the proper box
3677 c        if ((zj.gt.((0.5d0)*boxzsize)).or.
3678 c     &       (zj.lt.((-0.5d0)*boxzsize))) then
3679 c        go to 176
3680 c        endif
3681 C        endif !endPBC condintion
3682 C        xj=xj-xmedi
3683 C        yj=yj-ymedi
3684 C        zj=zj-zmedi
3685           rij=xj*xj+yj*yj+zj*zj
3686
3687             sss=sscale(sqrt(rij))
3688             sssgrad=sscagrad(sqrt(rij))
3689 c            if (sss.gt.0.0d0) then
3690           rrmij=1.0D0/rij
3691           rij=dsqrt(rij)
3692           rmij=1.0D0/rij
3693           r3ij=rrmij*rmij
3694           r6ij=r3ij*r3ij
3695           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
3696           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
3697           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
3698           fac=cosa-3.0D0*cosb*cosg
3699           ev1=aaa*r6ij*r6ij
3700 c 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
3701           if (j.eq.i+2) ev1=scal_el*ev1
3702           ev2=bbb*r6ij
3703           fac3=ael6i*r6ij
3704           fac4=ael3i*r3ij
3705           evdwij=(ev1+ev2)
3706           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
3707           el2=fac4*fac
3708 C MARYSIA
3709           eesij=(el1+el2)
3710 C 12/26/95 - for the evaluation of multi-body H-bonding interactions
3711           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
3712           ees=ees+eesij
3713           evdw1=evdw1+evdwij*sss
3714 cd          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
3715 cd     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
3716 cd     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
3717 cd     &      xmedi,ymedi,zmedi,xj,yj,zj
3718
3719           if (energy_dec) then
3720               write (iout,'(a6,2i5,0pf7.3,2i5,2e11.3)')
3721      &'evdw1',i,j,evdwij
3722 c     &,iteli,itelj,aaa,evdw1
3723               write (iout,'(a6,2i5,0pf7.3)') 'ees',i,j,eesij
3724           endif
3725
3726 C
3727 C Calculate contributions to the Cartesian gradient.
3728 C
3729 #ifdef SPLITELE
3730           facvdw=-6*rrmij*(ev1+evdwij)*sss
3731           facel=-3*rrmij*(el1+eesij)
3732           fac1=fac
3733           erij(1)=xj*rmij
3734           erij(2)=yj*rmij
3735           erij(3)=zj*rmij
3736
3737 *
3738 * Radial derivatives. First process both termini of the fragment (i,j)
3739 *
3740           ggg(1)=facel*xj
3741           ggg(2)=facel*yj
3742           ggg(3)=facel*zj
3743 c          do k=1,3
3744 c            ghalf=0.5D0*ggg(k)
3745 c            gelc(k,i)=gelc(k,i)+ghalf
3746 c            gelc(k,j)=gelc(k,j)+ghalf
3747 c          enddo
3748 c 9/28/08 AL Gradient compotents will be summed only at the end
3749           do k=1,3
3750             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
3751             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
3752           enddo
3753 *
3754 * Loop over residues i+1 thru j-1.
3755 *
3756 cgrad          do k=i+1,j-1
3757 cgrad            do l=1,3
3758 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3759 cgrad            enddo
3760 cgrad          enddo
3761           if (sss.gt.0.0) then
3762           ggg(1)=facvdw*xj+sssgrad*rmij*evdwij*xj
3763           ggg(2)=facvdw*yj+sssgrad*rmij*evdwij*yj
3764           ggg(3)=facvdw*zj+sssgrad*rmij*evdwij*zj
3765           else
3766           ggg(1)=0.0
3767           ggg(2)=0.0
3768           ggg(3)=0.0
3769           endif
3770 c          do k=1,3
3771 c            ghalf=0.5D0*ggg(k)
3772 c            gvdwpp(k,i)=gvdwpp(k,i)+ghalf
3773 c            gvdwpp(k,j)=gvdwpp(k,j)+ghalf
3774 c          enddo
3775 c 9/28/08 AL Gradient compotents will be summed only at the end
3776           do k=1,3
3777             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
3778             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
3779           enddo
3780 *
3781 * Loop over residues i+1 thru j-1.
3782 *
3783 cgrad          do k=i+1,j-1
3784 cgrad            do l=1,3
3785 cgrad              gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
3786 cgrad            enddo
3787 cgrad          enddo
3788 #else
3789 C MARYSIA
3790           facvdw=(ev1+evdwij)*sss
3791           facel=(el1+eesij)
3792           fac1=fac
3793           fac=-3*rrmij*(facvdw+facvdw+facel)
3794           erij(1)=xj*rmij
3795           erij(2)=yj*rmij
3796           erij(3)=zj*rmij
3797 *
3798 * Radial derivatives. First process both termini of the fragment (i,j)
3799 *
3800           ggg(1)=fac*xj
3801           ggg(2)=fac*yj
3802           ggg(3)=fac*zj
3803 c          do k=1,3
3804 c            ghalf=0.5D0*ggg(k)
3805 c            gelc(k,i)=gelc(k,i)+ghalf
3806 c            gelc(k,j)=gelc(k,j)+ghalf
3807 c          enddo
3808 c 9/28/08 AL Gradient compotents will be summed only at the end
3809           do k=1,3
3810             gelc_long(k,j)=gelc(k,j)+ggg(k)
3811             gelc_long(k,i)=gelc(k,i)-ggg(k)
3812           enddo
3813 *
3814 * Loop over residues i+1 thru j-1.
3815 *
3816 cgrad          do k=i+1,j-1
3817 cgrad            do l=1,3
3818 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3819 cgrad            enddo
3820 cgrad          enddo
3821 c 9/28/08 AL Gradient compotents will be summed only at the end
3822           ggg(1)=facvdw*xj+sssgrad*rmij*evdwij*xj
3823           ggg(2)=facvdw*yj+sssgrad*rmij*evdwij*yj
3824           ggg(3)=facvdw*zj+sssgrad*rmij*evdwij*zj
3825           do k=1,3
3826             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
3827             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
3828           enddo
3829 #endif
3830 *
3831 * Angular part
3832 *
3833           ecosa=2.0D0*fac3*fac1+fac4
3834           fac4=-3.0D0*fac4
3835           fac3=-6.0D0*fac3
3836           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
3837           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
3838           do k=1,3
3839             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
3840             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
3841           enddo
3842 cd        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
3843 cd   &          (dcosg(k),k=1,3)
3844           do k=1,3
3845             ggg(k)=ecosb*dcosb(k)+ecosg*dcosg(k)
3846           enddo
3847 c          do k=1,3
3848 c            ghalf=0.5D0*ggg(k)
3849 c            gelc(k,i)=gelc(k,i)+ghalf
3850 c     &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
3851 c     &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3852 c            gelc(k,j)=gelc(k,j)+ghalf
3853 c     &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
3854 c     &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3855 c          enddo
3856 cgrad          do k=i+1,j-1
3857 cgrad            do l=1,3
3858 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3859 cgrad            enddo
3860 cgrad          enddo
3861           do k=1,3
3862             gelc(k,i)=gelc(k,i)
3863      &           +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
3864      &           + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3865             gelc(k,j)=gelc(k,j)
3866      &           +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
3867      &           + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3868             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
3869             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
3870           enddo
3871 C MARYSIA
3872 c          endif !sscale
3873           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
3874      &        .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0
3875      &        .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
3876 C
3877 C 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
3878 C   energy of a peptide unit is assumed in the form of a second-order
3879 C   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
3880 C   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
3881 C   are computed for EVERY pair of non-contiguous peptide groups.
3882 C
3883
3884           if (j.lt.nres-1) then
3885             j1=j+1
3886             j2=j-1
3887           else
3888             j1=j-1
3889             j2=j-2
3890           endif
3891           kkk=0
3892           lll=0
3893           do k=1,2
3894             do l=1,2
3895               kkk=kkk+1
3896               muij(kkk)=mu(k,i)*mu(l,j)
3897 c              write(iout,*) 'mumu=', mu(k,i),mu(l,j),i,j,k,l
3898 #ifdef NEWCORR
3899              gmuij1(kkk)=gtb1(k,i+1)*mu(l,j)
3900 c             write(iout,*) 'k=',k,i,gtb1(k,i+1),gtb1(k,i+1)*mu(l,j)
3901              gmuij2(kkk)=gUb2(k,i)*mu(l,j)
3902              gmuji1(kkk)=mu(k,i)*gtb1(l,j+1)
3903 c             write(iout,*) 'l=',l,j,gtb1(l,j+1),gtb1(l,j+1)*mu(k,i)
3904              gmuji2(kkk)=mu(k,i)*gUb2(l,j)
3905 #endif
3906             enddo
3907           enddo
3908 cd         write (iout,*) 'EELEC: i',i,' j',j
3909 cd          write (iout,*) 'j',j,' j1',j1,' j2',j2
3910 cd          write(iout,*) 'muij',muij
3911           ury=scalar(uy(1,i),erij)
3912           urz=scalar(uz(1,i),erij)
3913           vry=scalar(uy(1,j),erij)
3914           vrz=scalar(uz(1,j),erij)
3915           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
3916           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
3917           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
3918           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
3919           fac=dsqrt(-ael6i)*r3ij
3920           a22=a22*fac
3921           a23=a23*fac
3922           a32=a32*fac
3923           a33=a33*fac
3924 cd          write (iout,'(4i5,4f10.5)')
3925 cd     &     i,itortyp(itype(i)),j,itortyp(itype(j)),a22,a23,a32,a33
3926 cd          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
3927 cd          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') uy(:,i),uz(:,i),
3928 cd     &      uy(:,j),uz(:,j)
3929 cd          write (iout,'(4f10.5)')
3930 cd     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
3931 cd     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
3932 cd          write (iout,'(4f10.5)') ury,urz,vry,vrz
3933 cd           write (iout,'(9f10.5/)')
3934 cd     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
3935 C Derivatives of the elements of A in virtual-bond vectors
3936           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
3937           do k=1,3
3938             uryg(k,1)=scalar(erder(1,k),uy(1,i))
3939             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
3940             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
3941             urzg(k,1)=scalar(erder(1,k),uz(1,i))
3942             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
3943             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
3944             vryg(k,1)=scalar(erder(1,k),uy(1,j))
3945             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
3946             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
3947             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
3948             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
3949             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
3950           enddo
3951 C Compute radial contributions to the gradient
3952           facr=-3.0d0*rrmij
3953           a22der=a22*facr
3954           a23der=a23*facr
3955           a32der=a32*facr
3956           a33der=a33*facr
3957           agg(1,1)=a22der*xj
3958           agg(2,1)=a22der*yj
3959           agg(3,1)=a22der*zj
3960           agg(1,2)=a23der*xj
3961           agg(2,2)=a23der*yj
3962           agg(3,2)=a23der*zj
3963           agg(1,3)=a32der*xj
3964           agg(2,3)=a32der*yj
3965           agg(3,3)=a32der*zj
3966           agg(1,4)=a33der*xj
3967           agg(2,4)=a33der*yj
3968           agg(3,4)=a33der*zj
3969 C Add the contributions coming from er
3970           fac3=-3.0d0*fac
3971           do k=1,3
3972             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
3973             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
3974             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
3975             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
3976           enddo
3977           do k=1,3
3978 C Derivatives in DC(i)
3979 cgrad            ghalf1=0.5d0*agg(k,1)
3980 cgrad            ghalf2=0.5d0*agg(k,2)
3981 cgrad            ghalf3=0.5d0*agg(k,3)
3982 cgrad            ghalf4=0.5d0*agg(k,4)
3983             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j))
3984      &      -3.0d0*uryg(k,2)*vry)!+ghalf1
3985             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j))
3986      &      -3.0d0*uryg(k,2)*vrz)!+ghalf2
3987             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j))
3988      &      -3.0d0*urzg(k,2)*vry)!+ghalf3
3989             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j))
3990      &      -3.0d0*urzg(k,2)*vrz)!+ghalf4
3991 C Derivatives in DC(i+1)
3992             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j))
3993      &      -3.0d0*uryg(k,3)*vry)!+agg(k,1)
3994             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j))
3995      &      -3.0d0*uryg(k,3)*vrz)!+agg(k,2)
3996             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j))
3997      &      -3.0d0*urzg(k,3)*vry)!+agg(k,3)
3998             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j))
3999      &      -3.0d0*urzg(k,3)*vrz)!+agg(k,4)
4000 C Derivatives in DC(j)
4001             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i))
4002      &      -3.0d0*vryg(k,2)*ury)!+ghalf1
4003             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i))
4004      &      -3.0d0*vrzg(k,2)*ury)!+ghalf2
4005             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i))
4006      &      -3.0d0*vryg(k,2)*urz)!+ghalf3
4007             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i))
4008      &      -3.0d0*vrzg(k,2)*urz)!+ghalf4
4009 C Derivatives in DC(j+1) or DC(nres-1)
4010             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i))
4011      &      -3.0d0*vryg(k,3)*ury)
4012             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i))
4013      &      -3.0d0*vrzg(k,3)*ury)
4014             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i))
4015      &      -3.0d0*vryg(k,3)*urz)
4016             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i))
4017      &      -3.0d0*vrzg(k,3)*urz)
4018 cgrad            if (j.eq.nres-1 .and. i.lt.j-2) then
4019 cgrad              do l=1,4
4020 cgrad                aggj1(k,l)=aggj1(k,l)+agg(k,l)
4021 cgrad              enddo
4022 cgrad            endif
4023           enddo
4024           acipa(1,1)=a22
4025           acipa(1,2)=a23
4026           acipa(2,1)=a32
4027           acipa(2,2)=a33
4028           a22=-a22
4029           a23=-a23
4030           do l=1,2
4031             do k=1,3
4032               agg(k,l)=-agg(k,l)
4033               aggi(k,l)=-aggi(k,l)
4034               aggi1(k,l)=-aggi1(k,l)
4035               aggj(k,l)=-aggj(k,l)
4036               aggj1(k,l)=-aggj1(k,l)
4037             enddo
4038           enddo
4039           if (j.lt.nres-1) then
4040             a22=-a22
4041             a32=-a32
4042             do l=1,3,2
4043               do k=1,3
4044                 agg(k,l)=-agg(k,l)
4045                 aggi(k,l)=-aggi(k,l)
4046                 aggi1(k,l)=-aggi1(k,l)
4047                 aggj(k,l)=-aggj(k,l)
4048                 aggj1(k,l)=-aggj1(k,l)
4049               enddo
4050             enddo
4051           else
4052             a22=-a22
4053             a23=-a23
4054             a32=-a32
4055             a33=-a33
4056             do l=1,4
4057               do k=1,3
4058                 agg(k,l)=-agg(k,l)
4059                 aggi(k,l)=-aggi(k,l)
4060                 aggi1(k,l)=-aggi1(k,l)
4061                 aggj(k,l)=-aggj(k,l)
4062                 aggj1(k,l)=-aggj1(k,l)
4063               enddo
4064             enddo
4065           endif
4066           ENDIF ! WCORR
4067           IF (wel_loc.gt.0.0d0) THEN
4068 C Contribution to the local-electrostatic energy coming from the i-j pair
4069           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3)
4070      &     +a33*muij(4)
4071 c          write (iout,*) 'i',i,' j',j,itype(i),itype(j),
4072 c     &                     ' eel_loc_ij',eel_loc_ij
4073 C          write(iout,*) 'muije=',i,j,muij(1),muij(2),muij(3),muij(4)
4074 C Calculate patrial derivative for theta angle
4075 #ifdef NEWCORR
4076          geel_loc_ij=a22*gmuij1(1)
4077      &     +a23*gmuij1(2)
4078      &     +a32*gmuij1(3)
4079      &     +a33*gmuij1(4)
4080 c         write(iout,*) "derivative over thatai"
4081 c         write(iout,*) a22*gmuij1(1), a23*gmuij1(2) ,a32*gmuij1(3),
4082 c     &   a33*gmuij1(4)
4083          gloc(nphi+i,icg)=gloc(nphi+i,icg)+
4084      &      geel_loc_ij*wel_loc
4085 c         write(iout,*) "derivative over thatai-1"
4086 c         write(iout,*) a22*gmuij2(1), a23*gmuij2(2) ,a32*gmuij2(3),
4087 c     &   a33*gmuij2(4)
4088          geel_loc_ij=
4089      &     a22*gmuij2(1)
4090      &     +a23*gmuij2(2)
4091      &     +a32*gmuij2(3)
4092      &     +a33*gmuij2(4)
4093          gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
4094      &      geel_loc_ij*wel_loc
4095 c  Derivative over j residue
4096          geel_loc_ji=a22*gmuji1(1)
4097      &     +a23*gmuji1(2)
4098      &     +a32*gmuji1(3)
4099      &     +a33*gmuji1(4)
4100 c         write(iout,*) "derivative over thataj"
4101 c         write(iout,*) a22*gmuji1(1), a23*gmuji1(2) ,a32*gmuji1(3),
4102 c     &   a33*gmuji1(4)
4103
4104         gloc(nphi+j,icg)=gloc(nphi+j,icg)+
4105      &      geel_loc_ji*wel_loc
4106          geel_loc_ji=
4107      &     +a22*gmuji2(1)
4108      &     +a23*gmuji2(2)
4109      &     +a32*gmuji2(3)
4110      &     +a33*gmuji2(4)
4111 c         write(iout,*) "derivative over thataj-1"
4112 c         write(iout,*) a22*gmuji2(1), a23*gmuji2(2) ,a32*gmuji2(3),
4113 c     &   a33*gmuji2(4)
4114          gloc(nphi+j-1,icg)=gloc(nphi+j-1,icg)+
4115      &      geel_loc_ji*wel_loc
4116 #endif
4117 cd          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
4118
4119           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
4120      &            'eelloc',i,j,eel_loc_ij
4121 c           if (eel_loc_ij.ne.0)
4122 c     &      write (iout,'(a4,2i4,8f9.5)')'chuj',
4123 c     &     i,j,a22,muij(1),a23,muij(2),a32,muij(3),a33,muij(4)
4124
4125           eel_loc=eel_loc+eel_loc_ij
4126 C Partial derivatives in virtual-bond dihedral angles gamma
4127           if (i.gt.1)
4128      &    gel_loc_loc(i-1)=gel_loc_loc(i-1)+
4129      &            a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j)
4130      &           +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j)
4131           gel_loc_loc(j-1)=gel_loc_loc(j-1)+
4132      &            a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j)
4133      &           +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j)
4134 C Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
4135           do l=1,3
4136             ggg(l)=agg(l,1)*muij(1)+
4137      &          agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4)
4138             gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l)
4139             gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l)
4140 cgrad            ghalf=0.5d0*ggg(l)
4141 cgrad            gel_loc(l,i)=gel_loc(l,i)+ghalf
4142 cgrad            gel_loc(l,j)=gel_loc(l,j)+ghalf
4143           enddo
4144 cgrad          do k=i+1,j2
4145 cgrad            do l=1,3
4146 cgrad              gel_loc(l,k)=gel_loc(l,k)+ggg(l)
4147 cgrad            enddo
4148 cgrad          enddo
4149 C Remaining derivatives of eello
4150           do l=1,3
4151             gel_loc(l,i)=gel_loc(l,i)+(aggi(l,1)*muij(1)+
4152      &        aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4))
4153             gel_loc(l,i+1)=gel_loc(l,i+1)+(aggi1(l,1)*muij(1)+
4154      &     aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4))
4155             gel_loc(l,j)=gel_loc(l,j)+(aggj(l,1)*muij(1)+
4156      &       aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4))
4157             gel_loc(l,j1)=gel_loc(l,j1)+(aggj1(l,1)*muij(1)+
4158      &     aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4))
4159           enddo
4160           ENDIF
4161 C Change 12/26/95 to calculate four-body contributions to H-bonding energy
4162 c          if (j.gt.i+1 .and. num_conti.le.maxconts) then
4163           if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0
4164      &       .and. num_conti.le.maxconts) then
4165 c            write (iout,*) i,j," entered corr"
4166 C
4167 C Calculate the contact function. The ith column of the array JCONT will
4168 C contain the numbers of atoms that make contacts with the atom I (of numbers
4169 C greater than I). The arrays FACONT and GACONT will contain the values of
4170 C the contact function and its derivative.
4171 c           r0ij=1.02D0*rpp(iteli,itelj)
4172 c           r0ij=1.11D0*rpp(iteli,itelj)
4173             r0ij=2.20D0*rpp(iteli,itelj)
4174 c           r0ij=1.55D0*rpp(iteli,itelj)
4175             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
4176             if (fcont.gt.0.0D0) then
4177               num_conti=num_conti+1
4178               if (num_conti.gt.maxconts) then
4179                 write (iout,*) 'WARNING - max. # of contacts exceeded;',
4180      &                         ' will skip next contacts for this conf.'
4181               else
4182                 jcont_hb(num_conti,i)=j
4183 cd                write (iout,*) "i",i," j",j," num_conti",num_conti,
4184 cd     &           " jcont_hb",jcont_hb(num_conti,i)
4185                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.
4186      &          wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
4187 C 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
4188 C  terms.
4189                 d_cont(num_conti,i)=rij
4190 cd                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
4191 C     --- Electrostatic-interaction matrix ---
4192                 a_chuj(1,1,num_conti,i)=a22
4193                 a_chuj(1,2,num_conti,i)=a23
4194                 a_chuj(2,1,num_conti,i)=a32
4195                 a_chuj(2,2,num_conti,i)=a33
4196 C     --- Gradient of rij
4197                 do kkk=1,3
4198                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
4199                 enddo
4200                 kkll=0
4201                 do k=1,2
4202                   do l=1,2
4203                     kkll=kkll+1
4204                     do m=1,3
4205                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
4206                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
4207                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
4208                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
4209                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
4210                     enddo
4211                   enddo
4212                 enddo
4213                 ENDIF
4214                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
4215 C Calculate contact energies
4216                 cosa4=4.0D0*cosa
4217                 wij=cosa-3.0D0*cosb*cosg
4218                 cosbg1=cosb+cosg
4219                 cosbg2=cosb-cosg
4220 c               fac3=dsqrt(-ael6i)/r0ij**3
4221                 fac3=dsqrt(-ael6i)*r3ij
4222 c                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
4223                 ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
4224                 if (ees0tmp.gt.0) then
4225                   ees0pij=dsqrt(ees0tmp)
4226                 else
4227                   ees0pij=0
4228                 endif
4229 c                ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
4230                 ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
4231                 if (ees0tmp.gt.0) then
4232                   ees0mij=dsqrt(ees0tmp)
4233                 else
4234                   ees0mij=0
4235                 endif
4236 c               ees0mij=0.0D0
4237                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij)
4238                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij)
4239 C Diagnostics. Comment out or remove after debugging!
4240 c               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
4241 c               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
4242 c               ees0m(num_conti,i)=0.0D0
4243 C End diagnostics.
4244 c               write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
4245 c    & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
4246 C Angular derivatives of the contact function
4247                 ees0pij1=fac3/ees0pij
4248                 ees0mij1=fac3/ees0mij
4249                 fac3p=-3.0D0*fac3*rrmij
4250                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
4251                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
4252 c               ees0mij1=0.0D0
4253                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
4254                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
4255                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
4256                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
4257                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
4258                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
4259                 ecosap=ecosa1+ecosa2
4260                 ecosbp=ecosb1+ecosb2
4261                 ecosgp=ecosg1+ecosg2
4262                 ecosam=ecosa1-ecosa2
4263                 ecosbm=ecosb1-ecosb2
4264                 ecosgm=ecosg1-ecosg2
4265 C Diagnostics
4266 c               ecosap=ecosa1
4267 c               ecosbp=ecosb1
4268 c               ecosgp=ecosg1
4269 c               ecosam=0.0D0
4270 c               ecosbm=0.0D0
4271 c               ecosgm=0.0D0
4272 C End diagnostics
4273                 facont_hb(num_conti,i)=fcont
4274                 fprimcont=fprimcont/rij
4275 cd              facont_hb(num_conti,i)=1.0D0
4276 C Following line is for diagnostics.
4277 cd              fprimcont=0.0D0
4278                 do k=1,3
4279                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
4280                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
4281                 enddo
4282                 do k=1,3
4283                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
4284                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
4285                 enddo
4286                 gggp(1)=gggp(1)+ees0pijp*xj
4287                 gggp(2)=gggp(2)+ees0pijp*yj
4288                 gggp(3)=gggp(3)+ees0pijp*zj
4289                 gggm(1)=gggm(1)+ees0mijp*xj
4290                 gggm(2)=gggm(2)+ees0mijp*yj
4291                 gggm(3)=gggm(3)+ees0mijp*zj
4292 C Derivatives due to the contact function
4293                 gacont_hbr(1,num_conti,i)=fprimcont*xj
4294                 gacont_hbr(2,num_conti,i)=fprimcont*yj
4295                 gacont_hbr(3,num_conti,i)=fprimcont*zj
4296                 do k=1,3
4297 c
4298 c 10/24/08 cgrad and ! comments indicate the parts of the code removed
4299 c          following the change of gradient-summation algorithm.
4300 c
4301 cgrad                  ghalfp=0.5D0*gggp(k)
4302 cgrad                  ghalfm=0.5D0*gggm(k)
4303                   gacontp_hb1(k,num_conti,i)=!ghalfp
4304      &              +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i))
4305      &              + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
4306                   gacontp_hb2(k,num_conti,i)=!ghalfp
4307      &              +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j))
4308      &              + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
4309                   gacontp_hb3(k,num_conti,i)=gggp(k)
4310                   gacontm_hb1(k,num_conti,i)=!ghalfm
4311      &              +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i))
4312      &              + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
4313                   gacontm_hb2(k,num_conti,i)=!ghalfm
4314      &              +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j))
4315      &              + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
4316                   gacontm_hb3(k,num_conti,i)=gggm(k)
4317                 enddo
4318 C Diagnostics. Comment out or remove after debugging!
4319 cdiag           do k=1,3
4320 cdiag             gacontp_hb1(k,num_conti,i)=0.0D0
4321 cdiag             gacontp_hb2(k,num_conti,i)=0.0D0
4322 cdiag             gacontp_hb3(k,num_conti,i)=0.0D0
4323 cdiag             gacontm_hb1(k,num_conti,i)=0.0D0
4324 cdiag             gacontm_hb2(k,num_conti,i)=0.0D0
4325 cdiag             gacontm_hb3(k,num_conti,i)=0.0D0
4326 cdiag           enddo
4327               ENDIF ! wcorr
4328               endif  ! num_conti.le.maxconts
4329             endif  ! fcont.gt.0
4330           endif    ! j.gt.i+1
4331           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
4332             do k=1,4
4333               do l=1,3
4334                 ghalf=0.5d0*agg(l,k)
4335                 aggi(l,k)=aggi(l,k)+ghalf
4336                 aggi1(l,k)=aggi1(l,k)+agg(l,k)
4337                 aggj(l,k)=aggj(l,k)+ghalf
4338               enddo
4339             enddo
4340             if (j.eq.nres-1 .and. i.lt.j-2) then
4341               do k=1,4
4342                 do l=1,3
4343                   aggj1(l,k)=aggj1(l,k)+agg(l,k)
4344                 enddo
4345               enddo
4346             endif
4347           endif
4348 c          t_eelecij=t_eelecij+MPI_Wtime()-time00
4349       return
4350       end
4351 C-----------------------------------------------------------------------------
4352       subroutine eturn3(i,eello_turn3)
4353 C Third- and fourth-order contributions from turns
4354       implicit real*8 (a-h,o-z)
4355       include 'DIMENSIONS'
4356       include 'COMMON.IOUNITS'
4357       include 'COMMON.GEO'
4358       include 'COMMON.VAR'
4359       include 'COMMON.LOCAL'
4360       include 'COMMON.CHAIN'
4361       include 'COMMON.DERIV'
4362       include 'COMMON.INTERACT'
4363       include 'COMMON.CONTACTS'
4364       include 'COMMON.TORSION'
4365       include 'COMMON.VECTORS'
4366       include 'COMMON.FFIELD'
4367       include 'COMMON.CONTROL'
4368       dimension ggg(3)
4369       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
4370      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
4371      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2),gpizda1(2,2),
4372      &  gpizda2(2,2),auxgmat1(2,2),auxgmatt1(2,2),
4373      &  auxgmat2(2,2),auxgmatt2(2,2)
4374       double precision agg(3,4),aggi(3,4),aggi1(3,4),
4375      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
4376       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
4377      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
4378      &    num_conti,j1,j2
4379       j=i+2
4380 c      write (iout,*) "eturn3",i,j,j1,j2
4381       a_temp(1,1)=a22
4382       a_temp(1,2)=a23
4383       a_temp(2,1)=a32
4384       a_temp(2,2)=a33
4385 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4386 C
4387 C               Third-order contributions
4388 C
4389 C                 (i+2)o----(i+3)
4390 C                      | |
4391 C                      | |
4392 C                 (i+1)o----i
4393 C
4394 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4395 cd        call checkint_turn3(i,a_temp,eello_turn3_num)
4396         call matmat2(EUg(1,1,i+1),EUg(1,1,i+2),auxmat(1,1))
4397 c auxalary matices for theta gradient
4398 c auxalary matrix for i+1 and constant i+2
4399         call matmat2(gtEUg(1,1,i+1),EUg(1,1,i+2),auxgmat1(1,1))
4400 c auxalary matrix for i+2 and constant i+1
4401         call matmat2(EUg(1,1,i+1),gtEUg(1,1,i+2),auxgmat2(1,1))
4402         call transpose2(auxmat(1,1),auxmat1(1,1))
4403         call transpose2(auxgmat1(1,1),auxgmatt1(1,1))
4404         call transpose2(auxgmat2(1,1),auxgmatt2(1,1))
4405         call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4406         call matmat2(a_temp(1,1),auxgmatt1(1,1),gpizda1(1,1))
4407         call matmat2(a_temp(1,1),auxgmatt2(1,1),gpizda2(1,1))
4408         eello_turn3=eello_turn3+0.5d0*(pizda(1,1)+pizda(2,2))
4409 C Derivatives in theta
4410         gloc(nphi+i,icg)=gloc(nphi+i,icg)
4411      &  +0.5d0*(gpizda1(1,1)+gpizda1(2,2))*wturn3
4412         gloc(nphi+i+1,icg)=gloc(nphi+i+1,icg)
4413      &  +0.5d0*(gpizda2(1,1)+gpizda2(2,2))*wturn3
4414
4415         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
4416      &          'eturn3',i,j,0.5d0*(pizda(1,1)+pizda(2,2))
4417 cd        write (2,*) 'i,',i,' j',j,'eello_turn3',
4418 cd     &    0.5d0*(pizda(1,1)+pizda(2,2)),
4419 cd     &    ' eello_turn3_num',4*eello_turn3_num
4420 C Derivatives in gamma(i)
4421         call matmat2(EUgder(1,1,i+1),EUg(1,1,i+2),auxmat2(1,1))
4422         call transpose2(auxmat2(1,1),auxmat3(1,1))
4423         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
4424         gel_loc_turn3(i)=gel_loc_turn3(i)+0.5d0*(pizda(1,1)+pizda(2,2))
4425 C Derivatives in gamma(i+1)
4426         call matmat2(EUg(1,1,i+1),EUgder(1,1,i+2),auxmat2(1,1))
4427         call transpose2(auxmat2(1,1),auxmat3(1,1))
4428         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
4429         gel_loc_turn3(i+1)=gel_loc_turn3(i+1)
4430      &    +0.5d0*(pizda(1,1)+pizda(2,2))
4431 C Cartesian derivatives
4432 !DIR$ UNROLL(0)
4433         do l=1,3
4434 c            ghalf1=0.5d0*agg(l,1)
4435 c            ghalf2=0.5d0*agg(l,2)
4436 c            ghalf3=0.5d0*agg(l,3)
4437 c            ghalf4=0.5d0*agg(l,4)
4438           a_temp(1,1)=aggi(l,1)!+ghalf1
4439           a_temp(1,2)=aggi(l,2)!+ghalf2
4440           a_temp(2,1)=aggi(l,3)!+ghalf3
4441           a_temp(2,2)=aggi(l,4)!+ghalf4
4442           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4443           gcorr3_turn(l,i)=gcorr3_turn(l,i)
4444      &      +0.5d0*(pizda(1,1)+pizda(2,2))
4445           a_temp(1,1)=aggi1(l,1)!+agg(l,1)
4446           a_temp(1,2)=aggi1(l,2)!+agg(l,2)
4447           a_temp(2,1)=aggi1(l,3)!+agg(l,3)
4448           a_temp(2,2)=aggi1(l,4)!+agg(l,4)
4449           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4450           gcorr3_turn(l,i+1)=gcorr3_turn(l,i+1)
4451      &      +0.5d0*(pizda(1,1)+pizda(2,2))
4452           a_temp(1,1)=aggj(l,1)!+ghalf1
4453           a_temp(1,2)=aggj(l,2)!+ghalf2
4454           a_temp(2,1)=aggj(l,3)!+ghalf3
4455           a_temp(2,2)=aggj(l,4)!+ghalf4
4456           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4457           gcorr3_turn(l,j)=gcorr3_turn(l,j)
4458      &      +0.5d0*(pizda(1,1)+pizda(2,2))
4459           a_temp(1,1)=aggj1(l,1)
4460           a_temp(1,2)=aggj1(l,2)
4461           a_temp(2,1)=aggj1(l,3)
4462           a_temp(2,2)=aggj1(l,4)
4463           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4464           gcorr3_turn(l,j1)=gcorr3_turn(l,j1)
4465      &      +0.5d0*(pizda(1,1)+pizda(2,2))
4466         enddo
4467       return
4468       end
4469 C-------------------------------------------------------------------------------
4470       subroutine eturn4(i,eello_turn4)
4471 C Third- and fourth-order contributions from turns
4472       implicit real*8 (a-h,o-z)
4473       include 'DIMENSIONS'
4474       include 'COMMON.IOUNITS'
4475       include 'COMMON.GEO'
4476       include 'COMMON.VAR'
4477       include 'COMMON.LOCAL'
4478       include 'COMMON.CHAIN'
4479       include 'COMMON.DERIV'
4480       include 'COMMON.INTERACT'
4481       include 'COMMON.CONTACTS'
4482       include 'COMMON.TORSION'
4483       include 'COMMON.VECTORS'
4484       include 'COMMON.FFIELD'
4485       include 'COMMON.CONTROL'
4486       dimension ggg(3)
4487       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
4488      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
4489      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2),auxgvec(2),
4490      &  auxgEvec1(2),auxgEvec2(2),auxgEvec3(2),
4491      &  gte1t(2,2),gte2t(2,2),gte3t(2,2),
4492      &  gte1a(2,2),gtae3(2,2),gtae3e2(2,2), ae3gte2(2,2),
4493      &  gtEpizda1(2,2),gtEpizda2(2,2),gtEpizda3(2,2)
4494       double precision agg(3,4),aggi(3,4),aggi1(3,4),
4495      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
4496       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
4497      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
4498      &    num_conti,j1,j2
4499       j=i+3
4500 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4501 C
4502 C               Fourth-order contributions
4503 C
4504 C                 (i+3)o----(i+4)
4505 C                     /  |
4506 C               (i+2)o   |
4507 C                     \  |
4508 C                 (i+1)o----i
4509 C
4510 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4511 cd        call checkint_turn4(i,a_temp,eello_turn4_num)
4512 c        write (iout,*) "eturn4 i",i," j",j," j1",j1," j2",j2
4513 c        write(iout,*)"WCHODZE W PROGRAM"
4514         a_temp(1,1)=a22
4515         a_temp(1,2)=a23
4516         a_temp(2,1)=a32
4517         a_temp(2,2)=a33
4518         iti1=itortyp(itype(i+1))
4519         iti2=itortyp(itype(i+2))
4520         iti3=itortyp(itype(i+3))
4521 c        write(iout,*) "iti1",iti1," iti2",iti2," iti3",iti3
4522         call transpose2(EUg(1,1,i+1),e1t(1,1))
4523         call transpose2(Eug(1,1,i+2),e2t(1,1))
4524         call transpose2(Eug(1,1,i+3),e3t(1,1))
4525 C Ematrix derivative in theta
4526         call transpose2(gtEUg(1,1,i+1),gte1t(1,1))
4527         call transpose2(gtEug(1,1,i+2),gte2t(1,1))
4528         call transpose2(gtEug(1,1,i+3),gte3t(1,1))
4529         call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4530 c       eta1 in derivative theta
4531         call matmat2(gte1t(1,1),a_temp(1,1),gte1a(1,1))
4532         call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4533 c       auxgvec is derivative of Ub2 so i+3 theta
4534         call matvec2(e1a(1,1),gUb2(1,i+3),auxgvec(1))
4535 c       auxalary matrix of E i+1
4536         call matvec2(gte1a(1,1),Ub2(1,i+3),auxgEvec1(1))
4537 c        s1=0.0
4538 c        gs1=0.0
4539         s1=scalar2(b1(1,i+2),auxvec(1))
4540 c derivative of theta i+2 with constant i+3
4541         gs23=scalar2(gtb1(1,i+2),auxvec(1))
4542 c derivative of theta i+2 with constant i+2
4543         gs32=scalar2(b1(1,i+2),auxgvec(1))
4544 c derivative of E matix in theta of i+1
4545         gsE13=scalar2(b1(1,i+2),auxgEvec1(1))
4546
4547         call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4548 c       ea31 in derivative theta
4549         call matmat2(a_temp(1,1),gte3t(1,1),gtae3(1,1))
4550         call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4551 c auxilary matrix auxgvec of Ub2 with constant E matirx
4552         call matvec2(ae3(1,1),gUb2(1,i+2),auxgvec(1))
4553 c auxilary matrix auxgEvec1 of E matix with Ub2 constant
4554         call matvec2(gtae3(1,1),Ub2(1,i+2),auxgEvec3(1))
4555
4556 c        s2=0.0
4557 c        gs2=0.0
4558         s2=scalar2(b1(1,i+1),auxvec(1))
4559 c derivative of theta i+1 with constant i+3
4560         gs13=scalar2(gtb1(1,i+1),auxvec(1))
4561 c derivative of theta i+2 with constant i+1
4562         gs21=scalar2(b1(1,i+1),auxgvec(1))
4563 c derivative of theta i+3 with constant i+1
4564         gsE31=scalar2(b1(1,i+1),auxgEvec3(1))
4565 c        write(iout,*) gs1,gs2,'i=',i,auxgvec(1),gUb2(1,i+2),gtb1(1,i+2),
4566 c     &  gtb1(1,i+1)
4567         call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4568 c two derivatives over diffetent matrices
4569 c gtae3e2 is derivative over i+3
4570         call matmat2(gtae3(1,1),e2t(1,1),gtae3e2(1,1))
4571 c ae3gte2 is derivative over i+2
4572         call matmat2(ae3(1,1),gte2t(1,1),ae3gte2(1,1))
4573         call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4574 c three possible derivative over theta E matices
4575 c i+1
4576         call matmat2(ae3e2(1,1),gte1t(1,1),gtEpizda1(1,1))
4577 c i+2
4578         call matmat2(ae3gte2(1,1),e1t(1,1),gtEpizda2(1,1))
4579 c i+3
4580         call matmat2(gtae3e2(1,1),e1t(1,1),gtEpizda3(1,1))
4581         s3=0.5d0*(pizda(1,1)+pizda(2,2))
4582
4583         gsEE1=0.5d0*(gtEpizda1(1,1)+gtEpizda1(2,2))
4584         gsEE2=0.5d0*(gtEpizda2(1,1)+gtEpizda2(2,2))
4585         gsEE3=0.5d0*(gtEpizda3(1,1)+gtEpizda3(2,2))
4586
4587         eello_turn4=eello_turn4-(s1+s2+s3)
4588 c             write(iout,*)'chujOWO', auxvec(1),b1(1,iti2)
4589 c        if (energy_dec) write (iout,'(a6,2i5,0pf7.3,3f7.3)')
4590 c     &      'eturn4',i,j,-(s1+s2+s3),s1,s2,s3
4591 cd        write (2,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
4592 cd     &    ' eello_turn4_num',8*eello_turn4_num
4593 #ifdef NEWCORR
4594         gloc(nphi+i,icg)=gloc(nphi+i,icg)
4595      &                  -(gs13+gsE13+gsEE1)*wturn4
4596         gloc(nphi+i+1,icg)= gloc(nphi+i+1,icg)
4597      &                    -(gs23+gs21+gsEE2)*wturn4
4598         gloc(nphi+i+2,icg)= gloc(nphi+i+2,icg)
4599      &                    -(gs32+gsE31+gsEE3)*wturn4
4600 c         gloc(nphi+i+1,icg)=gloc(nphi+i+1,icg)-
4601 c     &   gs2
4602 #endif
4603         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
4604      &      'eturn4',i,j,-(s1+s2+s3)
4605 c        write (iout,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
4606 c     &    ' eello_turn4_num',8*eello_turn4_num
4607 C Derivatives in gamma(i)
4608         call transpose2(EUgder(1,1,i+1),e1tder(1,1))
4609         call matmat2(e1tder(1,1),a_temp(1,1),auxmat(1,1))
4610         call matvec2(auxmat(1,1),Ub2(1,i+3),auxvec(1))
4611         s1=scalar2(b1(1,i+2),auxvec(1))
4612         call matmat2(ae3e2(1,1),e1tder(1,1),pizda(1,1))
4613         s3=0.5d0*(pizda(1,1)+pizda(2,2))
4614         gel_loc_turn4(i)=gel_loc_turn4(i)-(s1+s3)
4615 C Derivatives in gamma(i+1)
4616         call transpose2(EUgder(1,1,i+2),e2tder(1,1))
4617         call matvec2(ae3(1,1),Ub2der(1,i+2),auxvec(1))
4618         s2=scalar2(b1(1,i+1),auxvec(1))
4619         call matmat2(ae3(1,1),e2tder(1,1),auxmat(1,1))
4620         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
4621         s3=0.5d0*(pizda(1,1)+pizda(2,2))
4622         gel_loc_turn4(i+1)=gel_loc_turn4(i+1)-(s2+s3)
4623 C Derivatives in gamma(i+2)
4624         call transpose2(EUgder(1,1,i+3),e3tder(1,1))
4625         call matvec2(e1a(1,1),Ub2der(1,i+3),auxvec(1))
4626         s1=scalar2(b1(1,i+2),auxvec(1))
4627         call matmat2(a_temp(1,1),e3tder(1,1),auxmat(1,1))
4628         call matvec2(auxmat(1,1),Ub2(1,i+2),auxvec(1))
4629         s2=scalar2(b1(1,i+1),auxvec(1))
4630         call matmat2(auxmat(1,1),e2t(1,1),auxmat3(1,1))
4631         call matmat2(auxmat3(1,1),e1t(1,1),pizda(1,1))
4632         s3=0.5d0*(pizda(1,1)+pizda(2,2))
4633         gel_loc_turn4(i+2)=gel_loc_turn4(i+2)-(s1+s2+s3)
4634 C Cartesian derivatives
4635 C Derivatives of this turn contributions in DC(i+2)
4636         if (j.lt.nres-1) then
4637           do l=1,3
4638             a_temp(1,1)=agg(l,1)
4639             a_temp(1,2)=agg(l,2)
4640             a_temp(2,1)=agg(l,3)
4641             a_temp(2,2)=agg(l,4)
4642             call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4643             call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4644             s1=scalar2(b1(1,i+2),auxvec(1))
4645             call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4646             call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4647             s2=scalar2(b1(1,i+1),auxvec(1))
4648             call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4649             call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4650             s3=0.5d0*(pizda(1,1)+pizda(2,2))
4651             ggg(l)=-(s1+s2+s3)
4652             gcorr4_turn(l,i+2)=gcorr4_turn(l,i+2)-(s1+s2+s3)
4653           enddo
4654         endif
4655 C Remaining derivatives of this turn contribution
4656         do l=1,3
4657           a_temp(1,1)=aggi(l,1)
4658           a_temp(1,2)=aggi(l,2)
4659           a_temp(2,1)=aggi(l,3)
4660           a_temp(2,2)=aggi(l,4)
4661           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4662           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4663           s1=scalar2(b1(1,i+2),auxvec(1))
4664           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4665           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4666           s2=scalar2(b1(1,i+1),auxvec(1))
4667           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4668           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4669           s3=0.5d0*(pizda(1,1)+pizda(2,2))
4670           gcorr4_turn(l,i)=gcorr4_turn(l,i)-(s1+s2+s3)
4671           a_temp(1,1)=aggi1(l,1)
4672           a_temp(1,2)=aggi1(l,2)
4673           a_temp(2,1)=aggi1(l,3)
4674           a_temp(2,2)=aggi1(l,4)
4675           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4676           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4677           s1=scalar2(b1(1,i+2),auxvec(1))
4678           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4679           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4680           s2=scalar2(b1(1,i+1),auxvec(1))
4681           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4682           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4683           s3=0.5d0*(pizda(1,1)+pizda(2,2))
4684           gcorr4_turn(l,i+1)=gcorr4_turn(l,i+1)-(s1+s2+s3)
4685           a_temp(1,1)=aggj(l,1)
4686           a_temp(1,2)=aggj(l,2)
4687           a_temp(2,1)=aggj(l,3)
4688           a_temp(2,2)=aggj(l,4)
4689           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4690           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4691           s1=scalar2(b1(1,i+2),auxvec(1))
4692           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4693           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4694           s2=scalar2(b1(1,i+1),auxvec(1))
4695           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4696           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4697           s3=0.5d0*(pizda(1,1)+pizda(2,2))
4698           gcorr4_turn(l,j)=gcorr4_turn(l,j)-(s1+s2+s3)
4699           a_temp(1,1)=aggj1(l,1)
4700           a_temp(1,2)=aggj1(l,2)
4701           a_temp(2,1)=aggj1(l,3)
4702           a_temp(2,2)=aggj1(l,4)
4703           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4704           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4705           s1=scalar2(b1(1,i+2),auxvec(1))
4706           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4707           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4708           s2=scalar2(b1(1,i+1),auxvec(1))
4709           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4710           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4711           s3=0.5d0*(pizda(1,1)+pizda(2,2))
4712 c          write (iout,*) "s1",s1," s2",s2," s3",s3," s1+s2+s3",s1+s2+s3
4713           gcorr4_turn(l,j1)=gcorr4_turn(l,j1)-(s1+s2+s3)
4714         enddo
4715       return
4716       end
4717 C-----------------------------------------------------------------------------
4718       subroutine vecpr(u,v,w)
4719       implicit real*8(a-h,o-z)
4720       dimension u(3),v(3),w(3)
4721       w(1)=u(2)*v(3)-u(3)*v(2)
4722       w(2)=-u(1)*v(3)+u(3)*v(1)
4723       w(3)=u(1)*v(2)-u(2)*v(1)
4724       return
4725       end
4726 C-----------------------------------------------------------------------------
4727       subroutine unormderiv(u,ugrad,unorm,ungrad)
4728 C This subroutine computes the derivatives of a normalized vector u, given
4729 C the derivatives computed without normalization conditions, ugrad. Returns
4730 C ungrad.
4731       implicit none
4732       double precision u(3),ugrad(3,3),unorm,ungrad(3,3)
4733       double precision vec(3)
4734       double precision scalar
4735       integer i,j
4736 c      write (2,*) 'ugrad',ugrad
4737 c      write (2,*) 'u',u
4738       do i=1,3
4739         vec(i)=scalar(ugrad(1,i),u(1))
4740       enddo
4741 c      write (2,*) 'vec',vec
4742       do i=1,3
4743         do j=1,3
4744           ungrad(j,i)=(ugrad(j,i)-u(j)*vec(i))*unorm
4745         enddo
4746       enddo
4747 c      write (2,*) 'ungrad',ungrad
4748       return
4749       end
4750 C-----------------------------------------------------------------------------
4751       subroutine escp_soft_sphere(evdw2,evdw2_14)
4752 C
4753 C This subroutine calculates the excluded-volume interaction energy between
4754 C peptide-group centers and side chains and its gradient in virtual-bond and
4755 C side-chain vectors.
4756 C
4757       implicit real*8 (a-h,o-z)
4758       include 'DIMENSIONS'
4759       include 'COMMON.GEO'
4760       include 'COMMON.VAR'
4761       include 'COMMON.LOCAL'
4762       include 'COMMON.CHAIN'
4763       include 'COMMON.DERIV'
4764       include 'COMMON.INTERACT'
4765       include 'COMMON.FFIELD'
4766       include 'COMMON.IOUNITS'
4767       include 'COMMON.CONTROL'
4768       dimension ggg(3)
4769       evdw2=0.0D0
4770       evdw2_14=0.0d0
4771       r0_scp=4.5d0
4772 cd    print '(a)','Enter ESCP'
4773 cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
4774 C      do xshift=-1,1
4775 C      do yshift=-1,1
4776 C      do zshift=-1,1
4777       do i=iatscp_s,iatscp_e
4778         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
4779         iteli=itel(i)
4780         xi=0.5D0*(c(1,i)+c(1,i+1))
4781         yi=0.5D0*(c(2,i)+c(2,i+1))
4782         zi=0.5D0*(c(3,i)+c(3,i+1))
4783 C Return atom into box, boxxsize is size of box in x dimension
4784 c  134   continue
4785 c        if (xi.gt.((xshift+0.5d0)*boxxsize)) xi=xi-boxxsize
4786 c        if (xi.lt.((xshift-0.5d0)*boxxsize)) xi=xi+boxxsize
4787 C Condition for being inside the proper box
4788 c        if ((xi.gt.((xshift+0.5d0)*boxxsize)).or.
4789 c     &       (xi.lt.((xshift-0.5d0)*boxxsize))) then
4790 c        go to 134
4791 c        endif
4792 c  135   continue
4793 c        if (yi.gt.((yshift+0.5d0)*boxysize)) yi=yi-boxysize
4794 c        if (yi.lt.((yshift-0.5d0)*boxysize)) yi=yi+boxysize
4795 C Condition for being inside the proper box
4796 c        if ((yi.gt.((yshift+0.5d0)*boxysize)).or.
4797 c     &       (yi.lt.((yshift-0.5d0)*boxysize))) then
4798 c        go to 135
4799 c c       endif
4800 c  136   continue
4801 c        if (zi.gt.((zshift+0.5d0)*boxzsize)) zi=zi-boxzsize
4802 c        if (zi.lt.((zshift-0.5d0)*boxzsize)) zi=zi+boxzsize
4803 cC Condition for being inside the proper box
4804 c        if ((zi.gt.((zshift+0.5d0)*boxzsize)).or.
4805 c     &       (zi.lt.((zshift-0.5d0)*boxzsize))) then
4806 c        go to 136
4807 c        endif
4808           xi=mod(xi,boxxsize)
4809           if (xi.lt.0) xi=xi+boxxsize
4810           yi=mod(yi,boxysize)
4811           if (yi.lt.0) yi=yi+boxysize
4812           zi=mod(zi,boxzsize)
4813           if (zi.lt.0) zi=zi+boxzsize
4814 C          xi=xi+xshift*boxxsize
4815 C          yi=yi+yshift*boxysize
4816 C          zi=zi+zshift*boxzsize
4817         do iint=1,nscp_gr(i)
4818
4819         do j=iscpstart(i,iint),iscpend(i,iint)
4820           if (itype(j).eq.ntyp1) cycle
4821           itypj=iabs(itype(j))
4822 C Uncomment following three lines for SC-p interactions
4823 c         xj=c(1,nres+j)-xi
4824 c         yj=c(2,nres+j)-yi
4825 c         zj=c(3,nres+j)-zi
4826 C Uncomment following three lines for Ca-p interactions
4827           xj=c(1,j)
4828           yj=c(2,j)
4829           zj=c(3,j)
4830 c  174   continue
4831 c        if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
4832 c        if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
4833 C Condition for being inside the proper box
4834 c        if ((xj.gt.((0.5d0)*boxxsize)).or.
4835 c     &       (xj.lt.((-0.5d0)*boxxsize))) then
4836 c        go to 174
4837 c        endif
4838 c  175   continue
4839 c        if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
4840 c        if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
4841 cC Condition for being inside the proper box
4842 c        if ((yj.gt.((0.5d0)*boxysize)).or.
4843 c     &       (yj.lt.((-0.5d0)*boxysize))) then
4844 c        go to 175
4845 c        endif
4846 c  176   continue
4847 c        if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
4848 c        if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
4849 C Condition for being inside the proper box
4850 c        if ((zj.gt.((0.5d0)*boxzsize)).or.
4851 c     &       (zj.lt.((-0.5d0)*boxzsize))) then
4852 c        go to 176
4853           xj=mod(xj,boxxsize)
4854           if (xj.lt.0) xj=xj+boxxsize
4855           yj=mod(yj,boxysize)
4856           if (yj.lt.0) yj=yj+boxysize
4857           zj=mod(zj,boxzsize)
4858           if (zj.lt.0) zj=zj+boxzsize
4859       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
4860       xj_safe=xj
4861       yj_safe=yj
4862       zj_safe=zj
4863       subchap=0
4864       do xshift=-1,1
4865       do yshift=-1,1
4866       do zshift=-1,1
4867           xj=xj_safe+xshift*boxxsize
4868           yj=yj_safe+yshift*boxysize
4869           zj=zj_safe+zshift*boxzsize
4870           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
4871           if(dist_temp.lt.dist_init) then
4872             dist_init=dist_temp
4873             xj_temp=xj
4874             yj_temp=yj
4875             zj_temp=zj
4876             subchap=1
4877           endif
4878        enddo
4879        enddo
4880        enddo
4881        if (subchap.eq.1) then
4882           xj=xj_temp-xi
4883           yj=yj_temp-yi
4884           zj=zj_temp-zi
4885        else
4886           xj=xj_safe-xi
4887           yj=yj_safe-yi
4888           zj=zj_safe-zi
4889        endif
4890 c c       endif
4891 C          xj=xj-xi
4892 C          yj=yj-yi
4893 C          zj=zj-zi
4894           rij=xj*xj+yj*yj+zj*zj
4895
4896           r0ij=r0_scp
4897           r0ijsq=r0ij*r0ij
4898           if (rij.lt.r0ijsq) then
4899             evdwij=0.25d0*(rij-r0ijsq)**2
4900             fac=rij-r0ijsq
4901           else
4902             evdwij=0.0d0
4903             fac=0.0d0
4904           endif
4905           evdw2=evdw2+evdwij
4906 C
4907 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
4908 C
4909           ggg(1)=xj*fac
4910           ggg(2)=yj*fac
4911           ggg(3)=zj*fac
4912 cgrad          if (j.lt.i) then
4913 cd          write (iout,*) 'j<i'
4914 C Uncomment following three lines for SC-p interactions
4915 c           do k=1,3
4916 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
4917 c           enddo
4918 cgrad          else
4919 cd          write (iout,*) 'j>i'
4920 cgrad            do k=1,3
4921 cgrad              ggg(k)=-ggg(k)
4922 C Uncomment following line for SC-p interactions
4923 c             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
4924 cgrad            enddo
4925 cgrad          endif
4926 cgrad          do k=1,3
4927 cgrad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
4928 cgrad          enddo
4929 cgrad          kstart=min0(i+1,j)
4930 cgrad          kend=max0(i-1,j-1)
4931 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
4932 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
4933 cgrad          do k=kstart,kend
4934 cgrad            do l=1,3
4935 cgrad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
4936 cgrad            enddo
4937 cgrad          enddo
4938           do k=1,3
4939             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
4940             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
4941           enddo
4942         enddo
4943
4944         enddo ! iint
4945       enddo ! i
4946 C      enddo !zshift
4947 C      enddo !yshift
4948 C      enddo !xshift
4949       return
4950       end
4951 C-----------------------------------------------------------------------------
4952       subroutine escp(evdw2,evdw2_14)
4953 C
4954 C This subroutine calculates the excluded-volume interaction energy between
4955 C peptide-group centers and side chains and its gradient in virtual-bond and
4956 C side-chain vectors.
4957 C
4958       implicit real*8 (a-h,o-z)
4959       include 'DIMENSIONS'
4960       include 'COMMON.GEO'
4961       include 'COMMON.VAR'
4962       include 'COMMON.LOCAL'
4963       include 'COMMON.CHAIN'
4964       include 'COMMON.DERIV'
4965       include 'COMMON.INTERACT'
4966       include 'COMMON.FFIELD'
4967       include 'COMMON.IOUNITS'
4968       include 'COMMON.CONTROL'
4969       include 'COMMON.SPLITELE'
4970       dimension ggg(3)
4971       evdw2=0.0D0
4972       evdw2_14=0.0d0
4973 c        print *,boxxsize,boxysize,boxzsize,'wymiary pudla'
4974 cd    print '(a)','Enter ESCP'
4975 cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
4976 C      do xshift=-1,1
4977 C      do yshift=-1,1
4978 C      do zshift=-1,1
4979       do i=iatscp_s,iatscp_e
4980         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
4981         iteli=itel(i)
4982         xi=0.5D0*(c(1,i)+c(1,i+1))
4983         yi=0.5D0*(c(2,i)+c(2,i+1))
4984         zi=0.5D0*(c(3,i)+c(3,i+1))
4985           xi=mod(xi,boxxsize)
4986           if (xi.lt.0) xi=xi+boxxsize
4987           yi=mod(yi,boxysize)
4988           if (yi.lt.0) yi=yi+boxysize
4989           zi=mod(zi,boxzsize)
4990           if (zi.lt.0) zi=zi+boxzsize
4991 c          xi=xi+xshift*boxxsize
4992 c          yi=yi+yshift*boxysize
4993 c          zi=zi+zshift*boxzsize
4994 c        print *,xi,yi,zi,'polozenie i'
4995 C Return atom into box, boxxsize is size of box in x dimension
4996 c  134   continue
4997 c        if (xi.gt.((xshift+0.5d0)*boxxsize)) xi=xi-boxxsize
4998 c        if (xi.lt.((xshift-0.5d0)*boxxsize)) xi=xi+boxxsize
4999 C Condition for being inside the proper box
5000 c        if ((xi.gt.((xshift+0.5d0)*boxxsize)).or.
5001 c     &       (xi.lt.((xshift-0.5d0)*boxxsize))) then
5002 c        go to 134
5003 c        endif
5004 c  135   continue
5005 c          print *,xi,boxxsize,"pierwszy"
5006
5007 c        if (yi.gt.((yshift+0.5d0)*boxysize)) yi=yi-boxysize
5008 c        if (yi.lt.((yshift-0.5d0)*boxysize)) yi=yi+boxysize
5009 C Condition for being inside the proper box
5010 c        if ((yi.gt.((yshift+0.5d0)*boxysize)).or.
5011 c     &       (yi.lt.((yshift-0.5d0)*boxysize))) then
5012 c        go to 135
5013 c        endif
5014 c  136   continue
5015 c        if (zi.gt.((zshift+0.5d0)*boxzsize)) zi=zi-boxzsize
5016 c        if (zi.lt.((zshift-0.5d0)*boxzsize)) zi=zi+boxzsize
5017 C Condition for being inside the proper box
5018 c        if ((zi.gt.((zshift+0.5d0)*boxzsize)).or.
5019 c     &       (zi.lt.((zshift-0.5d0)*boxzsize))) then
5020 c        go to 136
5021 c        endif
5022         do iint=1,nscp_gr(i)
5023
5024         do j=iscpstart(i,iint),iscpend(i,iint)
5025           itypj=iabs(itype(j))
5026           if (itypj.eq.ntyp1) cycle
5027 C Uncomment following three lines for SC-p interactions
5028 c         xj=c(1,nres+j)-xi
5029 c         yj=c(2,nres+j)-yi
5030 c         zj=c(3,nres+j)-zi
5031 C Uncomment following three lines for Ca-p interactions
5032           xj=c(1,j)
5033           yj=c(2,j)
5034           zj=c(3,j)
5035           xj=mod(xj,boxxsize)
5036           if (xj.lt.0) xj=xj+boxxsize
5037           yj=mod(yj,boxysize)
5038           if (yj.lt.0) yj=yj+boxysize
5039           zj=mod(zj,boxzsize)
5040           if (zj.lt.0) zj=zj+boxzsize
5041 c  174   continue
5042 c        if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
5043 c        if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
5044 C Condition for being inside the proper box
5045 c        if ((xj.gt.((0.5d0)*boxxsize)).or.
5046 c     &       (xj.lt.((-0.5d0)*boxxsize))) then
5047 c        go to 174
5048 c        endif
5049 c  175   continue
5050 c        if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
5051 c        if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
5052 cC Condition for being inside the proper box
5053 c        if ((yj.gt.((0.5d0)*boxysize)).or.
5054 c     &       (yj.lt.((-0.5d0)*boxysize))) then
5055 c        go to 175
5056 c        endif
5057 c  176   continue
5058 c        if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
5059 c        if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
5060 C Condition for being inside the proper box
5061 c        if ((zj.gt.((0.5d0)*boxzsize)).or.
5062 c     &       (zj.lt.((-0.5d0)*boxzsize))) then
5063 c        go to 176
5064 c        endif
5065 CHERE IS THE CALCULATION WHICH MIRROR IMAGE IS THE CLOSEST ONE
5066       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
5067       xj_safe=xj
5068       yj_safe=yj
5069       zj_safe=zj
5070       subchap=0
5071       do xshift=-1,1
5072       do yshift=-1,1
5073       do zshift=-1,1
5074           xj=xj_safe+xshift*boxxsize
5075           yj=yj_safe+yshift*boxysize
5076           zj=zj_safe+zshift*boxzsize
5077           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
5078           if(dist_temp.lt.dist_init) then
5079             dist_init=dist_temp
5080             xj_temp=xj
5081             yj_temp=yj
5082             zj_temp=zj
5083             subchap=1
5084           endif
5085        enddo
5086        enddo
5087        enddo
5088        if (subchap.eq.1) then
5089           xj=xj_temp-xi
5090           yj=yj_temp-yi
5091           zj=zj_temp-zi
5092        else
5093           xj=xj_safe-xi
5094           yj=yj_safe-yi
5095           zj=zj_safe-zi
5096        endif
5097 c          print *,xj,yj,zj,'polozenie j'
5098           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
5099 c          print *,rrij
5100           sss=sscale(1.0d0/(dsqrt(rrij)))
5101 c          print *,r_cut,1.0d0/dsqrt(rrij),sss,'tu patrz'
5102 c          if (sss.eq.0) print *,'czasem jest OK'
5103           if (sss.le.0.0d0) cycle
5104           sssgrad=sscagrad(1.0d0/(dsqrt(rrij)))
5105           fac=rrij**expon2
5106           e1=fac*fac*aad(itypj,iteli)
5107           e2=fac*bad(itypj,iteli)
5108           if (iabs(j-i) .le. 2) then
5109             e1=scal14*e1
5110             e2=scal14*e2
5111             evdw2_14=evdw2_14+(e1+e2)*sss
5112           endif
5113           evdwij=e1+e2
5114           evdw2=evdw2+evdwij*sss
5115           if (energy_dec) write (iout,'(a6,2i5,0pf7.3,2i3,3e11.3)')
5116      &        'evdw2',i,j,evdwij
5117 c     &        ,iteli,itypj,fac,aad(itypj,iteli),bad(itypj,iteli)
5118 C
5119 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
5120 C
5121           fac=-(evdwij+e1)*rrij*sss
5122           fac=fac+(evdwij)*sssgrad*dsqrt(rrij)/expon
5123           ggg(1)=xj*fac
5124           ggg(2)=yj*fac
5125           ggg(3)=zj*fac
5126 cgrad          if (j.lt.i) then
5127 cd          write (iout,*) 'j<i'
5128 C Uncomment following three lines for SC-p interactions
5129 c           do k=1,3
5130 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
5131 c           enddo
5132 cgrad          else
5133 cd          write (iout,*) 'j>i'
5134 cgrad            do k=1,3
5135 cgrad              ggg(k)=-ggg(k)
5136 C Uncomment following line for SC-p interactions
5137 ccgrad             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
5138 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
5139 cgrad            enddo
5140 cgrad          endif
5141 cgrad          do k=1,3
5142 cgrad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
5143 cgrad          enddo
5144 cgrad          kstart=min0(i+1,j)
5145 cgrad          kend=max0(i-1,j-1)
5146 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
5147 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
5148 cgrad          do k=kstart,kend
5149 cgrad            do l=1,3
5150 cgrad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
5151 cgrad            enddo
5152 cgrad          enddo
5153           do k=1,3
5154             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
5155             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
5156           enddo
5157 c        endif !endif for sscale cutoff
5158         enddo ! j
5159
5160         enddo ! iint
5161       enddo ! i
5162 c      enddo !zshift
5163 c      enddo !yshift
5164 c      enddo !xshift
5165       do i=1,nct
5166         do j=1,3
5167           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
5168           gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
5169           gradx_scp(j,i)=expon*gradx_scp(j,i)
5170         enddo
5171       enddo
5172 C******************************************************************************
5173 C
5174 C                              N O T E !!!
5175 C
5176 C To save time the factor EXPON has been extracted from ALL components
5177 C of GVDWC and GRADX. Remember to multiply them by this factor before further
5178 C use!
5179 C
5180 C******************************************************************************
5181       return
5182       end
5183 C--------------------------------------------------------------------------
5184       subroutine edis(ehpb)
5185 C
5186 C Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors.
5187 C
5188       implicit real*8 (a-h,o-z)
5189       include 'DIMENSIONS'
5190       include 'COMMON.SBRIDGE'
5191       include 'COMMON.CHAIN'
5192       include 'COMMON.DERIV'
5193       include 'COMMON.VAR'
5194       include 'COMMON.INTERACT'
5195       include 'COMMON.IOUNITS'
5196       include 'COMMON.CONTROL'
5197       dimension ggg(3),ggg_peak(3,20)
5198       ehpb=0.0D0
5199       do i=1,3
5200        ggg(i)=0.0d0
5201       enddo
5202 C      write (iout,*) ,"link_end",link_end,constr_dist
5203 cd      write(iout,*)'edis: nhpb=',nhpb,' fbr=',fbr
5204 c      write(iout,*)'link_start=',link_start,' link_end=',link_end,
5205 c     &  " constr_dist",constr_dist," link_start_peak",link_start_peak,
5206 c     &  " link_end_peak",link_end_peak
5207       if (link_end.eq.0.and.link_end_peak.eq.0) return
5208       if (link_end_peak.ne.0) then
5209       do i=link_start_peak,link_end_peak
5210         ehpb_peak=0.0d0
5211 c        print *,"i",i," link_end_peak",link_end_peak," ipeak",
5212 c     &   ipeak(1,i),ipeak(2,i)
5213         do ip=ipeak(1,i),ipeak(2,i)
5214           ii=ihpb_peak(ip)
5215           jj=jhpb_peak(ip)
5216           dd=dist(ii,jj)
5217           iip=ip-ipeak(1,i)+1
5218 C iii and jjj point to the residues for which the distance is assigned.
5219           if (ii.gt.nres) then
5220             iii=ii-nres
5221             jjj=jj-nres
5222           else
5223             iii=ii
5224             jjj=jj
5225           endif
5226           aux=rlornmr1(dd,dhpb_peak(ip),dhpb1_peak(ip),forcon_peak(ip))
5227           aux=dexp(-scal_peak*aux)
5228           ehpb_peak=ehpb_peak+aux
5229           fac=rlornmr1prim(dd,dhpb_peak(ip),dhpb1_peak(ip),
5230      &      forcon_peak(ip))*aux/dd
5231           do j=1,3
5232             ggg_peak(j,iip)=fac*(c(j,jj)-c(j,ii))
5233           enddo
5234           if (energy_dec) write (iout,'(a6,3i5,6f10.3,i5)')
5235      &      "edisL",i,ii,jj,dd,dhpb_peak(ip),dhpb1_peak(ip),
5236      &      forcon_peak(ip),fordepth_peak(ip),ehpb_peak
5237         enddo
5238 c        write (iout,*) "ehpb_peak",ehpb_peak," scal_peak",scal_peak
5239         ehpb=ehpb-fordepth_peak(ipeak(1,i))*dlog(ehpb_peak)/scal_peak
5240         do ip=ipeak(1,i),ipeak(2,i)
5241           iip=ip-ipeak(1,i)+1
5242           do j=1,3
5243             ggg(j)=ggg_peak(j,iip)/ehpb_peak
5244           enddo
5245           ii=ihpb_peak(ip)
5246           jj=jhpb_peak(ip)
5247 C iii and jjj point to the residues for which the distance is assigned.
5248           if (ii.gt.nres) then
5249             iii=ii-nres
5250             jjj=jj-nres
5251           else
5252             iii=ii
5253             jjj=jj
5254           endif
5255           if (iii.lt.ii) then
5256             do j=1,3
5257               ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
5258               ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
5259             enddo
5260           endif
5261           do k=1,3
5262             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
5263             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
5264           enddo
5265         enddo
5266       enddo
5267       endif
5268       do i=link_start,link_end
5269 C If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a
5270 C CA-CA distance used in regularization of structure.
5271         ii=ihpb(i)
5272         jj=jhpb(i)
5273 C iii and jjj point to the residues for which the distance is assigned.
5274         if (ii.gt.nres) then
5275           iii=ii-nres
5276           jjj=jj-nres
5277         else
5278           iii=ii
5279           jjj=jj
5280         endif
5281 c        write (iout,*) "i",i," ii",ii," iii",iii," jj",jj," jjj",jjj,
5282 c     &    dhpb(i),dhpb1(i),forcon(i)
5283 C 24/11/03 AL: SS bridges handled separately because of introducing a specific
5284 C    distance and angle dependent SS bond potential.
5285 C        if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and.
5286 C     & iabs(itype(jjj)).eq.1) then
5287 cmc        if (ii.gt.nres .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then
5288 C 18/07/06 MC: Use the convention that the first nss pairs are SS bonds
5289         if (.not.dyn_ss .and. i.le.nss) then
5290 C 15/02/13 CC dynamic SSbond - additional check
5291           if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and.
5292      &        iabs(itype(jjj)).eq.1) then
5293            call ssbond_ene(iii,jjj,eij)
5294            ehpb=ehpb+eij
5295          endif
5296 cd          write (iout,*) "eij",eij
5297 cd   &   ' waga=',waga,' fac=',fac
5298 !        else if (ii.gt.nres .and. jj.gt.nres) then
5299         else
5300 C Calculate the distance between the two points and its difference from the
5301 C target distance.
5302           dd=dist(ii,jj)
5303           if (irestr_type(i).eq.11) then
5304             ehpb=ehpb+fordepth(i)!**4.0d0
5305      &           *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i))
5306             fac=fordepth(i)!**4.0d0
5307      &           *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd
5308             if (energy_dec) write (iout,'(a6,2i5,6f10.3,i5)')
5309      &        "edisL",ii,jj,dd,dhpb(i),dhpb1(i),forcon(i),fordepth(i),
5310      &        ehpb,irestr_type(i)
5311           else if (irestr_type(i).eq.10) then
5312 c AL 6//19/2018 cross-link restraints
5313             xdis = 0.5d0*(dd/forcon(i))**2
5314             expdis = dexp(-xdis)
5315 c            aux=(dhpb(i)+dhpb1(i)*xdis)*expdis+fordepth(i)
5316             aux=(dhpb(i)+dhpb1(i)*xdis*xdis)*expdis+fordepth(i)
5317 c            write (iout,*)"HERE: xdis",xdis," expdis",expdis," aux",aux,
5318 c     &          " wboltzd",wboltzd
5319             ehpb=ehpb-wboltzd*xlscore(i)*dlog(aux)
5320 c            fac=-wboltzd*(dhpb1(i)*(1.0d0-xdis)-dhpb(i))
5321             fac=-wboltzd*xlscore(i)*(dhpb1(i)*(2.0d0-xdis)*xdis-dhpb(i))
5322      &           *expdis/(aux*forcon(i)**2)
5323             if (energy_dec) write(iout,'(a6,2i5,6f10.3,i5)')
5324      &        "edisX",ii,jj,dd,dhpb(i),dhpb1(i),forcon(i),fordepth(i),
5325      &        -wboltzd*xlscore(i)*dlog(aux),irestr_type(i)
5326           else if (irestr_type(i).eq.2) then
5327 c Quartic restraints
5328             ehpb=ehpb+forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
5329             if (energy_dec) write(iout,'(a6,2i5,5f10.3,i5)')
5330      &      "edisQ",ii,jj,dd,dhpb(i),dhpb1(i),forcon(i),
5331      &      forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i)),irestr_type(i)
5332             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
5333           else
5334 c Quadratic restraints
5335             rdis=dd-dhpb(i)
5336 C Get the force constant corresponding to this distance.
5337             waga=forcon(i)
5338 C Calculate the contribution to energy.
5339             ehpb=ehpb+0.5d0*waga*rdis*rdis
5340             if (energy_dec) write(iout,'(a6,2i5,5f10.3,i5)')
5341      &      "edisS",ii,jj,dd,dhpb(i),dhpb1(i),forcon(i),
5342      &       0.5d0*waga*rdis*rdis,irestr_type(i)
5343 C
5344 C Evaluate gradient.
5345 C
5346             fac=waga*rdis/dd
5347           endif
5348 c Calculate Cartesian gradient
5349           do j=1,3
5350             ggg(j)=fac*(c(j,jj)-c(j,ii))
5351           enddo
5352 cd      print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
5353 C If this is a SC-SC distance, we need to calculate the contributions to the
5354 C Cartesian gradient in the SC vectors (ghpbx).
5355           if (iii.lt.ii) then
5356             do j=1,3
5357               ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
5358               ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
5359             enddo
5360           endif
5361 cgrad        do j=iii,jjj-1
5362 cgrad          do k=1,3
5363 cgrad            ghpbc(k,j)=ghpbc(k,j)+ggg(k)
5364 cgrad          enddo
5365 cgrad        enddo
5366           do k=1,3
5367             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
5368             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
5369           enddo
5370         endif
5371       enddo
5372       return
5373       end
5374 C--------------------------------------------------------------------------
5375       subroutine ssbond_ene(i,j,eij)
5376 C
5377 C Calculate the distance and angle dependent SS-bond potential energy
5378 C using a free-energy function derived based on RHF/6-31G** ab initio
5379 C calculations of diethyl disulfide.
5380 C
5381 C A. Liwo and U. Kozlowska, 11/24/03
5382 C
5383       implicit real*8 (a-h,o-z)
5384       include 'DIMENSIONS'
5385       include 'COMMON.SBRIDGE'
5386       include 'COMMON.CHAIN'
5387       include 'COMMON.DERIV'
5388       include 'COMMON.LOCAL'
5389       include 'COMMON.INTERACT'
5390       include 'COMMON.VAR'
5391       include 'COMMON.IOUNITS'
5392       double precision erij(3),dcosom1(3),dcosom2(3),gg(3)
5393       itypi=iabs(itype(i))
5394       xi=c(1,nres+i)
5395       yi=c(2,nres+i)
5396       zi=c(3,nres+i)
5397       dxi=dc_norm(1,nres+i)
5398       dyi=dc_norm(2,nres+i)
5399       dzi=dc_norm(3,nres+i)
5400 c      dsci_inv=dsc_inv(itypi)
5401       dsci_inv=vbld_inv(nres+i)
5402       itypj=iabs(itype(j))
5403 c      dscj_inv=dsc_inv(itypj)
5404       dscj_inv=vbld_inv(nres+j)
5405       xj=c(1,nres+j)-xi
5406       yj=c(2,nres+j)-yi
5407       zj=c(3,nres+j)-zi
5408       dxj=dc_norm(1,nres+j)
5409       dyj=dc_norm(2,nres+j)
5410       dzj=dc_norm(3,nres+j)
5411       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
5412       rij=dsqrt(rrij)
5413       erij(1)=xj*rij
5414       erij(2)=yj*rij
5415       erij(3)=zj*rij
5416       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
5417       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
5418       om12=dxi*dxj+dyi*dyj+dzi*dzj
5419       do k=1,3
5420         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
5421         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
5422       enddo
5423       rij=1.0d0/rij
5424       deltad=rij-d0cm
5425       deltat1=1.0d0-om1
5426       deltat2=1.0d0+om2
5427       deltat12=om2-om1+2.0d0
5428       cosphi=om12-om1*om2
5429       eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2)
5430      &  +akct*deltad*deltat12
5431      &  +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi+ebr
5432 c      write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth,
5433 c     &  " akct",akct," deltad",deltad," deltat",deltat1,deltat2,
5434 c     &  " deltat12",deltat12," eij",eij
5435       ed=2*akcm*deltad+akct*deltat12
5436       pom1=akct*deltad
5437       pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
5438       eom1=-2*akth*deltat1-pom1-om2*pom2
5439       eom2= 2*akth*deltat2+pom1-om1*pom2
5440       eom12=pom2
5441       do k=1,3
5442         ggk=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
5443         ghpbx(k,i)=ghpbx(k,i)-ggk
5444      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
5445      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
5446         ghpbx(k,j)=ghpbx(k,j)+ggk
5447      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
5448      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
5449         ghpbc(k,i)=ghpbc(k,i)-ggk
5450         ghpbc(k,j)=ghpbc(k,j)+ggk
5451       enddo
5452 C
5453 C Calculate the components of the gradient in DC and X
5454 C
5455 cgrad      do k=i,j-1
5456 cgrad        do l=1,3
5457 cgrad          ghpbc(l,k)=ghpbc(l,k)+gg(l)
5458 cgrad        enddo
5459 cgrad      enddo
5460       return
5461       end
5462 C--------------------------------------------------------------------------
5463       subroutine ebond(estr)
5464 c
5465 c Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
5466 c
5467       implicit real*8 (a-h,o-z)
5468       include 'DIMENSIONS'
5469       include 'COMMON.LOCAL'
5470       include 'COMMON.GEO'
5471       include 'COMMON.INTERACT'
5472       include 'COMMON.DERIV'
5473       include 'COMMON.VAR'
5474       include 'COMMON.CHAIN'
5475       include 'COMMON.IOUNITS'
5476       include 'COMMON.NAMES'
5477       include 'COMMON.FFIELD'
5478       include 'COMMON.CONTROL'
5479       include 'COMMON.SETUP'
5480       double precision u(3),ud(3)
5481       estr=0.0d0
5482       estr1=0.0d0
5483       do i=ibondp_start,ibondp_end
5484         if (itype(i-1).eq.ntyp1 .and. itype(i).eq.ntyp1) cycle
5485 c          estr1=estr1+gnmr1(vbld(i),-1.0d0,distchainmax)
5486 c          do j=1,3
5487 c          gradb(j,i-1)=gnmr1prim(vbld(i),-1.0d0,distchainmax)
5488 c     &      *dc(j,i-1)/vbld(i)
5489 c          enddo
5490 c          if (energy_dec) write(iout,*)
5491 c     &       "estr1",i,gnmr1(vbld(i),-1.0d0,distchainmax)
5492 c        else
5493 C       Checking if it involves dummy (NH3+ or COO-) group
5494          if (itype(i-1).eq.ntyp1 .or. itype(i).eq.ntyp1) then
5495 C YES   vbldpDUM is the equlibrium length of spring for Dummy atom
5496         diff = vbld(i)-vbldpDUM
5497          else
5498 C NO    vbldp0 is the equlibrium lenght of spring for peptide group
5499         diff = vbld(i)-vbldp0
5500          endif
5501         if (energy_dec)    write (iout,'(a7,i5,4f7.3)')
5502      &     "estr bb",i,vbld(i),vbldp0,diff,AKP*diff*diff
5503         estr=estr+diff*diff
5504         do j=1,3
5505           gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)
5506         enddo
5507 c        write (iout,'(i5,3f10.5)') i,(gradb(j,i-1),j=1,3)
5508 c        endif
5509       enddo
5510
5511       estr=0.5d0*AKP*estr+estr1
5512 c
5513 c 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included
5514 c
5515       do i=ibond_start,ibond_end
5516         iti=iabs(itype(i))
5517         if (iti.ne.10 .and. iti.ne.ntyp1) then
5518           nbi=nbondterm(iti)
5519           if (nbi.eq.1) then
5520             diff=vbld(i+nres)-vbldsc0(1,iti)
5521             if (energy_dec)  write (iout,*)
5522      &      "estr sc",i,iti,vbld(i+nres),vbldsc0(1,iti),diff,
5523      &      AKSC(1,iti),AKSC(1,iti)*diff*diff
5524             estr=estr+0.5d0*AKSC(1,iti)*diff*diff
5525             do j=1,3
5526               gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
5527             enddo
5528           else
5529             do j=1,nbi
5530               diff=vbld(i+nres)-vbldsc0(j,iti)
5531               ud(j)=aksc(j,iti)*diff
5532               u(j)=abond0(j,iti)+0.5d0*ud(j)*diff
5533             enddo
5534             uprod=u(1)
5535             do j=2,nbi
5536               uprod=uprod*u(j)
5537             enddo
5538             usum=0.0d0
5539             usumsqder=0.0d0
5540             do j=1,nbi
5541               uprod1=1.0d0
5542               uprod2=1.0d0
5543               do k=1,nbi
5544                 if (k.ne.j) then
5545                   uprod1=uprod1*u(k)
5546                   uprod2=uprod2*u(k)*u(k)
5547                 endif
5548               enddo
5549               usum=usum+uprod1
5550               usumsqder=usumsqder+ud(j)*uprod2
5551             enddo
5552             estr=estr+uprod/usum
5553             do j=1,3
5554              gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
5555             enddo
5556           endif
5557         endif
5558       enddo
5559       return
5560       end
5561 #ifdef CRYST_THETA
5562 C--------------------------------------------------------------------------
5563       subroutine ebend(etheta)
5564 C
5565 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
5566 C angles gamma and its derivatives in consecutive thetas and gammas.
5567 C
5568       implicit real*8 (a-h,o-z)
5569       include 'DIMENSIONS'
5570       include 'COMMON.LOCAL'
5571       include 'COMMON.GEO'
5572       include 'COMMON.INTERACT'
5573       include 'COMMON.DERIV'
5574       include 'COMMON.VAR'
5575       include 'COMMON.CHAIN'
5576       include 'COMMON.IOUNITS'
5577       include 'COMMON.NAMES'
5578       include 'COMMON.FFIELD'
5579       include 'COMMON.CONTROL'
5580       common /calcthet/ term1,term2,termm,diffak,ratak,
5581      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
5582      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
5583       double precision y(2),z(2)
5584       delta=0.02d0*pi
5585 c      time11=dexp(-2*time)
5586 c      time12=1.0d0
5587       etheta=0.0D0
5588 c     write (*,'(a,i2)') 'EBEND ICG=',icg
5589       do i=ithet_start,ithet_end
5590         if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
5591      &  .or.itype(i).eq.ntyp1) cycle
5592 C Zero the energy function and its derivative at 0 or pi.
5593         call splinthet(theta(i),0.5d0*delta,ss,ssd)
5594         it=itype(i-1)
5595         ichir1=isign(1,itype(i-2))
5596         ichir2=isign(1,itype(i))
5597          if (itype(i-2).eq.10) ichir1=isign(1,itype(i-1))
5598          if (itype(i).eq.10) ichir2=isign(1,itype(i-1))
5599          if (itype(i-1).eq.10) then
5600           itype1=isign(10,itype(i-2))
5601           ichir11=isign(1,itype(i-2))
5602           ichir12=isign(1,itype(i-2))
5603           itype2=isign(10,itype(i))
5604           ichir21=isign(1,itype(i))
5605           ichir22=isign(1,itype(i))
5606          endif
5607
5608         if (i.gt.3 .and. itype(i-3).ne.ntyp1) then
5609 #ifdef OSF
5610           phii=phi(i)
5611           if (phii.ne.phii) phii=150.0
5612 #else
5613           phii=phi(i)
5614 #endif
5615           y(1)=dcos(phii)
5616           y(2)=dsin(phii)
5617         else
5618           y(1)=0.0D0
5619           y(2)=0.0D0
5620         endif
5621         if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
5622 #ifdef OSF
5623           phii1=phi(i+1)
5624           if (phii1.ne.phii1) phii1=150.0
5625           phii1=pinorm(phii1)
5626           z(1)=cos(phii1)
5627 #else
5628           phii1=phi(i+1)
5629 #endif
5630           z(1)=dcos(phii1)
5631           z(2)=dsin(phii1)
5632         else
5633           z(1)=0.0D0
5634           z(2)=0.0D0
5635         endif
5636 C Calculate the "mean" value of theta from the part of the distribution
5637 C dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2).
5638 C In following comments this theta will be referred to as t_c.
5639         thet_pred_mean=0.0d0
5640         do k=1,2
5641             athetk=athet(k,it,ichir1,ichir2)
5642             bthetk=bthet(k,it,ichir1,ichir2)
5643           if (it.eq.10) then
5644              athetk=athet(k,itype1,ichir11,ichir12)
5645              bthetk=bthet(k,itype2,ichir21,ichir22)
5646           endif
5647          thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k)
5648 c         write(iout,*) 'chuj tu', y(k),z(k)
5649         enddo
5650         dthett=thet_pred_mean*ssd
5651         thet_pred_mean=thet_pred_mean*ss+a0thet(it)
5652 C Derivatives of the "mean" values in gamma1 and gamma2.
5653         dthetg1=(-athet(1,it,ichir1,ichir2)*y(2)
5654      &+athet(2,it,ichir1,ichir2)*y(1))*ss
5655          dthetg2=(-bthet(1,it,ichir1,ichir2)*z(2)
5656      &          +bthet(2,it,ichir1,ichir2)*z(1))*ss
5657          if (it.eq.10) then
5658       dthetg1=(-athet(1,itype1,ichir11,ichir12)*y(2)
5659      &+athet(2,itype1,ichir11,ichir12)*y(1))*ss
5660         dthetg2=(-bthet(1,itype2,ichir21,ichir22)*z(2)
5661      &         +bthet(2,itype2,ichir21,ichir22)*z(1))*ss
5662          endif
5663         if (theta(i).gt.pi-delta) then
5664           call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,
5665      &         E_tc0)
5666           call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0)
5667           call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
5668           call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,
5669      &        E_theta)
5670           call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,
5671      &        E_tc)
5672         else if (theta(i).lt.delta) then
5673           call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0)
5674           call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
5675           call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,
5676      &        E_theta)
5677           call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0)
5678           call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,
5679      &        E_tc)
5680         else
5681           call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,
5682      &        E_theta,E_tc)
5683         endif
5684         etheta=etheta+ethetai
5685         if (energy_dec) write (iout,'(a6,i5,0pf7.3,f7.3,i5)')
5686      &      'ebend',i,ethetai,theta(i),itype(i)
5687         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1
5688         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2
5689         gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)+gloc(nphi+i-2,icg)
5690       enddo
5691
5692 C Ufff.... We've done all this!!!
5693       return
5694       end
5695 C---------------------------------------------------------------------------
5696       subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,
5697      &     E_tc)
5698       implicit real*8 (a-h,o-z)
5699       include 'DIMENSIONS'
5700       include 'COMMON.LOCAL'
5701       include 'COMMON.IOUNITS'
5702       common /calcthet/ term1,term2,termm,diffak,ratak,
5703      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
5704      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
5705 C Calculate the contributions to both Gaussian lobes.
5706 C 6/6/97 - Deform the Gaussians using the factor of 1/(1+time)
5707 C The "polynomial part" of the "standard deviation" of this part of
5708 C the distributioni.
5709 ccc        write (iout,*) thetai,thet_pred_mean
5710         sig=polthet(3,it)
5711         do j=2,0,-1
5712           sig=sig*thet_pred_mean+polthet(j,it)
5713         enddo
5714 C Derivative of the "interior part" of the "standard deviation of the"
5715 C gamma-dependent Gaussian lobe in t_c.
5716         sigtc=3*polthet(3,it)
5717         do j=2,1,-1
5718           sigtc=sigtc*thet_pred_mean+j*polthet(j,it)
5719         enddo
5720         sigtc=sig*sigtc
5721 C Set the parameters of both Gaussian lobes of the distribution.
5722 C "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc)
5723         fac=sig*sig+sigc0(it)
5724         sigcsq=fac+fac
5725         sigc=1.0D0/sigcsq
5726 C Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c
5727         sigsqtc=-4.0D0*sigcsq*sigtc
5728 c       print *,i,sig,sigtc,sigsqtc
5729 C Following variable (sigtc) is d[sigma(t_c)]/dt_c
5730         sigtc=-sigtc/(fac*fac)
5731 C Following variable is sigma(t_c)**(-2)
5732         sigcsq=sigcsq*sigcsq
5733         sig0i=sig0(it)
5734         sig0inv=1.0D0/sig0i**2
5735         delthec=thetai-thet_pred_mean
5736         delthe0=thetai-theta0i
5737         term1=-0.5D0*sigcsq*delthec*delthec
5738         term2=-0.5D0*sig0inv*delthe0*delthe0
5739 C        write (iout,*)'term1',term1,term2,sigcsq,delthec,sig0inv,delthe0
5740 C Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and
5741 C NaNs in taking the logarithm. We extract the largest exponent which is added
5742 C to the energy (this being the log of the distribution) at the end of energy
5743 C term evaluation for this virtual-bond angle.
5744         if (term1.gt.term2) then
5745           termm=term1
5746           term2=dexp(term2-termm)
5747           term1=1.0d0
5748         else
5749           termm=term2
5750           term1=dexp(term1-termm)
5751           term2=1.0d0
5752         endif
5753 C The ratio between the gamma-independent and gamma-dependent lobes of
5754 C the distribution is a Gaussian function of thet_pred_mean too.
5755         diffak=gthet(2,it)-thet_pred_mean
5756         ratak=diffak/gthet(3,it)**2
5757         ak=dexp(gthet(1,it)-0.5D0*diffak*ratak)
5758 C Let's differentiate it in thet_pred_mean NOW.
5759         aktc=ak*ratak
5760 C Now put together the distribution terms to make complete distribution.
5761         termexp=term1+ak*term2
5762         termpre=sigc+ak*sig0i
5763 C Contribution of the bending energy from this theta is just the -log of
5764 C the sum of the contributions from the two lobes and the pre-exponential
5765 C factor. Simple enough, isn't it?
5766         ethetai=(-dlog(termexp)-termm+dlog(termpre))
5767 C       write (iout,*) 'termexp',termexp,termm,termpre,i
5768 C NOW the derivatives!!!
5769 C 6/6/97 Take into account the deformation.
5770         E_theta=(delthec*sigcsq*term1
5771      &       +ak*delthe0*sig0inv*term2)/termexp
5772         E_tc=((sigtc+aktc*sig0i)/termpre
5773      &      -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+
5774      &       aktc*term2)/termexp)
5775       return
5776       end
5777 c-----------------------------------------------------------------------------
5778       subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)
5779       implicit real*8 (a-h,o-z)
5780       include 'DIMENSIONS'
5781       include 'COMMON.LOCAL'
5782       include 'COMMON.IOUNITS'
5783       common /calcthet/ term1,term2,termm,diffak,ratak,
5784      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
5785      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
5786       delthec=thetai-thet_pred_mean
5787       delthe0=thetai-theta0i
5788 C "Thank you" to MAPLE (probably spared one day of hand-differentiation).
5789       t3 = thetai-thet_pred_mean
5790       t6 = t3**2
5791       t9 = term1
5792       t12 = t3*sigcsq
5793       t14 = t12+t6*sigsqtc
5794       t16 = 1.0d0
5795       t21 = thetai-theta0i
5796       t23 = t21**2
5797       t26 = term2
5798       t27 = t21*t26
5799       t32 = termexp
5800       t40 = t32**2
5801       E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9
5802      & -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40
5803      & *(-t12*t9-ak*sig0inv*t27)
5804       return
5805       end
5806 #else
5807 C--------------------------------------------------------------------------
5808       subroutine ebend(etheta)
5809 C
5810 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
5811 C angles gamma and its derivatives in consecutive thetas and gammas.
5812 C ab initio-derived potentials from
5813 c Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203
5814 C
5815       implicit real*8 (a-h,o-z)
5816       include 'DIMENSIONS'
5817       include 'COMMON.LOCAL'
5818       include 'COMMON.GEO'
5819       include 'COMMON.INTERACT'
5820       include 'COMMON.DERIV'
5821       include 'COMMON.VAR'
5822       include 'COMMON.CHAIN'
5823       include 'COMMON.IOUNITS'
5824       include 'COMMON.NAMES'
5825       include 'COMMON.FFIELD'
5826       include 'COMMON.CONTROL'
5827       double precision coskt(mmaxtheterm),sinkt(mmaxtheterm),
5828      & cosph1(maxsingle),sinph1(maxsingle),cosph2(maxsingle),
5829      & sinph2(maxsingle),cosph1ph2(maxdouble,maxdouble),
5830      & sinph1ph2(maxdouble,maxdouble)
5831       logical lprn /.false./, lprn1 /.false./
5832       etheta=0.0D0
5833       do i=ithet_start,ithet_end
5834 c        if (i.eq.2) cycle
5835 c        print *,i,itype(i-1),itype(i),itype(i-2)
5836         if ((itype(i-1).eq.ntyp1).or.(itype(i-2).eq.ntyp1)
5837      &  .or.(itype(i).eq.ntyp1)) cycle
5838 C In current verion the ALL DUMMY ATOM POTENTIALS ARE OFF
5839
5840         if (iabs(itype(i+1)).eq.20) iblock=2
5841         if (iabs(itype(i+1)).ne.20) iblock=1
5842         dethetai=0.0d0
5843         dephii=0.0d0
5844         dephii1=0.0d0
5845         theti2=0.5d0*theta(i)
5846         ityp2=ithetyp((itype(i-1)))
5847         do k=1,nntheterm
5848           coskt(k)=dcos(k*theti2)
5849           sinkt(k)=dsin(k*theti2)
5850         enddo
5851         if (i.gt.3 .and. itype(max0(i-3,1)).ne.ntyp1) then
5852 #ifdef OSF
5853           phii=phi(i)
5854           if (phii.ne.phii) phii=150.0
5855 #else
5856           phii=phi(i)
5857 #endif
5858           ityp1=ithetyp((itype(i-2)))
5859 C propagation of chirality for glycine type
5860           do k=1,nsingle
5861             cosph1(k)=dcos(k*phii)
5862             sinph1(k)=dsin(k*phii)
5863           enddo
5864         else
5865           phii=0.0d0
5866           ityp1=ithetyp(itype(i-2))
5867           do k=1,nsingle
5868             cosph1(k)=0.0d0
5869             sinph1(k)=0.0d0
5870           enddo
5871         endif
5872         if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
5873 #ifdef OSF
5874           phii1=phi(i+1)
5875           if (phii1.ne.phii1) phii1=150.0
5876           phii1=pinorm(phii1)
5877 #else
5878           phii1=phi(i+1)
5879 #endif
5880           ityp3=ithetyp((itype(i)))
5881           do k=1,nsingle
5882             cosph2(k)=dcos(k*phii1)
5883             sinph2(k)=dsin(k*phii1)
5884           enddo
5885         else
5886           phii1=0.0d0
5887           ityp3=ithetyp(itype(i))
5888           do k=1,nsingle
5889             cosph2(k)=0.0d0
5890             sinph2(k)=0.0d0
5891           enddo
5892         endif
5893         ethetai=aa0thet(ityp1,ityp2,ityp3,iblock)
5894         do k=1,ndouble
5895           do l=1,k-1
5896             ccl=cosph1(l)*cosph2(k-l)
5897             ssl=sinph1(l)*sinph2(k-l)
5898             scl=sinph1(l)*cosph2(k-l)
5899             csl=cosph1(l)*sinph2(k-l)
5900             cosph1ph2(l,k)=ccl-ssl
5901             cosph1ph2(k,l)=ccl+ssl
5902             sinph1ph2(l,k)=scl+csl
5903             sinph1ph2(k,l)=scl-csl
5904           enddo
5905         enddo
5906         if (lprn) then
5907         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,
5908      &    " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
5909         write (iout,*) "coskt and sinkt"
5910         do k=1,nntheterm
5911           write (iout,*) k,coskt(k),sinkt(k)
5912         enddo
5913         endif
5914         do k=1,ntheterm
5915           ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3,iblock)*sinkt(k)
5916           dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3,iblock)
5917      &      *coskt(k)
5918           if (lprn)
5919      &    write (iout,*) "k",k,"
5920      &     aathet",aathet(k,ityp1,ityp2,ityp3,iblock),
5921      &     " ethetai",ethetai
5922         enddo
5923         if (lprn) then
5924         write (iout,*) "cosph and sinph"
5925         do k=1,nsingle
5926           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
5927         enddo
5928         write (iout,*) "cosph1ph2 and sinph2ph2"
5929         do k=2,ndouble
5930           do l=1,k-1
5931             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),
5932      &         sinph1ph2(l,k),sinph1ph2(k,l)
5933           enddo
5934         enddo
5935         write(iout,*) "ethetai",ethetai
5936         endif
5937         do m=1,ntheterm2
5938           do k=1,nsingle
5939             aux=bbthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)
5940      &         +ccthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k)
5941      &         +ddthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)
5942      &         +eethet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k)
5943             ethetai=ethetai+sinkt(m)*aux
5944             dethetai=dethetai+0.5d0*m*aux*coskt(m)
5945             dephii=dephii+k*sinkt(m)*(
5946      &          ccthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)-
5947      &          bbthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k))
5948             dephii1=dephii1+k*sinkt(m)*(
5949      &          eethet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)-
5950      &          ddthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k))
5951             if (lprn)
5952      &      write (iout,*) "m",m," k",k," bbthet",
5953      &         bbthet(k,m,ityp1,ityp2,ityp3,iblock)," ccthet",
5954      &         ccthet(k,m,ityp1,ityp2,ityp3,iblock)," ddthet",
5955      &         ddthet(k,m,ityp1,ityp2,ityp3,iblock)," eethet",
5956      &         eethet(k,m,ityp1,ityp2,ityp3,iblock)," ethetai",ethetai
5957           enddo
5958         enddo
5959         if (lprn)
5960      &  write(iout,*) "ethetai",ethetai
5961         do m=1,ntheterm3
5962           do k=2,ndouble
5963             do l=1,k-1
5964               aux=ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
5965      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l)+
5966      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
5967      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)
5968               ethetai=ethetai+sinkt(m)*aux
5969               dethetai=dethetai+0.5d0*m*coskt(m)*aux
5970               dephii=dephii+l*sinkt(m)*(
5971      &           -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)-
5972      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
5973      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
5974      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
5975               dephii1=dephii1+(k-l)*sinkt(m)*(
5976      &           -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
5977      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
5978      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)-
5979      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
5980               if (lprn) then
5981               write (iout,*) "m",m," k",k," l",l," ffthet",
5982      &            ffthet(l,k,m,ityp1,ityp2,ityp3,iblock),
5983      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)," ggthet",
5984      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock),
5985      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock),
5986      &            " ethetai",ethetai
5987               write (iout,*) cosph1ph2(l,k)*sinkt(m),
5988      &            cosph1ph2(k,l)*sinkt(m),
5989      &            sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
5990               endif
5991             enddo
5992           enddo
5993         enddo
5994 10      continue
5995 c        lprn1=.true.
5996         if (lprn1)
5997      &    write (iout,'(i2,3f8.1,9h ethetai ,f10.5)')
5998      &   i,theta(i)*rad2deg,phii*rad2deg,
5999      &   phii1*rad2deg,ethetai
6000 c        lprn1=.false.
6001         etheta=etheta+ethetai
6002         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
6003      &      'ebend',i,ethetai
6004         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
6005         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
6006         gloc(nphi+i-2,icg)=wang*dethetai+gloc(nphi+i-2,icg)
6007       enddo
6008
6009       return
6010       end
6011 #endif
6012 #ifdef CRYST_SC
6013 c-----------------------------------------------------------------------------
6014       subroutine esc(escloc)
6015 C Calculate the local energy of a side chain and its derivatives in the
6016 C corresponding virtual-bond valence angles THETA and the spherical angles
6017 C ALPHA and OMEGA.
6018       implicit real*8 (a-h,o-z)
6019       include 'DIMENSIONS'
6020       include 'COMMON.GEO'
6021       include 'COMMON.LOCAL'
6022       include 'COMMON.VAR'
6023       include 'COMMON.INTERACT'
6024       include 'COMMON.DERIV'
6025       include 'COMMON.CHAIN'
6026       include 'COMMON.IOUNITS'
6027       include 'COMMON.NAMES'
6028       include 'COMMON.FFIELD'
6029       include 'COMMON.CONTROL'
6030       double precision x(3),dersc(3),xemp(3),dersc0(3),dersc1(3),
6031      &     ddersc0(3),ddummy(3),xtemp(3),temp(3)
6032       common /sccalc/ time11,time12,time112,theti,it,nlobit
6033       delta=0.02d0*pi
6034       escloc=0.0D0
6035 c     write (iout,'(a)') 'ESC'
6036       do i=loc_start,loc_end
6037         it=itype(i)
6038         if (it.eq.ntyp1) cycle
6039         if (it.eq.10) goto 1
6040         nlobit=nlob(iabs(it))
6041 c       print *,'i=',i,' it=',it,' nlobit=',nlobit
6042 c       write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
6043         theti=theta(i+1)-pipol
6044         x(1)=dtan(theti)
6045         x(2)=alph(i)
6046         x(3)=omeg(i)
6047
6048         if (x(2).gt.pi-delta) then
6049           xtemp(1)=x(1)
6050           xtemp(2)=pi-delta
6051           xtemp(3)=x(3)
6052           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
6053           xtemp(2)=pi
6054           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
6055           call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),
6056      &        escloci,dersc(2))
6057           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
6058      &        ddersc0(1),dersc(1))
6059           call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),
6060      &        ddersc0(3),dersc(3))
6061           xtemp(2)=pi-delta
6062           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
6063           xtemp(2)=pi
6064           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
6065           call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,
6066      &            dersc0(2),esclocbi,dersc02)
6067           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
6068      &            dersc12,dersc01)
6069           call splinthet(x(2),0.5d0*delta,ss,ssd)
6070           dersc0(1)=dersc01
6071           dersc0(2)=dersc02
6072           dersc0(3)=0.0d0
6073           do k=1,3
6074             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
6075           enddo
6076           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
6077 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
6078 c    &             esclocbi,ss,ssd
6079           escloci=ss*escloci+(1.0d0-ss)*esclocbi
6080 c         escloci=esclocbi
6081 c         write (iout,*) escloci
6082         else if (x(2).lt.delta) then
6083           xtemp(1)=x(1)
6084           xtemp(2)=delta
6085           xtemp(3)=x(3)
6086           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
6087           xtemp(2)=0.0d0
6088           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
6089           call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),
6090      &        escloci,dersc(2))
6091           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
6092      &        ddersc0(1),dersc(1))
6093           call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),
6094      &        ddersc0(3),dersc(3))
6095           xtemp(2)=delta
6096           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
6097           xtemp(2)=0.0d0
6098           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
6099           call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,
6100      &            dersc0(2),esclocbi,dersc02)
6101           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
6102      &            dersc12,dersc01)
6103           dersc0(1)=dersc01
6104           dersc0(2)=dersc02
6105           dersc0(3)=0.0d0
6106           call splinthet(x(2),0.5d0*delta,ss,ssd)
6107           do k=1,3
6108             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
6109           enddo
6110           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
6111 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
6112 c    &             esclocbi,ss,ssd
6113           escloci=ss*escloci+(1.0d0-ss)*esclocbi
6114 c         write (iout,*) escloci
6115         else
6116           call enesc(x,escloci,dersc,ddummy,.false.)
6117         endif
6118
6119         escloc=escloc+escloci
6120         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
6121      &     'escloc',i,escloci
6122 c       write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
6123
6124         gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
6125      &   wscloc*dersc(1)
6126         gloc(ialph(i,1),icg)=wscloc*dersc(2)
6127         gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
6128     1   continue
6129       enddo
6130       return
6131       end
6132 C---------------------------------------------------------------------------
6133       subroutine enesc(x,escloci,dersc,ddersc,mixed)
6134       implicit real*8 (a-h,o-z)
6135       include 'DIMENSIONS'
6136       include 'COMMON.GEO'
6137       include 'COMMON.LOCAL'
6138       include 'COMMON.IOUNITS'
6139       common /sccalc/ time11,time12,time112,theti,it,nlobit
6140       double precision x(3),z(3),Ax(3,maxlob,-1:1),dersc(3),ddersc(3)
6141       double precision contr(maxlob,-1:1)
6142       logical mixed
6143 c       write (iout,*) 'it=',it,' nlobit=',nlobit
6144         escloc_i=0.0D0
6145         do j=1,3
6146           dersc(j)=0.0D0
6147           if (mixed) ddersc(j)=0.0d0
6148         enddo
6149         x3=x(3)
6150
6151 C Because of periodicity of the dependence of the SC energy in omega we have
6152 C to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
6153 C To avoid underflows, first compute & store the exponents.
6154
6155         do iii=-1,1
6156
6157           x(3)=x3+iii*dwapi
6158
6159           do j=1,nlobit
6160             do k=1,3
6161               z(k)=x(k)-censc(k,j,it)
6162             enddo
6163             do k=1,3
6164               Axk=0.0D0
6165               do l=1,3
6166                 Axk=Axk+gaussc(l,k,j,it)*z(l)
6167               enddo
6168               Ax(k,j,iii)=Axk
6169             enddo
6170             expfac=0.0D0
6171             do k=1,3
6172               expfac=expfac+Ax(k,j,iii)*z(k)
6173             enddo
6174             contr(j,iii)=expfac
6175           enddo ! j
6176
6177         enddo ! iii
6178
6179         x(3)=x3
6180 C As in the case of ebend, we want to avoid underflows in exponentiation and
6181 C subsequent NaNs and INFs in energy calculation.
6182 C Find the largest exponent
6183         emin=contr(1,-1)
6184         do iii=-1,1
6185           do j=1,nlobit
6186             if (emin.gt.contr(j,iii)) emin=contr(j,iii)
6187           enddo
6188         enddo
6189         emin=0.5D0*emin
6190 cd      print *,'it=',it,' emin=',emin
6191
6192 C Compute the contribution to SC energy and derivatives
6193         do iii=-1,1
6194
6195           do j=1,nlobit
6196 #ifdef OSF
6197             adexp=bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin
6198             if(adexp.ne.adexp) adexp=1.0
6199             expfac=dexp(adexp)
6200 #else
6201             expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin)
6202 #endif
6203 cd          print *,'j=',j,' expfac=',expfac
6204             escloc_i=escloc_i+expfac
6205             do k=1,3
6206               dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
6207             enddo
6208             if (mixed) then
6209               do k=1,3,2
6210                 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii)
6211      &            +gaussc(k,2,j,it))*expfac
6212               enddo
6213             endif
6214           enddo
6215
6216         enddo ! iii
6217
6218         dersc(1)=dersc(1)/cos(theti)**2
6219         ddersc(1)=ddersc(1)/cos(theti)**2
6220         ddersc(3)=ddersc(3)
6221
6222         escloci=-(dlog(escloc_i)-emin)
6223         do j=1,3
6224           dersc(j)=dersc(j)/escloc_i
6225         enddo
6226         if (mixed) then
6227           do j=1,3,2
6228             ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
6229           enddo
6230         endif
6231       return
6232       end
6233 C------------------------------------------------------------------------------
6234       subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
6235       implicit real*8 (a-h,o-z)
6236       include 'DIMENSIONS'
6237       include 'COMMON.GEO'
6238       include 'COMMON.LOCAL'
6239       include 'COMMON.IOUNITS'
6240       common /sccalc/ time11,time12,time112,theti,it,nlobit
6241       double precision x(3),z(3),Ax(3,maxlob),dersc(3)
6242       double precision contr(maxlob)
6243       logical mixed
6244
6245       escloc_i=0.0D0
6246
6247       do j=1,3
6248         dersc(j)=0.0D0
6249       enddo
6250
6251       do j=1,nlobit
6252         do k=1,2
6253           z(k)=x(k)-censc(k,j,it)
6254         enddo
6255         z(3)=dwapi
6256         do k=1,3
6257           Axk=0.0D0
6258           do l=1,3
6259             Axk=Axk+gaussc(l,k,j,it)*z(l)
6260           enddo
6261           Ax(k,j)=Axk
6262         enddo
6263         expfac=0.0D0
6264         do k=1,3
6265           expfac=expfac+Ax(k,j)*z(k)
6266         enddo
6267         contr(j)=expfac
6268       enddo ! j
6269
6270 C As in the case of ebend, we want to avoid underflows in exponentiation and
6271 C subsequent NaNs and INFs in energy calculation.
6272 C Find the largest exponent
6273       emin=contr(1)
6274       do j=1,nlobit
6275         if (emin.gt.contr(j)) emin=contr(j)
6276       enddo
6277       emin=0.5D0*emin
6278
6279 C Compute the contribution to SC energy and derivatives
6280
6281       dersc12=0.0d0
6282       do j=1,nlobit
6283         expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j)+emin)
6284         escloc_i=escloc_i+expfac
6285         do k=1,2
6286           dersc(k)=dersc(k)+Ax(k,j)*expfac
6287         enddo
6288         if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j)
6289      &            +gaussc(1,2,j,it))*expfac
6290         dersc(3)=0.0d0
6291       enddo
6292
6293       dersc(1)=dersc(1)/cos(theti)**2
6294       dersc12=dersc12/cos(theti)**2
6295       escloci=-(dlog(escloc_i)-emin)
6296       do j=1,2
6297         dersc(j)=dersc(j)/escloc_i
6298       enddo
6299       if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
6300       return
6301       end
6302 #else
6303 c----------------------------------------------------------------------------------
6304       subroutine esc(escloc)
6305 C Calculate the local energy of a side chain and its derivatives in the
6306 C corresponding virtual-bond valence angles THETA and the spherical angles
6307 C ALPHA and OMEGA derived from AM1 all-atom calculations.
6308 C added by Urszula Kozlowska. 07/11/2007
6309 C
6310       implicit real*8 (a-h,o-z)
6311       include 'DIMENSIONS'
6312       include 'COMMON.GEO'
6313       include 'COMMON.LOCAL'
6314       include 'COMMON.VAR'
6315       include 'COMMON.SCROT'
6316       include 'COMMON.INTERACT'
6317       include 'COMMON.DERIV'
6318       include 'COMMON.CHAIN'
6319       include 'COMMON.IOUNITS'
6320       include 'COMMON.NAMES'
6321       include 'COMMON.FFIELD'
6322       include 'COMMON.CONTROL'
6323       include 'COMMON.VECTORS'
6324       double precision x_prime(3),y_prime(3),z_prime(3)
6325      &    , sumene,dsc_i,dp2_i,x(65),
6326      &     xx,yy,zz,sumene1,sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6,
6327      &    de_dxx,de_dyy,de_dzz,de_dt
6328       double precision s1_t,s1_6_t,s2_t,s2_6_t
6329       double precision
6330      & dXX_Ci1(3),dYY_Ci1(3),dZZ_Ci1(3),dXX_Ci(3),
6331      & dYY_Ci(3),dZZ_Ci(3),dXX_XYZ(3),dYY_XYZ(3),dZZ_XYZ(3),
6332      & dt_dCi(3),dt_dCi1(3)
6333       common /sccalc/ time11,time12,time112,theti,it,nlobit
6334       delta=0.02d0*pi
6335       escloc=0.0D0
6336       do i=loc_start,loc_end
6337         if (itype(i).eq.ntyp1) cycle
6338         costtab(i+1) =dcos(theta(i+1))
6339         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
6340         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
6341         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
6342         cosfac2=0.5d0/(1.0d0+costtab(i+1))
6343         cosfac=dsqrt(cosfac2)
6344         sinfac2=0.5d0/(1.0d0-costtab(i+1))
6345         sinfac=dsqrt(sinfac2)
6346         it=iabs(itype(i))
6347         if (it.eq.10) goto 1
6348 c
6349 C  Compute the axes of tghe local cartesian coordinates system; store in
6350 c   x_prime, y_prime and z_prime
6351 c
6352         do j=1,3
6353           x_prime(j) = 0.00
6354           y_prime(j) = 0.00
6355           z_prime(j) = 0.00
6356         enddo
6357 C        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
6358 C     &   dc_norm(3,i+nres)
6359         do j = 1,3
6360           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
6361           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
6362         enddo
6363         do j = 1,3
6364           z_prime(j) = -uz(j,i-1)*dsign(1.0d0,dfloat(itype(i)))
6365         enddo
6366 c       write (2,*) "i",i
6367 c       write (2,*) "x_prime",(x_prime(j),j=1,3)
6368 c       write (2,*) "y_prime",(y_prime(j),j=1,3)
6369 c       write (2,*) "z_prime",(z_prime(j),j=1,3)
6370 c       write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
6371 c      & " xy",scalar(x_prime(1),y_prime(1)),
6372 c      & " xz",scalar(x_prime(1),z_prime(1)),
6373 c      & " yy",scalar(y_prime(1),y_prime(1)),
6374 c      & " yz",scalar(y_prime(1),z_prime(1)),
6375 c      & " zz",scalar(z_prime(1),z_prime(1))
6376 c
6377 C Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
6378 C to local coordinate system. Store in xx, yy, zz.
6379 c
6380         xx=0.0d0
6381         yy=0.0d0
6382         zz=0.0d0
6383         do j = 1,3
6384           xx = xx + x_prime(j)*dc_norm(j,i+nres)
6385           yy = yy + y_prime(j)*dc_norm(j,i+nres)
6386           zz = zz + z_prime(j)*dc_norm(j,i+nres)
6387         enddo
6388
6389         xxtab(i)=xx
6390         yytab(i)=yy
6391         zztab(i)=zz
6392 C
6393 C Compute the energy of the ith side cbain
6394 C
6395 c        write (2,*) "xx",xx," yy",yy," zz",zz
6396         it=iabs(itype(i))
6397         do j = 1,65
6398           x(j) = sc_parmin(j,it)
6399         enddo
6400 #ifdef CHECK_COORD
6401 Cc diagnostics - remove later
6402         xx1 = dcos(alph(2))
6403         yy1 = dsin(alph(2))*dcos(omeg(2))
6404         zz1 = -dsign(1.0,dfloat(itype(i)))*dsin(alph(2))*dsin(omeg(2))
6405         write(2,'(3f8.1,3f9.3,1x,3f9.3)')
6406      &    alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,
6407      &    xx1,yy1,zz1
6408 C,"  --- ", xx_w,yy_w,zz_w
6409 c end diagnostics
6410 #endif
6411         sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
6412      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
6413      &   + x(10)*yy*zz
6414         sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
6415      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
6416      & + x(20)*yy*zz
6417         sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
6418      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
6419      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
6420      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
6421      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
6422      &  +x(40)*xx*yy*zz
6423         sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
6424      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
6425      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
6426      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
6427      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
6428      &  +x(60)*xx*yy*zz
6429         dsc_i   = 0.743d0+x(61)
6430         dp2_i   = 1.9d0+x(62)
6431         dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
6432      &          *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
6433         dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
6434      &          *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
6435         s1=(1+x(63))/(0.1d0 + dscp1)
6436         s1_6=(1+x(64))/(0.1d0 + dscp1**6)
6437         s2=(1+x(65))/(0.1d0 + dscp2)
6438         s2_6=(1+x(65))/(0.1d0 + dscp2**6)
6439         sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6)
6440      & + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
6441 c        write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
6442 c     &   sumene4,
6443 c     &   dscp1,dscp2,sumene
6444 c        sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6445         escloc = escloc + sumene
6446         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
6447      &     'escloc',i,sumene
6448 c        write (2,*) "i",i," escloc",sumene,escloc,it,itype(i)
6449 c     & ,zz,xx,yy
6450 c#define DEBUG
6451 #ifdef DEBUG
6452 C
6453 C This section to check the numerical derivatives of the energy of ith side
6454 C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
6455 C #define DEBUG in the code to turn it on.
6456 C
6457         write (2,*) "sumene               =",sumene
6458         aincr=1.0d-7
6459         xxsave=xx
6460         xx=xx+aincr
6461         write (2,*) xx,yy,zz
6462         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6463         de_dxx_num=(sumenep-sumene)/aincr
6464         xx=xxsave
6465         write (2,*) "xx+ sumene from enesc=",sumenep
6466         yysave=yy
6467         yy=yy+aincr
6468         write (2,*) xx,yy,zz
6469         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6470         de_dyy_num=(sumenep-sumene)/aincr
6471         yy=yysave
6472         write (2,*) "yy+ sumene from enesc=",sumenep
6473         zzsave=zz
6474         zz=zz+aincr
6475         write (2,*) xx,yy,zz
6476         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6477         de_dzz_num=(sumenep-sumene)/aincr
6478         zz=zzsave
6479         write (2,*) "zz+ sumene from enesc=",sumenep
6480         costsave=cost2tab(i+1)
6481         sintsave=sint2tab(i+1)
6482         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
6483         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
6484         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6485         de_dt_num=(sumenep-sumene)/aincr
6486         write (2,*) " t+ sumene from enesc=",sumenep
6487         cost2tab(i+1)=costsave
6488         sint2tab(i+1)=sintsave
6489 C End of diagnostics section.
6490 #endif
6491 C
6492 C Compute the gradient of esc
6493 C
6494 c        zz=zz*dsign(1.0,dfloat(itype(i)))
6495         pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
6496         pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
6497         pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
6498         pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
6499         pom_dx=dsc_i*dp2_i*cost2tab(i+1)
6500         pom_dy=dsc_i*dp2_i*sint2tab(i+1)
6501         pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
6502         pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
6503         pom1=(sumene3*sint2tab(i+1)+sumene1)
6504      &     *(pom_s1/dscp1+pom_s16*dscp1**4)
6505         pom2=(sumene4*cost2tab(i+1)+sumene2)
6506      &     *(pom_s2/dscp2+pom_s26*dscp2**4)
6507         sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
6508         sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2
6509      &  +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2)
6510      &  +x(40)*yy*zz
6511         sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
6512         sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2
6513      &  +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2)
6514      &  +x(60)*yy*zz
6515         de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6)
6516      &        +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6)
6517      &        +(pom1+pom2)*pom_dx
6518 #ifdef DEBUG
6519         write(2,*), "de_dxx = ", de_dxx,de_dxx_num,itype(i)
6520 #endif
6521 C
6522         sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
6523         sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2
6524      &  +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2)
6525      &  +x(40)*xx*zz
6526         sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
6527         sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz
6528      &  +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz
6529      &  +x(59)*zz**2 +x(60)*xx*zz
6530         de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6)
6531      &        +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6)
6532      &        +(pom1-pom2)*pom_dy
6533 #ifdef DEBUG
6534         write(2,*), "de_dyy = ", de_dyy,de_dyy_num,itype(i)
6535 #endif
6536 C
6537         de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy
6538      &  +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx
6539      &  +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6)
6540      &  +(x(4) + 2*x(7)*zz+  x(8)*xx + x(10)*yy)*(s1+s1_6)
6541      &  +(x(44)+2*x(47)*zz +x(48)*xx   +x(50)*yy  +3*x(53)*zz**2
6542      &  +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy
6543      &  +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6)
6544      &  + ( x(14) + 2*x(17)*zz+  x(18)*xx + x(20)*yy)*(s2+s2_6)
6545 #ifdef DEBUG
6546         write(2,*), "de_dzz = ", de_dzz,de_dzz_num,itype(i)
6547 #endif
6548 C
6549         de_dt =  0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6)
6550      &  -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6)
6551      &  +pom1*pom_dt1+pom2*pom_dt2
6552 #ifdef DEBUG
6553         write(2,*), "de_dt = ", de_dt,de_dt_num,itype(i)
6554 #endif
6555 c#undef DEBUG
6556 c
6557 C
6558        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
6559        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
6560        cosfac2xx=cosfac2*xx
6561        sinfac2yy=sinfac2*yy
6562        do k = 1,3
6563          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))*
6564      &      vbld_inv(i+1)
6565          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))*
6566      &      vbld_inv(i)
6567          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
6568          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
6569 c         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
6570 c     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
6571 c         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
6572 c     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
6573          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
6574          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
6575          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
6576          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
6577          dZZ_Ci1(k)=0.0d0
6578          dZZ_Ci(k)=0.0d0
6579          do j=1,3
6580            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)
6581      &     *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
6582            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)
6583      &     *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
6584          enddo
6585
6586          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
6587          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
6588          dZZ_XYZ(k)=vbld_inv(i+nres)*
6589      &   (z_prime(k)-zz*dC_norm(k,i+nres))
6590 c
6591          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
6592          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
6593        enddo
6594
6595        do k=1,3
6596          dXX_Ctab(k,i)=dXX_Ci(k)
6597          dXX_C1tab(k,i)=dXX_Ci1(k)
6598          dYY_Ctab(k,i)=dYY_Ci(k)
6599          dYY_C1tab(k,i)=dYY_Ci1(k)
6600          dZZ_Ctab(k,i)=dZZ_Ci(k)
6601          dZZ_C1tab(k,i)=dZZ_Ci1(k)
6602          dXX_XYZtab(k,i)=dXX_XYZ(k)
6603          dYY_XYZtab(k,i)=dYY_XYZ(k)
6604          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
6605        enddo
6606
6607        do k = 1,3
6608 c         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
6609 c     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
6610 c         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
6611 c     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
6612 c         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
6613 c     &    dt_dci(k)
6614 c         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
6615 c     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
6616          gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k)
6617      &    +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
6618          gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k)
6619      &    +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
6620          gsclocx(k,i)=                 de_dxx*dxx_XYZ(k)
6621      &    +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
6622        enddo
6623 c       write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
6624 c     &  (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
6625
6626 C to check gradient call subroutine check_grad
6627
6628     1 continue
6629       enddo
6630       return
6631       end
6632 c------------------------------------------------------------------------------
6633       double precision function enesc(x,xx,yy,zz,cost2,sint2)
6634       implicit none
6635       double precision x(65),xx,yy,zz,cost2,sint2,sumene1,sumene2,
6636      & sumene3,sumene4,sumene,dsc_i,dp2_i,dscp1,dscp2,s1,s1_6,s2,s2_6
6637       sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
6638      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
6639      &   + x(10)*yy*zz
6640       sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
6641      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
6642      & + x(20)*yy*zz
6643       sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
6644      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
6645      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
6646      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
6647      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
6648      &  +x(40)*xx*yy*zz
6649       sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
6650      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
6651      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
6652      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
6653      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
6654      &  +x(60)*xx*yy*zz
6655       dsc_i   = 0.743d0+x(61)
6656       dp2_i   = 1.9d0+x(62)
6657       dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
6658      &          *(xx*cost2+yy*sint2))
6659       dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
6660      &          *(xx*cost2-yy*sint2))
6661       s1=(1+x(63))/(0.1d0 + dscp1)
6662       s1_6=(1+x(64))/(0.1d0 + dscp1**6)
6663       s2=(1+x(65))/(0.1d0 + dscp2)
6664       s2_6=(1+x(65))/(0.1d0 + dscp2**6)
6665       sumene = ( sumene3*sint2 + sumene1)*(s1+s1_6)
6666      & + (sumene4*cost2 +sumene2)*(s2+s2_6)
6667       enesc=sumene
6668       return
6669       end
6670 #endif
6671 c------------------------------------------------------------------------------
6672       subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
6673 C
6674 C This procedure calculates two-body contact function g(rij) and its derivative:
6675 C
6676 C           eps0ij                                     !       x < -1
6677 C g(rij) =  esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5)  ! -1 =< x =< 1
6678 C            0                                         !       x > 1
6679 C
6680 C where x=(rij-r0ij)/delta
6681 C
6682 C rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
6683 C
6684       implicit none
6685       double precision rij,r0ij,eps0ij,fcont,fprimcont
6686       double precision x,x2,x4,delta
6687 c     delta=0.02D0*r0ij
6688 c      delta=0.2D0*r0ij
6689       x=(rij-r0ij)/delta
6690       if (x.lt.-1.0D0) then
6691         fcont=eps0ij
6692         fprimcont=0.0D0
6693       else if (x.le.1.0D0) then
6694         x2=x*x
6695         x4=x2*x2
6696         fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
6697         fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
6698       else
6699         fcont=0.0D0
6700         fprimcont=0.0D0
6701       endif
6702       return
6703       end
6704 c------------------------------------------------------------------------------
6705       subroutine splinthet(theti,delta,ss,ssder)
6706       implicit real*8 (a-h,o-z)
6707       include 'DIMENSIONS'
6708       include 'COMMON.VAR'
6709       include 'COMMON.GEO'
6710       thetup=pi-delta
6711       thetlow=delta
6712       if (theti.gt.pipol) then
6713         call gcont(theti,thetup,1.0d0,delta,ss,ssder)
6714       else
6715         call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
6716         ssder=-ssder
6717       endif
6718       return
6719       end
6720 c------------------------------------------------------------------------------
6721       subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
6722       implicit none
6723       double precision x,x0,delta,f0,f1,fprim0,f,fprim
6724       double precision ksi,ksi2,ksi3,a1,a2,a3
6725       a1=fprim0*delta/(f1-f0)
6726       a2=3.0d0-2.0d0*a1
6727       a3=a1-2.0d0
6728       ksi=(x-x0)/delta
6729       ksi2=ksi*ksi
6730       ksi3=ksi2*ksi
6731       f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
6732       fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
6733       return
6734       end
6735 c------------------------------------------------------------------------------
6736       subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
6737       implicit none
6738       double precision x,x0,delta,f0x,f1x,fprim0x,fx
6739       double precision ksi,ksi2,ksi3,a1,a2,a3
6740       ksi=(x-x0)/delta
6741       ksi2=ksi*ksi
6742       ksi3=ksi2*ksi
6743       a1=fprim0x*delta
6744       a2=3*(f1x-f0x)-2*fprim0x*delta
6745       a3=fprim0x*delta-2*(f1x-f0x)
6746       fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
6747       return
6748       end
6749 C-----------------------------------------------------------------------------
6750 #ifdef CRYST_TOR
6751 C-----------------------------------------------------------------------------
6752       subroutine etor(etors,edihcnstr)
6753       implicit real*8 (a-h,o-z)
6754       include 'DIMENSIONS'
6755       include 'COMMON.VAR'
6756       include 'COMMON.GEO'
6757       include 'COMMON.LOCAL'
6758       include 'COMMON.TORSION'
6759       include 'COMMON.INTERACT'
6760       include 'COMMON.DERIV'
6761       include 'COMMON.CHAIN'
6762       include 'COMMON.NAMES'
6763       include 'COMMON.IOUNITS'
6764       include 'COMMON.FFIELD'
6765       include 'COMMON.TORCNSTR'
6766       include 'COMMON.CONTROL'
6767       logical lprn
6768 C Set lprn=.true. for debugging
6769       lprn=.false.
6770 c      lprn=.true.
6771       etors=0.0D0
6772       do i=iphi_start,iphi_end
6773       etors_ii=0.0D0
6774         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
6775      &      .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
6776         itori=itortyp(itype(i-2))
6777         itori1=itortyp(itype(i-1))
6778         phii=phi(i)
6779         gloci=0.0D0
6780 C Proline-Proline pair is a special case...
6781         if (itori.eq.3 .and. itori1.eq.3) then
6782           if (phii.gt.-dwapi3) then
6783             cosphi=dcos(3*phii)
6784             fac=1.0D0/(1.0D0-cosphi)
6785             etorsi=v1(1,3,3)*fac
6786             etorsi=etorsi+etorsi
6787             etors=etors+etorsi-v1(1,3,3)
6788             if (energy_dec) etors_ii=etors_ii+etorsi-v1(1,3,3)
6789             gloci=gloci-3*fac*etorsi*dsin(3*phii)
6790           endif
6791           do j=1,3
6792             v1ij=v1(j+1,itori,itori1)
6793             v2ij=v2(j+1,itori,itori1)
6794             cosphi=dcos(j*phii)
6795             sinphi=dsin(j*phii)
6796             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
6797             if (energy_dec) etors_ii=etors_ii+
6798      &                              v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
6799             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
6800           enddo
6801         else
6802           do j=1,nterm_old
6803             v1ij=v1(j,itori,itori1)
6804             v2ij=v2(j,itori,itori1)
6805             cosphi=dcos(j*phii)
6806             sinphi=dsin(j*phii)
6807             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
6808             if (energy_dec) etors_ii=etors_ii+
6809      &                  v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
6810             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
6811           enddo
6812         endif
6813         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
6814              'etor',i,etors_ii
6815         if (lprn)
6816      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
6817      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
6818      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
6819         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
6820 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
6821       enddo
6822 ! 6/20/98 - dihedral angle constraints
6823       edihcnstr=0.0d0
6824       do i=1,ndih_constr
6825         itori=idih_constr(i)
6826         phii=phi(itori)
6827         difi=phii-phi0(i)
6828         if (difi.gt.drange(i)) then
6829           difi=difi-drange(i)
6830           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
6831           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
6832         else if (difi.lt.-drange(i)) then
6833           difi=difi+drange(i)
6834           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
6835           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
6836         endif
6837 !        write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii,
6838 !     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
6839       enddo
6840 !      write (iout,*) 'edihcnstr',edihcnstr
6841       return
6842       end
6843 c------------------------------------------------------------------------------
6844 c LICZENIE WIEZOW Z ROWNANIA ENERGII MODELLERA
6845       subroutine e_modeller(ehomology_constr)
6846       ehomology_constr=0.0d0
6847       write (iout,*) "!!!!!UWAGA, JESTEM W DZIWNEJ PETLI, TEST!!!!!"
6848       return
6849       end
6850 C !!!!!!!! NIE CZYTANE !!!!!!!!!!!
6851
6852 c------------------------------------------------------------------------------
6853       subroutine etor_d(etors_d)
6854       etors_d=0.0d0
6855       return
6856       end
6857 c----------------------------------------------------------------------------
6858 #else
6859       subroutine etor(etors,edihcnstr)
6860       implicit real*8 (a-h,o-z)
6861       include 'DIMENSIONS'
6862       include 'COMMON.VAR'
6863       include 'COMMON.GEO'
6864       include 'COMMON.LOCAL'
6865       include 'COMMON.TORSION'
6866       include 'COMMON.INTERACT'
6867       include 'COMMON.DERIV'
6868       include 'COMMON.CHAIN'
6869       include 'COMMON.NAMES'
6870       include 'COMMON.IOUNITS'
6871       include 'COMMON.FFIELD'
6872       include 'COMMON.TORCNSTR'
6873       include 'COMMON.CONTROL'
6874       logical lprn
6875 C Set lprn=.true. for debugging
6876       lprn=.false.
6877 c     lprn=.true.
6878       etors=0.0D0
6879       do i=iphi_start,iphi_end
6880 C ANY TWO ARE DUMMY ATOMS in row CYCLE
6881 c        if (((itype(i-3).eq.ntyp1).and.(itype(i-2).eq.ntyp1)).or.
6882 c     &      ((itype(i-2).eq.ntyp1).and.(itype(i-1).eq.ntyp1))  .or.
6883 c     &      ((itype(i-1).eq.ntyp1).and.(itype(i).eq.ntyp1))) cycle
6884         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
6885      &      .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
6886 C In current verion the ALL DUMMY ATOM POTENTIALS ARE OFF
6887 C For introducing the NH3+ and COO- group please check the etor_d for reference
6888 C and guidance
6889         etors_ii=0.0D0
6890          if (iabs(itype(i)).eq.20) then
6891          iblock=2
6892          else
6893          iblock=1
6894          endif
6895         itori=itortyp(itype(i-2))
6896         itori1=itortyp(itype(i-1))
6897         phii=phi(i)
6898         gloci=0.0D0
6899 C Regular cosine and sine terms
6900         do j=1,nterm(itori,itori1,iblock)
6901           v1ij=v1(j,itori,itori1,iblock)
6902           v2ij=v2(j,itori,itori1,iblock)
6903           cosphi=dcos(j*phii)
6904           sinphi=dsin(j*phii)
6905           etors=etors+v1ij*cosphi+v2ij*sinphi
6906           if (energy_dec) etors_ii=etors_ii+
6907      &                v1ij*cosphi+v2ij*sinphi
6908           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
6909         enddo
6910 C Lorentz terms
6911 C                         v1
6912 C  E = SUM ----------------------------------- - v1
6913 C          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
6914 C
6915         cosphi=dcos(0.5d0*phii)
6916         sinphi=dsin(0.5d0*phii)
6917         do j=1,nlor(itori,itori1,iblock)
6918           vl1ij=vlor1(j,itori,itori1)
6919           vl2ij=vlor2(j,itori,itori1)
6920           vl3ij=vlor3(j,itori,itori1)
6921           pom=vl2ij*cosphi+vl3ij*sinphi
6922           pom1=1.0d0/(pom*pom+1.0d0)
6923           etors=etors+vl1ij*pom1
6924           if (energy_dec) etors_ii=etors_ii+
6925      &                vl1ij*pom1
6926           pom=-pom*pom1*pom1
6927           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
6928         enddo
6929 C Subtract the constant term
6930         etors=etors-v0(itori,itori1,iblock)
6931           if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
6932      &         'etor',i,etors_ii-v0(itori,itori1,iblock)
6933         if (lprn)
6934      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
6935      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
6936      &  (v1(j,itori,itori1,iblock),j=1,6),
6937      &  (v2(j,itori,itori1,iblock),j=1,6)
6938         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
6939 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
6940       enddo
6941 ! 6/20/98 - dihedral angle constraints
6942       edihcnstr=0.0d0
6943 c      do i=1,ndih_constr
6944       do i=idihconstr_start,idihconstr_end
6945         itori=idih_constr(i)
6946         phii=phi(itori)
6947         difi=pinorm(phii-phi0(i))
6948         if (difi.gt.drange(i)) then
6949           difi=difi-drange(i)
6950           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
6951           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
6952         else if (difi.lt.-drange(i)) then
6953           difi=difi+drange(i)
6954           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
6955           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
6956         else
6957           difi=0.0
6958         endif
6959 cd        write (iout,'(2i5,4f8.3,2e14.5)') i,itori,rad2deg*phii,
6960 cd     &    rad2deg*phi0(i),  rad2deg*drange(i),
6961 cd     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
6962       enddo
6963 cd       write (iout,*) 'edihcnstr',edihcnstr
6964       return
6965       end
6966 c----------------------------------------------------------------------------
6967 c MODELLER restraint function
6968       subroutine e_modeller(ehomology_constr)
6969       implicit real*8 (a-h,o-z)
6970       include 'DIMENSIONS'
6971
6972       integer nnn, i, j, k, ki, irec, l
6973       integer katy, odleglosci, test7
6974       real*8 odleg, odleg2, odleg3, kat, kat2, kat3, gdih(max_template)
6975       real*8 Eval,Erot
6976       real*8 distance(max_template),distancek(max_template),
6977      &    min_odl,godl(max_template),dih_diff(max_template)
6978
6979 c
6980 c     FP - 30/10/2014 Temporary specifications for homology restraints
6981 c
6982       double precision utheta_i,gutheta_i,sum_gtheta,sum_sgtheta,
6983      &                 sgtheta
6984       double precision, dimension (maxres) :: guscdiff,usc_diff
6985       double precision, dimension (max_template) ::
6986      &           gtheta,dscdiff,uscdiffk,guscdiff2,guscdiff3,
6987      &           theta_diff
6988 c
6989
6990       include 'COMMON.SBRIDGE'
6991       include 'COMMON.CHAIN'
6992       include 'COMMON.GEO'
6993       include 'COMMON.DERIV'
6994       include 'COMMON.LOCAL'
6995       include 'COMMON.INTERACT'
6996       include 'COMMON.VAR'
6997       include 'COMMON.IOUNITS'
6998       include 'COMMON.MD'
6999       include 'COMMON.CONTROL'
7000 c
7001 c     From subroutine Econstr_back
7002 c
7003       include 'COMMON.NAMES'
7004       include 'COMMON.TIME1'
7005 c
7006
7007
7008       do i=1,max_template
7009         distancek(i)=9999999.9
7010       enddo
7011
7012
7013       odleg=0.0d0
7014
7015 c Pseudo-energy and gradient from homology restraints (MODELLER-like
7016 c function)
7017 C AL 5/2/14 - Introduce list of restraints
7018 c     write(iout,*) "waga_theta",waga_theta,"waga_d",waga_d
7019 #ifdef DEBUG
7020       write(iout,*) "------- dist restrs start -------"
7021 #endif
7022       do ii = link_start_homo,link_end_homo
7023          i = ires_homo(ii)
7024          j = jres_homo(ii)
7025          dij=dist(i,j)
7026 c        write (iout,*) "dij(",i,j,") =",dij
7027          nexl=0
7028          do k=1,constr_homology
7029 c           write(iout,*) ii,k,i,j,l_homo(k,ii),dij,odl(k,ii)
7030            if(.not.l_homo(k,ii)) then
7031              nexl=nexl+1
7032              cycle
7033            endif
7034            distance(k)=odl(k,ii)-dij
7035 c          write (iout,*) "distance(",k,") =",distance(k)
7036 c
7037 c          For Gaussian-type Urestr
7038 c
7039            distancek(k)=0.5d0*distance(k)**2*sigma_odl(k,ii) ! waga_dist rmvd from Gaussian argument
7040 c          write (iout,*) "sigma_odl(",k,ii,") =",sigma_odl(k,ii)
7041 c          write (iout,*) "distancek(",k,") =",distancek(k)
7042 c          distancek(k)=0.5d0*waga_dist*distance(k)**2*sigma_odl(k,ii)
7043 c
7044 c          For Lorentzian-type Urestr
7045 c
7046            if (waga_dist.lt.0.0d0) then
7047               sigma_odlir(k,ii)=dsqrt(1/sigma_odl(k,ii))
7048               distancek(k)=distance(k)**2/(sigma_odlir(k,ii)*
7049      &                     (distance(k)**2+sigma_odlir(k,ii)**2))
7050            endif
7051          enddo
7052
7053 c         min_odl=minval(distancek)
7054          do kk=1,constr_homology
7055           if(l_homo(kk,ii)) then
7056             min_odl=distancek(kk)
7057             exit
7058           endif
7059          enddo
7060          do kk=1,constr_homology
7061           if(l_homo(kk,ii) .and. distancek(kk).lt.min_odl)
7062      &              min_odl=distancek(kk)
7063          enddo
7064
7065 c        write (iout,* )"min_odl",min_odl
7066 #ifdef DEBUG
7067          write (iout,*) "ij dij",i,j,dij
7068          write (iout,*) "distance",(distance(k),k=1,constr_homology)
7069          write (iout,*) "distancek",(distancek(k),k=1,constr_homology)
7070          write (iout,* )"min_odl",min_odl
7071 #endif
7072 #ifdef OLDRESTR
7073          odleg2=0.0d0
7074 #else
7075          if (waga_dist.ge.0.0d0) then
7076            odleg2=nexl
7077          else
7078            odleg2=0.0d0
7079          endif
7080 #endif
7081          do k=1,constr_homology
7082 c Nie wiem po co to liczycie jeszcze raz!
7083 c            odleg3=-waga_dist(iset)*((distance(i,j,k)**2)/
7084 c     &              (2*(sigma_odl(i,j,k))**2))
7085            if(.not.l_homo(k,ii)) cycle
7086            if (waga_dist.ge.0.0d0) then
7087 c
7088 c          For Gaussian-type Urestr
7089 c
7090             godl(k)=dexp(-distancek(k)+min_odl)
7091             odleg2=odleg2+godl(k)
7092 c
7093 c          For Lorentzian-type Urestr
7094 c
7095            else
7096             odleg2=odleg2+distancek(k)
7097            endif
7098
7099 ccc       write(iout,779) i,j,k, "odleg2=",odleg2, "odleg3=", odleg3,
7100 ccc     & "dEXP(odleg3)=", dEXP(odleg3),"distance(i,j,k)^2=",
7101 ccc     & distance(i,j,k)**2, "dist(i+1,j+1)=", dist(i+1,j+1),
7102 ccc     & "sigma_odl(i,j,k)=", sigma_odl(i,j,k)
7103
7104          enddo
7105 c        write (iout,*) "godl",(godl(k),k=1,constr_homology) ! exponents
7106 c        write (iout,*) "ii i j",ii,i,j," odleg2",odleg2 ! sum of exps
7107 #ifdef DEBUG
7108          write (iout,*) "godl",(godl(k),k=1,constr_homology) ! exponents
7109          write (iout,*) "ii i j",ii,i,j," odleg2",odleg2 ! sum of exps
7110 #endif
7111            if (waga_dist.ge.0.0d0) then
7112 c
7113 c          For Gaussian-type Urestr
7114 c
7115               odleg=odleg-dLOG(odleg2/constr_homology)+min_odl
7116 c
7117 c          For Lorentzian-type Urestr
7118 c
7119            else
7120               odleg=odleg+odleg2/constr_homology
7121            endif
7122 c
7123 c        write (iout,*) "odleg",odleg ! sum of -ln-s
7124 c Gradient
7125 c
7126 c          For Gaussian-type Urestr
7127 c
7128          if (waga_dist.ge.0.0d0) sum_godl=odleg2
7129          sum_sgodl=0.0d0
7130          do k=1,constr_homology
7131 c            godl=dexp(((-(distance(i,j,k)**2)/(2*(sigma_odl(i,j,k))**2))
7132 c     &           *waga_dist)+min_odl
7133 c          sgodl=-godl(k)*distance(k)*sigma_odl(k,ii)*waga_dist
7134 c
7135          if(.not.l_homo(k,ii)) cycle
7136          if (waga_dist.ge.0.0d0) then
7137 c          For Gaussian-type Urestr
7138 c
7139            sgodl=-godl(k)*distance(k)*sigma_odl(k,ii) ! waga_dist rmvd
7140 c
7141 c          For Lorentzian-type Urestr
7142 c
7143          else
7144            sgodl=-2*sigma_odlir(k,ii)*(distance(k)/(distance(k)**2+
7145      &           sigma_odlir(k,ii)**2)**2)
7146          endif
7147            sum_sgodl=sum_sgodl+sgodl
7148
7149 c            sgodl2=sgodl2+sgodl
7150 c      write(iout,*) i, j, k, distance(i,j,k), "W GRADIENCIE1"
7151 c      write(iout,*) "constr_homology=",constr_homology
7152 c      write(iout,*) i, j, k, "TEST K"
7153          enddo
7154          if (waga_dist.ge.0.0d0) then
7155 c
7156 c          For Gaussian-type Urestr
7157 c
7158             grad_odl3=waga_homology(iset)*waga_dist
7159      &                *sum_sgodl/(sum_godl*dij)
7160 c
7161 c          For Lorentzian-type Urestr
7162 c
7163          else
7164 c Original grad expr modified by analogy w Gaussian-type Urestr grad
7165 c           grad_odl3=-waga_homology(iset)*waga_dist*sum_sgodl
7166             grad_odl3=-waga_homology(iset)*waga_dist*
7167      &                sum_sgodl/(constr_homology*dij)
7168          endif
7169 c
7170 c        grad_odl3=sum_sgodl/(sum_godl*dij)
7171
7172
7173 c      write(iout,*) i, j, k, distance(i,j,k), "W GRADIENCIE2"
7174 c      write(iout,*) (distance(i,j,k)**2), (2*(sigma_odl(i,j,k))**2),
7175 c     &              (-(distance(i,j,k)**2)/(2*(sigma_odl(i,j,k))**2))
7176
7177 ccc      write(iout,*) godl, sgodl, grad_odl3
7178
7179 c          grad_odl=grad_odl+grad_odl3
7180
7181          do jik=1,3
7182             ggodl=grad_odl3*(c(jik,i)-c(jik,j))
7183 ccc      write(iout,*) c(jik,i+1), c(jik,j+1), (c(jik,i+1)-c(jik,j+1))
7184 ccc      write(iout,746) "GRAD_ODL_1", i, j, jik, ggodl,
7185 ccc     &              ghpbc(jik,i+1), ghpbc(jik,j+1)
7186             ghpbc(jik,i)=ghpbc(jik,i)+ggodl
7187             ghpbc(jik,j)=ghpbc(jik,j)-ggodl
7188 ccc      write(iout,746) "GRAD_ODL_2", i, j, jik, ggodl,
7189 ccc     &              ghpbc(jik,i+1), ghpbc(jik,j+1)
7190 c         if (i.eq.25.and.j.eq.27) then
7191 c         write(iout,*) "jik",jik,"i",i,"j",j
7192 c         write(iout,*) "sum_sgodl",sum_sgodl,"sgodl",sgodl
7193 c         write(iout,*) "grad_odl3",grad_odl3
7194 c         write(iout,*) "c(",jik,i,")",c(jik,i),"c(",jik,j,")",c(jik,j)
7195 c         write(iout,*) "ggodl",ggodl
7196 c         write(iout,*) "ghpbc(",jik,i,")",
7197 c     &                 ghpbc(jik,i),"ghpbc(",jik,j,")",
7198 c     &                 ghpbc(jik,j)
7199 c         endif
7200          enddo
7201 ccc       write(iout,778)"TEST: odleg2=", odleg2, "DLOG(odleg2)=",
7202 ccc     & dLOG(odleg2),"-odleg=", -odleg
7203
7204       enddo ! ii-loop for dist
7205 #ifdef DEBUG
7206       write(iout,*) "------- dist restrs end -------"
7207 c     if (waga_angle.eq.1.0d0 .or. waga_theta.eq.1.0d0 .or.
7208 c    &     waga_d.eq.1.0d0) call sum_gradient
7209 #endif
7210 c Pseudo-energy and gradient from dihedral-angle restraints from
7211 c homology templates
7212 c      write (iout,*) "End of distance loop"
7213 c      call flush(iout)
7214       kat=0.0d0
7215 c      write (iout,*) idihconstr_start_homo,idihconstr_end_homo
7216 #ifdef DEBUG
7217       write(iout,*) "------- dih restrs start -------"
7218       do i=idihconstr_start_homo,idihconstr_end_homo
7219         write (iout,*) "gloc_init(",i,icg,")",gloc(i,icg)
7220       enddo
7221 #endif
7222       do i=idihconstr_start_homo,idihconstr_end_homo
7223         kat2=0.0d0
7224 c        betai=beta(i,i+1,i+2,i+3)
7225         betai = phi(i)
7226 c       write (iout,*) "betai =",betai
7227         do k=1,constr_homology
7228           dih_diff(k)=pinorm(dih(k,i)-betai)
7229 cd          write (iout,'(a8,2i4,2f15.8)') "dih_diff",i,k,dih_diff(k)
7230 cd     &                  ,sigma_dih(k,i)
7231 c          if (dih_diff(i,k).gt.3.14159) dih_diff(i,k)=
7232 c     &                                   -(6.28318-dih_diff(i,k))
7233 c          if (dih_diff(i,k).lt.-3.14159) dih_diff(i,k)=
7234 c     &                                   6.28318+dih_diff(i,k)
7235 #ifdef OLD_DIHED
7236           kat3=-0.5d0*dih_diff(k)**2*sigma_dih(k,i) ! waga_angle rmvd from Gaussian argument
7237 #else
7238           kat3=(dcos(dih_diff(k))-1)*sigma_dih(k,i) ! waga_angle rmvd from Gaussian argument
7239 #endif
7240 c         kat3=-0.5d0*waga_angle*dih_diff(k)**2*sigma_dih(k,i)
7241           gdih(k)=dexp(kat3)
7242           kat2=kat2+gdih(k)
7243 c          write(iout,*) "kat2=", kat2, "exp(kat3)=", exp(kat3)
7244 c          write(*,*)""
7245         enddo
7246 c       write (iout,*) "gdih",(gdih(k),k=1,constr_homology) ! exps
7247 c       write (iout,*) "i",i," betai",betai," kat2",kat2 ! sum of exps
7248 #ifdef DEBUG
7249         write (iout,*) "i",i," betai",betai," kat2",kat2
7250         write (iout,*) "gdih",(gdih(k),k=1,constr_homology)
7251 #endif
7252         if (kat2.le.1.0d-14) cycle
7253         kat=kat-dLOG(kat2/constr_homology)
7254 c       write (iout,*) "kat",kat ! sum of -ln-s
7255
7256 ccc       write(iout,778)"TEST: kat2=", kat2, "DLOG(kat2)=",
7257 ccc     & dLOG(kat2), "-kat=", -kat
7258
7259 c ----------------------------------------------------------------------
7260 c Gradient
7261 c ----------------------------------------------------------------------
7262
7263         sum_gdih=kat2
7264         sum_sgdih=0.0d0
7265         do k=1,constr_homology
7266 #ifdef OLD_DIHED
7267           sgdih=-gdih(k)*dih_diff(k)*sigma_dih(k,i)  ! waga_angle rmvd
7268 #else
7269           sgdih=-gdih(k)*dsin(dih_diff(k))*sigma_dih(k,i)  ! waga_angle rmvd
7270 #endif
7271 c         sgdih=-gdih(k)*dih_diff(k)*sigma_dih(k,i)*waga_angle
7272           sum_sgdih=sum_sgdih+sgdih
7273         enddo
7274 c       grad_dih3=sum_sgdih/sum_gdih
7275         grad_dih3=waga_homology(iset)*waga_angle*sum_sgdih/sum_gdih
7276
7277 c      write(iout,*)i,k,gdih,sgdih,beta(i+1,i+2,i+3,i+4),grad_dih3
7278 ccc      write(iout,747) "GRAD_KAT_1", i, nphi, icg, grad_dih3,
7279 ccc     & gloc(nphi+i-3,icg)
7280         gloc(i-3,icg)=gloc(i-3,icg)+grad_dih3
7281 c        if (i.eq.25) then
7282 c        write(iout,*) "i",i,"icg",icg,"gloc(",i,icg,")",gloc(i,icg)
7283 c        endif
7284 ccc      write(iout,747) "GRAD_KAT_2", i, nphi, icg, grad_dih3,
7285 ccc     & gloc(nphi+i-3,icg)
7286
7287       enddo ! i-loop for dih
7288 #ifdef DEBUG
7289       write(iout,*) "------- dih restrs end -------"
7290 #endif
7291
7292 c Pseudo-energy and gradient for theta angle restraints from
7293 c homology templates
7294 c FP 01/15 - inserted from econstr_local_test.F, loop structure
7295 c adapted
7296
7297 c
7298 c     For constr_homology reference structures (FP)
7299 c
7300 c     Uconst_back_tot=0.0d0
7301       Eval=0.0d0
7302       Erot=0.0d0
7303 c     Econstr_back legacy
7304       do i=1,nres
7305 c     do i=ithet_start,ithet_end
7306        dutheta(i)=0.0d0
7307 c     enddo
7308 c     do i=loc_start,loc_end
7309         do j=1,3
7310           duscdiff(j,i)=0.0d0
7311           duscdiffx(j,i)=0.0d0
7312         enddo
7313       enddo
7314 c
7315 c     do iref=1,nref
7316 c     write (iout,*) "ithet_start =",ithet_start,"ithet_end =",ithet_end
7317 c     write (iout,*) "waga_theta",waga_theta
7318       if (waga_theta.gt.0.0d0) then
7319 #ifdef DEBUG
7320       write (iout,*) "usampl",usampl
7321       write(iout,*) "------- theta restrs start -------"
7322 c     do i=ithet_start,ithet_end
7323 c       write (iout,*) "gloc_init(",nphi+i,icg,")",gloc(nphi+i,icg)
7324 c     enddo
7325 #endif
7326 c     write (iout,*) "maxres",maxres,"nres",nres
7327
7328       do i=ithet_start,ithet_end
7329 c
7330 c     do i=1,nfrag_back
7331 c       ii = ifrag_back(2,i,iset)-ifrag_back(1,i,iset)
7332 c
7333 c Deviation of theta angles wrt constr_homology ref structures
7334 c
7335         utheta_i=0.0d0 ! argument of Gaussian for single k
7336         gutheta_i=0.0d0 ! Sum of Gaussians over constr_homology ref structures
7337 c       do j=ifrag_back(1,i,iset)+2,ifrag_back(2,i,iset) ! original loop
7338 c       over residues in a fragment
7339 c       write (iout,*) "theta(",i,")=",theta(i)
7340         do k=1,constr_homology
7341 c
7342 c         dtheta_i=theta(j)-thetaref(j,iref)
7343 c         dtheta_i=thetaref(k,i)-theta(i) ! original form without indexing
7344           theta_diff(k)=thetatpl(k,i)-theta(i)
7345 cd          write (iout,'(a8,2i4,2f15.8)') "theta_diff",i,k,theta_diff(k)
7346 cd     &                  ,sigma_theta(k,i)
7347
7348 c
7349           utheta_i=-0.5d0*theta_diff(k)**2*sigma_theta(k,i) ! waga_theta rmvd from Gaussian argument
7350 c         utheta_i=-0.5d0*waga_theta*theta_diff(k)**2*sigma_theta(k,i) ! waga_theta?
7351           gtheta(k)=dexp(utheta_i) ! + min_utheta_i?
7352           gutheta_i=gutheta_i+gtheta(k)  ! Sum of Gaussians (pk)
7353 c         Gradient for single Gaussian restraint in subr Econstr_back
7354 c         dutheta(j-2)=dutheta(j-2)+wfrag_back(1,i,iset)*dtheta_i/(ii-1)
7355 c
7356         enddo
7357 c       write (iout,*) "gtheta",(gtheta(k),k=1,constr_homology) ! exps
7358 c       write (iout,*) "i",i," gutheta_i",gutheta_i ! sum of exps
7359
7360 c
7361 c         Gradient for multiple Gaussian restraint
7362         sum_gtheta=gutheta_i
7363         sum_sgtheta=0.0d0
7364         do k=1,constr_homology
7365 c        New generalized expr for multiple Gaussian from Econstr_back
7366          sgtheta=-gtheta(k)*theta_diff(k)*sigma_theta(k,i) ! waga_theta rmvd
7367 c
7368 c        sgtheta=-gtheta(k)*theta_diff(k)*sigma_theta(k,i)*waga_theta ! right functional form?
7369           sum_sgtheta=sum_sgtheta+sgtheta ! cum variable
7370         enddo
7371 c       Final value of gradient using same var as in Econstr_back
7372         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)
7373      &      +sum_sgtheta/sum_gtheta*waga_theta
7374      &               *waga_homology(iset)
7375 c        dutheta(i-2)=sum_sgtheta/sum_gtheta*waga_theta
7376 c     &               *waga_homology(iset)
7377 c       dutheta(i)=sum_sgtheta/sum_gtheta
7378 c
7379 c       Uconst_back=Uconst_back+waga_theta*utheta(i) ! waga_theta added as weight
7380         Eval=Eval-dLOG(gutheta_i/constr_homology)
7381 c       write (iout,*) "utheta(",i,")=",utheta(i) ! -ln of sum of exps
7382 c       write (iout,*) "Uconst_back",Uconst_back ! sum of -ln-s
7383 c       Uconst_back=Uconst_back+utheta(i)
7384       enddo ! (i-loop for theta)
7385 #ifdef DEBUG
7386       write(iout,*) "------- theta restrs end -------"
7387 #endif
7388       endif
7389 c
7390 c Deviation of local SC geometry
7391 c
7392 c Separation of two i-loops (instructed by AL - 11/3/2014)
7393 c
7394 c     write (iout,*) "loc_start =",loc_start,"loc_end =",loc_end
7395 c     write (iout,*) "waga_d",waga_d
7396
7397 #ifdef DEBUG
7398       write(iout,*) "------- SC restrs start -------"
7399       write (iout,*) "Initial duscdiff,duscdiffx"
7400       do i=loc_start,loc_end
7401         write (iout,*) i,(duscdiff(jik,i),jik=1,3),
7402      &                 (duscdiffx(jik,i),jik=1,3)
7403       enddo
7404 #endif
7405       do i=loc_start,loc_end
7406         usc_diff_i=0.0d0 ! argument of Gaussian for single k
7407         guscdiff(i)=0.0d0 ! Sum of Gaussians over constr_homology ref structures
7408 c       do j=ifrag_back(1,i,iset)+1,ifrag_back(2,i,iset)-1 ! Econstr_back legacy
7409 c       write(iout,*) "xxtab, yytab, zztab"
7410 c       write(iout,'(i5,3f8.2)') i,xxtab(i),yytab(i),zztab(i)
7411         do k=1,constr_homology
7412 c
7413           dxx=-xxtpl(k,i)+xxtab(i) ! Diff b/w x component of ith SC vector in model and kth ref str?
7414 c                                    Original sign inverted for calc of gradients (s. Econstr_back)
7415           dyy=-yytpl(k,i)+yytab(i) ! ibid y
7416           dzz=-zztpl(k,i)+zztab(i) ! ibid z
7417 c         write(iout,*) "dxx, dyy, dzz"
7418 cd          write(iout,'(2i5,4f8.2)') k,i,dxx,dyy,dzz,sigma_d(k,i)
7419 c
7420           usc_diff_i=-0.5d0*(dxx**2+dyy**2+dzz**2)*sigma_d(k,i)  ! waga_d rmvd from Gaussian argument
7421 c         usc_diff(i)=-0.5d0*waga_d*(dxx**2+dyy**2+dzz**2)*sigma_d(k,i) ! waga_d?
7422 c         uscdiffk(k)=usc_diff(i)
7423           guscdiff2(k)=dexp(usc_diff_i) ! without min_scdiff
7424 c          write(iout,*) "i",i," k",k," sigma_d",sigma_d(k,i),
7425 c     &       " guscdiff2",guscdiff2(k)
7426           guscdiff(i)=guscdiff(i)+guscdiff2(k)  !Sum of Gaussians (pk)
7427 c          write (iout,'(i5,6f10.5)') j,xxtab(j),yytab(j),zztab(j),
7428 c     &      xxref(j),yyref(j),zzref(j)
7429         enddo
7430 c
7431 c       Gradient
7432 c
7433 c       Generalized expression for multiple Gaussian acc to that for a single
7434 c       Gaussian in Econstr_back as instructed by AL (FP - 03/11/2014)
7435 c
7436 c       Original implementation
7437 c       sum_guscdiff=guscdiff(i)
7438 c
7439 c       sum_sguscdiff=0.0d0
7440 c       do k=1,constr_homology
7441 c          sguscdiff=-guscdiff2(k)*dscdiff(k)*sigma_d(k,i)*waga_d !waga_d?
7442 c          sguscdiff=-guscdiff3(k)*dscdiff(k)*sigma_d(k,i)*waga_d ! w min_uscdiff
7443 c          sum_sguscdiff=sum_sguscdiff+sguscdiff
7444 c       enddo
7445 c
7446 c       Implementation of new expressions for gradient (Jan. 2015)
7447 c
7448 c       grad_uscdiff=sum_sguscdiff/(sum_guscdiff*dtab) !?
7449         do k=1,constr_homology
7450 c
7451 c       New calculation of dxx, dyy, and dzz corrected by AL (07/11), was missing and wrong
7452 c       before. Now the drivatives should be correct
7453 c
7454           dxx=-xxtpl(k,i)+xxtab(i) ! Diff b/w x component of ith SC vector in model and kth ref str?
7455 c                                  Original sign inverted for calc of gradients (s. Econstr_back)
7456           dyy=-yytpl(k,i)+yytab(i) ! ibid y
7457           dzz=-zztpl(k,i)+zztab(i) ! ibid z
7458 c
7459 c         New implementation
7460 c
7461           sum_guscdiff=guscdiff2(k)*!(dsqrt(dxx*dxx+dyy*dyy+dzz*dzz))* -> wrong!
7462      &                 sigma_d(k,i) ! for the grad wrt r'
7463 c         sum_sguscdiff=sum_sguscdiff+sum_guscdiff
7464 c
7465 c
7466 c        New implementation
7467          sum_guscdiff = waga_homology(iset)*waga_d*sum_guscdiff
7468          do jik=1,3
7469             duscdiff(jik,i-1)=duscdiff(jik,i-1)+
7470      &      sum_guscdiff*(dXX_C1tab(jik,i)*dxx+
7471      &      dYY_C1tab(jik,i)*dyy+dZZ_C1tab(jik,i)*dzz)/guscdiff(i)
7472             duscdiff(jik,i)=duscdiff(jik,i)+
7473      &      sum_guscdiff*(dXX_Ctab(jik,i)*dxx+
7474      &      dYY_Ctab(jik,i)*dyy+dZZ_Ctab(jik,i)*dzz)/guscdiff(i)
7475             duscdiffx(jik,i)=duscdiffx(jik,i)+
7476      &      sum_guscdiff*(dXX_XYZtab(jik,i)*dxx+
7477      &      dYY_XYZtab(jik,i)*dyy+dZZ_XYZtab(jik,i)*dzz)/guscdiff(i)
7478 c
7479 #ifdef DEBUG
7480              write(iout,*) "jik",jik,"i",i
7481              write(iout,*) "dxx, dyy, dzz"
7482              write(iout,'(2i5,3f8.2)') k,i,dxx,dyy,dzz
7483              write(iout,*) "guscdiff2(",k,")",guscdiff2(k)
7484 c            write(iout,*) "sum_sguscdiff",sum_sguscdiff
7485 cc           write(iout,*) "dXX_Ctab(",jik,i,")",dXX_Ctab(jik,i)
7486 c            write(iout,*) "dYY_Ctab(",jik,i,")",dYY_Ctab(jik,i)
7487 c            write(iout,*) "dZZ_Ctab(",jik,i,")",dZZ_Ctab(jik,i)
7488 c            write(iout,*) "dXX_C1tab(",jik,i,")",dXX_C1tab(jik,i)
7489 c            write(iout,*) "dYY_C1tab(",jik,i,")",dYY_C1tab(jik,i)
7490 c            write(iout,*) "dZZ_C1tab(",jik,i,")",dZZ_C1tab(jik,i)
7491 c            write(iout,*) "dXX_XYZtab(",jik,i,")",dXX_XYZtab(jik,i)
7492 c            write(iout,*) "dYY_XYZtab(",jik,i,")",dYY_XYZtab(jik,i)
7493 c            write(iout,*) "dZZ_XYZtab(",jik,i,")",dZZ_XYZtab(jik,i)
7494 c            write(iout,*) "duscdiff(",jik,i-1,")",duscdiff(jik,i-1)
7495 c            write(iout,*) "duscdiff(",jik,i,")",duscdiff(jik,i)
7496 c            write(iout,*) "duscdiffx(",jik,i,")",duscdiffx(jik,i)
7497 c            endif
7498 #endif
7499          enddo
7500         enddo
7501 c
7502 c       uscdiff(i)=-dLOG(guscdiff(i)/(ii-1))      ! Weighting by (ii-1) required?
7503 c        usc_diff(i)=-dLOG(guscdiff(i)/constr_homology) ! + min_uscdiff ?
7504 c
7505 c        write (iout,*) i," uscdiff",uscdiff(i)
7506 c
7507 c Put together deviations from local geometry
7508
7509 c       Uconst_back=Uconst_back+wfrag_back(1,i,iset)*utheta(i)+
7510 c      &            wfrag_back(3,i,iset)*uscdiff(i)
7511         Erot=Erot-dLOG(guscdiff(i)/constr_homology)
7512 c       write (iout,*) "usc_diff(",i,")=",usc_diff(i) ! -ln of sum of exps
7513 c       write (iout,*) "Uconst_back",Uconst_back ! cum sum of -ln-s
7514 c       Uconst_back=Uconst_back+usc_diff(i)
7515 c
7516 c     Gradient of multiple Gaussian restraint (FP - 04/11/2014 - right?)
7517 c
7518 c     New implment: multiplied by sum_sguscdiff
7519 c
7520
7521       enddo ! (i-loop for dscdiff)
7522
7523 c      endif
7524
7525 #ifdef DEBUG
7526       write(iout,*) "------- SC restrs end -------"
7527         write (iout,*) "------ After SC loop in e_modeller ------"
7528         do i=loc_start,loc_end
7529          write (iout,*) "i",i," gradc",(gradc(j,i,icg),j=1,3)
7530          write (iout,*) "i",i," gradx",(gradx(j,i,icg),j=1,3)
7531         enddo
7532       if (waga_theta.eq.1.0d0) then
7533       write (iout,*) "in e_modeller after SC restr end: dutheta"
7534       do i=ithet_start,ithet_end
7535         write (iout,*) i,dutheta(i)
7536       enddo
7537       endif
7538       if (waga_d.eq.1.0d0) then
7539       write (iout,*) "e_modeller after SC loop: duscdiff/x"
7540       do i=1,nres
7541         write (iout,*) i,(duscdiff(j,i),j=1,3)
7542         write (iout,*) i,(duscdiffx(j,i),j=1,3)
7543       enddo
7544       endif
7545 #endif
7546
7547 c Total energy from homology restraints
7548 #ifdef DEBUG
7549       write (iout,*) "odleg",odleg," kat",kat
7550 #endif
7551 c
7552 c Addition of energy of theta angle and SC local geom over constr_homologs ref strs
7553 c
7554 c     ehomology_constr=odleg+kat
7555 c
7556 c     For Lorentzian-type Urestr
7557 c
7558
7559       if (waga_dist.ge.0.0d0) then
7560 c
7561 c          For Gaussian-type Urestr
7562 c
7563         ehomology_constr=(waga_dist*odleg+waga_angle*kat+
7564      &              waga_theta*Eval+waga_d*Erot)*waga_homology(iset)
7565 c     write (iout,*) "ehomology_constr=",ehomology_constr
7566       else
7567 c
7568 c          For Lorentzian-type Urestr
7569 c
7570         ehomology_constr=(-waga_dist*odleg+waga_angle*kat+
7571      &              waga_theta*Eval+waga_d*Erot)*waga_homology(iset)
7572 c     write (iout,*) "ehomology_constr=",ehomology_constr
7573       endif
7574 #ifdef DEBUG
7575       write (iout,*) "odleg",waga_dist,odleg," kat",waga_angle,kat,
7576      & "Eval",waga_theta,eval,
7577      &   "Erot",waga_d,Erot
7578       write (iout,*) "ehomology_constr",ehomology_constr
7579 #endif
7580       return
7581 c
7582 c FP 01/15 end
7583 c
7584   748 format(a8,f12.3,a6,f12.3,a7,f12.3)
7585   747 format(a12,i4,i4,i4,f8.3,f8.3)
7586   746 format(a12,i4,i4,i4,f8.3,f8.3,f8.3)
7587   778 format(a7,1X,f10.3,1X,a4,1X,f10.3,1X,a5,1X,f10.3)
7588   779 format(i3,1X,i3,1X,i2,1X,a7,1X,f7.3,1X,a7,1X,f7.3,1X,a13,1X,
7589      &       f7.3,1X,a17,1X,f9.3,1X,a10,1X,f8.3,1X,a10,1X,f8.3)
7590       end
7591
7592 c------------------------------------------------------------------------------
7593       subroutine etor_d(etors_d)
7594 C 6/23/01 Compute double torsional energy
7595       implicit real*8 (a-h,o-z)
7596       include 'DIMENSIONS'
7597       include 'COMMON.VAR'
7598       include 'COMMON.GEO'
7599       include 'COMMON.LOCAL'
7600       include 'COMMON.TORSION'
7601       include 'COMMON.INTERACT'
7602       include 'COMMON.DERIV'
7603       include 'COMMON.CHAIN'
7604       include 'COMMON.NAMES'
7605       include 'COMMON.IOUNITS'
7606       include 'COMMON.FFIELD'
7607       include 'COMMON.TORCNSTR'
7608       include 'COMMON.CONTROL'
7609       logical lprn
7610 C Set lprn=.true. for debugging
7611       lprn=.false.
7612 c     lprn=.true.
7613       etors_d=0.0D0
7614 c      write(iout,*) "a tu??"
7615       do i=iphid_start,iphid_end
7616 C ANY TWO ARE DUMMY ATOMS in row CYCLE
7617 C        if (((itype(i-3).eq.ntyp1).and.(itype(i-2).eq.ntyp1)).or.
7618 C     &      ((itype(i-2).eq.ntyp1).and.(itype(i-1).eq.ntyp1)).or.
7619 C     &      ((itype(i-1).eq.ntyp1).and.(itype(i).eq.ntyp1))  .or.
7620 C     &      ((itype(i).eq.ntyp1).and.(itype(i+1).eq.ntyp1))) cycle
7621          if ((itype(i-2).eq.ntyp1).or.itype(i-3).eq.ntyp1.or.
7622      &  (itype(i-1).eq.ntyp1).or.(itype(i).eq.ntyp1).or.
7623      &  (itype(i+1).eq.ntyp1)) cycle
7624 C In current verion the ALL DUMMY ATOM POTENTIALS ARE OFF
7625         etors_d_ii=0.0D0
7626         itori=itortyp(itype(i-2))
7627         itori1=itortyp(itype(i-1))
7628         itori2=itortyp(itype(i))
7629         phii=phi(i)
7630         phii1=phi(i+1)
7631         gloci1=0.0D0
7632         gloci2=0.0D0
7633         iblock=1
7634         if (iabs(itype(i+1)).eq.20) iblock=2
7635 C Iblock=2 Proline type
7636 C ADASKO: WHEN PARAMETERS FOR THIS TYPE OF BLOCKING GROUP IS READY UNCOMMENT
7637 C CHECK WEATHER THERE IS NECCESITY FOR iblock=3 for COO-
7638 C        if (itype(i+1).eq.ntyp1) iblock=3
7639 C The problem of NH3+ group can be resolved by adding new parameters please note if there
7640 C IS or IS NOT need for this
7641 C IF Yes uncomment below and add to parmread.F appropriate changes and to v1cij and so on
7642 C        is (itype(i-3).eq.ntyp1) ntblock=2
7643 C        ntblock is N-terminal blocking group
7644
7645 C Regular cosine and sine terms
7646         do j=1,ntermd_1(itori,itori1,itori2,iblock)
7647 C Example of changes for NH3+ blocking group
7648 C       do j=1,ntermd_1(itori,itori1,itori2,iblock,ntblock)
7649 C          v1cij=v1c(1,j,itori,itori1,itori2,iblock,ntblock)
7650           v1cij=v1c(1,j,itori,itori1,itori2,iblock)
7651           v1sij=v1s(1,j,itori,itori1,itori2,iblock)
7652           v2cij=v1c(2,j,itori,itori1,itori2,iblock)
7653           v2sij=v1s(2,j,itori,itori1,itori2,iblock)
7654           cosphi1=dcos(j*phii)
7655           sinphi1=dsin(j*phii)
7656           cosphi2=dcos(j*phii1)
7657           sinphi2=dsin(j*phii1)
7658           etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+
7659      &     v2cij*cosphi2+v2sij*sinphi2
7660           if (energy_dec) etors_d_ii=etors_d_ii+
7661      &     v1cij*cosphi1+v1sij*sinphi1+v2cij*cosphi2+v2sij*sinphi2
7662           gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
7663           gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
7664         enddo
7665         do k=2,ntermd_2(itori,itori1,itori2,iblock)
7666           do l=1,k-1
7667             v1cdij = v2c(k,l,itori,itori1,itori2,iblock)
7668             v2cdij = v2c(l,k,itori,itori1,itori2,iblock)
7669             v1sdij = v2s(k,l,itori,itori1,itori2,iblock)
7670             v2sdij = v2s(l,k,itori,itori1,itori2,iblock)
7671             cosphi1p2=dcos(l*phii+(k-l)*phii1)
7672             cosphi1m2=dcos(l*phii-(k-l)*phii1)
7673             sinphi1p2=dsin(l*phii+(k-l)*phii1)
7674             sinphi1m2=dsin(l*phii-(k-l)*phii1)
7675             etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+
7676      &        v1sdij*sinphi1p2+v2sdij*sinphi1m2
7677             if (energy_dec) etors_d_ii=etors_d_ii+
7678      &        v1cdij*cosphi1p2+v2cdij*cosphi1m2+
7679      &        v1sdij*sinphi1p2+v2sdij*sinphi1m2
7680             gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2
7681      &        -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
7682             gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2
7683      &        -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
7684           enddo
7685         enddo
7686           if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
7687      &         'etor_d',i,etors_d_ii
7688         gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*gloci1
7689         gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*gloci2
7690       enddo
7691       return
7692       end
7693 #endif
7694 c------------------------------------------------------------------------------
7695       subroutine eback_sc_corr(esccor)
7696 c 7/21/2007 Correlations between the backbone-local and side-chain-local
7697 c        conformational states; temporarily implemented as differences
7698 c        between UNRES torsional potentials (dependent on three types of
7699 c        residues) and the torsional potentials dependent on all 20 types
7700 c        of residues computed from AM1  energy surfaces of terminally-blocked
7701 c        amino-acid residues.
7702       implicit real*8 (a-h,o-z)
7703       include 'DIMENSIONS'
7704       include 'COMMON.VAR'
7705       include 'COMMON.GEO'
7706       include 'COMMON.LOCAL'
7707       include 'COMMON.TORSION'
7708       include 'COMMON.SCCOR'
7709       include 'COMMON.INTERACT'
7710       include 'COMMON.DERIV'
7711       include 'COMMON.CHAIN'
7712       include 'COMMON.NAMES'
7713       include 'COMMON.IOUNITS'
7714       include 'COMMON.FFIELD'
7715       include 'COMMON.CONTROL'
7716       logical lprn
7717 C Set lprn=.true. for debugging
7718       lprn=.false.
7719 c      lprn=.true.
7720 c      write (iout,*) "EBACK_SC_COR",itau_start,itau_end
7721       esccor=0.0D0
7722       do i=itau_start,itau_end
7723         if ((itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)) cycle
7724         isccori=isccortyp(itype(i-2))
7725         isccori1=isccortyp(itype(i-1))
7726 c      write (iout,*) "EBACK_SC_COR",i,nterm_sccor(isccori,isccori1)
7727         phii=phi(i)
7728         do intertyp=1,3 !intertyp
7729          esccor_ii=0.0D0
7730 cc Added 09 May 2012 (Adasko)
7731 cc  Intertyp means interaction type of backbone mainchain correlation:
7732 c   1 = SC...Ca...Ca...Ca
7733 c   2 = Ca...Ca...Ca...SC
7734 c   3 = SC...Ca...Ca...SCi
7735         gloci=0.0D0
7736         if (((intertyp.eq.3).and.((itype(i-2).eq.10).or.
7737      &      (itype(i-1).eq.10).or.(itype(i-2).eq.ntyp1).or.
7738      &      (itype(i-1).eq.ntyp1)))
7739      &    .or. ((intertyp.eq.1).and.((itype(i-2).eq.10)
7740      &     .or.(itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)
7741      &     .or.(itype(i).eq.ntyp1)))
7742      &    .or.((intertyp.eq.2).and.((itype(i-1).eq.10).or.
7743      &      (itype(i-1).eq.ntyp1).or.(itype(i-2).eq.ntyp1).or.
7744      &      (itype(i-3).eq.ntyp1)))) cycle
7745         if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1).eq.ntyp1)) cycle
7746         if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres).eq.ntyp1))
7747      & cycle
7748        do j=1,nterm_sccor(isccori,isccori1)
7749           v1ij=v1sccor(j,intertyp,isccori,isccori1)
7750           v2ij=v2sccor(j,intertyp,isccori,isccori1)
7751           cosphi=dcos(j*tauangle(intertyp,i))
7752           sinphi=dsin(j*tauangle(intertyp,i))
7753           if (energy_dec) esccor_ii=esccor_ii+v1ij*cosphi+v2ij*sinphi
7754           esccor=esccor+v1ij*cosphi+v2ij*sinphi
7755           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7756         enddo
7757          if (energy_dec) write (iout,'(a6,i5,i2,0pf7.3)')
7758      &         'esccor',i,intertyp,esccor_ii
7759 c      write (iout,*) "EBACK_SC_COR",i,v1ij*cosphi+v2ij*sinphi,intertyp
7760         gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci
7761         if (lprn)
7762      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
7763      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,isccori,isccori1,
7764      &  (v1sccor(j,intertyp,isccori,isccori1),j=1,6)
7765      & ,(v2sccor(j,intertyp,isccori,isccori1),j=1,6)
7766         gsccor_loc(i-3)=gsccor_loc(i-3)+gloci
7767        enddo !intertyp
7768       enddo
7769
7770       return
7771       end
7772 c----------------------------------------------------------------------------
7773       subroutine multibody(ecorr)
7774 C This subroutine calculates multi-body contributions to energy following
7775 C the idea of Skolnick et al. If side chains I and J make a contact and
7776 C at the same time side chains I+1 and J+1 make a contact, an extra
7777 C contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
7778       implicit real*8 (a-h,o-z)
7779       include 'DIMENSIONS'
7780       include 'COMMON.IOUNITS'
7781       include 'COMMON.DERIV'
7782       include 'COMMON.INTERACT'
7783       include 'COMMON.CONTACTS'
7784       double precision gx(3),gx1(3)
7785       logical lprn
7786
7787 C Set lprn=.true. for debugging
7788       lprn=.false.
7789
7790       if (lprn) then
7791         write (iout,'(a)') 'Contact function values:'
7792         do i=nnt,nct-2
7793           write (iout,'(i2,20(1x,i2,f10.5))')
7794      &        i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
7795         enddo
7796       endif
7797       ecorr=0.0D0
7798       do i=nnt,nct
7799         do j=1,3
7800           gradcorr(j,i)=0.0D0
7801           gradxorr(j,i)=0.0D0
7802         enddo
7803       enddo
7804       do i=nnt,nct-2
7805
7806         DO ISHIFT = 3,4
7807
7808         i1=i+ishift
7809         num_conti=num_cont(i)
7810         num_conti1=num_cont(i1)
7811         do jj=1,num_conti
7812           j=jcont(jj,i)
7813           do kk=1,num_conti1
7814             j1=jcont(kk,i1)
7815             if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
7816 cd          write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
7817 cd   &                   ' ishift=',ishift
7818 C Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
7819 C The system gains extra energy.
7820               ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
7821             endif   ! j1==j+-ishift
7822           enddo     ! kk
7823         enddo       ! jj
7824
7825         ENDDO ! ISHIFT
7826
7827       enddo         ! i
7828       return
7829       end
7830 c------------------------------------------------------------------------------
7831       double precision function esccorr(i,j,k,l,jj,kk)
7832       implicit real*8 (a-h,o-z)
7833       include 'DIMENSIONS'
7834       include 'COMMON.IOUNITS'
7835       include 'COMMON.DERIV'
7836       include 'COMMON.INTERACT'
7837       include 'COMMON.CONTACTS'
7838       double precision gx(3),gx1(3)
7839       logical lprn
7840       lprn=.false.
7841       eij=facont(jj,i)
7842       ekl=facont(kk,k)
7843 cd    write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
7844 C Calculate the multi-body contribution to energy.
7845 C Calculate multi-body contributions to the gradient.
7846 cd    write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
7847 cd   & k,l,(gacont(m,kk,k),m=1,3)
7848       do m=1,3
7849         gx(m) =ekl*gacont(m,jj,i)
7850         gx1(m)=eij*gacont(m,kk,k)
7851         gradxorr(m,i)=gradxorr(m,i)-gx(m)
7852         gradxorr(m,j)=gradxorr(m,j)+gx(m)
7853         gradxorr(m,k)=gradxorr(m,k)-gx1(m)
7854         gradxorr(m,l)=gradxorr(m,l)+gx1(m)
7855       enddo
7856       do m=i,j-1
7857         do ll=1,3
7858           gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
7859         enddo
7860       enddo
7861       do m=k,l-1
7862         do ll=1,3
7863           gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
7864         enddo
7865       enddo
7866       esccorr=-eij*ekl
7867       return
7868       end
7869 c------------------------------------------------------------------------------
7870       subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
7871 C This subroutine calculates multi-body contributions to hydrogen-bonding
7872       implicit real*8 (a-h,o-z)
7873       include 'DIMENSIONS'
7874       include 'COMMON.IOUNITS'
7875 #ifdef MPI
7876       include "mpif.h"
7877       parameter (max_cont=maxconts)
7878       parameter (max_dim=26)
7879       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
7880       double precision zapas(max_dim,maxconts,max_fg_procs),
7881      &  zapas_recv(max_dim,maxconts,max_fg_procs)
7882       common /przechowalnia/ zapas
7883       integer status(MPI_STATUS_SIZE),req(maxconts*2),
7884      &  status_array(MPI_STATUS_SIZE,maxconts*2)
7885 #endif
7886       include 'COMMON.SETUP'
7887       include 'COMMON.FFIELD'
7888       include 'COMMON.DERIV'
7889       include 'COMMON.INTERACT'
7890       include 'COMMON.CONTACTS'
7891       include 'COMMON.CONTROL'
7892       include 'COMMON.LOCAL'
7893       double precision gx(3),gx1(3),time00
7894       logical lprn,ldone
7895
7896 C Set lprn=.true. for debugging
7897       lprn=.false.
7898 #ifdef MPI
7899       n_corr=0
7900       n_corr1=0
7901       if (nfgtasks.le.1) goto 30
7902       if (lprn) then
7903         write (iout,'(a)') 'Contact function values before RECEIVE:'
7904         do i=nnt,nct-2
7905           write (iout,'(2i3,50(1x,i2,f5.2))')
7906      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
7907      &    j=1,num_cont_hb(i))
7908         enddo
7909       endif
7910       call flush(iout)
7911       do i=1,ntask_cont_from
7912         ncont_recv(i)=0
7913       enddo
7914       do i=1,ntask_cont_to
7915         ncont_sent(i)=0
7916       enddo
7917 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
7918 c     & ntask_cont_to
7919 C Make the list of contacts to send to send to other procesors
7920 c      write (iout,*) "limits",max0(iturn4_end-1,iatel_s),iturn3_end
7921 c      call flush(iout)
7922       do i=iturn3_start,iturn3_end
7923 c        write (iout,*) "make contact list turn3",i," num_cont",
7924 c     &    num_cont_hb(i)
7925         call add_hb_contact(i,i+2,iturn3_sent_local(1,i))
7926       enddo
7927       do i=iturn4_start,iturn4_end
7928 c        write (iout,*) "make contact list turn4",i," num_cont",
7929 c     &   num_cont_hb(i)
7930         call add_hb_contact(i,i+3,iturn4_sent_local(1,i))
7931       enddo
7932       do ii=1,nat_sent
7933         i=iat_sent(ii)
7934 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
7935 c     &    num_cont_hb(i)
7936         do j=1,num_cont_hb(i)
7937         do k=1,4
7938           jjc=jcont_hb(j,i)
7939           iproc=iint_sent_local(k,jjc,ii)
7940 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
7941           if (iproc.gt.0) then
7942             ncont_sent(iproc)=ncont_sent(iproc)+1
7943             nn=ncont_sent(iproc)
7944             zapas(1,nn,iproc)=i
7945             zapas(2,nn,iproc)=jjc
7946             zapas(3,nn,iproc)=facont_hb(j,i)
7947             zapas(4,nn,iproc)=ees0p(j,i)
7948             zapas(5,nn,iproc)=ees0m(j,i)
7949             zapas(6,nn,iproc)=gacont_hbr(1,j,i)
7950             zapas(7,nn,iproc)=gacont_hbr(2,j,i)
7951             zapas(8,nn,iproc)=gacont_hbr(3,j,i)
7952             zapas(9,nn,iproc)=gacontm_hb1(1,j,i)
7953             zapas(10,nn,iproc)=gacontm_hb1(2,j,i)
7954             zapas(11,nn,iproc)=gacontm_hb1(3,j,i)
7955             zapas(12,nn,iproc)=gacontp_hb1(1,j,i)
7956             zapas(13,nn,iproc)=gacontp_hb1(2,j,i)
7957             zapas(14,nn,iproc)=gacontp_hb1(3,j,i)
7958             zapas(15,nn,iproc)=gacontm_hb2(1,j,i)
7959             zapas(16,nn,iproc)=gacontm_hb2(2,j,i)
7960             zapas(17,nn,iproc)=gacontm_hb2(3,j,i)
7961             zapas(18,nn,iproc)=gacontp_hb2(1,j,i)
7962             zapas(19,nn,iproc)=gacontp_hb2(2,j,i)
7963             zapas(20,nn,iproc)=gacontp_hb2(3,j,i)
7964             zapas(21,nn,iproc)=gacontm_hb3(1,j,i)
7965             zapas(22,nn,iproc)=gacontm_hb3(2,j,i)
7966             zapas(23,nn,iproc)=gacontm_hb3(3,j,i)
7967             zapas(24,nn,iproc)=gacontp_hb3(1,j,i)
7968             zapas(25,nn,iproc)=gacontp_hb3(2,j,i)
7969             zapas(26,nn,iproc)=gacontp_hb3(3,j,i)
7970           endif
7971         enddo
7972         enddo
7973       enddo
7974       if (lprn) then
7975       write (iout,*)
7976      &  "Numbers of contacts to be sent to other processors",
7977      &  (ncont_sent(i),i=1,ntask_cont_to)
7978       write (iout,*) "Contacts sent"
7979       do ii=1,ntask_cont_to
7980         nn=ncont_sent(ii)
7981         iproc=itask_cont_to(ii)
7982         write (iout,*) nn," contacts to processor",iproc,
7983      &   " of CONT_TO_COMM group"
7984         do i=1,nn
7985           write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
7986         enddo
7987       enddo
7988       call flush(iout)
7989       endif
7990       CorrelType=477
7991       CorrelID=fg_rank+1
7992       CorrelType1=478
7993       CorrelID1=nfgtasks+fg_rank+1
7994       ireq=0
7995 C Receive the numbers of needed contacts from other processors
7996       do ii=1,ntask_cont_from
7997         iproc=itask_cont_from(ii)
7998         ireq=ireq+1
7999         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
8000      &    FG_COMM,req(ireq),IERR)
8001       enddo
8002 c      write (iout,*) "IRECV ended"
8003 c      call flush(iout)
8004 C Send the number of contacts needed by other processors
8005       do ii=1,ntask_cont_to
8006         iproc=itask_cont_to(ii)
8007         ireq=ireq+1
8008         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
8009      &    FG_COMM,req(ireq),IERR)
8010       enddo
8011 c      write (iout,*) "ISEND ended"
8012 c      write (iout,*) "number of requests (nn)",ireq
8013       call flush(iout)
8014       if (ireq.gt.0)
8015      &  call MPI_Waitall(ireq,req,status_array,ierr)
8016 c      write (iout,*)
8017 c     &  "Numbers of contacts to be received from other processors",
8018 c     &  (ncont_recv(i),i=1,ntask_cont_from)
8019 c      call flush(iout)
8020 C Receive contacts
8021       ireq=0
8022       do ii=1,ntask_cont_from
8023         iproc=itask_cont_from(ii)
8024         nn=ncont_recv(ii)
8025 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
8026 c     &   " of CONT_TO_COMM group"
8027         call flush(iout)
8028         if (nn.gt.0) then
8029           ireq=ireq+1
8030           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
8031      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
8032 c          write (iout,*) "ireq,req",ireq,req(ireq)
8033         endif
8034       enddo
8035 C Send the contacts to processors that need them
8036       do ii=1,ntask_cont_to
8037         iproc=itask_cont_to(ii)
8038         nn=ncont_sent(ii)
8039 c        write (iout,*) nn," contacts to processor",iproc,
8040 c     &   " of CONT_TO_COMM group"
8041         if (nn.gt.0) then
8042           ireq=ireq+1
8043           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
8044      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
8045 c          write (iout,*) "ireq,req",ireq,req(ireq)
8046 c          do i=1,nn
8047 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
8048 c          enddo
8049         endif
8050       enddo
8051 c      write (iout,*) "number of requests (contacts)",ireq
8052 c      write (iout,*) "req",(req(i),i=1,4)
8053 c      call flush(iout)
8054       if (ireq.gt.0)
8055      & call MPI_Waitall(ireq,req,status_array,ierr)
8056       do iii=1,ntask_cont_from
8057         iproc=itask_cont_from(iii)
8058         nn=ncont_recv(iii)
8059         if (lprn) then
8060         write (iout,*) "Received",nn," contacts from processor",iproc,
8061      &   " of CONT_FROM_COMM group"
8062         call flush(iout)
8063         do i=1,nn
8064           write(iout,'(2f5.0,4f10.5)')(zapas_recv(j,i,iii),j=1,5)
8065         enddo
8066         call flush(iout)
8067         endif
8068         do i=1,nn
8069           ii=zapas_recv(1,i,iii)
8070 c Flag the received contacts to prevent double-counting
8071           jj=-zapas_recv(2,i,iii)
8072 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
8073 c          call flush(iout)
8074           nnn=num_cont_hb(ii)+1
8075           num_cont_hb(ii)=nnn
8076           jcont_hb(nnn,ii)=jj
8077           facont_hb(nnn,ii)=zapas_recv(3,i,iii)
8078           ees0p(nnn,ii)=zapas_recv(4,i,iii)
8079           ees0m(nnn,ii)=zapas_recv(5,i,iii)
8080           gacont_hbr(1,nnn,ii)=zapas_recv(6,i,iii)
8081           gacont_hbr(2,nnn,ii)=zapas_recv(7,i,iii)
8082           gacont_hbr(3,nnn,ii)=zapas_recv(8,i,iii)
8083           gacontm_hb1(1,nnn,ii)=zapas_recv(9,i,iii)
8084           gacontm_hb1(2,nnn,ii)=zapas_recv(10,i,iii)
8085           gacontm_hb1(3,nnn,ii)=zapas_recv(11,i,iii)
8086           gacontp_hb1(1,nnn,ii)=zapas_recv(12,i,iii)
8087           gacontp_hb1(2,nnn,ii)=zapas_recv(13,i,iii)
8088           gacontp_hb1(3,nnn,ii)=zapas_recv(14,i,iii)
8089           gacontm_hb2(1,nnn,ii)=zapas_recv(15,i,iii)
8090           gacontm_hb2(2,nnn,ii)=zapas_recv(16,i,iii)
8091           gacontm_hb2(3,nnn,ii)=zapas_recv(17,i,iii)
8092           gacontp_hb2(1,nnn,ii)=zapas_recv(18,i,iii)
8093           gacontp_hb2(2,nnn,ii)=zapas_recv(19,i,iii)
8094           gacontp_hb2(3,nnn,ii)=zapas_recv(20,i,iii)
8095           gacontm_hb3(1,nnn,ii)=zapas_recv(21,i,iii)
8096           gacontm_hb3(2,nnn,ii)=zapas_recv(22,i,iii)
8097           gacontm_hb3(3,nnn,ii)=zapas_recv(23,i,iii)
8098           gacontp_hb3(1,nnn,ii)=zapas_recv(24,i,iii)
8099           gacontp_hb3(2,nnn,ii)=zapas_recv(25,i,iii)
8100           gacontp_hb3(3,nnn,ii)=zapas_recv(26,i,iii)
8101         enddo
8102       enddo
8103       call flush(iout)
8104       if (lprn) then
8105         write (iout,'(a)') 'Contact function values after receive:'
8106         do i=nnt,nct-2
8107           write (iout,'(2i3,50(1x,i3,f5.2))')
8108      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
8109      &    j=1,num_cont_hb(i))
8110         enddo
8111         call flush(iout)
8112       endif
8113    30 continue
8114 #endif
8115       if (lprn) then
8116         write (iout,'(a)') 'Contact function values:'
8117         do i=nnt,nct-2
8118           write (iout,'(2i3,50(1x,i3,f5.2))')
8119      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
8120      &    j=1,num_cont_hb(i))
8121         enddo
8122       endif
8123       ecorr=0.0D0
8124 C Remove the loop below after debugging !!!
8125       do i=nnt,nct
8126         do j=1,3
8127           gradcorr(j,i)=0.0D0
8128           gradxorr(j,i)=0.0D0
8129         enddo
8130       enddo
8131 C Calculate the local-electrostatic correlation terms
8132       do i=min0(iatel_s,iturn4_start),max0(iatel_e,iturn3_end)
8133         i1=i+1
8134         num_conti=num_cont_hb(i)
8135         num_conti1=num_cont_hb(i+1)
8136         do jj=1,num_conti
8137           j=jcont_hb(jj,i)
8138           jp=iabs(j)
8139           do kk=1,num_conti1
8140             j1=jcont_hb(kk,i1)
8141             jp1=iabs(j1)
8142 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
8143 c     &         ' jj=',jj,' kk=',kk
8144             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
8145      &          .or. j.lt.0 .and. j1.gt.0) .and.
8146      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
8147 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
8148 C The system gains extra energy.
8149               ecorr=ecorr+ehbcorr(i,jp,i+1,jp1,jj,kk,0.72D0,0.32D0)
8150               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
8151      &            'ecorrh',i,j,ehbcorr(i,j,i+1,j1,jj,kk,0.72D0,0.32D0)
8152               n_corr=n_corr+1
8153             else if (j1.eq.j) then
8154 C Contacts I-J and I-(J+1) occur simultaneously.
8155 C The system loses extra energy.
8156 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
8157             endif
8158           enddo ! kk
8159           do kk=1,num_conti
8160             j1=jcont_hb(kk,i)
8161 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
8162 c    &         ' jj=',jj,' kk=',kk
8163             if (j1.eq.j+1) then
8164 C Contacts I-J and (I+1)-J occur simultaneously.
8165 C The system loses extra energy.
8166 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
8167             endif ! j1==j+1
8168           enddo ! kk
8169         enddo ! jj
8170       enddo ! i
8171       return
8172       end
8173 c------------------------------------------------------------------------------
8174       subroutine add_hb_contact(ii,jj,itask)
8175       implicit real*8 (a-h,o-z)
8176       include "DIMENSIONS"
8177       include "COMMON.IOUNITS"
8178       integer max_cont
8179       integer max_dim
8180       parameter (max_cont=maxconts)
8181       parameter (max_dim=26)
8182       include "COMMON.CONTACTS"
8183       double precision zapas(max_dim,maxconts,max_fg_procs),
8184      &  zapas_recv(max_dim,maxconts,max_fg_procs)
8185       common /przechowalnia/ zapas
8186       integer i,j,ii,jj,iproc,itask(4),nn
8187 c      write (iout,*) "itask",itask
8188       do i=1,2
8189         iproc=itask(i)
8190         if (iproc.gt.0) then
8191           do j=1,num_cont_hb(ii)
8192             jjc=jcont_hb(j,ii)
8193 c            write (iout,*) "i",ii," j",jj," jjc",jjc
8194             if (jjc.eq.jj) then
8195               ncont_sent(iproc)=ncont_sent(iproc)+1
8196               nn=ncont_sent(iproc)
8197               zapas(1,nn,iproc)=ii
8198               zapas(2,nn,iproc)=jjc
8199               zapas(3,nn,iproc)=facont_hb(j,ii)
8200               zapas(4,nn,iproc)=ees0p(j,ii)
8201               zapas(5,nn,iproc)=ees0m(j,ii)
8202               zapas(6,nn,iproc)=gacont_hbr(1,j,ii)
8203               zapas(7,nn,iproc)=gacont_hbr(2,j,ii)
8204               zapas(8,nn,iproc)=gacont_hbr(3,j,ii)
8205               zapas(9,nn,iproc)=gacontm_hb1(1,j,ii)
8206               zapas(10,nn,iproc)=gacontm_hb1(2,j,ii)
8207               zapas(11,nn,iproc)=gacontm_hb1(3,j,ii)
8208               zapas(12,nn,iproc)=gacontp_hb1(1,j,ii)
8209               zapas(13,nn,iproc)=gacontp_hb1(2,j,ii)
8210               zapas(14,nn,iproc)=gacontp_hb1(3,j,ii)
8211               zapas(15,nn,iproc)=gacontm_hb2(1,j,ii)
8212               zapas(16,nn,iproc)=gacontm_hb2(2,j,ii)
8213               zapas(17,nn,iproc)=gacontm_hb2(3,j,ii)
8214               zapas(18,nn,iproc)=gacontp_hb2(1,j,ii)
8215               zapas(19,nn,iproc)=gacontp_hb2(2,j,ii)
8216               zapas(20,nn,iproc)=gacontp_hb2(3,j,ii)
8217               zapas(21,nn,iproc)=gacontm_hb3(1,j,ii)
8218               zapas(22,nn,iproc)=gacontm_hb3(2,j,ii)
8219               zapas(23,nn,iproc)=gacontm_hb3(3,j,ii)
8220               zapas(24,nn,iproc)=gacontp_hb3(1,j,ii)
8221               zapas(25,nn,iproc)=gacontp_hb3(2,j,ii)
8222               zapas(26,nn,iproc)=gacontp_hb3(3,j,ii)
8223               exit
8224             endif
8225           enddo
8226         endif
8227       enddo
8228       return
8229       end
8230 c------------------------------------------------------------------------------
8231       subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,
8232      &  n_corr1)
8233 C This subroutine calculates multi-body contributions to hydrogen-bonding
8234       implicit real*8 (a-h,o-z)
8235       include 'DIMENSIONS'
8236       include 'COMMON.IOUNITS'
8237 #ifdef MPI
8238       include "mpif.h"
8239       parameter (max_cont=maxconts)
8240       parameter (max_dim=70)
8241       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
8242       double precision zapas(max_dim,maxconts,max_fg_procs),
8243      &  zapas_recv(max_dim,maxconts,max_fg_procs)
8244       common /przechowalnia/ zapas
8245       integer status(MPI_STATUS_SIZE),req(maxconts*2),
8246      &  status_array(MPI_STATUS_SIZE,maxconts*2)
8247 #endif
8248       include 'COMMON.SETUP'
8249       include 'COMMON.FFIELD'
8250       include 'COMMON.DERIV'
8251       include 'COMMON.LOCAL'
8252       include 'COMMON.INTERACT'
8253       include 'COMMON.CONTACTS'
8254       include 'COMMON.CHAIN'
8255       include 'COMMON.CONTROL'
8256       double precision gx(3),gx1(3)
8257       integer num_cont_hb_old(maxres)
8258       logical lprn,ldone
8259       double precision eello4,eello5,eelo6,eello_turn6
8260       external eello4,eello5,eello6,eello_turn6
8261 C Set lprn=.true. for debugging
8262       lprn=.false.
8263       eturn6=0.0d0
8264 #ifdef MPI
8265       do i=1,nres
8266         num_cont_hb_old(i)=num_cont_hb(i)
8267       enddo
8268       n_corr=0
8269       n_corr1=0
8270       if (nfgtasks.le.1) goto 30
8271       if (lprn) then
8272         write (iout,'(a)') 'Contact function values before RECEIVE:'
8273         do i=nnt,nct-2
8274           write (iout,'(2i3,50(1x,i2,f5.2))')
8275      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
8276      &    j=1,num_cont_hb(i))
8277         enddo
8278       endif
8279       call flush(iout)
8280       do i=1,ntask_cont_from
8281         ncont_recv(i)=0
8282       enddo
8283       do i=1,ntask_cont_to
8284         ncont_sent(i)=0
8285       enddo
8286 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
8287 c     & ntask_cont_to
8288 C Make the list of contacts to send to send to other procesors
8289       do i=iturn3_start,iturn3_end
8290 c        write (iout,*) "make contact list turn3",i," num_cont",
8291 c     &    num_cont_hb(i)
8292         call add_hb_contact_eello(i,i+2,iturn3_sent_local(1,i))
8293       enddo
8294       do i=iturn4_start,iturn4_end
8295 c        write (iout,*) "make contact list turn4",i," num_cont",
8296 c     &   num_cont_hb(i)
8297         call add_hb_contact_eello(i,i+3,iturn4_sent_local(1,i))
8298       enddo
8299       do ii=1,nat_sent
8300         i=iat_sent(ii)
8301 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
8302 c     &    num_cont_hb(i)
8303         do j=1,num_cont_hb(i)
8304         do k=1,4
8305           jjc=jcont_hb(j,i)
8306           iproc=iint_sent_local(k,jjc,ii)
8307 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
8308           if (iproc.ne.0) then
8309             ncont_sent(iproc)=ncont_sent(iproc)+1
8310             nn=ncont_sent(iproc)
8311             zapas(1,nn,iproc)=i
8312             zapas(2,nn,iproc)=jjc
8313             zapas(3,nn,iproc)=d_cont(j,i)
8314             ind=3
8315             do kk=1,3
8316               ind=ind+1
8317               zapas(ind,nn,iproc)=grij_hb_cont(kk,j,i)
8318             enddo
8319             do kk=1,2
8320               do ll=1,2
8321                 ind=ind+1
8322                 zapas(ind,nn,iproc)=a_chuj(ll,kk,j,i)
8323               enddo
8324             enddo
8325             do jj=1,5
8326               do kk=1,3
8327                 do ll=1,2
8328                   do mm=1,2
8329                     ind=ind+1
8330                     zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,i)
8331                   enddo
8332                 enddo
8333               enddo
8334             enddo
8335           endif
8336         enddo
8337         enddo
8338       enddo
8339       if (lprn) then
8340       write (iout,*)
8341      &  "Numbers of contacts to be sent to other processors",
8342      &  (ncont_sent(i),i=1,ntask_cont_to)
8343       write (iout,*) "Contacts sent"
8344       do ii=1,ntask_cont_to
8345         nn=ncont_sent(ii)
8346         iproc=itask_cont_to(ii)
8347         write (iout,*) nn," contacts to processor",iproc,
8348      &   " of CONT_TO_COMM group"
8349         do i=1,nn
8350           write(iout,'(2f5.0,10f10.5)')(zapas(j,i,ii),j=1,10)
8351         enddo
8352       enddo
8353       call flush(iout)
8354       endif
8355       CorrelType=477
8356       CorrelID=fg_rank+1
8357       CorrelType1=478
8358       CorrelID1=nfgtasks+fg_rank+1
8359       ireq=0
8360 C Receive the numbers of needed contacts from other processors
8361       do ii=1,ntask_cont_from
8362         iproc=itask_cont_from(ii)
8363         ireq=ireq+1
8364         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
8365      &    FG_COMM,req(ireq),IERR)
8366       enddo
8367 c      write (iout,*) "IRECV ended"
8368 c      call flush(iout)
8369 C Send the number of contacts needed by other processors
8370       do ii=1,ntask_cont_to
8371         iproc=itask_cont_to(ii)
8372         ireq=ireq+1
8373         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
8374      &    FG_COMM,req(ireq),IERR)
8375       enddo
8376 c      write (iout,*) "ISEND ended"
8377 c      write (iout,*) "number of requests (nn)",ireq
8378       call flush(iout)
8379       if (ireq.gt.0)
8380      &  call MPI_Waitall(ireq,req,status_array,ierr)
8381 c      write (iout,*)
8382 c     &  "Numbers of contacts to be received from other processors",
8383 c     &  (ncont_recv(i),i=1,ntask_cont_from)
8384 c      call flush(iout)
8385 C Receive contacts
8386       ireq=0
8387       do ii=1,ntask_cont_from
8388         iproc=itask_cont_from(ii)
8389         nn=ncont_recv(ii)
8390 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
8391 c     &   " of CONT_TO_COMM group"
8392         call flush(iout)
8393         if (nn.gt.0) then
8394           ireq=ireq+1
8395           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
8396      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
8397 c          write (iout,*) "ireq,req",ireq,req(ireq)
8398         endif
8399       enddo
8400 C Send the contacts to processors that need them
8401       do ii=1,ntask_cont_to
8402         iproc=itask_cont_to(ii)
8403         nn=ncont_sent(ii)
8404 c        write (iout,*) nn," contacts to processor",iproc,
8405 c     &   " of CONT_TO_COMM group"
8406         if (nn.gt.0) then
8407           ireq=ireq+1
8408           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
8409      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
8410 c          write (iout,*) "ireq,req",ireq,req(ireq)
8411 c          do i=1,nn
8412 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
8413 c          enddo
8414         endif
8415       enddo
8416 c      write (iout,*) "number of requests (contacts)",ireq
8417 c      write (iout,*) "req",(req(i),i=1,4)
8418 c      call flush(iout)
8419       if (ireq.gt.0)
8420      & call MPI_Waitall(ireq,req,status_array,ierr)
8421       do iii=1,ntask_cont_from
8422         iproc=itask_cont_from(iii)
8423         nn=ncont_recv(iii)
8424         if (lprn) then
8425         write (iout,*) "Received",nn," contacts from processor",iproc,
8426      &   " of CONT_FROM_COMM group"
8427         call flush(iout)
8428         do i=1,nn
8429           write(iout,'(2f5.0,10f10.5)')(zapas_recv(j,i,iii),j=1,10)
8430         enddo
8431         call flush(iout)
8432         endif
8433         do i=1,nn
8434           ii=zapas_recv(1,i,iii)
8435 c Flag the received contacts to prevent double-counting
8436           jj=-zapas_recv(2,i,iii)
8437 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
8438 c          call flush(iout)
8439           nnn=num_cont_hb(ii)+1
8440           num_cont_hb(ii)=nnn
8441           jcont_hb(nnn,ii)=jj
8442           d_cont(nnn,ii)=zapas_recv(3,i,iii)
8443           ind=3
8444           do kk=1,3
8445             ind=ind+1
8446             grij_hb_cont(kk,nnn,ii)=zapas_recv(ind,i,iii)
8447           enddo
8448           do kk=1,2
8449             do ll=1,2
8450               ind=ind+1
8451               a_chuj(ll,kk,nnn,ii)=zapas_recv(ind,i,iii)
8452             enddo
8453           enddo
8454           do jj=1,5
8455             do kk=1,3
8456               do ll=1,2
8457                 do mm=1,2
8458                   ind=ind+1
8459                   a_chuj_der(mm,ll,kk,jj,nnn,ii)=zapas_recv(ind,i,iii)
8460                 enddo
8461               enddo
8462             enddo
8463           enddo
8464         enddo
8465       enddo
8466       call flush(iout)
8467       if (lprn) then
8468         write (iout,'(a)') 'Contact function values after receive:'
8469         do i=nnt,nct-2
8470           write (iout,'(2i3,50(1x,i3,5f6.3))')
8471      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
8472      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
8473         enddo
8474         call flush(iout)
8475       endif
8476    30 continue
8477 #endif
8478       if (lprn) then
8479         write (iout,'(a)') 'Contact function values:'
8480         do i=nnt,nct-2
8481           write (iout,'(2i3,50(1x,i2,5f6.3))')
8482      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
8483      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
8484         enddo
8485       endif
8486       ecorr=0.0D0
8487       ecorr5=0.0d0
8488       ecorr6=0.0d0
8489 C Remove the loop below after debugging !!!
8490       do i=nnt,nct
8491         do j=1,3
8492           gradcorr(j,i)=0.0D0
8493           gradxorr(j,i)=0.0D0
8494         enddo
8495       enddo
8496 C Calculate the dipole-dipole interaction energies
8497       if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
8498       do i=iatel_s,iatel_e+1
8499         num_conti=num_cont_hb(i)
8500         do jj=1,num_conti
8501           j=jcont_hb(jj,i)
8502 #ifdef MOMENT
8503           call dipole(i,j,jj)
8504 #endif
8505         enddo
8506       enddo
8507       endif
8508 C Calculate the local-electrostatic correlation terms
8509 c                write (iout,*) "gradcorr5 in eello5 before loop"
8510 c                do iii=1,nres
8511 c                  write (iout,'(i5,3f10.5)')
8512 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
8513 c                enddo
8514       do i=min0(iatel_s,iturn4_start),max0(iatel_e+1,iturn3_end+1)
8515 c        write (iout,*) "corr loop i",i
8516         i1=i+1
8517         num_conti=num_cont_hb(i)
8518         num_conti1=num_cont_hb(i+1)
8519         do jj=1,num_conti
8520           j=jcont_hb(jj,i)
8521           jp=iabs(j)
8522           do kk=1,num_conti1
8523             j1=jcont_hb(kk,i1)
8524             jp1=iabs(j1)
8525 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
8526 c     &         ' jj=',jj,' kk=',kk
8527 c            if (j1.eq.j+1 .or. j1.eq.j-1) then
8528             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
8529      &          .or. j.lt.0 .and. j1.gt.0) .and.
8530      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
8531 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
8532 C The system gains extra energy.
8533               n_corr=n_corr+1
8534               sqd1=dsqrt(d_cont(jj,i))
8535               sqd2=dsqrt(d_cont(kk,i1))
8536               sred_geom = sqd1*sqd2
8537               IF (sred_geom.lt.cutoff_corr) THEN
8538                 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,
8539      &            ekont,fprimcont)
8540 cd               write (iout,*) 'i=',i,' j=',jp,' i1=',i1,' j1=',jp1,
8541 cd     &         ' jj=',jj,' kk=',kk
8542                 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
8543                 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
8544                 do l=1,3
8545                   g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
8546                   g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
8547                 enddo
8548                 n_corr1=n_corr1+1
8549 cd               write (iout,*) 'sred_geom=',sred_geom,
8550 cd     &          ' ekont=',ekont,' fprim=',fprimcont,
8551 cd     &          ' fac_prim1',fac_prim1,' fac_prim2',fac_prim2
8552 cd               write (iout,*) "g_contij",g_contij
8553 cd               write (iout,*) "grij_hb_cont i",grij_hb_cont(:,jj,i)
8554 cd               write (iout,*) "grij_hb_cont i1",grij_hb_cont(:,jj,i1)
8555                 call calc_eello(i,jp,i+1,jp1,jj,kk)
8556                 if (wcorr4.gt.0.0d0)
8557      &            ecorr=ecorr+eello4(i,jp,i+1,jp1,jj,kk)
8558                   if (energy_dec.and.wcorr4.gt.0.0d0)
8559      1                 write (iout,'(a6,4i5,0pf7.3)')
8560      2                'ecorr4',i,j,i+1,j1,eello4(i,jp,i+1,jp1,jj,kk)
8561 c                write (iout,*) "gradcorr5 before eello5"
8562 c                do iii=1,nres
8563 c                  write (iout,'(i5,3f10.5)')
8564 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
8565 c                enddo
8566                 if (wcorr5.gt.0.0d0)
8567      &            ecorr5=ecorr5+eello5(i,jp,i+1,jp1,jj,kk)
8568 c                write (iout,*) "gradcorr5 after eello5"
8569 c                do iii=1,nres
8570 c                  write (iout,'(i5,3f10.5)')
8571 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
8572 c                enddo
8573                   if (energy_dec.and.wcorr5.gt.0.0d0)
8574      1                 write (iout,'(a6,4i5,0pf7.3)')
8575      2                'ecorr5',i,j,i+1,j1,eello5(i,jp,i+1,jp1,jj,kk)
8576 cd                write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
8577 cd                write(2,*)'ijkl',i,jp,i+1,jp1
8578                 if (wcorr6.gt.0.0d0 .and. (jp.ne.i+4 .or. jp1.ne.i+3
8579      &               .or. wturn6.eq.0.0d0))then
8580 cd                  write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
8581                   ecorr6=ecorr6+eello6(i,jp,i+1,jp1,jj,kk)
8582                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
8583      1                'ecorr6',i,j,i+1,j1,eello6(i,jp,i+1,jp1,jj,kk)
8584 cd                write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
8585 cd     &            'ecorr6=',ecorr6
8586 cd                write (iout,'(4e15.5)') sred_geom,
8587 cd     &          dabs(eello4(i,jp,i+1,jp1,jj,kk)),
8588 cd     &          dabs(eello5(i,jp,i+1,jp1,jj,kk)),
8589 cd     &          dabs(eello6(i,jp,i+1,jp1,jj,kk))
8590                 else if (wturn6.gt.0.0d0
8591      &            .and. (jp.eq.i+4 .and. jp1.eq.i+3)) then
8592 cd                  write (iout,*) '******eturn6: i,j,i+1,j1',i,jip,i+1,jp1
8593                   eturn6=eturn6+eello_turn6(i,jj,kk)
8594                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
8595      1                 'eturn6',i,j,i+1,j1,eello_turn6(i,jj,kk)
8596 cd                  write (2,*) 'multibody_eello:eturn6',eturn6
8597                 endif
8598               ENDIF
8599 1111          continue
8600             endif
8601           enddo ! kk
8602         enddo ! jj
8603       enddo ! i
8604       do i=1,nres
8605         num_cont_hb(i)=num_cont_hb_old(i)
8606       enddo
8607 c                write (iout,*) "gradcorr5 in eello5"
8608 c                do iii=1,nres
8609 c                  write (iout,'(i5,3f10.5)')
8610 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
8611 c                enddo
8612       return
8613       end
8614 c------------------------------------------------------------------------------
8615       subroutine add_hb_contact_eello(ii,jj,itask)
8616       implicit real*8 (a-h,o-z)
8617       include "DIMENSIONS"
8618       include "COMMON.IOUNITS"
8619       integer max_cont
8620       integer max_dim
8621       parameter (max_cont=maxconts)
8622       parameter (max_dim=70)
8623       include "COMMON.CONTACTS"
8624       double precision zapas(max_dim,maxconts,max_fg_procs),
8625      &  zapas_recv(max_dim,maxconts,max_fg_procs)
8626       common /przechowalnia/ zapas
8627       integer i,j,ii,jj,iproc,itask(4),nn
8628 c      write (iout,*) "itask",itask
8629       do i=1,2
8630         iproc=itask(i)
8631         if (iproc.gt.0) then
8632           do j=1,num_cont_hb(ii)
8633             jjc=jcont_hb(j,ii)
8634 c            write (iout,*) "send turns i",ii," j",jj," jjc",jjc
8635             if (jjc.eq.jj) then
8636               ncont_sent(iproc)=ncont_sent(iproc)+1
8637               nn=ncont_sent(iproc)
8638               zapas(1,nn,iproc)=ii
8639               zapas(2,nn,iproc)=jjc
8640               zapas(3,nn,iproc)=d_cont(j,ii)
8641               ind=3
8642               do kk=1,3
8643                 ind=ind+1
8644                 zapas(ind,nn,iproc)=grij_hb_cont(kk,j,ii)
8645               enddo
8646               do kk=1,2
8647                 do ll=1,2
8648                   ind=ind+1
8649                   zapas(ind,nn,iproc)=a_chuj(ll,kk,j,ii)
8650                 enddo
8651               enddo
8652               do jj=1,5
8653                 do kk=1,3
8654                   do ll=1,2
8655                     do mm=1,2
8656                       ind=ind+1
8657                       zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,ii)
8658                     enddo
8659                   enddo
8660                 enddo
8661               enddo
8662               exit
8663             endif
8664           enddo
8665         endif
8666       enddo
8667       return
8668       end
8669 c------------------------------------------------------------------------------
8670       double precision function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
8671       implicit real*8 (a-h,o-z)
8672       include 'DIMENSIONS'
8673       include 'COMMON.IOUNITS'
8674       include 'COMMON.DERIV'
8675       include 'COMMON.INTERACT'
8676       include 'COMMON.CONTACTS'
8677       double precision gx(3),gx1(3)
8678       logical lprn
8679       lprn=.false.
8680       eij=facont_hb(jj,i)
8681       ekl=facont_hb(kk,k)
8682       ees0pij=ees0p(jj,i)
8683       ees0pkl=ees0p(kk,k)
8684       ees0mij=ees0m(jj,i)
8685       ees0mkl=ees0m(kk,k)
8686       ekont=eij*ekl
8687       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
8688 cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
8689 C Following 4 lines for diagnostics.
8690 cd    ees0pkl=0.0D0
8691 cd    ees0pij=1.0D0
8692 cd    ees0mkl=0.0D0
8693 cd    ees0mij=1.0D0
8694 c      write (iout,'(2(a,2i3,a,f10.5,a,2f10.5),a,f10.5,a,$)')
8695 c     & 'Contacts ',i,j,
8696 c     & ' eij',eij,' eesij',ees0pij,ees0mij,' and ',k,l
8697 c     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' energy=',ekont*ees,
8698 c     & 'gradcorr_long'
8699 C Calculate the multi-body contribution to energy.
8700 C      ecorr=ecorr+ekont*ees
8701 C Calculate multi-body contributions to the gradient.
8702       coeffpees0pij=coeffp*ees0pij
8703       coeffmees0mij=coeffm*ees0mij
8704       coeffpees0pkl=coeffp*ees0pkl
8705       coeffmees0mkl=coeffm*ees0mkl
8706       do ll=1,3
8707 cgrad        ghalfi=ees*ekl*gacont_hbr(ll,jj,i)
8708         gradcorr(ll,i)=gradcorr(ll,i)!+0.5d0*ghalfi
8709      &  -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+
8710      &  coeffmees0mkl*gacontm_hb1(ll,jj,i))
8711         gradcorr(ll,j)=gradcorr(ll,j)!+0.5d0*ghalfi
8712      &  -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+
8713      &  coeffmees0mkl*gacontm_hb2(ll,jj,i))
8714 cgrad        ghalfk=ees*eij*gacont_hbr(ll,kk,k)
8715         gradcorr(ll,k)=gradcorr(ll,k)!+0.5d0*ghalfk
8716      &  -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+
8717      &  coeffmees0mij*gacontm_hb1(ll,kk,k))
8718         gradcorr(ll,l)=gradcorr(ll,l)!+0.5d0*ghalfk
8719      &  -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+
8720      &  coeffmees0mij*gacontm_hb2(ll,kk,k))
8721         gradlongij=ees*ekl*gacont_hbr(ll,jj,i)-
8722      &     ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+
8723      &     coeffmees0mkl*gacontm_hb3(ll,jj,i))
8724         gradcorr_long(ll,j)=gradcorr_long(ll,j)+gradlongij
8725         gradcorr_long(ll,i)=gradcorr_long(ll,i)-gradlongij
8726         gradlongkl=ees*eij*gacont_hbr(ll,kk,k)-
8727      &     ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+
8728      &     coeffmees0mij*gacontm_hb3(ll,kk,k))
8729         gradcorr_long(ll,l)=gradcorr_long(ll,l)+gradlongkl
8730         gradcorr_long(ll,k)=gradcorr_long(ll,k)-gradlongkl
8731 c        write (iout,'(2f10.5,2x,$)') gradlongij,gradlongkl
8732       enddo
8733 c      write (iout,*)
8734 cgrad      do m=i+1,j-1
8735 cgrad        do ll=1,3
8736 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
8737 cgrad     &     ees*ekl*gacont_hbr(ll,jj,i)-
8738 cgrad     &     ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
8739 cgrad     &     coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
8740 cgrad        enddo
8741 cgrad      enddo
8742 cgrad      do m=k+1,l-1
8743 cgrad        do ll=1,3
8744 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
8745 cgrad     &     ees*eij*gacont_hbr(ll,kk,k)-
8746 cgrad     &     ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
8747 cgrad     &     coeffm*ees0mij*gacontm_hb3(ll,kk,k))
8748 cgrad        enddo
8749 cgrad      enddo
8750 c      write (iout,*) "ehbcorr",ekont*ees
8751       ehbcorr=ekont*ees
8752       return
8753       end
8754 #ifdef MOMENT
8755 C---------------------------------------------------------------------------
8756       subroutine dipole(i,j,jj)
8757       implicit real*8 (a-h,o-z)
8758       include 'DIMENSIONS'
8759       include 'COMMON.IOUNITS'
8760       include 'COMMON.CHAIN'
8761       include 'COMMON.FFIELD'
8762       include 'COMMON.DERIV'
8763       include 'COMMON.INTERACT'
8764       include 'COMMON.CONTACTS'
8765       include 'COMMON.TORSION'
8766       include 'COMMON.VAR'
8767       include 'COMMON.GEO'
8768       dimension dipi(2,2),dipj(2,2),dipderi(2),dipderj(2),auxvec(2),
8769      &  auxmat(2,2)
8770       iti1 = itortyp(itype(i+1))
8771       if (j.lt.nres-1) then
8772         itj1 = itortyp(itype(j+1))
8773       else
8774         itj1=ntortyp
8775       endif
8776       do iii=1,2
8777         dipi(iii,1)=Ub2(iii,i)
8778         dipderi(iii)=Ub2der(iii,i)
8779         dipi(iii,2)=b1(iii,i+1)
8780         dipj(iii,1)=Ub2(iii,j)
8781         dipderj(iii)=Ub2der(iii,j)
8782         dipj(iii,2)=b1(iii,j+1)
8783       enddo
8784       kkk=0
8785       do iii=1,2
8786         call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
8787         do jjj=1,2
8788           kkk=kkk+1
8789           dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
8790         enddo
8791       enddo
8792       do kkk=1,5
8793         do lll=1,3
8794           mmm=0
8795           do iii=1,2
8796             call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),
8797      &        auxvec(1))
8798             do jjj=1,2
8799               mmm=mmm+1
8800               dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
8801             enddo
8802           enddo
8803         enddo
8804       enddo
8805       call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
8806       call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
8807       do iii=1,2
8808         dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
8809       enddo
8810       call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
8811       do iii=1,2
8812         dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
8813       enddo
8814       return
8815       end
8816 #endif
8817 C---------------------------------------------------------------------------
8818       subroutine calc_eello(i,j,k,l,jj,kk)
8819 C
8820 C This subroutine computes matrices and vectors needed to calculate
8821 C the fourth-, fifth-, and sixth-order local-electrostatic terms.
8822 C
8823       implicit real*8 (a-h,o-z)
8824       include 'DIMENSIONS'
8825       include 'COMMON.IOUNITS'
8826       include 'COMMON.CHAIN'
8827       include 'COMMON.DERIV'
8828       include 'COMMON.INTERACT'
8829       include 'COMMON.CONTACTS'
8830       include 'COMMON.TORSION'
8831       include 'COMMON.VAR'
8832       include 'COMMON.GEO'
8833       include 'COMMON.FFIELD'
8834       double precision aa1(2,2),aa2(2,2),aa1t(2,2),aa2t(2,2),
8835      &  aa1tder(2,2,3,5),aa2tder(2,2,3,5),auxmat(2,2)
8836       logical lprn
8837       common /kutas/ lprn
8838 cd      write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
8839 cd     & ' jj=',jj,' kk=',kk
8840 cd      if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
8841 cd      write (iout,*) "a_chujij",((a_chuj(iii,jjj,jj,i),iii=1,2),jjj=1,2)
8842 cd      write (iout,*) "a_chujkl",((a_chuj(iii,jjj,kk,k),iii=1,2),jjj=1,2)
8843       do iii=1,2
8844         do jjj=1,2
8845           aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
8846           aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
8847         enddo
8848       enddo
8849       call transpose2(aa1(1,1),aa1t(1,1))
8850       call transpose2(aa2(1,1),aa2t(1,1))
8851       do kkk=1,5
8852         do lll=1,3
8853           call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),
8854      &      aa1tder(1,1,lll,kkk))
8855           call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),
8856      &      aa2tder(1,1,lll,kkk))
8857         enddo
8858       enddo
8859       if (l.eq.j+1) then
8860 C parallel orientation of the two CA-CA-CA frames.
8861         if (i.gt.1) then
8862           iti=itortyp(itype(i))
8863         else
8864           iti=ntortyp
8865         endif
8866         itk1=itortyp(itype(k+1))
8867         itj=itortyp(itype(j))
8868         if (l.lt.nres-1) then
8869           itl1=itortyp(itype(l+1))
8870         else
8871           itl1=ntortyp
8872         endif
8873 C A1 kernel(j+1) A2T
8874 cd        do iii=1,2
8875 cd          write (iout,'(3f10.5,5x,3f10.5)')
8876 cd     &     (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
8877 cd        enddo
8878         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
8879      &   aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),
8880      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
8881 C Following matrices are needed only for 6-th order cumulants
8882         IF (wcorr6.gt.0.0d0) THEN
8883         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
8884      &   aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),
8885      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
8886         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
8887      &   aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),
8888      &   Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
8889      &   ADtEAderx(1,1,1,1,1,1))
8890         lprn=.false.
8891         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
8892      &   aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),
8893      &   DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
8894      &   ADtEA1derx(1,1,1,1,1,1))
8895         ENDIF
8896 C End 6-th order cumulants
8897 cd        lprn=.false.
8898 cd        if (lprn) then
8899 cd        write (2,*) 'In calc_eello6'
8900 cd        do iii=1,2
8901 cd          write (2,*) 'iii=',iii
8902 cd          do kkk=1,5
8903 cd            write (2,*) 'kkk=',kkk
8904 cd            do jjj=1,2
8905 cd              write (2,'(3(2f10.5),5x)')
8906 cd     &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
8907 cd            enddo
8908 cd          enddo
8909 cd        enddo
8910 cd        endif
8911         call transpose2(EUgder(1,1,k),auxmat(1,1))
8912         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
8913         call transpose2(EUg(1,1,k),auxmat(1,1))
8914         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
8915         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
8916         do iii=1,2
8917           do kkk=1,5
8918             do lll=1,3
8919               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
8920      &          EAEAderx(1,1,lll,kkk,iii,1))
8921             enddo
8922           enddo
8923         enddo
8924 C A1T kernel(i+1) A2
8925         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
8926      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),
8927      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
8928 C Following matrices are needed only for 6-th order cumulants
8929         IF (wcorr6.gt.0.0d0) THEN
8930         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
8931      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),
8932      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
8933         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
8934      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),
8935      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
8936      &   ADtEAderx(1,1,1,1,1,2))
8937         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
8938      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),
8939      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
8940      &   ADtEA1derx(1,1,1,1,1,2))
8941         ENDIF
8942 C End 6-th order cumulants
8943         call transpose2(EUgder(1,1,l),auxmat(1,1))
8944         call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
8945         call transpose2(EUg(1,1,l),auxmat(1,1))
8946         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
8947         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
8948         do iii=1,2
8949           do kkk=1,5
8950             do lll=1,3
8951               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
8952      &          EAEAderx(1,1,lll,kkk,iii,2))
8953             enddo
8954           enddo
8955         enddo
8956 C AEAb1 and AEAb2
8957 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
8958 C They are needed only when the fifth- or the sixth-order cumulants are
8959 C indluded.
8960         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
8961         call transpose2(AEA(1,1,1),auxmat(1,1))
8962         call matvec2(auxmat(1,1),b1(1,i),AEAb1(1,1,1))
8963         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
8964         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
8965         call transpose2(AEAderg(1,1,1),auxmat(1,1))
8966         call matvec2(auxmat(1,1),b1(1,i),AEAb1derg(1,1,1))
8967         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
8968         call matvec2(AEA(1,1,1),b1(1,k+1),AEAb1(1,2,1))
8969         call matvec2(AEAderg(1,1,1),b1(1,k+1),AEAb1derg(1,2,1))
8970         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
8971         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
8972         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
8973         call transpose2(AEA(1,1,2),auxmat(1,1))
8974         call matvec2(auxmat(1,1),b1(1,j),AEAb1(1,1,2))
8975         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
8976         call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
8977         call transpose2(AEAderg(1,1,2),auxmat(1,1))
8978         call matvec2(auxmat(1,1),b1(1,j),AEAb1derg(1,1,2))
8979         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
8980         call matvec2(AEA(1,1,2),b1(1,l+1),AEAb1(1,2,2))
8981         call matvec2(AEAderg(1,1,2),b1(1,l+1),AEAb1derg(1,2,2))
8982         call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
8983         call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
8984         call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
8985 C Calculate the Cartesian derivatives of the vectors.
8986         do iii=1,2
8987           do kkk=1,5
8988             do lll=1,3
8989               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
8990               call matvec2(auxmat(1,1),b1(1,i),
8991      &          AEAb1derx(1,lll,kkk,iii,1,1))
8992               call matvec2(auxmat(1,1),Ub2(1,i),
8993      &          AEAb2derx(1,lll,kkk,iii,1,1))
8994               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
8995      &          AEAb1derx(1,lll,kkk,iii,2,1))
8996               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
8997      &          AEAb2derx(1,lll,kkk,iii,2,1))
8998               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
8999               call matvec2(auxmat(1,1),b1(1,j),
9000      &          AEAb1derx(1,lll,kkk,iii,1,2))
9001               call matvec2(auxmat(1,1),Ub2(1,j),
9002      &          AEAb2derx(1,lll,kkk,iii,1,2))
9003               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,l+1),
9004      &          AEAb1derx(1,lll,kkk,iii,2,2))
9005               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),
9006      &          AEAb2derx(1,lll,kkk,iii,2,2))
9007             enddo
9008           enddo
9009         enddo
9010         ENDIF
9011 C End vectors
9012       else
9013 C Antiparallel orientation of the two CA-CA-CA frames.
9014         if (i.gt.1) then
9015           iti=itortyp(itype(i))
9016         else
9017           iti=ntortyp
9018         endif
9019         itk1=itortyp(itype(k+1))
9020         itl=itortyp(itype(l))
9021         itj=itortyp(itype(j))
9022         if (j.lt.nres-1) then
9023           itj1=itortyp(itype(j+1))
9024         else
9025           itj1=ntortyp
9026         endif
9027 C A2 kernel(j-1)T A1T
9028         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9029      &   aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),
9030      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
9031 C Following matrices are needed only for 6-th order cumulants
9032         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
9033      &     j.eq.i+4 .and. l.eq.i+3)) THEN
9034         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9035      &   aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),
9036      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
9037         call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9038      &   aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),
9039      &   Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
9040      &   ADtEAderx(1,1,1,1,1,1))
9041         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9042      &   aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),
9043      &   DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
9044      &   ADtEA1derx(1,1,1,1,1,1))
9045         ENDIF
9046 C End 6-th order cumulants
9047         call transpose2(EUgder(1,1,k),auxmat(1,1))
9048         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
9049         call transpose2(EUg(1,1,k),auxmat(1,1))
9050         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
9051         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
9052         do iii=1,2
9053           do kkk=1,5
9054             do lll=1,3
9055               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
9056      &          EAEAderx(1,1,lll,kkk,iii,1))
9057             enddo
9058           enddo
9059         enddo
9060 C A2T kernel(i+1)T A1
9061         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
9062      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),
9063      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
9064 C Following matrices are needed only for 6-th order cumulants
9065         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
9066      &     j.eq.i+4 .and. l.eq.i+3)) THEN
9067         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
9068      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),
9069      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
9070         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
9071      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),
9072      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
9073      &   ADtEAderx(1,1,1,1,1,2))
9074         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
9075      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),
9076      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
9077      &   ADtEA1derx(1,1,1,1,1,2))
9078         ENDIF
9079 C End 6-th order cumulants
9080         call transpose2(EUgder(1,1,j),auxmat(1,1))
9081         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
9082         call transpose2(EUg(1,1,j),auxmat(1,1))
9083         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
9084         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
9085         do iii=1,2
9086           do kkk=1,5
9087             do lll=1,3
9088               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
9089      &          EAEAderx(1,1,lll,kkk,iii,2))
9090             enddo
9091           enddo
9092         enddo
9093 C AEAb1 and AEAb2
9094 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
9095 C They are needed only when the fifth- or the sixth-order cumulants are
9096 C indluded.
9097         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or.
9098      &    (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
9099         call transpose2(AEA(1,1,1),auxmat(1,1))
9100         call matvec2(auxmat(1,1),b1(1,i),AEAb1(1,1,1))
9101         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
9102         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
9103         call transpose2(AEAderg(1,1,1),auxmat(1,1))
9104         call matvec2(auxmat(1,1),b1(1,i),AEAb1derg(1,1,1))
9105         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
9106         call matvec2(AEA(1,1,1),b1(1,k+1),AEAb1(1,2,1))
9107         call matvec2(AEAderg(1,1,1),b1(1,k+1),AEAb1derg(1,2,1))
9108         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
9109         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
9110         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
9111         call transpose2(AEA(1,1,2),auxmat(1,1))
9112         call matvec2(auxmat(1,1),b1(1,j+1),AEAb1(1,1,2))
9113         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
9114         call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
9115         call transpose2(AEAderg(1,1,2),auxmat(1,1))
9116         call matvec2(auxmat(1,1),b1(1,l),AEAb1(1,1,2))
9117         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
9118         call matvec2(AEA(1,1,2),b1(1,j+1),AEAb1(1,2,2))
9119         call matvec2(AEAderg(1,1,2),b1(1,j+1),AEAb1derg(1,2,2))
9120         call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
9121         call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
9122         call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
9123 C Calculate the Cartesian derivatives of the vectors.
9124         do iii=1,2
9125           do kkk=1,5
9126             do lll=1,3
9127               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
9128               call matvec2(auxmat(1,1),b1(1,i),
9129      &          AEAb1derx(1,lll,kkk,iii,1,1))
9130               call matvec2(auxmat(1,1),Ub2(1,i),
9131      &          AEAb2derx(1,lll,kkk,iii,1,1))
9132               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
9133      &          AEAb1derx(1,lll,kkk,iii,2,1))
9134               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
9135      &          AEAb2derx(1,lll,kkk,iii,2,1))
9136               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
9137               call matvec2(auxmat(1,1),b1(1,l),
9138      &          AEAb1derx(1,lll,kkk,iii,1,2))
9139               call matvec2(auxmat(1,1),Ub2(1,l),
9140      &          AEAb2derx(1,lll,kkk,iii,1,2))
9141               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,j+1),
9142      &          AEAb1derx(1,lll,kkk,iii,2,2))
9143               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),
9144      &          AEAb2derx(1,lll,kkk,iii,2,2))
9145             enddo
9146           enddo
9147         enddo
9148         ENDIF
9149 C End vectors
9150       endif
9151       return
9152       end
9153 C---------------------------------------------------------------------------
9154       subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,
9155      &  KK,KKderg,AKA,AKAderg,AKAderx)
9156       implicit none
9157       integer nderg
9158       logical transp
9159       double precision aa1(2,2),aa2t(2,2),aa1derx(2,2,3,5),
9160      &  aa2tderx(2,2,3,5),KK(2,2),KKderg(2,2,nderg),AKA(2,2),
9161      &  AKAderg(2,2,nderg),AKAderx(2,2,3,5,2)
9162       integer iii,kkk,lll
9163       integer jjj,mmm
9164       logical lprn
9165       common /kutas/ lprn
9166       call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
9167       do iii=1,nderg
9168         call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,
9169      &    AKAderg(1,1,iii))
9170       enddo
9171 cd      if (lprn) write (2,*) 'In kernel'
9172       do kkk=1,5
9173 cd        if (lprn) write (2,*) 'kkk=',kkk
9174         do lll=1,3
9175           call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),
9176      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
9177 cd          if (lprn) then
9178 cd            write (2,*) 'lll=',lll
9179 cd            write (2,*) 'iii=1'
9180 cd            do jjj=1,2
9181 cd              write (2,'(3(2f10.5),5x)')
9182 cd     &        (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
9183 cd            enddo
9184 cd          endif
9185           call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),
9186      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
9187 cd          if (lprn) then
9188 cd            write (2,*) 'lll=',lll
9189 cd            write (2,*) 'iii=2'
9190 cd            do jjj=1,2
9191 cd              write (2,'(3(2f10.5),5x)')
9192 cd     &        (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
9193 cd            enddo
9194 cd          endif
9195         enddo
9196       enddo
9197       return
9198       end
9199 C---------------------------------------------------------------------------
9200       double precision function eello4(i,j,k,l,jj,kk)
9201       implicit real*8 (a-h,o-z)
9202       include 'DIMENSIONS'
9203       include 'COMMON.IOUNITS'
9204       include 'COMMON.CHAIN'
9205       include 'COMMON.DERIV'
9206       include 'COMMON.INTERACT'
9207       include 'COMMON.CONTACTS'
9208       include 'COMMON.TORSION'
9209       include 'COMMON.VAR'
9210       include 'COMMON.GEO'
9211       double precision pizda(2,2),ggg1(3),ggg2(3)
9212 cd      if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
9213 cd        eello4=0.0d0
9214 cd        return
9215 cd      endif
9216 cd      print *,'eello4:',i,j,k,l,jj,kk
9217 cd      write (2,*) 'i',i,' j',j,' k',k,' l',l
9218 cd      call checkint4(i,j,k,l,jj,kk,eel4_num)
9219 cold      eij=facont_hb(jj,i)
9220 cold      ekl=facont_hb(kk,k)
9221 cold      ekont=eij*ekl
9222       eel4=-EAEA(1,1,1)-EAEA(2,2,1)
9223 cd      eel41=-EAEA(1,1,2)-EAEA(2,2,2)
9224       gcorr_loc(k-1)=gcorr_loc(k-1)
9225      &   -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
9226       if (l.eq.j+1) then
9227         gcorr_loc(l-1)=gcorr_loc(l-1)
9228      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
9229       else
9230         gcorr_loc(j-1)=gcorr_loc(j-1)
9231      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
9232       endif
9233       do iii=1,2
9234         do kkk=1,5
9235           do lll=1,3
9236             derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1)
9237      &                        -EAEAderx(2,2,lll,kkk,iii,1)
9238 cd            derx(lll,kkk,iii)=0.0d0
9239           enddo
9240         enddo
9241       enddo
9242 cd      gcorr_loc(l-1)=0.0d0
9243 cd      gcorr_loc(j-1)=0.0d0
9244 cd      gcorr_loc(k-1)=0.0d0
9245 cd      eel4=1.0d0
9246 cd      write (iout,*)'Contacts have occurred for peptide groups',
9247 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l,
9248 cd     &  ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
9249       if (j.lt.nres-1) then
9250         j1=j+1
9251         j2=j-1
9252       else
9253         j1=j-1
9254         j2=j-2
9255       endif
9256       if (l.lt.nres-1) then
9257         l1=l+1
9258         l2=l-1
9259       else
9260         l1=l-1
9261         l2=l-2
9262       endif
9263       do ll=1,3
9264 cgrad        ggg1(ll)=eel4*g_contij(ll,1)
9265 cgrad        ggg2(ll)=eel4*g_contij(ll,2)
9266         glongij=eel4*g_contij(ll,1)+ekont*derx(ll,1,1)
9267         glongkl=eel4*g_contij(ll,2)+ekont*derx(ll,1,2)
9268 cgrad        ghalf=0.5d0*ggg1(ll)
9269         gradcorr(ll,i)=gradcorr(ll,i)+ekont*derx(ll,2,1)
9270         gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
9271         gradcorr(ll,j)=gradcorr(ll,j)+ekont*derx(ll,4,1)
9272         gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
9273         gradcorr_long(ll,j)=gradcorr_long(ll,j)+glongij
9274         gradcorr_long(ll,i)=gradcorr_long(ll,i)-glongij
9275 cgrad        ghalf=0.5d0*ggg2(ll)
9276         gradcorr(ll,k)=gradcorr(ll,k)+ekont*derx(ll,2,2)
9277         gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
9278         gradcorr(ll,l)=gradcorr(ll,l)+ekont*derx(ll,4,2)
9279         gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
9280         gradcorr_long(ll,l)=gradcorr_long(ll,l)+glongkl
9281         gradcorr_long(ll,k)=gradcorr_long(ll,k)-glongkl
9282       enddo
9283 cgrad      do m=i+1,j-1
9284 cgrad        do ll=1,3
9285 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
9286 cgrad        enddo
9287 cgrad      enddo
9288 cgrad      do m=k+1,l-1
9289 cgrad        do ll=1,3
9290 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
9291 cgrad        enddo
9292 cgrad      enddo
9293 cgrad      do m=i+2,j2
9294 cgrad        do ll=1,3
9295 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
9296 cgrad        enddo
9297 cgrad      enddo
9298 cgrad      do m=k+2,l2
9299 cgrad        do ll=1,3
9300 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
9301 cgrad        enddo
9302 cgrad      enddo
9303 cd      do iii=1,nres-3
9304 cd        write (2,*) iii,gcorr_loc(iii)
9305 cd      enddo
9306       eello4=ekont*eel4
9307 cd      write (2,*) 'ekont',ekont
9308 cd      write (iout,*) 'eello4',ekont*eel4
9309       return
9310       end
9311 C---------------------------------------------------------------------------
9312       double precision function eello5(i,j,k,l,jj,kk)
9313       implicit real*8 (a-h,o-z)
9314       include 'DIMENSIONS'
9315       include 'COMMON.IOUNITS'
9316       include 'COMMON.CHAIN'
9317       include 'COMMON.DERIV'
9318       include 'COMMON.INTERACT'
9319       include 'COMMON.CONTACTS'
9320       include 'COMMON.TORSION'
9321       include 'COMMON.VAR'
9322       include 'COMMON.GEO'
9323       double precision pizda(2,2),auxmat(2,2),auxmat1(2,2),vv(2)
9324       double precision ggg1(3),ggg2(3)
9325 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9326 C                                                                              C
9327 C                            Parallel chains                                   C
9328 C                                                                              C
9329 C          o             o                   o             o                   C
9330 C         /l\           / \             \   / \           / \   /              C
9331 C        /   \         /   \             \ /   \         /   \ /               C
9332 C       j| o |l1       | o |              o| o |         | o |o                C
9333 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
9334 C      \i/   \         /   \ /             /   \         /   \                 C
9335 C       o    k1             o                                                  C
9336 C         (I)          (II)                (III)          (IV)                 C
9337 C                                                                              C
9338 C      eello5_1        eello5_2            eello5_3       eello5_4             C
9339 C                                                                              C
9340 C                            Antiparallel chains                               C
9341 C                                                                              C
9342 C          o             o                   o             o                   C
9343 C         /j\           / \             \   / \           / \   /              C
9344 C        /   \         /   \             \ /   \         /   \ /               C
9345 C      j1| o |l        | o |              o| o |         | o |o                C
9346 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
9347 C      \i/   \         /   \ /             /   \         /   \                 C
9348 C       o     k1            o                                                  C
9349 C         (I)          (II)                (III)          (IV)                 C
9350 C                                                                              C
9351 C      eello5_1        eello5_2            eello5_3       eello5_4             C
9352 C                                                                              C
9353 C o denotes a local interaction, vertical lines an electrostatic interaction.  C
9354 C                                                                              C
9355 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9356 cd      if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
9357 cd        eello5=0.0d0
9358 cd        return
9359 cd      endif
9360 cd      write (iout,*)
9361 cd     &   'EELLO5: Contacts have occurred for peptide groups',i,j,
9362 cd     &   ' and',k,l
9363       itk=itortyp(itype(k))
9364       itl=itortyp(itype(l))
9365       itj=itortyp(itype(j))
9366       eello5_1=0.0d0
9367       eello5_2=0.0d0
9368       eello5_3=0.0d0
9369       eello5_4=0.0d0
9370 cd      call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
9371 cd     &   eel5_3_num,eel5_4_num)
9372       do iii=1,2
9373         do kkk=1,5
9374           do lll=1,3
9375             derx(lll,kkk,iii)=0.0d0
9376           enddo
9377         enddo
9378       enddo
9379 cd      eij=facont_hb(jj,i)
9380 cd      ekl=facont_hb(kk,k)
9381 cd      ekont=eij*ekl
9382 cd      write (iout,*)'Contacts have occurred for peptide groups',
9383 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l
9384 cd      goto 1111
9385 C Contribution from the graph I.
9386 cd      write (2,*) 'AEA  ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
9387 cd      write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
9388       call transpose2(EUg(1,1,k),auxmat(1,1))
9389       call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
9390       vv(1)=pizda(1,1)-pizda(2,2)
9391       vv(2)=pizda(1,2)+pizda(2,1)
9392       eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k))
9393      & +0.5d0*scalar2(vv(1),Dtobr2(1,i))
9394 C Explicit gradient in virtual-dihedral angles.
9395       if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1)
9396      & +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k))
9397      & +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
9398       call transpose2(EUgder(1,1,k),auxmat1(1,1))
9399       call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
9400       vv(1)=pizda(1,1)-pizda(2,2)
9401       vv(2)=pizda(1,2)+pizda(2,1)
9402       g_corr5_loc(k-1)=g_corr5_loc(k-1)
9403      & +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k))
9404      & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
9405       call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
9406       vv(1)=pizda(1,1)-pizda(2,2)
9407       vv(2)=pizda(1,2)+pizda(2,1)
9408       if (l.eq.j+1) then
9409         if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1)
9410      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
9411      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
9412       else
9413         if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1)
9414      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
9415      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
9416       endif
9417 C Cartesian gradient
9418       do iii=1,2
9419         do kkk=1,5
9420           do lll=1,3
9421             call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),
9422      &        pizda(1,1))
9423             vv(1)=pizda(1,1)-pizda(2,2)
9424             vv(2)=pizda(1,2)+pizda(2,1)
9425             derx(lll,kkk,iii)=derx(lll,kkk,iii)
9426      &       +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k))
9427      &       +0.5d0*scalar2(vv(1),Dtobr2(1,i))
9428           enddo
9429         enddo
9430       enddo
9431 c      goto 1112
9432 c1111  continue
9433 C Contribution from graph II
9434       call transpose2(EE(1,1,itk),auxmat(1,1))
9435       call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
9436       vv(1)=pizda(1,1)+pizda(2,2)
9437       vv(2)=pizda(2,1)-pizda(1,2)
9438       eello5_2=scalar2(AEAb1(1,2,1),b1(1,k))
9439      & -0.5d0*scalar2(vv(1),Ctobr(1,k))
9440 C Explicit gradient in virtual-dihedral angles.
9441       g_corr5_loc(k-1)=g_corr5_loc(k-1)
9442      & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
9443       call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
9444       vv(1)=pizda(1,1)+pizda(2,2)
9445       vv(2)=pizda(2,1)-pizda(1,2)
9446       if (l.eq.j+1) then
9447         g_corr5_loc(l-1)=g_corr5_loc(l-1)
9448      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,k))
9449      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
9450       else
9451         g_corr5_loc(j-1)=g_corr5_loc(j-1)
9452      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,k))
9453      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
9454       endif
9455 C Cartesian gradient
9456       do iii=1,2
9457         do kkk=1,5
9458           do lll=1,3
9459             call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
9460      &        pizda(1,1))
9461             vv(1)=pizda(1,1)+pizda(2,2)
9462             vv(2)=pizda(2,1)-pizda(1,2)
9463             derx(lll,kkk,iii)=derx(lll,kkk,iii)
9464      &       +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,k))
9465      &       -0.5d0*scalar2(vv(1),Ctobr(1,k))
9466           enddo
9467         enddo
9468       enddo
9469 cd      goto 1112
9470 cd1111  continue
9471       if (l.eq.j+1) then
9472 cd        goto 1110
9473 C Parallel orientation
9474 C Contribution from graph III
9475         call transpose2(EUg(1,1,l),auxmat(1,1))
9476         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
9477         vv(1)=pizda(1,1)-pizda(2,2)
9478         vv(2)=pizda(1,2)+pizda(2,1)
9479         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l))
9480      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j))
9481 C Explicit gradient in virtual-dihedral angles.
9482         g_corr5_loc(j-1)=g_corr5_loc(j-1)
9483      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l))
9484      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
9485         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
9486         vv(1)=pizda(1,1)-pizda(2,2)
9487         vv(2)=pizda(1,2)+pizda(2,1)
9488         g_corr5_loc(k-1)=g_corr5_loc(k-1)
9489      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l))
9490      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
9491         call transpose2(EUgder(1,1,l),auxmat1(1,1))
9492         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
9493         vv(1)=pizda(1,1)-pizda(2,2)
9494         vv(2)=pizda(1,2)+pizda(2,1)
9495         g_corr5_loc(l-1)=g_corr5_loc(l-1)
9496      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l))
9497      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
9498 C Cartesian gradient
9499         do iii=1,2
9500           do kkk=1,5
9501             do lll=1,3
9502               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
9503      &          pizda(1,1))
9504               vv(1)=pizda(1,1)-pizda(2,2)
9505               vv(2)=pizda(1,2)+pizda(2,1)
9506               derx(lll,kkk,iii)=derx(lll,kkk,iii)
9507      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l))
9508      &         +0.5d0*scalar2(vv(1),Dtobr2(1,j))
9509             enddo
9510           enddo
9511         enddo
9512 cd        goto 1112
9513 C Contribution from graph IV
9514 cd1110    continue
9515         call transpose2(EE(1,1,itl),auxmat(1,1))
9516         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
9517         vv(1)=pizda(1,1)+pizda(2,2)
9518         vv(2)=pizda(2,1)-pizda(1,2)
9519         eello5_4=scalar2(AEAb1(1,2,2),b1(1,l))
9520      &   -0.5d0*scalar2(vv(1),Ctobr(1,l))
9521 C Explicit gradient in virtual-dihedral angles.
9522         g_corr5_loc(l-1)=g_corr5_loc(l-1)
9523      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
9524         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
9525         vv(1)=pizda(1,1)+pizda(2,2)
9526         vv(2)=pizda(2,1)-pizda(1,2)
9527         g_corr5_loc(k-1)=g_corr5_loc(k-1)
9528      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,l))
9529      &   -0.5d0*scalar2(vv(1),Ctobr(1,l)))
9530 C Cartesian gradient
9531         do iii=1,2
9532           do kkk=1,5
9533             do lll=1,3
9534               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
9535      &          pizda(1,1))
9536               vv(1)=pizda(1,1)+pizda(2,2)
9537               vv(2)=pizda(2,1)-pizda(1,2)
9538               derx(lll,kkk,iii)=derx(lll,kkk,iii)
9539      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,l))
9540      &         -0.5d0*scalar2(vv(1),Ctobr(1,l))
9541             enddo
9542           enddo
9543         enddo
9544       else
9545 C Antiparallel orientation
9546 C Contribution from graph III
9547 c        goto 1110
9548         call transpose2(EUg(1,1,j),auxmat(1,1))
9549         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
9550         vv(1)=pizda(1,1)-pizda(2,2)
9551         vv(2)=pizda(1,2)+pizda(2,1)
9552         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j))
9553      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l))
9554 C Explicit gradient in virtual-dihedral angles.
9555         g_corr5_loc(l-1)=g_corr5_loc(l-1)
9556      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j))
9557      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
9558         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
9559         vv(1)=pizda(1,1)-pizda(2,2)
9560         vv(2)=pizda(1,2)+pizda(2,1)
9561         g_corr5_loc(k-1)=g_corr5_loc(k-1)
9562      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j))
9563      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
9564         call transpose2(EUgder(1,1,j),auxmat1(1,1))
9565         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
9566         vv(1)=pizda(1,1)-pizda(2,2)
9567         vv(2)=pizda(1,2)+pizda(2,1)
9568         g_corr5_loc(j-1)=g_corr5_loc(j-1)
9569      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j))
9570      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
9571 C Cartesian gradient
9572         do iii=1,2
9573           do kkk=1,5
9574             do lll=1,3
9575               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
9576      &          pizda(1,1))
9577               vv(1)=pizda(1,1)-pizda(2,2)
9578               vv(2)=pizda(1,2)+pizda(2,1)
9579               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
9580      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j))
9581      &         +0.5d0*scalar2(vv(1),Dtobr2(1,l))
9582             enddo
9583           enddo
9584         enddo
9585 cd        goto 1112
9586 C Contribution from graph IV
9587 1110    continue
9588         call transpose2(EE(1,1,itj),auxmat(1,1))
9589         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
9590         vv(1)=pizda(1,1)+pizda(2,2)
9591         vv(2)=pizda(2,1)-pizda(1,2)
9592         eello5_4=scalar2(AEAb1(1,2,2),b1(1,j))
9593      &   -0.5d0*scalar2(vv(1),Ctobr(1,j))
9594 C Explicit gradient in virtual-dihedral angles.
9595         g_corr5_loc(j-1)=g_corr5_loc(j-1)
9596      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
9597         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
9598         vv(1)=pizda(1,1)+pizda(2,2)
9599         vv(2)=pizda(2,1)-pizda(1,2)
9600         g_corr5_loc(k-1)=g_corr5_loc(k-1)
9601      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,j))
9602      &   -0.5d0*scalar2(vv(1),Ctobr(1,j)))
9603 C Cartesian gradient
9604         do iii=1,2
9605           do kkk=1,5
9606             do lll=1,3
9607               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
9608      &          pizda(1,1))
9609               vv(1)=pizda(1,1)+pizda(2,2)
9610               vv(2)=pizda(2,1)-pizda(1,2)
9611               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
9612      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,j))
9613      &         -0.5d0*scalar2(vv(1),Ctobr(1,j))
9614             enddo
9615           enddo
9616         enddo
9617       endif
9618 1112  continue
9619       eel5=eello5_1+eello5_2+eello5_3+eello5_4
9620 cd      if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
9621 cd        write (2,*) 'ijkl',i,j,k,l
9622 cd        write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
9623 cd     &     ' eello5_3',eello5_3,' eello5_4',eello5_4
9624 cd      endif
9625 cd      write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
9626 cd      write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
9627 cd      write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
9628 cd      write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
9629       if (j.lt.nres-1) then
9630         j1=j+1
9631         j2=j-1
9632       else
9633         j1=j-1
9634         j2=j-2
9635       endif
9636       if (l.lt.nres-1) then
9637         l1=l+1
9638         l2=l-1
9639       else
9640         l1=l-1
9641         l2=l-2
9642       endif
9643 cd      eij=1.0d0
9644 cd      ekl=1.0d0
9645 cd      ekont=1.0d0
9646 cd      write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
9647 C 2/11/08 AL Gradients over DC's connecting interacting sites will be
9648 C        summed up outside the subrouine as for the other subroutines
9649 C        handling long-range interactions. The old code is commented out
9650 C        with "cgrad" to keep track of changes.
9651       do ll=1,3
9652 cgrad        ggg1(ll)=eel5*g_contij(ll,1)
9653 cgrad        ggg2(ll)=eel5*g_contij(ll,2)
9654         gradcorr5ij=eel5*g_contij(ll,1)+ekont*derx(ll,1,1)
9655         gradcorr5kl=eel5*g_contij(ll,2)+ekont*derx(ll,1,2)
9656 c        write (iout,'(a,3i3,a,5f8.3,2i3,a,5f8.3,a,f8.3)')
9657 c     &   "ecorr5",ll,i,j," derx",derx(ll,2,1),derx(ll,3,1),derx(ll,4,1),
9658 c     &   derx(ll,5,1),k,l," derx",derx(ll,2,2),derx(ll,3,2),
9659 c     &   derx(ll,4,2),derx(ll,5,2)," ekont",ekont
9660 c        write (iout,'(a,3i3,a,3f8.3,2i3,a,3f8.3)')
9661 c     &   "ecorr5",ll,i,j," gradcorr5",g_contij(ll,1),derx(ll,1,1),
9662 c     &   gradcorr5ij,
9663 c     &   k,l," gradcorr5",g_contij(ll,2),derx(ll,1,2),gradcorr5kl
9664 cold        ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
9665 cgrad        ghalf=0.5d0*ggg1(ll)
9666 cd        ghalf=0.0d0
9667         gradcorr5(ll,i)=gradcorr5(ll,i)+ekont*derx(ll,2,1)
9668         gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
9669         gradcorr5(ll,j)=gradcorr5(ll,j)+ekont*derx(ll,4,1)
9670         gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
9671         gradcorr5_long(ll,j)=gradcorr5_long(ll,j)+gradcorr5ij
9672         gradcorr5_long(ll,i)=gradcorr5_long(ll,i)-gradcorr5ij
9673 cold        ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
9674 cgrad        ghalf=0.5d0*ggg2(ll)
9675 cd        ghalf=0.0d0
9676         gradcorr5(ll,k)=gradcorr5(ll,k)+ghalf+ekont*derx(ll,2,2)
9677         gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
9678         gradcorr5(ll,l)=gradcorr5(ll,l)+ghalf+ekont*derx(ll,4,2)
9679         gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
9680         gradcorr5_long(ll,l)=gradcorr5_long(ll,l)+gradcorr5kl
9681         gradcorr5_long(ll,k)=gradcorr5_long(ll,k)-gradcorr5kl
9682       enddo
9683 cd      goto 1112
9684 cgrad      do m=i+1,j-1
9685 cgrad        do ll=1,3
9686 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
9687 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
9688 cgrad        enddo
9689 cgrad      enddo
9690 cgrad      do m=k+1,l-1
9691 cgrad        do ll=1,3
9692 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
9693 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
9694 cgrad        enddo
9695 cgrad      enddo
9696 c1112  continue
9697 cgrad      do m=i+2,j2
9698 cgrad        do ll=1,3
9699 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
9700 cgrad        enddo
9701 cgrad      enddo
9702 cgrad      do m=k+2,l2
9703 cgrad        do ll=1,3
9704 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
9705 cgrad        enddo
9706 cgrad      enddo
9707 cd      do iii=1,nres-3
9708 cd        write (2,*) iii,g_corr5_loc(iii)
9709 cd      enddo
9710       eello5=ekont*eel5
9711 cd      write (2,*) 'ekont',ekont
9712 cd      write (iout,*) 'eello5',ekont*eel5
9713       return
9714       end
9715 c--------------------------------------------------------------------------
9716       double precision function eello6(i,j,k,l,jj,kk)
9717       implicit real*8 (a-h,o-z)
9718       include 'DIMENSIONS'
9719       include 'COMMON.IOUNITS'
9720       include 'COMMON.CHAIN'
9721       include 'COMMON.DERIV'
9722       include 'COMMON.INTERACT'
9723       include 'COMMON.CONTACTS'
9724       include 'COMMON.TORSION'
9725       include 'COMMON.VAR'
9726       include 'COMMON.GEO'
9727       include 'COMMON.FFIELD'
9728       double precision ggg1(3),ggg2(3)
9729 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
9730 cd        eello6=0.0d0
9731 cd        return
9732 cd      endif
9733 cd      write (iout,*)
9734 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
9735 cd     &   ' and',k,l
9736       eello6_1=0.0d0
9737       eello6_2=0.0d0
9738       eello6_3=0.0d0
9739       eello6_4=0.0d0
9740       eello6_5=0.0d0
9741       eello6_6=0.0d0
9742 cd      call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
9743 cd     &   eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
9744       do iii=1,2
9745         do kkk=1,5
9746           do lll=1,3
9747             derx(lll,kkk,iii)=0.0d0
9748           enddo
9749         enddo
9750       enddo
9751 cd      eij=facont_hb(jj,i)
9752 cd      ekl=facont_hb(kk,k)
9753 cd      ekont=eij*ekl
9754 cd      eij=1.0d0
9755 cd      ekl=1.0d0
9756 cd      ekont=1.0d0
9757       if (l.eq.j+1) then
9758         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
9759         eello6_2=eello6_graph1(j,i,l,k,2,.false.)
9760         eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
9761         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
9762         eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
9763         eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
9764       else
9765         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
9766         eello6_2=eello6_graph1(l,k,j,i,2,.true.)
9767         eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
9768         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
9769         if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
9770           eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
9771         else
9772           eello6_5=0.0d0
9773         endif
9774         eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
9775       endif
9776 C If turn contributions are considered, they will be handled separately.
9777       eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
9778 cd      write(iout,*) 'eello6_1',eello6_1!,' eel6_1_num',16*eel6_1_num
9779 cd      write(iout,*) 'eello6_2',eello6_2!,' eel6_2_num',16*eel6_2_num
9780 cd      write(iout,*) 'eello6_3',eello6_3!,' eel6_3_num',16*eel6_3_num
9781 cd      write(iout,*) 'eello6_4',eello6_4!,' eel6_4_num',16*eel6_4_num
9782 cd      write(iout,*) 'eello6_5',eello6_5!,' eel6_5_num',16*eel6_5_num
9783 cd      write(iout,*) 'eello6_6',eello6_6!,' eel6_6_num',16*eel6_6_num
9784 cd      goto 1112
9785       if (j.lt.nres-1) then
9786         j1=j+1
9787         j2=j-1
9788       else
9789         j1=j-1
9790         j2=j-2
9791       endif
9792       if (l.lt.nres-1) then
9793         l1=l+1
9794         l2=l-1
9795       else
9796         l1=l-1
9797         l2=l-2
9798       endif
9799       do ll=1,3
9800 cgrad        ggg1(ll)=eel6*g_contij(ll,1)
9801 cgrad        ggg2(ll)=eel6*g_contij(ll,2)
9802 cold        ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
9803 cgrad        ghalf=0.5d0*ggg1(ll)
9804 cd        ghalf=0.0d0
9805         gradcorr6ij=eel6*g_contij(ll,1)+ekont*derx(ll,1,1)
9806         gradcorr6kl=eel6*g_contij(ll,2)+ekont*derx(ll,1,2)
9807         gradcorr6(ll,i)=gradcorr6(ll,i)+ekont*derx(ll,2,1)
9808         gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
9809         gradcorr6(ll,j)=gradcorr6(ll,j)+ekont*derx(ll,4,1)
9810         gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
9811         gradcorr6_long(ll,j)=gradcorr6_long(ll,j)+gradcorr6ij
9812         gradcorr6_long(ll,i)=gradcorr6_long(ll,i)-gradcorr6ij
9813 cgrad        ghalf=0.5d0*ggg2(ll)
9814 cold        ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
9815 cd        ghalf=0.0d0
9816         gradcorr6(ll,k)=gradcorr6(ll,k)+ekont*derx(ll,2,2)
9817         gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
9818         gradcorr6(ll,l)=gradcorr6(ll,l)+ekont*derx(ll,4,2)
9819         gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
9820         gradcorr6_long(ll,l)=gradcorr6_long(ll,l)+gradcorr6kl
9821         gradcorr6_long(ll,k)=gradcorr6_long(ll,k)-gradcorr6kl
9822       enddo
9823 cd      goto 1112
9824 cgrad      do m=i+1,j-1
9825 cgrad        do ll=1,3
9826 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
9827 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
9828 cgrad        enddo
9829 cgrad      enddo
9830 cgrad      do m=k+1,l-1
9831 cgrad        do ll=1,3
9832 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
9833 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
9834 cgrad        enddo
9835 cgrad      enddo
9836 cgrad1112  continue
9837 cgrad      do m=i+2,j2
9838 cgrad        do ll=1,3
9839 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
9840 cgrad        enddo
9841 cgrad      enddo
9842 cgrad      do m=k+2,l2
9843 cgrad        do ll=1,3
9844 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
9845 cgrad        enddo
9846 cgrad      enddo
9847 cd      do iii=1,nres-3
9848 cd        write (2,*) iii,g_corr6_loc(iii)
9849 cd      enddo
9850       eello6=ekont*eel6
9851 cd      write (2,*) 'ekont',ekont
9852 cd      write (iout,*) 'eello6',ekont*eel6
9853       return
9854       end
9855 c--------------------------------------------------------------------------
9856       double precision function eello6_graph1(i,j,k,l,imat,swap)
9857       implicit real*8 (a-h,o-z)
9858       include 'DIMENSIONS'
9859       include 'COMMON.IOUNITS'
9860       include 'COMMON.CHAIN'
9861       include 'COMMON.DERIV'
9862       include 'COMMON.INTERACT'
9863       include 'COMMON.CONTACTS'
9864       include 'COMMON.TORSION'
9865       include 'COMMON.VAR'
9866       include 'COMMON.GEO'
9867       double precision vv(2),vv1(2),pizda(2,2),auxmat(2,2),pizda1(2,2)
9868       logical swap
9869       logical lprn
9870       common /kutas/ lprn
9871 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9872 C                                                                              C
9873 C      Parallel       Antiparallel                                             C
9874 C                                                                              C
9875 C          o             o                                                     C
9876 C         /l\           /j\                                                    C
9877 C        /   \         /   \                                                   C
9878 C       /| o |         | o |\                                                  C
9879 C     \ j|/k\|  /   \  |/k\|l /                                                C
9880 C      \ /   \ /     \ /   \ /                                                 C
9881 C       o     o       o     o                                                  C
9882 C       i             i                                                        C
9883 C                                                                              C
9884 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9885       itk=itortyp(itype(k))
9886       s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
9887       s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
9888       s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
9889       call transpose2(EUgC(1,1,k),auxmat(1,1))
9890       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
9891       vv1(1)=pizda1(1,1)-pizda1(2,2)
9892       vv1(2)=pizda1(1,2)+pizda1(2,1)
9893       s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
9894       vv(1)=AEAb1(1,2,imat)*b1(1,k)-AEAb1(2,2,imat)*b1(2,k)
9895       vv(2)=AEAb1(1,2,imat)*b1(2,k)+AEAb1(2,2,imat)*b1(1,k)
9896       s5=scalar2(vv(1),Dtobr2(1,i))
9897 cd      write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
9898       eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
9899       if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1)
9900      & -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i))
9901      & -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k))
9902      & +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k))
9903      & +0.5d0*scalar2(vv1(1),Dtobr2der(1,i))
9904      & +scalar2(vv(1),Dtobr2der(1,i)))
9905       call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
9906       vv1(1)=pizda1(1,1)-pizda1(2,2)
9907       vv1(2)=pizda1(1,2)+pizda1(2,1)
9908       vv(1)=AEAb1derg(1,2,imat)*b1(1,k)-AEAb1derg(2,2,imat)*b1(2,k)
9909       vv(2)=AEAb1derg(1,2,imat)*b1(2,k)+AEAb1derg(2,2,imat)*b1(1,k)
9910       if (l.eq.j+1) then
9911         g_corr6_loc(l-1)=g_corr6_loc(l-1)
9912      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
9913      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
9914      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
9915      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
9916       else
9917         g_corr6_loc(j-1)=g_corr6_loc(j-1)
9918      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
9919      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
9920      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
9921      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
9922       endif
9923       call transpose2(EUgCder(1,1,k),auxmat(1,1))
9924       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
9925       vv1(1)=pizda1(1,1)-pizda1(2,2)
9926       vv1(2)=pizda1(1,2)+pizda1(2,1)
9927       if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1)
9928      & +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k))
9929      & +scalar2(AEAb2(1,1,imat),CUgb2der(1,k))
9930      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
9931       do iii=1,2
9932         if (swap) then
9933           ind=3-iii
9934         else
9935           ind=iii
9936         endif
9937         do kkk=1,5
9938           do lll=1,3
9939             s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
9940             s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
9941             s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
9942             call transpose2(EUgC(1,1,k),auxmat(1,1))
9943             call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
9944      &        pizda1(1,1))
9945             vv1(1)=pizda1(1,1)-pizda1(2,2)
9946             vv1(2)=pizda1(1,2)+pizda1(2,1)
9947             s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
9948             vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,k)
9949      &       -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,k)
9950             vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,k)
9951      &       +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,k)
9952             s5=scalar2(vv(1),Dtobr2(1,i))
9953             derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
9954           enddo
9955         enddo
9956       enddo
9957       return
9958       end
9959 c----------------------------------------------------------------------------
9960       double precision function eello6_graph2(i,j,k,l,jj,kk,swap)
9961       implicit real*8 (a-h,o-z)
9962       include 'DIMENSIONS'
9963       include 'COMMON.IOUNITS'
9964       include 'COMMON.CHAIN'
9965       include 'COMMON.DERIV'
9966       include 'COMMON.INTERACT'
9967       include 'COMMON.CONTACTS'
9968       include 'COMMON.TORSION'
9969       include 'COMMON.VAR'
9970       include 'COMMON.GEO'
9971       logical swap
9972       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
9973      & auxvec1(2),auxvec2(2),auxmat1(2,2)
9974       logical lprn
9975       common /kutas/ lprn
9976 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9977 C                                                                              C
9978 C      Parallel       Antiparallel                                             C
9979 C                                                                              C
9980 C          o             o                                                     C
9981 C     \   /l\           /j\   /                                                C
9982 C      \ /   \         /   \ /                                                 C
9983 C       o| o |         | o |o                                                  C
9984 C     \ j|/k\|      \  |/k\|l                                                  C
9985 C      \ /   \       \ /   \                                                   C
9986 C       o             o                                                        C
9987 C       i             i                                                        C
9988 C                                                                              C
9989 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9990 cd      write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
9991 C AL 7/4/01 s1 would occur in the sixth-order moment,
9992 C           but not in a cluster cumulant
9993 #ifdef MOMENT
9994       s1=dip(1,jj,i)*dip(1,kk,k)
9995 #endif
9996       call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
9997       s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
9998       call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
9999       s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
10000       call transpose2(EUg(1,1,k),auxmat(1,1))
10001       call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
10002       vv(1)=pizda(1,1)-pizda(2,2)
10003       vv(2)=pizda(1,2)+pizda(2,1)
10004       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
10005 cd      write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
10006 #ifdef MOMENT
10007       eello6_graph2=-(s1+s2+s3+s4)
10008 #else
10009       eello6_graph2=-(s2+s3+s4)
10010 #endif
10011 c      eello6_graph2=-s3
10012 C Derivatives in gamma(i-1)
10013       if (i.gt.1) then
10014 #ifdef MOMENT
10015         s1=dipderg(1,jj,i)*dip(1,kk,k)
10016 #endif
10017         s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
10018         call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
10019         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
10020         s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
10021 #ifdef MOMENT
10022         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
10023 #else
10024         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
10025 #endif
10026 c        g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
10027       endif
10028 C Derivatives in gamma(k-1)
10029 #ifdef MOMENT
10030       s1=dip(1,jj,i)*dipderg(1,kk,k)
10031 #endif
10032       call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
10033       s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
10034       call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
10035       s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
10036       call transpose2(EUgder(1,1,k),auxmat1(1,1))
10037       call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
10038       vv(1)=pizda(1,1)-pizda(2,2)
10039       vv(2)=pizda(1,2)+pizda(2,1)
10040       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
10041 #ifdef MOMENT
10042       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
10043 #else
10044       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
10045 #endif
10046 c      g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
10047 C Derivatives in gamma(j-1) or gamma(l-1)
10048       if (j.gt.1) then
10049 #ifdef MOMENT
10050         s1=dipderg(3,jj,i)*dip(1,kk,k)
10051 #endif
10052         call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
10053         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
10054         s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
10055         call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
10056         vv(1)=pizda(1,1)-pizda(2,2)
10057         vv(2)=pizda(1,2)+pizda(2,1)
10058         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
10059 #ifdef MOMENT
10060         if (swap) then
10061           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
10062         else
10063           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
10064         endif
10065 #endif
10066         g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
10067 c        g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
10068       endif
10069 C Derivatives in gamma(l-1) or gamma(j-1)
10070       if (l.gt.1) then
10071 #ifdef MOMENT
10072         s1=dip(1,jj,i)*dipderg(3,kk,k)
10073 #endif
10074         call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
10075         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
10076         call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
10077         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
10078         call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
10079         vv(1)=pizda(1,1)-pizda(2,2)
10080         vv(2)=pizda(1,2)+pizda(2,1)
10081         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
10082 #ifdef MOMENT
10083         if (swap) then
10084           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
10085         else
10086           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
10087         endif
10088 #endif
10089         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
10090 c        g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
10091       endif
10092 C Cartesian derivatives.
10093       if (lprn) then
10094         write (2,*) 'In eello6_graph2'
10095         do iii=1,2
10096           write (2,*) 'iii=',iii
10097           do kkk=1,5
10098             write (2,*) 'kkk=',kkk
10099             do jjj=1,2
10100               write (2,'(3(2f10.5),5x)')
10101      &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
10102             enddo
10103           enddo
10104         enddo
10105       endif
10106       do iii=1,2
10107         do kkk=1,5
10108           do lll=1,3
10109 #ifdef MOMENT
10110             if (iii.eq.1) then
10111               s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
10112             else
10113               s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
10114             endif
10115 #endif
10116             call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),
10117      &        auxvec(1))
10118             s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
10119             call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),
10120      &        auxvec(1))
10121             s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
10122             call transpose2(EUg(1,1,k),auxmat(1,1))
10123             call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),
10124      &        pizda(1,1))
10125             vv(1)=pizda(1,1)-pizda(2,2)
10126             vv(2)=pizda(1,2)+pizda(2,1)
10127             s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
10128 cd            write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
10129 #ifdef MOMENT
10130             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
10131 #else
10132             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
10133 #endif
10134             if (swap) then
10135               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
10136             else
10137               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
10138             endif
10139           enddo
10140         enddo
10141       enddo
10142       return
10143       end
10144 c----------------------------------------------------------------------------
10145       double precision function eello6_graph3(i,j,k,l,jj,kk,swap)
10146       implicit real*8 (a-h,o-z)
10147       include 'DIMENSIONS'
10148       include 'COMMON.IOUNITS'
10149       include 'COMMON.CHAIN'
10150       include 'COMMON.DERIV'
10151       include 'COMMON.INTERACT'
10152       include 'COMMON.CONTACTS'
10153       include 'COMMON.TORSION'
10154       include 'COMMON.VAR'
10155       include 'COMMON.GEO'
10156       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2)
10157       logical swap
10158 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10159 C                                                                              C
10160 C      Parallel       Antiparallel                                             C
10161 C                                                                              C
10162 C          o             o                                                     C
10163 C         /l\   /   \   /j\                                                    C
10164 C        /   \ /     \ /   \                                                   C
10165 C       /| o |o       o| o |\                                                  C
10166 C       j|/k\|  /      |/k\|l /                                                C
10167 C        /   \ /       /   \ /                                                 C
10168 C       /     o       /     o                                                  C
10169 C       i             i                                                        C
10170 C                                                                              C
10171 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10172 C
10173 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
10174 C           energy moment and not to the cluster cumulant.
10175       iti=itortyp(itype(i))
10176       if (j.lt.nres-1) then
10177         itj1=itortyp(itype(j+1))
10178       else
10179         itj1=ntortyp
10180       endif
10181       itk=itortyp(itype(k))
10182       itk1=itortyp(itype(k+1))
10183       if (l.lt.nres-1) then
10184         itl1=itortyp(itype(l+1))
10185       else
10186         itl1=ntortyp
10187       endif
10188 #ifdef MOMENT
10189       s1=dip(4,jj,i)*dip(4,kk,k)
10190 #endif
10191       call matvec2(AECA(1,1,1),b1(1,k+1),auxvec(1))
10192       s2=0.5d0*scalar2(b1(1,k),auxvec(1))
10193       call matvec2(AECA(1,1,2),b1(1,l+1),auxvec(1))
10194       s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
10195       call transpose2(EE(1,1,itk),auxmat(1,1))
10196       call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
10197       vv(1)=pizda(1,1)+pizda(2,2)
10198       vv(2)=pizda(2,1)-pizda(1,2)
10199       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
10200 cd      write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4,
10201 cd     & "sum",-(s2+s3+s4)
10202 #ifdef MOMENT
10203       eello6_graph3=-(s1+s2+s3+s4)
10204 #else
10205       eello6_graph3=-(s2+s3+s4)
10206 #endif
10207 c      eello6_graph3=-s4
10208 C Derivatives in gamma(k-1)
10209       call matvec2(AECAderg(1,1,2),b1(1,l+1),auxvec(1))
10210       s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
10211       s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
10212       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
10213 C Derivatives in gamma(l-1)
10214       call matvec2(AECAderg(1,1,1),b1(1,k+1),auxvec(1))
10215       s2=0.5d0*scalar2(b1(1,k),auxvec(1))
10216       call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
10217       vv(1)=pizda(1,1)+pizda(2,2)
10218       vv(2)=pizda(2,1)-pizda(1,2)
10219       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
10220       g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
10221 C Cartesian derivatives.
10222       do iii=1,2
10223         do kkk=1,5
10224           do lll=1,3
10225 #ifdef MOMENT
10226             if (iii.eq.1) then
10227               s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
10228             else
10229               s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
10230             endif
10231 #endif
10232             call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
10233      &        auxvec(1))
10234             s2=0.5d0*scalar2(b1(1,k),auxvec(1))
10235             call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,l+1),
10236      &        auxvec(1))
10237             s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
10238             call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),
10239      &        pizda(1,1))
10240             vv(1)=pizda(1,1)+pizda(2,2)
10241             vv(2)=pizda(2,1)-pizda(1,2)
10242             s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
10243 #ifdef MOMENT
10244             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
10245 #else
10246             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
10247 #endif
10248             if (swap) then
10249               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
10250             else
10251               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
10252             endif
10253 c            derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
10254           enddo
10255         enddo
10256       enddo
10257       return
10258       end
10259 c----------------------------------------------------------------------------
10260       double precision function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
10261       implicit real*8 (a-h,o-z)
10262       include 'DIMENSIONS'
10263       include 'COMMON.IOUNITS'
10264       include 'COMMON.CHAIN'
10265       include 'COMMON.DERIV'
10266       include 'COMMON.INTERACT'
10267       include 'COMMON.CONTACTS'
10268       include 'COMMON.TORSION'
10269       include 'COMMON.VAR'
10270       include 'COMMON.GEO'
10271       include 'COMMON.FFIELD'
10272       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
10273      & auxvec1(2),auxmat1(2,2)
10274       logical swap
10275 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10276 C                                                                              C
10277 C      Parallel       Antiparallel                                             C
10278 C                                                                              C
10279 C          o             o                                                     C
10280 C         /l\   /   \   /j\                                                    C
10281 C        /   \ /     \ /   \                                                   C
10282 C       /| o |o       o| o |\                                                  C
10283 C     \ j|/k\|      \  |/k\|l                                                  C
10284 C      \ /   \       \ /   \                                                   C
10285 C       o     \       o     \                                                  C
10286 C       i             i                                                        C
10287 C                                                                              C
10288 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10289 C
10290 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
10291 C           energy moment and not to the cluster cumulant.
10292 cd      write (2,*) 'eello_graph4: wturn6',wturn6
10293       iti=itortyp(itype(i))
10294       itj=itortyp(itype(j))
10295       if (j.lt.nres-1) then
10296         itj1=itortyp(itype(j+1))
10297       else
10298         itj1=ntortyp
10299       endif
10300       itk=itortyp(itype(k))
10301       if (k.lt.nres-1) then
10302         itk1=itortyp(itype(k+1))
10303       else
10304         itk1=ntortyp
10305       endif
10306       itl=itortyp(itype(l))
10307       if (l.lt.nres-1) then
10308         itl1=itortyp(itype(l+1))
10309       else
10310         itl1=ntortyp
10311       endif
10312 cd      write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
10313 cd      write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
10314 cd     & ' itl',itl,' itl1',itl1
10315 #ifdef MOMENT
10316       if (imat.eq.1) then
10317         s1=dip(3,jj,i)*dip(3,kk,k)
10318       else
10319         s1=dip(2,jj,j)*dip(2,kk,l)
10320       endif
10321 #endif
10322       call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
10323       s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
10324       if (j.eq.l+1) then
10325         call matvec2(ADtEA1(1,1,3-imat),b1(1,j+1),auxvec1(1))
10326         s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
10327       else
10328         call matvec2(ADtEA1(1,1,3-imat),b1(1,l+1),auxvec1(1))
10329         s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
10330       endif
10331       call transpose2(EUg(1,1,k),auxmat(1,1))
10332       call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
10333       vv(1)=pizda(1,1)-pizda(2,2)
10334       vv(2)=pizda(2,1)+pizda(1,2)
10335       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
10336 cd      write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
10337 #ifdef MOMENT
10338       eello6_graph4=-(s1+s2+s3+s4)
10339 #else
10340       eello6_graph4=-(s2+s3+s4)
10341 #endif
10342 C Derivatives in gamma(i-1)
10343       if (i.gt.1) then
10344 #ifdef MOMENT
10345         if (imat.eq.1) then
10346           s1=dipderg(2,jj,i)*dip(3,kk,k)
10347         else
10348           s1=dipderg(4,jj,j)*dip(2,kk,l)
10349         endif
10350 #endif
10351         s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
10352         if (j.eq.l+1) then
10353           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,j+1),auxvec1(1))
10354           s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
10355         else
10356           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,l+1),auxvec1(1))
10357           s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
10358         endif
10359         s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
10360         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
10361 cd          write (2,*) 'turn6 derivatives'
10362 #ifdef MOMENT
10363           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
10364 #else
10365           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
10366 #endif
10367         else
10368 #ifdef MOMENT
10369           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
10370 #else
10371           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
10372 #endif
10373         endif
10374       endif
10375 C Derivatives in gamma(k-1)
10376 #ifdef MOMENT
10377       if (imat.eq.1) then
10378         s1=dip(3,jj,i)*dipderg(2,kk,k)
10379       else
10380         s1=dip(2,jj,j)*dipderg(4,kk,l)
10381       endif
10382 #endif
10383       call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
10384       s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
10385       if (j.eq.l+1) then
10386         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,j+1),auxvec1(1))
10387         s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
10388       else
10389         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,l+1),auxvec1(1))
10390         s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
10391       endif
10392       call transpose2(EUgder(1,1,k),auxmat1(1,1))
10393       call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
10394       vv(1)=pizda(1,1)-pizda(2,2)
10395       vv(2)=pizda(2,1)+pizda(1,2)
10396       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
10397       if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
10398 #ifdef MOMENT
10399         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
10400 #else
10401         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
10402 #endif
10403       else
10404 #ifdef MOMENT
10405         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
10406 #else
10407         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
10408 #endif
10409       endif
10410 C Derivatives in gamma(j-1) or gamma(l-1)
10411       if (l.eq.j+1 .and. l.gt.1) then
10412         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
10413         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
10414         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
10415         vv(1)=pizda(1,1)-pizda(2,2)
10416         vv(2)=pizda(2,1)+pizda(1,2)
10417         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
10418         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
10419       else if (j.gt.1) then
10420         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
10421         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
10422         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
10423         vv(1)=pizda(1,1)-pizda(2,2)
10424         vv(2)=pizda(2,1)+pizda(1,2)
10425         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
10426         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
10427           gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
10428         else
10429           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
10430         endif
10431       endif
10432 C Cartesian derivatives.
10433       do iii=1,2
10434         do kkk=1,5
10435           do lll=1,3
10436 #ifdef MOMENT
10437             if (iii.eq.1) then
10438               if (imat.eq.1) then
10439                 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
10440               else
10441                 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
10442               endif
10443             else
10444               if (imat.eq.1) then
10445                 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
10446               else
10447                 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
10448               endif
10449             endif
10450 #endif
10451             call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),
10452      &        auxvec(1))
10453             s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
10454             if (j.eq.l+1) then
10455               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
10456      &          b1(1,j+1),auxvec(1))
10457               s3=-0.5d0*scalar2(b1(1,j),auxvec(1))
10458             else
10459               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
10460      &          b1(1,l+1),auxvec(1))
10461               s3=-0.5d0*scalar2(b1(1,l),auxvec(1))
10462             endif
10463             call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
10464      &        pizda(1,1))
10465             vv(1)=pizda(1,1)-pizda(2,2)
10466             vv(2)=pizda(2,1)+pizda(1,2)
10467             s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
10468             if (swap) then
10469               if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
10470 #ifdef MOMENT
10471                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
10472      &             -(s1+s2+s4)
10473 #else
10474                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
10475      &             -(s2+s4)
10476 #endif
10477                 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
10478               else
10479 #ifdef MOMENT
10480                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
10481 #else
10482                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
10483 #endif
10484                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
10485               endif
10486             else
10487 #ifdef MOMENT
10488               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
10489 #else
10490               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
10491 #endif
10492               if (l.eq.j+1) then
10493                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
10494               else
10495                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
10496               endif
10497             endif
10498           enddo
10499         enddo
10500       enddo
10501       return
10502       end
10503 c----------------------------------------------------------------------------
10504       double precision function eello_turn6(i,jj,kk)
10505       implicit real*8 (a-h,o-z)
10506       include 'DIMENSIONS'
10507       include 'COMMON.IOUNITS'
10508       include 'COMMON.CHAIN'
10509       include 'COMMON.DERIV'
10510       include 'COMMON.INTERACT'
10511       include 'COMMON.CONTACTS'
10512       include 'COMMON.TORSION'
10513       include 'COMMON.VAR'
10514       include 'COMMON.GEO'
10515       double precision vtemp1(2),vtemp2(2),vtemp3(2),vtemp4(2),
10516      &  atemp(2,2),auxmat(2,2),achuj_temp(2,2),gtemp(2,2),gvec(2),
10517      &  ggg1(3),ggg2(3)
10518       double precision vtemp1d(2),vtemp2d(2),vtemp3d(2),vtemp4d(2),
10519      &  atempd(2,2),auxmatd(2,2),achuj_tempd(2,2),gtempd(2,2),gvecd(2)
10520 C 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
10521 C           the respective energy moment and not to the cluster cumulant.
10522       s1=0.0d0
10523       s8=0.0d0
10524       s13=0.0d0
10525 c
10526       eello_turn6=0.0d0
10527       j=i+4
10528       k=i+1
10529       l=i+3
10530       iti=itortyp(itype(i))
10531       itk=itortyp(itype(k))
10532       itk1=itortyp(itype(k+1))
10533       itl=itortyp(itype(l))
10534       itj=itortyp(itype(j))
10535 cd      write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
10536 cd      write (2,*) 'i',i,' k',k,' j',j,' l',l
10537 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
10538 cd        eello6=0.0d0
10539 cd        return
10540 cd      endif
10541 cd      write (iout,*)
10542 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
10543 cd     &   ' and',k,l
10544 cd      call checkint_turn6(i,jj,kk,eel_turn6_num)
10545       do iii=1,2
10546         do kkk=1,5
10547           do lll=1,3
10548             derx_turn(lll,kkk,iii)=0.0d0
10549           enddo
10550         enddo
10551       enddo
10552 cd      eij=1.0d0
10553 cd      ekl=1.0d0
10554 cd      ekont=1.0d0
10555       eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
10556 cd      eello6_5=0.0d0
10557 cd      write (2,*) 'eello6_5',eello6_5
10558 #ifdef MOMENT
10559       call transpose2(AEA(1,1,1),auxmat(1,1))
10560       call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
10561       ss1=scalar2(Ub2(1,i+2),b1(1,l))
10562       s1 = (auxmat(1,1)+auxmat(2,2))*ss1
10563 #endif
10564       call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1(1))
10565       call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
10566       s2 = scalar2(b1(1,k),vtemp1(1))
10567 #ifdef MOMENT
10568       call transpose2(AEA(1,1,2),atemp(1,1))
10569       call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
10570       call matvec2(Ug2(1,1,i+2),dd(1,1,itk1),vtemp2(1))
10571       s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
10572 #endif
10573       call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
10574       call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
10575       s12 = scalar2(Ub2(1,i+2),vtemp3(1))
10576 #ifdef MOMENT
10577       call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
10578       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
10579       call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
10580       call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
10581       ss13 = scalar2(b1(1,k),vtemp4(1))
10582       s13 = (gtemp(1,1)+gtemp(2,2))*ss13
10583 #endif
10584 c      write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
10585 c      s1=0.0d0
10586 c      s2=0.0d0
10587 c      s8=0.0d0
10588 c      s12=0.0d0
10589 c      s13=0.0d0
10590       eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
10591 C Derivatives in gamma(i+2)
10592       s1d =0.0d0
10593       s8d =0.0d0
10594 #ifdef MOMENT
10595       call transpose2(AEA(1,1,1),auxmatd(1,1))
10596       call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
10597       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
10598       call transpose2(AEAderg(1,1,2),atempd(1,1))
10599       call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
10600       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
10601 #endif
10602       call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
10603       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
10604       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
10605 c      s1d=0.0d0
10606 c      s2d=0.0d0
10607 c      s8d=0.0d0
10608 c      s12d=0.0d0
10609 c      s13d=0.0d0
10610       gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
10611 C Derivatives in gamma(i+3)
10612 #ifdef MOMENT
10613       call transpose2(AEA(1,1,1),auxmatd(1,1))
10614       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
10615       ss1d=scalar2(Ub2der(1,i+2),b1(1,l))
10616       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
10617 #endif
10618       call matvec2(EUgder(1,1,i+2),b1(1,l),vtemp1d(1))
10619       call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
10620       s2d = scalar2(b1(1,k),vtemp1d(1))
10621 #ifdef MOMENT
10622       call matvec2(Ug2der(1,1,i+2),dd(1,1,itk1),vtemp2d(1))
10623       s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2d(1))
10624 #endif
10625       s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
10626 #ifdef MOMENT
10627       call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
10628       call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
10629       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
10630 #endif
10631 c      s1d=0.0d0
10632 c      s2d=0.0d0
10633 c      s8d=0.0d0
10634 c      s12d=0.0d0
10635 c      s13d=0.0d0
10636 #ifdef MOMENT
10637       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
10638      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
10639 #else
10640       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
10641      &               -0.5d0*ekont*(s2d+s12d)
10642 #endif
10643 C Derivatives in gamma(i+4)
10644       call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
10645       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
10646       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
10647 #ifdef MOMENT
10648       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
10649       call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
10650       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
10651 #endif
10652 c      s1d=0.0d0
10653 c      s2d=0.0d0
10654 c      s8d=0.0d0
10655 C      s12d=0.0d0
10656 c      s13d=0.0d0
10657 #ifdef MOMENT
10658       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
10659 #else
10660       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
10661 #endif
10662 C Derivatives in gamma(i+5)
10663 #ifdef MOMENT
10664       call transpose2(AEAderg(1,1,1),auxmatd(1,1))
10665       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
10666       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
10667 #endif
10668       call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1d(1))
10669       call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
10670       s2d = scalar2(b1(1,k),vtemp1d(1))
10671 #ifdef MOMENT
10672       call transpose2(AEA(1,1,2),atempd(1,1))
10673       call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
10674       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
10675 #endif
10676       call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
10677       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
10678 #ifdef MOMENT
10679       call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
10680       ss13d = scalar2(b1(1,k),vtemp4d(1))
10681       s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
10682 #endif
10683 c      s1d=0.0d0
10684 c      s2d=0.0d0
10685 c      s8d=0.0d0
10686 c      s12d=0.0d0
10687 c      s13d=0.0d0
10688 #ifdef MOMENT
10689       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
10690      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
10691 #else
10692       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
10693      &               -0.5d0*ekont*(s2d+s12d)
10694 #endif
10695 C Cartesian derivatives
10696       do iii=1,2
10697         do kkk=1,5
10698           do lll=1,3
10699 #ifdef MOMENT
10700             call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
10701             call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
10702             s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
10703 #endif
10704             call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1(1))
10705             call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),
10706      &          vtemp1d(1))
10707             s2d = scalar2(b1(1,k),vtemp1d(1))
10708 #ifdef MOMENT
10709             call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
10710             call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
10711             s8d = -(atempd(1,1)+atempd(2,2))*
10712      &           scalar2(cc(1,1,itl),vtemp2(1))
10713 #endif
10714             call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),
10715      &           auxmatd(1,1))
10716             call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
10717             s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
10718 c      s1d=0.0d0
10719 c      s2d=0.0d0
10720 c      s8d=0.0d0
10721 c      s12d=0.0d0
10722 c      s13d=0.0d0
10723 #ifdef MOMENT
10724             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
10725      &        - 0.5d0*(s1d+s2d)
10726 #else
10727             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
10728      &        - 0.5d0*s2d
10729 #endif
10730 #ifdef MOMENT
10731             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
10732      &        - 0.5d0*(s8d+s12d)
10733 #else
10734             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
10735      &        - 0.5d0*s12d
10736 #endif
10737           enddo
10738         enddo
10739       enddo
10740 #ifdef MOMENT
10741       do kkk=1,5
10742         do lll=1,3
10743           call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),
10744      &      achuj_tempd(1,1))
10745           call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
10746           call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
10747           s13d=(gtempd(1,1)+gtempd(2,2))*ss13
10748           derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
10749           call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),
10750      &      vtemp4d(1))
10751           ss13d = scalar2(b1(1,k),vtemp4d(1))
10752           s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
10753           derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
10754         enddo
10755       enddo
10756 #endif
10757 cd      write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
10758 cd     &  16*eel_turn6_num
10759 cd      goto 1112
10760       if (j.lt.nres-1) then
10761         j1=j+1
10762         j2=j-1
10763       else
10764         j1=j-1
10765         j2=j-2
10766       endif
10767       if (l.lt.nres-1) then
10768         l1=l+1
10769         l2=l-1
10770       else
10771         l1=l-1
10772         l2=l-2
10773       endif
10774       do ll=1,3
10775 cgrad        ggg1(ll)=eel_turn6*g_contij(ll,1)
10776 cgrad        ggg2(ll)=eel_turn6*g_contij(ll,2)
10777 cgrad        ghalf=0.5d0*ggg1(ll)
10778 cd        ghalf=0.0d0
10779         gturn6ij=eel_turn6*g_contij(ll,1)+ekont*derx_turn(ll,1,1)
10780         gturn6kl=eel_turn6*g_contij(ll,2)+ekont*derx_turn(ll,1,2)
10781         gcorr6_turn(ll,i)=gcorr6_turn(ll,i)!+ghalf
10782      &    +ekont*derx_turn(ll,2,1)
10783         gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
10784         gcorr6_turn(ll,j)=gcorr6_turn(ll,j)!+ghalf
10785      &    +ekont*derx_turn(ll,4,1)
10786         gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
10787         gcorr6_turn_long(ll,j)=gcorr6_turn_long(ll,j)+gturn6ij
10788         gcorr6_turn_long(ll,i)=gcorr6_turn_long(ll,i)-gturn6ij
10789 cgrad        ghalf=0.5d0*ggg2(ll)
10790 cd        ghalf=0.0d0
10791         gcorr6_turn(ll,k)=gcorr6_turn(ll,k)!+ghalf
10792      &    +ekont*derx_turn(ll,2,2)
10793         gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
10794         gcorr6_turn(ll,l)=gcorr6_turn(ll,l)!+ghalf
10795      &    +ekont*derx_turn(ll,4,2)
10796         gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
10797         gcorr6_turn_long(ll,l)=gcorr6_turn_long(ll,l)+gturn6kl
10798         gcorr6_turn_long(ll,k)=gcorr6_turn_long(ll,k)-gturn6kl
10799       enddo
10800 cd      goto 1112
10801 cgrad      do m=i+1,j-1
10802 cgrad        do ll=1,3
10803 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
10804 cgrad        enddo
10805 cgrad      enddo
10806 cgrad      do m=k+1,l-1
10807 cgrad        do ll=1,3
10808 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
10809 cgrad        enddo
10810 cgrad      enddo
10811 cgrad1112  continue
10812 cgrad      do m=i+2,j2
10813 cgrad        do ll=1,3
10814 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
10815 cgrad        enddo
10816 cgrad      enddo
10817 cgrad      do m=k+2,l2
10818 cgrad        do ll=1,3
10819 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
10820 cgrad        enddo
10821 cgrad      enddo
10822 cd      do iii=1,nres-3
10823 cd        write (2,*) iii,g_corr6_loc(iii)
10824 cd      enddo
10825       eello_turn6=ekont*eel_turn6
10826 cd      write (2,*) 'ekont',ekont
10827 cd      write (2,*) 'eel_turn6',ekont*eel_turn6
10828       return
10829       end
10830
10831 C-----------------------------------------------------------------------------
10832       double precision function scalar(u,v)
10833 !DIR$ INLINEALWAYS scalar
10834 #ifndef OSF
10835 cDEC$ ATTRIBUTES FORCEINLINE::scalar
10836 #endif
10837       implicit none
10838       double precision u(3),v(3)
10839 cd      double precision sc
10840 cd      integer i
10841 cd      sc=0.0d0
10842 cd      do i=1,3
10843 cd        sc=sc+u(i)*v(i)
10844 cd      enddo
10845 cd      scalar=sc
10846
10847       scalar=u(1)*v(1)+u(2)*v(2)+u(3)*v(3)
10848       return
10849       end
10850 crc-------------------------------------------------
10851       SUBROUTINE MATVEC2(A1,V1,V2)
10852 !DIR$ INLINEALWAYS MATVEC2
10853 #ifndef OSF
10854 cDEC$ ATTRIBUTES FORCEINLINE::MATVEC2
10855 #endif
10856       implicit real*8 (a-h,o-z)
10857       include 'DIMENSIONS'
10858       DIMENSION A1(2,2),V1(2),V2(2)
10859 c      DO 1 I=1,2
10860 c        VI=0.0
10861 c        DO 3 K=1,2
10862 c    3     VI=VI+A1(I,K)*V1(K)
10863 c        Vaux(I)=VI
10864 c    1 CONTINUE
10865
10866       vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
10867       vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
10868
10869       v2(1)=vaux1
10870       v2(2)=vaux2
10871       END
10872 C---------------------------------------
10873       SUBROUTINE MATMAT2(A1,A2,A3)
10874 #ifndef OSF
10875 cDEC$ ATTRIBUTES FORCEINLINE::MATMAT2
10876 #endif
10877       implicit real*8 (a-h,o-z)
10878       include 'DIMENSIONS'
10879       DIMENSION A1(2,2),A2(2,2),A3(2,2)
10880 c      DIMENSION AI3(2,2)
10881 c        DO  J=1,2
10882 c          A3IJ=0.0
10883 c          DO K=1,2
10884 c           A3IJ=A3IJ+A1(I,K)*A2(K,J)
10885 c          enddo
10886 c          A3(I,J)=A3IJ
10887 c       enddo
10888 c      enddo
10889
10890       ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
10891       ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
10892       ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
10893       ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
10894
10895       A3(1,1)=AI3_11
10896       A3(2,1)=AI3_21
10897       A3(1,2)=AI3_12
10898       A3(2,2)=AI3_22
10899       END
10900
10901 c-------------------------------------------------------------------------
10902       double precision function scalar2(u,v)
10903 !DIR$ INLINEALWAYS scalar2
10904       implicit none
10905       double precision u(2),v(2)
10906       double precision sc
10907       integer i
10908       scalar2=u(1)*v(1)+u(2)*v(2)
10909       return
10910       end
10911
10912 C-----------------------------------------------------------------------------
10913
10914       subroutine transpose2(a,at)
10915 !DIR$ INLINEALWAYS transpose2
10916 #ifndef OSF
10917 cDEC$ ATTRIBUTES FORCEINLINE::transpose2
10918 #endif
10919       implicit none
10920       double precision a(2,2),at(2,2)
10921       at(1,1)=a(1,1)
10922       at(1,2)=a(2,1)
10923       at(2,1)=a(1,2)
10924       at(2,2)=a(2,2)
10925       return
10926       end
10927 c--------------------------------------------------------------------------
10928       subroutine transpose(n,a,at)
10929       implicit none
10930       integer n,i,j
10931       double precision a(n,n),at(n,n)
10932       do i=1,n
10933         do j=1,n
10934           at(j,i)=a(i,j)
10935         enddo
10936       enddo
10937       return
10938       end
10939 C---------------------------------------------------------------------------
10940       subroutine prodmat3(a1,a2,kk,transp,prod)
10941 !DIR$ INLINEALWAYS prodmat3
10942 #ifndef OSF
10943 cDEC$ ATTRIBUTES FORCEINLINE::prodmat3
10944 #endif
10945       implicit none
10946       integer i,j
10947       double precision a1(2,2),a2(2,2),a2t(2,2),kk(2,2),prod(2,2)
10948       logical transp
10949 crc      double precision auxmat(2,2),prod_(2,2)
10950
10951       if (transp) then
10952 crc        call transpose2(kk(1,1),auxmat(1,1))
10953 crc        call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
10954 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
10955
10956            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1)
10957      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
10958            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2)
10959      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
10960            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1)
10961      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
10962            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2)
10963      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
10964
10965       else
10966 crc        call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
10967 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
10968
10969            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1)
10970      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
10971            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2)
10972      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
10973            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1)
10974      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
10975            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2)
10976      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
10977
10978       endif
10979 c      call transpose2(a2(1,1),a2t(1,1))
10980
10981 crc      print *,transp
10982 crc      print *,((prod_(i,j),i=1,2),j=1,2)
10983 crc      print *,((prod(i,j),i=1,2),j=1,2)
10984
10985       return
10986       end
10987 CCC----------------------------------------------
10988       subroutine Eliptransfer(eliptran)
10989       implicit real*8 (a-h,o-z)
10990       include 'DIMENSIONS'
10991       include 'COMMON.GEO'
10992       include 'COMMON.VAR'
10993       include 'COMMON.LOCAL'
10994       include 'COMMON.CHAIN'
10995       include 'COMMON.DERIV'
10996       include 'COMMON.NAMES'
10997       include 'COMMON.INTERACT'
10998       include 'COMMON.IOUNITS'
10999       include 'COMMON.CALC'
11000       include 'COMMON.CONTROL'
11001       include 'COMMON.SPLITELE'
11002       include 'COMMON.SBRIDGE'
11003 C this is done by Adasko
11004 C      print *,"wchodze"
11005 C structure of box:
11006 C      water
11007 C--bordliptop-- buffore starts
11008 C--bufliptop--- here true lipid starts
11009 C      lipid
11010 C--buflipbot--- lipid ends buffore starts
11011 C--bordlipbot--buffore ends
11012       eliptran=0.0
11013       do i=ilip_start,ilip_end
11014 C       do i=1,1
11015         if (itype(i).eq.ntyp1) cycle
11016
11017         positi=(mod(((c(3,i)+c(3,i+1))/2.0d0),boxzsize))
11018         if (positi.le.0) positi=positi+boxzsize
11019 C        print *,i
11020 C first for peptide groups
11021 c for each residue check if it is in lipid or lipid water border area
11022        if ((positi.gt.bordlipbot)
11023      &.and.(positi.lt.bordliptop)) then
11024 C the energy transfer exist
11025         if (positi.lt.buflipbot) then
11026 C what fraction I am in
11027          fracinbuf=1.0d0-
11028      &        ((positi-bordlipbot)/lipbufthick)
11029 C lipbufthick is thickenes of lipid buffore
11030          sslip=sscalelip(fracinbuf)
11031          ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
11032          eliptran=eliptran+sslip*pepliptran
11033          gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
11034          gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
11035 C         gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
11036
11037 C        print *,"doing sccale for lower part"
11038 C         print *,i,sslip,fracinbuf,ssgradlip
11039         elseif (positi.gt.bufliptop) then
11040          fracinbuf=1.0d0-((bordliptop-positi)/lipbufthick)
11041          sslip=sscalelip(fracinbuf)
11042          ssgradlip=sscagradlip(fracinbuf)/lipbufthick
11043          eliptran=eliptran+sslip*pepliptran
11044          gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
11045          gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
11046 C         gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
11047 C          print *, "doing sscalefor top part"
11048 C         print *,i,sslip,fracinbuf,ssgradlip
11049         else
11050          eliptran=eliptran+pepliptran
11051 C         print *,"I am in true lipid"
11052         endif
11053 C       else
11054 C       eliptran=elpitran+0.0 ! I am in water
11055        endif
11056        enddo
11057 C       print *, "nic nie bylo w lipidzie?"
11058 C now multiply all by the peptide group transfer factor
11059 C       eliptran=eliptran*pepliptran
11060 C now the same for side chains
11061 CV       do i=1,1
11062        do i=ilip_start,ilip_end
11063         if (itype(i).eq.ntyp1) cycle
11064         positi=(mod(c(3,i+nres),boxzsize))
11065         if (positi.le.0) positi=positi+boxzsize
11066 C       print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop
11067 c for each residue check if it is in lipid or lipid water border area
11068 C       respos=mod(c(3,i+nres),boxzsize)
11069 C       print *,positi,bordlipbot,buflipbot
11070        if ((positi.gt.bordlipbot)
11071      & .and.(positi.lt.bordliptop)) then
11072 C the energy transfer exist
11073         if (positi.lt.buflipbot) then
11074          fracinbuf=1.0d0-
11075      &     ((positi-bordlipbot)/lipbufthick)
11076 C lipbufthick is thickenes of lipid buffore
11077          sslip=sscalelip(fracinbuf)
11078          ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
11079          eliptran=eliptran+sslip*liptranene(itype(i))
11080          gliptranx(3,i)=gliptranx(3,i)
11081      &+ssgradlip*liptranene(itype(i))
11082          gliptranc(3,i-1)= gliptranc(3,i-1)
11083      &+ssgradlip*liptranene(itype(i))
11084 C         print *,"doing sccale for lower part"
11085         elseif (positi.gt.bufliptop) then
11086          fracinbuf=1.0d0-
11087      &((bordliptop-positi)/lipbufthick)
11088          sslip=sscalelip(fracinbuf)
11089          ssgradlip=sscagradlip(fracinbuf)/lipbufthick
11090          eliptran=eliptran+sslip*liptranene(itype(i))
11091          gliptranx(3,i)=gliptranx(3,i)
11092      &+ssgradlip*liptranene(itype(i))
11093          gliptranc(3,i-1)= gliptranc(3,i-1)
11094      &+ssgradlip*liptranene(itype(i))
11095 C          print *, "doing sscalefor top part",sslip,fracinbuf
11096         else
11097          eliptran=eliptran+liptranene(itype(i))
11098 C         print *,"I am in true lipid"
11099         endif
11100         endif ! if in lipid or buffor
11101 C       else
11102 C       eliptran=elpitran+0.0 ! I am in water
11103        enddo
11104        return
11105        end
11106 C---------------------------------------------------------
11107 C AFM soubroutine for constant force
11108        subroutine AFMforce(Eafmforce)
11109        implicit real*8 (a-h,o-z)
11110       include 'DIMENSIONS'
11111       include 'COMMON.GEO'
11112       include 'COMMON.VAR'
11113       include 'COMMON.LOCAL'
11114       include 'COMMON.CHAIN'
11115       include 'COMMON.DERIV'
11116       include 'COMMON.NAMES'
11117       include 'COMMON.INTERACT'
11118       include 'COMMON.IOUNITS'
11119       include 'COMMON.CALC'
11120       include 'COMMON.CONTROL'
11121       include 'COMMON.SPLITELE'
11122       include 'COMMON.SBRIDGE'
11123       real*8 diffafm(3)
11124       dist=0.0d0
11125       Eafmforce=0.0d0
11126       do i=1,3
11127       diffafm(i)=c(i,afmend)-c(i,afmbeg)
11128       dist=dist+diffafm(i)**2
11129       enddo
11130       dist=dsqrt(dist)
11131       Eafmforce=-forceAFMconst*(dist-distafminit)
11132       do i=1,3
11133       gradafm(i,afmend-1)=-forceAFMconst*diffafm(i)/dist
11134       gradafm(i,afmbeg-1)=forceAFMconst*diffafm(i)/dist
11135       enddo
11136 C      print *,'AFM',Eafmforce
11137       return
11138       end
11139 C---------------------------------------------------------
11140 C AFM subroutine with pseudoconstant velocity
11141        subroutine AFMvel(Eafmforce)
11142        implicit real*8 (a-h,o-z)
11143       include 'DIMENSIONS'
11144       include 'COMMON.GEO'
11145       include 'COMMON.VAR'
11146       include 'COMMON.LOCAL'
11147       include 'COMMON.CHAIN'
11148       include 'COMMON.DERIV'
11149       include 'COMMON.NAMES'
11150       include 'COMMON.INTERACT'
11151       include 'COMMON.IOUNITS'
11152       include 'COMMON.CALC'
11153       include 'COMMON.CONTROL'
11154       include 'COMMON.SPLITELE'
11155       include 'COMMON.SBRIDGE'
11156       real*8 diffafm(3)
11157 C Only for check grad COMMENT if not used for checkgrad
11158 C      totT=3.0d0
11159 C--------------------------------------------------------
11160 C      print *,"wchodze"
11161       dist=0.0d0
11162       Eafmforce=0.0d0
11163       do i=1,3
11164       diffafm(i)=c(i,afmend)-c(i,afmbeg)
11165       dist=dist+diffafm(i)**2
11166       enddo
11167       dist=dsqrt(dist)
11168       Eafmforce=0.5d0*forceAFMconst
11169      & *(distafminit+totTafm*velAFMconst-dist)**2
11170 C      Eafmforce=-forceAFMconst*(dist-distafminit)
11171       do i=1,3
11172       gradafm(i,afmend-1)=-forceAFMconst*
11173      &(distafminit+totTafm*velAFMconst-dist)
11174      &*diffafm(i)/dist
11175       gradafm(i,afmbeg-1)=forceAFMconst*
11176      &(distafminit+totTafm*velAFMconst-dist)
11177      &*diffafm(i)/dist
11178       enddo
11179 C      print *,'AFM',Eafmforce,totTafm*velAFMconst,dist
11180       return
11181       end
11182
11183 c----------------------------------------------------------------------------
11184       double precision function sscale2(r,r_cut,r0,rlamb)
11185       implicit none
11186       double precision r,gamm,r_cut,r0,rlamb,rr
11187       rr = dabs(r-r0)
11188 c      write (2,*) "r",r," r_cut",r_cut," r0",r0," rlamb",rlamb
11189 c      write (2,*) "rr",rr
11190       if(rr.lt.r_cut-rlamb) then
11191         sscale2=1.0d0
11192       else if(rr.le.r_cut.and.rr.ge.r_cut-rlamb) then
11193         gamm=(rr-(r_cut-rlamb))/rlamb
11194         sscale2=1.0d0+gamm*gamm*(2*gamm-3.0d0)
11195         else
11196         sscale2=0d0
11197       endif
11198         return
11199         end
11200 C-----------------------------------------------------------------------
11201       double precision function sscalgrad2(r,r_cut,r0,rlamb)
11202       implicit none
11203       double precision r,gamm,r_cut,r0,rlamb,rr
11204       rr = dabs(r-r0)
11205       if(rr.lt.r_cut-rlamb) then
11206         sscalgrad2=0.0d0
11207       else if(rr.le.r_cut.and.rr.ge.r_cut-rlamb) then
11208         gamm=(rr-(r_cut-rlamb))/rlamb
11209         if (r.ge.r0) then
11210           sscalgrad2=gamm*(6*gamm-6.0d0)/rlamb
11211         else
11212           sscalgrad2=-gamm*(6*gamm-6.0d0)/rlamb
11213         endif
11214         else
11215         sscalgrad2=0.0d0
11216       endif
11217         return
11218         end
11219 c----------------------------------------------------------------------------
11220       subroutine e_saxs(Esaxs_constr)
11221       implicit none
11222       include 'DIMENSIONS'
11223 #ifdef MPI
11224       include "mpif.h"
11225       include "COMMON.SETUP"
11226       integer IERR
11227 #endif
11228       include 'COMMON.SBRIDGE'
11229       include 'COMMON.CHAIN'
11230       include 'COMMON.GEO'
11231       include 'COMMON.DERIV'
11232       include 'COMMON.LOCAL'
11233       include 'COMMON.INTERACT'
11234       include 'COMMON.VAR'
11235       include 'COMMON.IOUNITS'
11236       include 'COMMON.MD'
11237       include 'COMMON.CONTROL'
11238       include 'COMMON.NAMES'
11239       include 'COMMON.TIME1'
11240       include 'COMMON.FFIELD'
11241 c
11242       double precision Esaxs_constr
11243       integer i,iint,j,k,l
11244       double precision PgradC(maxSAXS,3,maxres),
11245      &  PgradX(maxSAXS,3,maxres),Pcalc(maxSAXS)
11246 #ifdef MPI
11247       double precision PgradC_(maxSAXS,3,maxres),
11248      &  PgradX_(maxSAXS,3,maxres),Pcalc_(maxSAXS)
11249 #endif
11250       double precision dk,dijCACA,dijCASC,dijSCCA,dijSCSC,
11251      & sigma2CACA,sigma2CASC,sigma2SCCA,sigma2SCSC,expCACA,expCASC,
11252      & expSCCA,expSCSC,CASCgrad,SCCAgrad,SCSCgrad,aux,auxC,auxC1,
11253      & auxX,auxX1,CACAgrad,Cnorm
11254       double precision sss2,ssgrad2,rrr,sscalgrad2,sscale2
11255       double precision dist
11256       external dist
11257 c  SAXS restraint penalty function
11258 #ifdef DEBUG
11259       write(iout,*) "------- SAXS penalty function start -------"
11260       write (iout,*) "nsaxs",nsaxs
11261       write (iout,*) "Esaxs: iatsc_s",iatsc_s," iatsc_e",iatsc_e
11262       write (iout,*) "Psaxs"
11263       do i=1,nsaxs
11264         write (iout,'(i5,e15.5)') i, Psaxs(i)
11265       enddo
11266 #endif
11267       Esaxs_constr = 0.0d0
11268       do k=1,nsaxs
11269         Pcalc(k)=0.0d0
11270         do j=1,nres
11271           do l=1,3
11272             PgradC(k,l,j)=0.0d0
11273             PgradX(k,l,j)=0.0d0
11274           enddo
11275         enddo
11276       enddo
11277       do i=iatsc_s,iatsc_e
11278        if (itype(i).eq.ntyp1) cycle
11279        do iint=1,nint_gr(i)
11280          do j=istart(i,iint),iend(i,iint)
11281            if (itype(j).eq.ntyp1) cycle
11282 #ifdef ALLSAXS
11283            dijCACA=dist(i,j)
11284            dijCASC=dist(i,j+nres)
11285            dijSCCA=dist(i+nres,j)
11286            dijSCSC=dist(i+nres,j+nres)
11287            sigma2CACA=2.0d0/(pstok**2)
11288            sigma2CASC=4.0d0/(pstok**2+restok(itype(j))**2)
11289            sigma2SCCA=4.0d0/(pstok**2+restok(itype(i))**2)
11290            sigma2SCSC=4.0d0/(restok(itype(j))**2+restok(itype(i))**2)
11291            do k=1,nsaxs
11292              dk = distsaxs(k)
11293              expCACA = dexp(-0.5d0*sigma2CACA*(dijCACA-dk)**2)
11294              if (itype(j).ne.10) then
11295              expCASC = dexp(-0.5d0*sigma2CASC*(dijCASC-dk)**2)
11296              else
11297              endif
11298              expCASC = 0.0d0
11299              if (itype(i).ne.10) then
11300              expSCCA = dexp(-0.5d0*sigma2SCCA*(dijSCCA-dk)**2)
11301              else
11302              expSCCA = 0.0d0
11303              endif
11304              if (itype(i).ne.10 .and. itype(j).ne.10) then
11305              expSCSC = dexp(-0.5d0*sigma2SCSC*(dijSCSC-dk)**2)
11306              else
11307              expSCSC = 0.0d0
11308              endif
11309              Pcalc(k) = Pcalc(k)+expCACA+expCASC+expSCCA+expSCSC
11310 #ifdef DEBUG
11311              write(iout,*) "i j k Pcalc",i,j,Pcalc(k)
11312 #endif
11313              CACAgrad = sigma2CACA*(dijCACA-dk)*expCACA
11314              CASCgrad = sigma2CASC*(dijCASC-dk)*expCASC
11315              SCCAgrad = sigma2SCCA*(dijSCCA-dk)*expSCCA
11316              SCSCgrad = sigma2SCSC*(dijSCSC-dk)*expSCSC
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 c CA SC
11323                if (itype(j).ne.10) then
11324                aux = CASCgrad*(C(l,j+nres)-C(l,i))/dijCASC
11325                PgradC(k,l,i) = PgradC(k,l,i)-aux
11326                PgradC(k,l,j) = PgradC(k,l,j)+aux
11327                PgradX(k,l,j) = PgradX(k,l,j)+aux
11328                endif
11329 c SC CA
11330                if (itype(i).ne.10) then
11331                aux = SCCAgrad*(C(l,j)-C(l,i+nres))/dijSCCA
11332                PgradX(k,l,i) = PgradX(k,l,i)-aux
11333                PgradC(k,l,i) = PgradC(k,l,i)-aux
11334                PgradC(k,l,j) = PgradC(k,l,j)+aux
11335                endif
11336 c SC SC
11337                if (itype(i).ne.10 .and. itype(j).ne.10) then
11338                aux = SCSCgrad*(C(l,j+nres)-C(l,i+nres))/dijSCSC
11339                PgradC(k,l,i) = PgradC(k,l,i)-aux
11340                PgradC(k,l,j) = PgradC(k,l,j)+aux
11341                PgradX(k,l,i) = PgradX(k,l,i)-aux
11342                PgradX(k,l,j) = PgradX(k,l,j)+aux
11343                endif
11344              enddo ! l
11345            enddo ! k
11346 #else
11347            dijCACA=dist(i,j)
11348            sigma2CACA=scal_rad**2*0.25d0/
11349      &        (restok(itype(j))**2+restok(itype(i))**2)
11350
11351            IF (saxs_cutoff.eq.0) THEN
11352            do k=1,nsaxs
11353              dk = distsaxs(k)
11354              expCACA = dexp(-0.5d0*sigma2CACA*(dijCACA-dk)**2)
11355              Pcalc(k) = Pcalc(k)+expCACA
11356              CACAgrad = sigma2CACA*(dijCACA-dk)*expCACA
11357              do l=1,3
11358                aux = CACAgrad*(C(l,j)-C(l,i))/dijCACA
11359                PgradC(k,l,i) = PgradC(k,l,i)-aux
11360                PgradC(k,l,j) = PgradC(k,l,j)+aux
11361              enddo ! l
11362            enddo ! k
11363            ELSE
11364            rrr = saxs_cutoff*2.0d0/dsqrt(sigma2CACA)
11365            do k=1,nsaxs
11366              dk = distsaxs(k)
11367 c             write (2,*) "ijk",i,j,k
11368              sss2 = sscale2(dijCACA,rrr,dk,0.3d0)
11369              if (sss2.eq.0.0d0) cycle
11370              ssgrad2 = sscalgrad2(dijCACA,rrr,dk,0.3d0)
11371              if (energy_dec) write(iout,'(a4,3i5,5f10.4)')
11372      &          'saxs',i,j,k,dijCACA,rrr,dk,sss2,ssgrad2
11373              expCACA = dexp(-0.5d0*sigma2CACA*(dijCACA-dk)**2)*sss2
11374              Pcalc(k) = Pcalc(k)+expCACA
11375 #ifdef DEBUG
11376              write(iout,*) "i j k Pcalc",i,j,Pcalc(k)
11377 #endif
11378              CACAgrad = -sigma2CACA*(dijCACA-dk)*expCACA+
11379      &             ssgrad2*expCACA/sss2
11380              do l=1,3
11381 c CA CA
11382                aux = CACAgrad*(C(l,j)-C(l,i))/dijCACA
11383                PgradC(k,l,i) = PgradC(k,l,i)+aux
11384                PgradC(k,l,j) = PgradC(k,l,j)-aux
11385              enddo ! l
11386            enddo ! k
11387            ENDIF
11388 #endif
11389          enddo ! j
11390        enddo ! iint
11391       enddo ! i
11392 #ifdef MPI
11393       if (nfgtasks.gt.1) then
11394        call MPI_AllReduce(Pcalc(1),Pcalc_(1),nsaxs,MPI_DOUBLE_PRECISION,
11395      &    MPI_SUM,FG_COMM,IERR)
11396 c        if (fg_rank.eq.king) then
11397           do k=1,nsaxs
11398             Pcalc(k) = Pcalc_(k)
11399           enddo
11400 c        endif
11401 c        call MPI_AllReduce(PgradC(k,1,1),PgradC_(k,1,1),3*maxsaxs*nres,
11402 c     &    MPI_DOUBLE_PRECISION,MPI_SUM,FG_COMM,IERR)
11403 c        if (fg_rank.eq.king) then
11404 c          do i=1,nres
11405 c            do l=1,3
11406 c              do k=1,nsaxs
11407 c                PgradC(k,l,i) = PgradC_(k,l,i)
11408 c              enddo
11409 c            enddo
11410 c          enddo
11411 c        endif
11412 #ifdef ALLSAXS
11413 c        call MPI_AllReduce(PgradX(k,1,1),PgradX_(k,1,1),3*maxsaxs*nres,
11414 c     &    MPI_DOUBLE_PRECISION,MPI_SUM,FG_COMM,IERR)
11415 c        if (fg_rank.eq.king) then
11416 c          do i=1,nres
11417 c            do l=1,3
11418 c              do k=1,nsaxs
11419 c                PgradX(k,l,i) = PgradX_(k,l,i)
11420 c              enddo
11421 c            enddo
11422 c          enddo
11423 c        endif
11424 #endif
11425       endif
11426 #endif
11427       Cnorm = 0.0d0
11428       do k=1,nsaxs
11429         Cnorm = Cnorm + Pcalc(k)
11430       enddo
11431 #ifdef MPI
11432       if (fg_rank.eq.king) then
11433 #endif
11434       Esaxs_constr = dlog(Cnorm)-wsaxs0
11435       do k=1,nsaxs
11436         if (Pcalc(k).gt.0.0d0)
11437      &  Esaxs_constr = Esaxs_constr - Psaxs(k)*dlog(Pcalc(k))
11438 #ifdef DEBUG
11439         write (iout,*) "k",k," Esaxs_constr",Esaxs_constr
11440 #endif
11441       enddo
11442 #ifdef DEBUG
11443       write (iout,*) "Cnorm",Cnorm," Esaxs_constr",Esaxs_constr
11444 #endif
11445 #ifdef MPI
11446       endif
11447 #endif
11448       gsaxsC=0.0d0
11449       gsaxsX=0.0d0
11450       do i=nnt,nct
11451         do l=1,3
11452           auxC=0.0d0
11453           auxC1=0.0d0
11454           auxX=0.0d0
11455           auxX1=0.d0
11456           do k=1,nsaxs
11457             if (Pcalc(k).gt.0)
11458      &      auxC  = auxC +Psaxs(k)*PgradC(k,l,i)/Pcalc(k)
11459             auxC1 = auxC1+PgradC(k,l,i)
11460 #ifdef ALLSAXS
11461             auxX  = auxX +Psaxs(k)*PgradX(k,l,i)/Pcalc(k)
11462             auxX1 = auxX1+PgradX(k,l,i)
11463 #endif
11464           enddo
11465           gsaxsC(l,i) = auxC - auxC1/Cnorm
11466 #ifdef ALLSAXS
11467           gsaxsX(l,i) = auxX - auxX1/Cnorm
11468 #endif
11469 c          write (iout,*) "l i",l,i," gradC",wsaxs*(auxC - auxC1/Cnorm),
11470 c     *     " gradX",wsaxs*(auxX - auxX1/Cnorm)
11471         enddo
11472       enddo
11473 #ifdef MPI
11474 c      endif
11475 #endif
11476       return
11477       end
11478 c----------------------------------------------------------------------------
11479       subroutine e_saxsC(Esaxs_constr)
11480       implicit none
11481       include 'DIMENSIONS'
11482 #ifdef MPI
11483       include "mpif.h"
11484       include "COMMON.SETUP"
11485       integer IERR
11486 #endif
11487       include 'COMMON.SBRIDGE'
11488       include 'COMMON.CHAIN'
11489       include 'COMMON.GEO'
11490       include 'COMMON.DERIV'
11491       include 'COMMON.LOCAL'
11492       include 'COMMON.INTERACT'
11493       include 'COMMON.VAR'
11494       include 'COMMON.IOUNITS'
11495       include 'COMMON.MD'
11496       include 'COMMON.CONTROL'
11497       include 'COMMON.NAMES'
11498       include 'COMMON.TIME1'
11499       include 'COMMON.FFIELD'
11500 c
11501       double precision Esaxs_constr
11502       integer i,iint,j,k,l
11503       double precision PgradC(3,maxres),PgradX(3,maxres),Pcalc,logPtot
11504 #ifdef MPI
11505       double precision gsaxsc_(3,maxres),gsaxsx_(3,maxres),logPtot_
11506 #endif
11507       double precision dk,dijCASPH,dijSCSPH,
11508      & sigma2CA,sigma2SC,expCASPH,expSCSPH,
11509      & CASPHgrad,SCSPHgrad,aux,auxC,auxC1,
11510      & auxX,auxX1,Cnorm
11511 c  SAXS restraint penalty function
11512 #ifdef DEBUG
11513       write(iout,*) "------- SAXS penalty function start -------"
11514       write (iout,*) "nsaxs",nsaxs
11515
11516       do i=nnt,nct
11517         print *,MyRank,"C",i,(C(j,i),j=1,3)
11518       enddo
11519       do i=nnt,nct
11520         print *,MyRank,"CSaxs",i,(Csaxs(j,i),j=1,3)
11521       enddo
11522 #endif
11523       Esaxs_constr = 0.0d0
11524       logPtot=0.0d0
11525       do j=isaxs_start,isaxs_end
11526         Pcalc=0.0d0
11527         do i=1,nres
11528           do l=1,3
11529             PgradC(l,i)=0.0d0
11530             PgradX(l,i)=0.0d0
11531           enddo
11532         enddo
11533         do i=nnt,nct
11534           if (itype(i).eq.ntyp1) cycle
11535           dijCASPH=0.0d0
11536           dijSCSPH=0.0d0
11537           do l=1,3
11538             dijCASPH=dijCASPH+(C(l,i)-Csaxs(l,j))**2
11539           enddo
11540           if (itype(i).ne.10) then
11541           do l=1,3
11542             dijSCSPH=dijSCSPH+(C(l,i+nres)-Csaxs(l,j))**2
11543           enddo
11544           endif
11545           sigma2CA=2.0d0/pstok**2
11546           sigma2SC=4.0d0/restok(itype(i))**2
11547           expCASPH = dexp(-0.5d0*sigma2CA*dijCASPH)
11548           expSCSPH = dexp(-0.5d0*sigma2SC*dijSCSPH)
11549           Pcalc = Pcalc+expCASPH+expSCSPH
11550 #ifdef DEBUG
11551           write(*,*) "processor i j Pcalc",
11552      &       MyRank,i,j,dijCASPH,dijSCSPH, Pcalc
11553 #endif
11554           CASPHgrad = sigma2CA*expCASPH
11555           SCSPHgrad = sigma2SC*expSCSPH
11556           do l=1,3
11557             aux = (C(l,i+nres)-Csaxs(l,j))*SCSPHgrad
11558             PgradX(l,i) = PgradX(l,i) + aux
11559             PgradC(l,i) = PgradC(l,i)+(C(l,i)-Csaxs(l,j))*CASPHgrad+aux
11560           enddo ! l
11561         enddo ! i
11562         do i=nnt,nct
11563           do l=1,3
11564             gsaxsc(l,i)=gsaxsc(l,i)+PgradC(l,i)/Pcalc
11565             gsaxsx(l,i)=gsaxsx(l,i)+PgradX(l,i)/Pcalc
11566           enddo
11567         enddo
11568         logPtot = logPtot - dlog(Pcalc)
11569 c        print *,"me",me,MyRank," j",j," logPcalc",-dlog(Pcalc),
11570 c     &    " logPtot",logPtot
11571       enddo ! j
11572 #ifdef MPI
11573       if (nfgtasks.gt.1) then
11574 c        write (iout,*) "logPtot before reduction",logPtot
11575         call MPI_Reduce(logPtot,logPtot_,1,MPI_DOUBLE_PRECISION,
11576      &    MPI_SUM,king,FG_COMM,IERR)
11577         logPtot = logPtot_
11578 c        write (iout,*) "logPtot after reduction",logPtot
11579         call MPI_Reduce(gsaxsC(1,1),gsaxsC_(1,1),3*nres,
11580      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
11581         if (fg_rank.eq.king) then
11582           do i=1,nres
11583             do l=1,3
11584               gsaxsC(l,i) = gsaxsC_(l,i)
11585             enddo
11586           enddo
11587         endif
11588         call MPI_Reduce(gsaxsX(1,1),gsaxsX_(1,1),3*nres,
11589      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
11590         if (fg_rank.eq.king) then
11591           do i=1,nres
11592             do l=1,3
11593               gsaxsX(l,i) = gsaxsX_(l,i)
11594             enddo
11595           enddo
11596         endif
11597       endif
11598 #endif
11599       Esaxs_constr = logPtot
11600       return
11601       end