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 C FG Master broadcasts the WEIGHTS_ array
  59           call MPI_Bcast(weights_(1),n_ene,
  60      &        MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
  61         else
  62 C FG slaves receive the WEIGHTS array
  63           call MPI_Bcast(weights(1),n_ene,
  64      &        MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
  65           wsc=weights(1)
  66           wscp=weights(2)
  67           welec=weights(3)
  68           wcorr=weights(4)
  69           wcorr5=weights(5)
  70           wcorr6=weights(6)
  71           wel_loc=weights(7)
  72           wturn3=weights(8)
  73           wturn4=weights(9)
  74           wturn6=weights(10)
  75           wang=weights(11)
  76           wscloc=weights(12)
  77           wtor=weights(13)
  78           wtor_d=weights(14)
  79           wstrain=weights(15)
  80           wvdwpp=weights(16)
  81           wbond=weights(17)
  82           scal14=weights(18)
  83           wsccor=weights(21)
  84         endif
  85         time_Bcast=time_Bcast+MPI_Wtime()-time00
  86         time_Bcastw=time_Bcastw+MPI_Wtime()-time00
  87 c        call chainbuild_cart
  88       endif
  89 c      print *,'Processor',myrank,' calling etotal ipot=',ipot
  90 c      print *,'Processor',myrank,' nnt=',nnt,' nct=',nct
  91 #else
  92 c      if (modecalc.eq.12.or.modecalc.eq.14) then
  93 c        call int_from_cart1(.false.)
  94 c      endif
  95 #endif
  96 #ifdef TIMING
  97       time00=MPI_Wtime()
  98 #endif
  99 C
 100 C Compute the side-chain and electrostatic interaction energy
 101 C
 102 C      print *,ipot
 103       goto (101,102,103,104,105,106) ipot
 104 C Lennard-Jones potential.
 105   101 call elj(evdw)
 106 cd    print '(a)','Exit ELJ'
 107       goto 107
 108 C Lennard-Jones-Kihara potential (shifted).
 109   102 call eljk(evdw)
 110       goto 107
 111 C Berne-Pechukas potential (dilated LJ, angular dependence).
 112   103 call ebp(evdw)
 113       goto 107
 114 C Gay-Berne potential (shifted LJ, angular dependence).
 115   104 call egb(evdw)
 116 C      print *,"bylem w egb"
 117       goto 107
 118 C Gay-Berne-Vorobjev potential (shifted LJ, angular dependence).
 119   105 call egbv(evdw)
 120       goto 107
 121 C Soft-sphere potential
 122   106 call e_softsphere(evdw)
 123 C
 124 C Calculate electrostatic (H-bonding) energy of the main chain.
 125 C
 126   107 continue
 127 cmc
 128 cmc Sep-06: egb takes care of dynamic ss bonds too
 129 cmc
 130 c      if (dyn_ss) call dyn_set_nss
 131
 132 c      print *,"Processor",myrank," computed USCSC"
 133 #ifdef TIMING
 134       time01=MPI_Wtime()
 135 #endif
 136       call vec_and_deriv
 137 #ifdef TIMING
 138       time_vec=time_vec+MPI_Wtime()-time01
 139 #endif
 140 C Introduction of shielding effect first for each peptide group
 141 C the shielding factor is set this factor is describing how each
 142 C peptide group is shielded by side-chains
 143 C the matrix - shield_fac(i) the i index describe the ith between i and i+1
 144 C      write (iout,*) "shield_mode",shield_mode
 145       if (shield_mode.gt.0) then
 146        call set_shield_fac
 147       endif
 148 c      print *,"Processor",myrank," left VEC_AND_DERIV"
 149       if (ipot.lt.6) then
 150 #ifdef SPLITELE
 151          if (welec.gt.0d0.or.wvdwpp.gt.0d0.or.wel_loc.gt.0d0.or.
 152      &       wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0
 153      &       .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0
 154      &       .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
 155 #else
 156          if (welec.gt.0d0.or.wel_loc.gt.0d0.or.
 157      &       wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0
 158      &       .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0
 159      &       .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
 160 #endif
 161             call eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
 162          else
 163             ees=0.0d0
 164             evdw1=0.0d0
 165             eel_loc=0.0d0
 166             eello_turn3=0.0d0
 167             eello_turn4=0.0d0
 168          endif
 169       else
 170         write (iout,*) "Soft-spheer ELEC potential"
 171 c        call eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,
 172 c     &   eello_turn4)
 173       endif
 174 c      print *,"Processor",myrank," computed UELEC"
 175 C
 176 C Calculate excluded-volume interaction energy between peptide groups
 177 C and side chains.
 178 C
 179       if (ipot.lt.6) then
 180        if(wscp.gt.0d0) then
 181         call escp(evdw2,evdw2_14)
 182        else
 183         evdw2=0
 184         evdw2_14=0
 185        endif
 186       else
 187 c        write (iout,*) "Soft-sphere SCP potential"
 188         call escp_soft_sphere(evdw2,evdw2_14)
 189       endif
 190 c
 191 c Calculate the bond-stretching energy
 192 c
 193       call ebond(estr)
 194 C
 195 C Calculate the disulfide-bridge and other energy and the contributions
 196 C from other distance constraints.
 197 cd    print *,'Calling EHPB'
 198       call edis(ehpb)
 199 cd    print *,'EHPB exitted succesfully.'
 200 C
 201 C Calculate the virtual-bond-angle energy.
 202 C
 203       if (wang.gt.0d0) then
 204         call ebend(ebe,ethetacnstr)
 205       else
 206         ebe=0
 207         ethetacnstr=0
 208       endif
 209 c      print *,"Processor",myrank," computed UB"
 210 C
 211 C Calculate the SC local energy.
 212 C
 213 C      print *,"TU DOCHODZE?"
 214       call esc(escloc)
 215 c      print *,"Processor",myrank," computed USC"
 216 C
 217 C Calculate the virtual-bond torsional energy.
 218 C
 219 cd    print *,'nterm=',nterm
 220       if (wtor.gt.0) then
 221        call etor(etors,edihcnstr)
 222       else
 223        etors=0
 224        edihcnstr=0
 225       endif
 226 c      print *,"Processor",myrank," computed Utor"
 227 C
 228 C 6/23/01 Calculate double-torsional energy
 229 C
 230       if (wtor_d.gt.0) then
 231        call etor_d(etors_d)
 232       else
 233        etors_d=0
 234       endif
 235 c      print *,"Processor",myrank," computed Utord"
 236 C
 237 C 21/5/07 Calculate local sicdechain correlation energy
 238 C
 239       if (wsccor.gt.0.0d0) then
 240         call eback_sc_corr(esccor)
 241       else
 242         esccor=0.0d0
 243       endif
 244 C      print *,"PRZED MULIt"
 245 c      print *,"Processor",myrank," computed Usccorr"
 246 C
 247 C 12/1/95 Multi-body terms
 248 C
 249       n_corr=0
 250       n_corr1=0
 251       if ((wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0
 252      &    .or. wturn6.gt.0.0d0) .and. ipot.lt.6) then
 253          call multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1)
 254 cd         write(2,*)'multibody_eello n_corr=',n_corr,' n_corr1=',n_corr1,
 255 cd     &" ecorr",ecorr," ecorr5",ecorr5," ecorr6",ecorr6," eturn6",eturn6
 256       else
 257          ecorr=0.0d0
 258          ecorr5=0.0d0
 259          ecorr6=0.0d0
 260          eturn6=0.0d0
 261       endif
 262       if ((wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) .and. ipot.lt.6) then
 263          call multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
 264 cd         write (iout,*) "multibody_hb ecorr",ecorr
 265       endif
 266 c      print *,"Processor",myrank," computed Ucorr"
 267 C
 268 C If performing constraint dynamics, call the constraint energy
 269 C  after the equilibration time
 270       if(usampl.and.totT.gt.eq_time) then
 271          call EconstrQ
 272          call Econstr_back
 273       else
 274          Uconst=0.0d0
 275          Uconst_back=0.0d0
 276       endif
 277 C 01/27/2015 added by adasko
 278 C the energy component below is energy transfer into lipid environment
 279 C based on partition function
 280 C      print *,"przed lipidami"
 281       if (wliptran.gt.0) then
 282         call Eliptransfer(eliptran)
 283       endif
 284 C      print *,"za lipidami"
 285       if (AFMlog.gt.0) then
 286         call AFMforce(Eafmforce)
 287       else if (selfguide.gt.0) then
 288         call AFMvel(Eafmforce)
 289       endif
 290 #ifdef TIMING
 291       time_enecalc=time_enecalc+MPI_Wtime()-time00
 292 #endif
 293 c      print *,"Processor",myrank," computed Uconstr"
 294 #ifdef TIMING
 295       time00=MPI_Wtime()
 296 #endif
 297 c
 298 C Sum the energies
 299 C
 300       energia(1)=evdw
 301 #ifdef SCP14
 302       energia(2)=evdw2-evdw2_14
 303       energia(18)=evdw2_14
 304 #else
 305       energia(2)=evdw2
 306       energia(18)=0.0d0
 307 #endif
 308 #ifdef SPLITELE
 309       energia(3)=ees
 310       energia(16)=evdw1
 311 #else
 312       energia(3)=ees+evdw1
 313       energia(16)=0.0d0
 314 #endif
 315       energia(4)=ecorr
 316       energia(5)=ecorr5
 317       energia(6)=ecorr6
 318       energia(7)=eel_loc
 319       energia(8)=eello_turn3
 320       energia(9)=eello_turn4
 321       energia(10)=eturn6
 322       energia(11)=ebe
 323       energia(12)=escloc
 324       energia(13)=etors
 325       energia(14)=etors_d
 326       energia(15)=ehpb
 327       energia(19)=edihcnstr
 328       energia(17)=estr
 329       energia(20)=Uconst+Uconst_back
 330       energia(21)=esccor
 331       energia(22)=eliptran
 332       energia(23)=Eafmforce
 333       energia(24)=ethetacnstr
 334 c    Here are the energies showed per procesor if the are more processors
 335 c    per molecule then we sum it up in sum_energy subroutine
 336 c      print *," Processor",myrank," calls SUM_ENERGY"
 337       call sum_energy(energia,.true.)
 338       if (dyn_ss) call dyn_set_nss
 339 c      print *," Processor",myrank," left SUM_ENERGY"
 340 #ifdef TIMING
 341       time_sumene=time_sumene+MPI_Wtime()-time00
 342 #endif
 343       return
 344       end
 345 c-------------------------------------------------------------------------------
 346       subroutine sum_energy(energia,reduce)
 347       implicit real*8 (a-h,o-z)
 348       include 'DIMENSIONS'
 349 #ifndef ISNAN
 350       external proc_proc
 351 #ifdef WINPGI
 352 cMS$ATTRIBUTES C ::  proc_proc
 353 #endif
 354 #endif
 355 #ifdef MPI
 356       include "mpif.h"
 357 #endif
 358       include 'COMMON.SETUP'
 359       include 'COMMON.IOUNITS'
 360       double precision energia(0:n_ene),enebuff(0:n_ene+1)
 361       include 'COMMON.FFIELD'
 362       include 'COMMON.DERIV'
 363       include 'COMMON.INTERACT'
 364       include 'COMMON.SBRIDGE'
 365       include 'COMMON.CHAIN'
 366       include 'COMMON.VAR'
 367       include 'COMMON.CONTROL'
 368       include 'COMMON.TIME1'
 369       logical reduce
 370 #ifdef MPI
 371       if (nfgtasks.gt.1 .and. reduce) then
 372 #ifdef DEBUG
 373         write (iout,*) "energies before REDUCE"
 374         call enerprint(energia)
 375         call flush(iout)
 376 #endif
 377         do i=0,n_ene
 378           enebuff(i)=energia(i)
 379         enddo
 380         time00=MPI_Wtime()
 381         call MPI_Barrier(FG_COMM,IERR)
 382         time_barrier_e=time_barrier_e+MPI_Wtime()-time00
 383         time00=MPI_Wtime()
 384         call MPI_Reduce(enebuff(0),energia(0),n_ene+1,
 385      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 386 #ifdef DEBUG
 387         write (iout,*) "energies after REDUCE"
 388         call enerprint(energia)
 389         call flush(iout)
 390 #endif
 391         time_Reduce=time_Reduce+MPI_Wtime()-time00
 392       endif
 393       if (fg_rank.eq.0) then
 394 #endif
 395       evdw=energia(1)
 396 #ifdef SCP14
 397       evdw2=energia(2)+energia(18)
 398       evdw2_14=energia(18)
 399 #else
 400       evdw2=energia(2)
 401 #endif
 402 #ifdef SPLITELE
 403       ees=energia(3)
 404       evdw1=energia(16)
 405 #else
 406       ees=energia(3)
 407       evdw1=0.0d0
 408 #endif
 409       ecorr=energia(4)
 410       ecorr5=energia(5)
 411       ecorr6=energia(6)
 412       eel_loc=energia(7)
 413       eello_turn3=energia(8)
 414       eello_turn4=energia(9)
 415       eturn6=energia(10)
 416       ebe=energia(11)
 417       escloc=energia(12)
 418       etors=energia(13)
 419       etors_d=energia(14)
 420       ehpb=energia(15)
 421       edihcnstr=energia(19)
 422       estr=energia(17)
 423       Uconst=energia(20)
 424       esccor=energia(21)
 425       eliptran=energia(22)
 426       Eafmforce=energia(23)
 427       ethetacnstr=energia(24)
 428 #ifdef SPLITELE
 429       etot=wsc*evdw+wscp*evdw2+welec*ees+wvdwpp*evdw1
 430      & +wang*ebe+wtor*etors+wscloc*escloc
 431      & +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5
 432      & +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3
 433      & +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d
 434      & +wbond*estr+Uconst+wsccor*esccor+wliptran*eliptran+Eafmforce
 435      & +ethetacnstr
 436 #else
 437       etot=wsc*evdw+wscp*evdw2+welec*(ees+evdw1)
 438      & +wang*ebe+wtor*etors+wscloc*escloc
 439      & +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5
 440      & +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3
 441      & +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d
 442      & +wbond*estr+Uconst+wsccor*esccor+wliptran*eliptran
 443      & +Eafmforce
 444      & +ethetacnstr
 445 #endif
 446       energia(0)=etot
 447 c detecting NaNQ
 448 #ifdef ISNAN
 449 #ifdef AIX
 450       if (isnan(etot).ne.0) energia(0)=1.0d+99
 451 #else
 452       if (isnan(etot)) energia(0)=1.0d+99
 453 #endif
 454 #else
 455       i=0
 456 #ifdef WINPGI
 457       idumm=proc_proc(etot,i)
 458 #else
 459       call proc_proc(etot,i)
 460 #endif
 461       if(i.eq.1)energia(0)=1.0d+99
 462 #endif
 463 #ifdef MPI
 464       endif
 465 #endif
 466       return
 467       end
 468 c-------------------------------------------------------------------------------
 469       subroutine sum_gradient
 470       implicit real*8 (a-h,o-z)
 471       include 'DIMENSIONS'
 472 #ifndef ISNAN
 473       external proc_proc
 474 #ifdef WINPGI
 475 cMS$ATTRIBUTES C ::  proc_proc
 476 #endif
 477 #endif
 478 #ifdef MPI
 479       include 'mpif.h'
 480 #endif
 481       double precision gradbufc(3,-1:maxres),gradbufx(3,-1:maxres),
 482      & glocbuf(4*maxres),gradbufc_sum(3,-1:maxres)
 483      & ,gloc_scbuf(3,-1:maxres)
 484       include 'COMMON.SETUP'
 485       include 'COMMON.IOUNITS'
 486       include 'COMMON.FFIELD'
 487       include 'COMMON.DERIV'
 488       include 'COMMON.INTERACT'
 489       include 'COMMON.SBRIDGE'
 490       include 'COMMON.CHAIN'
 491       include 'COMMON.VAR'
 492       include 'COMMON.CONTROL'
 493       include 'COMMON.TIME1'
 494       include 'COMMON.MAXGRAD'
 495       include 'COMMON.SCCOR'
 496 #ifdef TIMING
 497       time01=MPI_Wtime()
 498 #endif
 499 #ifdef DEBUG
 500       write (iout,*) "sum_gradient gvdwc, gvdwx"
 501       do i=1,nres
 502         write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)')
 503      &   i,(gvdwx(j,i),j=1,3),(gvdwc(j,i),j=1,3)
 504       enddo
 505       call flush(iout)
 506 #endif
 507 #ifdef MPI
 508 C FG slaves call the following matching MPI_Bcast in ERGASTULUM
 509         if (nfgtasks.gt.1 .and. fg_rank.eq.0)
 510      &    call MPI_Bcast(1,1,MPI_INTEGER,king,FG_COMM,IERROR)
 511 #endif
 512 C
 513 C 9/29/08 AL Transform parts of gradients in site coordinates to the gradient
 514 C            in virtual-bond-vector coordinates
 515 C
 516 #ifdef DEBUG
 517 c      write (iout,*) "gel_loc gel_loc_long and gel_loc_loc"
 518 c      do i=1,nres-1
 519 c        write (iout,'(i5,3f10.5,2x,3f10.5,2x,f10.5)')
 520 c     &   i,(gel_loc(j,i),j=1,3),(gel_loc_long(j,i),j=1,3),gel_loc_loc(i)
 521 c      enddo
 522 c      write (iout,*) "gel_loc_tur3 gel_loc_turn4"
 523 c      do i=1,nres-1
 524 c        write (iout,'(i5,3f10.5,2x,f10.5)')
 525 c     &  i,(gcorr4_turn(j,i),j=1,3),gel_loc_turn4(i)
 526 c      enddo
 527       write (iout,*) "gradcorr5 gradcorr5_long gradcorr5_loc"
 528       do i=1,nres
 529         write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)')
 530      &   i,(gradcorr5(j,i),j=1,3),(gradcorr5_long(j,i),j=1,3),
 531      &   g_corr5_loc(i)
 532       enddo
 533       call flush(iout)
 534 #endif
 535 #ifdef SPLITELE
 536       do i=0,nct
 537         do j=1,3
 538           gradbufc(j,i)=wsc*gvdwc(j,i)+
 539      &                wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+
 540      &                welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+
 541      &                wel_loc*gel_loc_long(j,i)+
 542      &                wcorr*gradcorr_long(j,i)+
 543      &                wcorr5*gradcorr5_long(j,i)+
 544      &                wcorr6*gradcorr6_long(j,i)+
 545      &                wturn6*gcorr6_turn_long(j,i)+
 546      &                wstrain*ghpbc(j,i)
 547      &                +wliptran*gliptranc(j,i)
 548      &                +gradafm(j,i)
 549      &                 +welec*gshieldc(j,i)
 550
 551         enddo
 552       enddo
 553 #else
 554       do i=0,nct
 555         do j=1,3
 556           gradbufc(j,i)=wsc*gvdwc(j,i)+
 557      &                wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+
 558      &                welec*gelc_long(j,i)+
 559      &                wbond*gradb(j,i)+
 560      &                wel_loc*gel_loc_long(j,i)+
 561      &                wcorr*gradcorr_long(j,i)+
 562      &                wcorr5*gradcorr5_long(j,i)+
 563      &                wcorr6*gradcorr6_long(j,i)+
 564      &                wturn6*gcorr6_turn_long(j,i)+
 565      &                wstrain*ghpbc(j,i)
 566      &                +wliptran*gliptranc(j,i)
 567      &                +gradafm(j,i)
 568      &                 +welec*gshieldc(j,i)
 569
 570         enddo
 571       enddo
 572 #endif
 573 #ifdef MPI
 574       if (nfgtasks.gt.1) then
 575       time00=MPI_Wtime()
 576 #ifdef DEBUG
 577       write (iout,*) "gradbufc before allreduce"
 578       do i=1,nres
 579         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 580       enddo
 581       call flush(iout)
 582 #endif
 583       do i=0,nres
 584         do j=1,3
 585           gradbufc_sum(j,i)=gradbufc(j,i)
 586         enddo
 587       enddo
 588 c      call MPI_AllReduce(gradbufc(1,1),gradbufc_sum(1,1),3*nres,
 589 c     &    MPI_DOUBLE_PRECISION,MPI_SUM,FG_COMM,IERR)
 590 c      time_reduce=time_reduce+MPI_Wtime()-time00
 591 #ifdef DEBUG
 592 c      write (iout,*) "gradbufc_sum after allreduce"
 593 c      do i=1,nres
 594 c        write (iout,'(i3,3f10.5)') i,(gradbufc_sum(j,i),j=1,3)
 595 c      enddo
 596 c      call flush(iout)
 597 #endif
 598 #ifdef TIMING
 599 c      time_allreduce=time_allreduce+MPI_Wtime()-time00
 600 #endif
 601       do i=nnt,nres
 602         do k=1,3
 603           gradbufc(k,i)=0.0d0
 604         enddo
 605       enddo
 606 #ifdef DEBUG
 607       write (iout,*) "igrad_start",igrad_start," igrad_end",igrad_end
 608       write (iout,*) (i," jgrad_start",jgrad_start(i),
 609      &                  " jgrad_end  ",jgrad_end(i),
 610      &                  i=igrad_start,igrad_end)
 611 #endif
 612 c
 613 c Obsolete and inefficient code; we can make the effort O(n) and, therefore,
 614 c do not parallelize this part.
 615 c
 616 c      do i=igrad_start,igrad_end
 617 c        do j=jgrad_start(i),jgrad_end(i)
 618 c          do k=1,3
 619 c            gradbufc(k,i)=gradbufc(k,i)+gradbufc_sum(k,j)
 620 c          enddo
 621 c        enddo
 622 c      enddo
 623       do j=1,3
 624         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
 625       enddo
 626       do i=nres-2,-1,-1
 627         do j=1,3
 628           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
 629         enddo
 630       enddo
 631 #ifdef DEBUG
 632       write (iout,*) "gradbufc after summing"
 633       do i=1,nres
 634         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 635       enddo
 636       call flush(iout)
 637 #endif
 638       else
 639 #endif
 640 #ifdef DEBUG
 641       write (iout,*) "gradbufc"
 642       do i=1,nres
 643         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 644       enddo
 645       call flush(iout)
 646 #endif
 647       do i=-1,nres
 648         do j=1,3
 649           gradbufc_sum(j,i)=gradbufc(j,i)
 650           gradbufc(j,i)=0.0d0
 651         enddo
 652       enddo
 653       do j=1,3
 654         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
 655       enddo
 656       do i=nres-2,-1,-1
 657         do j=1,3
 658           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
 659         enddo
 660       enddo
 661 c      do i=nnt,nres-1
 662 c        do k=1,3
 663 c          gradbufc(k,i)=0.0d0
 664 c        enddo
 665 c        do j=i+1,nres
 666 c          do k=1,3
 667 c            gradbufc(k,i)=gradbufc(k,i)+gradbufc(k,j)
 668 c          enddo
 669 c        enddo
 670 c      enddo
 671 #ifdef DEBUG
 672       write (iout,*) "gradbufc after summing"
 673       do i=1,nres
 674         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 675       enddo
 676       call flush(iout)
 677 #endif
 678 #ifdef MPI
 679       endif
 680 #endif
 681       do k=1,3
 682         gradbufc(k,nres)=0.0d0
 683       enddo
 684       do i=-1,nct
 685         do j=1,3
 686 #ifdef SPLITELE
 687 C          print *,gradbufc(1,13)
 688 C          print *,welec*gelc(1,13)
 689 C          print *,wel_loc*gel_loc(1,13)
 690 C          print *,0.5d0*(wscp*gvdwc_scpp(1,13))
 691 C          print *,welec*gelc_long(1,13)+wvdwpp*gvdwpp(1,13)
 692 C          print *,wel_loc*gel_loc_long(1,13)
 693 C          print *,gradafm(1,13),"AFM"
 694           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+
 695      &                wel_loc*gel_loc(j,i)+
 696      &                0.5d0*(wscp*gvdwc_scpp(j,i)+
 697      &                welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+
 698      &                wel_loc*gel_loc_long(j,i)+
 699      &                wcorr*gradcorr_long(j,i)+
 700      &                wcorr5*gradcorr5_long(j,i)+
 701      &                wcorr6*gradcorr6_long(j,i)+
 702      &                wturn6*gcorr6_turn_long(j,i))+
 703      &                wbond*gradb(j,i)+
 704      &                wcorr*gradcorr(j,i)+
 705      &                wturn3*gcorr3_turn(j,i)+
 706      &                wturn4*gcorr4_turn(j,i)+
 707      &                wcorr5*gradcorr5(j,i)+
 708      &                wcorr6*gradcorr6(j,i)+
 709      &                wturn6*gcorr6_turn(j,i)+
 710      &                wsccor*gsccorc(j,i)
 711      &               +wscloc*gscloc(j,i)
 712      &               +wliptran*gliptranc(j,i)
 713      &                +gradafm(j,i)
 714      &                 +welec*gshieldc(j,i)
 715      &                 +welec*gshieldc_loc(j,i)
 716
 717
 718 #else
 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)
 723      &                wel_loc*gel_loc_long(j,i)+
 724      &                wcorr*gcorr_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      &                 +welec*gshieldc(j,i)
 740      &                 +welec*gshieldc_loc(j,i)
 741
 742
 743 #endif
 744           gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+
 745      &                  wbond*gradbx(j,i)+
 746      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
 747      &                  wsccor*gsccorx(j,i)
 748      &                 +wscloc*gsclocx(j,i)
 749      &                 +wliptran*gliptranx(j,i)
 750      &                 +welec*gshieldx(j,i)
 751         enddo
 752       enddo
 753 #ifdef DEBUG
 754       write (iout,*) "gloc before adding corr"
 755       do i=1,4*nres
 756         write (iout,*) i,gloc(i,icg)
 757       enddo
 758 #endif
 759       do i=1,nres-3
 760         gloc(i,icg)=gloc(i,icg)+wcorr*gcorr_loc(i)
 761      &   +wcorr5*g_corr5_loc(i)
 762      &   +wcorr6*g_corr6_loc(i)
 763      &   +wturn4*gel_loc_turn4(i)
 764      &   +wturn3*gel_loc_turn3(i)
 765      &   +wturn6*gel_loc_turn6(i)
 766      &   +wel_loc*gel_loc_loc(i)
 767       enddo
 768 #ifdef DEBUG
 769       write (iout,*) "gloc after adding corr"
 770       do i=1,4*nres
 771         write (iout,*) i,gloc(i,icg)
 772       enddo
 773 #endif
 774 #ifdef MPI
 775       if (nfgtasks.gt.1) then
 776         do j=1,3
 777           do i=1,nres
 778             gradbufc(j,i)=gradc(j,i,icg)
 779             gradbufx(j,i)=gradx(j,i,icg)
 780           enddo
 781         enddo
 782         do i=1,4*nres
 783           glocbuf(i)=gloc(i,icg)
 784         enddo
 785 c#define DEBUG
 786 #ifdef DEBUG
 787       write (iout,*) "gloc_sc before reduce"
 788       do i=1,nres
 789        do j=1,1
 790         write (iout,*) i,j,gloc_sc(j,i,icg)
 791        enddo
 792       enddo
 793 #endif
 794 c#undef DEBUG
 795         do i=1,nres
 796          do j=1,3
 797           gloc_scbuf(j,i)=gloc_sc(j,i,icg)
 798          enddo
 799         enddo
 800         time00=MPI_Wtime()
 801         call MPI_Barrier(FG_COMM,IERR)
 802         time_barrier_g=time_barrier_g+MPI_Wtime()-time00
 803         time00=MPI_Wtime()
 804         call MPI_Reduce(gradbufc(1,1),gradc(1,1,icg),3*nres,
 805      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 806         call MPI_Reduce(gradbufx(1,1),gradx(1,1,icg),3*nres,
 807      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 808         call MPI_Reduce(glocbuf(1),gloc(1,icg),4*nres,
 809      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 810         time_reduce=time_reduce+MPI_Wtime()-time00
 811         call MPI_Reduce(gloc_scbuf(1,1),gloc_sc(1,1,icg),3*nres,
 812      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 813         time_reduce=time_reduce+MPI_Wtime()-time00
 814 c#define DEBUG
 815 #ifdef DEBUG
 816       write (iout,*) "gloc_sc after reduce"
 817       do i=1,nres
 818        do j=1,1
 819         write (iout,*) i,j,gloc_sc(j,i,icg)
 820        enddo
 821       enddo
 822 #endif
 823 c#undef DEBUG
 824 #ifdef DEBUG
 825       write (iout,*) "gloc after reduce"
 826       do i=1,4*nres
 827         write (iout,*) i,gloc(i,icg)
 828       enddo
 829 #endif
 830       endif
 831 #endif
 832       if (gnorm_check) then
 833 c
 834 c Compute the maximum elements of the gradient
 835 c
 836       gvdwc_max=0.0d0
 837       gvdwc_scp_max=0.0d0
 838       gelc_max=0.0d0
 839       gvdwpp_max=0.0d0
 840       gradb_max=0.0d0
 841       ghpbc_max=0.0d0
 842       gradcorr_max=0.0d0
 843       gel_loc_max=0.0d0
 844       gcorr3_turn_max=0.0d0
 845       gcorr4_turn_max=0.0d0
 846       gradcorr5_max=0.0d0
 847       gradcorr6_max=0.0d0
 848       gcorr6_turn_max=0.0d0
 849       gsccorc_max=0.0d0
 850       gscloc_max=0.0d0
 851       gvdwx_max=0.0d0
 852       gradx_scp_max=0.0d0
 853       ghpbx_max=0.0d0
 854       gradxorr_max=0.0d0
 855       gsccorx_max=0.0d0
 856       gsclocx_max=0.0d0
 857       do i=1,nct
 858         gvdwc_norm=dsqrt(scalar(gvdwc(1,i),gvdwc(1,i)))
 859         if (gvdwc_norm.gt.gvdwc_max) gvdwc_max=gvdwc_norm
 860         gvdwc_scp_norm=dsqrt(scalar(gvdwc_scp(1,i),gvdwc_scp(1,i)))
 861         if (gvdwc_scp_norm.gt.gvdwc_scp_max)
 862      &   gvdwc_scp_max=gvdwc_scp_norm
 863         gelc_norm=dsqrt(scalar(gelc(1,i),gelc(1,i)))
 864         if (gelc_norm.gt.gelc_max) gelc_max=gelc_norm
 865         gvdwpp_norm=dsqrt(scalar(gvdwpp(1,i),gvdwpp(1,i)))
 866         if (gvdwpp_norm.gt.gvdwpp_max) gvdwpp_max=gvdwpp_norm
 867         gradb_norm=dsqrt(scalar(gradb(1,i),gradb(1,i)))
 868         if (gradb_norm.gt.gradb_max) gradb_max=gradb_norm
 869         ghpbc_norm=dsqrt(scalar(ghpbc(1,i),ghpbc(1,i)))
 870         if (ghpbc_norm.gt.ghpbc_max) ghpbc_max=ghpbc_norm
 871         gradcorr_norm=dsqrt(scalar(gradcorr(1,i),gradcorr(1,i)))
 872         if (gradcorr_norm.gt.gradcorr_max) gradcorr_max=gradcorr_norm
 873         gel_loc_norm=dsqrt(scalar(gel_loc(1,i),gel_loc(1,i)))
 874         if (gel_loc_norm.gt.gel_loc_max) gel_loc_max=gel_loc_norm
 875         gcorr3_turn_norm=dsqrt(scalar(gcorr3_turn(1,i),
 876      &    gcorr3_turn(1,i)))
 877         if (gcorr3_turn_norm.gt.gcorr3_turn_max)
 878      &    gcorr3_turn_max=gcorr3_turn_norm
 879         gcorr4_turn_norm=dsqrt(scalar(gcorr4_turn(1,i),
 880      &    gcorr4_turn(1,i)))
 881         if (gcorr4_turn_norm.gt.gcorr4_turn_max)
 882      &    gcorr4_turn_max=gcorr4_turn_norm
 883         gradcorr5_norm=dsqrt(scalar(gradcorr5(1,i),gradcorr5(1,i)))
 884         if (gradcorr5_norm.gt.gradcorr5_max)
 885      &    gradcorr5_max=gradcorr5_norm
 886         gradcorr6_norm=dsqrt(scalar(gradcorr6(1,i),gradcorr6(1,i)))
 887         if (gradcorr6_norm.gt.gradcorr6_max) gcorr6_max=gradcorr6_norm
 888         gcorr6_turn_norm=dsqrt(scalar(gcorr6_turn(1,i),
 889      &    gcorr6_turn(1,i)))
 890         if (gcorr6_turn_norm.gt.gcorr6_turn_max)
 891      &    gcorr6_turn_max=gcorr6_turn_norm
 892         gsccorr_norm=dsqrt(scalar(gsccorc(1,i),gsccorc(1,i)))
 893         if (gsccorr_norm.gt.gsccorr_max) gsccorr_max=gsccorr_norm
 894         gscloc_norm=dsqrt(scalar(gscloc(1,i),gscloc(1,i)))
 895         if (gscloc_norm.gt.gscloc_max) gscloc_max=gscloc_norm
 896         gvdwx_norm=dsqrt(scalar(gvdwx(1,i),gvdwx(1,i)))
 897         if (gvdwx_norm.gt.gvdwx_max) gvdwx_max=gvdwx_norm
 898         gradx_scp_norm=dsqrt(scalar(gradx_scp(1,i),gradx_scp(1,i)))
 899         if (gradx_scp_norm.gt.gradx_scp_max)
 900      &    gradx_scp_max=gradx_scp_norm
 901         ghpbx_norm=dsqrt(scalar(ghpbx(1,i),ghpbx(1,i)))
 902         if (ghpbx_norm.gt.ghpbx_max) ghpbx_max=ghpbx_norm
 903         gradxorr_norm=dsqrt(scalar(gradxorr(1,i),gradxorr(1,i)))
 904         if (gradxorr_norm.gt.gradxorr_max) gradxorr_max=gradxorr_norm
 905         gsccorrx_norm=dsqrt(scalar(gsccorx(1,i),gsccorx(1,i)))
 906         if (gsccorrx_norm.gt.gsccorrx_max) gsccorrx_max=gsccorrx_norm
 907         gsclocx_norm=dsqrt(scalar(gsclocx(1,i),gsclocx(1,i)))
 908         if (gsclocx_norm.gt.gsclocx_max) gsclocx_max=gsclocx_norm
 909       enddo
 910       if (gradout) then
 911 #ifdef AIX
 912         open(istat,file=statname,position="append")
 913 #else
 914         open(istat,file=statname,access="append")
 915 #endif
 916         write (istat,'(1h#,21f10.2)') gvdwc_max,gvdwc_scp_max,
 917      &     gelc_max,gvdwpp_max,gradb_max,ghpbc_max,
 918      &     gradcorr_max,gel_loc_max,gcorr3_turn_max,gcorr4_turn_max,
 919      &     gradcorr5_max,gradcorr6_max,gcorr6_turn_max,gsccorc_max,
 920      &     gscloc_max,gvdwx_max,gradx_scp_max,ghpbx_max,gradxorr_max,
 921      &     gsccorx_max,gsclocx_max
 922         close(istat)
 923         if (gvdwc_max.gt.1.0d4) then
 924           write (iout,*) "gvdwc gvdwx gradb gradbx"
 925           do i=nnt,nct
 926             write(iout,'(i5,4(3f10.2,5x))') i,(gvdwc(j,i),gvdwx(j,i),
 927      &        gradb(j,i),gradbx(j,i),j=1,3)
 928           enddo
 929           call pdbout(0.0d0,'cipiszcze',iout)
 930           call flush(iout)
 931         endif
 932       endif
 933       endif
 934 #ifdef DEBUG
 935       write (iout,*) "gradc gradx gloc"
 936       do i=1,nres
 937         write (iout,'(i5,3f10.5,5x,3f10.5,5x,f10.5)')
 938      &   i,(gradc(j,i,icg),j=1,3),(gradx(j,i,icg),j=1,3),gloc(i,icg)
 939       enddo
 940 #endif
 941 #ifdef TIMING
 942       time_sumgradient=time_sumgradient+MPI_Wtime()-time01
 943 #endif
 944       return
 945       end
 946 c-------------------------------------------------------------------------------
 947       subroutine rescale_weights(t_bath)
 948       implicit real*8 (a-h,o-z)
 949       include 'DIMENSIONS'
 950       include 'COMMON.IOUNITS'
 951       include 'COMMON.FFIELD'
 952       include 'COMMON.SBRIDGE'
 953       double precision kfac /2.4d0/
 954       double precision x,x2,x3,x4,x5,licznik /1.12692801104297249644/
 955 c      facT=temp0/t_bath
 956 c      facT=2*temp0/(t_bath+temp0)
 957       if (rescale_mode.eq.0) then
 958         facT=1.0d0
 959         facT2=1.0d0
 960         facT3=1.0d0
 961         facT4=1.0d0
 962         facT5=1.0d0
 963       else if (rescale_mode.eq.1) then
 964         facT=kfac/(kfac-1.0d0+t_bath/temp0)
 965         facT2=kfac**2/(kfac**2-1.0d0+(t_bath/temp0)**2)
 966         facT3=kfac**3/(kfac**3-1.0d0+(t_bath/temp0)**3)
 967         facT4=kfac**4/(kfac**4-1.0d0+(t_bath/temp0)**4)
 968         facT5=kfac**5/(kfac**5-1.0d0+(t_bath/temp0)**5)
 969       else if (rescale_mode.eq.2) then
 970         x=t_bath/temp0
 971         x2=x*x
 972         x3=x2*x
 973         x4=x3*x
 974         x5=x4*x
 975         facT=licznik/dlog(dexp(x)+dexp(-x))
 976         facT2=licznik/dlog(dexp(x2)+dexp(-x2))
 977         facT3=licznik/dlog(dexp(x3)+dexp(-x3))
 978         facT4=licznik/dlog(dexp(x4)+dexp(-x4))
 979         facT5=licznik/dlog(dexp(x5)+dexp(-x5))
 980       else
 981         write (iout,*) "Wrong RESCALE_MODE",rescale_mode
 982         write (*,*) "Wrong RESCALE_MODE",rescale_mode
 983 #ifdef MPI
 984        call MPI_Finalize(MPI_COMM_WORLD,IERROR)
 985 #endif
 986        stop 555
 987       endif
 988       welec=weights(3)*fact
 989       wcorr=weights(4)*fact3
 990       wcorr5=weights(5)*fact4
 991       wcorr6=weights(6)*fact5
 992       wel_loc=weights(7)*fact2
 993       wturn3=weights(8)*fact2
 994       wturn4=weights(9)*fact3
 995       wturn6=weights(10)*fact5
 996       wtor=weights(13)*fact
 997       wtor_d=weights(14)*fact2
 998       wsccor=weights(21)*fact
 999
1000       return
1001       end
1002 C------------------------------------------------------------------------
1003       subroutine enerprint(energia)
1004       implicit real*8 (a-h,o-z)
1005       include 'DIMENSIONS'
1006       include 'COMMON.IOUNITS'
1007       include 'COMMON.FFIELD'
1008       include 'COMMON.SBRIDGE'
1009       include 'COMMON.MD'
1010       double precision energia(0:n_ene)
1011       etot=energia(0)
1012       evdw=energia(1)
1013       evdw2=energia(2)
1014 #ifdef SCP14
1015       evdw2=energia(2)+energia(18)
1016 #else
1017       evdw2=energia(2)
1018 #endif
1019       ees=energia(3)
1020 #ifdef SPLITELE
1021       evdw1=energia(16)
1022 #endif
1023       ecorr=energia(4)
1024       ecorr5=energia(5)
1025       ecorr6=energia(6)
1026       eel_loc=energia(7)
1027       eello_turn3=energia(8)
1028       eello_turn4=energia(9)
1029       eello_turn6=energia(10)
1030       ebe=energia(11)
1031       escloc=energia(12)
1032       etors=energia(13)
1033       etors_d=energia(14)
1034       ehpb=energia(15)
1035       edihcnstr=energia(19)
1036       estr=energia(17)
1037       Uconst=energia(20)
1038       esccor=energia(21)
1039       eliptran=energia(22)
1040       Eafmforce=energia(23)
1041       ethetacnstr=energia(24)
1042 #ifdef SPLITELE
1043       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,evdw1,wvdwpp,
1044      &  estr,wbond,ebe,wang,
1045      &  escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,
1046      &  ecorr,wcorr,
1047      &  ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,
1048      &  eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccro,edihcnstr,
1049      &  ethetacnstr,ebr*nss,Uconst,eliptran,wliptran,Eafmforc,
1050      &  etot
1051    10 format (/'Virtual-chain energies:'//
1052      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
1053      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
1054      & 'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/
1055      & 'EVDWPP=',1pE16.6,' WEIGHT=',1pD16.6,' (p-p VDW)'/
1056      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
1057      & 'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
1058      & 'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
1059      & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
1060      & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
1061      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6,
1062      & ' (SS bridges & dist. cnstr.)'/
1063      & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1064      & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1065      & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1066      & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
1067      & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
1068      & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
1069      & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
1070      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
1071      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
1072      & 'ETHETC= ',1pE16.6,' (valence angle constraints)'/
1073      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
1074      & 'UCONST= ',1pE16.6,' (Constraint energy)'/
1075      & 'ELT=',1pE16.6, ' WEIGHT=',1pD16.6,' (Lipid transfer energy)'/
1076      & 'EAFM=  ',1pE16.6,' (atomic-force microscopy)'/
1077      & 'ETOT=  ',1pE16.6,' (total)')
1078
1079 #else
1080       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,
1081      &  estr,wbond,ebe,wang,
1082      &  escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,
1083      &  ecorr,wcorr,
1084      &  ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,
1085      &  eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccro,edihcnstr,
1086      &  ethetacnstr,ebr*nss,Uconst,eliptran,wliptran,Eafmforc,
1087      &  etot
1088    10 format (/'Virtual-chain energies:'//
1089      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
1090      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
1091      & 'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/
1092      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
1093      & 'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
1094      & 'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
1095      & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
1096      & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
1097      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6,
1098      & ' (SS bridges & dist. cnstr.)'/
1099      & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1100      & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1101      & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1102      & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
1103      & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
1104      & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
1105      & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
1106      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
1107      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
1108      & 'ETHETC= ',1pE16.6,' (valence angle constraints)'/
1109      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
1110      & 'UCONST=',1pE16.6,' (Constraint energy)'/
1111      & 'ELT=',1pE16.6, ' WEIGHT=',1pD16.6,' (Lipid transfer energy)'/
1112      & 'EAFM=  ',1pE16.6,' (atomic-force microscopy)'/
1113      & 'ETOT=  ',1pE16.6,' (total)')
1114 #endif
1115       return
1116       end
1117 C-----------------------------------------------------------------------
1118       subroutine elj(evdw)
1119 C
1120 C This subroutine calculates the interaction energy of nonbonded side chains
1121 C assuming the LJ potential of interaction.
1122 C
1123       implicit real*8 (a-h,o-z)
1124       include 'DIMENSIONS'
1125       parameter (accur=1.0d-10)
1126       include 'COMMON.GEO'
1127       include 'COMMON.VAR'
1128       include 'COMMON.LOCAL'
1129       include 'COMMON.CHAIN'
1130       include 'COMMON.DERIV'
1131       include 'COMMON.INTERACT'
1132       include 'COMMON.TORSION'
1133       include 'COMMON.SBRIDGE'
1134       include 'COMMON.NAMES'
1135       include 'COMMON.IOUNITS'
1136       include 'COMMON.CONTACTS'
1137       dimension gg(3)
1138 c      write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
1139       evdw=0.0D0
1140       do i=iatsc_s,iatsc_e
1141         itypi=iabs(itype(i))
1142         if (itypi.eq.ntyp1) cycle
1143         itypi1=iabs(itype(i+1))
1144         xi=c(1,nres+i)
1145         yi=c(2,nres+i)
1146         zi=c(3,nres+i)
1147 C Change 12/1/95
1148         num_conti=0
1149 C
1150 C Calculate SC interaction energy.
1151 C
1152         do iint=1,nint_gr(i)
1153 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
1154 cd   &                  'iend=',iend(i,iint)
1155           do j=istart(i,iint),iend(i,iint)
1156             itypj=iabs(itype(j))
1157             if (itypj.eq.ntyp1) cycle
1158             xj=c(1,nres+j)-xi
1159             yj=c(2,nres+j)-yi
1160             zj=c(3,nres+j)-zi
1161 C Change 12/1/95 to calculate four-body interactions
1162             rij=xj*xj+yj*yj+zj*zj
1163             rrij=1.0D0/rij
1164 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
1165             eps0ij=eps(itypi,itypj)
1166             fac=rrij**expon2
1167 C have you changed here?
1168             e1=fac*fac*aa
1169             e2=fac*bb
1170             evdwij=e1+e2
1171 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1172 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1173 cd          write (iout,'(2(a3,i3,2x),6(1pd12.4)/2(3(1pd12.4),5x)/)')
1174 cd   &        restyp(itypi),i,restyp(itypj),j,a(itypi,itypj),
1175 cd   &        bb(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,epsi,sigm,
1176 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1177             evdw=evdw+evdwij
1178 C
1179 C Calculate the components of the gradient in DC and X
1180 C
1181             fac=-rrij*(e1+evdwij)
1182             gg(1)=xj*fac
1183             gg(2)=yj*fac
1184             gg(3)=zj*fac
1185             do k=1,3
1186               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1187               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1188               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1189               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1190             enddo
1191 cgrad            do k=i,j-1
1192 cgrad              do l=1,3
1193 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1194 cgrad              enddo
1195 cgrad            enddo
1196 C
1197 C 12/1/95, revised on 5/20/97
1198 C
1199 C Calculate the contact function. The ith column of the array JCONT will
1200 C contain the numbers of atoms that make contacts with the atom I (of numbers
1201 C greater than I). The arrays FACONT and GACONT will contain the values of
1202 C the contact function and its derivative.
1203 C
1204 C Uncomment next line, if the correlation interactions include EVDW explicitly.
1205 c           if (j.gt.i+1 .and. evdwij.le.0.0D0) then
1206 C Uncomment next line, if the correlation interactions are contact function only
1207             if (j.gt.i+1.and. eps0ij.gt.0.0D0) then
1208               rij=dsqrt(rij)
1209               sigij=sigma(itypi,itypj)
1210               r0ij=rs0(itypi,itypj)
1211 C
1212 C Check whether the SC's are not too far to make a contact.
1213 C
1214               rcut=1.5d0*r0ij
1215               call gcont(rij,rcut,1.0d0,0.2d0*rcut,fcont,fprimcont)
1216 C Add a new contact, if the SC's are close enough, but not too close (r<sigma).
1217 C
1218               if (fcont.gt.0.0D0) then
1219 C If the SC-SC distance if close to sigma, apply spline.
1220 cAdam           call gcont(-rij,-1.03d0*sigij,2.0d0*sigij,1.0d0,
1221 cAdam &             fcont1,fprimcont1)
1222 cAdam           fcont1=1.0d0-fcont1
1223 cAdam           if (fcont1.gt.0.0d0) then
1224 cAdam             fprimcont=fprimcont*fcont1+fcont*fprimcont1
1225 cAdam             fcont=fcont*fcont1
1226 cAdam           endif
1227 C Uncomment following 4 lines to have the geometric average of the epsilon0's
1228 cga             eps0ij=1.0d0/dsqrt(eps0ij)
1229 cga             do k=1,3
1230 cga               gg(k)=gg(k)*eps0ij
1231 cga             enddo
1232 cga             eps0ij=-evdwij*eps0ij
1233 C Uncomment for AL's type of SC correlation interactions.
1234 cadam           eps0ij=-evdwij
1235                 num_conti=num_conti+1
1236                 jcont(num_conti,i)=j
1237                 facont(num_conti,i)=fcont*eps0ij
1238                 fprimcont=eps0ij*fprimcont/rij
1239                 fcont=expon*fcont
1240 cAdam           gacont(1,num_conti,i)=-fprimcont*xj+fcont*gg(1)
1241 cAdam           gacont(2,num_conti,i)=-fprimcont*yj+fcont*gg(2)
1242 cAdam           gacont(3,num_conti,i)=-fprimcont*zj+fcont*gg(3)
1243 C Uncomment following 3 lines for Skolnick's type of SC correlation.
1244                 gacont(1,num_conti,i)=-fprimcont*xj
1245                 gacont(2,num_conti,i)=-fprimcont*yj
1246                 gacont(3,num_conti,i)=-fprimcont*zj
1247 cd              write (iout,'(2i5,2f10.5)') i,j,rij,facont(num_conti,i)
1248 cd              write (iout,'(2i3,3f10.5)')
1249 cd   &           i,j,(gacont(kk,num_conti,i),kk=1,3)
1250               endif
1251             endif
1252           enddo      ! j
1253         enddo        ! iint
1254 C Change 12/1/95
1255         num_cont(i)=num_conti
1256       enddo          ! i
1257       do i=1,nct
1258         do j=1,3
1259           gvdwc(j,i)=expon*gvdwc(j,i)
1260           gvdwx(j,i)=expon*gvdwx(j,i)
1261         enddo
1262       enddo
1263 C******************************************************************************
1264 C
1265 C                              N O T E !!!
1266 C
1267 C To save time, the factor of EXPON has been extracted from ALL components
1268 C of GVDWC and GRADX. Remember to multiply them by this factor before further
1269 C use!
1270 C
1271 C******************************************************************************
1272       return
1273       end
1274 C-----------------------------------------------------------------------------
1275       subroutine eljk(evdw)
1276 C
1277 C This subroutine calculates the interaction energy of nonbonded side chains
1278 C assuming the LJK potential of interaction.
1279 C
1280       implicit real*8 (a-h,o-z)
1281       include 'DIMENSIONS'
1282       include 'COMMON.GEO'
1283       include 'COMMON.VAR'
1284       include 'COMMON.LOCAL'
1285       include 'COMMON.CHAIN'
1286       include 'COMMON.DERIV'
1287       include 'COMMON.INTERACT'
1288       include 'COMMON.IOUNITS'
1289       include 'COMMON.NAMES'
1290       dimension gg(3)
1291       logical scheck
1292 c     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
1293       evdw=0.0D0
1294       do i=iatsc_s,iatsc_e
1295         itypi=iabs(itype(i))
1296         if (itypi.eq.ntyp1) cycle
1297         itypi1=iabs(itype(i+1))
1298         xi=c(1,nres+i)
1299         yi=c(2,nres+i)
1300         zi=c(3,nres+i)
1301 C
1302 C Calculate SC interaction energy.
1303 C
1304         do iint=1,nint_gr(i)
1305           do j=istart(i,iint),iend(i,iint)
1306             itypj=iabs(itype(j))
1307             if (itypj.eq.ntyp1) cycle
1308             xj=c(1,nres+j)-xi
1309             yj=c(2,nres+j)-yi
1310             zj=c(3,nres+j)-zi
1311             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1312             fac_augm=rrij**expon
1313             e_augm=augm(itypi,itypj)*fac_augm
1314             r_inv_ij=dsqrt(rrij)
1315             rij=1.0D0/r_inv_ij
1316             r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
1317             fac=r_shift_inv**expon
1318 C have you changed here?
1319             e1=fac*fac*aa
1320             e2=fac*bb
1321             evdwij=e_augm+e1+e2
1322 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1323 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1324 cd          write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
1325 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
1326 cd   &        bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
1327 cd   &        sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
1328 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1329             evdw=evdw+evdwij
1330 C
1331 C Calculate the components of the gradient in DC and X
1332 C
1333             fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
1334             gg(1)=xj*fac
1335             gg(2)=yj*fac
1336             gg(3)=zj*fac
1337             do k=1,3
1338               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1339               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1340               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1341               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1342             enddo
1343 cgrad            do k=i,j-1
1344 cgrad              do l=1,3
1345 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1346 cgrad              enddo
1347 cgrad            enddo
1348           enddo      ! j
1349         enddo        ! iint
1350       enddo          ! i
1351       do i=1,nct
1352         do j=1,3
1353           gvdwc(j,i)=expon*gvdwc(j,i)
1354           gvdwx(j,i)=expon*gvdwx(j,i)
1355         enddo
1356       enddo
1357       return
1358       end
1359 C-----------------------------------------------------------------------------
1360       subroutine ebp(evdw)
1361 C
1362 C This subroutine calculates the interaction energy of nonbonded side chains
1363 C assuming the Berne-Pechukas potential of interaction.
1364 C
1365       implicit real*8 (a-h,o-z)
1366       include 'DIMENSIONS'
1367       include 'COMMON.GEO'
1368       include 'COMMON.VAR'
1369       include 'COMMON.LOCAL'
1370       include 'COMMON.CHAIN'
1371       include 'COMMON.DERIV'
1372       include 'COMMON.NAMES'
1373       include 'COMMON.INTERACT'
1374       include 'COMMON.IOUNITS'
1375       include 'COMMON.CALC'
1376       common /srutu/ icall
1377 c     double precision rrsave(maxdim)
1378       logical lprn
1379       evdw=0.0D0
1380 c     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
1381       evdw=0.0D0
1382 c     if (icall.eq.0) then
1383 c       lprn=.true.
1384 c     else
1385         lprn=.false.
1386 c     endif
1387       ind=0
1388       do i=iatsc_s,iatsc_e
1389         itypi=iabs(itype(i))
1390         if (itypi.eq.ntyp1) cycle
1391         itypi1=iabs(itype(i+1))
1392         xi=c(1,nres+i)
1393         yi=c(2,nres+i)
1394         zi=c(3,nres+i)
1395         dxi=dc_norm(1,nres+i)
1396         dyi=dc_norm(2,nres+i)
1397         dzi=dc_norm(3,nres+i)
1398 c        dsci_inv=dsc_inv(itypi)
1399         dsci_inv=vbld_inv(i+nres)
1400 C
1401 C Calculate SC interaction energy.
1402 C
1403         do iint=1,nint_gr(i)
1404           do j=istart(i,iint),iend(i,iint)
1405             ind=ind+1
1406             itypj=iabs(itype(j))
1407             if (itypj.eq.ntyp1) cycle
1408 c            dscj_inv=dsc_inv(itypj)
1409             dscj_inv=vbld_inv(j+nres)
1410             chi1=chi(itypi,itypj)
1411             chi2=chi(itypj,itypi)
1412             chi12=chi1*chi2
1413             chip1=chip(itypi)
1414             chip2=chip(itypj)
1415             chip12=chip1*chip2
1416             alf1=alp(itypi)
1417             alf2=alp(itypj)
1418             alf12=0.5D0*(alf1+alf2)
1419 C For diagnostics only!!!
1420 c           chi1=0.0D0
1421 c           chi2=0.0D0
1422 c           chi12=0.0D0
1423 c           chip1=0.0D0
1424 c           chip2=0.0D0
1425 c           chip12=0.0D0
1426 c           alf1=0.0D0
1427 c           alf2=0.0D0
1428 c           alf12=0.0D0
1429             xj=c(1,nres+j)-xi
1430             yj=c(2,nres+j)-yi
1431             zj=c(3,nres+j)-zi
1432             dxj=dc_norm(1,nres+j)
1433             dyj=dc_norm(2,nres+j)
1434             dzj=dc_norm(3,nres+j)
1435             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1436 cd          if (icall.eq.0) then
1437 cd            rrsave(ind)=rrij
1438 cd          else
1439 cd            rrij=rrsave(ind)
1440 cd          endif
1441             rij=dsqrt(rrij)
1442 C Calculate the angle-dependent terms of energy & contributions to derivatives.
1443             call sc_angular
1444 C Calculate whole angle-dependent part of epsilon and contributions
1445 C to its derivatives
1446 C have you changed here?
1447             fac=(rrij*sigsq)**expon2
1448             e1=fac*fac*aa
1449             e2=fac*bb
1450             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1451             eps2der=evdwij*eps3rt
1452             eps3der=evdwij*eps2rt
1453             evdwij=evdwij*eps2rt*eps3rt
1454             evdw=evdw+evdwij
1455             if (lprn) then
1456             sigm=dabs(aa/bb)**(1.0D0/6.0D0)
1457             epsi=bb**2/aa
1458 cd            write (iout,'(2(a3,i3,2x),15(0pf7.3))')
1459 cd     &        restyp(itypi),i,restyp(itypj),j,
1460 cd     &        epsi,sigm,chi1,chi2,chip1,chip2,
1461 cd     &        eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
1462 cd     &        om1,om2,om12,1.0D0/dsqrt(rrij),
1463 cd     &        evdwij
1464             endif
1465 C Calculate gradient components.
1466             e1=e1*eps1*eps2rt**2*eps3rt**2
1467             fac=-expon*(e1+evdwij)
1468             sigder=fac/sigsq
1469             fac=rrij*fac
1470 C Calculate radial part of the gradient
1471             gg(1)=xj*fac
1472             gg(2)=yj*fac
1473             gg(3)=zj*fac
1474 C Calculate the angular part of the gradient and sum add the contributions
1475 C to the appropriate components of the Cartesian gradient.
1476             call sc_grad
1477           enddo      ! j
1478         enddo        ! iint
1479       enddo          ! i
1480 c     stop
1481       return
1482       end
1483 C-----------------------------------------------------------------------------
1484       subroutine egb(evdw)
1485 C
1486 C This subroutine calculates the interaction energy of nonbonded side chains
1487 C assuming the Gay-Berne potential of interaction.
1488 C
1489       implicit real*8 (a-h,o-z)
1490       include 'DIMENSIONS'
1491       include 'COMMON.GEO'
1492       include 'COMMON.VAR'
1493       include 'COMMON.LOCAL'
1494       include 'COMMON.CHAIN'
1495       include 'COMMON.DERIV'
1496       include 'COMMON.NAMES'
1497       include 'COMMON.INTERACT'
1498       include 'COMMON.IOUNITS'
1499       include 'COMMON.CALC'
1500       include 'COMMON.CONTROL'
1501       include 'COMMON.SPLITELE'
1502       include 'COMMON.SBRIDGE'
1503       logical lprn
1504       integer xshift,yshift,zshift
1505
1506       evdw=0.0D0
1507 ccccc      energy_dec=.false.
1508 C      print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1509       evdw=0.0D0
1510       lprn=.false.
1511 c     if (icall.eq.0) lprn=.false.
1512       ind=0
1513 C the loop over all 27 posible neigbours (for xshift=0,yshift=0,zshift=0
1514 C we have the original box)
1515 C      do xshift=-1,1
1516 C      do yshift=-1,1
1517 C      do zshift=-1,1
1518       do i=iatsc_s,iatsc_e
1519         itypi=iabs(itype(i))
1520         if (itypi.eq.ntyp1) cycle
1521         itypi1=iabs(itype(i+1))
1522         xi=c(1,nres+i)
1523         yi=c(2,nres+i)
1524         zi=c(3,nres+i)
1525 C Return atom into box, boxxsize is size of box in x dimension
1526 c  134   continue
1527 c        if (xi.gt.((xshift+0.5d0)*boxxsize)) xi=xi-boxxsize
1528 c        if (xi.lt.((xshift-0.5d0)*boxxsize)) xi=xi+boxxsize
1529 C Condition for being inside the proper box
1530 c        if ((xi.gt.((xshift+0.5d0)*boxxsize)).or.
1531 c     &       (xi.lt.((xshift-0.5d0)*boxxsize))) then
1532 c        go to 134
1533 c        endif
1534 c  135   continue
1535 c        if (yi.gt.((yshift+0.5d0)*boxysize)) yi=yi-boxysize
1536 c        if (yi.lt.((yshift-0.5d0)*boxysize)) yi=yi+boxysize
1537 C Condition for being inside the proper box
1538 c        if ((yi.gt.((yshift+0.5d0)*boxysize)).or.
1539 c     &       (yi.lt.((yshift-0.5d0)*boxysize))) then
1540 c        go to 135
1541 c        endif
1542 c  136   continue
1543 c        if (zi.gt.((zshift+0.5d0)*boxzsize)) zi=zi-boxzsize
1544 c        if (zi.lt.((zshift-0.5d0)*boxzsize)) zi=zi+boxzsize
1545 C Condition for being inside the proper box
1546 c        if ((zi.gt.((zshift+0.5d0)*boxzsize)).or.
1547 c     &       (zi.lt.((zshift-0.5d0)*boxzsize))) then
1548 c        go to 136
1549 c        endif
1550           xi=mod(xi,boxxsize)
1551           if (xi.lt.0) xi=xi+boxxsize
1552           yi=mod(yi,boxysize)
1553           if (yi.lt.0) yi=yi+boxysize
1554           zi=mod(zi,boxzsize)
1555           if (zi.lt.0) zi=zi+boxzsize
1556 C define scaling factor for lipids
1557
1558 C        if (positi.le.0) positi=positi+boxzsize
1559 C        print *,i
1560 C first for peptide groups
1561 c for each residue check if it is in lipid or lipid water border area
1562        if ((zi.gt.bordlipbot)
1563      &.and.(zi.lt.bordliptop)) then
1564 C the energy transfer exist
1565         if (zi.lt.buflipbot) then
1566 C what fraction I am in
1567          fracinbuf=1.0d0-
1568      &        ((zi-bordlipbot)/lipbufthick)
1569 C lipbufthick is thickenes of lipid buffore
1570          sslipi=sscalelip(fracinbuf)
1571          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
1572         elseif (zi.gt.bufliptop) then
1573          fracinbuf=1.0d0-((bordliptop-zi)/lipbufthick)
1574          sslipi=sscalelip(fracinbuf)
1575          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
1576         else
1577          sslipi=1.0d0
1578          ssgradlipi=0.0
1579         endif
1580        else
1581          sslipi=0.0d0
1582          ssgradlipi=0.0
1583        endif
1584
1585 C          xi=xi+xshift*boxxsize
1586 C          yi=yi+yshift*boxysize
1587 C          zi=zi+zshift*boxzsize
1588
1589         dxi=dc_norm(1,nres+i)
1590         dyi=dc_norm(2,nres+i)
1591         dzi=dc_norm(3,nres+i)
1592 c        dsci_inv=dsc_inv(itypi)
1593         dsci_inv=vbld_inv(i+nres)
1594 c        write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)
1595 c        write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi
1596 C
1597 C Calculate SC interaction energy.
1598 C
1599         do iint=1,nint_gr(i)
1600           do j=istart(i,iint),iend(i,iint)
1601             IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN
1602
1603 c              write(iout,*) "PRZED ZWYKLE", evdwij
1604               call dyn_ssbond_ene(i,j,evdwij)
1605 c              write(iout,*) "PO ZWYKLE", evdwij
1606
1607               evdw=evdw+evdwij
1608               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)')
1609      &                        'evdw',i,j,evdwij,' ss'
1610 C triple bond artifac removal
1611              do k=j+1,iend(i,iint)
1612 C search over all next residues
1613               if (dyn_ss_mask(k)) then
1614 C check if they are cysteins
1615 C              write(iout,*) 'k=',k
1616
1617 c              write(iout,*) "PRZED TRI", evdwij
1618                evdwij_przed_tri=evdwij
1619               call triple_ssbond_ene(i,j,k,evdwij)
1620 c               if(evdwij_przed_tri.ne.evdwij) then
1621 c                 write (iout,*) "TRI:", evdwij, evdwij_przed_tri
1622 c               endif
1623
1624 c              write(iout,*) "PO TRI", evdwij
1625 C call the energy function that removes the artifical triple disulfide
1626 C bond the soubroutine is located in ssMD.F
1627               evdw=evdw+evdwij
1628               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)')
1629      &                        'evdw',i,j,evdwij,'tss'
1630               endif!dyn_ss_mask(k)
1631              enddo! k
1632             ELSE
1633             ind=ind+1
1634             itypj=iabs(itype(j))
1635             if (itypj.eq.ntyp1) cycle
1636 c            dscj_inv=dsc_inv(itypj)
1637             dscj_inv=vbld_inv(j+nres)
1638 c            write (iout,*) "j",j,dsc_inv(itypj),dscj_inv,
1639 c     &       1.0d0/vbld(j+nres)
1640 c            write (iout,*) "i",i," j", j," itype",itype(i),itype(j)
1641             sig0ij=sigma(itypi,itypj)
1642             chi1=chi(itypi,itypj)
1643             chi2=chi(itypj,itypi)
1644             chi12=chi1*chi2
1645             chip1=chip(itypi)
1646             chip2=chip(itypj)
1647             chip12=chip1*chip2
1648             alf1=alp(itypi)
1649             alf2=alp(itypj)
1650             alf12=0.5D0*(alf1+alf2)
1651 C For diagnostics only!!!
1652 c           chi1=0.0D0
1653 c           chi2=0.0D0
1654 c           chi12=0.0D0
1655 c           chip1=0.0D0
1656 c           chip2=0.0D0
1657 c           chip12=0.0D0
1658 c           alf1=0.0D0
1659 c           alf2=0.0D0
1660 c           alf12=0.0D0
1661             xj=c(1,nres+j)
1662             yj=c(2,nres+j)
1663             zj=c(3,nres+j)
1664 C Return atom J into box the original box
1665 c  137   continue
1666 c        if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
1667 c        if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
1668 C Condition for being inside the proper box
1669 c        if ((xj.gt.((0.5d0)*boxxsize)).or.
1670 c     &       (xj.lt.((-0.5d0)*boxxsize))) then
1671 c        go to 137
1672 c        endif
1673 c  138   continue
1674 c        if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
1675 c        if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
1676 C Condition for being inside the proper box
1677 c        if ((yj.gt.((0.5d0)*boxysize)).or.
1678 c     &       (yj.lt.((-0.5d0)*boxysize))) then
1679 c        go to 138
1680 c        endif
1681 c  139   continue
1682 c        if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
1683 c        if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
1684 C Condition for being inside the proper box
1685 c        if ((zj.gt.((0.5d0)*boxzsize)).or.
1686 c     &       (zj.lt.((-0.5d0)*boxzsize))) then
1687 c        go to 139
1688 c        endif
1689           xj=mod(xj,boxxsize)
1690           if (xj.lt.0) xj=xj+boxxsize
1691           yj=mod(yj,boxysize)
1692           if (yj.lt.0) yj=yj+boxysize
1693           zj=mod(zj,boxzsize)
1694           if (zj.lt.0) zj=zj+boxzsize
1695        if ((zj.gt.bordlipbot)
1696      &.and.(zj.lt.bordliptop)) then
1697 C the energy transfer exist
1698         if (zj.lt.buflipbot) then
1699 C what fraction I am in
1700          fracinbuf=1.0d0-
1701      &        ((zj-bordlipbot)/lipbufthick)
1702 C lipbufthick is thickenes of lipid buffore
1703          sslipj=sscalelip(fracinbuf)
1704          ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
1705         elseif (zj.gt.bufliptop) then
1706          fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
1707          sslipj=sscalelip(fracinbuf)
1708          ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
1709         else
1710          sslipj=1.0d0
1711          ssgradlipj=0.0
1712         endif
1713        else
1714          sslipj=0.0d0
1715          ssgradlipj=0.0
1716        endif
1717       aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
1718      &  +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1719       bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
1720      &  +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1721 C      if (aa.ne.aa_aq(itypi,itypj)) write(63,'(2e10.5)')
1722 C     &(aa-aa_aq(itypi,itypj)),(bb-bb_aq(itypi,itypj))
1723 C      if (ssgradlipj.gt.0.0d0) print *,"??WTF??"
1724 C      print *,sslipi,sslipj,bordlipbot,zi,zj
1725       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
1726       xj_safe=xj
1727       yj_safe=yj
1728       zj_safe=zj
1729       subchap=0
1730       do xshift=-1,1
1731       do yshift=-1,1
1732       do zshift=-1,1
1733           xj=xj_safe+xshift*boxxsize
1734           yj=yj_safe+yshift*boxysize
1735           zj=zj_safe+zshift*boxzsize
1736           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
1737           if(dist_temp.lt.dist_init) then
1738             dist_init=dist_temp
1739             xj_temp=xj
1740             yj_temp=yj
1741             zj_temp=zj
1742             subchap=1
1743           endif
1744        enddo
1745        enddo
1746        enddo
1747        if (subchap.eq.1) then
1748           xj=xj_temp-xi
1749           yj=yj_temp-yi
1750           zj=zj_temp-zi
1751        else
1752           xj=xj_safe-xi
1753           yj=yj_safe-yi
1754           zj=zj_safe-zi
1755        endif
1756             dxj=dc_norm(1,nres+j)
1757             dyj=dc_norm(2,nres+j)
1758             dzj=dc_norm(3,nres+j)
1759 C            xj=xj-xi
1760 C            yj=yj-yi
1761 C            zj=zj-zi
1762 c            write (iout,*) "dcnorj",dxi*dxi+dyi*dyi+dzi*dzi
1763 c            write (iout,*) "j",j," dc_norm",
1764 c     &       dc_norm(1,nres+j),dc_norm(2,nres+j),dc_norm(3,nres+j)
1765             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1766             rij=dsqrt(rrij)
1767             sss=sscale((1.0d0/rij)/sigma(itypi,itypj))
1768             sssgrad=sscagrad((1.0d0/rij)/sigma(itypi,itypj))
1769
1770 c            write (iout,'(a7,4f8.3)')
1771 c    &      "ssscale",sss,((1.0d0/rij)/sigma(itypi,itypj)),r_cut,rlamb
1772             if (sss.gt.0.0d0) then
1773 C Calculate angle-dependent terms of energy and contributions to their
1774 C derivatives.
1775             call sc_angular
1776             sigsq=1.0D0/sigsq
1777             sig=sig0ij*dsqrt(sigsq)
1778             rij_shift=1.0D0/rij-sig+sig0ij
1779 c for diagnostics; uncomment
1780 c            rij_shift=1.2*sig0ij
1781 C I hate to put IF's in the loops, but here don't have another choice!!!!
1782             if (rij_shift.le.0.0D0) then
1783               evdw=1.0D20
1784 cd              write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1785 cd     &        restyp(itypi),i,restyp(itypj),j,
1786 cd     &        rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq)
1787               return
1788             endif
1789             sigder=-sig*sigsq
1790 c---------------------------------------------------------------
1791             rij_shift=1.0D0/rij_shift
1792             fac=rij_shift**expon
1793 C here to start with
1794 C            if (c(i,3).gt.
1795             faclip=fac
1796             e1=fac*fac*aa
1797             e2=fac*bb
1798             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1799             eps2der=evdwij*eps3rt
1800             eps3der=evdwij*eps2rt
1801 C       write(63,'(2i3,2e10.3,2f10.5)') i,j,aa,bb, evdwij,
1802 C     &((sslipi+sslipj)/2.0d0+
1803 C     &(2.0d0-sslipi-sslipj)/2.0d0)
1804 c            write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt,
1805 c     &        " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2
1806             evdwij=evdwij*eps2rt*eps3rt
1807             evdw=evdw+evdwij*sss
1808             if (lprn) then
1809             sigm=dabs(aa/bb)**(1.0D0/6.0D0)
1810             epsi=bb**2/aa
1811             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1812      &        restyp(itypi),i,restyp(itypj),j,
1813      &        epsi,sigm,chi1,chi2,chip1,chip2,
1814      &        eps1,eps2rt**2,eps3rt**2,sig,sig0ij,
1815      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1816      &        evdwij
1817             endif
1818
1819             if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
1820      &                        'evdw',i,j,evdwij
1821
1822 C Calculate gradient components.
1823             e1=e1*eps1*eps2rt**2*eps3rt**2
1824             fac=-expon*(e1+evdwij)*rij_shift
1825             sigder=fac*sigder
1826             fac=rij*fac
1827 c            print '(2i4,6f8.4)',i,j,sss,sssgrad*
1828 c     &      evdwij,fac,sigma(itypi,itypj),expon
1829             fac=fac+evdwij/sss*sssgrad/sigma(itypi,itypj)*rij
1830 c            fac=0.0d0
1831 C Calculate the radial part of the gradient
1832             gg_lipi(3)=eps1*(eps2rt*eps2rt)
1833      &*(eps3rt*eps3rt)*sss/2.0d0*(faclip*faclip*
1834      & (aa_lip(itypi,itypj)-aa_aq(itypi,itypj))
1835      &+faclip*(bb_lip(itypi,itypj)-bb_aq(itypi,itypj)))
1836             gg_lipj(3)=ssgradlipj*gg_lipi(3)
1837             gg_lipi(3)=gg_lipi(3)*ssgradlipi
1838 C            gg_lipi(3)=0.0d0
1839 C            gg_lipj(3)=0.0d0
1840             gg(1)=xj*fac
1841             gg(2)=yj*fac
1842             gg(3)=zj*fac
1843 C Calculate angular part of the gradient.
1844             call sc_grad
1845             endif
1846             ENDIF    ! dyn_ss
1847           enddo      ! j
1848         enddo        ! iint
1849       enddo          ! i
1850 C      enddo          ! zshift
1851 C      enddo          ! yshift
1852 C      enddo          ! xshift
1853 c      write (iout,*) "Number of loop steps in EGB:",ind
1854 cccc      energy_dec=.false.
1855       return
1856       end
1857 C-----------------------------------------------------------------------------
1858       subroutine egbv(evdw)
1859 C
1860 C This subroutine calculates the interaction energy of nonbonded side chains
1861 C assuming the Gay-Berne-Vorobjev potential of interaction.
1862 C
1863       implicit real*8 (a-h,o-z)
1864       include 'DIMENSIONS'
1865       include 'COMMON.GEO'
1866       include 'COMMON.VAR'
1867       include 'COMMON.LOCAL'
1868       include 'COMMON.CHAIN'
1869       include 'COMMON.DERIV'
1870       include 'COMMON.NAMES'
1871       include 'COMMON.INTERACT'
1872       include 'COMMON.IOUNITS'
1873       include 'COMMON.CALC'
1874       common /srutu/ icall
1875       logical lprn
1876       evdw=0.0D0
1877 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1878       evdw=0.0D0
1879       lprn=.false.
1880 c     if (icall.eq.0) lprn=.true.
1881       ind=0
1882       do i=iatsc_s,iatsc_e
1883         itypi=iabs(itype(i))
1884         if (itypi.eq.ntyp1) cycle
1885         itypi1=iabs(itype(i+1))
1886         xi=c(1,nres+i)
1887         yi=c(2,nres+i)
1888         zi=c(3,nres+i)
1889           xi=mod(xi,boxxsize)
1890           if (xi.lt.0) xi=xi+boxxsize
1891           yi=mod(yi,boxysize)
1892           if (yi.lt.0) yi=yi+boxysize
1893           zi=mod(zi,boxzsize)
1894           if (zi.lt.0) zi=zi+boxzsize
1895 C define scaling factor for lipids
1896
1897 C        if (positi.le.0) positi=positi+boxzsize
1898 C        print *,i
1899 C first for peptide groups
1900 c for each residue check if it is in lipid or lipid water border area
1901        if ((zi.gt.bordlipbot)
1902      &.and.(zi.lt.bordliptop)) then
1903 C the energy transfer exist
1904         if (zi.lt.buflipbot) then
1905 C what fraction I am in
1906          fracinbuf=1.0d0-
1907      &        ((zi-bordlipbot)/lipbufthick)
1908 C lipbufthick is thickenes of lipid buffore
1909          sslipi=sscalelip(fracinbuf)
1910          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
1911         elseif (zi.gt.bufliptop) then
1912          fracinbuf=1.0d0-((bordliptop-zi)/lipbufthick)
1913          sslipi=sscalelip(fracinbuf)
1914          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
1915         else
1916          sslipi=1.0d0
1917          ssgradlipi=0.0
1918         endif
1919        else
1920          sslipi=0.0d0
1921          ssgradlipi=0.0
1922        endif
1923
1924         dxi=dc_norm(1,nres+i)
1925         dyi=dc_norm(2,nres+i)
1926         dzi=dc_norm(3,nres+i)
1927 c        dsci_inv=dsc_inv(itypi)
1928         dsci_inv=vbld_inv(i+nres)
1929 C
1930 C Calculate SC interaction energy.
1931 C
1932         do iint=1,nint_gr(i)
1933           do j=istart(i,iint),iend(i,iint)
1934             ind=ind+1
1935             itypj=iabs(itype(j))
1936             if (itypj.eq.ntyp1) cycle
1937 c            dscj_inv=dsc_inv(itypj)
1938             dscj_inv=vbld_inv(j+nres)
1939             sig0ij=sigma(itypi,itypj)
1940             r0ij=r0(itypi,itypj)
1941             chi1=chi(itypi,itypj)
1942             chi2=chi(itypj,itypi)
1943             chi12=chi1*chi2
1944             chip1=chip(itypi)
1945             chip2=chip(itypj)
1946             chip12=chip1*chip2
1947             alf1=alp(itypi)
1948             alf2=alp(itypj)
1949             alf12=0.5D0*(alf1+alf2)
1950 C For diagnostics only!!!
1951 c           chi1=0.0D0
1952 c           chi2=0.0D0
1953 c           chi12=0.0D0
1954 c           chip1=0.0D0
1955 c           chip2=0.0D0
1956 c           chip12=0.0D0
1957 c           alf1=0.0D0
1958 c           alf2=0.0D0
1959 c           alf12=0.0D0
1960 C            xj=c(1,nres+j)-xi
1961 C            yj=c(2,nres+j)-yi
1962 C            zj=c(3,nres+j)-zi
1963           xj=mod(xj,boxxsize)
1964           if (xj.lt.0) xj=xj+boxxsize
1965           yj=mod(yj,boxysize)
1966           if (yj.lt.0) yj=yj+boxysize
1967           zj=mod(zj,boxzsize)
1968           if (zj.lt.0) zj=zj+boxzsize
1969        if ((zj.gt.bordlipbot)
1970      &.and.(zj.lt.bordliptop)) then
1971 C the energy transfer exist
1972         if (zj.lt.buflipbot) then
1973 C what fraction I am in
1974          fracinbuf=1.0d0-
1975      &        ((zj-bordlipbot)/lipbufthick)
1976 C lipbufthick is thickenes of lipid buffore
1977          sslipj=sscalelip(fracinbuf)
1978          ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
1979         elseif (zj.gt.bufliptop) then
1980          fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
1981          sslipj=sscalelip(fracinbuf)
1982          ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
1983         else
1984          sslipj=1.0d0
1985          ssgradlipj=0.0
1986         endif
1987        else
1988          sslipj=0.0d0
1989          ssgradlipj=0.0
1990        endif
1991       aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
1992      &  +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1993       bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
1994      &  +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1995 C      if (aa.ne.aa_aq(itypi,itypj)) write(63,'2e10.5')
1996 C     &(aa-aa_aq(itypi,itypj)),(bb-bb_aq(itypi,itypj))
1997       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
1998       xj_safe=xj
1999       yj_safe=yj
2000       zj_safe=zj
2001       subchap=0
2002       do xshift=-1,1
2003       do yshift=-1,1
2004       do zshift=-1,1
2005           xj=xj_safe+xshift*boxxsize
2006           yj=yj_safe+yshift*boxysize
2007           zj=zj_safe+zshift*boxzsize
2008           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
2009           if(dist_temp.lt.dist_init) then
2010             dist_init=dist_temp
2011             xj_temp=xj
2012             yj_temp=yj
2013             zj_temp=zj
2014             subchap=1
2015           endif
2016        enddo
2017        enddo
2018        enddo
2019        if (subchap.eq.1) then
2020           xj=xj_temp-xi
2021           yj=yj_temp-yi
2022           zj=zj_temp-zi
2023        else
2024           xj=xj_safe-xi
2025           yj=yj_safe-yi
2026           zj=zj_safe-zi
2027        endif
2028             dxj=dc_norm(1,nres+j)
2029             dyj=dc_norm(2,nres+j)
2030             dzj=dc_norm(3,nres+j)
2031             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
2032             rij=dsqrt(rrij)
2033 C Calculate angle-dependent terms of energy and contributions to their
2034 C derivatives.
2035             call sc_angular
2036             sigsq=1.0D0/sigsq
2037             sig=sig0ij*dsqrt(sigsq)
2038             rij_shift=1.0D0/rij-sig+r0ij
2039 C I hate to put IF's in the loops, but here don't have another choice!!!!
2040             if (rij_shift.le.0.0D0) then
2041               evdw=1.0D20
2042               return
2043             endif
2044             sigder=-sig*sigsq
2045 c---------------------------------------------------------------
2046             rij_shift=1.0D0/rij_shift
2047             fac=rij_shift**expon
2048             e1=fac*fac*aa
2049             e2=fac*bb
2050             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
2051             eps2der=evdwij*eps3rt
2052             eps3der=evdwij*eps2rt
2053             fac_augm=rrij**expon
2054             e_augm=augm(itypi,itypj)*fac_augm
2055             evdwij=evdwij*eps2rt*eps3rt
2056             evdw=evdw+evdwij+e_augm
2057             if (lprn) then
2058             sigm=dabs(aa/bb)**(1.0D0/6.0D0)
2059             epsi=bb**2/aa
2060             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
2061      &        restyp(itypi),i,restyp(itypj),j,
2062      &        epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),
2063      &        chi1,chi2,chip1,chip2,
2064      &        eps1,eps2rt**2,eps3rt**2,
2065      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
2066      &        evdwij+e_augm
2067             endif
2068 C Calculate gradient components.
2069             e1=e1*eps1*eps2rt**2*eps3rt**2
2070             fac=-expon*(e1+evdwij)*rij_shift
2071             sigder=fac*sigder
2072             fac=rij*fac-2*expon*rrij*e_augm
2073             fac=fac+evdwij/sss*sssgrad/sigma(itypi,itypj)*rij
2074 C Calculate the radial part of the gradient
2075             gg(1)=xj*fac
2076             gg(2)=yj*fac
2077             gg(3)=zj*fac
2078 C Calculate angular part of the gradient.
2079             call sc_grad
2080           enddo      ! j
2081         enddo        ! iint
2082       enddo          ! i
2083       end
2084 C-----------------------------------------------------------------------------
2085       subroutine sc_angular
2086 C Calculate eps1,eps2,eps3,sigma, and parts of their derivatives in om1,om2,
2087 C om12. Called by ebp, egb, and egbv.
2088       implicit none
2089       include 'COMMON.CALC'
2090       include 'COMMON.IOUNITS'
2091       erij(1)=xj*rij
2092       erij(2)=yj*rij
2093       erij(3)=zj*rij
2094       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
2095       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
2096       om12=dxi*dxj+dyi*dyj+dzi*dzj
2097       chiom12=chi12*om12
2098 C Calculate eps1(om12) and its derivative in om12
2099       faceps1=1.0D0-om12*chiom12
2100       faceps1_inv=1.0D0/faceps1
2101       eps1=dsqrt(faceps1_inv)
2102 C Following variable is eps1*deps1/dom12
2103       eps1_om12=faceps1_inv*chiom12
2104 c diagnostics only
2105 c      faceps1_inv=om12
2106 c      eps1=om12
2107 c      eps1_om12=1.0d0
2108 c      write (iout,*) "om12",om12," eps1",eps1
2109 C Calculate sigma(om1,om2,om12) and the derivatives of sigma**2 in om1,om2,
2110 C and om12.
2111       om1om2=om1*om2
2112       chiom1=chi1*om1
2113       chiom2=chi2*om2
2114       facsig=om1*chiom1+om2*chiom2-2.0D0*om1om2*chiom12
2115       sigsq=1.0D0-facsig*faceps1_inv
2116       sigsq_om1=(chiom1-chiom12*om2)*faceps1_inv
2117       sigsq_om2=(chiom2-chiom12*om1)*faceps1_inv
2118       sigsq_om12=-chi12*(om1om2*faceps1-om12*facsig)*faceps1_inv**2
2119 c diagnostics only
2120 c      sigsq=1.0d0
2121 c      sigsq_om1=0.0d0
2122 c      sigsq_om2=0.0d0
2123 c      sigsq_om12=0.0d0
2124 c      write (iout,*) "chiom1",chiom1," chiom2",chiom2," chiom12",chiom12
2125 c      write (iout,*) "faceps1",faceps1," faceps1_inv",faceps1_inv,
2126 c     &    " eps1",eps1
2127 C Calculate eps2 and its derivatives in om1, om2, and om12.
2128       chipom1=chip1*om1
2129       chipom2=chip2*om2
2130       chipom12=chip12*om12
2131       facp=1.0D0-om12*chipom12
2132       facp_inv=1.0D0/facp
2133       facp1=om1*chipom1+om2*chipom2-2.0D0*om1om2*chipom12
2134 c      write (iout,*) "chipom1",chipom1," chipom2",chipom2,
2135 c     &  " chipom12",chipom12," facp",facp," facp_inv",facp_inv
2136 C Following variable is the square root of eps2
2137       eps2rt=1.0D0-facp1*facp_inv
2138 C Following three variables are the derivatives of the square root of eps
2139 C in om1, om2, and om12.
2140       eps2rt_om1=-4.0D0*(chipom1-chipom12*om2)*facp_inv
2141       eps2rt_om2=-4.0D0*(chipom2-chipom12*om1)*facp_inv
2142       eps2rt_om12=4.0D0*chip12*(om1om2*facp-om12*facp1)*facp_inv**2
2143 C Evaluate the "asymmetric" factor in the VDW constant, eps3
2144       eps3rt=1.0D0-alf1*om1+alf2*om2-alf12*om12
2145 c      write (iout,*) "eps2rt",eps2rt," eps3rt",eps3rt
2146 c      write (iout,*) "eps2rt_om1",eps2rt_om1," eps2rt_om2",eps2rt_om2,
2147 c     &  " eps2rt_om12",eps2rt_om12
2148 C Calculate whole angle-dependent part of epsilon and contributions
2149 C to its derivatives
2150       return
2151       end
2152 C----------------------------------------------------------------------------
2153       subroutine sc_grad
2154       implicit real*8 (a-h,o-z)
2155       include 'DIMENSIONS'
2156       include 'COMMON.CHAIN'
2157       include 'COMMON.DERIV'
2158       include 'COMMON.CALC'
2159       include 'COMMON.IOUNITS'
2160       double precision dcosom1(3),dcosom2(3)
2161 cc      print *,'sss=',sss
2162       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
2163       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
2164       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12
2165      &     -2.0D0*alf12*eps3der+sigder*sigsq_om12
2166 c diagnostics only
2167 c      eom1=0.0d0
2168 c      eom2=0.0d0
2169 c      eom12=evdwij*eps1_om12
2170 c end diagnostics
2171 c      write (iout,*) "eps2der",eps2der," eps3der",eps3der,
2172 c     &  " sigder",sigder
2173 c      write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12
2174 c      write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12
2175       do k=1,3
2176         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
2177         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
2178       enddo
2179       do k=1,3
2180         gg(k)=(gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k))*sss
2181       enddo
2182 c      write (iout,*) "gg",(gg(k),k=1,3)
2183       do k=1,3
2184         gvdwx(k,i)=gvdwx(k,i)-gg(k)+gg_lipi(k)
2185      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
2186      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv*sss
2187         gvdwx(k,j)=gvdwx(k,j)+gg(k)+gg_lipj(k)
2188      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
2189      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv*sss
2190 c        write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
2191 c     &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
2192 c        write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
2193 c     &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
2194       enddo
2195 C
2196 C Calculate the components of the gradient in DC and X
2197 C
2198 cgrad      do k=i,j-1
2199 cgrad        do l=1,3
2200 cgrad          gvdwc(l,k)=gvdwc(l,k)+gg(l)
2201 cgrad        enddo
2202 cgrad      enddo
2203       do l=1,3
2204         gvdwc(l,i)=gvdwc(l,i)-gg(l)+gg_lipi(l)
2205         gvdwc(l,j)=gvdwc(l,j)+gg(l)+gg_lipj(l)
2206       enddo
2207       return
2208       end
2209 C-----------------------------------------------------------------------
2210       subroutine e_softsphere(evdw)
2211 C
2212 C This subroutine calculates the interaction energy of nonbonded side chains
2213 C assuming the LJ potential of interaction.
2214 C
2215       implicit real*8 (a-h,o-z)
2216       include 'DIMENSIONS'
2217       parameter (accur=1.0d-10)
2218       include 'COMMON.GEO'
2219       include 'COMMON.VAR'
2220       include 'COMMON.LOCAL'
2221       include 'COMMON.CHAIN'
2222       include 'COMMON.DERIV'
2223       include 'COMMON.INTERACT'
2224       include 'COMMON.TORSION'
2225       include 'COMMON.SBRIDGE'
2226       include 'COMMON.NAMES'
2227       include 'COMMON.IOUNITS'
2228       include 'COMMON.CONTACTS'
2229       dimension gg(3)
2230 cd    print *,'Entering Esoft_sphere nnt=',nnt,' nct=',nct
2231       evdw=0.0D0
2232       do i=iatsc_s,iatsc_e
2233         itypi=iabs(itype(i))
2234         if (itypi.eq.ntyp1) cycle
2235         itypi1=iabs(itype(i+1))
2236         xi=c(1,nres+i)
2237         yi=c(2,nres+i)
2238         zi=c(3,nres+i)
2239 C
2240 C Calculate SC interaction energy.
2241 C
2242         do iint=1,nint_gr(i)
2243 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
2244 cd   &                  'iend=',iend(i,iint)
2245           do j=istart(i,iint),iend(i,iint)
2246             itypj=iabs(itype(j))
2247             if (itypj.eq.ntyp1) cycle
2248             xj=c(1,nres+j)-xi
2249             yj=c(2,nres+j)-yi
2250             zj=c(3,nres+j)-zi
2251             rij=xj*xj+yj*yj+zj*zj
2252 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
2253             r0ij=r0(itypi,itypj)
2254             r0ijsq=r0ij*r0ij
2255 c            print *,i,j,r0ij,dsqrt(rij)
2256             if (rij.lt.r0ijsq) then
2257               evdwij=0.25d0*(rij-r0ijsq)**2
2258               fac=rij-r0ijsq
2259             else
2260               evdwij=0.0d0
2261               fac=0.0d0
2262             endif
2263             evdw=evdw+evdwij
2264 C
2265 C Calculate the components of the gradient in DC and X
2266 C
2267             gg(1)=xj*fac
2268             gg(2)=yj*fac
2269             gg(3)=zj*fac
2270             do k=1,3
2271               gvdwx(k,i)=gvdwx(k,i)-gg(k)
2272               gvdwx(k,j)=gvdwx(k,j)+gg(k)
2273               gvdwc(k,i)=gvdwc(k,i)-gg(k)
2274               gvdwc(k,j)=gvdwc(k,j)+gg(k)
2275             enddo
2276 cgrad            do k=i,j-1
2277 cgrad              do l=1,3
2278 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
2279 cgrad              enddo
2280 cgrad            enddo
2281           enddo ! j
2282         enddo ! iint
2283       enddo ! i
2284       return
2285       end
2286 C--------------------------------------------------------------------------
2287       subroutine eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,
2288      &              eello_turn4)
2289 C
2290 C Soft-sphere potential of p-p interaction
2291 C
2292       implicit real*8 (a-h,o-z)
2293       include 'DIMENSIONS'
2294       include 'COMMON.CONTROL'
2295       include 'COMMON.IOUNITS'
2296       include 'COMMON.GEO'
2297       include 'COMMON.VAR'
2298       include 'COMMON.LOCAL'
2299       include 'COMMON.CHAIN'
2300       include 'COMMON.DERIV'
2301       include 'COMMON.INTERACT'
2302       include 'COMMON.CONTACTS'
2303       include 'COMMON.TORSION'
2304       include 'COMMON.VECTORS'
2305       include 'COMMON.FFIELD'
2306       dimension ggg(3)
2307 C      write(iout,*) 'In EELEC_soft_sphere'
2308       ees=0.0D0
2309       evdw1=0.0D0
2310       eel_loc=0.0d0
2311       eello_turn3=0.0d0
2312       eello_turn4=0.0d0
2313       ind=0
2314       do i=iatel_s,iatel_e
2315         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
2316         dxi=dc(1,i)
2317         dyi=dc(2,i)
2318         dzi=dc(3,i)
2319         xmedi=c(1,i)+0.5d0*dxi
2320         ymedi=c(2,i)+0.5d0*dyi
2321         zmedi=c(3,i)+0.5d0*dzi
2322           xmedi=mod(xmedi,boxxsize)
2323           if (xmedi.lt.0) xmedi=xmedi+boxxsize
2324           ymedi=mod(ymedi,boxysize)
2325           if (ymedi.lt.0) ymedi=ymedi+boxysize
2326           zmedi=mod(zmedi,boxzsize)
2327           if (zmedi.lt.0) zmedi=zmedi+boxzsize
2328         num_conti=0
2329 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
2330         do j=ielstart(i),ielend(i)
2331           if (itype(j).eq.ntyp1 .or. itype(j+1).eq.ntyp1) cycle
2332           ind=ind+1
2333           iteli=itel(i)
2334           itelj=itel(j)
2335           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
2336           r0ij=rpp(iteli,itelj)
2337           r0ijsq=r0ij*r0ij
2338           dxj=dc(1,j)
2339           dyj=dc(2,j)
2340           dzj=dc(3,j)
2341           xj=c(1,j)+0.5D0*dxj
2342           yj=c(2,j)+0.5D0*dyj
2343           zj=c(3,j)+0.5D0*dzj
2344           xj=mod(xj,boxxsize)
2345           if (xj.lt.0) xj=xj+boxxsize
2346           yj=mod(yj,boxysize)
2347           if (yj.lt.0) yj=yj+boxysize
2348           zj=mod(zj,boxzsize)
2349           if (zj.lt.0) zj=zj+boxzsize
2350       dist_init=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
2351       xj_safe=xj
2352       yj_safe=yj
2353       zj_safe=zj
2354       isubchap=0
2355       do xshift=-1,1
2356       do yshift=-1,1
2357       do zshift=-1,1
2358           xj=xj_safe+xshift*boxxsize
2359           yj=yj_safe+yshift*boxysize
2360           zj=zj_safe+zshift*boxzsize
2361           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
2362           if(dist_temp.lt.dist_init) then
2363             dist_init=dist_temp
2364             xj_temp=xj
2365             yj_temp=yj
2366             zj_temp=zj
2367             isubchap=1
2368           endif
2369        enddo
2370        enddo
2371        enddo
2372        if (isubchap.eq.1) then
2373           xj=xj_temp-xmedi
2374           yj=yj_temp-ymedi
2375           zj=zj_temp-zmedi
2376        else
2377           xj=xj_safe-xmedi
2378           yj=yj_safe-ymedi
2379           zj=zj_safe-zmedi
2380        endif
2381           rij=xj*xj+yj*yj+zj*zj
2382             sss=sscale(sqrt(rij))
2383             sssgrad=sscagrad(sqrt(rij))
2384           if (rij.lt.r0ijsq) then
2385             evdw1ij=0.25d0*(rij-r0ijsq)**2
2386             fac=rij-r0ijsq
2387           else
2388             evdw1ij=0.0d0
2389             fac=0.0d0
2390           endif
2391           evdw1=evdw1+evdw1ij*sss
2392 C
2393 C Calculate contributions to the Cartesian gradient.
2394 C
2395           ggg(1)=fac*xj*sssgrad
2396           ggg(2)=fac*yj*sssgrad
2397           ggg(3)=fac*zj*sssgrad
2398           do k=1,3
2399             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
2400             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
2401           enddo
2402 *
2403 * Loop over residues i+1 thru j-1.
2404 *
2405 cgrad          do k=i+1,j-1
2406 cgrad            do l=1,3
2407 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
2408 cgrad            enddo
2409 cgrad          enddo
2410         enddo ! j
2411       enddo   ! i
2412 cgrad      do i=nnt,nct-1
2413 cgrad        do k=1,3
2414 cgrad          gelc(k,i)=gelc(k,i)+0.5d0*gelc(k,i)
2415 cgrad        enddo
2416 cgrad        do j=i+1,nct-1
2417 cgrad          do k=1,3
2418 cgrad            gelc(k,i)=gelc(k,i)+gelc(k,j)
2419 cgrad          enddo
2420 cgrad        enddo
2421 cgrad      enddo
2422       return
2423       end
2424 c------------------------------------------------------------------------------
2425       subroutine vec_and_deriv
2426       implicit real*8 (a-h,o-z)
2427       include 'DIMENSIONS'
2428 #ifdef MPI
2429       include 'mpif.h'
2430 #endif
2431       include 'COMMON.IOUNITS'
2432       include 'COMMON.GEO'
2433       include 'COMMON.VAR'
2434       include 'COMMON.LOCAL'
2435       include 'COMMON.CHAIN'
2436       include 'COMMON.VECTORS'
2437       include 'COMMON.SETUP'
2438       include 'COMMON.TIME1'
2439       dimension uyder(3,3,2),uzder(3,3,2),vbld_inv_temp(2)
2440 C Compute the local reference systems. For reference system (i), the
2441 C X-axis points from CA(i) to CA(i+1), the Y axis is in the
2442 C CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
2443 #ifdef PARVEC
2444       do i=ivec_start,ivec_end
2445 #else
2446       do i=1,nres-1
2447 #endif
2448           if (i.eq.nres-1) then
2449 C Case of the last full residue
2450 C Compute the Z-axis
2451             call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
2452             costh=dcos(pi-theta(nres))
2453             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2454             do k=1,3
2455               uz(k,i)=fac*uz(k,i)
2456             enddo
2457 C Compute the derivatives of uz
2458             uzder(1,1,1)= 0.0d0
2459             uzder(2,1,1)=-dc_norm(3,i-1)
2460             uzder(3,1,1)= dc_norm(2,i-1)
2461             uzder(1,2,1)= dc_norm(3,i-1)
2462             uzder(2,2,1)= 0.0d0
2463             uzder(3,2,1)=-dc_norm(1,i-1)
2464             uzder(1,3,1)=-dc_norm(2,i-1)
2465             uzder(2,3,1)= dc_norm(1,i-1)
2466             uzder(3,3,1)= 0.0d0
2467             uzder(1,1,2)= 0.0d0
2468             uzder(2,1,2)= dc_norm(3,i)
2469             uzder(3,1,2)=-dc_norm(2,i)
2470             uzder(1,2,2)=-dc_norm(3,i)
2471             uzder(2,2,2)= 0.0d0
2472             uzder(3,2,2)= dc_norm(1,i)
2473             uzder(1,3,2)= dc_norm(2,i)
2474             uzder(2,3,2)=-dc_norm(1,i)
2475             uzder(3,3,2)= 0.0d0
2476 C Compute the Y-axis
2477             facy=fac
2478             do k=1,3
2479               uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
2480             enddo
2481 C Compute the derivatives of uy
2482             do j=1,3
2483               do k=1,3
2484                 uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i)
2485      &                        -dc_norm(k,i)*dc_norm(j,i-1)
2486                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2487               enddo
2488               uyder(j,j,1)=uyder(j,j,1)-costh
2489               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2490             enddo
2491             do j=1,2
2492               do k=1,3
2493                 do l=1,3
2494                   uygrad(l,k,j,i)=uyder(l,k,j)
2495                   uzgrad(l,k,j,i)=uzder(l,k,j)
2496                 enddo
2497               enddo
2498             enddo
2499             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2500             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2501             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2502             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2503           else
2504 C Other residues
2505 C Compute the Z-axis
2506             call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
2507             costh=dcos(pi-theta(i+2))
2508             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2509             do k=1,3
2510               uz(k,i)=fac*uz(k,i)
2511             enddo
2512 C Compute the derivatives of uz
2513             uzder(1,1,1)= 0.0d0
2514             uzder(2,1,1)=-dc_norm(3,i+1)
2515             uzder(3,1,1)= dc_norm(2,i+1)
2516             uzder(1,2,1)= dc_norm(3,i+1)
2517             uzder(2,2,1)= 0.0d0
2518             uzder(3,2,1)=-dc_norm(1,i+1)
2519             uzder(1,3,1)=-dc_norm(2,i+1)
2520             uzder(2,3,1)= dc_norm(1,i+1)
2521             uzder(3,3,1)= 0.0d0
2522             uzder(1,1,2)= 0.0d0
2523             uzder(2,1,2)= dc_norm(3,i)
2524             uzder(3,1,2)=-dc_norm(2,i)
2525             uzder(1,2,2)=-dc_norm(3,i)
2526             uzder(2,2,2)= 0.0d0
2527             uzder(3,2,2)= dc_norm(1,i)
2528             uzder(1,3,2)= dc_norm(2,i)
2529             uzder(2,3,2)=-dc_norm(1,i)
2530             uzder(3,3,2)= 0.0d0
2531 C Compute the Y-axis
2532             facy=fac
2533             do k=1,3
2534               uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
2535             enddo
2536 C Compute the derivatives of uy
2537             do j=1,3
2538               do k=1,3
2539                 uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i)
2540      &                        -dc_norm(k,i)*dc_norm(j,i+1)
2541                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2542               enddo
2543               uyder(j,j,1)=uyder(j,j,1)-costh
2544               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2545             enddo
2546             do j=1,2
2547               do k=1,3
2548                 do l=1,3
2549                   uygrad(l,k,j,i)=uyder(l,k,j)
2550                   uzgrad(l,k,j,i)=uzder(l,k,j)
2551                 enddo
2552               enddo
2553             enddo
2554             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2555             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2556             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2557             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2558           endif
2559       enddo
2560       do i=1,nres-1
2561         vbld_inv_temp(1)=vbld_inv(i+1)
2562         if (i.lt.nres-1) then
2563           vbld_inv_temp(2)=vbld_inv(i+2)
2564           else
2565           vbld_inv_temp(2)=vbld_inv(i)
2566           endif
2567         do j=1,2
2568           do k=1,3
2569             do l=1,3
2570               uygrad(l,k,j,i)=vbld_inv_temp(j)*uygrad(l,k,j,i)
2571               uzgrad(l,k,j,i)=vbld_inv_temp(j)*uzgrad(l,k,j,i)
2572             enddo
2573           enddo
2574         enddo
2575       enddo
2576 #if defined(PARVEC) && defined(MPI)
2577       if (nfgtasks1.gt.1) then
2578         time00=MPI_Wtime()
2579 c        print *,"Processor",fg_rank1,kolor1," ivec_start",ivec_start,
2580 c     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks1-1),
2581 c     &   " ivec_count",(ivec_count(i),i=0,nfgtasks1-1)
2582         call MPI_Allgatherv(uy(1,ivec_start),ivec_count(fg_rank1),
2583      &   MPI_UYZ,uy(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
2584      &   FG_COMM1,IERR)
2585         call MPI_Allgatherv(uz(1,ivec_start),ivec_count(fg_rank1),
2586      &   MPI_UYZ,uz(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
2587      &   FG_COMM1,IERR)
2588         call MPI_Allgatherv(uygrad(1,1,1,ivec_start),
2589      &   ivec_count(fg_rank1),MPI_UYZGRAD,uygrad(1,1,1,1),ivec_count(0),
2590      &   ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2591         call MPI_Allgatherv(uzgrad(1,1,1,ivec_start),
2592      &   ivec_count(fg_rank1),MPI_UYZGRAD,uzgrad(1,1,1,1),ivec_count(0),
2593      &   ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2594         time_gather=time_gather+MPI_Wtime()-time00
2595       endif
2596 c      if (fg_rank.eq.0) then
2597 c        write (iout,*) "Arrays UY and UZ"
2598 c        do i=1,nres-1
2599 c          write (iout,'(i5,3f10.5,5x,3f10.5)') i,(uy(k,i),k=1,3),
2600 c     &     (uz(k,i),k=1,3)
2601 c        enddo
2602 c      endif
2603 #endif
2604       return
2605       end
2606 C-----------------------------------------------------------------------------
2607       subroutine check_vecgrad
2608       implicit real*8 (a-h,o-z)
2609       include 'DIMENSIONS'
2610       include 'COMMON.IOUNITS'
2611       include 'COMMON.GEO'
2612       include 'COMMON.VAR'
2613       include 'COMMON.LOCAL'
2614       include 'COMMON.CHAIN'
2615       include 'COMMON.VECTORS'
2616       dimension uygradt(3,3,2,maxres),uzgradt(3,3,2,maxres)
2617       dimension uyt(3,maxres),uzt(3,maxres)
2618       dimension uygradn(3,3,2),uzgradn(3,3,2),erij(3)
2619       double precision delta /1.0d-7/
2620       call vec_and_deriv
2621 cd      do i=1,nres
2622 crc          write(iout,'(2i5,2(3f10.5,5x))') i,1,dc_norm(:,i)
2623 crc          write(iout,'(2i5,2(3f10.5,5x))') i,2,uy(:,i)
2624 crc          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,uz(:,i)
2625 cd          write(iout,'(2i5,2(3f10.5,5x))') i,1,
2626 cd     &     (dc_norm(if90,i),if90=1,3)
2627 cd          write(iout,'(2i5,2(3f10.5,5x))') i,2,(uy(if90,i),if90=1,3)
2628 cd          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,(uz(if90,i),if90=1,3)
2629 cd          write(iout,'(a)')
2630 cd      enddo
2631       do i=1,nres
2632         do j=1,2
2633           do k=1,3
2634             do l=1,3
2635               uygradt(l,k,j,i)=uygrad(l,k,j,i)
2636               uzgradt(l,k,j,i)=uzgrad(l,k,j,i)
2637             enddo
2638           enddo
2639         enddo
2640       enddo
2641       call vec_and_deriv
2642       do i=1,nres
2643         do j=1,3
2644           uyt(j,i)=uy(j,i)
2645           uzt(j,i)=uz(j,i)
2646         enddo
2647       enddo
2648       do i=1,nres
2649 cd        write (iout,*) 'i=',i
2650         do k=1,3
2651           erij(k)=dc_norm(k,i)
2652         enddo
2653         do j=1,3
2654           do k=1,3
2655             dc_norm(k,i)=erij(k)
2656           enddo
2657           dc_norm(j,i)=dc_norm(j,i)+delta
2658 c          fac=dsqrt(scalar(dc_norm(1,i),dc_norm(1,i)))
2659 c          do k=1,3
2660 c            dc_norm(k,i)=dc_norm(k,i)/fac
2661 c          enddo
2662 c          write (iout,*) (dc_norm(k,i),k=1,3)
2663 c          write (iout,*) (erij(k),k=1,3)
2664           call vec_and_deriv
2665           do k=1,3
2666             uygradn(k,j,1)=(uy(k,i)-uyt(k,i))/delta
2667             uygradn(k,j,2)=(uy(k,i-1)-uyt(k,i-1))/delta
2668             uzgradn(k,j,1)=(uz(k,i)-uzt(k,i))/delta
2669             uzgradn(k,j,2)=(uz(k,i-1)-uzt(k,i-1))/delta
2670           enddo
2671 c          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2672 c     &      j,(uzgradt(k,j,1,i),k=1,3),(uzgradn(k,j,1),k=1,3),
2673 c     &      (uzgradt(k,j,2,i-1),k=1,3),(uzgradn(k,j,2),k=1,3)
2674         enddo
2675         do k=1,3
2676           dc_norm(k,i)=erij(k)
2677         enddo
2678 cd        do k=1,3
2679 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2680 cd     &      k,(uygradt(k,l,1,i),l=1,3),(uygradn(k,l,1),l=1,3),
2681 cd     &      (uygradt(k,l,2,i-1),l=1,3),(uygradn(k,l,2),l=1,3)
2682 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2683 cd     &      k,(uzgradt(k,l,1,i),l=1,3),(uzgradn(k,l,1),l=1,3),
2684 cd     &      (uzgradt(k,l,2,i-1),l=1,3),(uzgradn(k,l,2),l=1,3)
2685 cd          write (iout,'(a)')
2686 cd        enddo
2687       enddo
2688       return
2689       end
2690 C--------------------------------------------------------------------------
2691       subroutine set_matrices
2692       implicit real*8 (a-h,o-z)
2693       include 'DIMENSIONS'
2694 #ifdef MPI
2695       include "mpif.h"
2696       include "COMMON.SETUP"
2697       integer IERR
2698       integer status(MPI_STATUS_SIZE)
2699 #endif
2700       include 'COMMON.IOUNITS'
2701       include 'COMMON.GEO'
2702       include 'COMMON.VAR'
2703       include 'COMMON.LOCAL'
2704       include 'COMMON.CHAIN'
2705       include 'COMMON.DERIV'
2706       include 'COMMON.INTERACT'
2707       include 'COMMON.CONTACTS'
2708       include 'COMMON.TORSION'
2709       include 'COMMON.VECTORS'
2710       include 'COMMON.FFIELD'
2711       double precision auxvec(2),auxmat(2,2)
2712 C
2713 C Compute the virtual-bond-torsional-angle dependent quantities needed
2714 C to calculate the el-loc multibody terms of various order.
2715 C
2716 c      write(iout,*) 'nphi=',nphi,nres
2717 #ifdef PARMAT
2718       do i=ivec_start+2,ivec_end+2
2719 #else
2720       do i=3,nres+1
2721 #endif
2722 #ifdef NEWCORR
2723         if (i.gt. nnt+2 .and. i.lt.nct+2) then
2724           iti = itortyp(itype(i-2))
2725         else
2726           iti=ntortyp+1
2727         endif
2728 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2729         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2730           iti1 = itortyp(itype(i-1))
2731         else
2732           iti1=ntortyp+1
2733         endif
2734 c        write(iout,*),i
2735         b1(1,i-2)=bnew1(1,1,iti)*dsin(theta(i-1)/2.0)
2736      &           +bnew1(2,1,iti)*dsin(theta(i-1))
2737      &           +bnew1(3,1,iti)*dcos(theta(i-1)/2.0)
2738         gtb1(1,i-2)=bnew1(1,1,iti)*dcos(theta(i-1)/2.0d0)/2.0d0
2739      &             +bnew1(2,1,iti)*dcos(theta(i-1))
2740      &             -bnew1(3,1,iti)*dsin(theta(i-1)/2.0d0)/2.0d0
2741 c     &           +bnew1(3,1,iti)*sin(alpha(i))*cos(beta(i))
2742 c     &*(cos(theta(i)/2.0)
2743         b2(1,i-2)=bnew2(1,1,iti)*dsin(theta(i-1)/2.0)
2744      &           +bnew2(2,1,iti)*dsin(theta(i-1))
2745      &           +bnew2(3,1,iti)*dcos(theta(i-1)/2.0)
2746 c     &           +bnew2(3,1,iti)*sin(alpha(i))*cos(beta(i))
2747 c     &*(cos(theta(i)/2.0)
2748         gtb2(1,i-2)=bnew2(1,1,iti)*dcos(theta(i-1)/2.0d0)/2.0d0
2749      &             +bnew2(2,1,iti)*dcos(theta(i-1))
2750      &             -bnew2(3,1,iti)*dsin(theta(i-1)/2.0d0)/2.0d0
2751 c        if (ggb1(1,i).eq.0.0d0) then
2752 c        write(iout,*) 'i=',i,ggb1(1,i),
2753 c     &bnew1(1,1,iti)*cos(theta(i)/2.0)/2.0,
2754 c     &bnew1(2,1,iti)*cos(theta(i)),
2755 c     &bnew1(3,1,iti)*sin(theta(i)/2.0)/2.0
2756 c        endif
2757         b1(2,i-2)=bnew1(1,2,iti)
2758         gtb1(2,i-2)=0.0
2759         b2(2,i-2)=bnew2(1,2,iti)
2760         gtb2(2,i-2)=0.0
2761         EE(1,1,i-2)=eenew(1,iti)*dcos(theta(i-1))
2762         EE(1,2,i-2)=eeold(1,2,iti)
2763         EE(2,1,i-2)=eeold(2,1,iti)
2764         EE(2,2,i-2)=eeold(2,2,iti)
2765         gtEE(1,1,i-2)=-eenew(1,iti)*dsin(theta(i-1))
2766         gtEE(1,2,i-2)=0.0d0
2767         gtEE(2,2,i-2)=0.0d0
2768         gtEE(2,1,i-2)=0.0d0
2769 c        EE(2,2,iti)=0.0d0
2770 c        EE(1,2,iti)=0.5d0*eenew(1,iti)
2771 c        EE(2,1,iti)=0.5d0*eenew(1,iti)
2772 c        b1(2,iti)=bnew1(1,2,iti)*sin(alpha(i))*sin(beta(i))
2773 c        b2(2,iti)=bnew2(1,2,iti)*sin(alpha(i))*sin(beta(i))
2774        b1tilde(1,i-2)=b1(1,i-2)
2775        b1tilde(2,i-2)=-b1(2,i-2)
2776        b2tilde(1,i-2)=b2(1,i-2)
2777        b2tilde(2,i-2)=-b2(2,i-2)
2778 c       write (iout,*) 'i=',i-2,gtb1(2,i-2),gtb1(1,i-2)
2779 c       write(iout,*)  'b1=',b1(1,i-2)
2780 c       write (iout,*) 'theta=', theta(i-1)
2781        enddo
2782 #else
2783         b1(1,i-2)=b(3,iti)
2784         b1(2,i-2)=b(5,iti)
2785         b2(1,i-2)=b(2,iti)
2786         b2(2,i-2)=b(4,iti)
2787        b1tilde(1,i-2)=b1(1,i-2)
2788        b1tilde(2,i-2)=-b1(2,i-2)
2789        b2tilde(1,i-2)=b2(1,i-2)
2790        b2tilde(2,i-2)=-b2(2,i-2)
2791         EE(1,2,i-2)=eeold(1,2,iti)
2792         EE(2,1,i-2)=eeold(2,1,iti)
2793         EE(2,2,i-2)=eeold(2,2,iti)
2794         EE(1,1,i-2)=eeold(1,1,iti)
2795       enddo
2796 #endif
2797 #ifdef PARMAT
2798       do i=ivec_start+2,ivec_end+2
2799 #else
2800       do i=3,nres+1
2801 #endif
2802         if (i .lt. nres+1) then
2803           sin1=dsin(phi(i))
2804           cos1=dcos(phi(i))
2805           sintab(i-2)=sin1
2806           costab(i-2)=cos1
2807           obrot(1,i-2)=cos1
2808           obrot(2,i-2)=sin1
2809           sin2=dsin(2*phi(i))
2810           cos2=dcos(2*phi(i))
2811           sintab2(i-2)=sin2
2812           costab2(i-2)=cos2
2813           obrot2(1,i-2)=cos2
2814           obrot2(2,i-2)=sin2
2815           Ug(1,1,i-2)=-cos1
2816           Ug(1,2,i-2)=-sin1
2817           Ug(2,1,i-2)=-sin1
2818           Ug(2,2,i-2)= cos1
2819           Ug2(1,1,i-2)=-cos2
2820           Ug2(1,2,i-2)=-sin2
2821           Ug2(2,1,i-2)=-sin2
2822           Ug2(2,2,i-2)= cos2
2823         else
2824           costab(i-2)=1.0d0
2825           sintab(i-2)=0.0d0
2826           obrot(1,i-2)=1.0d0
2827           obrot(2,i-2)=0.0d0
2828           obrot2(1,i-2)=0.0d0
2829           obrot2(2,i-2)=0.0d0
2830           Ug(1,1,i-2)=1.0d0
2831           Ug(1,2,i-2)=0.0d0
2832           Ug(2,1,i-2)=0.0d0
2833           Ug(2,2,i-2)=1.0d0
2834           Ug2(1,1,i-2)=0.0d0
2835           Ug2(1,2,i-2)=0.0d0
2836           Ug2(2,1,i-2)=0.0d0
2837           Ug2(2,2,i-2)=0.0d0
2838         endif
2839         if (i .gt. 3 .and. i .lt. nres+1) then
2840           obrot_der(1,i-2)=-sin1
2841           obrot_der(2,i-2)= cos1
2842           Ugder(1,1,i-2)= sin1
2843           Ugder(1,2,i-2)=-cos1
2844           Ugder(2,1,i-2)=-cos1
2845           Ugder(2,2,i-2)=-sin1
2846           dwacos2=cos2+cos2
2847           dwasin2=sin2+sin2
2848           obrot2_der(1,i-2)=-dwasin2
2849           obrot2_der(2,i-2)= dwacos2
2850           Ug2der(1,1,i-2)= dwasin2
2851           Ug2der(1,2,i-2)=-dwacos2
2852           Ug2der(2,1,i-2)=-dwacos2
2853           Ug2der(2,2,i-2)=-dwasin2
2854         else
2855           obrot_der(1,i-2)=0.0d0
2856           obrot_der(2,i-2)=0.0d0
2857           Ugder(1,1,i-2)=0.0d0
2858           Ugder(1,2,i-2)=0.0d0
2859           Ugder(2,1,i-2)=0.0d0
2860           Ugder(2,2,i-2)=0.0d0
2861           obrot2_der(1,i-2)=0.0d0
2862           obrot2_der(2,i-2)=0.0d0
2863           Ug2der(1,1,i-2)=0.0d0
2864           Ug2der(1,2,i-2)=0.0d0
2865           Ug2der(2,1,i-2)=0.0d0
2866           Ug2der(2,2,i-2)=0.0d0
2867         endif
2868 c        if (i.gt. iatel_s+2 .and. i.lt.iatel_e+5) then
2869         if (i.gt. nnt+2 .and. i.lt.nct+2) then
2870           iti = itortyp(itype(i-2))
2871         else
2872           iti=ntortyp
2873         endif
2874 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2875         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2876           iti1 = itortyp(itype(i-1))
2877         else
2878           iti1=ntortyp
2879         endif
2880 cd        write (iout,*) '*******i',i,' iti1',iti
2881 cd        write (iout,*) 'b1',b1(:,iti)
2882 cd        write (iout,*) 'b2',b2(:,iti)
2883 cd        write (iout,*) 'Ug',Ug(:,:,i-2)
2884 c        if (i .gt. iatel_s+2) then
2885         if (i .gt. nnt+2) then
2886           call matvec2(Ug(1,1,i-2),b2(1,i-2),Ub2(1,i-2))
2887 #ifdef NEWCORR
2888           call matvec2(Ug(1,1,i-2),gtb2(1,i-2),gUb2(1,i-2))
2889 c          write (iout,*) Ug(1,1,i-2),gtb2(1,i-2),gUb2(1,i-2),"chuj"
2890 #endif
2891 c          write(iout,*) "co jest kurwa", iti, EE(1,1,iti),EE(2,1,iti),
2892 c     &    EE(1,2,iti),EE(2,2,iti)
2893           call matmat2(EE(1,1,i-2),Ug(1,1,i-2),EUg(1,1,i-2))
2894           call matmat2(gtEE(1,1,i-2),Ug(1,1,i-2),gtEUg(1,1,i-2))
2895 c          write(iout,*) "Macierz EUG",
2896 c     &    eug(1,1,i-2),eug(1,2,i-2),eug(2,1,i-2),
2897 c     &    eug(2,2,i-2)
2898           if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2899      &    then
2900           call matmat2(CC(1,1,iti),Ug(1,1,i-2),CUg(1,1,i-2))
2901           call matmat2(DD(1,1,iti),Ug(1,1,i-2),DUg(1,1,i-2))
2902           call matmat2(Dtilde(1,1,iti),Ug2(1,1,i-2),DtUg2(1,1,i-2))
2903           call matvec2(Ctilde(1,1,iti1),obrot(1,i-2),Ctobr(1,i-2))
2904           call matvec2(Dtilde(1,1,iti),obrot2(1,i-2),Dtobr2(1,i-2))
2905           endif
2906         else
2907           do k=1,2
2908             Ub2(k,i-2)=0.0d0
2909             Ctobr(k,i-2)=0.0d0
2910             Dtobr2(k,i-2)=0.0d0
2911             do l=1,2
2912               EUg(l,k,i-2)=0.0d0
2913               CUg(l,k,i-2)=0.0d0
2914               DUg(l,k,i-2)=0.0d0
2915               DtUg2(l,k,i-2)=0.0d0
2916             enddo
2917           enddo
2918         endif
2919         call matvec2(Ugder(1,1,i-2),b2(1,i-2),Ub2der(1,i-2))
2920         call matmat2(EE(1,1,i-2),Ugder(1,1,i-2),EUgder(1,1,i-2))
2921         do k=1,2
2922           muder(k,i-2)=Ub2der(k,i-2)
2923         enddo
2924 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2925         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2926           if (itype(i-1).le.ntyp) then
2927             iti1 = itortyp(itype(i-1))
2928           else
2929             iti1=ntortyp
2930           endif
2931         else
2932           iti1=ntortyp
2933         endif
2934         do k=1,2
2935           mu(k,i-2)=Ub2(k,i-2)+b1(k,i-1)
2936         enddo
2937 c        write (iout,*) 'mu ',mu(:,i-2),i-2
2938 cd        write (iout,*) 'mu1',mu1(:,i-2)
2939 cd        write (iout,*) 'mu2',mu2(:,i-2)
2940         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
2941      &  then
2942         call matmat2(CC(1,1,iti1),Ugder(1,1,i-2),CUgder(1,1,i-2))
2943         call matmat2(DD(1,1,iti),Ugder(1,1,i-2),DUgder(1,1,i-2))
2944         call matmat2(Dtilde(1,1,iti),Ug2der(1,1,i-2),DtUg2der(1,1,i-2))
2945         call matvec2(Ctilde(1,1,iti1),obrot_der(1,i-2),Ctobrder(1,i-2))
2946         call matvec2(Dtilde(1,1,iti),obrot2_der(1,i-2),Dtobr2der(1,i-2))
2947 C Vectors and matrices dependent on a single virtual-bond dihedral.
2948         call matvec2(DD(1,1,iti),b1tilde(1,i-1),auxvec(1))
2949         call matvec2(Ug2(1,1,i-2),auxvec(1),Ug2Db1t(1,i-2))
2950         call matvec2(Ug2der(1,1,i-2),auxvec(1),Ug2Db1tder(1,i-2))
2951         call matvec2(CC(1,1,iti1),Ub2(1,i-2),CUgb2(1,i-2))
2952         call matvec2(CC(1,1,iti1),Ub2der(1,i-2),CUgb2der(1,i-2))
2953         call matmat2(EUg(1,1,i-2),CC(1,1,iti1),EUgC(1,1,i-2))
2954         call matmat2(EUgder(1,1,i-2),CC(1,1,iti1),EUgCder(1,1,i-2))
2955         call matmat2(EUg(1,1,i-2),DD(1,1,iti1),EUgD(1,1,i-2))
2956         call matmat2(EUgder(1,1,i-2),DD(1,1,iti1),EUgDder(1,1,i-2))
2957         endif
2958       enddo
2959 C Matrices dependent on two consecutive virtual-bond dihedrals.
2960 C The order of matrices is from left to right.
2961       if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
2962      &then
2963 c      do i=max0(ivec_start,2),ivec_end
2964       do i=2,nres-1
2965         call matmat2(DtUg2(1,1,i-1),EUg(1,1,i),DtUg2EUg(1,1,i))
2966         call matmat2(DtUg2der(1,1,i-1),EUg(1,1,i),DtUg2EUgder(1,1,1,i))
2967         call matmat2(DtUg2(1,1,i-1),EUgder(1,1,i),DtUg2EUgder(1,1,2,i))
2968         call transpose2(DtUg2(1,1,i-1),auxmat(1,1))
2969         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUg(1,1,i))
2970         call matmat2(auxmat(1,1),EUgder(1,1,i),Ug2DtEUgder(1,1,2,i))
2971         call transpose2(DtUg2der(1,1,i-1),auxmat(1,1))
2972         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUgder(1,1,1,i))
2973       enddo
2974       endif
2975 #if defined(MPI) && defined(PARMAT)
2976 #ifdef DEBUG
2977 c      if (fg_rank.eq.0) then
2978         write (iout,*) "Arrays UG and UGDER before GATHER"
2979         do i=1,nres-1
2980           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2981      &     ((ug(l,k,i),l=1,2),k=1,2),
2982      &     ((ugder(l,k,i),l=1,2),k=1,2)
2983         enddo
2984         write (iout,*) "Arrays UG2 and UG2DER"
2985         do i=1,nres-1
2986           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2987      &     ((ug2(l,k,i),l=1,2),k=1,2),
2988      &     ((ug2der(l,k,i),l=1,2),k=1,2)
2989         enddo
2990         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
2991         do i=1,nres-1
2992           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2993      &     (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
2994      &     (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
2995         enddo
2996         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
2997         do i=1,nres-1
2998           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2999      &     costab(i),sintab(i),costab2(i),sintab2(i)
3000         enddo
3001         write (iout,*) "Array MUDER"
3002         do i=1,nres-1
3003           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
3004         enddo
3005 c      endif
3006 #endif
3007       if (nfgtasks.gt.1) then
3008         time00=MPI_Wtime()
3009 c        write(iout,*)"Processor",fg_rank,kolor," ivec_start",ivec_start,
3010 c     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks-1),
3011 c     &   " ivec_count",(ivec_count(i),i=0,nfgtasks-1)
3012 #ifdef MATGATHER
3013         call MPI_Allgatherv(Ub2(1,ivec_start),ivec_count(fg_rank1),
3014      &   MPI_MU,Ub2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3015      &   FG_COMM1,IERR)
3016         call MPI_Allgatherv(Ub2der(1,ivec_start),ivec_count(fg_rank1),
3017      &   MPI_MU,Ub2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3018      &   FG_COMM1,IERR)
3019         call MPI_Allgatherv(mu(1,ivec_start),ivec_count(fg_rank1),
3020      &   MPI_MU,mu(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3021      &   FG_COMM1,IERR)
3022         call MPI_Allgatherv(muder(1,ivec_start),ivec_count(fg_rank1),
3023      &   MPI_MU,muder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3024      &   FG_COMM1,IERR)
3025         call MPI_Allgatherv(Eug(1,1,ivec_start),ivec_count(fg_rank1),
3026      &   MPI_MAT1,Eug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3027      &   FG_COMM1,IERR)
3028         call MPI_Allgatherv(Eugder(1,1,ivec_start),ivec_count(fg_rank1),
3029      &   MPI_MAT1,Eugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3030      &   FG_COMM1,IERR)
3031         call MPI_Allgatherv(costab(ivec_start),ivec_count(fg_rank1),
3032      &   MPI_DOUBLE_PRECISION,costab(1),ivec_count(0),ivec_displ(0),
3033      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3034         call MPI_Allgatherv(sintab(ivec_start),ivec_count(fg_rank1),
3035      &   MPI_DOUBLE_PRECISION,sintab(1),ivec_count(0),ivec_displ(0),
3036      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3037         call MPI_Allgatherv(costab2(ivec_start),ivec_count(fg_rank1),
3038      &   MPI_DOUBLE_PRECISION,costab2(1),ivec_count(0),ivec_displ(0),
3039      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3040         call MPI_Allgatherv(sintab2(ivec_start),ivec_count(fg_rank1),
3041      &   MPI_DOUBLE_PRECISION,sintab2(1),ivec_count(0),ivec_displ(0),
3042      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3043         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
3044      &  then
3045         call MPI_Allgatherv(Ctobr(1,ivec_start),ivec_count(fg_rank1),
3046      &   MPI_MU,Ctobr(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3047      &   FG_COMM1,IERR)
3048         call MPI_Allgatherv(Ctobrder(1,ivec_start),ivec_count(fg_rank1),
3049      &   MPI_MU,Ctobrder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3050      &   FG_COMM1,IERR)
3051         call MPI_Allgatherv(Dtobr2(1,ivec_start),ivec_count(fg_rank1),
3052      &   MPI_MU,Dtobr2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3053      &   FG_COMM1,IERR)
3054        call MPI_Allgatherv(Dtobr2der(1,ivec_start),ivec_count(fg_rank1),
3055      &   MPI_MU,Dtobr2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3056      &   FG_COMM1,IERR)
3057         call MPI_Allgatherv(Ug2Db1t(1,ivec_start),ivec_count(fg_rank1),
3058      &   MPI_MU,Ug2Db1t(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3059      &   FG_COMM1,IERR)
3060         call MPI_Allgatherv(Ug2Db1tder(1,ivec_start),
3061      &   ivec_count(fg_rank1),
3062      &   MPI_MU,Ug2Db1tder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3063      &   FG_COMM1,IERR)
3064         call MPI_Allgatherv(CUgb2(1,ivec_start),ivec_count(fg_rank1),
3065      &   MPI_MU,CUgb2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3066      &   FG_COMM1,IERR)
3067         call MPI_Allgatherv(CUgb2der(1,ivec_start),ivec_count(fg_rank1),
3068      &   MPI_MU,CUgb2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3069      &   FG_COMM1,IERR)
3070         call MPI_Allgatherv(Cug(1,1,ivec_start),ivec_count(fg_rank1),
3071      &   MPI_MAT1,Cug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3072      &   FG_COMM1,IERR)
3073         call MPI_Allgatherv(Cugder(1,1,ivec_start),ivec_count(fg_rank1),
3074      &   MPI_MAT1,Cugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3075      &   FG_COMM1,IERR)
3076         call MPI_Allgatherv(Dug(1,1,ivec_start),ivec_count(fg_rank1),
3077      &   MPI_MAT1,Dug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3078      &   FG_COMM1,IERR)
3079         call MPI_Allgatherv(Dugder(1,1,ivec_start),ivec_count(fg_rank1),
3080      &   MPI_MAT1,Dugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3081      &   FG_COMM1,IERR)
3082         call MPI_Allgatherv(Dtug2(1,1,ivec_start),ivec_count(fg_rank1),
3083      &   MPI_MAT1,Dtug2(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3084      &   FG_COMM1,IERR)
3085         call MPI_Allgatherv(Dtug2der(1,1,ivec_start),
3086      &   ivec_count(fg_rank1),
3087      &   MPI_MAT1,Dtug2der(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3088      &   FG_COMM1,IERR)
3089         call MPI_Allgatherv(EugC(1,1,ivec_start),ivec_count(fg_rank1),
3090      &   MPI_MAT1,EugC(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3091      &   FG_COMM1,IERR)
3092        call MPI_Allgatherv(EugCder(1,1,ivec_start),ivec_count(fg_rank1),
3093      &   MPI_MAT1,EugCder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3094      &   FG_COMM1,IERR)
3095         call MPI_Allgatherv(EugD(1,1,ivec_start),ivec_count(fg_rank1),
3096      &   MPI_MAT1,EugD(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3097      &   FG_COMM1,IERR)
3098        call MPI_Allgatherv(EugDder(1,1,ivec_start),ivec_count(fg_rank1),
3099      &   MPI_MAT1,EugDder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3100      &   FG_COMM1,IERR)
3101         call MPI_Allgatherv(DtUg2EUg(1,1,ivec_start),
3102      &   ivec_count(fg_rank1),
3103      &   MPI_MAT1,DtUg2EUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3104      &   FG_COMM1,IERR)
3105         call MPI_Allgatherv(Ug2DtEUg(1,1,ivec_start),
3106      &   ivec_count(fg_rank1),
3107      &   MPI_MAT1,Ug2DtEUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3108      &   FG_COMM1,IERR)
3109         call MPI_Allgatherv(DtUg2EUgder(1,1,1,ivec_start),
3110      &   ivec_count(fg_rank1),
3111      &   MPI_MAT2,DtUg2EUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
3112      &   MPI_MAT2,FG_COMM1,IERR)
3113         call MPI_Allgatherv(Ug2DtEUgder(1,1,1,ivec_start),
3114      &   ivec_count(fg_rank1),
3115      &   MPI_MAT2,Ug2DtEUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
3116      &   MPI_MAT2,FG_COMM1,IERR)
3117         endif
3118 #else
3119 c Passes matrix info through the ring
3120       isend=fg_rank1
3121       irecv=fg_rank1-1
3122       if (irecv.lt.0) irecv=nfgtasks1-1
3123       iprev=irecv
3124       inext=fg_rank1+1
3125       if (inext.ge.nfgtasks1) inext=0
3126       do i=1,nfgtasks1-1
3127 c        write (iout,*) "isend",isend," irecv",irecv
3128 c        call flush(iout)
3129         lensend=lentyp(isend)
3130         lenrecv=lentyp(irecv)
3131 c        write (iout,*) "lensend",lensend," lenrecv",lenrecv
3132 c        call MPI_SENDRECV(ug(1,1,ivec_displ(isend)+1),1,
3133 c     &   MPI_ROTAT1(lensend),inext,2200+isend,
3134 c     &   ug(1,1,ivec_displ(irecv)+1),1,MPI_ROTAT1(lenrecv),
3135 c     &   iprev,2200+irecv,FG_COMM,status,IERR)
3136 c        write (iout,*) "Gather ROTAT1"
3137 c        call flush(iout)
3138 c        call MPI_SENDRECV(obrot(1,ivec_displ(isend)+1),1,
3139 c     &   MPI_ROTAT2(lensend),inext,3300+isend,
3140 c     &   obrot(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
3141 c     &   iprev,3300+irecv,FG_COMM,status,IERR)
3142 c        write (iout,*) "Gather ROTAT2"
3143 c        call flush(iout)
3144         call MPI_SENDRECV(costab(ivec_displ(isend)+1),1,
3145      &   MPI_ROTAT_OLD(lensend),inext,4400+isend,
3146      &   costab(ivec_displ(irecv)+1),1,MPI_ROTAT_OLD(lenrecv),
3147      &   iprev,4400+irecv,FG_COMM,status,IERR)
3148 c        write (iout,*) "Gather ROTAT_OLD"
3149 c        call flush(iout)
3150         call MPI_SENDRECV(mu(1,ivec_displ(isend)+1),1,
3151      &   MPI_PRECOMP11(lensend),inext,5500+isend,
3152      &   mu(1,ivec_displ(irecv)+1),1,MPI_PRECOMP11(lenrecv),
3153      &   iprev,5500+irecv,FG_COMM,status,IERR)
3154 c        write (iout,*) "Gather PRECOMP11"
3155 c        call flush(iout)
3156         call MPI_SENDRECV(Eug(1,1,ivec_displ(isend)+1),1,
3157      &   MPI_PRECOMP12(lensend),inext,6600+isend,
3158      &   Eug(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP12(lenrecv),
3159      &   iprev,6600+irecv,FG_COMM,status,IERR)
3160 c        write (iout,*) "Gather PRECOMP12"
3161 c        call flush(iout)
3162         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
3163      &  then
3164         call MPI_SENDRECV(ug2db1t(1,ivec_displ(isend)+1),1,
3165      &   MPI_ROTAT2(lensend),inext,7700+isend,
3166      &   ug2db1t(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
3167      &   iprev,7700+irecv,FG_COMM,status,IERR)
3168 c        write (iout,*) "Gather PRECOMP21"
3169 c        call flush(iout)
3170         call MPI_SENDRECV(EUgC(1,1,ivec_displ(isend)+1),1,
3171      &   MPI_PRECOMP22(lensend),inext,8800+isend,
3172      &   EUgC(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP22(lenrecv),
3173      &   iprev,8800+irecv,FG_COMM,status,IERR)
3174 c        write (iout,*) "Gather PRECOMP22"
3175 c        call flush(iout)
3176         call MPI_SENDRECV(Ug2DtEUgder(1,1,1,ivec_displ(isend)+1),1,
3177      &   MPI_PRECOMP23(lensend),inext,9900+isend,
3178      &   Ug2DtEUgder(1,1,1,ivec_displ(irecv)+1),1,
3179      &   MPI_PRECOMP23(lenrecv),
3180      &   iprev,9900+irecv,FG_COMM,status,IERR)
3181 c        write (iout,*) "Gather PRECOMP23"
3182 c        call flush(iout)
3183         endif
3184         isend=irecv
3185         irecv=irecv-1
3186         if (irecv.lt.0) irecv=nfgtasks1-1
3187       enddo
3188 #endif
3189         time_gather=time_gather+MPI_Wtime()-time00
3190       endif
3191 #ifdef DEBUG
3192 c      if (fg_rank.eq.0) then
3193         write (iout,*) "Arrays UG and UGDER"
3194         do i=1,nres-1
3195           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3196      &     ((ug(l,k,i),l=1,2),k=1,2),
3197      &     ((ugder(l,k,i),l=1,2),k=1,2)
3198         enddo
3199         write (iout,*) "Arrays UG2 and UG2DER"
3200         do i=1,nres-1
3201           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3202      &     ((ug2(l,k,i),l=1,2),k=1,2),
3203      &     ((ug2der(l,k,i),l=1,2),k=1,2)
3204         enddo
3205         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
3206         do i=1,nres-1
3207           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3208      &     (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
3209      &     (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
3210         enddo
3211         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
3212         do i=1,nres-1
3213           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3214      &     costab(i),sintab(i),costab2(i),sintab2(i)
3215         enddo
3216         write (iout,*) "Array MUDER"
3217         do i=1,nres-1
3218           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
3219         enddo
3220 c      endif
3221 #endif
3222 #endif
3223 cd      do i=1,nres
3224 cd        iti = itortyp(itype(i))
3225 cd        write (iout,*) i
3226 cd        do j=1,2
3227 cd        write (iout,'(2f10.5,5x,2f10.5,5x,2f10.5)')
3228 cd     &  (EE(j,k,iti),k=1,2),(Ug(j,k,i),k=1,2),(EUg(j,k,i),k=1,2)
3229 cd        enddo
3230 cd      enddo
3231       return
3232       end
3233 C--------------------------------------------------------------------------
3234       subroutine eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
3235 C
3236 C This subroutine calculates the average interaction energy and its gradient
3237 C in the virtual-bond vectors between non-adjacent peptide groups, based on
3238 C the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
3239 C The potential depends both on the distance of peptide-group centers and on
3240 C the orientation of the CA-CA virtual bonds.
3241 C
3242       implicit real*8 (a-h,o-z)
3243 #ifdef MPI
3244       include 'mpif.h'
3245 #endif
3246       include 'DIMENSIONS'
3247       include 'COMMON.CONTROL'
3248       include 'COMMON.SETUP'
3249       include 'COMMON.IOUNITS'
3250       include 'COMMON.GEO'
3251       include 'COMMON.VAR'
3252       include 'COMMON.LOCAL'
3253       include 'COMMON.CHAIN'
3254       include 'COMMON.DERIV'
3255       include 'COMMON.INTERACT'
3256       include 'COMMON.CONTACTS'
3257       include 'COMMON.TORSION'
3258       include 'COMMON.VECTORS'
3259       include 'COMMON.FFIELD'
3260       include 'COMMON.TIME1'
3261       include 'COMMON.SPLITELE'
3262       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
3263      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
3264       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
3265      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4),gmuij(4)
3266       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3267      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3268      &    num_conti,j1,j2
3269 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
3270 #ifdef MOMENT
3271       double precision scal_el /1.0d0/
3272 #else
3273       double precision scal_el /0.5d0/
3274 #endif
3275 C 12/13/98
3276 C 13-go grudnia roku pamietnego...
3277       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
3278      &                   0.0d0,1.0d0,0.0d0,
3279      &                   0.0d0,0.0d0,1.0d0/
3280 cd      write(iout,*) 'In EELEC'
3281 cd      do i=1,nloctyp
3282 cd        write(iout,*) 'Type',i
3283 cd        write(iout,*) 'B1',B1(:,i)
3284 cd        write(iout,*) 'B2',B2(:,i)
3285 cd        write(iout,*) 'CC',CC(:,:,i)
3286 cd        write(iout,*) 'DD',DD(:,:,i)
3287 cd        write(iout,*) 'EE',EE(:,:,i)
3288 cd      enddo
3289 cd      call check_vecgrad
3290 cd      stop
3291       if (icheckgrad.eq.1) then
3292         do i=1,nres-1
3293           fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
3294           do k=1,3
3295             dc_norm(k,i)=dc(k,i)*fac
3296           enddo
3297 c          write (iout,*) 'i',i,' fac',fac
3298         enddo
3299       endif
3300       if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
3301      &    .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or.
3302      &    wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
3303 c        call vec_and_deriv
3304 #ifdef TIMING
3305         time01=MPI_Wtime()
3306 #endif
3307         call set_matrices
3308 #ifdef TIMING
3309         time_mat=time_mat+MPI_Wtime()-time01
3310 #endif
3311       endif
3312 cd      do i=1,nres-1
3313 cd        write (iout,*) 'i=',i
3314 cd        do k=1,3
3315 cd        write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
3316 cd        enddo
3317 cd        do k=1,3
3318 cd          write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
3319 cd     &     uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
3320 cd        enddo
3321 cd      enddo
3322       t_eelecij=0.0d0
3323       ees=0.0D0
3324       evdw1=0.0D0
3325       eel_loc=0.0d0
3326       eello_turn3=0.0d0
3327       eello_turn4=0.0d0
3328       ind=0
3329       do i=1,nres
3330         num_cont_hb(i)=0
3331       enddo
3332 cd      print '(a)','Enter EELEC'
3333 cd      write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
3334       do i=1,nres
3335         gel_loc_loc(i)=0.0d0
3336         gcorr_loc(i)=0.0d0
3337       enddo
3338 c
3339 c
3340 c 9/27/08 AL Split the interaction loop to ensure load balancing of turn terms
3341 C
3342 C Loop over i,i+2 and i,i+3 pairs of the peptide groups
3343 C
3344 C 14/01/2014 TURN3,TUNR4 does no go under periodic boundry condition
3345       do i=iturn3_start,iturn3_end
3346         if (i.le.1) cycle
3347 C        write(iout,*) "tu jest i",i
3348         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
3349 C changes suggested by Ana to avoid out of bounds
3350      & .or.((i+4).gt.nres)
3351      & .or.((i-1).le.0)
3352 C end of changes by Ana
3353      &  .or. itype(i+2).eq.ntyp1
3354      &  .or. itype(i+3).eq.ntyp1) cycle
3355         if(i.gt.1)then
3356           if(itype(i-1).eq.ntyp1)cycle
3357         end if
3358         if(i.LT.nres-3)then
3359           if (itype(i+4).eq.ntyp1) cycle
3360         end if
3361         dxi=dc(1,i)
3362         dyi=dc(2,i)
3363         dzi=dc(3,i)
3364         dx_normi=dc_norm(1,i)
3365         dy_normi=dc_norm(2,i)
3366         dz_normi=dc_norm(3,i)
3367         xmedi=c(1,i)+0.5d0*dxi
3368         ymedi=c(2,i)+0.5d0*dyi
3369         zmedi=c(3,i)+0.5d0*dzi
3370           xmedi=mod(xmedi,boxxsize)
3371           if (xmedi.lt.0) xmedi=xmedi+boxxsize
3372           ymedi=mod(ymedi,boxysize)
3373           if (ymedi.lt.0) ymedi=ymedi+boxysize
3374           zmedi=mod(zmedi,boxzsize)
3375           if (zmedi.lt.0) zmedi=zmedi+boxzsize
3376         num_conti=0
3377         call eelecij(i,i+2,ees,evdw1,eel_loc)
3378         if (wturn3.gt.0.0d0) call eturn3(i,eello_turn3)
3379         num_cont_hb(i)=num_conti
3380       enddo
3381       do i=iturn4_start,iturn4_end
3382         if (i.le.1) cycle
3383         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
3384 C changes suggested by Ana to avoid out of bounds
3385      & .or.((i+5).gt.nres)
3386      & .or.((i-1).le.0)
3387 C end of changes suggested by Ana
3388      &    .or. itype(i+3).eq.ntyp1
3389      &    .or. itype(i+4).eq.ntyp1
3390      &    .or. itype(i+5).eq.ntyp1
3391      &    .or. itype(i).eq.ntyp1
3392      &    .or. itype(i-1).eq.ntyp1
3393      &                             ) cycle
3394         dxi=dc(1,i)
3395         dyi=dc(2,i)
3396         dzi=dc(3,i)
3397         dx_normi=dc_norm(1,i)
3398         dy_normi=dc_norm(2,i)
3399         dz_normi=dc_norm(3,i)
3400         xmedi=c(1,i)+0.5d0*dxi
3401         ymedi=c(2,i)+0.5d0*dyi
3402         zmedi=c(3,i)+0.5d0*dzi
3403 C Return atom into box, boxxsize is size of box in x dimension
3404 c  194   continue
3405 c        if (xmedi.gt.((0.5d0)*boxxsize)) xmedi=xmedi-boxxsize
3406 c        if (xmedi.lt.((-0.5d0)*boxxsize)) xmedi=xmedi+boxxsize
3407 C Condition for being inside the proper box
3408 c        if ((xmedi.gt.((0.5d0)*boxxsize)).or.
3409 c     &       (xmedi.lt.((-0.5d0)*boxxsize))) then
3410 c        go to 194
3411 c        endif
3412 c  195   continue
3413 c        if (ymedi.gt.((0.5d0)*boxysize)) ymedi=ymedi-boxysize
3414 c        if (ymedi.lt.((-0.5d0)*boxysize)) ymedi=ymedi+boxysize
3415 C Condition for being inside the proper box
3416 c        if ((ymedi.gt.((0.5d0)*boxysize)).or.
3417 c     &       (ymedi.lt.((-0.5d0)*boxysize))) then
3418 c        go to 195
3419 c        endif
3420 c  196   continue
3421 c        if (zmedi.gt.((0.5d0)*boxzsize)) zmedi=zmedi-boxzsize
3422 c        if (zmedi.lt.((-0.5d0)*boxzsize)) zmedi=zmedi+boxzsize
3423 C Condition for being inside the proper box
3424 c        if ((zmedi.gt.((0.5d0)*boxzsize)).or.
3425 c     &       (zmedi.lt.((-0.5d0)*boxzsize))) then
3426 c        go to 196
3427 c        endif
3428           xmedi=mod(xmedi,boxxsize)
3429           if (xmedi.lt.0) xmedi=xmedi+boxxsize
3430           ymedi=mod(ymedi,boxysize)
3431           if (ymedi.lt.0) ymedi=ymedi+boxysize
3432           zmedi=mod(zmedi,boxzsize)
3433           if (zmedi.lt.0) zmedi=zmedi+boxzsize
3434
3435         num_conti=num_cont_hb(i)
3436 c        write(iout,*) "JESTEM W PETLI"
3437         call eelecij(i,i+3,ees,evdw1,eel_loc)
3438         if (wturn4.gt.0.0d0 .and. itype(i+2).ne.ntyp1)
3439      &   call eturn4(i,eello_turn4)
3440         num_cont_hb(i)=num_conti
3441       enddo   ! i
3442 C Loop over all neighbouring boxes
3443 C      do xshift=-1,1
3444 C      do yshift=-1,1
3445 C      do zshift=-1,1
3446 c
3447 c Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
3448 c
3449 CTU KURWA
3450       do i=iatel_s,iatel_e
3451 C        do i=75,75
3452         if (i.le.1) cycle
3453         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
3454 C changes suggested by Ana to avoid out of bounds
3455      & .or.((i+2).gt.nres)
3456      & .or.((i-1).le.0)
3457 C end of changes by Ana
3458      &  .or. itype(i+2).eq.ntyp1
3459      &  .or. itype(i-1).eq.ntyp1
3460      &                ) cycle
3461         dxi=dc(1,i)
3462         dyi=dc(2,i)
3463         dzi=dc(3,i)
3464         dx_normi=dc_norm(1,i)
3465         dy_normi=dc_norm(2,i)
3466         dz_normi=dc_norm(3,i)
3467         xmedi=c(1,i)+0.5d0*dxi
3468         ymedi=c(2,i)+0.5d0*dyi
3469         zmedi=c(3,i)+0.5d0*dzi
3470           xmedi=mod(xmedi,boxxsize)
3471           if (xmedi.lt.0) xmedi=xmedi+boxxsize
3472           ymedi=mod(ymedi,boxysize)
3473           if (ymedi.lt.0) ymedi=ymedi+boxysize
3474           zmedi=mod(zmedi,boxzsize)
3475           if (zmedi.lt.0) zmedi=zmedi+boxzsize
3476 C          xmedi=xmedi+xshift*boxxsize
3477 C          ymedi=ymedi+yshift*boxysize
3478 C          zmedi=zmedi+zshift*boxzsize
3479
3480 C Return tom into box, boxxsize is size of box in x dimension
3481 c  164   continue
3482 c        if (xmedi.gt.((xshift+0.5d0)*boxxsize)) xmedi=xmedi-boxxsize
3483 c        if (xmedi.lt.((xshift-0.5d0)*boxxsize)) xmedi=xmedi+boxxsize
3484 C Condition for being inside the proper box
3485 c        if ((xmedi.gt.((xshift+0.5d0)*boxxsize)).or.
3486 c     &       (xmedi.lt.((xshift-0.5d0)*boxxsize))) then
3487 c        go to 164
3488 c        endif
3489 c  165   continue
3490 c        if (ymedi.gt.((yshift+0.5d0)*boxysize)) ymedi=ymedi-boxysize
3491 c        if (ymedi.lt.((yshift-0.5d0)*boxysize)) ymedi=ymedi+boxysize
3492 C Condition for being inside the proper box
3493 c        if ((ymedi.gt.((yshift+0.5d0)*boxysize)).or.
3494 c     &       (ymedi.lt.((yshift-0.5d0)*boxysize))) then
3495 c        go to 165
3496 c        endif
3497 c  166   continue
3498 c        if (zmedi.gt.((zshift+0.5d0)*boxzsize)) zmedi=zmedi-boxzsize
3499 c        if (zmedi.lt.((zshift-0.5d0)*boxzsize)) zmedi=zmedi+boxzsize
3500 cC Condition for being inside the proper box
3501 c        if ((zmedi.gt.((zshift+0.5d0)*boxzsize)).or.
3502 c     &       (zmedi.lt.((zshift-0.5d0)*boxzsize))) then
3503 c        go to 166
3504 c        endif
3505
3506 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
3507         num_conti=num_cont_hb(i)
3508 C I TU KURWA
3509         do j=ielstart(i),ielend(i)
3510 C          do j=16,17
3511 C          write (iout,*) i,j
3512          if (j.le.1) cycle
3513           if (itype(j).eq.ntyp1.or. itype(j+1).eq.ntyp1
3514 C changes suggested by Ana to avoid out of bounds
3515      & .or.((j+2).gt.nres)
3516      & .or.((j-1).le.0)
3517 C end of changes by Ana
3518      & .or.itype(j+2).eq.ntyp1
3519      & .or.itype(j-1).eq.ntyp1
3520      &) cycle
3521           call eelecij(i,j,ees,evdw1,eel_loc)
3522         enddo ! j
3523         num_cont_hb(i)=num_conti
3524       enddo   ! i
3525 C     enddo   ! zshift
3526 C      enddo   ! yshift
3527 C      enddo   ! xshift
3528
3529 c      write (iout,*) "Number of loop steps in EELEC:",ind
3530 cd      do i=1,nres
3531 cd        write (iout,'(i3,3f10.5,5x,3f10.5)')
3532 cd     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
3533 cd      enddo
3534 c 12/7/99 Adam eello_turn3 will be considered as a separate energy term
3535 ccc      eel_loc=eel_loc+eello_turn3
3536 cd      print *,"Processor",fg_rank," t_eelecij",t_eelecij
3537       return
3538       end
3539 C-------------------------------------------------------------------------------
3540       subroutine eelecij(i,j,ees,evdw1,eel_loc)
3541       implicit real*8 (a-h,o-z)
3542       include 'DIMENSIONS'
3543 #ifdef MPI
3544       include "mpif.h"
3545 #endif
3546       include 'COMMON.CONTROL'
3547       include 'COMMON.IOUNITS'
3548       include 'COMMON.GEO'
3549       include 'COMMON.VAR'
3550       include 'COMMON.LOCAL'
3551       include 'COMMON.CHAIN'
3552       include 'COMMON.DERIV'
3553       include 'COMMON.INTERACT'
3554       include 'COMMON.CONTACTS'
3555       include 'COMMON.TORSION'
3556       include 'COMMON.VECTORS'
3557       include 'COMMON.FFIELD'
3558       include 'COMMON.TIME1'
3559       include 'COMMON.SPLITELE'
3560       include 'COMMON.SHIELD'
3561       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
3562      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
3563       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
3564      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4),gmuij1(4),gmuji1(4),
3565      &    gmuij2(4),gmuji2(4)
3566       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3567      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3568      &    num_conti,j1,j2
3569 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
3570 #ifdef MOMENT
3571       double precision scal_el /1.0d0/
3572 #else
3573       double precision scal_el /0.5d0/
3574 #endif
3575 C 12/13/98
3576 C 13-go grudnia roku pamietnego...
3577       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
3578      &                   0.0d0,1.0d0,0.0d0,
3579      &                   0.0d0,0.0d0,1.0d0/
3580 c          time00=MPI_Wtime()
3581 cd      write (iout,*) "eelecij",i,j
3582 c          ind=ind+1
3583           iteli=itel(i)
3584           itelj=itel(j)
3585           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
3586           aaa=app(iteli,itelj)
3587           bbb=bpp(iteli,itelj)
3588           ael6i=ael6(iteli,itelj)
3589           ael3i=ael3(iteli,itelj)
3590           dxj=dc(1,j)
3591           dyj=dc(2,j)
3592           dzj=dc(3,j)
3593           dx_normj=dc_norm(1,j)
3594           dy_normj=dc_norm(2,j)
3595           dz_normj=dc_norm(3,j)
3596 C          xj=c(1,j)+0.5D0*dxj-xmedi
3597 C          yj=c(2,j)+0.5D0*dyj-ymedi
3598 C          zj=c(3,j)+0.5D0*dzj-zmedi
3599           xj=c(1,j)+0.5D0*dxj
3600           yj=c(2,j)+0.5D0*dyj
3601           zj=c(3,j)+0.5D0*dzj
3602           xj=mod(xj,boxxsize)
3603           if (xj.lt.0) xj=xj+boxxsize
3604           yj=mod(yj,boxysize)
3605           if (yj.lt.0) yj=yj+boxysize
3606           zj=mod(zj,boxzsize)
3607           if (zj.lt.0) zj=zj+boxzsize
3608           if ((zj.lt.0).or.(xj.lt.0).or.(yj.lt.0)) write (*,*) "CHUJ"
3609       dist_init=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
3610       xj_safe=xj
3611       yj_safe=yj
3612       zj_safe=zj
3613       isubchap=0
3614       do xshift=-1,1
3615       do yshift=-1,1
3616       do zshift=-1,1
3617           xj=xj_safe+xshift*boxxsize
3618           yj=yj_safe+yshift*boxysize
3619           zj=zj_safe+zshift*boxzsize
3620           dist_temp=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
3621           if(dist_temp.lt.dist_init) then
3622             dist_init=dist_temp
3623             xj_temp=xj
3624             yj_temp=yj
3625             zj_temp=zj
3626             isubchap=1
3627           endif
3628        enddo
3629        enddo
3630        enddo
3631        if (isubchap.eq.1) then
3632           xj=xj_temp-xmedi
3633           yj=yj_temp-ymedi
3634           zj=zj_temp-zmedi
3635        else
3636           xj=xj_safe-xmedi
3637           yj=yj_safe-ymedi
3638           zj=zj_safe-zmedi
3639        endif
3640 C        if ((i+3).lt.j) then !this condition keeps for turn3 and turn4 not subject to PBC
3641 c  174   continue
3642 c        if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
3643 c        if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
3644 C Condition for being inside the proper box
3645 c        if ((xj.gt.((0.5d0)*boxxsize)).or.
3646 c     &       (xj.lt.((-0.5d0)*boxxsize))) then
3647 c        go to 174
3648 c        endif
3649 c  175   continue
3650 c        if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
3651 c        if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
3652 C Condition for being inside the proper box
3653 c        if ((yj.gt.((0.5d0)*boxysize)).or.
3654 c     &       (yj.lt.((-0.5d0)*boxysize))) then
3655 c        go to 175
3656 c        endif
3657 c  176   continue
3658 c        if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
3659 c        if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
3660 C Condition for being inside the proper box
3661 c        if ((zj.gt.((0.5d0)*boxzsize)).or.
3662 c     &       (zj.lt.((-0.5d0)*boxzsize))) then
3663 c        go to 176
3664 c        endif
3665 C        endif !endPBC condintion
3666 C        xj=xj-xmedi
3667 C        yj=yj-ymedi
3668 C        zj=zj-zmedi
3669           rij=xj*xj+yj*yj+zj*zj
3670
3671             sss=sscale(sqrt(rij))
3672             sssgrad=sscagrad(sqrt(rij))
3673 c            if (sss.gt.0.0d0) then
3674           rrmij=1.0D0/rij
3675           rij=dsqrt(rij)
3676           rmij=1.0D0/rij
3677           r3ij=rrmij*rmij
3678           r6ij=r3ij*r3ij
3679           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
3680           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
3681           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
3682           fac=cosa-3.0D0*cosb*cosg
3683           ev1=aaa*r6ij*r6ij
3684 c 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
3685           if (j.eq.i+2) ev1=scal_el*ev1
3686           ev2=bbb*r6ij
3687           fac3=ael6i*r6ij
3688           fac4=ael3i*r3ij
3689           evdwij=(ev1+ev2)
3690           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
3691           el2=fac4*fac
3692 C MARYSIA
3693 C          eesij=(el1+el2)
3694 C 12/26/95 - for the evaluation of multi-body H-bonding interactions
3695           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
3696           if (shield_mode.gt.0) then
3697 C          fac_shield(i)=0.4
3698 C          fac_shield(j)=0.6
3699           el1=el1*fac_shield(i)*fac_shield(j)
3700           el2=el2*fac_shield(i)*fac_shield(j)
3701           eesij=(el1+el2)
3702           ees=ees+eesij
3703           else
3704           fac_shield(i)=1.0
3705           fac_shield(j)=1.0
3706           eesij=(el1+el2)
3707           ees=ees+eesij
3708           endif
3709           evdw1=evdw1+evdwij*sss
3710 cd          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
3711 cd     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
3712 cd     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
3713 cd     &      xmedi,ymedi,zmedi,xj,yj,zj
3714
3715           if (energy_dec) then
3716               write (iout,'(a6,2i5,0pf7.3,2i5,2e11.3)')
3717      &'evdw1',i,j,evdwij
3718      &,iteli,itelj,aaa,evdw1
3719               write (iout,'(a6,2i5,0pf7.3)') 'ees',i,j,eesij
3720           endif
3721
3722 C
3723 C Calculate contributions to the Cartesian gradient.
3724 C
3725 #ifdef SPLITELE
3726           facvdw=-6*rrmij*(ev1+evdwij)*sss
3727           facel=-3*rrmij*(el1+eesij)
3728           fac1=fac
3729           erij(1)=xj*rmij
3730           erij(2)=yj*rmij
3731           erij(3)=zj*rmij
3732
3733 *
3734 * Radial derivatives. First process both termini of the fragment (i,j)
3735 *
3736           ggg(1)=facel*xj
3737           ggg(2)=facel*yj
3738           ggg(3)=facel*zj
3739           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
3740      &  (shield_mode.gt.0)) then
3741 C          print *,i,j
3742           do ilist=1,ishield_list(i)
3743            iresshield=shield_list(ilist,i)
3744            do k=1,3
3745            rlocshield=grad_shield_side(k,ilist,i)*eesij/fac_shield(i)
3746            gshieldx(k,iresshield)=gshieldx(k,iresshield)+
3747      &              rlocshield
3748      & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)
3749             gshieldc(k,iresshield-1)=gshieldc(k,iresshield-1)+rlocshield
3750 C           gshieldc_loc(k,iresshield)=gshieldc_loc(k,iresshield)
3751 C     & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)
3752 C             if (iresshield.gt.i) then
3753 C               do ishi=i+1,iresshield-1
3754 C                gshieldc(k,ishi)=gshieldc(k,ishi)+rlocshield
3755 C     & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)
3756 C
3757 C              enddo
3758 C             else
3759 C               do ishi=iresshield,i
3760 C                gshieldc(k,ishi)=gshieldc(k,ishi)-rlocshield
3761 C     & -grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)
3762 C
3763 C               enddo
3764 C              endif
3765            enddo
3766           enddo
3767           do ilist=1,ishield_list(j)
3768            iresshield=shield_list(ilist,j)
3769            do k=1,3
3770            rlocshield=grad_shield_side(k,ilist,j)*eesij/fac_shield(j)
3771            gshieldx(k,iresshield)=gshieldx(k,iresshield)+
3772      &              rlocshield
3773      & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
3774            gshieldc(k,iresshield-1)=gshieldc(k,iresshield-1)+rlocshield
3775
3776 C     & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
3777 C           gshieldc_loc(k,iresshield)=gshieldc_loc(k,iresshield)
3778 C     & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
3779 C             if (iresshield.gt.j) then
3780 C               do ishi=j+1,iresshield-1
3781 C                gshieldc(k,ishi)=gshieldc(k,ishi)+rlocshield
3782 C     & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
3783 C
3784 C               enddo
3785 C            else
3786 C               do ishi=iresshield,j
3787 C                gshieldc(k,ishi)=gshieldc(k,ishi)-rlocshield
3788 C     & -grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
3789 C               enddo
3790 C              endif
3791            enddo
3792           enddo
3793
3794           do k=1,3
3795             gshieldc(k,i)=gshieldc(k,i)+
3796      &              grad_shield(k,i)*eesij/fac_shield(i)
3797             gshieldc(k,j)=gshieldc(k,j)+
3798      &              grad_shield(k,j)*eesij/fac_shield(j)
3799             gshieldc(k,i-1)=gshieldc(k,i-1)+
3800      &              grad_shield(k,i)*eesij/fac_shield(i)
3801             gshieldc(k,j-1)=gshieldc(k,j-1)+
3802      &              grad_shield(k,j)*eesij/fac_shield(j)
3803
3804            enddo
3805            endif
3806 c          do k=1,3
3807 c            ghalf=0.5D0*ggg(k)
3808 c            gelc(k,i)=gelc(k,i)+ghalf
3809 c            gelc(k,j)=gelc(k,j)+ghalf
3810 c          enddo
3811 c 9/28/08 AL Gradient compotents will be summed only at the end
3812 C           print *,"before", gelc_long(1,i), gelc_long(1,j)
3813           do k=1,3
3814             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
3815 C     &                    +grad_shield(k,j)*eesij/fac_shield(j)
3816             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
3817 C     &                    +grad_shield(k,i)*eesij/fac_shield(i)
3818 C            gelc_long(k,i-1)=gelc_long(k,i-1)
3819 C     &                    +grad_shield(k,i)*eesij/fac_shield(i)
3820 C            gelc_long(k,j-1)=gelc_long(k,j-1)
3821 C     &                    +grad_shield(k,j)*eesij/fac_shield(j)
3822           enddo
3823 C           print *,"bafter", gelc_long(1,i), gelc_long(1,j)
3824
3825 *
3826 * Loop over residues i+1 thru j-1.
3827 *
3828 cgrad          do k=i+1,j-1
3829 cgrad            do l=1,3
3830 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3831 cgrad            enddo
3832 cgrad          enddo
3833           if (sss.gt.0.0) then
3834           ggg(1)=facvdw*xj+sssgrad*rmij*evdwij*xj
3835           ggg(2)=facvdw*yj+sssgrad*rmij*evdwij*yj
3836           ggg(3)=facvdw*zj+sssgrad*rmij*evdwij*zj
3837           else
3838           ggg(1)=0.0
3839           ggg(2)=0.0
3840           ggg(3)=0.0
3841           endif
3842 c          do k=1,3
3843 c            ghalf=0.5D0*ggg(k)
3844 c            gvdwpp(k,i)=gvdwpp(k,i)+ghalf
3845 c            gvdwpp(k,j)=gvdwpp(k,j)+ghalf
3846 c          enddo
3847 c 9/28/08 AL Gradient compotents will be summed only at the end
3848           do k=1,3
3849             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
3850             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
3851           enddo
3852 *
3853 * Loop over residues i+1 thru j-1.
3854 *
3855 cgrad          do k=i+1,j-1
3856 cgrad            do l=1,3
3857 cgrad              gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
3858 cgrad            enddo
3859 cgrad          enddo
3860 #else
3861 C MARYSIA
3862           facvdw=(ev1+evdwij)*sss
3863           facel=(el1+eesij)
3864           fac1=fac
3865           fac=-3*rrmij*(facvdw+facvdw+facel)
3866           erij(1)=xj*rmij
3867           erij(2)=yj*rmij
3868           erij(3)=zj*rmij
3869 *
3870 * Radial derivatives. First process both termini of the fragment (i,j)
3871 *
3872           ggg(1)=fac*xj
3873 C+eesij*grad_shield(1,i)+eesij*grad_shield(1,j)
3874           ggg(2)=fac*yj
3875 C+eesij*grad_shield(2,i)+eesij*grad_shield(2,j)
3876           ggg(3)=fac*zj
3877 C+eesij*grad_shield(3,i)+eesij*grad_shield(3,j)
3878 c          do k=1,3
3879 c            ghalf=0.5D0*ggg(k)
3880 c            gelc(k,i)=gelc(k,i)+ghalf
3881 c            gelc(k,j)=gelc(k,j)+ghalf
3882 c          enddo
3883 c 9/28/08 AL Gradient compotents will be summed only at the end
3884           do k=1,3
3885             gelc_long(k,j)=gelc(k,j)+ggg(k)
3886             gelc_long(k,i)=gelc(k,i)-ggg(k)
3887           enddo
3888 *
3889 * Loop over residues i+1 thru j-1.
3890 *
3891 cgrad          do k=i+1,j-1
3892 cgrad            do l=1,3
3893 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3894 cgrad            enddo
3895 cgrad          enddo
3896 c 9/28/08 AL Gradient compotents will be summed only at the end
3897           ggg(1)=facvdw*xj+sssgrad*rmij*evdwij*xj
3898           ggg(2)=facvdw*yj+sssgrad*rmij*evdwij*yj
3899           ggg(3)=facvdw*zj+sssgrad*rmij*evdwij*zj
3900           do k=1,3
3901             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
3902             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
3903           enddo
3904 #endif
3905 *
3906 * Angular part
3907 *
3908           ecosa=2.0D0*fac3*fac1+fac4
3909           fac4=-3.0D0*fac4
3910           fac3=-6.0D0*fac3
3911           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
3912           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
3913           do k=1,3
3914             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
3915             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
3916           enddo
3917 cd        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
3918 cd   &          (dcosg(k),k=1,3)
3919           do k=1,3
3920             ggg(k)=(ecosb*dcosb(k)+ecosg*dcosg(k))*
3921      &      fac_shield(i)*fac_shield(j)
3922           enddo
3923 c          do k=1,3
3924 c            ghalf=0.5D0*ggg(k)
3925 c            gelc(k,i)=gelc(k,i)+ghalf
3926 c     &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
3927 c     &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3928 c            gelc(k,j)=gelc(k,j)+ghalf
3929 c     &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
3930 c     &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3931 c          enddo
3932 cgrad          do k=i+1,j-1
3933 cgrad            do l=1,3
3934 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3935 cgrad            enddo
3936 cgrad          enddo
3937 C                     print *,"before22", gelc_long(1,i), gelc_long(1,j)
3938           do k=1,3
3939             gelc(k,i)=gelc(k,i)
3940      &           +((ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
3941      &           + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1))
3942      &           *fac_shield(i)*fac_shield(j)
3943             gelc(k,j)=gelc(k,j)
3944      &           +((ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
3945      &           + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1))
3946      &           *fac_shield(i)*fac_shield(j)
3947             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
3948             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
3949           enddo
3950 C           print *,"before33", gelc_long(1,i), gelc_long(1,j)
3951
3952 C MARYSIA
3953 c          endif !sscale
3954           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
3955      &        .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0
3956      &        .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
3957 C
3958 C 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
3959 C   energy of a peptide unit is assumed in the form of a second-order
3960 C   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
3961 C   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
3962 C   are computed for EVERY pair of non-contiguous peptide groups.
3963 C
3964
3965           if (j.lt.nres-1) then
3966             j1=j+1
3967             j2=j-1
3968           else
3969             j1=j-1
3970             j2=j-2
3971           endif
3972           kkk=0
3973           lll=0
3974           do k=1,2
3975             do l=1,2
3976               kkk=kkk+1
3977               muij(kkk)=mu(k,i)*mu(l,j)
3978 c              write(iout,*) 'mumu=', mu(k,i),mu(l,j),i,j,k,l
3979 #ifdef NEWCORR
3980              gmuij1(kkk)=gtb1(k,i+1)*mu(l,j)
3981 c             write(iout,*) 'k=',k,i,gtb1(k,i+1),gtb1(k,i+1)*mu(l,j)
3982              gmuij2(kkk)=gUb2(k,i)*mu(l,j)
3983              gmuji1(kkk)=mu(k,i)*gtb1(l,j+1)
3984 c             write(iout,*) 'l=',l,j,gtb1(l,j+1),gtb1(l,j+1)*mu(k,i)
3985              gmuji2(kkk)=mu(k,i)*gUb2(l,j)
3986 #endif
3987             enddo
3988           enddo
3989 cd         write (iout,*) 'EELEC: i',i,' j',j
3990 cd          write (iout,*) 'j',j,' j1',j1,' j2',j2
3991 cd          write(iout,*) 'muij',muij
3992           ury=scalar(uy(1,i),erij)
3993           urz=scalar(uz(1,i),erij)
3994           vry=scalar(uy(1,j),erij)
3995           vrz=scalar(uz(1,j),erij)
3996           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
3997           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
3998           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
3999           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
4000           fac=dsqrt(-ael6i)*r3ij
4001           a22=a22*fac
4002           a23=a23*fac
4003           a32=a32*fac
4004           a33=a33*fac
4005 cd          write (iout,'(4i5,4f10.5)')
4006 cd     &     i,itortyp(itype(i)),j,itortyp(itype(j)),a22,a23,a32,a33
4007 cd          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
4008 cd          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') uy(:,i),uz(:,i),
4009 cd     &      uy(:,j),uz(:,j)
4010 cd          write (iout,'(4f10.5)')
4011 cd     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
4012 cd     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
4013 cd          write (iout,'(4f10.5)') ury,urz,vry,vrz
4014 cd           write (iout,'(9f10.5/)')
4015 cd     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
4016 C Derivatives of the elements of A in virtual-bond vectors
4017           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
4018           do k=1,3
4019             uryg(k,1)=scalar(erder(1,k),uy(1,i))
4020             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
4021             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
4022             urzg(k,1)=scalar(erder(1,k),uz(1,i))
4023             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
4024             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
4025             vryg(k,1)=scalar(erder(1,k),uy(1,j))
4026             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
4027             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
4028             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
4029             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
4030             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
4031           enddo
4032 C Compute radial contributions to the gradient
4033           facr=-3.0d0*rrmij
4034           a22der=a22*facr
4035           a23der=a23*facr
4036           a32der=a32*facr
4037           a33der=a33*facr
4038           agg(1,1)=a22der*xj
4039           agg(2,1)=a22der*yj
4040           agg(3,1)=a22der*zj
4041           agg(1,2)=a23der*xj
4042           agg(2,2)=a23der*yj
4043           agg(3,2)=a23der*zj
4044           agg(1,3)=a32der*xj
4045           agg(2,3)=a32der*yj
4046           agg(3,3)=a32der*zj
4047           agg(1,4)=a33der*xj
4048           agg(2,4)=a33der*yj
4049           agg(3,4)=a33der*zj
4050 C Add the contributions coming from er
4051           fac3=-3.0d0*fac
4052           do k=1,3
4053             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
4054             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
4055             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
4056             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
4057           enddo
4058           do k=1,3
4059 C Derivatives in DC(i)
4060 cgrad            ghalf1=0.5d0*agg(k,1)
4061 cgrad            ghalf2=0.5d0*agg(k,2)
4062 cgrad            ghalf3=0.5d0*agg(k,3)
4063 cgrad            ghalf4=0.5d0*agg(k,4)
4064             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j))
4065      &      -3.0d0*uryg(k,2)*vry)!+ghalf1
4066             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j))
4067      &      -3.0d0*uryg(k,2)*vrz)!+ghalf2
4068             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j))
4069      &      -3.0d0*urzg(k,2)*vry)!+ghalf3
4070             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j))
4071      &      -3.0d0*urzg(k,2)*vrz)!+ghalf4
4072 C Derivatives in DC(i+1)
4073             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j))
4074      &      -3.0d0*uryg(k,3)*vry)!+agg(k,1)
4075             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j))
4076      &      -3.0d0*uryg(k,3)*vrz)!+agg(k,2)
4077             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j))
4078      &      -3.0d0*urzg(k,3)*vry)!+agg(k,3)
4079             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j))
4080      &      -3.0d0*urzg(k,3)*vrz)!+agg(k,4)
4081 C Derivatives in DC(j)
4082             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i))
4083      &      -3.0d0*vryg(k,2)*ury)!+ghalf1
4084             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i))
4085      &      -3.0d0*vrzg(k,2)*ury)!+ghalf2
4086             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i))
4087      &      -3.0d0*vryg(k,2)*urz)!+ghalf3
4088             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i))
4089      &      -3.0d0*vrzg(k,2)*urz)!+ghalf4
4090 C Derivatives in DC(j+1) or DC(nres-1)
4091             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i))
4092      &      -3.0d0*vryg(k,3)*ury)
4093             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i))
4094      &      -3.0d0*vrzg(k,3)*ury)
4095             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i))
4096      &      -3.0d0*vryg(k,3)*urz)
4097             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i))
4098      &      -3.0d0*vrzg(k,3)*urz)
4099 cgrad            if (j.eq.nres-1 .and. i.lt.j-2) then
4100 cgrad              do l=1,4
4101 cgrad                aggj1(k,l)=aggj1(k,l)+agg(k,l)
4102 cgrad              enddo
4103 cgrad            endif
4104           enddo
4105           acipa(1,1)=a22
4106           acipa(1,2)=a23
4107           acipa(2,1)=a32
4108           acipa(2,2)=a33
4109           a22=-a22
4110           a23=-a23
4111           do l=1,2
4112             do k=1,3
4113               agg(k,l)=-agg(k,l)
4114               aggi(k,l)=-aggi(k,l)
4115               aggi1(k,l)=-aggi1(k,l)
4116               aggj(k,l)=-aggj(k,l)
4117               aggj1(k,l)=-aggj1(k,l)
4118             enddo
4119           enddo
4120           if (j.lt.nres-1) then
4121             a22=-a22
4122             a32=-a32
4123             do l=1,3,2
4124               do k=1,3
4125                 agg(k,l)=-agg(k,l)
4126                 aggi(k,l)=-aggi(k,l)
4127                 aggi1(k,l)=-aggi1(k,l)
4128                 aggj(k,l)=-aggj(k,l)
4129                 aggj1(k,l)=-aggj1(k,l)
4130               enddo
4131             enddo
4132           else
4133             a22=-a22
4134             a23=-a23
4135             a32=-a32
4136             a33=-a33
4137             do l=1,4
4138               do k=1,3
4139                 agg(k,l)=-agg(k,l)
4140                 aggi(k,l)=-aggi(k,l)
4141                 aggi1(k,l)=-aggi1(k,l)
4142                 aggj(k,l)=-aggj(k,l)
4143                 aggj1(k,l)=-aggj1(k,l)
4144               enddo
4145             enddo
4146           endif
4147           ENDIF ! WCORR
4148           IF (wel_loc.gt.0.0d0) THEN
4149 C Contribution to the local-electrostatic energy coming from the i-j pair
4150           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3)
4151      &     +a33*muij(4)
4152 c          write (iout,*) 'i',i,' j',j,itype(i),itype(j),
4153 c     &                     ' eel_loc_ij',eel_loc_ij
4154 c          write(iout,*) 'muije=',muij(1),muij(2),muij(3),muij(4)
4155 C Calculate patrial derivative for theta angle
4156 #ifdef NEWCORR
4157          geel_loc_ij=a22*gmuij1(1)
4158      &     +a23*gmuij1(2)
4159      &     +a32*gmuij1(3)
4160      &     +a33*gmuij1(4)
4161 c         write(iout,*) "derivative over thatai"
4162 c         write(iout,*) a22*gmuij1(1), a23*gmuij1(2) ,a32*gmuij1(3),
4163 c     &   a33*gmuij1(4)
4164          gloc(nphi+i,icg)=gloc(nphi+i,icg)+
4165      &      geel_loc_ij*wel_loc
4166 c         write(iout,*) "derivative over thatai-1"
4167 c         write(iout,*) a22*gmuij2(1), a23*gmuij2(2) ,a32*gmuij2(3),
4168 c     &   a33*gmuij2(4)
4169          geel_loc_ij=
4170      &     a22*gmuij2(1)
4171      &     +a23*gmuij2(2)
4172      &     +a32*gmuij2(3)
4173      &     +a33*gmuij2(4)
4174          gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
4175      &      geel_loc_ij*wel_loc
4176 c  Derivative over j residue
4177          geel_loc_ji=a22*gmuji1(1)
4178      &     +a23*gmuji1(2)
4179      &     +a32*gmuji1(3)
4180      &     +a33*gmuji1(4)
4181 c         write(iout,*) "derivative over thataj"
4182 c         write(iout,*) a22*gmuji1(1), a23*gmuji1(2) ,a32*gmuji1(3),
4183 c     &   a33*gmuji1(4)
4184
4185         gloc(nphi+j,icg)=gloc(nphi+j,icg)+
4186      &      geel_loc_ji*wel_loc
4187          geel_loc_ji=
4188      &     +a22*gmuji2(1)
4189      &     +a23*gmuji2(2)
4190      &     +a32*gmuji2(3)
4191      &     +a33*gmuji2(4)
4192 c         write(iout,*) "derivative over thataj-1"
4193 c         write(iout,*) a22*gmuji2(1), a23*gmuji2(2) ,a32*gmuji2(3),
4194 c     &   a33*gmuji2(4)
4195          gloc(nphi+j-1,icg)=gloc(nphi+j-1,icg)+
4196      &      geel_loc_ji*wel_loc
4197 #endif
4198 cd          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
4199
4200           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
4201      &            'eelloc',i,j,eel_loc_ij
4202 c           if (eel_loc_ij.ne.0)
4203 c     &      write (iout,'(a4,2i4,8f9.5)')'chuj',
4204 c     &     i,j,a22,muij(1),a23,muij(2),a32,muij(3),a33,muij(4)
4205
4206           eel_loc=eel_loc+eel_loc_ij
4207 C Partial derivatives in virtual-bond dihedral angles gamma
4208           if (i.gt.1)
4209      &    gel_loc_loc(i-1)=gel_loc_loc(i-1)+
4210      &            a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j)
4211      &           +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j)
4212           gel_loc_loc(j-1)=gel_loc_loc(j-1)+
4213      &            a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j)
4214      &           +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j)
4215 C Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
4216           do l=1,3
4217             ggg(l)=agg(l,1)*muij(1)+
4218      &          agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4)
4219             gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l)
4220             gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l)
4221 cgrad            ghalf=0.5d0*ggg(l)
4222 cgrad            gel_loc(l,i)=gel_loc(l,i)+ghalf
4223 cgrad            gel_loc(l,j)=gel_loc(l,j)+ghalf
4224           enddo
4225 cgrad          do k=i+1,j2
4226 cgrad            do l=1,3
4227 cgrad              gel_loc(l,k)=gel_loc(l,k)+ggg(l)
4228 cgrad            enddo
4229 cgrad          enddo
4230 C Remaining derivatives of eello
4231           do l=1,3
4232             gel_loc(l,i)=gel_loc(l,i)+(aggi(l,1)*muij(1)+
4233      &        aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4))
4234             gel_loc(l,i+1)=gel_loc(l,i+1)+(aggi1(l,1)*muij(1)+
4235      &     aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4))
4236             gel_loc(l,j)=gel_loc(l,j)+(aggj(l,1)*muij(1)+
4237      &       aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4))
4238             gel_loc(l,j1)=gel_loc(l,j1)+(aggj1(l,1)*muij(1)+
4239      &     aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4))
4240           enddo
4241           ENDIF
4242 C Change 12/26/95 to calculate four-body contributions to H-bonding energy
4243 c          if (j.gt.i+1 .and. num_conti.le.maxconts) then
4244           if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0
4245      &       .and. num_conti.le.maxconts) then
4246 c            write (iout,*) i,j," entered corr"
4247 C
4248 C Calculate the contact function. The ith column of the array JCONT will
4249 C contain the numbers of atoms that make contacts with the atom I (of numbers
4250 C greater than I). The arrays FACONT and GACONT will contain the values of
4251 C the contact function and its derivative.
4252 c           r0ij=1.02D0*rpp(iteli,itelj)
4253 c           r0ij=1.11D0*rpp(iteli,itelj)
4254             r0ij=2.20D0*rpp(iteli,itelj)
4255 c           r0ij=1.55D0*rpp(iteli,itelj)
4256             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
4257             if (fcont.gt.0.0D0) then
4258               num_conti=num_conti+1
4259               if (num_conti.gt.maxconts) then
4260                 write (iout,*) 'WARNING - max. # of contacts exceeded;',
4261      &                         ' will skip next contacts for this conf.'
4262               else
4263                 jcont_hb(num_conti,i)=j
4264 cd                write (iout,*) "i",i," j",j," num_conti",num_conti,
4265 cd     &           " jcont_hb",jcont_hb(num_conti,i)
4266                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.
4267      &          wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
4268 C 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
4269 C  terms.
4270                 d_cont(num_conti,i)=rij
4271 cd                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
4272 C     --- Electrostatic-interaction matrix ---
4273                 a_chuj(1,1,num_conti,i)=a22
4274                 a_chuj(1,2,num_conti,i)=a23
4275                 a_chuj(2,1,num_conti,i)=a32
4276                 a_chuj(2,2,num_conti,i)=a33
4277 C     --- Gradient of rij
4278                 do kkk=1,3
4279                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
4280                 enddo
4281                 kkll=0
4282                 do k=1,2
4283                   do l=1,2
4284                     kkll=kkll+1
4285                     do m=1,3
4286                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
4287                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
4288                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
4289                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
4290                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
4291                     enddo
4292                   enddo
4293                 enddo
4294                 ENDIF
4295                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
4296 C Calculate contact energies
4297                 cosa4=4.0D0*cosa
4298                 wij=cosa-3.0D0*cosb*cosg
4299                 cosbg1=cosb+cosg
4300                 cosbg2=cosb-cosg
4301 c               fac3=dsqrt(-ael6i)/r0ij**3
4302                 fac3=dsqrt(-ael6i)*r3ij
4303 c                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
4304                 ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
4305                 if (ees0tmp.gt.0) then
4306                   ees0pij=dsqrt(ees0tmp)
4307                 else
4308                   ees0pij=0
4309                 endif
4310 c                ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
4311                 ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
4312                 if (ees0tmp.gt.0) then
4313                   ees0mij=dsqrt(ees0tmp)
4314                 else
4315                   ees0mij=0
4316                 endif
4317 c               ees0mij=0.0D0
4318                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij)
4319                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij)
4320 C Diagnostics. Comment out or remove after debugging!
4321 c               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
4322 c               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
4323 c               ees0m(num_conti,i)=0.0D0
4324 C End diagnostics.
4325 c               write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
4326 c    & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
4327 C Angular derivatives of the contact function
4328                 ees0pij1=fac3/ees0pij
4329                 ees0mij1=fac3/ees0mij
4330                 fac3p=-3.0D0*fac3*rrmij
4331                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
4332                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
4333 c               ees0mij1=0.0D0
4334                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
4335                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
4336                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
4337                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
4338                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
4339                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
4340                 ecosap=ecosa1+ecosa2
4341                 ecosbp=ecosb1+ecosb2
4342                 ecosgp=ecosg1+ecosg2
4343                 ecosam=ecosa1-ecosa2
4344                 ecosbm=ecosb1-ecosb2
4345                 ecosgm=ecosg1-ecosg2
4346 C Diagnostics
4347 c               ecosap=ecosa1
4348 c               ecosbp=ecosb1
4349 c               ecosgp=ecosg1
4350 c               ecosam=0.0D0
4351 c               ecosbm=0.0D0
4352 c               ecosgm=0.0D0
4353 C End diagnostics
4354                 facont_hb(num_conti,i)=fcont
4355                 fprimcont=fprimcont/rij
4356 cd              facont_hb(num_conti,i)=1.0D0
4357 C Following line is for diagnostics.
4358 cd              fprimcont=0.0D0
4359                 do k=1,3
4360                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
4361                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
4362                 enddo
4363                 do k=1,3
4364                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
4365                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
4366                 enddo
4367                 gggp(1)=gggp(1)+ees0pijp*xj
4368                 gggp(2)=gggp(2)+ees0pijp*yj
4369                 gggp(3)=gggp(3)+ees0pijp*zj
4370                 gggm(1)=gggm(1)+ees0mijp*xj
4371                 gggm(2)=gggm(2)+ees0mijp*yj
4372                 gggm(3)=gggm(3)+ees0mijp*zj
4373 C Derivatives due to the contact function
4374                 gacont_hbr(1,num_conti,i)=fprimcont*xj
4375                 gacont_hbr(2,num_conti,i)=fprimcont*yj
4376                 gacont_hbr(3,num_conti,i)=fprimcont*zj
4377                 do k=1,3
4378 c
4379 c 10/24/08 cgrad and ! comments indicate the parts of the code removed
4380 c          following the change of gradient-summation algorithm.
4381 c
4382 cgrad                  ghalfp=0.5D0*gggp(k)
4383 cgrad                  ghalfm=0.5D0*gggm(k)
4384                   gacontp_hb1(k,num_conti,i)=!ghalfp
4385      &              +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i))
4386      &              + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
4387                   gacontp_hb2(k,num_conti,i)=!ghalfp
4388      &              +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j))
4389      &              + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
4390                   gacontp_hb3(k,num_conti,i)=gggp(k)
4391                   gacontm_hb1(k,num_conti,i)=!ghalfm
4392      &              +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i))
4393      &              + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
4394                   gacontm_hb2(k,num_conti,i)=!ghalfm
4395      &              +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j))
4396      &              + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
4397                   gacontm_hb3(k,num_conti,i)=gggm(k)
4398                 enddo
4399 C Diagnostics. Comment out or remove after debugging!
4400 cdiag           do k=1,3
4401 cdiag             gacontp_hb1(k,num_conti,i)=0.0D0
4402 cdiag             gacontp_hb2(k,num_conti,i)=0.0D0
4403 cdiag             gacontp_hb3(k,num_conti,i)=0.0D0
4404 cdiag             gacontm_hb1(k,num_conti,i)=0.0D0
4405 cdiag             gacontm_hb2(k,num_conti,i)=0.0D0
4406 cdiag             gacontm_hb3(k,num_conti,i)=0.0D0
4407 cdiag           enddo
4408               ENDIF ! wcorr
4409               endif  ! num_conti.le.maxconts
4410             endif  ! fcont.gt.0
4411           endif    ! j.gt.i+1
4412           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
4413             do k=1,4
4414               do l=1,3
4415                 ghalf=0.5d0*agg(l,k)
4416                 aggi(l,k)=aggi(l,k)+ghalf
4417                 aggi1(l,k)=aggi1(l,k)+agg(l,k)
4418                 aggj(l,k)=aggj(l,k)+ghalf
4419               enddo
4420             enddo
4421             if (j.eq.nres-1 .and. i.lt.j-2) then
4422               do k=1,4
4423                 do l=1,3
4424                   aggj1(l,k)=aggj1(l,k)+agg(l,k)
4425                 enddo
4426               enddo
4427             endif
4428           endif
4429 c          t_eelecij=t_eelecij+MPI_Wtime()-time00
4430       return
4431       end
4432 C-----------------------------------------------------------------------------
4433       subroutine eturn3(i,eello_turn3)
4434 C Third- and fourth-order contributions from turns
4435       implicit real*8 (a-h,o-z)
4436       include 'DIMENSIONS'
4437       include 'COMMON.IOUNITS'
4438       include 'COMMON.GEO'
4439       include 'COMMON.VAR'
4440       include 'COMMON.LOCAL'
4441       include 'COMMON.CHAIN'
4442       include 'COMMON.DERIV'
4443       include 'COMMON.INTERACT'
4444       include 'COMMON.CONTACTS'
4445       include 'COMMON.TORSION'
4446       include 'COMMON.VECTORS'
4447       include 'COMMON.FFIELD'
4448       include 'COMMON.CONTROL'
4449       dimension ggg(3)
4450       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
4451      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
4452      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2),gpizda1(2,2),
4453      &  gpizda2(2,2),auxgmat1(2,2),auxgmatt1(2,2),
4454      &  auxgmat2(2,2),auxgmatt2(2,2)
4455       double precision agg(3,4),aggi(3,4),aggi1(3,4),
4456      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
4457       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
4458      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
4459      &    num_conti,j1,j2
4460       j=i+2
4461 c      write (iout,*) "eturn3",i,j,j1,j2
4462       a_temp(1,1)=a22
4463       a_temp(1,2)=a23
4464       a_temp(2,1)=a32
4465       a_temp(2,2)=a33
4466 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4467 C
4468 C               Third-order contributions
4469 C
4470 C                 (i+2)o----(i+3)
4471 C                      | |
4472 C                      | |
4473 C                 (i+1)o----i
4474 C
4475 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4476 cd        call checkint_turn3(i,a_temp,eello_turn3_num)
4477         call matmat2(EUg(1,1,i+1),EUg(1,1,i+2),auxmat(1,1))
4478 c auxalary matices for theta gradient
4479 c auxalary matrix for i+1 and constant i+2
4480         call matmat2(gtEUg(1,1,i+1),EUg(1,1,i+2),auxgmat1(1,1))
4481 c auxalary matrix for i+2 and constant i+1
4482         call matmat2(EUg(1,1,i+1),gtEUg(1,1,i+2),auxgmat2(1,1))
4483         call transpose2(auxmat(1,1),auxmat1(1,1))
4484         call transpose2(auxgmat1(1,1),auxgmatt1(1,1))
4485         call transpose2(auxgmat2(1,1),auxgmatt2(1,1))
4486         call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4487         call matmat2(a_temp(1,1),auxgmatt1(1,1),gpizda1(1,1))
4488         call matmat2(a_temp(1,1),auxgmatt2(1,1),gpizda2(1,1))
4489         eello_turn3=eello_turn3+0.5d0*(pizda(1,1)+pizda(2,2))
4490 C Derivatives in theta
4491         gloc(nphi+i,icg)=gloc(nphi+i,icg)
4492      &  +0.5d0*(gpizda1(1,1)+gpizda1(2,2))*wturn3
4493         gloc(nphi+i+1,icg)=gloc(nphi+i+1,icg)
4494      &  +0.5d0*(gpizda2(1,1)+gpizda2(2,2))*wturn3
4495
4496         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
4497      &          'eturn3',i,j,0.5d0*(pizda(1,1)+pizda(2,2))
4498 cd        write (2,*) 'i,',i,' j',j,'eello_turn3',
4499 cd     &    0.5d0*(pizda(1,1)+pizda(2,2)),
4500 cd     &    ' eello_turn3_num',4*eello_turn3_num
4501 C Derivatives in gamma(i)
4502         call matmat2(EUgder(1,1,i+1),EUg(1,1,i+2),auxmat2(1,1))
4503         call transpose2(auxmat2(1,1),auxmat3(1,1))
4504         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
4505         gel_loc_turn3(i)=gel_loc_turn3(i)+0.5d0*(pizda(1,1)+pizda(2,2))
4506 C Derivatives in gamma(i+1)
4507         call matmat2(EUg(1,1,i+1),EUgder(1,1,i+2),auxmat2(1,1))
4508         call transpose2(auxmat2(1,1),auxmat3(1,1))
4509         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
4510         gel_loc_turn3(i+1)=gel_loc_turn3(i+1)
4511      &    +0.5d0*(pizda(1,1)+pizda(2,2))
4512 C Cartesian derivatives
4513         do l=1,3
4514 c            ghalf1=0.5d0*agg(l,1)
4515 c            ghalf2=0.5d0*agg(l,2)
4516 c            ghalf3=0.5d0*agg(l,3)
4517 c            ghalf4=0.5d0*agg(l,4)
4518           a_temp(1,1)=aggi(l,1)!+ghalf1
4519           a_temp(1,2)=aggi(l,2)!+ghalf2
4520           a_temp(2,1)=aggi(l,3)!+ghalf3
4521           a_temp(2,2)=aggi(l,4)!+ghalf4
4522           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4523           gcorr3_turn(l,i)=gcorr3_turn(l,i)
4524      &      +0.5d0*(pizda(1,1)+pizda(2,2))
4525           a_temp(1,1)=aggi1(l,1)!+agg(l,1)
4526           a_temp(1,2)=aggi1(l,2)!+agg(l,2)
4527           a_temp(2,1)=aggi1(l,3)!+agg(l,3)
4528           a_temp(2,2)=aggi1(l,4)!+agg(l,4)
4529           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4530           gcorr3_turn(l,i+1)=gcorr3_turn(l,i+1)
4531      &      +0.5d0*(pizda(1,1)+pizda(2,2))
4532           a_temp(1,1)=aggj(l,1)!+ghalf1
4533           a_temp(1,2)=aggj(l,2)!+ghalf2
4534           a_temp(2,1)=aggj(l,3)!+ghalf3
4535           a_temp(2,2)=aggj(l,4)!+ghalf4
4536           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4537           gcorr3_turn(l,j)=gcorr3_turn(l,j)
4538      &      +0.5d0*(pizda(1,1)+pizda(2,2))
4539           a_temp(1,1)=aggj1(l,1)
4540           a_temp(1,2)=aggj1(l,2)
4541           a_temp(2,1)=aggj1(l,3)
4542           a_temp(2,2)=aggj1(l,4)
4543           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4544           gcorr3_turn(l,j1)=gcorr3_turn(l,j1)
4545      &      +0.5d0*(pizda(1,1)+pizda(2,2))
4546         enddo
4547       return
4548       end
4549 C-------------------------------------------------------------------------------
4550       subroutine eturn4(i,eello_turn4)
4551 C Third- and fourth-order contributions from turns
4552       implicit real*8 (a-h,o-z)
4553       include 'DIMENSIONS'
4554       include 'COMMON.IOUNITS'
4555       include 'COMMON.GEO'
4556       include 'COMMON.VAR'
4557       include 'COMMON.LOCAL'
4558       include 'COMMON.CHAIN'
4559       include 'COMMON.DERIV'
4560       include 'COMMON.INTERACT'
4561       include 'COMMON.CONTACTS'
4562       include 'COMMON.TORSION'
4563       include 'COMMON.VECTORS'
4564       include 'COMMON.FFIELD'
4565       include 'COMMON.CONTROL'
4566       dimension ggg(3)
4567       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
4568      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
4569      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2),auxgvec(2),
4570      &  auxgEvec1(2),auxgEvec2(2),auxgEvec3(2),
4571      &  gte1t(2,2),gte2t(2,2),gte3t(2,2),
4572      &  gte1a(2,2),gtae3(2,2),gtae3e2(2,2), ae3gte2(2,2),
4573      &  gtEpizda1(2,2),gtEpizda2(2,2),gtEpizda3(2,2)
4574       double precision agg(3,4),aggi(3,4),aggi1(3,4),
4575      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
4576       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
4577      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
4578      &    num_conti,j1,j2
4579       j=i+3
4580 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4581 C
4582 C               Fourth-order contributions
4583 C
4584 C                 (i+3)o----(i+4)
4585 C                     /  |
4586 C               (i+2)o   |
4587 C                     \  |
4588 C                 (i+1)o----i
4589 C
4590 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4591 cd        call checkint_turn4(i,a_temp,eello_turn4_num)
4592 c        write (iout,*) "eturn4 i",i," j",j," j1",j1," j2",j2
4593 c        write(iout,*)"WCHODZE W PROGRAM"
4594         a_temp(1,1)=a22
4595         a_temp(1,2)=a23
4596         a_temp(2,1)=a32
4597         a_temp(2,2)=a33
4598         iti1=itortyp(itype(i+1))
4599         iti2=itortyp(itype(i+2))
4600         iti3=itortyp(itype(i+3))
4601 c        write(iout,*) "iti1",iti1," iti2",iti2," iti3",iti3
4602         call transpose2(EUg(1,1,i+1),e1t(1,1))
4603         call transpose2(Eug(1,1,i+2),e2t(1,1))
4604         call transpose2(Eug(1,1,i+3),e3t(1,1))
4605 C Ematrix derivative in theta
4606         call transpose2(gtEUg(1,1,i+1),gte1t(1,1))
4607         call transpose2(gtEug(1,1,i+2),gte2t(1,1))
4608         call transpose2(gtEug(1,1,i+3),gte3t(1,1))
4609         call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4610 c       eta1 in derivative theta
4611         call matmat2(gte1t(1,1),a_temp(1,1),gte1a(1,1))
4612         call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4613 c       auxgvec is derivative of Ub2 so i+3 theta
4614         call matvec2(e1a(1,1),gUb2(1,i+3),auxgvec(1))
4615 c       auxalary matrix of E i+1
4616         call matvec2(gte1a(1,1),Ub2(1,i+3),auxgEvec1(1))
4617 c        s1=0.0
4618 c        gs1=0.0
4619         s1=scalar2(b1(1,i+2),auxvec(1))
4620 c derivative of theta i+2 with constant i+3
4621         gs23=scalar2(gtb1(1,i+2),auxvec(1))
4622 c derivative of theta i+2 with constant i+2
4623         gs32=scalar2(b1(1,i+2),auxgvec(1))
4624 c derivative of E matix in theta of i+1
4625         gsE13=scalar2(b1(1,i+2),auxgEvec1(1))
4626
4627         call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4628 c       ea31 in derivative theta
4629         call matmat2(a_temp(1,1),gte3t(1,1),gtae3(1,1))
4630         call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4631 c auxilary matrix auxgvec of Ub2 with constant E matirx
4632         call matvec2(ae3(1,1),gUb2(1,i+2),auxgvec(1))
4633 c auxilary matrix auxgEvec1 of E matix with Ub2 constant
4634         call matvec2(gtae3(1,1),Ub2(1,i+2),auxgEvec3(1))
4635
4636 c        s2=0.0
4637 c        gs2=0.0
4638         s2=scalar2(b1(1,i+1),auxvec(1))
4639 c derivative of theta i+1 with constant i+3
4640         gs13=scalar2(gtb1(1,i+1),auxvec(1))
4641 c derivative of theta i+2 with constant i+1
4642         gs21=scalar2(b1(1,i+1),auxgvec(1))
4643 c derivative of theta i+3 with constant i+1
4644         gsE31=scalar2(b1(1,i+1),auxgEvec3(1))
4645 c        write(iout,*) gs1,gs2,'i=',i,auxgvec(1),gUb2(1,i+2),gtb1(1,i+2),
4646 c     &  gtb1(1,i+1)
4647         call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4648 c two derivatives over diffetent matrices
4649 c gtae3e2 is derivative over i+3
4650         call matmat2(gtae3(1,1),e2t(1,1),gtae3e2(1,1))
4651 c ae3gte2 is derivative over i+2
4652         call matmat2(ae3(1,1),gte2t(1,1),ae3gte2(1,1))
4653         call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4654 c three possible derivative over theta E matices
4655 c i+1
4656         call matmat2(ae3e2(1,1),gte1t(1,1),gtEpizda1(1,1))
4657 c i+2
4658         call matmat2(ae3gte2(1,1),e1t(1,1),gtEpizda2(1,1))
4659 c i+3
4660         call matmat2(gtae3e2(1,1),e1t(1,1),gtEpizda3(1,1))
4661         s3=0.5d0*(pizda(1,1)+pizda(2,2))
4662
4663         gsEE1=0.5d0*(gtEpizda1(1,1)+gtEpizda1(2,2))
4664         gsEE2=0.5d0*(gtEpizda2(1,1)+gtEpizda2(2,2))
4665         gsEE3=0.5d0*(gtEpizda3(1,1)+gtEpizda3(2,2))
4666
4667         eello_turn4=eello_turn4-(s1+s2+s3)
4668 c             write(iout,*)'chujOWO', auxvec(1),b1(1,iti2)
4669         if (energy_dec) write (iout,'(a6,2i5,0pf7.3,3f7.3)')
4670      &      'eturn4',i,j,-(s1+s2+s3),s1,s2,s3
4671 cd        write (2,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
4672 cd     &    ' eello_turn4_num',8*eello_turn4_num
4673 #ifdef NEWCORR
4674         gloc(nphi+i,icg)=gloc(nphi+i,icg)
4675      &                  -(gs13+gsE13+gsEE1)*wturn4
4676         gloc(nphi+i+1,icg)= gloc(nphi+i+1,icg)
4677      &                    -(gs23+gs21+gsEE2)*wturn4
4678         gloc(nphi+i+2,icg)= gloc(nphi+i+2,icg)
4679      &                    -(gs32+gsE31+gsEE3)*wturn4
4680 c         gloc(nphi+i+1,icg)=gloc(nphi+i+1,icg)-
4681 c     &   gs2
4682 #endif
4683         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
4684      &      'eturn4',i,j,-(s1+s2+s3)
4685 c        write (iout,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
4686 c     &    ' eello_turn4_num',8*eello_turn4_num
4687 C Derivatives in gamma(i)
4688         call transpose2(EUgder(1,1,i+1),e1tder(1,1))
4689         call matmat2(e1tder(1,1),a_temp(1,1),auxmat(1,1))
4690         call matvec2(auxmat(1,1),Ub2(1,i+3),auxvec(1))
4691         s1=scalar2(b1(1,i+2),auxvec(1))
4692         call matmat2(ae3e2(1,1),e1tder(1,1),pizda(1,1))
4693         s3=0.5d0*(pizda(1,1)+pizda(2,2))
4694         gel_loc_turn4(i)=gel_loc_turn4(i)-(s1+s3)
4695 C Derivatives in gamma(i+1)
4696         call transpose2(EUgder(1,1,i+2),e2tder(1,1))
4697         call matvec2(ae3(1,1),Ub2der(1,i+2),auxvec(1))
4698         s2=scalar2(b1(1,i+1),auxvec(1))
4699         call matmat2(ae3(1,1),e2tder(1,1),auxmat(1,1))
4700         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
4701         s3=0.5d0*(pizda(1,1)+pizda(2,2))
4702         gel_loc_turn4(i+1)=gel_loc_turn4(i+1)-(s2+s3)
4703 C Derivatives in gamma(i+2)
4704         call transpose2(EUgder(1,1,i+3),e3tder(1,1))
4705         call matvec2(e1a(1,1),Ub2der(1,i+3),auxvec(1))
4706         s1=scalar2(b1(1,i+2),auxvec(1))
4707         call matmat2(a_temp(1,1),e3tder(1,1),auxmat(1,1))
4708         call matvec2(auxmat(1,1),Ub2(1,i+2),auxvec(1))
4709         s2=scalar2(b1(1,i+1),auxvec(1))
4710         call matmat2(auxmat(1,1),e2t(1,1),auxmat3(1,1))
4711         call matmat2(auxmat3(1,1),e1t(1,1),pizda(1,1))
4712         s3=0.5d0*(pizda(1,1)+pizda(2,2))
4713         gel_loc_turn4(i+2)=gel_loc_turn4(i+2)-(s1+s2+s3)
4714 C Cartesian derivatives
4715 C Derivatives of this turn contributions in DC(i+2)
4716         if (j.lt.nres-1) then
4717           do l=1,3
4718             a_temp(1,1)=agg(l,1)
4719             a_temp(1,2)=agg(l,2)
4720             a_temp(2,1)=agg(l,3)
4721             a_temp(2,2)=agg(l,4)
4722             call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4723             call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4724             s1=scalar2(b1(1,i+2),auxvec(1))
4725             call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4726             call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4727             s2=scalar2(b1(1,i+1),auxvec(1))
4728             call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4729             call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4730             s3=0.5d0*(pizda(1,1)+pizda(2,2))
4731             ggg(l)=-(s1+s2+s3)
4732             gcorr4_turn(l,i+2)=gcorr4_turn(l,i+2)-(s1+s2+s3)
4733           enddo
4734         endif
4735 C Remaining derivatives of this turn contribution
4736         do l=1,3
4737           a_temp(1,1)=aggi(l,1)
4738           a_temp(1,2)=aggi(l,2)
4739           a_temp(2,1)=aggi(l,3)
4740           a_temp(2,2)=aggi(l,4)
4741           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4742           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4743           s1=scalar2(b1(1,i+2),auxvec(1))
4744           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4745           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4746           s2=scalar2(b1(1,i+1),auxvec(1))
4747           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4748           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4749           s3=0.5d0*(pizda(1,1)+pizda(2,2))
4750           gcorr4_turn(l,i)=gcorr4_turn(l,i)-(s1+s2+s3)
4751           a_temp(1,1)=aggi1(l,1)
4752           a_temp(1,2)=aggi1(l,2)
4753           a_temp(2,1)=aggi1(l,3)
4754           a_temp(2,2)=aggi1(l,4)
4755           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4756           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4757           s1=scalar2(b1(1,i+2),auxvec(1))
4758           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4759           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4760           s2=scalar2(b1(1,i+1),auxvec(1))
4761           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4762           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4763           s3=0.5d0*(pizda(1,1)+pizda(2,2))
4764           gcorr4_turn(l,i+1)=gcorr4_turn(l,i+1)-(s1+s2+s3)
4765           a_temp(1,1)=aggj(l,1)
4766           a_temp(1,2)=aggj(l,2)
4767           a_temp(2,1)=aggj(l,3)
4768           a_temp(2,2)=aggj(l,4)
4769           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4770           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4771           s1=scalar2(b1(1,i+2),auxvec(1))
4772           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4773           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4774           s2=scalar2(b1(1,i+1),auxvec(1))
4775           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4776           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4777           s3=0.5d0*(pizda(1,1)+pizda(2,2))
4778           gcorr4_turn(l,j)=gcorr4_turn(l,j)-(s1+s2+s3)
4779           a_temp(1,1)=aggj1(l,1)
4780           a_temp(1,2)=aggj1(l,2)
4781           a_temp(2,1)=aggj1(l,3)
4782           a_temp(2,2)=aggj1(l,4)
4783           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4784           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4785           s1=scalar2(b1(1,i+2),auxvec(1))
4786           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4787           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4788           s2=scalar2(b1(1,i+1),auxvec(1))
4789           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4790           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4791           s3=0.5d0*(pizda(1,1)+pizda(2,2))
4792 c          write (iout,*) "s1",s1," s2",s2," s3",s3," s1+s2+s3",s1+s2+s3
4793           gcorr4_turn(l,j1)=gcorr4_turn(l,j1)-(s1+s2+s3)
4794         enddo
4795       return
4796       end
4797 C-----------------------------------------------------------------------------
4798       subroutine vecpr(u,v,w)
4799       implicit real*8(a-h,o-z)
4800       dimension u(3),v(3),w(3)
4801       w(1)=u(2)*v(3)-u(3)*v(2)
4802       w(2)=-u(1)*v(3)+u(3)*v(1)
4803       w(3)=u(1)*v(2)-u(2)*v(1)
4804       return
4805       end
4806 C-----------------------------------------------------------------------------
4807       subroutine unormderiv(u,ugrad,unorm,ungrad)
4808 C This subroutine computes the derivatives of a normalized vector u, given
4809 C the derivatives computed without normalization conditions, ugrad. Returns
4810 C ungrad.
4811       implicit none
4812       double precision u(3),ugrad(3,3),unorm,ungrad(3,3)
4813       double precision vec(3)
4814       double precision scalar
4815       integer i,j
4816 c      write (2,*) 'ugrad',ugrad
4817 c      write (2,*) 'u',u
4818       do i=1,3
4819         vec(i)=scalar(ugrad(1,i),u(1))
4820       enddo
4821 c      write (2,*) 'vec',vec
4822       do i=1,3
4823         do j=1,3
4824           ungrad(j,i)=(ugrad(j,i)-u(j)*vec(i))*unorm
4825         enddo
4826       enddo
4827 c      write (2,*) 'ungrad',ungrad
4828       return
4829       end
4830 C-----------------------------------------------------------------------------
4831       subroutine escp_soft_sphere(evdw2,evdw2_14)
4832 C
4833 C This subroutine calculates the excluded-volume interaction energy between
4834 C peptide-group centers and side chains and its gradient in virtual-bond and
4835 C side-chain vectors.
4836 C
4837       implicit real*8 (a-h,o-z)
4838       include 'DIMENSIONS'
4839       include 'COMMON.GEO'
4840       include 'COMMON.VAR'
4841       include 'COMMON.LOCAL'
4842       include 'COMMON.CHAIN'
4843       include 'COMMON.DERIV'
4844       include 'COMMON.INTERACT'
4845       include 'COMMON.FFIELD'
4846       include 'COMMON.IOUNITS'
4847       include 'COMMON.CONTROL'
4848       dimension ggg(3)
4849       evdw2=0.0D0
4850       evdw2_14=0.0d0
4851       r0_scp=4.5d0
4852 cd    print '(a)','Enter ESCP'
4853 cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
4854 C      do xshift=-1,1
4855 C      do yshift=-1,1
4856 C      do zshift=-1,1
4857       do i=iatscp_s,iatscp_e
4858         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
4859         iteli=itel(i)
4860         xi=0.5D0*(c(1,i)+c(1,i+1))
4861         yi=0.5D0*(c(2,i)+c(2,i+1))
4862         zi=0.5D0*(c(3,i)+c(3,i+1))
4863 C Return atom into box, boxxsize is size of box in x dimension
4864 c  134   continue
4865 c        if (xi.gt.((xshift+0.5d0)*boxxsize)) xi=xi-boxxsize
4866 c        if (xi.lt.((xshift-0.5d0)*boxxsize)) xi=xi+boxxsize
4867 C Condition for being inside the proper box
4868 c        if ((xi.gt.((xshift+0.5d0)*boxxsize)).or.
4869 c     &       (xi.lt.((xshift-0.5d0)*boxxsize))) then
4870 c        go to 134
4871 c        endif
4872 c  135   continue
4873 c        if (yi.gt.((yshift+0.5d0)*boxysize)) yi=yi-boxysize
4874 c        if (yi.lt.((yshift-0.5d0)*boxysize)) yi=yi+boxysize
4875 C Condition for being inside the proper box
4876 c        if ((yi.gt.((yshift+0.5d0)*boxysize)).or.
4877 c     &       (yi.lt.((yshift-0.5d0)*boxysize))) then
4878 c        go to 135
4879 c c       endif
4880 c  136   continue
4881 c        if (zi.gt.((zshift+0.5d0)*boxzsize)) zi=zi-boxzsize
4882 c        if (zi.lt.((zshift-0.5d0)*boxzsize)) zi=zi+boxzsize
4883 cC Condition for being inside the proper box
4884 c        if ((zi.gt.((zshift+0.5d0)*boxzsize)).or.
4885 c     &       (zi.lt.((zshift-0.5d0)*boxzsize))) then
4886 c        go to 136
4887 c        endif
4888           xi=mod(xi,boxxsize)
4889           if (xi.lt.0) xi=xi+boxxsize
4890           yi=mod(yi,boxysize)
4891           if (yi.lt.0) yi=yi+boxysize
4892           zi=mod(zi,boxzsize)
4893           if (zi.lt.0) zi=zi+boxzsize
4894 C          xi=xi+xshift*boxxsize
4895 C          yi=yi+yshift*boxysize
4896 C          zi=zi+zshift*boxzsize
4897         do iint=1,nscp_gr(i)
4898
4899         do j=iscpstart(i,iint),iscpend(i,iint)
4900           if (itype(j).eq.ntyp1) cycle
4901           itypj=iabs(itype(j))
4902 C Uncomment following three lines for SC-p interactions
4903 c         xj=c(1,nres+j)-xi
4904 c         yj=c(2,nres+j)-yi
4905 c         zj=c(3,nres+j)-zi
4906 C Uncomment following three lines for Ca-p interactions
4907           xj=c(1,j)
4908           yj=c(2,j)
4909           zj=c(3,j)
4910 c  174   continue
4911 c        if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
4912 c        if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
4913 C Condition for being inside the proper box
4914 c        if ((xj.gt.((0.5d0)*boxxsize)).or.
4915 c     &       (xj.lt.((-0.5d0)*boxxsize))) then
4916 c        go to 174
4917 c        endif
4918 c  175   continue
4919 c        if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
4920 c        if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
4921 cC Condition for being inside the proper box
4922 c        if ((yj.gt.((0.5d0)*boxysize)).or.
4923 c     &       (yj.lt.((-0.5d0)*boxysize))) then
4924 c        go to 175
4925 c        endif
4926 c  176   continue
4927 c        if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
4928 c        if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
4929 C Condition for being inside the proper box
4930 c        if ((zj.gt.((0.5d0)*boxzsize)).or.
4931 c     &       (zj.lt.((-0.5d0)*boxzsize))) then
4932 c        go to 176
4933           xj=mod(xj,boxxsize)
4934           if (xj.lt.0) xj=xj+boxxsize
4935           yj=mod(yj,boxysize)
4936           if (yj.lt.0) yj=yj+boxysize
4937           zj=mod(zj,boxzsize)
4938           if (zj.lt.0) zj=zj+boxzsize
4939       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
4940       xj_safe=xj
4941       yj_safe=yj
4942       zj_safe=zj
4943       subchap=0
4944       do xshift=-1,1
4945       do yshift=-1,1
4946       do zshift=-1,1
4947           xj=xj_safe+xshift*boxxsize
4948           yj=yj_safe+yshift*boxysize
4949           zj=zj_safe+zshift*boxzsize
4950           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
4951           if(dist_temp.lt.dist_init) then
4952             dist_init=dist_temp
4953             xj_temp=xj
4954             yj_temp=yj
4955             zj_temp=zj
4956             subchap=1
4957           endif
4958        enddo
4959        enddo
4960        enddo
4961        if (subchap.eq.1) then
4962           xj=xj_temp-xi
4963           yj=yj_temp-yi
4964           zj=zj_temp-zi
4965        else
4966           xj=xj_safe-xi
4967           yj=yj_safe-yi
4968           zj=zj_safe-zi
4969        endif
4970 c c       endif
4971 C          xj=xj-xi
4972 C          yj=yj-yi
4973 C          zj=zj-zi
4974           rij=xj*xj+yj*yj+zj*zj
4975
4976           r0ij=r0_scp
4977           r0ijsq=r0ij*r0ij
4978           if (rij.lt.r0ijsq) then
4979             evdwij=0.25d0*(rij-r0ijsq)**2
4980             fac=rij-r0ijsq
4981           else
4982             evdwij=0.0d0
4983             fac=0.0d0
4984           endif
4985           evdw2=evdw2+evdwij
4986 C
4987 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
4988 C
4989           ggg(1)=xj*fac
4990           ggg(2)=yj*fac
4991           ggg(3)=zj*fac
4992 cgrad          if (j.lt.i) then
4993 cd          write (iout,*) 'j<i'
4994 C Uncomment following three lines for SC-p interactions
4995 c           do k=1,3
4996 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
4997 c           enddo
4998 cgrad          else
4999 cd          write (iout,*) 'j>i'
5000 cgrad            do k=1,3
5001 cgrad              ggg(k)=-ggg(k)
5002 C Uncomment following line for SC-p interactions
5003 c             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
5004 cgrad            enddo
5005 cgrad          endif
5006 cgrad          do k=1,3
5007 cgrad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
5008 cgrad          enddo
5009 cgrad          kstart=min0(i+1,j)
5010 cgrad          kend=max0(i-1,j-1)
5011 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
5012 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
5013 cgrad          do k=kstart,kend
5014 cgrad            do l=1,3
5015 cgrad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
5016 cgrad            enddo
5017 cgrad          enddo
5018           do k=1,3
5019             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
5020             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
5021           enddo
5022         enddo
5023
5024         enddo ! iint
5025       enddo ! i
5026 C      enddo !zshift
5027 C      enddo !yshift
5028 C      enddo !xshift
5029       return
5030       end
5031 C-----------------------------------------------------------------------------
5032       subroutine escp(evdw2,evdw2_14)
5033 C
5034 C This subroutine calculates the excluded-volume interaction energy between
5035 C peptide-group centers and side chains and its gradient in virtual-bond and
5036 C side-chain vectors.
5037 C
5038       implicit real*8 (a-h,o-z)
5039       include 'DIMENSIONS'
5040       include 'COMMON.GEO'
5041       include 'COMMON.VAR'
5042       include 'COMMON.LOCAL'
5043       include 'COMMON.CHAIN'
5044       include 'COMMON.DERIV'
5045       include 'COMMON.INTERACT'
5046       include 'COMMON.FFIELD'
5047       include 'COMMON.IOUNITS'
5048       include 'COMMON.CONTROL'
5049       include 'COMMON.SPLITELE'
5050       dimension ggg(3)
5051       evdw2=0.0D0
5052       evdw2_14=0.0d0
5053 c        print *,boxxsize,boxysize,boxzsize,'wymiary pudla'
5054 cd    print '(a)','Enter ESCP'
5055 cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
5056 C      do xshift=-1,1
5057 C      do yshift=-1,1
5058 C      do zshift=-1,1
5059       do i=iatscp_s,iatscp_e
5060         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
5061         iteli=itel(i)
5062         xi=0.5D0*(c(1,i)+c(1,i+1))
5063         yi=0.5D0*(c(2,i)+c(2,i+1))
5064         zi=0.5D0*(c(3,i)+c(3,i+1))
5065           xi=mod(xi,boxxsize)
5066           if (xi.lt.0) xi=xi+boxxsize
5067           yi=mod(yi,boxysize)
5068           if (yi.lt.0) yi=yi+boxysize
5069           zi=mod(zi,boxzsize)
5070           if (zi.lt.0) zi=zi+boxzsize
5071 c          xi=xi+xshift*boxxsize
5072 c          yi=yi+yshift*boxysize
5073 c          zi=zi+zshift*boxzsize
5074 c        print *,xi,yi,zi,'polozenie i'
5075 C Return atom into box, boxxsize is size of box in x dimension
5076 c  134   continue
5077 c        if (xi.gt.((xshift+0.5d0)*boxxsize)) xi=xi-boxxsize
5078 c        if (xi.lt.((xshift-0.5d0)*boxxsize)) xi=xi+boxxsize
5079 C Condition for being inside the proper box
5080 c        if ((xi.gt.((xshift+0.5d0)*boxxsize)).or.
5081 c     &       (xi.lt.((xshift-0.5d0)*boxxsize))) then
5082 c        go to 134
5083 c        endif
5084 c  135   continue
5085 c          print *,xi,boxxsize,"pierwszy"
5086
5087 c        if (yi.gt.((yshift+0.5d0)*boxysize)) yi=yi-boxysize
5088 c        if (yi.lt.((yshift-0.5d0)*boxysize)) yi=yi+boxysize
5089 C Condition for being inside the proper box
5090 c        if ((yi.gt.((yshift+0.5d0)*boxysize)).or.
5091 c     &       (yi.lt.((yshift-0.5d0)*boxysize))) then
5092 c        go to 135
5093 c        endif
5094 c  136   continue
5095 c        if (zi.gt.((zshift+0.5d0)*boxzsize)) zi=zi-boxzsize
5096 c        if (zi.lt.((zshift-0.5d0)*boxzsize)) zi=zi+boxzsize
5097 C Condition for being inside the proper box
5098 c        if ((zi.gt.((zshift+0.5d0)*boxzsize)).or.
5099 c     &       (zi.lt.((zshift-0.5d0)*boxzsize))) then
5100 c        go to 136
5101 c        endif
5102         do iint=1,nscp_gr(i)
5103
5104         do j=iscpstart(i,iint),iscpend(i,iint)
5105           itypj=iabs(itype(j))
5106           if (itypj.eq.ntyp1) cycle
5107 C Uncomment following three lines for SC-p interactions
5108 c         xj=c(1,nres+j)-xi
5109 c         yj=c(2,nres+j)-yi
5110 c         zj=c(3,nres+j)-zi
5111 C Uncomment following three lines for Ca-p interactions
5112           xj=c(1,j)
5113           yj=c(2,j)
5114           zj=c(3,j)
5115           xj=mod(xj,boxxsize)
5116           if (xj.lt.0) xj=xj+boxxsize
5117           yj=mod(yj,boxysize)
5118           if (yj.lt.0) yj=yj+boxysize
5119           zj=mod(zj,boxzsize)
5120           if (zj.lt.0) zj=zj+boxzsize
5121 c  174   continue
5122 c        if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
5123 c        if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
5124 C Condition for being inside the proper box
5125 c        if ((xj.gt.((0.5d0)*boxxsize)).or.
5126 c     &       (xj.lt.((-0.5d0)*boxxsize))) then
5127 c        go to 174
5128 c        endif
5129 c  175   continue
5130 c        if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
5131 c        if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
5132 cC Condition for being inside the proper box
5133 c        if ((yj.gt.((0.5d0)*boxysize)).or.
5134 c     &       (yj.lt.((-0.5d0)*boxysize))) then
5135 c        go to 175
5136 c        endif
5137 c  176   continue
5138 c        if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
5139 c        if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
5140 C Condition for being inside the proper box
5141 c        if ((zj.gt.((0.5d0)*boxzsize)).or.
5142 c     &       (zj.lt.((-0.5d0)*boxzsize))) then
5143 c        go to 176
5144 c        endif
5145 CHERE IS THE CALCULATION WHICH MIRROR IMAGE IS THE CLOSEST ONE
5146       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
5147       xj_safe=xj
5148       yj_safe=yj
5149       zj_safe=zj
5150       subchap=0
5151       do xshift=-1,1
5152       do yshift=-1,1
5153       do zshift=-1,1
5154           xj=xj_safe+xshift*boxxsize
5155           yj=yj_safe+yshift*boxysize
5156           zj=zj_safe+zshift*boxzsize
5157           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
5158           if(dist_temp.lt.dist_init) then
5159             dist_init=dist_temp
5160             xj_temp=xj
5161             yj_temp=yj
5162             zj_temp=zj
5163             subchap=1
5164           endif
5165        enddo
5166        enddo
5167        enddo
5168        if (subchap.eq.1) then
5169           xj=xj_temp-xi
5170           yj=yj_temp-yi
5171           zj=zj_temp-zi
5172        else
5173           xj=xj_safe-xi
5174           yj=yj_safe-yi
5175           zj=zj_safe-zi
5176        endif
5177 c          print *,xj,yj,zj,'polozenie j'
5178           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
5179 c          print *,rrij
5180           sss=sscale(1.0d0/(dsqrt(rrij)))
5181 c          print *,r_cut,1.0d0/dsqrt(rrij),sss,'tu patrz'
5182 c          if (sss.eq.0) print *,'czasem jest OK'
5183           if (sss.le.0.0d0) cycle
5184           sssgrad=sscagrad(1.0d0/(dsqrt(rrij)))
5185           fac=rrij**expon2
5186           e1=fac*fac*aad(itypj,iteli)
5187           e2=fac*bad(itypj,iteli)
5188           if (iabs(j-i) .le. 2) then
5189             e1=scal14*e1
5190             e2=scal14*e2
5191             evdw2_14=evdw2_14+(e1+e2)*sss
5192           endif
5193           evdwij=e1+e2
5194           evdw2=evdw2+evdwij*sss
5195           if (energy_dec) write (iout,'(a6,2i5,0pf7.3,2i3,3e11.3)')
5196      &        'evdw2',i,j,evdwij,iteli,itypj,fac,aad(itypj,iteli),
5197      &       bad(itypj,iteli)
5198 C
5199 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
5200 C
5201           fac=-(evdwij+e1)*rrij*sss
5202           fac=fac+(evdwij)*sssgrad*dsqrt(rrij)/expon
5203           ggg(1)=xj*fac
5204           ggg(2)=yj*fac
5205           ggg(3)=zj*fac
5206 cgrad          if (j.lt.i) then
5207 cd          write (iout,*) 'j<i'
5208 C Uncomment following three lines for SC-p interactions
5209 c           do k=1,3
5210 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
5211 c           enddo
5212 cgrad          else
5213 cd          write (iout,*) 'j>i'
5214 cgrad            do k=1,3
5215 cgrad              ggg(k)=-ggg(k)
5216 C Uncomment following line for SC-p interactions
5217 ccgrad             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
5218 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
5219 cgrad            enddo
5220 cgrad          endif
5221 cgrad          do k=1,3
5222 cgrad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
5223 cgrad          enddo
5224 cgrad          kstart=min0(i+1,j)
5225 cgrad          kend=max0(i-1,j-1)
5226 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
5227 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
5228 cgrad          do k=kstart,kend
5229 cgrad            do l=1,3
5230 cgrad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
5231 cgrad            enddo
5232 cgrad          enddo
5233           do k=1,3
5234             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
5235             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
5236           enddo
5237 c        endif !endif for sscale cutoff
5238         enddo ! j
5239
5240         enddo ! iint
5241       enddo ! i
5242 c      enddo !zshift
5243 c      enddo !yshift
5244 c      enddo !xshift
5245       do i=1,nct
5246         do j=1,3
5247           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
5248           gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
5249           gradx_scp(j,i)=expon*gradx_scp(j,i)
5250         enddo
5251       enddo
5252 C******************************************************************************
5253 C
5254 C                              N O T E !!!
5255 C
5256 C To save time the factor EXPON has been extracted from ALL components
5257 C of GVDWC and GRADX. Remember to multiply them by this factor before further
5258 C use!
5259 C
5260 C******************************************************************************
5261       return
5262       end
5263 C--------------------------------------------------------------------------
5264       subroutine edis(ehpb)
5265 C
5266 C Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors.
5267 C
5268       implicit real*8 (a-h,o-z)
5269       include 'DIMENSIONS'
5270       include 'COMMON.SBRIDGE'
5271       include 'COMMON.CHAIN'
5272       include 'COMMON.DERIV'
5273       include 'COMMON.VAR'
5274       include 'COMMON.INTERACT'
5275       include 'COMMON.IOUNITS'
5276       include 'COMMON.CONTROL'
5277       dimension ggg(3)
5278       ehpb=0.0D0
5279       do i=1,3
5280        ggg(i)=0.0d0
5281       enddo
5282 C      write (iout,*) ,"link_end",link_end,constr_dist
5283 cd      write(iout,*)'edis: nhpb=',nhpb,' fbr=',fbr
5284 cd      write(iout,*)'link_start=',link_start,' link_end=',link_end
5285       if (link_end.eq.0) return
5286       do i=link_start,link_end
5287 C If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a
5288 C CA-CA distance used in regularization of structure.
5289         ii=ihpb(i)
5290         jj=jhpb(i)
5291 C iii and jjj point to the residues for which the distance is assigned.
5292         if (ii.gt.nres) then
5293           iii=ii-nres
5294           jjj=jj-nres
5295         else
5296           iii=ii
5297           jjj=jj
5298         endif
5299 c        write (iout,*) "i",i," ii",ii," iii",iii," jj",jj," jjj",jjj,
5300 c     &    dhpb(i),dhpb1(i),forcon(i)
5301 C 24/11/03 AL: SS bridges handled separately because of introducing a specific
5302 C    distance and angle dependent SS bond potential.
5303 C        if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and.
5304 C     & iabs(itype(jjj)).eq.1) then
5305 cmc        if (ii.gt.nres .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then
5306 C 18/07/06 MC: Use the convention that the first nss pairs are SS bonds
5307         if (.not.dyn_ss .and. i.le.nss) then
5308 C 15/02/13 CC dynamic SSbond - additional check
5309          if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and.
5310      & iabs(itype(jjj)).eq.1) then
5311           call ssbond_ene(iii,jjj,eij)
5312           ehpb=ehpb+2*eij
5313          endif
5314 cd          write (iout,*) "eij",eij
5315 cd   &   ' waga=',waga,' fac=',fac
5316         else if (ii.gt.nres .and. jj.gt.nres) then
5317 c Restraints from contact prediction
5318           dd=dist(ii,jj)
5319           if (constr_dist.eq.11) then
5320             ehpb=ehpb+fordepth(i)**4.0d0
5321      &          *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i))
5322             fac=fordepth(i)**4.0d0
5323      &          *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd
5324           if (energy_dec) write (iout,'(a6,2i5,3f8.3)') "edisl",ii,jj,
5325      &    ehpb,fordepth(i),dd
5326            else
5327           if (dhpb1(i).gt.0.0d0) then
5328             ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
5329             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
5330 c            write (iout,*) "beta nmr",
5331 c     &        dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
5332           else
5333             dd=dist(ii,jj)
5334             rdis=dd-dhpb(i)
5335 C Get the force constant corresponding to this distance.
5336             waga=forcon(i)
5337 C Calculate the contribution to energy.
5338             ehpb=ehpb+waga*rdis*rdis
5339 c            write (iout,*) "beta reg",dd,waga*rdis*rdis
5340 C
5341 C Evaluate gradient.
5342 C
5343             fac=waga*rdis/dd
5344           endif
5345           endif
5346           do j=1,3
5347             ggg(j)=fac*(c(j,jj)-c(j,ii))
5348           enddo
5349           do j=1,3
5350             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
5351             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
5352           enddo
5353           do k=1,3
5354             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
5355             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
5356           enddo
5357         else
5358 C Calculate the distance between the two points and its difference from the
5359 C target distance.
5360           dd=dist(ii,jj)
5361           if (constr_dist.eq.11) then
5362             ehpb=ehpb+fordepth(i)**4.0d0
5363      &           *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i))
5364             fac=fordepth(i)**4.0d0
5365      &           *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd
5366           if (energy_dec) write (iout,'(a6,2i5,3f8.3)') "edisl",ii,jj,
5367      &    ehpb,fordepth(i),dd
5368            else
5369           if (dhpb1(i).gt.0.0d0) then
5370             ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
5371             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
5372 c            write (iout,*) "alph nmr",
5373 c     &        dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
5374           else
5375             rdis=dd-dhpb(i)
5376 C Get the force constant corresponding to this distance.
5377             waga=forcon(i)
5378 C Calculate the contribution to energy.
5379             ehpb=ehpb+waga*rdis*rdis
5380 c            write (iout,*) "alpha reg",dd,waga*rdis*rdis
5381 C
5382 C Evaluate gradient.
5383 C
5384             fac=waga*rdis/dd
5385           endif
5386           endif
5387             do j=1,3
5388               ggg(j)=fac*(c(j,jj)-c(j,ii))
5389             enddo
5390 cd      print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
5391 C If this is a SC-SC distance, we need to calculate the contributions to the
5392 C Cartesian gradient in the SC vectors (ghpbx).
5393           if (iii.lt.ii) then
5394           do j=1,3
5395             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
5396             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
5397           enddo
5398           endif
5399 cgrad        do j=iii,jjj-1
5400 cgrad          do k=1,3
5401 cgrad            ghpbc(k,j)=ghpbc(k,j)+ggg(k)
5402 cgrad          enddo
5403 cgrad        enddo
5404           do k=1,3
5405             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
5406             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
5407           enddo
5408         endif
5409       enddo
5410       if (constr_dist.ne.11) ehpb=0.5D0*ehpb
5411       return
5412       end
5413 C--------------------------------------------------------------------------
5414       subroutine ssbond_ene(i,j,eij)
5415 C
5416 C Calculate the distance and angle dependent SS-bond potential energy
5417 C using a free-energy function derived based on RHF/6-31G** ab initio
5418 C calculations of diethyl disulfide.
5419 C
5420 C A. Liwo and U. Kozlowska, 11/24/03
5421 C
5422       implicit real*8 (a-h,o-z)
5423       include 'DIMENSIONS'
5424       include 'COMMON.SBRIDGE'
5425       include 'COMMON.CHAIN'
5426       include 'COMMON.DERIV'
5427       include 'COMMON.LOCAL'
5428       include 'COMMON.INTERACT'
5429       include 'COMMON.VAR'
5430       include 'COMMON.IOUNITS'
5431       double precision erij(3),dcosom1(3),dcosom2(3),gg(3)
5432       itypi=iabs(itype(i))
5433       xi=c(1,nres+i)
5434       yi=c(2,nres+i)
5435       zi=c(3,nres+i)
5436       dxi=dc_norm(1,nres+i)
5437       dyi=dc_norm(2,nres+i)
5438       dzi=dc_norm(3,nres+i)
5439 c      dsci_inv=dsc_inv(itypi)
5440       dsci_inv=vbld_inv(nres+i)
5441       itypj=iabs(itype(j))
5442 c      dscj_inv=dsc_inv(itypj)
5443       dscj_inv=vbld_inv(nres+j)
5444       xj=c(1,nres+j)-xi
5445       yj=c(2,nres+j)-yi
5446       zj=c(3,nres+j)-zi
5447       dxj=dc_norm(1,nres+j)
5448       dyj=dc_norm(2,nres+j)
5449       dzj=dc_norm(3,nres+j)
5450       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
5451       rij=dsqrt(rrij)
5452       erij(1)=xj*rij
5453       erij(2)=yj*rij
5454       erij(3)=zj*rij
5455       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
5456       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
5457       om12=dxi*dxj+dyi*dyj+dzi*dzj
5458       do k=1,3
5459         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
5460         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
5461       enddo
5462       rij=1.0d0/rij
5463       deltad=rij-d0cm
5464       deltat1=1.0d0-om1
5465       deltat2=1.0d0+om2
5466       deltat12=om2-om1+2.0d0
5467       cosphi=om12-om1*om2
5468       eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2)
5469      &  +akct*deltad*deltat12
5470      &  +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi+ebr
5471 c      write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth,
5472 c     &  " akct",akct," deltad",deltad," deltat",deltat1,deltat2,
5473 c     &  " deltat12",deltat12," eij",eij
5474       ed=2*akcm*deltad+akct*deltat12
5475       pom1=akct*deltad
5476       pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
5477       eom1=-2*akth*deltat1-pom1-om2*pom2
5478       eom2= 2*akth*deltat2+pom1-om1*pom2
5479       eom12=pom2
5480       do k=1,3
5481         ggk=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
5482         ghpbx(k,i)=ghpbx(k,i)-ggk
5483      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
5484      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
5485         ghpbx(k,j)=ghpbx(k,j)+ggk
5486      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
5487      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
5488         ghpbc(k,i)=ghpbc(k,i)-ggk
5489         ghpbc(k,j)=ghpbc(k,j)+ggk
5490       enddo
5491 C
5492 C Calculate the components of the gradient in DC and X
5493 C
5494 cgrad      do k=i,j-1
5495 cgrad        do l=1,3
5496 cgrad          ghpbc(l,k)=ghpbc(l,k)+gg(l)
5497 cgrad        enddo
5498 cgrad      enddo
5499       return
5500       end
5501 C--------------------------------------------------------------------------
5502       subroutine ebond(estr)
5503 c
5504 c Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
5505 c
5506       implicit real*8 (a-h,o-z)
5507       include 'DIMENSIONS'
5508       include 'COMMON.LOCAL'
5509       include 'COMMON.GEO'
5510       include 'COMMON.INTERACT'
5511       include 'COMMON.DERIV'
5512       include 'COMMON.VAR'
5513       include 'COMMON.CHAIN'
5514       include 'COMMON.IOUNITS'
5515       include 'COMMON.NAMES'
5516       include 'COMMON.FFIELD'
5517       include 'COMMON.CONTROL'
5518       include 'COMMON.SETUP'
5519       double precision u(3),ud(3)
5520       estr=0.0d0
5521       estr1=0.0d0
5522       do i=ibondp_start,ibondp_end
5523         if (itype(i-1).eq.ntyp1 .and. itype(i).eq.ntyp1) cycle
5524 c          estr1=estr1+gnmr1(vbld(i),-1.0d0,distchainmax)
5525 c          do j=1,3
5526 c          gradb(j,i-1)=gnmr1prim(vbld(i),-1.0d0,distchainmax)
5527 c     &      *dc(j,i-1)/vbld(i)
5528 c          enddo
5529 c          if (energy_dec) write(iout,*)
5530 c     &       "estr1",i,gnmr1(vbld(i),-1.0d0,distchainmax)
5531 c        else
5532 C       Checking if it involves dummy (NH3+ or COO-) group
5533          if (itype(i-1).eq.ntyp1 .or. itype(i).eq.ntyp1) then
5534 C YES   vbldpDUM is the equlibrium length of spring for Dummy atom
5535         diff = vbld(i)-vbldpDUM
5536          else
5537 C NO    vbldp0 is the equlibrium lenght of spring for peptide group
5538         diff = vbld(i)-vbldp0
5539          endif
5540         if (energy_dec)    write (iout,'(a7,i5,4f7.3)')
5541      &     "estr bb",i,vbld(i),vbldp0,diff,AKP*diff*diff
5542         estr=estr+diff*diff
5543         do j=1,3
5544           gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)
5545         enddo
5546 c        write (iout,'(i5,3f10.5)') i,(gradb(j,i-1),j=1,3)
5547 c        endif
5548       enddo
5549       estr=0.5d0*AKP*estr+estr1
5550 c
5551 c 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included
5552 c
5553       do i=ibond_start,ibond_end
5554         iti=iabs(itype(i))
5555         if (iti.ne.10 .and. iti.ne.ntyp1) then
5556           nbi=nbondterm(iti)
5557           if (nbi.eq.1) then
5558             diff=vbld(i+nres)-vbldsc0(1,iti)
5559             if (energy_dec)  write (iout,*)
5560      &      "estr sc",i,iti,vbld(i+nres),vbldsc0(1,iti),diff,
5561      &      AKSC(1,iti),AKSC(1,iti)*diff*diff
5562             estr=estr+0.5d0*AKSC(1,iti)*diff*diff
5563             do j=1,3
5564               gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
5565             enddo
5566           else
5567             do j=1,nbi
5568               diff=vbld(i+nres)-vbldsc0(j,iti)
5569               ud(j)=aksc(j,iti)*diff
5570               u(j)=abond0(j,iti)+0.5d0*ud(j)*diff
5571             enddo
5572             uprod=u(1)
5573             do j=2,nbi
5574               uprod=uprod*u(j)
5575             enddo
5576             usum=0.0d0
5577             usumsqder=0.0d0
5578             do j=1,nbi
5579               uprod1=1.0d0
5580               uprod2=1.0d0
5581               do k=1,nbi
5582                 if (k.ne.j) then
5583                   uprod1=uprod1*u(k)
5584                   uprod2=uprod2*u(k)*u(k)
5585                 endif
5586               enddo
5587               usum=usum+uprod1
5588               usumsqder=usumsqder+ud(j)*uprod2
5589             enddo
5590             estr=estr+uprod/usum
5591             do j=1,3
5592              gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
5593             enddo
5594           endif
5595         endif
5596       enddo
5597       return
5598       end
5599 #ifdef CRYST_THETA
5600 C--------------------------------------------------------------------------
5601       subroutine ebend(etheta,ethetacnstr)
5602 C
5603 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
5604 C angles gamma and its derivatives in consecutive thetas and gammas.
5605 C
5606       implicit real*8 (a-h,o-z)
5607       include 'DIMENSIONS'
5608       include 'COMMON.LOCAL'
5609       include 'COMMON.GEO'
5610       include 'COMMON.INTERACT'
5611       include 'COMMON.DERIV'
5612       include 'COMMON.VAR'
5613       include 'COMMON.CHAIN'
5614       include 'COMMON.IOUNITS'
5615       include 'COMMON.NAMES'
5616       include 'COMMON.FFIELD'
5617       include 'COMMON.CONTROL'
5618       include 'COMMON.TORCNSTR'
5619       common /calcthet/ term1,term2,termm,diffak,ratak,
5620      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
5621      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
5622       double precision y(2),z(2)
5623       delta=0.02d0*pi
5624 c      time11=dexp(-2*time)
5625 c      time12=1.0d0
5626       etheta=0.0D0
5627 c     write (*,'(a,i2)') 'EBEND ICG=',icg
5628       do i=ithet_start,ithet_end
5629         if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
5630      &  .or.itype(i).eq.ntyp1) cycle
5631 C Zero the energy function and its derivative at 0 or pi.
5632         call splinthet(theta(i),0.5d0*delta,ss,ssd)
5633         it=itype(i-1)
5634         ichir1=isign(1,itype(i-2))
5635         ichir2=isign(1,itype(i))
5636          if (itype(i-2).eq.10) ichir1=isign(1,itype(i-1))
5637          if (itype(i).eq.10) ichir2=isign(1,itype(i-1))
5638          if (itype(i-1).eq.10) then
5639           itype1=isign(10,itype(i-2))
5640           ichir11=isign(1,itype(i-2))
5641           ichir12=isign(1,itype(i-2))
5642           itype2=isign(10,itype(i))
5643           ichir21=isign(1,itype(i))
5644           ichir22=isign(1,itype(i))
5645          endif
5646
5647         if (i.gt.3 .and. itype(i-3).ne.ntyp1) then
5648 #ifdef OSF
5649           phii=phi(i)
5650           if (phii.ne.phii) phii=150.0
5651 #else
5652           phii=phi(i)
5653 #endif
5654           y(1)=dcos(phii)
5655           y(2)=dsin(phii)
5656         else
5657           y(1)=0.0D0
5658           y(2)=0.0D0
5659         endif
5660         if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
5661 #ifdef OSF
5662           phii1=phi(i+1)
5663           if (phii1.ne.phii1) phii1=150.0
5664           phii1=pinorm(phii1)
5665           z(1)=cos(phii1)
5666 #else
5667           phii1=phi(i+1)
5668 #endif
5669           z(1)=dcos(phii1)
5670           z(2)=dsin(phii1)
5671         else
5672           z(1)=0.0D0
5673           z(2)=0.0D0
5674         endif
5675 C Calculate the "mean" value of theta from the part of the distribution
5676 C dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2).
5677 C In following comments this theta will be referred to as t_c.
5678         thet_pred_mean=0.0d0
5679         do k=1,2
5680             athetk=athet(k,it,ichir1,ichir2)
5681             bthetk=bthet(k,it,ichir1,ichir2)
5682           if (it.eq.10) then
5683              athetk=athet(k,itype1,ichir11,ichir12)
5684              bthetk=bthet(k,itype2,ichir21,ichir22)
5685           endif
5686          thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k)
5687 c         write(iout,*) 'chuj tu', y(k),z(k)
5688         enddo
5689         dthett=thet_pred_mean*ssd
5690         thet_pred_mean=thet_pred_mean*ss+a0thet(it)
5691 C Derivatives of the "mean" values in gamma1 and gamma2.
5692         dthetg1=(-athet(1,it,ichir1,ichir2)*y(2)
5693      &+athet(2,it,ichir1,ichir2)*y(1))*ss
5694          dthetg2=(-bthet(1,it,ichir1,ichir2)*z(2)
5695      &          +bthet(2,it,ichir1,ichir2)*z(1))*ss
5696          if (it.eq.10) then
5697       dthetg1=(-athet(1,itype1,ichir11,ichir12)*y(2)
5698      &+athet(2,itype1,ichir11,ichir12)*y(1))*ss
5699         dthetg2=(-bthet(1,itype2,ichir21,ichir22)*z(2)
5700      &         +bthet(2,itype2,ichir21,ichir22)*z(1))*ss
5701          endif
5702         if (theta(i).gt.pi-delta) then
5703           call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,
5704      &         E_tc0)
5705           call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0)
5706           call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
5707           call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,
5708      &        E_theta)
5709           call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,
5710      &        E_tc)
5711         else if (theta(i).lt.delta) then
5712           call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0)
5713           call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
5714           call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,
5715      &        E_theta)
5716           call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0)
5717           call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,
5718      &        E_tc)
5719         else
5720           call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,
5721      &        E_theta,E_tc)
5722         endif
5723         etheta=etheta+ethetai
5724         if (energy_dec) write (iout,'(a6,i5,0pf7.3,f7.3,i5)')
5725      &      'ebend',i,ethetai,theta(i),itype(i)
5726         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1
5727         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2
5728         gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)+gloc(nphi+i-2,icg)
5729       enddo
5730       ethetacnstr=0.0d0
5731 C      print *,ithetaconstr_start,ithetaconstr_end,"TU"
5732       do i=ithetaconstr_start,ithetaconstr_end
5733         itheta=itheta_constr(i)
5734         thetiii=theta(itheta)
5735         difi=pinorm(thetiii-theta_constr0(i))
5736         if (difi.gt.theta_drange(i)) then
5737           difi=difi-theta_drange(i)
5738           ethetacnstr=ethetcnstr+0.25d0*for_thet_constr(i)*difi**4
5739           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
5740      &    +for_thet_constr(i)*difi**3
5741         else if (difi.lt.-drange(i)) then
5742           difi=difi+drange(i)
5743           ethetacnstr=ethetcnstr+0.25d0*for_thet_constr(i)*difi**4
5744           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
5745      &    +for_thet_constr(i)*difi**3
5746         else
5747           difi=0.0
5748         endif
5749        if (energy_dec) then
5750         write (iout,'(a6,2i5,4f8.3,2e14.5)') "ethetc",
5751      &    i,itheta,rad2deg*thetiii,
5752      &    rad2deg*theta_constr0(i),  rad2deg*theta_drange(i),
5753      &    rad2deg*difi,0.25d0*for_thet_constr(i)*difi**4,
5754      &    gloc(itheta+nphi-2,icg)
5755         endif
5756       enddo
5757
5758 C Ufff.... We've done all this!!!
5759       return
5760       end
5761 C---------------------------------------------------------------------------
5762       subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,
5763      &     E_tc)
5764       implicit real*8 (a-h,o-z)
5765       include 'DIMENSIONS'
5766       include 'COMMON.LOCAL'
5767       include 'COMMON.IOUNITS'
5768       common /calcthet/ term1,term2,termm,diffak,ratak,
5769      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
5770      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
5771 C Calculate the contributions to both Gaussian lobes.
5772 C 6/6/97 - Deform the Gaussians using the factor of 1/(1+time)
5773 C The "polynomial part" of the "standard deviation" of this part of
5774 C the distributioni.
5775 ccc        write (iout,*) thetai,thet_pred_mean
5776         sig=polthet(3,it)
5777         do j=2,0,-1
5778           sig=sig*thet_pred_mean+polthet(j,it)
5779         enddo
5780 C Derivative of the "interior part" of the "standard deviation of the"
5781 C gamma-dependent Gaussian lobe in t_c.
5782         sigtc=3*polthet(3,it)
5783         do j=2,1,-1
5784           sigtc=sigtc*thet_pred_mean+j*polthet(j,it)
5785         enddo
5786         sigtc=sig*sigtc
5787 C Set the parameters of both Gaussian lobes of the distribution.
5788 C "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc)
5789         fac=sig*sig+sigc0(it)
5790         sigcsq=fac+fac
5791         sigc=1.0D0/sigcsq
5792 C Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c
5793         sigsqtc=-4.0D0*sigcsq*sigtc
5794 c       print *,i,sig,sigtc,sigsqtc
5795 C Following variable (sigtc) is d[sigma(t_c)]/dt_c
5796         sigtc=-sigtc/(fac*fac)
5797 C Following variable is sigma(t_c)**(-2)
5798         sigcsq=sigcsq*sigcsq
5799         sig0i=sig0(it)
5800         sig0inv=1.0D0/sig0i**2
5801         delthec=thetai-thet_pred_mean
5802         delthe0=thetai-theta0i
5803         term1=-0.5D0*sigcsq*delthec*delthec
5804         term2=-0.5D0*sig0inv*delthe0*delthe0
5805 C        write (iout,*)'term1',term1,term2,sigcsq,delthec,sig0inv,delthe0
5806 C Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and
5807 C NaNs in taking the logarithm. We extract the largest exponent which is added
5808 C to the energy (this being the log of the distribution) at the end of energy
5809 C term evaluation for this virtual-bond angle.
5810         if (term1.gt.term2) then
5811           termm=term1
5812           term2=dexp(term2-termm)
5813           term1=1.0d0
5814         else
5815           termm=term2
5816           term1=dexp(term1-termm)
5817           term2=1.0d0
5818         endif
5819 C The ratio between the gamma-independent and gamma-dependent lobes of
5820 C the distribution is a Gaussian function of thet_pred_mean too.
5821         diffak=gthet(2,it)-thet_pred_mean
5822         ratak=diffak/gthet(3,it)**2
5823         ak=dexp(gthet(1,it)-0.5D0*diffak*ratak)
5824 C Let's differentiate it in thet_pred_mean NOW.
5825         aktc=ak*ratak
5826 C Now put together the distribution terms to make complete distribution.
5827         termexp=term1+ak*term2
5828         termpre=sigc+ak*sig0i
5829 C Contribution of the bending energy from this theta is just the -log of
5830 C the sum of the contributions from the two lobes and the pre-exponential
5831 C factor. Simple enough, isn't it?
5832         ethetai=(-dlog(termexp)-termm+dlog(termpre))
5833 C       write (iout,*) 'termexp',termexp,termm,termpre,i
5834 C NOW the derivatives!!!
5835 C 6/6/97 Take into account the deformation.
5836         E_theta=(delthec*sigcsq*term1
5837      &       +ak*delthe0*sig0inv*term2)/termexp
5838         E_tc=((sigtc+aktc*sig0i)/termpre
5839      &      -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+
5840      &       aktc*term2)/termexp)
5841       return
5842       end
5843 c-----------------------------------------------------------------------------
5844       subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)
5845       implicit real*8 (a-h,o-z)
5846       include 'DIMENSIONS'
5847       include 'COMMON.LOCAL'
5848       include 'COMMON.IOUNITS'
5849       common /calcthet/ term1,term2,termm,diffak,ratak,
5850      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
5851      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
5852       delthec=thetai-thet_pred_mean
5853       delthe0=thetai-theta0i
5854 C "Thank you" to MAPLE (probably spared one day of hand-differentiation).
5855       t3 = thetai-thet_pred_mean
5856       t6 = t3**2
5857       t9 = term1
5858       t12 = t3*sigcsq
5859       t14 = t12+t6*sigsqtc
5860       t16 = 1.0d0
5861       t21 = thetai-theta0i
5862       t23 = t21**2
5863       t26 = term2
5864       t27 = t21*t26
5865       t32 = termexp
5866       t40 = t32**2
5867       E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9
5868      & -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40
5869      & *(-t12*t9-ak*sig0inv*t27)
5870       return
5871       end
5872 #else
5873 C--------------------------------------------------------------------------
5874       subroutine ebend(etheta,ethetacnstr)
5875 C
5876 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
5877 C angles gamma and its derivatives in consecutive thetas and gammas.
5878 C ab initio-derived potentials from
5879 c Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203
5880 C
5881       implicit real*8 (a-h,o-z)
5882       include 'DIMENSIONS'
5883       include 'COMMON.LOCAL'
5884       include 'COMMON.GEO'
5885       include 'COMMON.INTERACT'
5886       include 'COMMON.DERIV'
5887       include 'COMMON.VAR'
5888       include 'COMMON.CHAIN'
5889       include 'COMMON.IOUNITS'
5890       include 'COMMON.NAMES'
5891       include 'COMMON.FFIELD'
5892       include 'COMMON.CONTROL'
5893       include 'COMMON.TORCNSTR'
5894       double precision coskt(mmaxtheterm),sinkt(mmaxtheterm),
5895      & cosph1(maxsingle),sinph1(maxsingle),cosph2(maxsingle),
5896      & sinph2(maxsingle),cosph1ph2(maxdouble,maxdouble),
5897      & sinph1ph2(maxdouble,maxdouble)
5898       logical lprn /.false./, lprn1 /.false./
5899       etheta=0.0D0
5900       do i=ithet_start,ithet_end
5901 c        print *,i,itype(i-1),itype(i),itype(i-2)
5902         if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
5903      &  .or.itype(i).eq.ntyp1) cycle
5904 C        print *,i,theta(i)
5905         if (iabs(itype(i+1)).eq.20) iblock=2
5906         if (iabs(itype(i+1)).ne.20) iblock=1
5907         dethetai=0.0d0
5908         dephii=0.0d0
5909         dephii1=0.0d0
5910         theti2=0.5d0*theta(i)
5911         ityp2=ithetyp((itype(i-1)))
5912         do k=1,nntheterm
5913           coskt(k)=dcos(k*theti2)
5914           sinkt(k)=dsin(k*theti2)
5915         enddo
5916 C        print *,ethetai
5917         if (i.gt.3 .and. itype(i-3).ne.ntyp1) then
5918 #ifdef OSF
5919           phii=phi(i)
5920           if (phii.ne.phii) phii=150.0
5921 #else
5922           phii=phi(i)
5923 #endif
5924           ityp1=ithetyp((itype(i-2)))
5925 C propagation of chirality for glycine type
5926           do k=1,nsingle
5927             cosph1(k)=dcos(k*phii)
5928             sinph1(k)=dsin(k*phii)
5929           enddo
5930         else
5931           phii=0.0d0
5932           do k=1,nsingle
5933           ityp1=ithetyp((itype(i-2)))
5934             cosph1(k)=0.0d0
5935             sinph1(k)=0.0d0
5936           enddo
5937         endif
5938         if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
5939 #ifdef OSF
5940           phii1=phi(i+1)
5941           if (phii1.ne.phii1) phii1=150.0
5942           phii1=pinorm(phii1)
5943 #else
5944           phii1=phi(i+1)
5945 #endif
5946           ityp3=ithetyp((itype(i)))
5947           do k=1,nsingle
5948             cosph2(k)=dcos(k*phii1)
5949             sinph2(k)=dsin(k*phii1)
5950           enddo
5951         else
5952           phii1=0.0d0
5953           ityp3=ithetyp((itype(i)))
5954           do k=1,nsingle
5955             cosph2(k)=0.0d0
5956             sinph2(k)=0.0d0
5957           enddo
5958         endif
5959         ethetai=aa0thet(ityp1,ityp2,ityp3,iblock)
5960         do k=1,ndouble
5961           do l=1,k-1
5962             ccl=cosph1(l)*cosph2(k-l)
5963             ssl=sinph1(l)*sinph2(k-l)
5964             scl=sinph1(l)*cosph2(k-l)
5965             csl=cosph1(l)*sinph2(k-l)
5966             cosph1ph2(l,k)=ccl-ssl
5967             cosph1ph2(k,l)=ccl+ssl
5968             sinph1ph2(l,k)=scl+csl
5969             sinph1ph2(k,l)=scl-csl
5970           enddo
5971         enddo
5972         if (lprn) then
5973         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,
5974      &    " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
5975         write (iout,*) "coskt and sinkt"
5976         do k=1,nntheterm
5977           write (iout,*) k,coskt(k),sinkt(k)
5978         enddo
5979         endif
5980         do k=1,ntheterm
5981           ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3,iblock)*sinkt(k)
5982           dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3,iblock)
5983      &      *coskt(k)
5984           if (lprn)
5985      &    write (iout,*) "k",k,"
5986      &     aathet",aathet(k,ityp1,ityp2,ityp3,iblock),
5987      &     " ethetai",ethetai
5988         enddo
5989         if (lprn) then
5990         write (iout,*) "cosph and sinph"
5991         do k=1,nsingle
5992           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
5993         enddo
5994         write (iout,*) "cosph1ph2 and sinph2ph2"
5995         do k=2,ndouble
5996           do l=1,k-1
5997             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),
5998      &         sinph1ph2(l,k),sinph1ph2(k,l)
5999           enddo
6000         enddo
6001         write(iout,*) "ethetai",ethetai
6002         endif
6003 C       print *,ethetai
6004         do m=1,ntheterm2
6005           do k=1,nsingle
6006             aux=bbthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)
6007      &         +ccthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k)
6008      &         +ddthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)
6009      &         +eethet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k)
6010             ethetai=ethetai+sinkt(m)*aux
6011             dethetai=dethetai+0.5d0*m*aux*coskt(m)
6012             dephii=dephii+k*sinkt(m)*(
6013      &          ccthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)-
6014      &          bbthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k))
6015             dephii1=dephii1+k*sinkt(m)*(
6016      &          eethet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)-
6017      &          ddthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k))
6018             if (lprn)
6019      &      write (iout,*) "m",m," k",k," bbthet",
6020      &         bbthet(k,m,ityp1,ityp2,ityp3,iblock)," ccthet",
6021      &         ccthet(k,m,ityp1,ityp2,ityp3,iblock)," ddthet",
6022      &         ddthet(k,m,ityp1,ityp2,ityp3,iblock)," eethet",
6023      &         eethet(k,m,ityp1,ityp2,ityp3,iblock)," ethetai",ethetai
6024 C        print *,"tu",cosph1(k),sinph1(k),cosph2(k),sinph2(k)
6025           enddo
6026         enddo
6027 C        print *,"cosph1", (cosph1(k), k=1,nsingle)
6028 C        print *,"cosph2", (cosph2(k), k=1,nsingle)
6029 C        print *,"sinph1", (sinph1(k), k=1,nsingle)
6030 C        print *,"sinph2", (sinph2(k), k=1,nsingle)
6031         if (lprn)
6032      &  write(iout,*) "ethetai",ethetai
6033 C        print *,"tu",cosph1(k),sinph1(k),cosph2(k),sinph2(k)
6034         do m=1,ntheterm3
6035           do k=2,ndouble
6036             do l=1,k-1
6037               aux=ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
6038      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l)+
6039      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
6040      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)
6041               ethetai=ethetai+sinkt(m)*aux
6042               dethetai=dethetai+0.5d0*m*coskt(m)*aux
6043               dephii=dephii+l*sinkt(m)*(
6044      &           -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)-
6045      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
6046      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
6047      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
6048               dephii1=dephii1+(k-l)*sinkt(m)*(
6049      &           -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
6050      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
6051      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)-
6052      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
6053               if (lprn) then
6054               write (iout,*) "m",m," k",k," l",l," ffthet",
6055      &            ffthet(l,k,m,ityp1,ityp2,ityp3,iblock),
6056      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)," ggthet",
6057      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock),
6058      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock),
6059      &            " ethetai",ethetai
6060               write (iout,*) cosph1ph2(l,k)*sinkt(m),
6061      &            cosph1ph2(k,l)*sinkt(m),
6062      &            sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
6063               endif
6064             enddo
6065           enddo
6066         enddo
6067 10      continue
6068 c        lprn1=.true.
6069 C        print *,ethetai
6070         if (lprn1)
6071      &    write (iout,'(i2,3f8.1,9h ethetai ,f10.5)')
6072      &   i,theta(i)*rad2deg,phii*rad2deg,
6073      &   phii1*rad2deg,ethetai
6074 c        lprn1=.false.
6075         etheta=etheta+ethetai
6076         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
6077         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
6078         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)+wang*dethetai
6079       enddo
6080 C now constrains
6081       ethetacnstr=0.0d0
6082 C      print *,ithetaconstr_start,ithetaconstr_end,"TU"
6083       do i=ithetaconstr_start,ithetaconstr_end
6084         itheta=itheta_constr(i)
6085         thetiii=theta(itheta)
6086         difi=pinorm(thetiii-theta_constr0(i))
6087         if (difi.gt.theta_drange(i)) then
6088           difi=difi-theta_drange(i)
6089           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
6090           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
6091      &    +for_thet_constr(i)*difi**3
6092         else if (difi.lt.-drange(i)) then
6093           difi=difi+drange(i)
6094           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
6095           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
6096      &    +for_thet_constr(i)*difi**3
6097         else
6098           difi=0.0
6099         endif
6100        if (energy_dec) then
6101         write (iout,'(a6,2i5,4f8.3,2e14.5)') "ethetc",
6102      &    i,itheta,rad2deg*thetiii,
6103      &    rad2deg*theta_constr0(i),  rad2deg*theta_drange(i),
6104      &    rad2deg*difi,0.25d0*for_thet_constr(i)*difi**4,
6105      &    gloc(itheta+nphi-2,icg)
6106         endif
6107       enddo
6108
6109       return
6110       end
6111 #endif
6112 #ifdef CRYST_SC
6113 c-----------------------------------------------------------------------------
6114       subroutine esc(escloc)
6115 C Calculate the local energy of a side chain and its derivatives in the
6116 C corresponding virtual-bond valence angles THETA and the spherical angles
6117 C ALPHA and OMEGA.
6118       implicit real*8 (a-h,o-z)
6119       include 'DIMENSIONS'
6120       include 'COMMON.GEO'
6121       include 'COMMON.LOCAL'
6122       include 'COMMON.VAR'
6123       include 'COMMON.INTERACT'
6124       include 'COMMON.DERIV'
6125       include 'COMMON.CHAIN'
6126       include 'COMMON.IOUNITS'
6127       include 'COMMON.NAMES'
6128       include 'COMMON.FFIELD'
6129       include 'COMMON.CONTROL'
6130       double precision x(3),dersc(3),xemp(3),dersc0(3),dersc1(3),
6131      &     ddersc0(3),ddummy(3),xtemp(3),temp(3)
6132       common /sccalc/ time11,time12,time112,theti,it,nlobit
6133       delta=0.02d0*pi
6134       escloc=0.0D0
6135 c     write (iout,'(a)') 'ESC'
6136       do i=loc_start,loc_end
6137         it=itype(i)
6138         if (it.eq.ntyp1) cycle
6139         if (it.eq.10) goto 1
6140         nlobit=nlob(iabs(it))
6141 c       print *,'i=',i,' it=',it,' nlobit=',nlobit
6142 c       write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
6143         theti=theta(i+1)-pipol
6144         x(1)=dtan(theti)
6145         x(2)=alph(i)
6146         x(3)=omeg(i)
6147
6148         if (x(2).gt.pi-delta) then
6149           xtemp(1)=x(1)
6150           xtemp(2)=pi-delta
6151           xtemp(3)=x(3)
6152           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
6153           xtemp(2)=pi
6154           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
6155           call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),
6156      &        escloci,dersc(2))
6157           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
6158      &        ddersc0(1),dersc(1))
6159           call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),
6160      &        ddersc0(3),dersc(3))
6161           xtemp(2)=pi-delta
6162           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
6163           xtemp(2)=pi
6164           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
6165           call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,
6166      &            dersc0(2),esclocbi,dersc02)
6167           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
6168      &            dersc12,dersc01)
6169           call splinthet(x(2),0.5d0*delta,ss,ssd)
6170           dersc0(1)=dersc01
6171           dersc0(2)=dersc02
6172           dersc0(3)=0.0d0
6173           do k=1,3
6174             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
6175           enddo
6176           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
6177 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
6178 c    &             esclocbi,ss,ssd
6179           escloci=ss*escloci+(1.0d0-ss)*esclocbi
6180 c         escloci=esclocbi
6181 c         write (iout,*) escloci
6182         else if (x(2).lt.delta) then
6183           xtemp(1)=x(1)
6184           xtemp(2)=delta
6185           xtemp(3)=x(3)
6186           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
6187           xtemp(2)=0.0d0
6188           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
6189           call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),
6190      &        escloci,dersc(2))
6191           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
6192      &        ddersc0(1),dersc(1))
6193           call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),
6194      &        ddersc0(3),dersc(3))
6195           xtemp(2)=delta
6196           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
6197           xtemp(2)=0.0d0
6198           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
6199           call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,
6200      &            dersc0(2),esclocbi,dersc02)
6201           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
6202      &            dersc12,dersc01)
6203           dersc0(1)=dersc01
6204           dersc0(2)=dersc02
6205           dersc0(3)=0.0d0
6206           call splinthet(x(2),0.5d0*delta,ss,ssd)
6207           do k=1,3
6208             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
6209           enddo
6210           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
6211 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
6212 c    &             esclocbi,ss,ssd
6213           escloci=ss*escloci+(1.0d0-ss)*esclocbi
6214 c         write (iout,*) escloci
6215         else
6216           call enesc(x,escloci,dersc,ddummy,.false.)
6217         endif
6218
6219         escloc=escloc+escloci
6220         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
6221      &     'escloc',i,escloci
6222 c       write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
6223
6224         gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
6225      &   wscloc*dersc(1)
6226         gloc(ialph(i,1),icg)=wscloc*dersc(2)
6227         gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
6228     1   continue
6229       enddo
6230       return
6231       end
6232 C---------------------------------------------------------------------------
6233       subroutine enesc(x,escloci,dersc,ddersc,mixed)
6234       implicit real*8 (a-h,o-z)
6235       include 'DIMENSIONS'
6236       include 'COMMON.GEO'
6237       include 'COMMON.LOCAL'
6238       include 'COMMON.IOUNITS'
6239       common /sccalc/ time11,time12,time112,theti,it,nlobit
6240       double precision x(3),z(3),Ax(3,maxlob,-1:1),dersc(3),ddersc(3)
6241       double precision contr(maxlob,-1:1)
6242       logical mixed
6243 c       write (iout,*) 'it=',it,' nlobit=',nlobit
6244         escloc_i=0.0D0
6245         do j=1,3
6246           dersc(j)=0.0D0
6247           if (mixed) ddersc(j)=0.0d0
6248         enddo
6249         x3=x(3)
6250
6251 C Because of periodicity of the dependence of the SC energy in omega we have
6252 C to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
6253 C To avoid underflows, first compute & store the exponents.
6254
6255         do iii=-1,1
6256
6257           x(3)=x3+iii*dwapi
6258
6259           do j=1,nlobit
6260             do k=1,3
6261               z(k)=x(k)-censc(k,j,it)
6262             enddo
6263             do k=1,3
6264               Axk=0.0D0
6265               do l=1,3
6266                 Axk=Axk+gaussc(l,k,j,it)*z(l)
6267               enddo
6268               Ax(k,j,iii)=Axk
6269             enddo
6270             expfac=0.0D0
6271             do k=1,3
6272               expfac=expfac+Ax(k,j,iii)*z(k)
6273             enddo
6274             contr(j,iii)=expfac
6275           enddo ! j
6276
6277         enddo ! iii
6278
6279         x(3)=x3
6280 C As in the case of ebend, we want to avoid underflows in exponentiation and
6281 C subsequent NaNs and INFs in energy calculation.
6282 C Find the largest exponent
6283         emin=contr(1,-1)
6284         do iii=-1,1
6285           do j=1,nlobit
6286             if (emin.gt.contr(j,iii)) emin=contr(j,iii)
6287           enddo
6288         enddo
6289         emin=0.5D0*emin
6290 cd      print *,'it=',it,' emin=',emin
6291
6292 C Compute the contribution to SC energy and derivatives
6293         do iii=-1,1
6294
6295           do j=1,nlobit
6296 #ifdef OSF
6297             adexp=bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin
6298             if(adexp.ne.adexp) adexp=1.0
6299             expfac=dexp(adexp)
6300 #else
6301             expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin)
6302 #endif
6303 cd          print *,'j=',j,' expfac=',expfac
6304             escloc_i=escloc_i+expfac
6305             do k=1,3
6306               dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
6307             enddo
6308             if (mixed) then
6309               do k=1,3,2
6310                 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii)
6311      &            +gaussc(k,2,j,it))*expfac
6312               enddo
6313             endif
6314           enddo
6315
6316         enddo ! iii
6317
6318         dersc(1)=dersc(1)/cos(theti)**2
6319         ddersc(1)=ddersc(1)/cos(theti)**2
6320         ddersc(3)=ddersc(3)
6321
6322         escloci=-(dlog(escloc_i)-emin)
6323         do j=1,3
6324           dersc(j)=dersc(j)/escloc_i
6325         enddo
6326         if (mixed) then
6327           do j=1,3,2
6328             ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
6329           enddo
6330         endif
6331       return
6332       end
6333 C------------------------------------------------------------------------------
6334       subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
6335       implicit real*8 (a-h,o-z)
6336       include 'DIMENSIONS'
6337       include 'COMMON.GEO'
6338       include 'COMMON.LOCAL'
6339       include 'COMMON.IOUNITS'
6340       common /sccalc/ time11,time12,time112,theti,it,nlobit
6341       double precision x(3),z(3),Ax(3,maxlob),dersc(3)
6342       double precision contr(maxlob)
6343       logical mixed
6344
6345       escloc_i=0.0D0
6346
6347       do j=1,3
6348         dersc(j)=0.0D0
6349       enddo
6350
6351       do j=1,nlobit
6352         do k=1,2
6353           z(k)=x(k)-censc(k,j,it)
6354         enddo
6355         z(3)=dwapi
6356         do k=1,3
6357           Axk=0.0D0
6358           do l=1,3
6359             Axk=Axk+gaussc(l,k,j,it)*z(l)
6360           enddo
6361           Ax(k,j)=Axk
6362         enddo
6363         expfac=0.0D0
6364         do k=1,3
6365           expfac=expfac+Ax(k,j)*z(k)
6366         enddo
6367         contr(j)=expfac
6368       enddo ! j
6369
6370 C As in the case of ebend, we want to avoid underflows in exponentiation and
6371 C subsequent NaNs and INFs in energy calculation.
6372 C Find the largest exponent
6373       emin=contr(1)
6374       do j=1,nlobit
6375         if (emin.gt.contr(j)) emin=contr(j)
6376       enddo
6377       emin=0.5D0*emin
6378
6379 C Compute the contribution to SC energy and derivatives
6380
6381       dersc12=0.0d0
6382       do j=1,nlobit
6383         expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j)+emin)
6384         escloc_i=escloc_i+expfac
6385         do k=1,2
6386           dersc(k)=dersc(k)+Ax(k,j)*expfac
6387         enddo
6388         if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j)
6389      &            +gaussc(1,2,j,it))*expfac
6390         dersc(3)=0.0d0
6391       enddo
6392
6393       dersc(1)=dersc(1)/cos(theti)**2
6394       dersc12=dersc12/cos(theti)**2
6395       escloci=-(dlog(escloc_i)-emin)
6396       do j=1,2
6397         dersc(j)=dersc(j)/escloc_i
6398       enddo
6399       if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
6400       return
6401       end
6402 #else
6403 c----------------------------------------------------------------------------------
6404       subroutine esc(escloc)
6405 C Calculate the local energy of a side chain and its derivatives in the
6406 C corresponding virtual-bond valence angles THETA and the spherical angles
6407 C ALPHA and OMEGA derived from AM1 all-atom calculations.
6408 C added by Urszula Kozlowska. 07/11/2007
6409 C
6410       implicit real*8 (a-h,o-z)
6411       include 'DIMENSIONS'
6412       include 'COMMON.GEO'
6413       include 'COMMON.LOCAL'
6414       include 'COMMON.VAR'
6415       include 'COMMON.SCROT'
6416       include 'COMMON.INTERACT'
6417       include 'COMMON.DERIV'
6418       include 'COMMON.CHAIN'
6419       include 'COMMON.IOUNITS'
6420       include 'COMMON.NAMES'
6421       include 'COMMON.FFIELD'
6422       include 'COMMON.CONTROL'
6423       include 'COMMON.VECTORS'
6424       double precision x_prime(3),y_prime(3),z_prime(3)
6425      &    , sumene,dsc_i,dp2_i,x(65),
6426      &     xx,yy,zz,sumene1,sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6,
6427      &    de_dxx,de_dyy,de_dzz,de_dt
6428       double precision s1_t,s1_6_t,s2_t,s2_6_t
6429       double precision
6430      & dXX_Ci1(3),dYY_Ci1(3),dZZ_Ci1(3),dXX_Ci(3),
6431      & dYY_Ci(3),dZZ_Ci(3),dXX_XYZ(3),dYY_XYZ(3),dZZ_XYZ(3),
6432      & dt_dCi(3),dt_dCi1(3)
6433       common /sccalc/ time11,time12,time112,theti,it,nlobit
6434       delta=0.02d0*pi
6435       escloc=0.0D0
6436       do i=loc_start,loc_end
6437         if (itype(i).eq.ntyp1) cycle
6438         costtab(i+1) =dcos(theta(i+1))
6439         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
6440         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
6441         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
6442         cosfac2=0.5d0/(1.0d0+costtab(i+1))
6443         cosfac=dsqrt(cosfac2)
6444         sinfac2=0.5d0/(1.0d0-costtab(i+1))
6445         sinfac=dsqrt(sinfac2)
6446         it=iabs(itype(i))
6447         if (it.eq.10) goto 1
6448 c
6449 C  Compute the axes of tghe local cartesian coordinates system; store in
6450 c   x_prime, y_prime and z_prime
6451 c
6452         do j=1,3
6453           x_prime(j) = 0.00
6454           y_prime(j) = 0.00
6455           z_prime(j) = 0.00
6456         enddo
6457 C        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
6458 C     &   dc_norm(3,i+nres)
6459         do j = 1,3
6460           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
6461           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
6462         enddo
6463         do j = 1,3
6464           z_prime(j) = -uz(j,i-1)*dsign(1.0d0,dfloat(itype(i)))
6465         enddo
6466 c       write (2,*) "i",i
6467 c       write (2,*) "x_prime",(x_prime(j),j=1,3)
6468 c       write (2,*) "y_prime",(y_prime(j),j=1,3)
6469 c       write (2,*) "z_prime",(z_prime(j),j=1,3)
6470 c       write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
6471 c      & " xy",scalar(x_prime(1),y_prime(1)),
6472 c      & " xz",scalar(x_prime(1),z_prime(1)),
6473 c      & " yy",scalar(y_prime(1),y_prime(1)),
6474 c      & " yz",scalar(y_prime(1),z_prime(1)),
6475 c      & " zz",scalar(z_prime(1),z_prime(1))
6476 c
6477 C Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
6478 C to local coordinate system. Store in xx, yy, zz.
6479 c
6480         xx=0.0d0
6481         yy=0.0d0
6482         zz=0.0d0
6483         do j = 1,3
6484           xx = xx + x_prime(j)*dc_norm(j,i+nres)
6485           yy = yy + y_prime(j)*dc_norm(j,i+nres)
6486           zz = zz + z_prime(j)*dc_norm(j,i+nres)
6487         enddo
6488
6489         xxtab(i)=xx
6490         yytab(i)=yy
6491         zztab(i)=zz
6492 C
6493 C Compute the energy of the ith side cbain
6494 C
6495 c        write (2,*) "xx",xx," yy",yy," zz",zz
6496         it=iabs(itype(i))
6497         do j = 1,65
6498           x(j) = sc_parmin(j,it)
6499         enddo
6500 #ifdef CHECK_COORD
6501 Cc diagnostics - remove later
6502         xx1 = dcos(alph(2))
6503         yy1 = dsin(alph(2))*dcos(omeg(2))
6504         zz1 = -dsign(1.0,dfloat(itype(i)))*dsin(alph(2))*dsin(omeg(2))
6505         write(2,'(3f8.1,3f9.3,1x,3f9.3)')
6506      &    alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,
6507      &    xx1,yy1,zz1
6508 C,"  --- ", xx_w,yy_w,zz_w
6509 c end diagnostics
6510 #endif
6511         sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
6512      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
6513      &   + x(10)*yy*zz
6514         sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
6515      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
6516      & + x(20)*yy*zz
6517         sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
6518      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
6519      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
6520      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
6521      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
6522      &  +x(40)*xx*yy*zz
6523         sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
6524      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
6525      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
6526      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
6527      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
6528      &  +x(60)*xx*yy*zz
6529         dsc_i   = 0.743d0+x(61)
6530         dp2_i   = 1.9d0+x(62)
6531         dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
6532      &          *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
6533         dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
6534      &          *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
6535         s1=(1+x(63))/(0.1d0 + dscp1)
6536         s1_6=(1+x(64))/(0.1d0 + dscp1**6)
6537         s2=(1+x(65))/(0.1d0 + dscp2)
6538         s2_6=(1+x(65))/(0.1d0 + dscp2**6)
6539         sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6)
6540      & + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
6541 c        write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
6542 c     &   sumene4,
6543 c     &   dscp1,dscp2,sumene
6544 c        sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6545         escloc = escloc + sumene
6546 c        write (2,*) "i",i," escloc",sumene,escloc,it,itype(i)
6547 c     & ,zz,xx,yy
6548 c#define DEBUG
6549 #ifdef DEBUG
6550 C
6551 C This section to check the numerical derivatives of the energy of ith side
6552 C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
6553 C #define DEBUG in the code to turn it on.
6554 C
6555         write (2,*) "sumene               =",sumene
6556         aincr=1.0d-7
6557         xxsave=xx
6558         xx=xx+aincr
6559         write (2,*) xx,yy,zz
6560         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6561         de_dxx_num=(sumenep-sumene)/aincr
6562         xx=xxsave
6563         write (2,*) "xx+ sumene from enesc=",sumenep
6564         yysave=yy
6565         yy=yy+aincr
6566         write (2,*) xx,yy,zz
6567         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6568         de_dyy_num=(sumenep-sumene)/aincr
6569         yy=yysave
6570         write (2,*) "yy+ sumene from enesc=",sumenep
6571         zzsave=zz
6572         zz=zz+aincr
6573         write (2,*) xx,yy,zz
6574         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6575         de_dzz_num=(sumenep-sumene)/aincr
6576         zz=zzsave
6577         write (2,*) "zz+ sumene from enesc=",sumenep
6578         costsave=cost2tab(i+1)
6579         sintsave=sint2tab(i+1)
6580         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
6581         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
6582         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6583         de_dt_num=(sumenep-sumene)/aincr
6584         write (2,*) " t+ sumene from enesc=",sumenep
6585         cost2tab(i+1)=costsave
6586         sint2tab(i+1)=sintsave
6587 C End of diagnostics section.
6588 #endif
6589 C
6590 C Compute the gradient of esc
6591 C
6592 c        zz=zz*dsign(1.0,dfloat(itype(i)))
6593         pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
6594         pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
6595         pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
6596         pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
6597         pom_dx=dsc_i*dp2_i*cost2tab(i+1)
6598         pom_dy=dsc_i*dp2_i*sint2tab(i+1)
6599         pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
6600         pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
6601         pom1=(sumene3*sint2tab(i+1)+sumene1)
6602      &     *(pom_s1/dscp1+pom_s16*dscp1**4)
6603         pom2=(sumene4*cost2tab(i+1)+sumene2)
6604      &     *(pom_s2/dscp2+pom_s26*dscp2**4)
6605         sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
6606         sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2
6607      &  +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2)
6608      &  +x(40)*yy*zz
6609         sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
6610         sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2
6611      &  +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2)
6612      &  +x(60)*yy*zz
6613         de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6)
6614      &        +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6)
6615      &        +(pom1+pom2)*pom_dx
6616 #ifdef DEBUG
6617         write(2,*), "de_dxx = ", de_dxx,de_dxx_num,itype(i)
6618 #endif
6619 C
6620         sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
6621         sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2
6622      &  +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2)
6623      &  +x(40)*xx*zz
6624         sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
6625         sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz
6626      &  +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz
6627      &  +x(59)*zz**2 +x(60)*xx*zz
6628         de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6)
6629      &        +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6)
6630      &        +(pom1-pom2)*pom_dy
6631 #ifdef DEBUG
6632         write(2,*), "de_dyy = ", de_dyy,de_dyy_num,itype(i)
6633 #endif
6634 C
6635         de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy
6636      &  +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx
6637      &  +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6)
6638      &  +(x(4) + 2*x(7)*zz+  x(8)*xx + x(10)*yy)*(s1+s1_6)
6639      &  +(x(44)+2*x(47)*zz +x(48)*xx   +x(50)*yy  +3*x(53)*zz**2
6640      &  +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy
6641      &  +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6)
6642      &  + ( x(14) + 2*x(17)*zz+  x(18)*xx + x(20)*yy)*(s2+s2_6)
6643 #ifdef DEBUG
6644         write(2,*), "de_dzz = ", de_dzz,de_dzz_num,itype(i)
6645 #endif
6646 C
6647         de_dt =  0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6)
6648      &  -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6)
6649      &  +pom1*pom_dt1+pom2*pom_dt2
6650 #ifdef DEBUG
6651         write(2,*), "de_dt = ", de_dt,de_dt_num,itype(i)
6652 #endif
6653 c#undef DEBUG
6654 c
6655 C
6656        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
6657        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
6658        cosfac2xx=cosfac2*xx
6659        sinfac2yy=sinfac2*yy
6660        do k = 1,3
6661          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))*
6662      &      vbld_inv(i+1)
6663          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))*
6664      &      vbld_inv(i)
6665          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
6666          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
6667 c         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
6668 c     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
6669 c         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
6670 c     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
6671          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
6672          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
6673          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
6674          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
6675          dZZ_Ci1(k)=0.0d0
6676          dZZ_Ci(k)=0.0d0
6677          do j=1,3
6678            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)
6679      &     *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
6680            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)
6681      &     *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
6682          enddo
6683
6684          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
6685          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
6686          dZZ_XYZ(k)=vbld_inv(i+nres)*
6687      &   (z_prime(k)-zz*dC_norm(k,i+nres))
6688 c
6689          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
6690          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
6691        enddo
6692
6693        do k=1,3
6694          dXX_Ctab(k,i)=dXX_Ci(k)
6695          dXX_C1tab(k,i)=dXX_Ci1(k)
6696          dYY_Ctab(k,i)=dYY_Ci(k)
6697          dYY_C1tab(k,i)=dYY_Ci1(k)
6698          dZZ_Ctab(k,i)=dZZ_Ci(k)
6699          dZZ_C1tab(k,i)=dZZ_Ci1(k)
6700          dXX_XYZtab(k,i)=dXX_XYZ(k)
6701          dYY_XYZtab(k,i)=dYY_XYZ(k)
6702          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
6703        enddo
6704
6705        do k = 1,3
6706 c         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
6707 c     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
6708 c         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
6709 c     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
6710 c         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
6711 c     &    dt_dci(k)
6712 c         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
6713 c     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
6714          gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k)
6715      &    +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
6716          gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k)
6717      &    +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
6718          gsclocx(k,i)=                 de_dxx*dxx_XYZ(k)
6719      &    +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
6720        enddo
6721 c       write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
6722 c     &  (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
6723
6724 C to check gradient call subroutine check_grad
6725
6726     1 continue
6727       enddo
6728       return
6729       end
6730 c------------------------------------------------------------------------------
6731       double precision function enesc(x,xx,yy,zz,cost2,sint2)
6732       implicit none
6733       double precision x(65),xx,yy,zz,cost2,sint2,sumene1,sumene2,
6734      & sumene3,sumene4,sumene,dsc_i,dp2_i,dscp1,dscp2,s1,s1_6,s2,s2_6
6735       sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
6736      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
6737      &   + x(10)*yy*zz
6738       sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
6739      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
6740      & + x(20)*yy*zz
6741       sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
6742      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
6743      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
6744      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
6745      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
6746      &  +x(40)*xx*yy*zz
6747       sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
6748      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
6749      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
6750      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
6751      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
6752      &  +x(60)*xx*yy*zz
6753       dsc_i   = 0.743d0+x(61)
6754       dp2_i   = 1.9d0+x(62)
6755       dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
6756      &          *(xx*cost2+yy*sint2))
6757       dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
6758      &          *(xx*cost2-yy*sint2))
6759       s1=(1+x(63))/(0.1d0 + dscp1)
6760       s1_6=(1+x(64))/(0.1d0 + dscp1**6)
6761       s2=(1+x(65))/(0.1d0 + dscp2)
6762       s2_6=(1+x(65))/(0.1d0 + dscp2**6)
6763       sumene = ( sumene3*sint2 + sumene1)*(s1+s1_6)
6764      & + (sumene4*cost2 +sumene2)*(s2+s2_6)
6765       enesc=sumene
6766       return
6767       end
6768 #endif
6769 c------------------------------------------------------------------------------
6770       subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
6771 C
6772 C This procedure calculates two-body contact function g(rij) and its derivative:
6773 C
6774 C           eps0ij                                     !       x < -1
6775 C g(rij) =  esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5)  ! -1 =< x =< 1
6776 C            0                                         !       x > 1
6777 C
6778 C where x=(rij-r0ij)/delta
6779 C
6780 C rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
6781 C
6782       implicit none
6783       double precision rij,r0ij,eps0ij,fcont,fprimcont
6784       double precision x,x2,x4,delta
6785 c     delta=0.02D0*r0ij
6786 c      delta=0.2D0*r0ij
6787       x=(rij-r0ij)/delta
6788       if (x.lt.-1.0D0) then
6789         fcont=eps0ij
6790         fprimcont=0.0D0
6791       else if (x.le.1.0D0) then
6792         x2=x*x
6793         x4=x2*x2
6794         fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
6795         fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
6796       else
6797         fcont=0.0D0
6798         fprimcont=0.0D0
6799       endif
6800       return
6801       end
6802 c------------------------------------------------------------------------------
6803       subroutine splinthet(theti,delta,ss,ssder)
6804       implicit real*8 (a-h,o-z)
6805       include 'DIMENSIONS'
6806       include 'COMMON.VAR'
6807       include 'COMMON.GEO'
6808       thetup=pi-delta
6809       thetlow=delta
6810       if (theti.gt.pipol) then
6811         call gcont(theti,thetup,1.0d0,delta,ss,ssder)
6812       else
6813         call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
6814         ssder=-ssder
6815       endif
6816       return
6817       end
6818 c------------------------------------------------------------------------------
6819       subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
6820       implicit none
6821       double precision x,x0,delta,f0,f1,fprim0,f,fprim
6822       double precision ksi,ksi2,ksi3,a1,a2,a3
6823       a1=fprim0*delta/(f1-f0)
6824       a2=3.0d0-2.0d0*a1
6825       a3=a1-2.0d0
6826       ksi=(x-x0)/delta
6827       ksi2=ksi*ksi
6828       ksi3=ksi2*ksi
6829       f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
6830       fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
6831       return
6832       end
6833 c------------------------------------------------------------------------------
6834       subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
6835       implicit none
6836       double precision x,x0,delta,f0x,f1x,fprim0x,fx
6837       double precision ksi,ksi2,ksi3,a1,a2,a3
6838       ksi=(x-x0)/delta
6839       ksi2=ksi*ksi
6840       ksi3=ksi2*ksi
6841       a1=fprim0x*delta
6842       a2=3*(f1x-f0x)-2*fprim0x*delta
6843       a3=fprim0x*delta-2*(f1x-f0x)
6844       fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
6845       return
6846       end
6847 C-----------------------------------------------------------------------------
6848 #ifdef CRYST_TOR
6849 C-----------------------------------------------------------------------------
6850       subroutine etor(etors,edihcnstr)
6851       implicit real*8 (a-h,o-z)
6852       include 'DIMENSIONS'
6853       include 'COMMON.VAR'
6854       include 'COMMON.GEO'
6855       include 'COMMON.LOCAL'
6856       include 'COMMON.TORSION'
6857       include 'COMMON.INTERACT'
6858       include 'COMMON.DERIV'
6859       include 'COMMON.CHAIN'
6860       include 'COMMON.NAMES'
6861       include 'COMMON.IOUNITS'
6862       include 'COMMON.FFIELD'
6863       include 'COMMON.TORCNSTR'
6864       include 'COMMON.CONTROL'
6865       logical lprn
6866 C Set lprn=.true. for debugging
6867       lprn=.false.
6868 c      lprn=.true.
6869       etors=0.0D0
6870       do i=iphi_start,iphi_end
6871       etors_ii=0.0D0
6872         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
6873      &      .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
6874         itori=itortyp(itype(i-2))
6875         itori1=itortyp(itype(i-1))
6876         phii=phi(i)
6877         gloci=0.0D0
6878 C Proline-Proline pair is a special case...
6879         if (itori.eq.3 .and. itori1.eq.3) then
6880           if (phii.gt.-dwapi3) then
6881             cosphi=dcos(3*phii)
6882             fac=1.0D0/(1.0D0-cosphi)
6883             etorsi=v1(1,3,3)*fac
6884             etorsi=etorsi+etorsi
6885             etors=etors+etorsi-v1(1,3,3)
6886             if (energy_dec) etors_ii=etors_ii+etorsi-v1(1,3,3)
6887             gloci=gloci-3*fac*etorsi*dsin(3*phii)
6888           endif
6889           do j=1,3
6890             v1ij=v1(j+1,itori,itori1)
6891             v2ij=v2(j+1,itori,itori1)
6892             cosphi=dcos(j*phii)
6893             sinphi=dsin(j*phii)
6894             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
6895             if (energy_dec) etors_ii=etors_ii+
6896      &                              v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
6897             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
6898           enddo
6899         else
6900           do j=1,nterm_old
6901             v1ij=v1(j,itori,itori1)
6902             v2ij=v2(j,itori,itori1)
6903             cosphi=dcos(j*phii)
6904             sinphi=dsin(j*phii)
6905             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
6906             if (energy_dec) etors_ii=etors_ii+
6907      &                  v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
6908             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
6909           enddo
6910         endif
6911         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
6912              'etor',i,etors_ii
6913         if (lprn)
6914      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
6915      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
6916      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
6917         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
6918 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
6919       enddo
6920 ! 6/20/98 - dihedral angle constraints
6921       edihcnstr=0.0d0
6922       do i=1,ndih_constr
6923         itori=idih_constr(i)
6924         phii=phi(itori)
6925         difi=phii-phi0(i)
6926         if (difi.gt.drange(i)) then
6927           difi=difi-drange(i)
6928           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
6929           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
6930         else if (difi.lt.-drange(i)) then
6931           difi=difi+drange(i)
6932           edihcnstr=edihcnstr+0.25d0*ftors(i)**difi**4
6933           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
6934         endif
6935 !        write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii,
6936 !     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
6937       enddo
6938 !      write (iout,*) 'edihcnstr',edihcnstr
6939       return
6940       end
6941 c------------------------------------------------------------------------------
6942       subroutine etor_d(etors_d)
6943       etors_d=0.0d0
6944       return
6945       end
6946 c----------------------------------------------------------------------------
6947 #else
6948       subroutine etor(etors,edihcnstr)
6949       implicit real*8 (a-h,o-z)
6950       include 'DIMENSIONS'
6951       include 'COMMON.VAR'
6952       include 'COMMON.GEO'
6953       include 'COMMON.LOCAL'
6954       include 'COMMON.TORSION'
6955       include 'COMMON.INTERACT'
6956       include 'COMMON.DERIV'
6957       include 'COMMON.CHAIN'
6958       include 'COMMON.NAMES'
6959       include 'COMMON.IOUNITS'
6960       include 'COMMON.FFIELD'
6961       include 'COMMON.TORCNSTR'
6962       include 'COMMON.CONTROL'
6963       logical lprn
6964 C Set lprn=.true. for debugging
6965       lprn=.false.
6966 c     lprn=.true.
6967       etors=0.0D0
6968       do i=iphi_start,iphi_end
6969 C ANY TWO ARE DUMMY ATOMS in row CYCLE
6970 c        if (((itype(i-3).eq.ntyp1).and.(itype(i-2).eq.ntyp1)).or.
6971 c     &      ((itype(i-2).eq.ntyp1).and.(itype(i-1).eq.ntyp1))  .or.
6972 c     &      ((itype(i-1).eq.ntyp1).and.(itype(i).eq.ntyp1))) cycle
6973         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
6974      &      .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
6975 C In current verion the ALL DUMMY ATOM POTENTIALS ARE OFF
6976 C For introducing the NH3+ and COO- group please check the etor_d for reference
6977 C and guidance
6978         etors_ii=0.0D0
6979          if (iabs(itype(i)).eq.20) then
6980          iblock=2
6981          else
6982          iblock=1
6983          endif
6984         itori=itortyp(itype(i-2))
6985         itori1=itortyp(itype(i-1))
6986         phii=phi(i)
6987         gloci=0.0D0
6988 C Regular cosine and sine terms
6989         do j=1,nterm(itori,itori1,iblock)
6990           v1ij=v1(j,itori,itori1,iblock)
6991           v2ij=v2(j,itori,itori1,iblock)
6992           cosphi=dcos(j*phii)
6993           sinphi=dsin(j*phii)
6994           etors=etors+v1ij*cosphi+v2ij*sinphi
6995           if (energy_dec) etors_ii=etors_ii+
6996      &                v1ij*cosphi+v2ij*sinphi
6997           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
6998         enddo
6999 C Lorentz terms
7000 C                         v1
7001 C  E = SUM ----------------------------------- - v1
7002 C          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
7003 C
7004         cosphi=dcos(0.5d0*phii)
7005         sinphi=dsin(0.5d0*phii)
7006         do j=1,nlor(itori,itori1,iblock)
7007           vl1ij=vlor1(j,itori,itori1)
7008           vl2ij=vlor2(j,itori,itori1)
7009           vl3ij=vlor3(j,itori,itori1)
7010           pom=vl2ij*cosphi+vl3ij*sinphi
7011           pom1=1.0d0/(pom*pom+1.0d0)
7012           etors=etors+vl1ij*pom1
7013           if (energy_dec) etors_ii=etors_ii+
7014      &                vl1ij*pom1
7015           pom=-pom*pom1*pom1
7016           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
7017         enddo
7018 C Subtract the constant term
7019         etors=etors-v0(itori,itori1,iblock)
7020           if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
7021      &         'etor',i,etors_ii-v0(itori,itori1,iblock)
7022         if (lprn)
7023      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
7024      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
7025      &  (v1(j,itori,itori1,iblock),j=1,6),
7026      &  (v2(j,itori,itori1,iblock),j=1,6)
7027         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
7028 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
7029       enddo
7030 ! 6/20/98 - dihedral angle constraints
7031       edihcnstr=0.0d0
7032 c      do i=1,ndih_constr
7033       do i=idihconstr_start,idihconstr_end
7034         itori=idih_constr(i)
7035         phii=phi(itori)
7036         difi=pinorm(phii-phi0(i))
7037         if (difi.gt.drange(i)) then
7038           difi=difi-drange(i)
7039           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
7040           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
7041         else if (difi.lt.-drange(i)) then
7042           difi=difi+drange(i)
7043           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
7044           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
7045         else
7046           difi=0.0
7047         endif
7048        if (energy_dec) then
7049         write (iout,'(a6,2i5,4f8.3,2e14.5)') "edihc",
7050      &    i,itori,rad2deg*phii,
7051      &    rad2deg*phi0(i),  rad2deg*drange(i),
7052      &    rad2deg*difi,0.25d0*ftors(i)*difi**4,gloc(itori-3,icg)
7053         endif
7054       enddo
7055 cd       write (iout,*) 'edihcnstr',edihcnstr
7056       return
7057       end
7058 c----------------------------------------------------------------------------
7059       subroutine etor_d(etors_d)
7060 C 6/23/01 Compute double torsional energy
7061       implicit real*8 (a-h,o-z)
7062       include 'DIMENSIONS'
7063       include 'COMMON.VAR'
7064       include 'COMMON.GEO'
7065       include 'COMMON.LOCAL'
7066       include 'COMMON.TORSION'
7067       include 'COMMON.INTERACT'
7068       include 'COMMON.DERIV'
7069       include 'COMMON.CHAIN'
7070       include 'COMMON.NAMES'
7071       include 'COMMON.IOUNITS'
7072       include 'COMMON.FFIELD'
7073       include 'COMMON.TORCNSTR'
7074       logical lprn
7075 C Set lprn=.true. for debugging
7076       lprn=.false.
7077 c     lprn=.true.
7078       etors_d=0.0D0
7079 c      write(iout,*) "a tu??"
7080       do i=iphid_start,iphid_end
7081 C ANY TWO ARE DUMMY ATOMS in row CYCLE
7082 C        if (((itype(i-3).eq.ntyp1).and.(itype(i-2).eq.ntyp1)).or.
7083 C     &      ((itype(i-2).eq.ntyp1).and.(itype(i-1).eq.ntyp1)).or.
7084 C     &      ((itype(i-1).eq.ntyp1).and.(itype(i).eq.ntyp1))  .or.
7085 C     &      ((itype(i).eq.ntyp1).and.(itype(i+1).eq.ntyp1))) cycle
7086          if ((itype(i-2).eq.ntyp1).or.itype(i-3).eq.ntyp1.or.
7087      &  (itype(i-1).eq.ntyp1).or.(itype(i).eq.ntyp1).or.
7088      &  (itype(i+1).eq.ntyp1)) cycle
7089 C In current verion the ALL DUMMY ATOM POTENTIALS ARE OFF
7090         itori=itortyp(itype(i-2))
7091         itori1=itortyp(itype(i-1))
7092         itori2=itortyp(itype(i))
7093         phii=phi(i)
7094         phii1=phi(i+1)
7095         gloci1=0.0D0
7096         gloci2=0.0D0
7097         iblock=1
7098         if (iabs(itype(i+1)).eq.20) iblock=2
7099 C Iblock=2 Proline type
7100 C ADASKO: WHEN PARAMETERS FOR THIS TYPE OF BLOCKING GROUP IS READY UNCOMMENT
7101 C CHECK WEATHER THERE IS NECCESITY FOR iblock=3 for COO-
7102 C        if (itype(i+1).eq.ntyp1) iblock=3
7103 C The problem of NH3+ group can be resolved by adding new parameters please note if there
7104 C IS or IS NOT need for this
7105 C IF Yes uncomment below and add to parmread.F appropriate changes and to v1cij and so on
7106 C        is (itype(i-3).eq.ntyp1) ntblock=2
7107 C        ntblock is N-terminal blocking group
7108
7109 C Regular cosine and sine terms
7110         do j=1,ntermd_1(itori,itori1,itori2,iblock)
7111 C Example of changes for NH3+ blocking group
7112 C       do j=1,ntermd_1(itori,itori1,itori2,iblock,ntblock)
7113 C          v1cij=v1c(1,j,itori,itori1,itori2,iblock,ntblock)
7114           v1cij=v1c(1,j,itori,itori1,itori2,iblock)
7115           v1sij=v1s(1,j,itori,itori1,itori2,iblock)
7116           v2cij=v1c(2,j,itori,itori1,itori2,iblock)
7117           v2sij=v1s(2,j,itori,itori1,itori2,iblock)
7118           cosphi1=dcos(j*phii)
7119           sinphi1=dsin(j*phii)
7120           cosphi2=dcos(j*phii1)
7121           sinphi2=dsin(j*phii1)
7122           etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+
7123      &     v2cij*cosphi2+v2sij*sinphi2
7124           gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
7125           gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
7126         enddo
7127         do k=2,ntermd_2(itori,itori1,itori2,iblock)
7128           do l=1,k-1
7129             v1cdij = v2c(k,l,itori,itori1,itori2,iblock)
7130             v2cdij = v2c(l,k,itori,itori1,itori2,iblock)
7131             v1sdij = v2s(k,l,itori,itori1,itori2,iblock)
7132             v2sdij = v2s(l,k,itori,itori1,itori2,iblock)
7133             cosphi1p2=dcos(l*phii+(k-l)*phii1)
7134             cosphi1m2=dcos(l*phii-(k-l)*phii1)
7135             sinphi1p2=dsin(l*phii+(k-l)*phii1)
7136             sinphi1m2=dsin(l*phii-(k-l)*phii1)
7137             etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+
7138      &        v1sdij*sinphi1p2+v2sdij*sinphi1m2
7139             gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2
7140      &        -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
7141             gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2
7142      &        -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
7143           enddo
7144         enddo
7145         gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*gloci1
7146         gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*gloci2
7147       enddo
7148       return
7149       end
7150 #endif
7151 c------------------------------------------------------------------------------
7152       subroutine eback_sc_corr(esccor)
7153 c 7/21/2007 Correlations between the backbone-local and side-chain-local
7154 c        conformational states; temporarily implemented as differences
7155 c        between UNRES torsional potentials (dependent on three types of
7156 c        residues) and the torsional potentials dependent on all 20 types
7157 c        of residues computed from AM1  energy surfaces of terminally-blocked
7158 c        amino-acid residues.
7159       implicit real*8 (a-h,o-z)
7160       include 'DIMENSIONS'
7161       include 'COMMON.VAR'
7162       include 'COMMON.GEO'
7163       include 'COMMON.LOCAL'
7164       include 'COMMON.TORSION'
7165       include 'COMMON.SCCOR'
7166       include 'COMMON.INTERACT'
7167       include 'COMMON.DERIV'
7168       include 'COMMON.CHAIN'
7169       include 'COMMON.NAMES'
7170       include 'COMMON.IOUNITS'
7171       include 'COMMON.FFIELD'
7172       include 'COMMON.CONTROL'
7173       logical lprn
7174 C Set lprn=.true. for debugging
7175       lprn=.false.
7176 c      lprn=.true.
7177 c      write (iout,*) "EBACK_SC_COR",itau_start,itau_end
7178       esccor=0.0D0
7179       do i=itau_start,itau_end
7180         if ((itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)) cycle
7181         esccor_ii=0.0D0
7182         isccori=isccortyp(itype(i-2))
7183         isccori1=isccortyp(itype(i-1))
7184 c      write (iout,*) "EBACK_SC_COR",i,nterm_sccor(isccori,isccori1)
7185         phii=phi(i)
7186         do intertyp=1,3 !intertyp
7187 cc Added 09 May 2012 (Adasko)
7188 cc  Intertyp means interaction type of backbone mainchain correlation:
7189 c   1 = SC...Ca...Ca...Ca
7190 c   2 = Ca...Ca...Ca...SC
7191 c   3 = SC...Ca...Ca...SCi
7192         gloci=0.0D0
7193         if (((intertyp.eq.3).and.((itype(i-2).eq.10).or.
7194      &      (itype(i-1).eq.10).or.(itype(i-2).eq.ntyp1).or.
7195      &      (itype(i-1).eq.ntyp1)))
7196      &    .or. ((intertyp.eq.1).and.((itype(i-2).eq.10)
7197      &     .or.(itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)
7198      &     .or.(itype(i).eq.ntyp1)))
7199      &    .or.((intertyp.eq.2).and.((itype(i-1).eq.10).or.
7200      &      (itype(i-1).eq.ntyp1).or.(itype(i-2).eq.ntyp1).or.
7201      &      (itype(i-3).eq.ntyp1)))) cycle
7202         if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1).eq.ntyp1)) cycle
7203         if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres).eq.ntyp1))
7204      & cycle
7205        do j=1,nterm_sccor(isccori,isccori1)
7206           v1ij=v1sccor(j,intertyp,isccori,isccori1)
7207           v2ij=v2sccor(j,intertyp,isccori,isccori1)
7208           cosphi=dcos(j*tauangle(intertyp,i))
7209           sinphi=dsin(j*tauangle(intertyp,i))
7210           esccor=esccor+v1ij*cosphi+v2ij*sinphi
7211           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7212         enddo
7213 c      write (iout,*) "EBACK_SC_COR",i,v1ij*cosphi+v2ij*sinphi,intertyp
7214         gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci
7215         if (lprn)
7216      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
7217      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,isccori,isccori1,
7218      &  (v1sccor(j,intertyp,isccori,isccori1),j=1,6)
7219      & ,(v2sccor(j,intertyp,isccori,isccori1),j=1,6)
7220         gsccor_loc(i-3)=gsccor_loc(i-3)+gloci
7221        enddo !intertyp
7222       enddo
7223
7224       return
7225       end
7226 c----------------------------------------------------------------------------
7227       subroutine multibody(ecorr)
7228 C This subroutine calculates multi-body contributions to energy following
7229 C the idea of Skolnick et al. If side chains I and J make a contact and
7230 C at the same time side chains I+1 and J+1 make a contact, an extra
7231 C contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
7232       implicit real*8 (a-h,o-z)
7233       include 'DIMENSIONS'
7234       include 'COMMON.IOUNITS'
7235       include 'COMMON.DERIV'
7236       include 'COMMON.INTERACT'
7237       include 'COMMON.CONTACTS'
7238       double precision gx(3),gx1(3)
7239       logical lprn
7240
7241 C Set lprn=.true. for debugging
7242       lprn=.false.
7243
7244       if (lprn) then
7245         write (iout,'(a)') 'Contact function values:'
7246         do i=nnt,nct-2
7247           write (iout,'(i2,20(1x,i2,f10.5))')
7248      &        i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
7249         enddo
7250       endif
7251       ecorr=0.0D0
7252       do i=nnt,nct
7253         do j=1,3
7254           gradcorr(j,i)=0.0D0
7255           gradxorr(j,i)=0.0D0
7256         enddo
7257       enddo
7258       do i=nnt,nct-2
7259
7260         DO ISHIFT = 3,4
7261
7262         i1=i+ishift
7263         num_conti=num_cont(i)
7264         num_conti1=num_cont(i1)
7265         do jj=1,num_conti
7266           j=jcont(jj,i)
7267           do kk=1,num_conti1
7268             j1=jcont(kk,i1)
7269             if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
7270 cd          write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
7271 cd   &                   ' ishift=',ishift
7272 C Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
7273 C The system gains extra energy.
7274               ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
7275             endif   ! j1==j+-ishift
7276           enddo     ! kk
7277         enddo       ! jj
7278
7279         ENDDO ! ISHIFT
7280
7281       enddo         ! i
7282       return
7283       end
7284 c------------------------------------------------------------------------------
7285       double precision function esccorr(i,j,k,l,jj,kk)
7286       implicit real*8 (a-h,o-z)
7287       include 'DIMENSIONS'
7288       include 'COMMON.IOUNITS'
7289       include 'COMMON.DERIV'
7290       include 'COMMON.INTERACT'
7291       include 'COMMON.CONTACTS'
7292       double precision gx(3),gx1(3)
7293       logical lprn
7294       lprn=.false.
7295       eij=facont(jj,i)
7296       ekl=facont(kk,k)
7297 cd    write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
7298 C Calculate the multi-body contribution to energy.
7299 C Calculate multi-body contributions to the gradient.
7300 cd    write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
7301 cd   & k,l,(gacont(m,kk,k),m=1,3)
7302       do m=1,3
7303         gx(m) =ekl*gacont(m,jj,i)
7304         gx1(m)=eij*gacont(m,kk,k)
7305         gradxorr(m,i)=gradxorr(m,i)-gx(m)
7306         gradxorr(m,j)=gradxorr(m,j)+gx(m)
7307         gradxorr(m,k)=gradxorr(m,k)-gx1(m)
7308         gradxorr(m,l)=gradxorr(m,l)+gx1(m)
7309       enddo
7310       do m=i,j-1
7311         do ll=1,3
7312           gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
7313         enddo
7314       enddo
7315       do m=k,l-1
7316         do ll=1,3
7317           gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
7318         enddo
7319       enddo
7320       esccorr=-eij*ekl
7321       return
7322       end
7323 c------------------------------------------------------------------------------
7324       subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
7325 C This subroutine calculates multi-body contributions to hydrogen-bonding
7326       implicit real*8 (a-h,o-z)
7327       include 'DIMENSIONS'
7328       include 'COMMON.IOUNITS'
7329 #ifdef MPI
7330       include "mpif.h"
7331       parameter (max_cont=maxconts)
7332       parameter (max_dim=26)
7333       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
7334       double precision zapas(max_dim,maxconts,max_fg_procs),
7335      &  zapas_recv(max_dim,maxconts,max_fg_procs)
7336       common /przechowalnia/ zapas
7337       integer status(MPI_STATUS_SIZE),req(maxconts*2),
7338      &  status_array(MPI_STATUS_SIZE,maxconts*2)
7339 #endif
7340       include 'COMMON.SETUP'
7341       include 'COMMON.FFIELD'
7342       include 'COMMON.DERIV'
7343       include 'COMMON.INTERACT'
7344       include 'COMMON.CONTACTS'
7345       include 'COMMON.CONTROL'
7346       include 'COMMON.LOCAL'
7347       double precision gx(3),gx1(3),time00
7348       logical lprn,ldone
7349
7350 C Set lprn=.true. for debugging
7351       lprn=.false.
7352 #ifdef MPI
7353       n_corr=0
7354       n_corr1=0
7355       if (nfgtasks.le.1) goto 30
7356       if (lprn) then
7357         write (iout,'(a)') 'Contact function values before RECEIVE:'
7358         do i=nnt,nct-2
7359           write (iout,'(2i3,50(1x,i2,f5.2))')
7360      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
7361      &    j=1,num_cont_hb(i))
7362         enddo
7363       endif
7364       call flush(iout)
7365       do i=1,ntask_cont_from
7366         ncont_recv(i)=0
7367       enddo
7368       do i=1,ntask_cont_to
7369         ncont_sent(i)=0
7370       enddo
7371 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
7372 c     & ntask_cont_to
7373 C Make the list of contacts to send to send to other procesors
7374 c      write (iout,*) "limits",max0(iturn4_end-1,iatel_s),iturn3_end
7375 c      call flush(iout)
7376       do i=iturn3_start,iturn3_end
7377 c        write (iout,*) "make contact list turn3",i," num_cont",
7378 c     &    num_cont_hb(i)
7379         call add_hb_contact(i,i+2,iturn3_sent_local(1,i))
7380       enddo
7381       do i=iturn4_start,iturn4_end
7382 c        write (iout,*) "make contact list turn4",i," num_cont",
7383 c     &   num_cont_hb(i)
7384         call add_hb_contact(i,i+3,iturn4_sent_local(1,i))
7385       enddo
7386       do ii=1,nat_sent
7387         i=iat_sent(ii)
7388 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
7389 c     &    num_cont_hb(i)
7390         do j=1,num_cont_hb(i)
7391         do k=1,4
7392           jjc=jcont_hb(j,i)
7393           iproc=iint_sent_local(k,jjc,ii)
7394 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
7395           if (iproc.gt.0) then
7396             ncont_sent(iproc)=ncont_sent(iproc)+1
7397             nn=ncont_sent(iproc)
7398             zapas(1,nn,iproc)=i
7399             zapas(2,nn,iproc)=jjc
7400             zapas(3,nn,iproc)=facont_hb(j,i)
7401             zapas(4,nn,iproc)=ees0p(j,i)
7402             zapas(5,nn,iproc)=ees0m(j,i)
7403             zapas(6,nn,iproc)=gacont_hbr(1,j,i)
7404             zapas(7,nn,iproc)=gacont_hbr(2,j,i)
7405             zapas(8,nn,iproc)=gacont_hbr(3,j,i)
7406             zapas(9,nn,iproc)=gacontm_hb1(1,j,i)
7407             zapas(10,nn,iproc)=gacontm_hb1(2,j,i)
7408             zapas(11,nn,iproc)=gacontm_hb1(3,j,i)
7409             zapas(12,nn,iproc)=gacontp_hb1(1,j,i)
7410             zapas(13,nn,iproc)=gacontp_hb1(2,j,i)
7411             zapas(14,nn,iproc)=gacontp_hb1(3,j,i)
7412             zapas(15,nn,iproc)=gacontm_hb2(1,j,i)
7413             zapas(16,nn,iproc)=gacontm_hb2(2,j,i)
7414             zapas(17,nn,iproc)=gacontm_hb2(3,j,i)
7415             zapas(18,nn,iproc)=gacontp_hb2(1,j,i)
7416             zapas(19,nn,iproc)=gacontp_hb2(2,j,i)
7417             zapas(20,nn,iproc)=gacontp_hb2(3,j,i)
7418             zapas(21,nn,iproc)=gacontm_hb3(1,j,i)
7419             zapas(22,nn,iproc)=gacontm_hb3(2,j,i)
7420             zapas(23,nn,iproc)=gacontm_hb3(3,j,i)
7421             zapas(24,nn,iproc)=gacontp_hb3(1,j,i)
7422             zapas(25,nn,iproc)=gacontp_hb3(2,j,i)
7423             zapas(26,nn,iproc)=gacontp_hb3(3,j,i)
7424           endif
7425         enddo
7426         enddo
7427       enddo
7428       if (lprn) then
7429       write (iout,*)
7430      &  "Numbers of contacts to be sent to other processors",
7431      &  (ncont_sent(i),i=1,ntask_cont_to)
7432       write (iout,*) "Contacts sent"
7433       do ii=1,ntask_cont_to
7434         nn=ncont_sent(ii)
7435         iproc=itask_cont_to(ii)
7436         write (iout,*) nn," contacts to processor",iproc,
7437      &   " of CONT_TO_COMM group"
7438         do i=1,nn
7439           write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
7440         enddo
7441       enddo
7442       call flush(iout)
7443       endif
7444       CorrelType=477
7445       CorrelID=fg_rank+1
7446       CorrelType1=478
7447       CorrelID1=nfgtasks+fg_rank+1
7448       ireq=0
7449 C Receive the numbers of needed contacts from other processors
7450       do ii=1,ntask_cont_from
7451         iproc=itask_cont_from(ii)
7452         ireq=ireq+1
7453         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
7454      &    FG_COMM,req(ireq),IERR)
7455       enddo
7456 c      write (iout,*) "IRECV ended"
7457 c      call flush(iout)
7458 C Send the number of contacts needed by other processors
7459       do ii=1,ntask_cont_to
7460         iproc=itask_cont_to(ii)
7461         ireq=ireq+1
7462         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
7463      &    FG_COMM,req(ireq),IERR)
7464       enddo
7465 c      write (iout,*) "ISEND ended"
7466 c      write (iout,*) "number of requests (nn)",ireq
7467       call flush(iout)
7468       if (ireq.gt.0)
7469      &  call MPI_Waitall(ireq,req,status_array,ierr)
7470 c      write (iout,*)
7471 c     &  "Numbers of contacts to be received from other processors",
7472 c     &  (ncont_recv(i),i=1,ntask_cont_from)
7473 c      call flush(iout)
7474 C Receive contacts
7475       ireq=0
7476       do ii=1,ntask_cont_from
7477         iproc=itask_cont_from(ii)
7478         nn=ncont_recv(ii)
7479 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
7480 c     &   " of CONT_TO_COMM group"
7481         call flush(iout)
7482         if (nn.gt.0) then
7483           ireq=ireq+1
7484           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
7485      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
7486 c          write (iout,*) "ireq,req",ireq,req(ireq)
7487         endif
7488       enddo
7489 C Send the contacts to processors that need them
7490       do ii=1,ntask_cont_to
7491         iproc=itask_cont_to(ii)
7492         nn=ncont_sent(ii)
7493 c        write (iout,*) nn," contacts to processor",iproc,
7494 c     &   " of CONT_TO_COMM group"
7495         if (nn.gt.0) then
7496           ireq=ireq+1
7497           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
7498      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
7499 c          write (iout,*) "ireq,req",ireq,req(ireq)
7500 c          do i=1,nn
7501 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
7502 c          enddo
7503         endif
7504       enddo
7505 c      write (iout,*) "number of requests (contacts)",ireq
7506 c      write (iout,*) "req",(req(i),i=1,4)
7507 c      call flush(iout)
7508       if (ireq.gt.0)
7509      & call MPI_Waitall(ireq,req,status_array,ierr)
7510       do iii=1,ntask_cont_from
7511         iproc=itask_cont_from(iii)
7512         nn=ncont_recv(iii)
7513         if (lprn) then
7514         write (iout,*) "Received",nn," contacts from processor",iproc,
7515      &   " of CONT_FROM_COMM group"
7516         call flush(iout)
7517         do i=1,nn
7518           write(iout,'(2f5.0,4f10.5)')(zapas_recv(j,i,iii),j=1,5)
7519         enddo
7520         call flush(iout)
7521         endif
7522         do i=1,nn
7523           ii=zapas_recv(1,i,iii)
7524 c Flag the received contacts to prevent double-counting
7525           jj=-zapas_recv(2,i,iii)
7526 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
7527 c          call flush(iout)
7528           nnn=num_cont_hb(ii)+1
7529           num_cont_hb(ii)=nnn
7530           jcont_hb(nnn,ii)=jj
7531           facont_hb(nnn,ii)=zapas_recv(3,i,iii)
7532           ees0p(nnn,ii)=zapas_recv(4,i,iii)
7533           ees0m(nnn,ii)=zapas_recv(5,i,iii)
7534           gacont_hbr(1,nnn,ii)=zapas_recv(6,i,iii)
7535           gacont_hbr(2,nnn,ii)=zapas_recv(7,i,iii)
7536           gacont_hbr(3,nnn,ii)=zapas_recv(8,i,iii)
7537           gacontm_hb1(1,nnn,ii)=zapas_recv(9,i,iii)
7538           gacontm_hb1(2,nnn,ii)=zapas_recv(10,i,iii)
7539           gacontm_hb1(3,nnn,ii)=zapas_recv(11,i,iii)
7540           gacontp_hb1(1,nnn,ii)=zapas_recv(12,i,iii)
7541           gacontp_hb1(2,nnn,ii)=zapas_recv(13,i,iii)
7542           gacontp_hb1(3,nnn,ii)=zapas_recv(14,i,iii)
7543           gacontm_hb2(1,nnn,ii)=zapas_recv(15,i,iii)
7544           gacontm_hb2(2,nnn,ii)=zapas_recv(16,i,iii)
7545           gacontm_hb2(3,nnn,ii)=zapas_recv(17,i,iii)
7546           gacontp_hb2(1,nnn,ii)=zapas_recv(18,i,iii)
7547           gacontp_hb2(2,nnn,ii)=zapas_recv(19,i,iii)
7548           gacontp_hb2(3,nnn,ii)=zapas_recv(20,i,iii)
7549           gacontm_hb3(1,nnn,ii)=zapas_recv(21,i,iii)
7550           gacontm_hb3(2,nnn,ii)=zapas_recv(22,i,iii)
7551           gacontm_hb3(3,nnn,ii)=zapas_recv(23,i,iii)
7552           gacontp_hb3(1,nnn,ii)=zapas_recv(24,i,iii)
7553           gacontp_hb3(2,nnn,ii)=zapas_recv(25,i,iii)
7554           gacontp_hb3(3,nnn,ii)=zapas_recv(26,i,iii)
7555         enddo
7556       enddo
7557       call flush(iout)
7558       if (lprn) then
7559         write (iout,'(a)') 'Contact function values after receive:'
7560         do i=nnt,nct-2
7561           write (iout,'(2i3,50(1x,i3,f5.2))')
7562      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
7563      &    j=1,num_cont_hb(i))
7564         enddo
7565         call flush(iout)
7566       endif
7567    30 continue
7568 #endif
7569       if (lprn) then
7570         write (iout,'(a)') 'Contact function values:'
7571         do i=nnt,nct-2
7572           write (iout,'(2i3,50(1x,i3,f5.2))')
7573      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
7574      &    j=1,num_cont_hb(i))
7575         enddo
7576       endif
7577       ecorr=0.0D0
7578 C Remove the loop below after debugging !!!
7579       do i=nnt,nct
7580         do j=1,3
7581           gradcorr(j,i)=0.0D0
7582           gradxorr(j,i)=0.0D0
7583         enddo
7584       enddo
7585 C Calculate the local-electrostatic correlation terms
7586       do i=min0(iatel_s,iturn4_start),max0(iatel_e,iturn3_end)
7587         i1=i+1
7588         num_conti=num_cont_hb(i)
7589         num_conti1=num_cont_hb(i+1)
7590         do jj=1,num_conti
7591           j=jcont_hb(jj,i)
7592           jp=iabs(j)
7593           do kk=1,num_conti1
7594             j1=jcont_hb(kk,i1)
7595             jp1=iabs(j1)
7596 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
7597 c     &         ' jj=',jj,' kk=',kk
7598             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
7599      &          .or. j.lt.0 .and. j1.gt.0) .and.
7600      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
7601 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
7602 C The system gains extra energy.
7603               ecorr=ecorr+ehbcorr(i,jp,i+1,jp1,jj,kk,0.72D0,0.32D0)
7604               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
7605      &            'ecorrh',i,j,ehbcorr(i,j,i+1,j1,jj,kk,0.72D0,0.32D0)
7606               n_corr=n_corr+1
7607             else if (j1.eq.j) then
7608 C Contacts I-J and I-(J+1) occur simultaneously.
7609 C The system loses extra energy.
7610 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
7611             endif
7612           enddo ! kk
7613           do kk=1,num_conti
7614             j1=jcont_hb(kk,i)
7615 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
7616 c    &         ' jj=',jj,' kk=',kk
7617             if (j1.eq.j+1) then
7618 C Contacts I-J and (I+1)-J occur simultaneously.
7619 C The system loses extra energy.
7620 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
7621             endif ! j1==j+1
7622           enddo ! kk
7623         enddo ! jj
7624       enddo ! i
7625       return
7626       end
7627 c------------------------------------------------------------------------------
7628       subroutine add_hb_contact(ii,jj,itask)
7629       implicit real*8 (a-h,o-z)
7630       include "DIMENSIONS"
7631       include "COMMON.IOUNITS"
7632       integer max_cont
7633       integer max_dim
7634       parameter (max_cont=maxconts)
7635       parameter (max_dim=26)
7636       include "COMMON.CONTACTS"
7637       double precision zapas(max_dim,maxconts,max_fg_procs),
7638      &  zapas_recv(max_dim,maxconts,max_fg_procs)
7639       common /przechowalnia/ zapas
7640       integer i,j,ii,jj,iproc,itask(4),nn
7641 c      write (iout,*) "itask",itask
7642       do i=1,2
7643         iproc=itask(i)
7644         if (iproc.gt.0) then
7645           do j=1,num_cont_hb(ii)
7646             jjc=jcont_hb(j,ii)
7647 c            write (iout,*) "i",ii," j",jj," jjc",jjc
7648             if (jjc.eq.jj) then
7649               ncont_sent(iproc)=ncont_sent(iproc)+1
7650               nn=ncont_sent(iproc)
7651               zapas(1,nn,iproc)=ii
7652               zapas(2,nn,iproc)=jjc
7653               zapas(3,nn,iproc)=facont_hb(j,ii)
7654               zapas(4,nn,iproc)=ees0p(j,ii)
7655               zapas(5,nn,iproc)=ees0m(j,ii)
7656               zapas(6,nn,iproc)=gacont_hbr(1,j,ii)
7657               zapas(7,nn,iproc)=gacont_hbr(2,j,ii)
7658               zapas(8,nn,iproc)=gacont_hbr(3,j,ii)
7659               zapas(9,nn,iproc)=gacontm_hb1(1,j,ii)
7660               zapas(10,nn,iproc)=gacontm_hb1(2,j,ii)
7661               zapas(11,nn,iproc)=gacontm_hb1(3,j,ii)
7662               zapas(12,nn,iproc)=gacontp_hb1(1,j,ii)
7663               zapas(13,nn,iproc)=gacontp_hb1(2,j,ii)
7664               zapas(14,nn,iproc)=gacontp_hb1(3,j,ii)
7665               zapas(15,nn,iproc)=gacontm_hb2(1,j,ii)
7666               zapas(16,nn,iproc)=gacontm_hb2(2,j,ii)
7667               zapas(17,nn,iproc)=gacontm_hb2(3,j,ii)
7668               zapas(18,nn,iproc)=gacontp_hb2(1,j,ii)
7669               zapas(19,nn,iproc)=gacontp_hb2(2,j,ii)
7670               zapas(20,nn,iproc)=gacontp_hb2(3,j,ii)
7671               zapas(21,nn,iproc)=gacontm_hb3(1,j,ii)
7672               zapas(22,nn,iproc)=gacontm_hb3(2,j,ii)
7673               zapas(23,nn,iproc)=gacontm_hb3(3,j,ii)
7674               zapas(24,nn,iproc)=gacontp_hb3(1,j,ii)
7675               zapas(25,nn,iproc)=gacontp_hb3(2,j,ii)
7676               zapas(26,nn,iproc)=gacontp_hb3(3,j,ii)
7677               exit
7678             endif
7679           enddo
7680         endif
7681       enddo
7682       return
7683       end
7684 c------------------------------------------------------------------------------
7685       subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,
7686      &  n_corr1)
7687 C This subroutine calculates multi-body contributions to hydrogen-bonding
7688       implicit real*8 (a-h,o-z)
7689       include 'DIMENSIONS'
7690       include 'COMMON.IOUNITS'
7691 #ifdef MPI
7692       include "mpif.h"
7693       parameter (max_cont=maxconts)
7694       parameter (max_dim=70)
7695       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
7696       double precision zapas(max_dim,maxconts,max_fg_procs),
7697      &  zapas_recv(max_dim,maxconts,max_fg_procs)
7698       common /przechowalnia/ zapas
7699       integer status(MPI_STATUS_SIZE),req(maxconts*2),
7700      &  status_array(MPI_STATUS_SIZE,maxconts*2)
7701 #endif
7702       include 'COMMON.SETUP'
7703       include 'COMMON.FFIELD'
7704       include 'COMMON.DERIV'
7705       include 'COMMON.LOCAL'
7706       include 'COMMON.INTERACT'
7707       include 'COMMON.CONTACTS'
7708       include 'COMMON.CHAIN'
7709       include 'COMMON.CONTROL'
7710       double precision gx(3),gx1(3)
7711       integer num_cont_hb_old(maxres)
7712       logical lprn,ldone
7713       double precision eello4,eello5,eelo6,eello_turn6
7714       external eello4,eello5,eello6,eello_turn6
7715 C Set lprn=.true. for debugging
7716       lprn=.false.
7717       eturn6=0.0d0
7718 #ifdef MPI
7719       do i=1,nres
7720         num_cont_hb_old(i)=num_cont_hb(i)
7721       enddo
7722       n_corr=0
7723       n_corr1=0
7724       if (nfgtasks.le.1) goto 30
7725       if (lprn) then
7726         write (iout,'(a)') 'Contact function values before RECEIVE:'
7727         do i=nnt,nct-2
7728           write (iout,'(2i3,50(1x,i2,f5.2))')
7729      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
7730      &    j=1,num_cont_hb(i))
7731         enddo
7732       endif
7733       call flush(iout)
7734       do i=1,ntask_cont_from
7735         ncont_recv(i)=0
7736       enddo
7737       do i=1,ntask_cont_to
7738         ncont_sent(i)=0
7739       enddo
7740 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
7741 c     & ntask_cont_to
7742 C Make the list of contacts to send to send to other procesors
7743       do i=iturn3_start,iturn3_end
7744 c        write (iout,*) "make contact list turn3",i," num_cont",
7745 c     &    num_cont_hb(i)
7746         call add_hb_contact_eello(i,i+2,iturn3_sent_local(1,i))
7747       enddo
7748       do i=iturn4_start,iturn4_end
7749 c        write (iout,*) "make contact list turn4",i," num_cont",
7750 c     &   num_cont_hb(i)
7751         call add_hb_contact_eello(i,i+3,iturn4_sent_local(1,i))
7752       enddo
7753       do ii=1,nat_sent
7754         i=iat_sent(ii)
7755 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
7756 c     &    num_cont_hb(i)
7757         do j=1,num_cont_hb(i)
7758         do k=1,4
7759           jjc=jcont_hb(j,i)
7760           iproc=iint_sent_local(k,jjc,ii)
7761 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
7762           if (iproc.ne.0) then
7763             ncont_sent(iproc)=ncont_sent(iproc)+1
7764             nn=ncont_sent(iproc)
7765             zapas(1,nn,iproc)=i
7766             zapas(2,nn,iproc)=jjc
7767             zapas(3,nn,iproc)=d_cont(j,i)
7768             ind=3
7769             do kk=1,3
7770               ind=ind+1
7771               zapas(ind,nn,iproc)=grij_hb_cont(kk,j,i)
7772             enddo
7773             do kk=1,2
7774               do ll=1,2
7775                 ind=ind+1
7776                 zapas(ind,nn,iproc)=a_chuj(ll,kk,j,i)
7777               enddo
7778             enddo
7779             do jj=1,5
7780               do kk=1,3
7781                 do ll=1,2
7782                   do mm=1,2
7783                     ind=ind+1
7784                     zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,i)
7785                   enddo
7786                 enddo
7787               enddo
7788             enddo
7789           endif
7790         enddo
7791         enddo
7792       enddo
7793       if (lprn) then
7794       write (iout,*)
7795      &  "Numbers of contacts to be sent to other processors",
7796      &  (ncont_sent(i),i=1,ntask_cont_to)
7797       write (iout,*) "Contacts sent"
7798       do ii=1,ntask_cont_to
7799         nn=ncont_sent(ii)
7800         iproc=itask_cont_to(ii)
7801         write (iout,*) nn," contacts to processor",iproc,
7802      &   " of CONT_TO_COMM group"
7803         do i=1,nn
7804           write(iout,'(2f5.0,10f10.5)')(zapas(j,i,ii),j=1,10)
7805         enddo
7806       enddo
7807       call flush(iout)
7808       endif
7809       CorrelType=477
7810       CorrelID=fg_rank+1
7811       CorrelType1=478
7812       CorrelID1=nfgtasks+fg_rank+1
7813       ireq=0
7814 C Receive the numbers of needed contacts from other processors
7815       do ii=1,ntask_cont_from
7816         iproc=itask_cont_from(ii)
7817         ireq=ireq+1
7818         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
7819      &    FG_COMM,req(ireq),IERR)
7820       enddo
7821 c      write (iout,*) "IRECV ended"
7822 c      call flush(iout)
7823 C Send the number of contacts needed by other processors
7824       do ii=1,ntask_cont_to
7825         iproc=itask_cont_to(ii)
7826         ireq=ireq+1
7827         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
7828      &    FG_COMM,req(ireq),IERR)
7829       enddo
7830 c      write (iout,*) "ISEND ended"
7831 c      write (iout,*) "number of requests (nn)",ireq
7832       call flush(iout)
7833       if (ireq.gt.0)
7834      &  call MPI_Waitall(ireq,req,status_array,ierr)
7835 c      write (iout,*)
7836 c     &  "Numbers of contacts to be received from other processors",
7837 c     &  (ncont_recv(i),i=1,ntask_cont_from)
7838 c      call flush(iout)
7839 C Receive contacts
7840       ireq=0
7841       do ii=1,ntask_cont_from
7842         iproc=itask_cont_from(ii)
7843         nn=ncont_recv(ii)
7844 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
7845 c     &   " of CONT_TO_COMM group"
7846         call flush(iout)
7847         if (nn.gt.0) then
7848           ireq=ireq+1
7849           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
7850      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
7851 c          write (iout,*) "ireq,req",ireq,req(ireq)
7852         endif
7853       enddo
7854 C Send the contacts to processors that need them
7855       do ii=1,ntask_cont_to
7856         iproc=itask_cont_to(ii)
7857         nn=ncont_sent(ii)
7858 c        write (iout,*) nn," contacts to processor",iproc,
7859 c     &   " of CONT_TO_COMM group"
7860         if (nn.gt.0) then
7861           ireq=ireq+1
7862           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
7863      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
7864 c          write (iout,*) "ireq,req",ireq,req(ireq)
7865 c          do i=1,nn
7866 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
7867 c          enddo
7868         endif
7869       enddo
7870 c      write (iout,*) "number of requests (contacts)",ireq
7871 c      write (iout,*) "req",(req(i),i=1,4)
7872 c      call flush(iout)
7873       if (ireq.gt.0)
7874      & call MPI_Waitall(ireq,req,status_array,ierr)
7875       do iii=1,ntask_cont_from
7876         iproc=itask_cont_from(iii)
7877         nn=ncont_recv(iii)
7878         if (lprn) then
7879         write (iout,*) "Received",nn," contacts from processor",iproc,
7880      &   " of CONT_FROM_COMM group"
7881         call flush(iout)
7882         do i=1,nn
7883           write(iout,'(2f5.0,10f10.5)')(zapas_recv(j,i,iii),j=1,10)
7884         enddo
7885         call flush(iout)
7886         endif
7887         do i=1,nn
7888           ii=zapas_recv(1,i,iii)
7889 c Flag the received contacts to prevent double-counting
7890           jj=-zapas_recv(2,i,iii)
7891 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
7892 c          call flush(iout)
7893           nnn=num_cont_hb(ii)+1
7894           num_cont_hb(ii)=nnn
7895           jcont_hb(nnn,ii)=jj
7896           d_cont(nnn,ii)=zapas_recv(3,i,iii)
7897           ind=3
7898           do kk=1,3
7899             ind=ind+1
7900             grij_hb_cont(kk,nnn,ii)=zapas_recv(ind,i,iii)
7901           enddo
7902           do kk=1,2
7903             do ll=1,2
7904               ind=ind+1
7905               a_chuj(ll,kk,nnn,ii)=zapas_recv(ind,i,iii)
7906             enddo
7907           enddo
7908           do jj=1,5
7909             do kk=1,3
7910               do ll=1,2
7911                 do mm=1,2
7912                   ind=ind+1
7913                   a_chuj_der(mm,ll,kk,jj,nnn,ii)=zapas_recv(ind,i,iii)
7914                 enddo
7915               enddo
7916             enddo
7917           enddo
7918         enddo
7919       enddo
7920       call flush(iout)
7921       if (lprn) then
7922         write (iout,'(a)') 'Contact function values after receive:'
7923         do i=nnt,nct-2
7924           write (iout,'(2i3,50(1x,i3,5f6.3))')
7925      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
7926      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
7927         enddo
7928         call flush(iout)
7929       endif
7930    30 continue
7931 #endif
7932       if (lprn) then
7933         write (iout,'(a)') 'Contact function values:'
7934         do i=nnt,nct-2
7935           write (iout,'(2i3,50(1x,i2,5f6.3))')
7936      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
7937      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
7938         enddo
7939       endif
7940       ecorr=0.0D0
7941       ecorr5=0.0d0
7942       ecorr6=0.0d0
7943 C Remove the loop below after debugging !!!
7944       do i=nnt,nct
7945         do j=1,3
7946           gradcorr(j,i)=0.0D0
7947           gradxorr(j,i)=0.0D0
7948         enddo
7949       enddo
7950 C Calculate the dipole-dipole interaction energies
7951       if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
7952       do i=iatel_s,iatel_e+1
7953         num_conti=num_cont_hb(i)
7954         do jj=1,num_conti
7955           j=jcont_hb(jj,i)
7956 #ifdef MOMENT
7957           call dipole(i,j,jj)
7958 #endif
7959         enddo
7960       enddo
7961       endif
7962 C Calculate the local-electrostatic correlation terms
7963 c                write (iout,*) "gradcorr5 in eello5 before loop"
7964 c                do iii=1,nres
7965 c                  write (iout,'(i5,3f10.5)')
7966 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
7967 c                enddo
7968       do i=min0(iatel_s,iturn4_start),max0(iatel_e+1,iturn3_end+1)
7969 c        write (iout,*) "corr loop i",i
7970         i1=i+1
7971         num_conti=num_cont_hb(i)
7972         num_conti1=num_cont_hb(i+1)
7973         do jj=1,num_conti
7974           j=jcont_hb(jj,i)
7975           jp=iabs(j)
7976           do kk=1,num_conti1
7977             j1=jcont_hb(kk,i1)
7978             jp1=iabs(j1)
7979 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
7980 c     &         ' jj=',jj,' kk=',kk
7981 c            if (j1.eq.j+1 .or. j1.eq.j-1) then
7982             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
7983      &          .or. j.lt.0 .and. j1.gt.0) .and.
7984      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
7985 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
7986 C The system gains extra energy.
7987               n_corr=n_corr+1
7988               sqd1=dsqrt(d_cont(jj,i))
7989               sqd2=dsqrt(d_cont(kk,i1))
7990               sred_geom = sqd1*sqd2
7991               IF (sred_geom.lt.cutoff_corr) THEN
7992                 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,
7993      &            ekont,fprimcont)
7994 cd               write (iout,*) 'i=',i,' j=',jp,' i1=',i1,' j1=',jp1,
7995 cd     &         ' jj=',jj,' kk=',kk
7996                 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
7997                 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
7998                 do l=1,3
7999                   g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
8000                   g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
8001                 enddo
8002                 n_corr1=n_corr1+1
8003 cd               write (iout,*) 'sred_geom=',sred_geom,
8004 cd     &          ' ekont=',ekont,' fprim=',fprimcont,
8005 cd     &          ' fac_prim1',fac_prim1,' fac_prim2',fac_prim2
8006 cd               write (iout,*) "g_contij",g_contij
8007 cd               write (iout,*) "grij_hb_cont i",grij_hb_cont(:,jj,i)
8008 cd               write (iout,*) "grij_hb_cont i1",grij_hb_cont(:,jj,i1)
8009                 call calc_eello(i,jp,i+1,jp1,jj,kk)
8010                 if (wcorr4.gt.0.0d0)
8011      &            ecorr=ecorr+eello4(i,jp,i+1,jp1,jj,kk)
8012                   if (energy_dec.and.wcorr4.gt.0.0d0)
8013      1                 write (iout,'(a6,4i5,0pf7.3)')
8014      2                'ecorr4',i,j,i+1,j1,eello4(i,jp,i+1,jp1,jj,kk)
8015 c                write (iout,*) "gradcorr5 before eello5"
8016 c                do iii=1,nres
8017 c                  write (iout,'(i5,3f10.5)')
8018 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
8019 c                enddo
8020                 if (wcorr5.gt.0.0d0)
8021      &            ecorr5=ecorr5+eello5(i,jp,i+1,jp1,jj,kk)
8022 c                write (iout,*) "gradcorr5 after eello5"
8023 c                do iii=1,nres
8024 c                  write (iout,'(i5,3f10.5)')
8025 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
8026 c                enddo
8027                   if (energy_dec.and.wcorr5.gt.0.0d0)
8028      1                 write (iout,'(a6,4i5,0pf7.3)')
8029      2                'ecorr5',i,j,i+1,j1,eello5(i,jp,i+1,jp1,jj,kk)
8030 cd                write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
8031 cd                write(2,*)'ijkl',i,jp,i+1,jp1
8032                 if (wcorr6.gt.0.0d0 .and. (jp.ne.i+4 .or. jp1.ne.i+3
8033      &               .or. wturn6.eq.0.0d0))then
8034 cd                  write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
8035                   ecorr6=ecorr6+eello6(i,jp,i+1,jp1,jj,kk)
8036                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
8037      1                'ecorr6',i,j,i+1,j1,eello6(i,jp,i+1,jp1,jj,kk)
8038 cd                write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
8039 cd     &            'ecorr6=',ecorr6
8040 cd                write (iout,'(4e15.5)') sred_geom,
8041 cd     &          dabs(eello4(i,jp,i+1,jp1,jj,kk)),
8042 cd     &          dabs(eello5(i,jp,i+1,jp1,jj,kk)),
8043 cd     &          dabs(eello6(i,jp,i+1,jp1,jj,kk))
8044                 else if (wturn6.gt.0.0d0
8045      &            .and. (jp.eq.i+4 .and. jp1.eq.i+3)) then
8046 cd                  write (iout,*) '******eturn6: i,j,i+1,j1',i,jip,i+1,jp1
8047                   eturn6=eturn6+eello_turn6(i,jj,kk)
8048                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
8049      1                 'eturn6',i,j,i+1,j1,eello_turn6(i,jj,kk)
8050 cd                  write (2,*) 'multibody_eello:eturn6',eturn6
8051                 endif
8052               ENDIF
8053 1111          continue
8054             endif
8055           enddo ! kk
8056         enddo ! jj
8057       enddo ! i
8058       do i=1,nres
8059         num_cont_hb(i)=num_cont_hb_old(i)
8060       enddo
8061 c                write (iout,*) "gradcorr5 in eello5"
8062 c                do iii=1,nres
8063 c                  write (iout,'(i5,3f10.5)')
8064 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
8065 c                enddo
8066       return
8067       end
8068 c------------------------------------------------------------------------------
8069       subroutine add_hb_contact_eello(ii,jj,itask)
8070       implicit real*8 (a-h,o-z)
8071       include "DIMENSIONS"
8072       include "COMMON.IOUNITS"
8073       integer max_cont
8074       integer max_dim
8075       parameter (max_cont=maxconts)
8076       parameter (max_dim=70)
8077       include "COMMON.CONTACTS"
8078       double precision zapas(max_dim,maxconts,max_fg_procs),
8079      &  zapas_recv(max_dim,maxconts,max_fg_procs)
8080       common /przechowalnia/ zapas
8081       integer i,j,ii,jj,iproc,itask(4),nn
8082 c      write (iout,*) "itask",itask
8083       do i=1,2
8084         iproc=itask(i)
8085         if (iproc.gt.0) then
8086           do j=1,num_cont_hb(ii)
8087             jjc=jcont_hb(j,ii)
8088 c            write (iout,*) "send turns i",ii," j",jj," jjc",jjc
8089             if (jjc.eq.jj) then
8090               ncont_sent(iproc)=ncont_sent(iproc)+1
8091               nn=ncont_sent(iproc)
8092               zapas(1,nn,iproc)=ii
8093               zapas(2,nn,iproc)=jjc
8094               zapas(3,nn,iproc)=d_cont(j,ii)
8095               ind=3
8096               do kk=1,3
8097                 ind=ind+1
8098                 zapas(ind,nn,iproc)=grij_hb_cont(kk,j,ii)
8099               enddo
8100               do kk=1,2
8101                 do ll=1,2
8102                   ind=ind+1
8103                   zapas(ind,nn,iproc)=a_chuj(ll,kk,j,ii)
8104                 enddo
8105               enddo
8106               do jj=1,5
8107                 do kk=1,3
8108                   do ll=1,2
8109                     do mm=1,2
8110                       ind=ind+1
8111                       zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,ii)
8112                     enddo
8113                   enddo
8114                 enddo
8115               enddo
8116               exit
8117             endif
8118           enddo
8119         endif
8120       enddo
8121       return
8122       end
8123 c------------------------------------------------------------------------------
8124       double precision function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
8125       implicit real*8 (a-h,o-z)
8126       include 'DIMENSIONS'
8127       include 'COMMON.IOUNITS'
8128       include 'COMMON.DERIV'
8129       include 'COMMON.INTERACT'
8130       include 'COMMON.CONTACTS'
8131       double precision gx(3),gx1(3)
8132       logical lprn
8133       lprn=.false.
8134       eij=facont_hb(jj,i)
8135       ekl=facont_hb(kk,k)
8136       ees0pij=ees0p(jj,i)
8137       ees0pkl=ees0p(kk,k)
8138       ees0mij=ees0m(jj,i)
8139       ees0mkl=ees0m(kk,k)
8140       ekont=eij*ekl
8141       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
8142 cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
8143 C Following 4 lines for diagnostics.
8144 cd    ees0pkl=0.0D0
8145 cd    ees0pij=1.0D0
8146 cd    ees0mkl=0.0D0
8147 cd    ees0mij=1.0D0
8148 c      write (iout,'(2(a,2i3,a,f10.5,a,2f10.5),a,f10.5,a,$)')
8149 c     & 'Contacts ',i,j,
8150 c     & ' eij',eij,' eesij',ees0pij,ees0mij,' and ',k,l
8151 c     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' energy=',ekont*ees,
8152 c     & 'gradcorr_long'
8153 C Calculate the multi-body contribution to energy.
8154 c      ecorr=ecorr+ekont*ees
8155 C Calculate multi-body contributions to the gradient.
8156       coeffpees0pij=coeffp*ees0pij
8157       coeffmees0mij=coeffm*ees0mij
8158       coeffpees0pkl=coeffp*ees0pkl
8159       coeffmees0mkl=coeffm*ees0mkl
8160       do ll=1,3
8161 cgrad        ghalfi=ees*ekl*gacont_hbr(ll,jj,i)
8162         gradcorr(ll,i)=gradcorr(ll,i)!+0.5d0*ghalfi
8163      &  -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+
8164      &  coeffmees0mkl*gacontm_hb1(ll,jj,i))
8165         gradcorr(ll,j)=gradcorr(ll,j)!+0.5d0*ghalfi
8166      &  -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+
8167      &  coeffmees0mkl*gacontm_hb2(ll,jj,i))
8168 cgrad        ghalfk=ees*eij*gacont_hbr(ll,kk,k)
8169         gradcorr(ll,k)=gradcorr(ll,k)!+0.5d0*ghalfk
8170      &  -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+
8171      &  coeffmees0mij*gacontm_hb1(ll,kk,k))
8172         gradcorr(ll,l)=gradcorr(ll,l)!+0.5d0*ghalfk
8173      &  -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+
8174      &  coeffmees0mij*gacontm_hb2(ll,kk,k))
8175         gradlongij=ees*ekl*gacont_hbr(ll,jj,i)-
8176      &     ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+
8177      &     coeffmees0mkl*gacontm_hb3(ll,jj,i))
8178         gradcorr_long(ll,j)=gradcorr_long(ll,j)+gradlongij
8179         gradcorr_long(ll,i)=gradcorr_long(ll,i)-gradlongij
8180         gradlongkl=ees*eij*gacont_hbr(ll,kk,k)-
8181      &     ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+
8182      &     coeffmees0mij*gacontm_hb3(ll,kk,k))
8183         gradcorr_long(ll,l)=gradcorr_long(ll,l)+gradlongkl
8184         gradcorr_long(ll,k)=gradcorr_long(ll,k)-gradlongkl
8185 c        write (iout,'(2f10.5,2x,$)') gradlongij,gradlongkl
8186       enddo
8187 c      write (iout,*)
8188 cgrad      do m=i+1,j-1
8189 cgrad        do ll=1,3
8190 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
8191 cgrad     &     ees*ekl*gacont_hbr(ll,jj,i)-
8192 cgrad     &     ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
8193 cgrad     &     coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
8194 cgrad        enddo
8195 cgrad      enddo
8196 cgrad      do m=k+1,l-1
8197 cgrad        do ll=1,3
8198 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
8199 cgrad     &     ees*eij*gacont_hbr(ll,kk,k)-
8200 cgrad     &     ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
8201 cgrad     &     coeffm*ees0mij*gacontm_hb3(ll,kk,k))
8202 cgrad        enddo
8203 cgrad      enddo
8204 c      write (iout,*) "ehbcorr",ekont*ees
8205       ehbcorr=ekont*ees
8206       return
8207       end
8208 #ifdef MOMENT
8209 C---------------------------------------------------------------------------
8210       subroutine dipole(i,j,jj)
8211       implicit real*8 (a-h,o-z)
8212       include 'DIMENSIONS'
8213       include 'COMMON.IOUNITS'
8214       include 'COMMON.CHAIN'
8215       include 'COMMON.FFIELD'
8216       include 'COMMON.DERIV'
8217       include 'COMMON.INTERACT'
8218       include 'COMMON.CONTACTS'
8219       include 'COMMON.TORSION'
8220       include 'COMMON.VAR'
8221       include 'COMMON.GEO'
8222       dimension dipi(2,2),dipj(2,2),dipderi(2),dipderj(2),auxvec(2),
8223      &  auxmat(2,2)
8224       iti1 = itortyp(itype(i+1))
8225       if (j.lt.nres-1) then
8226         itj1 = itortyp(itype(j+1))
8227       else
8228         itj1=ntortyp
8229       endif
8230       do iii=1,2
8231         dipi(iii,1)=Ub2(iii,i)
8232         dipderi(iii)=Ub2der(iii,i)
8233         dipi(iii,2)=b1(iii,i+1)
8234         dipj(iii,1)=Ub2(iii,j)
8235         dipderj(iii)=Ub2der(iii,j)
8236         dipj(iii,2)=b1(iii,j+1)
8237       enddo
8238       kkk=0
8239       do iii=1,2
8240         call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
8241         do jjj=1,2
8242           kkk=kkk+1
8243           dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
8244         enddo
8245       enddo
8246       do kkk=1,5
8247         do lll=1,3
8248           mmm=0
8249           do iii=1,2
8250             call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),
8251      &        auxvec(1))
8252             do jjj=1,2
8253               mmm=mmm+1
8254               dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
8255             enddo
8256           enddo
8257         enddo
8258       enddo
8259       call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
8260       call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
8261       do iii=1,2
8262         dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
8263       enddo
8264       call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
8265       do iii=1,2
8266         dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
8267       enddo
8268       return
8269       end
8270 #endif
8271 C---------------------------------------------------------------------------
8272       subroutine calc_eello(i,j,k,l,jj,kk)
8273 C
8274 C This subroutine computes matrices and vectors needed to calculate
8275 C the fourth-, fifth-, and sixth-order local-electrostatic terms.
8276 C
8277       implicit real*8 (a-h,o-z)
8278       include 'DIMENSIONS'
8279       include 'COMMON.IOUNITS'
8280       include 'COMMON.CHAIN'
8281       include 'COMMON.DERIV'
8282       include 'COMMON.INTERACT'
8283       include 'COMMON.CONTACTS'
8284       include 'COMMON.TORSION'
8285       include 'COMMON.VAR'
8286       include 'COMMON.GEO'
8287       include 'COMMON.FFIELD'
8288       double precision aa1(2,2),aa2(2,2),aa1t(2,2),aa2t(2,2),
8289      &  aa1tder(2,2,3,5),aa2tder(2,2,3,5),auxmat(2,2)
8290       logical lprn
8291       common /kutas/ lprn
8292 cd      write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
8293 cd     & ' jj=',jj,' kk=',kk
8294 cd      if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
8295 cd      write (iout,*) "a_chujij",((a_chuj(iii,jjj,jj,i),iii=1,2),jjj=1,2)
8296 cd      write (iout,*) "a_chujkl",((a_chuj(iii,jjj,kk,k),iii=1,2),jjj=1,2)
8297       do iii=1,2
8298         do jjj=1,2
8299           aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
8300           aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
8301         enddo
8302       enddo
8303       call transpose2(aa1(1,1),aa1t(1,1))
8304       call transpose2(aa2(1,1),aa2t(1,1))
8305       do kkk=1,5
8306         do lll=1,3
8307           call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),
8308      &      aa1tder(1,1,lll,kkk))
8309           call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),
8310      &      aa2tder(1,1,lll,kkk))
8311         enddo
8312       enddo
8313       if (l.eq.j+1) then
8314 C parallel orientation of the two CA-CA-CA frames.
8315         if (i.gt.1) then
8316           iti=itortyp(itype(i))
8317         else
8318           iti=ntortyp
8319         endif
8320         itk1=itortyp(itype(k+1))
8321         itj=itortyp(itype(j))
8322         if (l.lt.nres-1) then
8323           itl1=itortyp(itype(l+1))
8324         else
8325           itl1=ntortyp
8326         endif
8327 C A1 kernel(j+1) A2T
8328 cd        do iii=1,2
8329 cd          write (iout,'(3f10.5,5x,3f10.5)')
8330 cd     &     (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
8331 cd        enddo
8332         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
8333      &   aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),
8334      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
8335 C Following matrices are needed only for 6-th order cumulants
8336         IF (wcorr6.gt.0.0d0) THEN
8337         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
8338      &   aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),
8339      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
8340         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
8341      &   aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),
8342      &   Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
8343      &   ADtEAderx(1,1,1,1,1,1))
8344         lprn=.false.
8345         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
8346      &   aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),
8347      &   DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
8348      &   ADtEA1derx(1,1,1,1,1,1))
8349         ENDIF
8350 C End 6-th order cumulants
8351 cd        lprn=.false.
8352 cd        if (lprn) then
8353 cd        write (2,*) 'In calc_eello6'
8354 cd        do iii=1,2
8355 cd          write (2,*) 'iii=',iii
8356 cd          do kkk=1,5
8357 cd            write (2,*) 'kkk=',kkk
8358 cd            do jjj=1,2
8359 cd              write (2,'(3(2f10.5),5x)')
8360 cd     &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
8361 cd            enddo
8362 cd          enddo
8363 cd        enddo
8364 cd        endif
8365         call transpose2(EUgder(1,1,k),auxmat(1,1))
8366         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
8367         call transpose2(EUg(1,1,k),auxmat(1,1))
8368         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
8369         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
8370         do iii=1,2
8371           do kkk=1,5
8372             do lll=1,3
8373               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
8374      &          EAEAderx(1,1,lll,kkk,iii,1))
8375             enddo
8376           enddo
8377         enddo
8378 C A1T kernel(i+1) A2
8379         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
8380      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),
8381      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
8382 C Following matrices are needed only for 6-th order cumulants
8383         IF (wcorr6.gt.0.0d0) THEN
8384         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
8385      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),
8386      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
8387         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
8388      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),
8389      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
8390      &   ADtEAderx(1,1,1,1,1,2))
8391         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
8392      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),
8393      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
8394      &   ADtEA1derx(1,1,1,1,1,2))
8395         ENDIF
8396 C End 6-th order cumulants
8397         call transpose2(EUgder(1,1,l),auxmat(1,1))
8398         call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
8399         call transpose2(EUg(1,1,l),auxmat(1,1))
8400         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
8401         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
8402         do iii=1,2
8403           do kkk=1,5
8404             do lll=1,3
8405               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
8406      &          EAEAderx(1,1,lll,kkk,iii,2))
8407             enddo
8408           enddo
8409         enddo
8410 C AEAb1 and AEAb2
8411 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
8412 C They are needed only when the fifth- or the sixth-order cumulants are
8413 C indluded.
8414         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
8415         call transpose2(AEA(1,1,1),auxmat(1,1))
8416         call matvec2(auxmat(1,1),b1(1,i),AEAb1(1,1,1))
8417         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
8418         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
8419         call transpose2(AEAderg(1,1,1),auxmat(1,1))
8420         call matvec2(auxmat(1,1),b1(1,i),AEAb1derg(1,1,1))
8421         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
8422         call matvec2(AEA(1,1,1),b1(1,k+1),AEAb1(1,2,1))
8423         call matvec2(AEAderg(1,1,1),b1(1,k+1),AEAb1derg(1,2,1))
8424         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
8425         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
8426         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
8427         call transpose2(AEA(1,1,2),auxmat(1,1))
8428         call matvec2(auxmat(1,1),b1(1,j),AEAb1(1,1,2))
8429         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
8430         call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
8431         call transpose2(AEAderg(1,1,2),auxmat(1,1))
8432         call matvec2(auxmat(1,1),b1(1,j),AEAb1derg(1,1,2))
8433         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
8434         call matvec2(AEA(1,1,2),b1(1,l+1),AEAb1(1,2,2))
8435         call matvec2(AEAderg(1,1,2),b1(1,l+1),AEAb1derg(1,2,2))
8436         call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
8437         call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
8438         call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
8439 C Calculate the Cartesian derivatives of the vectors.
8440         do iii=1,2
8441           do kkk=1,5
8442             do lll=1,3
8443               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
8444               call matvec2(auxmat(1,1),b1(1,i),
8445      &          AEAb1derx(1,lll,kkk,iii,1,1))
8446               call matvec2(auxmat(1,1),Ub2(1,i),
8447      &          AEAb2derx(1,lll,kkk,iii,1,1))
8448               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
8449      &          AEAb1derx(1,lll,kkk,iii,2,1))
8450               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
8451      &          AEAb2derx(1,lll,kkk,iii,2,1))
8452               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
8453               call matvec2(auxmat(1,1),b1(1,j),
8454      &          AEAb1derx(1,lll,kkk,iii,1,2))
8455               call matvec2(auxmat(1,1),Ub2(1,j),
8456      &          AEAb2derx(1,lll,kkk,iii,1,2))
8457               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,l+1),
8458      &          AEAb1derx(1,lll,kkk,iii,2,2))
8459               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),
8460      &          AEAb2derx(1,lll,kkk,iii,2,2))
8461             enddo
8462           enddo
8463         enddo
8464         ENDIF
8465 C End vectors
8466       else
8467 C Antiparallel orientation of the two CA-CA-CA frames.
8468         if (i.gt.1) then
8469           iti=itortyp(itype(i))
8470         else
8471           iti=ntortyp
8472         endif
8473         itk1=itortyp(itype(k+1))
8474         itl=itortyp(itype(l))
8475         itj=itortyp(itype(j))
8476         if (j.lt.nres-1) then
8477           itj1=itortyp(itype(j+1))
8478         else
8479           itj1=ntortyp
8480         endif
8481 C A2 kernel(j-1)T A1T
8482         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
8483      &   aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),
8484      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
8485 C Following matrices are needed only for 6-th order cumulants
8486         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
8487      &     j.eq.i+4 .and. l.eq.i+3)) THEN
8488         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
8489      &   aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),
8490      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
8491         call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
8492      &   aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),
8493      &   Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
8494      &   ADtEAderx(1,1,1,1,1,1))
8495         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
8496      &   aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),
8497      &   DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
8498      &   ADtEA1derx(1,1,1,1,1,1))
8499         ENDIF
8500 C End 6-th order cumulants
8501         call transpose2(EUgder(1,1,k),auxmat(1,1))
8502         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
8503         call transpose2(EUg(1,1,k),auxmat(1,1))
8504         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
8505         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
8506         do iii=1,2
8507           do kkk=1,5
8508             do lll=1,3
8509               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
8510      &          EAEAderx(1,1,lll,kkk,iii,1))
8511             enddo
8512           enddo
8513         enddo
8514 C A2T kernel(i+1)T A1
8515         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
8516      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),
8517      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
8518 C Following matrices are needed only for 6-th order cumulants
8519         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
8520      &     j.eq.i+4 .and. l.eq.i+3)) THEN
8521         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
8522      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),
8523      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
8524         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
8525      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),
8526      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
8527      &   ADtEAderx(1,1,1,1,1,2))
8528         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
8529      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),
8530      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
8531      &   ADtEA1derx(1,1,1,1,1,2))
8532         ENDIF
8533 C End 6-th order cumulants
8534         call transpose2(EUgder(1,1,j),auxmat(1,1))
8535         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
8536         call transpose2(EUg(1,1,j),auxmat(1,1))
8537         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
8538         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
8539         do iii=1,2
8540           do kkk=1,5
8541             do lll=1,3
8542               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
8543      &          EAEAderx(1,1,lll,kkk,iii,2))
8544             enddo
8545           enddo
8546         enddo
8547 C AEAb1 and AEAb2
8548 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
8549 C They are needed only when the fifth- or the sixth-order cumulants are
8550 C indluded.
8551         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or.
8552      &    (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
8553         call transpose2(AEA(1,1,1),auxmat(1,1))
8554         call matvec2(auxmat(1,1),b1(1,i),AEAb1(1,1,1))
8555         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
8556         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
8557         call transpose2(AEAderg(1,1,1),auxmat(1,1))
8558         call matvec2(auxmat(1,1),b1(1,i),AEAb1derg(1,1,1))
8559         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
8560         call matvec2(AEA(1,1,1),b1(1,k+1),AEAb1(1,2,1))
8561         call matvec2(AEAderg(1,1,1),b1(1,k+1),AEAb1derg(1,2,1))
8562         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
8563         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
8564         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
8565         call transpose2(AEA(1,1,2),auxmat(1,1))
8566         call matvec2(auxmat(1,1),b1(1,j+1),AEAb1(1,1,2))
8567         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
8568         call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
8569         call transpose2(AEAderg(1,1,2),auxmat(1,1))
8570         call matvec2(auxmat(1,1),b1(1,l),AEAb1(1,1,2))
8571         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
8572         call matvec2(AEA(1,1,2),b1(1,j+1),AEAb1(1,2,2))
8573         call matvec2(AEAderg(1,1,2),b1(1,j+1),AEAb1derg(1,2,2))
8574         call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
8575         call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
8576         call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
8577 C Calculate the Cartesian derivatives of the vectors.
8578         do iii=1,2
8579           do kkk=1,5
8580             do lll=1,3
8581               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
8582               call matvec2(auxmat(1,1),b1(1,i),
8583      &          AEAb1derx(1,lll,kkk,iii,1,1))
8584               call matvec2(auxmat(1,1),Ub2(1,i),
8585      &          AEAb2derx(1,lll,kkk,iii,1,1))
8586               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
8587      &          AEAb1derx(1,lll,kkk,iii,2,1))
8588               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
8589      &          AEAb2derx(1,lll,kkk,iii,2,1))
8590               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
8591               call matvec2(auxmat(1,1),b1(1,l),
8592      &          AEAb1derx(1,lll,kkk,iii,1,2))
8593               call matvec2(auxmat(1,1),Ub2(1,l),
8594      &          AEAb2derx(1,lll,kkk,iii,1,2))
8595               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,j+1),
8596      &          AEAb1derx(1,lll,kkk,iii,2,2))
8597               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),
8598      &          AEAb2derx(1,lll,kkk,iii,2,2))
8599             enddo
8600           enddo
8601         enddo
8602         ENDIF
8603 C End vectors
8604       endif
8605       return
8606       end
8607 C---------------------------------------------------------------------------
8608       subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,
8609      &  KK,KKderg,AKA,AKAderg,AKAderx)
8610       implicit none
8611       integer nderg
8612       logical transp
8613       double precision aa1(2,2),aa2t(2,2),aa1derx(2,2,3,5),
8614      &  aa2tderx(2,2,3,5),KK(2,2),KKderg(2,2,nderg),AKA(2,2),
8615      &  AKAderg(2,2,nderg),AKAderx(2,2,3,5,2)
8616       integer iii,kkk,lll
8617       integer jjj,mmm
8618       logical lprn
8619       common /kutas/ lprn
8620       call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
8621       do iii=1,nderg
8622         call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,
8623      &    AKAderg(1,1,iii))
8624       enddo
8625 cd      if (lprn) write (2,*) 'In kernel'
8626       do kkk=1,5
8627 cd        if (lprn) write (2,*) 'kkk=',kkk
8628         do lll=1,3
8629           call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),
8630      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
8631 cd          if (lprn) then
8632 cd            write (2,*) 'lll=',lll
8633 cd            write (2,*) 'iii=1'
8634 cd            do jjj=1,2
8635 cd              write (2,'(3(2f10.5),5x)')
8636 cd     &        (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
8637 cd            enddo
8638 cd          endif
8639           call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),
8640      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
8641 cd          if (lprn) then
8642 cd            write (2,*) 'lll=',lll
8643 cd            write (2,*) 'iii=2'
8644 cd            do jjj=1,2
8645 cd              write (2,'(3(2f10.5),5x)')
8646 cd     &        (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
8647 cd            enddo
8648 cd          endif
8649         enddo
8650       enddo
8651       return
8652       end
8653 C---------------------------------------------------------------------------
8654       double precision function eello4(i,j,k,l,jj,kk)
8655       implicit real*8 (a-h,o-z)
8656       include 'DIMENSIONS'
8657       include 'COMMON.IOUNITS'
8658       include 'COMMON.CHAIN'
8659       include 'COMMON.DERIV'
8660       include 'COMMON.INTERACT'
8661       include 'COMMON.CONTACTS'
8662       include 'COMMON.TORSION'
8663       include 'COMMON.VAR'
8664       include 'COMMON.GEO'
8665       double precision pizda(2,2),ggg1(3),ggg2(3)
8666 cd      if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
8667 cd        eello4=0.0d0
8668 cd        return
8669 cd      endif
8670 cd      print *,'eello4:',i,j,k,l,jj,kk
8671 cd      write (2,*) 'i',i,' j',j,' k',k,' l',l
8672 cd      call checkint4(i,j,k,l,jj,kk,eel4_num)
8673 cold      eij=facont_hb(jj,i)
8674 cold      ekl=facont_hb(kk,k)
8675 cold      ekont=eij*ekl
8676       eel4=-EAEA(1,1,1)-EAEA(2,2,1)
8677 cd      eel41=-EAEA(1,1,2)-EAEA(2,2,2)
8678       gcorr_loc(k-1)=gcorr_loc(k-1)
8679      &   -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
8680       if (l.eq.j+1) then
8681         gcorr_loc(l-1)=gcorr_loc(l-1)
8682      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
8683       else
8684         gcorr_loc(j-1)=gcorr_loc(j-1)
8685      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
8686       endif
8687       do iii=1,2
8688         do kkk=1,5
8689           do lll=1,3
8690             derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1)
8691      &                        -EAEAderx(2,2,lll,kkk,iii,1)
8692 cd            derx(lll,kkk,iii)=0.0d0
8693           enddo
8694         enddo
8695       enddo
8696 cd      gcorr_loc(l-1)=0.0d0
8697 cd      gcorr_loc(j-1)=0.0d0
8698 cd      gcorr_loc(k-1)=0.0d0
8699 cd      eel4=1.0d0
8700 cd      write (iout,*)'Contacts have occurred for peptide groups',
8701 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l,
8702 cd     &  ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
8703       if (j.lt.nres-1) then
8704         j1=j+1
8705         j2=j-1
8706       else
8707         j1=j-1
8708         j2=j-2
8709       endif
8710       if (l.lt.nres-1) then
8711         l1=l+1
8712         l2=l-1
8713       else
8714         l1=l-1
8715         l2=l-2
8716       endif
8717       do ll=1,3
8718 cgrad        ggg1(ll)=eel4*g_contij(ll,1)
8719 cgrad        ggg2(ll)=eel4*g_contij(ll,2)
8720         glongij=eel4*g_contij(ll,1)+ekont*derx(ll,1,1)
8721         glongkl=eel4*g_contij(ll,2)+ekont*derx(ll,1,2)
8722 cgrad        ghalf=0.5d0*ggg1(ll)
8723         gradcorr(ll,i)=gradcorr(ll,i)+ekont*derx(ll,2,1)
8724         gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
8725         gradcorr(ll,j)=gradcorr(ll,j)+ekont*derx(ll,4,1)
8726         gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
8727         gradcorr_long(ll,j)=gradcorr_long(ll,j)+glongij
8728         gradcorr_long(ll,i)=gradcorr_long(ll,i)-glongij
8729 cgrad        ghalf=0.5d0*ggg2(ll)
8730         gradcorr(ll,k)=gradcorr(ll,k)+ekont*derx(ll,2,2)
8731         gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
8732         gradcorr(ll,l)=gradcorr(ll,l)+ekont*derx(ll,4,2)
8733         gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
8734         gradcorr_long(ll,l)=gradcorr_long(ll,l)+glongkl
8735         gradcorr_long(ll,k)=gradcorr_long(ll,k)-glongkl
8736       enddo
8737 cgrad      do m=i+1,j-1
8738 cgrad        do ll=1,3
8739 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
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)+ggg2(ll)
8745 cgrad        enddo
8746 cgrad      enddo
8747 cgrad      do m=i+2,j2
8748 cgrad        do ll=1,3
8749 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
8750 cgrad        enddo
8751 cgrad      enddo
8752 cgrad      do m=k+2,l2
8753 cgrad        do ll=1,3
8754 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
8755 cgrad        enddo
8756 cgrad      enddo
8757 cd      do iii=1,nres-3
8758 cd        write (2,*) iii,gcorr_loc(iii)
8759 cd      enddo
8760       eello4=ekont*eel4
8761 cd      write (2,*) 'ekont',ekont
8762 cd      write (iout,*) 'eello4',ekont*eel4
8763       return
8764       end
8765 C---------------------------------------------------------------------------
8766       double precision function eello5(i,j,k,l,jj,kk)
8767       implicit real*8 (a-h,o-z)
8768       include 'DIMENSIONS'
8769       include 'COMMON.IOUNITS'
8770       include 'COMMON.CHAIN'
8771       include 'COMMON.DERIV'
8772       include 'COMMON.INTERACT'
8773       include 'COMMON.CONTACTS'
8774       include 'COMMON.TORSION'
8775       include 'COMMON.VAR'
8776       include 'COMMON.GEO'
8777       double precision pizda(2,2),auxmat(2,2),auxmat1(2,2),vv(2)
8778       double precision ggg1(3),ggg2(3)
8779 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8780 C                                                                              C
8781 C                            Parallel chains                                   C
8782 C                                                                              C
8783 C          o             o                   o             o                   C
8784 C         /l\           / \             \   / \           / \   /              C
8785 C        /   \         /   \             \ /   \         /   \ /               C
8786 C       j| o |l1       | o |              o| o |         | o |o                C
8787 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
8788 C      \i/   \         /   \ /             /   \         /   \                 C
8789 C       o    k1             o                                                  C
8790 C         (I)          (II)                (III)          (IV)                 C
8791 C                                                                              C
8792 C      eello5_1        eello5_2            eello5_3       eello5_4             C
8793 C                                                                              C
8794 C                            Antiparallel chains                               C
8795 C                                                                              C
8796 C          o             o                   o             o                   C
8797 C         /j\           / \             \   / \           / \   /              C
8798 C        /   \         /   \             \ /   \         /   \ /               C
8799 C      j1| o |l        | o |              o| o |         | o |o                C
8800 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
8801 C      \i/   \         /   \ /             /   \         /   \                 C
8802 C       o     k1            o                                                  C
8803 C         (I)          (II)                (III)          (IV)                 C
8804 C                                                                              C
8805 C      eello5_1        eello5_2            eello5_3       eello5_4             C
8806 C                                                                              C
8807 C o denotes a local interaction, vertical lines an electrostatic interaction.  C
8808 C                                                                              C
8809 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8810 cd      if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
8811 cd        eello5=0.0d0
8812 cd        return
8813 cd      endif
8814 cd      write (iout,*)
8815 cd     &   'EELLO5: Contacts have occurred for peptide groups',i,j,
8816 cd     &   ' and',k,l
8817       itk=itortyp(itype(k))
8818       itl=itortyp(itype(l))
8819       itj=itortyp(itype(j))
8820       eello5_1=0.0d0
8821       eello5_2=0.0d0
8822       eello5_3=0.0d0
8823       eello5_4=0.0d0
8824 cd      call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
8825 cd     &   eel5_3_num,eel5_4_num)
8826       do iii=1,2
8827         do kkk=1,5
8828           do lll=1,3
8829             derx(lll,kkk,iii)=0.0d0
8830           enddo
8831         enddo
8832       enddo
8833 cd      eij=facont_hb(jj,i)
8834 cd      ekl=facont_hb(kk,k)
8835 cd      ekont=eij*ekl
8836 cd      write (iout,*)'Contacts have occurred for peptide groups',
8837 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l
8838 cd      goto 1111
8839 C Contribution from the graph I.
8840 cd      write (2,*) 'AEA  ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
8841 cd      write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
8842       call transpose2(EUg(1,1,k),auxmat(1,1))
8843       call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
8844       vv(1)=pizda(1,1)-pizda(2,2)
8845       vv(2)=pizda(1,2)+pizda(2,1)
8846       eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k))
8847      & +0.5d0*scalar2(vv(1),Dtobr2(1,i))
8848 C Explicit gradient in virtual-dihedral angles.
8849       if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1)
8850      & +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k))
8851      & +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
8852       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8853       call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
8854       vv(1)=pizda(1,1)-pizda(2,2)
8855       vv(2)=pizda(1,2)+pizda(2,1)
8856       g_corr5_loc(k-1)=g_corr5_loc(k-1)
8857      & +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k))
8858      & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
8859       call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
8860       vv(1)=pizda(1,1)-pizda(2,2)
8861       vv(2)=pizda(1,2)+pizda(2,1)
8862       if (l.eq.j+1) then
8863         if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1)
8864      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
8865      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
8866       else
8867         if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1)
8868      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
8869      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
8870       endif
8871 C Cartesian gradient
8872       do iii=1,2
8873         do kkk=1,5
8874           do lll=1,3
8875             call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),
8876      &        pizda(1,1))
8877             vv(1)=pizda(1,1)-pizda(2,2)
8878             vv(2)=pizda(1,2)+pizda(2,1)
8879             derx(lll,kkk,iii)=derx(lll,kkk,iii)
8880      &       +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k))
8881      &       +0.5d0*scalar2(vv(1),Dtobr2(1,i))
8882           enddo
8883         enddo
8884       enddo
8885 c      goto 1112
8886 c1111  continue
8887 C Contribution from graph II
8888       call transpose2(EE(1,1,itk),auxmat(1,1))
8889       call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
8890       vv(1)=pizda(1,1)+pizda(2,2)
8891       vv(2)=pizda(2,1)-pizda(1,2)
8892       eello5_2=scalar2(AEAb1(1,2,1),b1(1,k))
8893      & -0.5d0*scalar2(vv(1),Ctobr(1,k))
8894 C Explicit gradient in virtual-dihedral angles.
8895       g_corr5_loc(k-1)=g_corr5_loc(k-1)
8896      & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
8897       call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
8898       vv(1)=pizda(1,1)+pizda(2,2)
8899       vv(2)=pizda(2,1)-pizda(1,2)
8900       if (l.eq.j+1) then
8901         g_corr5_loc(l-1)=g_corr5_loc(l-1)
8902      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,k))
8903      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
8904       else
8905         g_corr5_loc(j-1)=g_corr5_loc(j-1)
8906      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,k))
8907      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
8908       endif
8909 C Cartesian gradient
8910       do iii=1,2
8911         do kkk=1,5
8912           do lll=1,3
8913             call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
8914      &        pizda(1,1))
8915             vv(1)=pizda(1,1)+pizda(2,2)
8916             vv(2)=pizda(2,1)-pizda(1,2)
8917             derx(lll,kkk,iii)=derx(lll,kkk,iii)
8918      &       +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,k))
8919      &       -0.5d0*scalar2(vv(1),Ctobr(1,k))
8920           enddo
8921         enddo
8922       enddo
8923 cd      goto 1112
8924 cd1111  continue
8925       if (l.eq.j+1) then
8926 cd        goto 1110
8927 C Parallel orientation
8928 C Contribution from graph III
8929         call transpose2(EUg(1,1,l),auxmat(1,1))
8930         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
8931         vv(1)=pizda(1,1)-pizda(2,2)
8932         vv(2)=pizda(1,2)+pizda(2,1)
8933         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l))
8934      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j))
8935 C Explicit gradient in virtual-dihedral angles.
8936         g_corr5_loc(j-1)=g_corr5_loc(j-1)
8937      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l))
8938      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
8939         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
8940         vv(1)=pizda(1,1)-pizda(2,2)
8941         vv(2)=pizda(1,2)+pizda(2,1)
8942         g_corr5_loc(k-1)=g_corr5_loc(k-1)
8943      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l))
8944      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
8945         call transpose2(EUgder(1,1,l),auxmat1(1,1))
8946         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
8947         vv(1)=pizda(1,1)-pizda(2,2)
8948         vv(2)=pizda(1,2)+pizda(2,1)
8949         g_corr5_loc(l-1)=g_corr5_loc(l-1)
8950      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l))
8951      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
8952 C Cartesian gradient
8953         do iii=1,2
8954           do kkk=1,5
8955             do lll=1,3
8956               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
8957      &          pizda(1,1))
8958               vv(1)=pizda(1,1)-pizda(2,2)
8959               vv(2)=pizda(1,2)+pizda(2,1)
8960               derx(lll,kkk,iii)=derx(lll,kkk,iii)
8961      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l))
8962      &         +0.5d0*scalar2(vv(1),Dtobr2(1,j))
8963             enddo
8964           enddo
8965         enddo
8966 cd        goto 1112
8967 C Contribution from graph IV
8968 cd1110    continue
8969         call transpose2(EE(1,1,itl),auxmat(1,1))
8970         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
8971         vv(1)=pizda(1,1)+pizda(2,2)
8972         vv(2)=pizda(2,1)-pizda(1,2)
8973         eello5_4=scalar2(AEAb1(1,2,2),b1(1,l))
8974      &   -0.5d0*scalar2(vv(1),Ctobr(1,l))
8975 C Explicit gradient in virtual-dihedral angles.
8976         g_corr5_loc(l-1)=g_corr5_loc(l-1)
8977      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
8978         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
8979         vv(1)=pizda(1,1)+pizda(2,2)
8980         vv(2)=pizda(2,1)-pizda(1,2)
8981         g_corr5_loc(k-1)=g_corr5_loc(k-1)
8982      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,l))
8983      &   -0.5d0*scalar2(vv(1),Ctobr(1,l)))
8984 C Cartesian gradient
8985         do iii=1,2
8986           do kkk=1,5
8987             do lll=1,3
8988               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
8989      &          pizda(1,1))
8990               vv(1)=pizda(1,1)+pizda(2,2)
8991               vv(2)=pizda(2,1)-pizda(1,2)
8992               derx(lll,kkk,iii)=derx(lll,kkk,iii)
8993      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,l))
8994      &         -0.5d0*scalar2(vv(1),Ctobr(1,l))
8995             enddo
8996           enddo
8997         enddo
8998       else
8999 C Antiparallel orientation
9000 C Contribution from graph III
9001 c        goto 1110
9002         call transpose2(EUg(1,1,j),auxmat(1,1))
9003         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
9004         vv(1)=pizda(1,1)-pizda(2,2)
9005         vv(2)=pizda(1,2)+pizda(2,1)
9006         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j))
9007      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l))
9008 C Explicit gradient in virtual-dihedral angles.
9009         g_corr5_loc(l-1)=g_corr5_loc(l-1)
9010      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j))
9011      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
9012         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
9013         vv(1)=pizda(1,1)-pizda(2,2)
9014         vv(2)=pizda(1,2)+pizda(2,1)
9015         g_corr5_loc(k-1)=g_corr5_loc(k-1)
9016      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j))
9017      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
9018         call transpose2(EUgder(1,1,j),auxmat1(1,1))
9019         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
9020         vv(1)=pizda(1,1)-pizda(2,2)
9021         vv(2)=pizda(1,2)+pizda(2,1)
9022         g_corr5_loc(j-1)=g_corr5_loc(j-1)
9023      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j))
9024      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
9025 C Cartesian gradient
9026         do iii=1,2
9027           do kkk=1,5
9028             do lll=1,3
9029               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
9030      &          pizda(1,1))
9031               vv(1)=pizda(1,1)-pizda(2,2)
9032               vv(2)=pizda(1,2)+pizda(2,1)
9033               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
9034      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j))
9035      &         +0.5d0*scalar2(vv(1),Dtobr2(1,l))
9036             enddo
9037           enddo
9038         enddo
9039 cd        goto 1112
9040 C Contribution from graph IV
9041 1110    continue
9042         call transpose2(EE(1,1,itj),auxmat(1,1))
9043         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
9044         vv(1)=pizda(1,1)+pizda(2,2)
9045         vv(2)=pizda(2,1)-pizda(1,2)
9046         eello5_4=scalar2(AEAb1(1,2,2),b1(1,j))
9047      &   -0.5d0*scalar2(vv(1),Ctobr(1,j))
9048 C Explicit gradient in virtual-dihedral angles.
9049         g_corr5_loc(j-1)=g_corr5_loc(j-1)
9050      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
9051         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
9052         vv(1)=pizda(1,1)+pizda(2,2)
9053         vv(2)=pizda(2,1)-pizda(1,2)
9054         g_corr5_loc(k-1)=g_corr5_loc(k-1)
9055      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,j))
9056      &   -0.5d0*scalar2(vv(1),Ctobr(1,j)))
9057 C Cartesian gradient
9058         do iii=1,2
9059           do kkk=1,5
9060             do lll=1,3
9061               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
9062      &          pizda(1,1))
9063               vv(1)=pizda(1,1)+pizda(2,2)
9064               vv(2)=pizda(2,1)-pizda(1,2)
9065               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
9066      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,j))
9067      &         -0.5d0*scalar2(vv(1),Ctobr(1,j))
9068             enddo
9069           enddo
9070         enddo
9071       endif
9072 1112  continue
9073       eel5=eello5_1+eello5_2+eello5_3+eello5_4
9074 cd      if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
9075 cd        write (2,*) 'ijkl',i,j,k,l
9076 cd        write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
9077 cd     &     ' eello5_3',eello5_3,' eello5_4',eello5_4
9078 cd      endif
9079 cd      write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
9080 cd      write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
9081 cd      write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
9082 cd      write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
9083       if (j.lt.nres-1) then
9084         j1=j+1
9085         j2=j-1
9086       else
9087         j1=j-1
9088         j2=j-2
9089       endif
9090       if (l.lt.nres-1) then
9091         l1=l+1
9092         l2=l-1
9093       else
9094         l1=l-1
9095         l2=l-2
9096       endif
9097 cd      eij=1.0d0
9098 cd      ekl=1.0d0
9099 cd      ekont=1.0d0
9100 cd      write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
9101 C 2/11/08 AL Gradients over DC's connecting interacting sites will be
9102 C        summed up outside the subrouine as for the other subroutines
9103 C        handling long-range interactions. The old code is commented out
9104 C        with "cgrad" to keep track of changes.
9105       do ll=1,3
9106 cgrad        ggg1(ll)=eel5*g_contij(ll,1)
9107 cgrad        ggg2(ll)=eel5*g_contij(ll,2)
9108         gradcorr5ij=eel5*g_contij(ll,1)+ekont*derx(ll,1,1)
9109         gradcorr5kl=eel5*g_contij(ll,2)+ekont*derx(ll,1,2)
9110 c        write (iout,'(a,3i3,a,5f8.3,2i3,a,5f8.3,a,f8.3)')
9111 c     &   "ecorr5",ll,i,j," derx",derx(ll,2,1),derx(ll,3,1),derx(ll,4,1),
9112 c     &   derx(ll,5,1),k,l," derx",derx(ll,2,2),derx(ll,3,2),
9113 c     &   derx(ll,4,2),derx(ll,5,2)," ekont",ekont
9114 c        write (iout,'(a,3i3,a,3f8.3,2i3,a,3f8.3)')
9115 c     &   "ecorr5",ll,i,j," gradcorr5",g_contij(ll,1),derx(ll,1,1),
9116 c     &   gradcorr5ij,
9117 c     &   k,l," gradcorr5",g_contij(ll,2),derx(ll,1,2),gradcorr5kl
9118 cold        ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
9119 cgrad        ghalf=0.5d0*ggg1(ll)
9120 cd        ghalf=0.0d0
9121         gradcorr5(ll,i)=gradcorr5(ll,i)+ekont*derx(ll,2,1)
9122         gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
9123         gradcorr5(ll,j)=gradcorr5(ll,j)+ekont*derx(ll,4,1)
9124         gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
9125         gradcorr5_long(ll,j)=gradcorr5_long(ll,j)+gradcorr5ij
9126         gradcorr5_long(ll,i)=gradcorr5_long(ll,i)-gradcorr5ij
9127 cold        ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
9128 cgrad        ghalf=0.5d0*ggg2(ll)
9129 cd        ghalf=0.0d0
9130         gradcorr5(ll,k)=gradcorr5(ll,k)+ekont*derx(ll,2,2)
9131         gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
9132         gradcorr5(ll,l)=gradcorr5(ll,l)+ekont*derx(ll,4,2)
9133         gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
9134         gradcorr5_long(ll,l)=gradcorr5_long(ll,l)+gradcorr5kl
9135         gradcorr5_long(ll,k)=gradcorr5_long(ll,k)-gradcorr5kl
9136       enddo
9137 cd      goto 1112
9138 cgrad      do m=i+1,j-1
9139 cgrad        do ll=1,3
9140 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
9141 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
9142 cgrad        enddo
9143 cgrad      enddo
9144 cgrad      do m=k+1,l-1
9145 cgrad        do ll=1,3
9146 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
9147 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
9148 cgrad        enddo
9149 cgrad      enddo
9150 c1112  continue
9151 cgrad      do m=i+2,j2
9152 cgrad        do ll=1,3
9153 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
9154 cgrad        enddo
9155 cgrad      enddo
9156 cgrad      do m=k+2,l2
9157 cgrad        do ll=1,3
9158 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
9159 cgrad        enddo
9160 cgrad      enddo
9161 cd      do iii=1,nres-3
9162 cd        write (2,*) iii,g_corr5_loc(iii)
9163 cd      enddo
9164       eello5=ekont*eel5
9165 cd      write (2,*) 'ekont',ekont
9166 cd      write (iout,*) 'eello5',ekont*eel5
9167       return
9168       end
9169 c--------------------------------------------------------------------------
9170       double precision function eello6(i,j,k,l,jj,kk)
9171       implicit real*8 (a-h,o-z)
9172       include 'DIMENSIONS'
9173       include 'COMMON.IOUNITS'
9174       include 'COMMON.CHAIN'
9175       include 'COMMON.DERIV'
9176       include 'COMMON.INTERACT'
9177       include 'COMMON.CONTACTS'
9178       include 'COMMON.TORSION'
9179       include 'COMMON.VAR'
9180       include 'COMMON.GEO'
9181       include 'COMMON.FFIELD'
9182       double precision ggg1(3),ggg2(3)
9183 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
9184 cd        eello6=0.0d0
9185 cd        return
9186 cd      endif
9187 cd      write (iout,*)
9188 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
9189 cd     &   ' and',k,l
9190       eello6_1=0.0d0
9191       eello6_2=0.0d0
9192       eello6_3=0.0d0
9193       eello6_4=0.0d0
9194       eello6_5=0.0d0
9195       eello6_6=0.0d0
9196 cd      call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
9197 cd     &   eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
9198       do iii=1,2
9199         do kkk=1,5
9200           do lll=1,3
9201             derx(lll,kkk,iii)=0.0d0
9202           enddo
9203         enddo
9204       enddo
9205 cd      eij=facont_hb(jj,i)
9206 cd      ekl=facont_hb(kk,k)
9207 cd      ekont=eij*ekl
9208 cd      eij=1.0d0
9209 cd      ekl=1.0d0
9210 cd      ekont=1.0d0
9211       if (l.eq.j+1) then
9212         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
9213         eello6_2=eello6_graph1(j,i,l,k,2,.false.)
9214         eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
9215         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
9216         eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
9217         eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
9218       else
9219         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
9220         eello6_2=eello6_graph1(l,k,j,i,2,.true.)
9221         eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
9222         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
9223         if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
9224           eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
9225         else
9226           eello6_5=0.0d0
9227         endif
9228         eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
9229       endif
9230 C If turn contributions are considered, they will be handled separately.
9231       eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
9232 cd      write(iout,*) 'eello6_1',eello6_1!,' eel6_1_num',16*eel6_1_num
9233 cd      write(iout,*) 'eello6_2',eello6_2!,' eel6_2_num',16*eel6_2_num
9234 cd      write(iout,*) 'eello6_3',eello6_3!,' eel6_3_num',16*eel6_3_num
9235 cd      write(iout,*) 'eello6_4',eello6_4!,' eel6_4_num',16*eel6_4_num
9236 cd      write(iout,*) 'eello6_5',eello6_5!,' eel6_5_num',16*eel6_5_num
9237 cd      write(iout,*) 'eello6_6',eello6_6!,' eel6_6_num',16*eel6_6_num
9238 cd      goto 1112
9239       if (j.lt.nres-1) then
9240         j1=j+1
9241         j2=j-1
9242       else
9243         j1=j-1
9244         j2=j-2
9245       endif
9246       if (l.lt.nres-1) then
9247         l1=l+1
9248         l2=l-1
9249       else
9250         l1=l-1
9251         l2=l-2
9252       endif
9253       do ll=1,3
9254 cgrad        ggg1(ll)=eel6*g_contij(ll,1)
9255 cgrad        ggg2(ll)=eel6*g_contij(ll,2)
9256 cold        ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
9257 cgrad        ghalf=0.5d0*ggg1(ll)
9258 cd        ghalf=0.0d0
9259         gradcorr6ij=eel6*g_contij(ll,1)+ekont*derx(ll,1,1)
9260         gradcorr6kl=eel6*g_contij(ll,2)+ekont*derx(ll,1,2)
9261         gradcorr6(ll,i)=gradcorr6(ll,i)+ekont*derx(ll,2,1)
9262         gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
9263         gradcorr6(ll,j)=gradcorr6(ll,j)+ekont*derx(ll,4,1)
9264         gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
9265         gradcorr6_long(ll,j)=gradcorr6_long(ll,j)+gradcorr6ij
9266         gradcorr6_long(ll,i)=gradcorr6_long(ll,i)-gradcorr6ij
9267 cgrad        ghalf=0.5d0*ggg2(ll)
9268 cold        ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
9269 cd        ghalf=0.0d0
9270         gradcorr6(ll,k)=gradcorr6(ll,k)+ekont*derx(ll,2,2)
9271         gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
9272         gradcorr6(ll,l)=gradcorr6(ll,l)+ekont*derx(ll,4,2)
9273         gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
9274         gradcorr6_long(ll,l)=gradcorr6_long(ll,l)+gradcorr6kl
9275         gradcorr6_long(ll,k)=gradcorr6_long(ll,k)-gradcorr6kl
9276       enddo
9277 cd      goto 1112
9278 cgrad      do m=i+1,j-1
9279 cgrad        do ll=1,3
9280 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
9281 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
9282 cgrad        enddo
9283 cgrad      enddo
9284 cgrad      do m=k+1,l-1
9285 cgrad        do ll=1,3
9286 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
9287 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
9288 cgrad        enddo
9289 cgrad      enddo
9290 cgrad1112  continue
9291 cgrad      do m=i+2,j2
9292 cgrad        do ll=1,3
9293 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
9294 cgrad        enddo
9295 cgrad      enddo
9296 cgrad      do m=k+2,l2
9297 cgrad        do ll=1,3
9298 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
9299 cgrad        enddo
9300 cgrad      enddo
9301 cd      do iii=1,nres-3
9302 cd        write (2,*) iii,g_corr6_loc(iii)
9303 cd      enddo
9304       eello6=ekont*eel6
9305 cd      write (2,*) 'ekont',ekont
9306 cd      write (iout,*) 'eello6',ekont*eel6
9307       return
9308       end
9309 c--------------------------------------------------------------------------
9310       double precision function eello6_graph1(i,j,k,l,imat,swap)
9311       implicit real*8 (a-h,o-z)
9312       include 'DIMENSIONS'
9313       include 'COMMON.IOUNITS'
9314       include 'COMMON.CHAIN'
9315       include 'COMMON.DERIV'
9316       include 'COMMON.INTERACT'
9317       include 'COMMON.CONTACTS'
9318       include 'COMMON.TORSION'
9319       include 'COMMON.VAR'
9320       include 'COMMON.GEO'
9321       double precision vv(2),vv1(2),pizda(2,2),auxmat(2,2),pizda1(2,2)
9322       logical swap
9323       logical lprn
9324       common /kutas/ lprn
9325 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9326 C                                                                              C
9327 C      Parallel       Antiparallel                                             C
9328 C                                                                              C
9329 C          o             o                                                     C
9330 C         /l\           /j\                                                    C
9331 C        /   \         /   \                                                   C
9332 C       /| o |         | o |\                                                  C
9333 C     \ j|/k\|  /   \  |/k\|l /                                                C
9334 C      \ /   \ /     \ /   \ /                                                 C
9335 C       o     o       o     o                                                  C
9336 C       i             i                                                        C
9337 C                                                                              C
9338 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9339       itk=itortyp(itype(k))
9340       s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
9341       s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
9342       s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
9343       call transpose2(EUgC(1,1,k),auxmat(1,1))
9344       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
9345       vv1(1)=pizda1(1,1)-pizda1(2,2)
9346       vv1(2)=pizda1(1,2)+pizda1(2,1)
9347       s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
9348       vv(1)=AEAb1(1,2,imat)*b1(1,k)-AEAb1(2,2,imat)*b1(2,k)
9349       vv(2)=AEAb1(1,2,imat)*b1(2,k)+AEAb1(2,2,imat)*b1(1,k)
9350       s5=scalar2(vv(1),Dtobr2(1,i))
9351 cd      write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
9352       eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
9353       if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1)
9354      & -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i))
9355      & -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k))
9356      & +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k))
9357      & +0.5d0*scalar2(vv1(1),Dtobr2der(1,i))
9358      & +scalar2(vv(1),Dtobr2der(1,i)))
9359       call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
9360       vv1(1)=pizda1(1,1)-pizda1(2,2)
9361       vv1(2)=pizda1(1,2)+pizda1(2,1)
9362       vv(1)=AEAb1derg(1,2,imat)*b1(1,k)-AEAb1derg(2,2,imat)*b1(2,k)
9363       vv(2)=AEAb1derg(1,2,imat)*b1(2,k)+AEAb1derg(2,2,imat)*b1(1,k)
9364       if (l.eq.j+1) then
9365         g_corr6_loc(l-1)=g_corr6_loc(l-1)
9366      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
9367      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
9368      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
9369      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
9370       else
9371         g_corr6_loc(j-1)=g_corr6_loc(j-1)
9372      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
9373      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
9374      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
9375      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
9376       endif
9377       call transpose2(EUgCder(1,1,k),auxmat(1,1))
9378       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
9379       vv1(1)=pizda1(1,1)-pizda1(2,2)
9380       vv1(2)=pizda1(1,2)+pizda1(2,1)
9381       if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1)
9382      & +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k))
9383      & +scalar2(AEAb2(1,1,imat),CUgb2der(1,k))
9384      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
9385       do iii=1,2
9386         if (swap) then
9387           ind=3-iii
9388         else
9389           ind=iii
9390         endif
9391         do kkk=1,5
9392           do lll=1,3
9393             s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
9394             s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
9395             s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
9396             call transpose2(EUgC(1,1,k),auxmat(1,1))
9397             call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
9398      &        pizda1(1,1))
9399             vv1(1)=pizda1(1,1)-pizda1(2,2)
9400             vv1(2)=pizda1(1,2)+pizda1(2,1)
9401             s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
9402             vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,k)
9403      &       -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,k)
9404             vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,k)
9405      &       +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,k)
9406             s5=scalar2(vv(1),Dtobr2(1,i))
9407             derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
9408           enddo
9409         enddo
9410       enddo
9411       return
9412       end
9413 c----------------------------------------------------------------------------
9414       double precision function eello6_graph2(i,j,k,l,jj,kk,swap)
9415       implicit real*8 (a-h,o-z)
9416       include 'DIMENSIONS'
9417       include 'COMMON.IOUNITS'
9418       include 'COMMON.CHAIN'
9419       include 'COMMON.DERIV'
9420       include 'COMMON.INTERACT'
9421       include 'COMMON.CONTACTS'
9422       include 'COMMON.TORSION'
9423       include 'COMMON.VAR'
9424       include 'COMMON.GEO'
9425       logical swap
9426       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
9427      & auxvec1(2),auxvec2(2),auxmat1(2,2)
9428       logical lprn
9429       common /kutas/ lprn
9430 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9431 C                                                                              C
9432 C      Parallel       Antiparallel                                             C
9433 C                                                                              C
9434 C          o             o                                                     C
9435 C     \   /l\           /j\   /                                                C
9436 C      \ /   \         /   \ /                                                 C
9437 C       o| o |         | o |o                                                  C
9438 C     \ j|/k\|      \  |/k\|l                                                  C
9439 C      \ /   \       \ /   \                                                   C
9440 C       o             o                                                        C
9441 C       i             i                                                        C
9442 C                                                                              C
9443 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9444 cd      write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
9445 C AL 7/4/01 s1 would occur in the sixth-order moment,
9446 C           but not in a cluster cumulant
9447 #ifdef MOMENT
9448       s1=dip(1,jj,i)*dip(1,kk,k)
9449 #endif
9450       call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
9451       s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
9452       call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
9453       s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
9454       call transpose2(EUg(1,1,k),auxmat(1,1))
9455       call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
9456       vv(1)=pizda(1,1)-pizda(2,2)
9457       vv(2)=pizda(1,2)+pizda(2,1)
9458       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
9459 cd      write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
9460 #ifdef MOMENT
9461       eello6_graph2=-(s1+s2+s3+s4)
9462 #else
9463       eello6_graph2=-(s2+s3+s4)
9464 #endif
9465 c      eello6_graph2=-s3
9466 C Derivatives in gamma(i-1)
9467       if (i.gt.1) then
9468 #ifdef MOMENT
9469         s1=dipderg(1,jj,i)*dip(1,kk,k)
9470 #endif
9471         s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
9472         call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
9473         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
9474         s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
9475 #ifdef MOMENT
9476         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
9477 #else
9478         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
9479 #endif
9480 c        g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
9481       endif
9482 C Derivatives in gamma(k-1)
9483 #ifdef MOMENT
9484       s1=dip(1,jj,i)*dipderg(1,kk,k)
9485 #endif
9486       call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
9487       s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
9488       call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
9489       s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
9490       call transpose2(EUgder(1,1,k),auxmat1(1,1))
9491       call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
9492       vv(1)=pizda(1,1)-pizda(2,2)
9493       vv(2)=pizda(1,2)+pizda(2,1)
9494       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
9495 #ifdef MOMENT
9496       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
9497 #else
9498       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
9499 #endif
9500 c      g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
9501 C Derivatives in gamma(j-1) or gamma(l-1)
9502       if (j.gt.1) then
9503 #ifdef MOMENT
9504         s1=dipderg(3,jj,i)*dip(1,kk,k)
9505 #endif
9506         call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
9507         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
9508         s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
9509         call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
9510         vv(1)=pizda(1,1)-pizda(2,2)
9511         vv(2)=pizda(1,2)+pizda(2,1)
9512         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
9513 #ifdef MOMENT
9514         if (swap) then
9515           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
9516         else
9517           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
9518         endif
9519 #endif
9520         g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
9521 c        g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
9522       endif
9523 C Derivatives in gamma(l-1) or gamma(j-1)
9524       if (l.gt.1) then
9525 #ifdef MOMENT
9526         s1=dip(1,jj,i)*dipderg(3,kk,k)
9527 #endif
9528         call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
9529         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
9530         call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
9531         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
9532         call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
9533         vv(1)=pizda(1,1)-pizda(2,2)
9534         vv(2)=pizda(1,2)+pizda(2,1)
9535         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
9536 #ifdef MOMENT
9537         if (swap) then
9538           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
9539         else
9540           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
9541         endif
9542 #endif
9543         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
9544 c        g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
9545       endif
9546 C Cartesian derivatives.
9547       if (lprn) then
9548         write (2,*) 'In eello6_graph2'
9549         do iii=1,2
9550           write (2,*) 'iii=',iii
9551           do kkk=1,5
9552             write (2,*) 'kkk=',kkk
9553             do jjj=1,2
9554               write (2,'(3(2f10.5),5x)')
9555      &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
9556             enddo
9557           enddo
9558         enddo
9559       endif
9560       do iii=1,2
9561         do kkk=1,5
9562           do lll=1,3
9563 #ifdef MOMENT
9564             if (iii.eq.1) then
9565               s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
9566             else
9567               s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
9568             endif
9569 #endif
9570             call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),
9571      &        auxvec(1))
9572             s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
9573             call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),
9574      &        auxvec(1))
9575             s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
9576             call transpose2(EUg(1,1,k),auxmat(1,1))
9577             call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),
9578      &        pizda(1,1))
9579             vv(1)=pizda(1,1)-pizda(2,2)
9580             vv(2)=pizda(1,2)+pizda(2,1)
9581             s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
9582 cd            write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
9583 #ifdef MOMENT
9584             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
9585 #else
9586             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
9587 #endif
9588             if (swap) then
9589               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
9590             else
9591               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
9592             endif
9593           enddo
9594         enddo
9595       enddo
9596       return
9597       end
9598 c----------------------------------------------------------------------------
9599       double precision function eello6_graph3(i,j,k,l,jj,kk,swap)
9600       implicit real*8 (a-h,o-z)
9601       include 'DIMENSIONS'
9602       include 'COMMON.IOUNITS'
9603       include 'COMMON.CHAIN'
9604       include 'COMMON.DERIV'
9605       include 'COMMON.INTERACT'
9606       include 'COMMON.CONTACTS'
9607       include 'COMMON.TORSION'
9608       include 'COMMON.VAR'
9609       include 'COMMON.GEO'
9610       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2)
9611       logical swap
9612 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9613 C                                                                              C
9614 C      Parallel       Antiparallel                                             C
9615 C                                                                              C
9616 C          o             o                                                     C
9617 C         /l\   /   \   /j\                                                    C
9618 C        /   \ /     \ /   \                                                   C
9619 C       /| o |o       o| o |\                                                  C
9620 C       j|/k\|  /      |/k\|l /                                                C
9621 C        /   \ /       /   \ /                                                 C
9622 C       /     o       /     o                                                  C
9623 C       i             i                                                        C
9624 C                                                                              C
9625 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9626 C
9627 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
9628 C           energy moment and not to the cluster cumulant.
9629       iti=itortyp(itype(i))
9630       if (j.lt.nres-1) then
9631         itj1=itortyp(itype(j+1))
9632       else
9633         itj1=ntortyp
9634       endif
9635       itk=itortyp(itype(k))
9636       itk1=itortyp(itype(k+1))
9637       if (l.lt.nres-1) then
9638         itl1=itortyp(itype(l+1))
9639       else
9640         itl1=ntortyp
9641       endif
9642 #ifdef MOMENT
9643       s1=dip(4,jj,i)*dip(4,kk,k)
9644 #endif
9645       call matvec2(AECA(1,1,1),b1(1,k+1),auxvec(1))
9646       s2=0.5d0*scalar2(b1(1,k),auxvec(1))
9647       call matvec2(AECA(1,1,2),b1(1,l+1),auxvec(1))
9648       s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
9649       call transpose2(EE(1,1,itk),auxmat(1,1))
9650       call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
9651       vv(1)=pizda(1,1)+pizda(2,2)
9652       vv(2)=pizda(2,1)-pizda(1,2)
9653       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
9654 cd      write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4,
9655 cd     & "sum",-(s2+s3+s4)
9656 #ifdef MOMENT
9657       eello6_graph3=-(s1+s2+s3+s4)
9658 #else
9659       eello6_graph3=-(s2+s3+s4)
9660 #endif
9661 c      eello6_graph3=-s4
9662 C Derivatives in gamma(k-1)
9663       call matvec2(AECAderg(1,1,2),b1(1,l+1),auxvec(1))
9664       s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
9665       s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
9666       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
9667 C Derivatives in gamma(l-1)
9668       call matvec2(AECAderg(1,1,1),b1(1,k+1),auxvec(1))
9669       s2=0.5d0*scalar2(b1(1,k),auxvec(1))
9670       call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
9671       vv(1)=pizda(1,1)+pizda(2,2)
9672       vv(2)=pizda(2,1)-pizda(1,2)
9673       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
9674       g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
9675 C Cartesian derivatives.
9676       do iii=1,2
9677         do kkk=1,5
9678           do lll=1,3
9679 #ifdef MOMENT
9680             if (iii.eq.1) then
9681               s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
9682             else
9683               s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
9684             endif
9685 #endif
9686             call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
9687      &        auxvec(1))
9688             s2=0.5d0*scalar2(b1(1,k),auxvec(1))
9689             call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,l+1),
9690      &        auxvec(1))
9691             s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
9692             call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),
9693      &        pizda(1,1))
9694             vv(1)=pizda(1,1)+pizda(2,2)
9695             vv(2)=pizda(2,1)-pizda(1,2)
9696             s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
9697 #ifdef MOMENT
9698             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
9699 #else
9700             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
9701 #endif
9702             if (swap) then
9703               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
9704             else
9705               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
9706             endif
9707 c            derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
9708           enddo
9709         enddo
9710       enddo
9711       return
9712       end
9713 c----------------------------------------------------------------------------
9714       double precision function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
9715       implicit real*8 (a-h,o-z)
9716       include 'DIMENSIONS'
9717       include 'COMMON.IOUNITS'
9718       include 'COMMON.CHAIN'
9719       include 'COMMON.DERIV'
9720       include 'COMMON.INTERACT'
9721       include 'COMMON.CONTACTS'
9722       include 'COMMON.TORSION'
9723       include 'COMMON.VAR'
9724       include 'COMMON.GEO'
9725       include 'COMMON.FFIELD'
9726       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
9727      & auxvec1(2),auxmat1(2,2)
9728       logical swap
9729 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9730 C                                                                              C
9731 C      Parallel       Antiparallel                                             C
9732 C                                                                              C
9733 C          o             o                                                     C
9734 C         /l\   /   \   /j\                                                    C
9735 C        /   \ /     \ /   \                                                   C
9736 C       /| o |o       o| o |\                                                  C
9737 C     \ j|/k\|      \  |/k\|l                                                  C
9738 C      \ /   \       \ /   \                                                   C
9739 C       o     \       o     \                                                  C
9740 C       i             i                                                        C
9741 C                                                                              C
9742 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9743 C
9744 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
9745 C           energy moment and not to the cluster cumulant.
9746 cd      write (2,*) 'eello_graph4: wturn6',wturn6
9747       iti=itortyp(itype(i))
9748       itj=itortyp(itype(j))
9749       if (j.lt.nres-1) then
9750         itj1=itortyp(itype(j+1))
9751       else
9752         itj1=ntortyp
9753       endif
9754       itk=itortyp(itype(k))
9755       if (k.lt.nres-1) then
9756         itk1=itortyp(itype(k+1))
9757       else
9758         itk1=ntortyp
9759       endif
9760       itl=itortyp(itype(l))
9761       if (l.lt.nres-1) then
9762         itl1=itortyp(itype(l+1))
9763       else
9764         itl1=ntortyp
9765       endif
9766 cd      write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
9767 cd      write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
9768 cd     & ' itl',itl,' itl1',itl1
9769 #ifdef MOMENT
9770       if (imat.eq.1) then
9771         s1=dip(3,jj,i)*dip(3,kk,k)
9772       else
9773         s1=dip(2,jj,j)*dip(2,kk,l)
9774       endif
9775 #endif
9776       call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
9777       s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
9778       if (j.eq.l+1) then
9779         call matvec2(ADtEA1(1,1,3-imat),b1(1,j+1),auxvec1(1))
9780         s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
9781       else
9782         call matvec2(ADtEA1(1,1,3-imat),b1(1,l+1),auxvec1(1))
9783         s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
9784       endif
9785       call transpose2(EUg(1,1,k),auxmat(1,1))
9786       call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
9787       vv(1)=pizda(1,1)-pizda(2,2)
9788       vv(2)=pizda(2,1)+pizda(1,2)
9789       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9790 cd      write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
9791 #ifdef MOMENT
9792       eello6_graph4=-(s1+s2+s3+s4)
9793 #else
9794       eello6_graph4=-(s2+s3+s4)
9795 #endif
9796 C Derivatives in gamma(i-1)
9797       if (i.gt.1) then
9798 #ifdef MOMENT
9799         if (imat.eq.1) then
9800           s1=dipderg(2,jj,i)*dip(3,kk,k)
9801         else
9802           s1=dipderg(4,jj,j)*dip(2,kk,l)
9803         endif
9804 #endif
9805         s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
9806         if (j.eq.l+1) then
9807           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,j+1),auxvec1(1))
9808           s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
9809         else
9810           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,l+1),auxvec1(1))
9811           s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
9812         endif
9813         s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
9814         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
9815 cd          write (2,*) 'turn6 derivatives'
9816 #ifdef MOMENT
9817           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
9818 #else
9819           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
9820 #endif
9821         else
9822 #ifdef MOMENT
9823           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
9824 #else
9825           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
9826 #endif
9827         endif
9828       endif
9829 C Derivatives in gamma(k-1)
9830 #ifdef MOMENT
9831       if (imat.eq.1) then
9832         s1=dip(3,jj,i)*dipderg(2,kk,k)
9833       else
9834         s1=dip(2,jj,j)*dipderg(4,kk,l)
9835       endif
9836 #endif
9837       call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
9838       s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
9839       if (j.eq.l+1) then
9840         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,j+1),auxvec1(1))
9841         s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
9842       else
9843         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,l+1),auxvec1(1))
9844         s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
9845       endif
9846       call transpose2(EUgder(1,1,k),auxmat1(1,1))
9847       call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
9848       vv(1)=pizda(1,1)-pizda(2,2)
9849       vv(2)=pizda(2,1)+pizda(1,2)
9850       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9851       if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
9852 #ifdef MOMENT
9853         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
9854 #else
9855         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
9856 #endif
9857       else
9858 #ifdef MOMENT
9859         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
9860 #else
9861         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
9862 #endif
9863       endif
9864 C Derivatives in gamma(j-1) or gamma(l-1)
9865       if (l.eq.j+1 .and. l.gt.1) then
9866         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
9867         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
9868         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
9869         vv(1)=pizda(1,1)-pizda(2,2)
9870         vv(2)=pizda(2,1)+pizda(1,2)
9871         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9872         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
9873       else if (j.gt.1) then
9874         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
9875         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
9876         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
9877         vv(1)=pizda(1,1)-pizda(2,2)
9878         vv(2)=pizda(2,1)+pizda(1,2)
9879         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9880         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
9881           gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
9882         else
9883           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
9884         endif
9885       endif
9886 C Cartesian derivatives.
9887       do iii=1,2
9888         do kkk=1,5
9889           do lll=1,3
9890 #ifdef MOMENT
9891             if (iii.eq.1) then
9892               if (imat.eq.1) then
9893                 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
9894               else
9895                 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
9896               endif
9897             else
9898               if (imat.eq.1) then
9899                 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
9900               else
9901                 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
9902               endif
9903             endif
9904 #endif
9905             call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),
9906      &        auxvec(1))
9907             s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
9908             if (j.eq.l+1) then
9909               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
9910      &          b1(1,j+1),auxvec(1))
9911               s3=-0.5d0*scalar2(b1(1,j),auxvec(1))
9912             else
9913               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
9914      &          b1(1,l+1),auxvec(1))
9915               s3=-0.5d0*scalar2(b1(1,l),auxvec(1))
9916             endif
9917             call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
9918      &        pizda(1,1))
9919             vv(1)=pizda(1,1)-pizda(2,2)
9920             vv(2)=pizda(2,1)+pizda(1,2)
9921             s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9922             if (swap) then
9923               if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
9924 #ifdef MOMENT
9925                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
9926      &             -(s1+s2+s4)
9927 #else
9928                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
9929      &             -(s2+s4)
9930 #endif
9931                 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
9932               else
9933 #ifdef MOMENT
9934                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
9935 #else
9936                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
9937 #endif
9938                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
9939               endif
9940             else
9941 #ifdef MOMENT
9942               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
9943 #else
9944               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
9945 #endif
9946               if (l.eq.j+1) then
9947                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
9948               else
9949                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
9950               endif
9951             endif
9952           enddo
9953         enddo
9954       enddo
9955       return
9956       end
9957 c----------------------------------------------------------------------------
9958       double precision function eello_turn6(i,jj,kk)
9959       implicit real*8 (a-h,o-z)
9960       include 'DIMENSIONS'
9961       include 'COMMON.IOUNITS'
9962       include 'COMMON.CHAIN'
9963       include 'COMMON.DERIV'
9964       include 'COMMON.INTERACT'
9965       include 'COMMON.CONTACTS'
9966       include 'COMMON.TORSION'
9967       include 'COMMON.VAR'
9968       include 'COMMON.GEO'
9969       double precision vtemp1(2),vtemp2(2),vtemp3(2),vtemp4(2),
9970      &  atemp(2,2),auxmat(2,2),achuj_temp(2,2),gtemp(2,2),gvec(2),
9971      &  ggg1(3),ggg2(3)
9972       double precision vtemp1d(2),vtemp2d(2),vtemp3d(2),vtemp4d(2),
9973      &  atempd(2,2),auxmatd(2,2),achuj_tempd(2,2),gtempd(2,2),gvecd(2)
9974 C 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
9975 C           the respective energy moment and not to the cluster cumulant.
9976       s1=0.0d0
9977       s8=0.0d0
9978       s13=0.0d0
9979 c
9980       eello_turn6=0.0d0
9981       j=i+4
9982       k=i+1
9983       l=i+3
9984       iti=itortyp(itype(i))
9985       itk=itortyp(itype(k))
9986       itk1=itortyp(itype(k+1))
9987       itl=itortyp(itype(l))
9988       itj=itortyp(itype(j))
9989 cd      write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
9990 cd      write (2,*) 'i',i,' k',k,' j',j,' l',l
9991 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
9992 cd        eello6=0.0d0
9993 cd        return
9994 cd      endif
9995 cd      write (iout,*)
9996 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
9997 cd     &   ' and',k,l
9998 cd      call checkint_turn6(i,jj,kk,eel_turn6_num)
9999       do iii=1,2
10000         do kkk=1,5
10001           do lll=1,3
10002             derx_turn(lll,kkk,iii)=0.0d0
10003           enddo
10004         enddo
10005       enddo
10006 cd      eij=1.0d0
10007 cd      ekl=1.0d0
10008 cd      ekont=1.0d0
10009       eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
10010 cd      eello6_5=0.0d0
10011 cd      write (2,*) 'eello6_5',eello6_5
10012 #ifdef MOMENT
10013       call transpose2(AEA(1,1,1),auxmat(1,1))
10014       call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
10015       ss1=scalar2(Ub2(1,i+2),b1(1,l))
10016       s1 = (auxmat(1,1)+auxmat(2,2))*ss1
10017 #endif
10018       call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1(1))
10019       call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
10020       s2 = scalar2(b1(1,k),vtemp1(1))
10021 #ifdef MOMENT
10022       call transpose2(AEA(1,1,2),atemp(1,1))
10023       call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
10024       call matvec2(Ug2(1,1,i+2),dd(1,1,itk1),vtemp2(1))
10025       s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
10026 #endif
10027       call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
10028       call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
10029       s12 = scalar2(Ub2(1,i+2),vtemp3(1))
10030 #ifdef MOMENT
10031       call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
10032       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
10033       call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
10034       call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
10035       ss13 = scalar2(b1(1,k),vtemp4(1))
10036       s13 = (gtemp(1,1)+gtemp(2,2))*ss13
10037 #endif
10038 c      write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
10039 c      s1=0.0d0
10040 c      s2=0.0d0
10041 c      s8=0.0d0
10042 c      s12=0.0d0
10043 c      s13=0.0d0
10044       eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
10045 C Derivatives in gamma(i+2)
10046       s1d =0.0d0
10047       s8d =0.0d0
10048 #ifdef MOMENT
10049       call transpose2(AEA(1,1,1),auxmatd(1,1))
10050       call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
10051       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
10052       call transpose2(AEAderg(1,1,2),atempd(1,1))
10053       call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
10054       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
10055 #endif
10056       call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
10057       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
10058       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
10059 c      s1d=0.0d0
10060 c      s2d=0.0d0
10061 c      s8d=0.0d0
10062 c      s12d=0.0d0
10063 c      s13d=0.0d0
10064       gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
10065 C Derivatives in gamma(i+3)
10066 #ifdef MOMENT
10067       call transpose2(AEA(1,1,1),auxmatd(1,1))
10068       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
10069       ss1d=scalar2(Ub2der(1,i+2),b1(1,l))
10070       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
10071 #endif
10072       call matvec2(EUgder(1,1,i+2),b1(1,l),vtemp1d(1))
10073       call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
10074       s2d = scalar2(b1(1,k),vtemp1d(1))
10075 #ifdef MOMENT
10076       call matvec2(Ug2der(1,1,i+2),dd(1,1,itk1),vtemp2d(1))
10077       s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2d(1))
10078 #endif
10079       s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
10080 #ifdef MOMENT
10081       call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
10082       call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
10083       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
10084 #endif
10085 c      s1d=0.0d0
10086 c      s2d=0.0d0
10087 c      s8d=0.0d0
10088 c      s12d=0.0d0
10089 c      s13d=0.0d0
10090 #ifdef MOMENT
10091       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
10092      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
10093 #else
10094       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
10095      &               -0.5d0*ekont*(s2d+s12d)
10096 #endif
10097 C Derivatives in gamma(i+4)
10098       call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
10099       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
10100       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
10101 #ifdef MOMENT
10102       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
10103       call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
10104       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
10105 #endif
10106 c      s1d=0.0d0
10107 c      s2d=0.0d0
10108 c      s8d=0.0d0
10109 C      s12d=0.0d0
10110 c      s13d=0.0d0
10111 #ifdef MOMENT
10112       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
10113 #else
10114       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
10115 #endif
10116 C Derivatives in gamma(i+5)
10117 #ifdef MOMENT
10118       call transpose2(AEAderg(1,1,1),auxmatd(1,1))
10119       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
10120       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
10121 #endif
10122       call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1d(1))
10123       call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
10124       s2d = scalar2(b1(1,k),vtemp1d(1))
10125 #ifdef MOMENT
10126       call transpose2(AEA(1,1,2),atempd(1,1))
10127       call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
10128       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
10129 #endif
10130       call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
10131       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
10132 #ifdef MOMENT
10133       call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
10134       ss13d = scalar2(b1(1,k),vtemp4d(1))
10135       s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
10136 #endif
10137 c      s1d=0.0d0
10138 c      s2d=0.0d0
10139 c      s8d=0.0d0
10140 c      s12d=0.0d0
10141 c      s13d=0.0d0
10142 #ifdef MOMENT
10143       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
10144      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
10145 #else
10146       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
10147      &               -0.5d0*ekont*(s2d+s12d)
10148 #endif
10149 C Cartesian derivatives
10150       do iii=1,2
10151         do kkk=1,5
10152           do lll=1,3
10153 #ifdef MOMENT
10154             call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
10155             call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
10156             s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
10157 #endif
10158             call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1(1))
10159             call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),
10160      &          vtemp1d(1))
10161             s2d = scalar2(b1(1,k),vtemp1d(1))
10162 #ifdef MOMENT
10163             call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
10164             call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
10165             s8d = -(atempd(1,1)+atempd(2,2))*
10166      &           scalar2(cc(1,1,itl),vtemp2(1))
10167 #endif
10168             call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),
10169      &           auxmatd(1,1))
10170             call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
10171             s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
10172 c      s1d=0.0d0
10173 c      s2d=0.0d0
10174 c      s8d=0.0d0
10175 c      s12d=0.0d0
10176 c      s13d=0.0d0
10177 #ifdef MOMENT
10178             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
10179      &        - 0.5d0*(s1d+s2d)
10180 #else
10181             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
10182      &        - 0.5d0*s2d
10183 #endif
10184 #ifdef MOMENT
10185             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
10186      &        - 0.5d0*(s8d+s12d)
10187 #else
10188             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
10189      &        - 0.5d0*s12d
10190 #endif
10191           enddo
10192         enddo
10193       enddo
10194 #ifdef MOMENT
10195       do kkk=1,5
10196         do lll=1,3
10197           call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),
10198      &      achuj_tempd(1,1))
10199           call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
10200           call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
10201           s13d=(gtempd(1,1)+gtempd(2,2))*ss13
10202           derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
10203           call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),
10204      &      vtemp4d(1))
10205           ss13d = scalar2(b1(1,k),vtemp4d(1))
10206           s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
10207           derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
10208         enddo
10209       enddo
10210 #endif
10211 cd      write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
10212 cd     &  16*eel_turn6_num
10213 cd      goto 1112
10214       if (j.lt.nres-1) then
10215         j1=j+1
10216         j2=j-1
10217       else
10218         j1=j-1
10219         j2=j-2
10220       endif
10221       if (l.lt.nres-1) then
10222         l1=l+1
10223         l2=l-1
10224       else
10225         l1=l-1
10226         l2=l-2
10227       endif
10228       do ll=1,3
10229 cgrad        ggg1(ll)=eel_turn6*g_contij(ll,1)
10230 cgrad        ggg2(ll)=eel_turn6*g_contij(ll,2)
10231 cgrad        ghalf=0.5d0*ggg1(ll)
10232 cd        ghalf=0.0d0
10233         gturn6ij=eel_turn6*g_contij(ll,1)+ekont*derx_turn(ll,1,1)
10234         gturn6kl=eel_turn6*g_contij(ll,2)+ekont*derx_turn(ll,1,2)
10235         gcorr6_turn(ll,i)=gcorr6_turn(ll,i)!+ghalf
10236      &    +ekont*derx_turn(ll,2,1)
10237         gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
10238         gcorr6_turn(ll,j)=gcorr6_turn(ll,j)!+ghalf
10239      &    +ekont*derx_turn(ll,4,1)
10240         gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
10241         gcorr6_turn_long(ll,j)=gcorr6_turn_long(ll,j)+gturn6ij
10242         gcorr6_turn_long(ll,i)=gcorr6_turn_long(ll,i)-gturn6ij
10243 cgrad        ghalf=0.5d0*ggg2(ll)
10244 cd        ghalf=0.0d0
10245         gcorr6_turn(ll,k)=gcorr6_turn(ll,k)!+ghalf
10246      &    +ekont*derx_turn(ll,2,2)
10247         gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
10248         gcorr6_turn(ll,l)=gcorr6_turn(ll,l)!+ghalf
10249      &    +ekont*derx_turn(ll,4,2)
10250         gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
10251         gcorr6_turn_long(ll,l)=gcorr6_turn_long(ll,l)+gturn6kl
10252         gcorr6_turn_long(ll,k)=gcorr6_turn_long(ll,k)-gturn6kl
10253       enddo
10254 cd      goto 1112
10255 cgrad      do m=i+1,j-1
10256 cgrad        do ll=1,3
10257 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
10258 cgrad        enddo
10259 cgrad      enddo
10260 cgrad      do m=k+1,l-1
10261 cgrad        do ll=1,3
10262 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
10263 cgrad        enddo
10264 cgrad      enddo
10265 cgrad1112  continue
10266 cgrad      do m=i+2,j2
10267 cgrad        do ll=1,3
10268 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
10269 cgrad        enddo
10270 cgrad      enddo
10271 cgrad      do m=k+2,l2
10272 cgrad        do ll=1,3
10273 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
10274 cgrad        enddo
10275 cgrad      enddo
10276 cd      do iii=1,nres-3
10277 cd        write (2,*) iii,g_corr6_loc(iii)
10278 cd      enddo
10279       eello_turn6=ekont*eel_turn6
10280 cd      write (2,*) 'ekont',ekont
10281 cd      write (2,*) 'eel_turn6',ekont*eel_turn6
10282       return
10283       end
10284
10285 C-----------------------------------------------------------------------------
10286       double precision function scalar(u,v)
10287 !DIR$ INLINEALWAYS scalar
10288 #ifndef OSF
10289 cDEC$ ATTRIBUTES FORCEINLINE::scalar
10290 #endif
10291       implicit none
10292       double precision u(3),v(3)
10293 cd      double precision sc
10294 cd      integer i
10295 cd      sc=0.0d0
10296 cd      do i=1,3
10297 cd        sc=sc+u(i)*v(i)
10298 cd      enddo
10299 cd      scalar=sc
10300
10301       scalar=u(1)*v(1)+u(2)*v(2)+u(3)*v(3)
10302       return
10303       end
10304 crc-------------------------------------------------
10305       SUBROUTINE MATVEC2(A1,V1,V2)
10306 !DIR$ INLINEALWAYS MATVEC2
10307 #ifndef OSF
10308 cDEC$ ATTRIBUTES FORCEINLINE::MATVEC2
10309 #endif
10310       implicit real*8 (a-h,o-z)
10311       include 'DIMENSIONS'
10312       DIMENSION A1(2,2),V1(2),V2(2)
10313 c      DO 1 I=1,2
10314 c        VI=0.0
10315 c        DO 3 K=1,2
10316 c    3     VI=VI+A1(I,K)*V1(K)
10317 c        Vaux(I)=VI
10318 c    1 CONTINUE
10319
10320       vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
10321       vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
10322
10323       v2(1)=vaux1
10324       v2(2)=vaux2
10325       END
10326 C---------------------------------------
10327       SUBROUTINE MATMAT2(A1,A2,A3)
10328 #ifndef OSF
10329 cDEC$ ATTRIBUTES FORCEINLINE::MATMAT2
10330 #endif
10331       implicit real*8 (a-h,o-z)
10332       include 'DIMENSIONS'
10333       DIMENSION A1(2,2),A2(2,2),A3(2,2)
10334 c      DIMENSION AI3(2,2)
10335 c        DO  J=1,2
10336 c          A3IJ=0.0
10337 c          DO K=1,2
10338 c           A3IJ=A3IJ+A1(I,K)*A2(K,J)
10339 c          enddo
10340 c          A3(I,J)=A3IJ
10341 c       enddo
10342 c      enddo
10343
10344       ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
10345       ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
10346       ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
10347       ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
10348
10349       A3(1,1)=AI3_11
10350       A3(2,1)=AI3_21
10351       A3(1,2)=AI3_12
10352       A3(2,2)=AI3_22
10353       END
10354
10355 c-------------------------------------------------------------------------
10356       double precision function scalar2(u,v)
10357 !DIR$ INLINEALWAYS scalar2
10358       implicit none
10359       double precision u(2),v(2)
10360       double precision sc
10361       integer i
10362       scalar2=u(1)*v(1)+u(2)*v(2)
10363       return
10364       end
10365
10366 C-----------------------------------------------------------------------------
10367
10368       subroutine transpose2(a,at)
10369 !DIR$ INLINEALWAYS transpose2
10370 #ifndef OSF
10371 cDEC$ ATTRIBUTES FORCEINLINE::transpose2
10372 #endif
10373       implicit none
10374       double precision a(2,2),at(2,2)
10375       at(1,1)=a(1,1)
10376       at(1,2)=a(2,1)
10377       at(2,1)=a(1,2)
10378       at(2,2)=a(2,2)
10379       return
10380       end
10381 c--------------------------------------------------------------------------
10382       subroutine transpose(n,a,at)
10383       implicit none
10384       integer n,i,j
10385       double precision a(n,n),at(n,n)
10386       do i=1,n
10387         do j=1,n
10388           at(j,i)=a(i,j)
10389         enddo
10390       enddo
10391       return
10392       end
10393 C---------------------------------------------------------------------------
10394       subroutine prodmat3(a1,a2,kk,transp,prod)
10395 !DIR$ INLINEALWAYS prodmat3
10396 #ifndef OSF
10397 cDEC$ ATTRIBUTES FORCEINLINE::prodmat3
10398 #endif
10399       implicit none
10400       integer i,j
10401       double precision a1(2,2),a2(2,2),a2t(2,2),kk(2,2),prod(2,2)
10402       logical transp
10403 crc      double precision auxmat(2,2),prod_(2,2)
10404
10405       if (transp) then
10406 crc        call transpose2(kk(1,1),auxmat(1,1))
10407 crc        call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
10408 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
10409
10410            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1)
10411      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
10412            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2)
10413      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
10414            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1)
10415      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
10416            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2)
10417      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
10418
10419       else
10420 crc        call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
10421 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
10422
10423            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1)
10424      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
10425            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2)
10426      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
10427            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1)
10428      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
10429            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2)
10430      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
10431
10432       endif
10433 c      call transpose2(a2(1,1),a2t(1,1))
10434
10435 crc      print *,transp
10436 crc      print *,((prod_(i,j),i=1,2),j=1,2)
10437 crc      print *,((prod(i,j),i=1,2),j=1,2)
10438
10439       return
10440       end
10441 CCC----------------------------------------------
10442       subroutine Eliptransfer(eliptran)
10443       implicit real*8 (a-h,o-z)
10444       include 'DIMENSIONS'
10445       include 'COMMON.GEO'
10446       include 'COMMON.VAR'
10447       include 'COMMON.LOCAL'
10448       include 'COMMON.CHAIN'
10449       include 'COMMON.DERIV'
10450       include 'COMMON.NAMES'
10451       include 'COMMON.INTERACT'
10452       include 'COMMON.IOUNITS'
10453       include 'COMMON.CALC'
10454       include 'COMMON.CONTROL'
10455       include 'COMMON.SPLITELE'
10456       include 'COMMON.SBRIDGE'
10457 C this is done by Adasko
10458 C      print *,"wchodze"
10459 C structure of box:
10460 C      water
10461 C--bordliptop-- buffore starts
10462 C--bufliptop--- here true lipid starts
10463 C      lipid
10464 C--buflipbot--- lipid ends buffore starts
10465 C--bordlipbot--buffore ends
10466       eliptran=0.0
10467       do i=ilip_start,ilip_end
10468 C       do i=1,1
10469         if (itype(i).eq.ntyp1) cycle
10470
10471         positi=(mod(((c(3,i)+c(3,i+1))/2.0d0),boxzsize))
10472         if (positi.le.0) positi=positi+boxzsize
10473 C        print *,i
10474 C first for peptide groups
10475 c for each residue check if it is in lipid or lipid water border area
10476        if ((positi.gt.bordlipbot)
10477      &.and.(positi.lt.bordliptop)) then
10478 C the energy transfer exist
10479         if (positi.lt.buflipbot) then
10480 C what fraction I am in
10481          fracinbuf=1.0d0-
10482      &        ((positi-bordlipbot)/lipbufthick)
10483 C lipbufthick is thickenes of lipid buffore
10484          sslip=sscalelip(fracinbuf)
10485          ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
10486          eliptran=eliptran+sslip*pepliptran
10487          gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
10488          gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
10489 C         gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
10490
10491 C        print *,"doing sccale for lower part"
10492 C         print *,i,sslip,fracinbuf,ssgradlip
10493         elseif (positi.gt.bufliptop) then
10494          fracinbuf=1.0d0-((bordliptop-positi)/lipbufthick)
10495          sslip=sscalelip(fracinbuf)
10496          ssgradlip=sscagradlip(fracinbuf)/lipbufthick
10497          eliptran=eliptran+sslip*pepliptran
10498          gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
10499          gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
10500 C         gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
10501 C          print *, "doing sscalefor top part"
10502 C         print *,i,sslip,fracinbuf,ssgradlip
10503         else
10504          eliptran=eliptran+pepliptran
10505 C         print *,"I am in true lipid"
10506         endif
10507 C       else
10508 C       eliptran=elpitran+0.0 ! I am in water
10509        endif
10510        enddo
10511 C       print *, "nic nie bylo w lipidzie?"
10512 C now multiply all by the peptide group transfer factor
10513 C       eliptran=eliptran*pepliptran
10514 C now the same for side chains
10515 CV       do i=1,1
10516        do i=ilip_start,ilip_end
10517         if (itype(i).eq.ntyp1) cycle
10518         positi=(mod(c(3,i+nres),boxzsize))
10519         if (positi.le.0) positi=positi+boxzsize
10520 C       print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop
10521 c for each residue check if it is in lipid or lipid water border area
10522 C       respos=mod(c(3,i+nres),boxzsize)
10523 C       print *,positi,bordlipbot,buflipbot
10524        if ((positi.gt.bordlipbot)
10525      & .and.(positi.lt.bordliptop)) then
10526 C the energy transfer exist
10527         if (positi.lt.buflipbot) then
10528          fracinbuf=1.0d0-
10529      &     ((positi-bordlipbot)/lipbufthick)
10530 C lipbufthick is thickenes of lipid buffore
10531          sslip=sscalelip(fracinbuf)
10532          ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
10533          eliptran=eliptran+sslip*liptranene(itype(i))
10534          gliptranx(3,i)=gliptranx(3,i)
10535      &+ssgradlip*liptranene(itype(i))
10536          gliptranc(3,i-1)= gliptranc(3,i-1)
10537      &+ssgradlip*liptranene(itype(i))
10538 C         print *,"doing sccale for lower part"
10539         elseif (positi.gt.bufliptop) then
10540          fracinbuf=1.0d0-
10541      &((bordliptop-positi)/lipbufthick)
10542          sslip=sscalelip(fracinbuf)
10543          ssgradlip=sscagradlip(fracinbuf)/lipbufthick
10544          eliptran=eliptran+sslip*liptranene(itype(i))
10545          gliptranx(3,i)=gliptranx(3,i)
10546      &+ssgradlip*liptranene(itype(i))
10547          gliptranc(3,i-1)= gliptranc(3,i-1)
10548      &+ssgradlip*liptranene(itype(i))
10549 C          print *, "doing sscalefor top part",sslip,fracinbuf
10550         else
10551          eliptran=eliptran+liptranene(itype(i))
10552 C         print *,"I am in true lipid"
10553         endif
10554         endif ! if in lipid or buffor
10555 C       else
10556 C       eliptran=elpitran+0.0 ! I am in water
10557        enddo
10558        return
10559        end
10560 C---------------------------------------------------------
10561 C AFM soubroutine for constant force
10562        subroutine AFMforce(Eafmforce)
10563        implicit real*8 (a-h,o-z)
10564       include 'DIMENSIONS'
10565       include 'COMMON.GEO'
10566       include 'COMMON.VAR'
10567       include 'COMMON.LOCAL'
10568       include 'COMMON.CHAIN'
10569       include 'COMMON.DERIV'
10570       include 'COMMON.NAMES'
10571       include 'COMMON.INTERACT'
10572       include 'COMMON.IOUNITS'
10573       include 'COMMON.CALC'
10574       include 'COMMON.CONTROL'
10575       include 'COMMON.SPLITELE'
10576       include 'COMMON.SBRIDGE'
10577       real*8 diffafm(3)
10578       dist=0.0d0
10579       Eafmforce=0.0d0
10580       do i=1,3
10581       diffafm(i)=c(i,afmend)-c(i,afmbeg)
10582       dist=dist+diffafm(i)**2
10583       enddo
10584       dist=dsqrt(dist)
10585       Eafmforce=-forceAFMconst*(dist-distafminit)
10586       do i=1,3
10587       gradafm(i,afmend-1)=-forceAFMconst*diffafm(i)/dist
10588       gradafm(i,afmbeg-1)=forceAFMconst*diffafm(i)/dist
10589       enddo
10590 C      print *,'AFM',Eafmforce
10591       return
10592       end
10593 C---------------------------------------------------------
10594 C AFM subroutine with pseudoconstant velocity
10595        subroutine AFMvel(Eafmforce)
10596        implicit real*8 (a-h,o-z)
10597       include 'DIMENSIONS'
10598       include 'COMMON.GEO'
10599       include 'COMMON.VAR'
10600       include 'COMMON.LOCAL'
10601       include 'COMMON.CHAIN'
10602       include 'COMMON.DERIV'
10603       include 'COMMON.NAMES'
10604       include 'COMMON.INTERACT'
10605       include 'COMMON.IOUNITS'
10606       include 'COMMON.CALC'
10607       include 'COMMON.CONTROL'
10608       include 'COMMON.SPLITELE'
10609       include 'COMMON.SBRIDGE'
10610       real*8 diffafm(3)
10611 C Only for check grad COMMENT if not used for checkgrad
10612 C      totT=3.0d0
10613 C--------------------------------------------------------
10614 C      print *,"wchodze"
10615       dist=0.0d0
10616       Eafmforce=0.0d0
10617       do i=1,3
10618       diffafm(i)=c(i,afmend)-c(i,afmbeg)
10619       dist=dist+diffafm(i)**2
10620       enddo
10621       dist=dsqrt(dist)
10622       Eafmforce=0.5d0*forceAFMconst
10623      & *(distafminit+totTafm*velAFMconst-dist)**2
10624 C      Eafmforce=-forceAFMconst*(dist-distafminit)
10625       do i=1,3
10626       gradafm(i,afmend-1)=-forceAFMconst*
10627      &(distafminit+totTafm*velAFMconst-dist)
10628      &*diffafm(i)/dist
10629       gradafm(i,afmbeg-1)=forceAFMconst*
10630      &(distafminit+totTafm*velAFMconst-dist)
10631      &*diffafm(i)/dist
10632       enddo
10633 C      print *,'AFM',Eafmforce,totTafm*velAFMconst,dist
10634       return
10635       end
10636 C-----------------------------------------------------------
10637 C first for shielding is setting of function of side-chains
10638        subroutine set_shield_fac
10639       implicit real*8 (a-h,o-z)
10640       include 'DIMENSIONS'
10641       include 'COMMON.CHAIN'
10642       include 'COMMON.DERIV'
10643       include 'COMMON.IOUNITS'
10644       include 'COMMON.SHIELD'
10645       include 'COMMON.INTERACT'
10646 C this is the squar root 77 devided by 81 the epislion in lipid (in protein)
10647       double precision div77_81/0.974996043d0/,
10648      &div4_81/0.2222222222d0/,sh_frac_dist_grad(3)
10649
10650 C the vector between center of side_chain and peptide group
10651        double precision pep_side(3),long,side_calf(3),
10652      &pept_group(3),costhet_grad(3),cosphi_grad_long(3),
10653      &cosphi_grad_loc(3),pep_side_norm(3),side_calf_norm(3)
10654 C the line belowe needs to be changed for FGPROC>1
10655       do i=1,nres-1
10656       if ((itype(i).eq.ntyp1).and.itype(i+1).eq.ntyp1) cycle
10657       ishield_list(i)=0
10658 Cif there two consequtive dummy atoms there is no peptide group between them
10659 C the line below has to be changed for FGPROC>1
10660       VolumeTotal=0.0
10661       do k=1,nres
10662        if ((itype(k).eq.ntyp1).or.(itype(k).eq.10)) cycle
10663        dist_pep_side=0.0
10664        dist_side_calf=0.0
10665        do j=1,3
10666 C first lets set vector conecting the ithe side-chain with kth side-chain
10667       pep_side(j)=c(j,k+nres)-(c(j,i)+c(j,i+1))/2.0d0
10668 C      pep_side(j)=2.0d0
10669 C and vector conecting the side-chain with its proper calfa
10670       side_calf(j)=c(j,k+nres)-c(j,k)
10671 C      side_calf(j)=2.0d0
10672       pept_group(j)=c(j,i)-c(j,i+1)
10673 C lets have their lenght
10674       dist_pep_side=pep_side(j)**2+dist_pep_side
10675       dist_side_calf=dist_side_calf+side_calf(j)**2
10676       dist_pept_group=dist_pept_group+pept_group(j)**2
10677       enddo
10678        dist_pep_side=dsqrt(dist_pep_side)
10679        dist_pept_group=dsqrt(dist_pept_group)
10680        dist_side_calf=dsqrt(dist_side_calf)
10681       do j=1,3
10682         pep_side_norm(j)=pep_side(j)/dist_pep_side
10683         side_calf_norm(j)=dist_side_calf
10684       enddo
10685 C now sscale fraction
10686        sh_frac_dist=-(dist_pep_side-rpp(1,1)-buff_shield)/buff_shield
10687 C       print *,buff_shield,"buff"
10688 C now sscale
10689         if (sh_frac_dist.le.0.0) cycle
10690 C If we reach here it means that this side chain reaches the shielding sphere
10691 C Lets add him to the list for gradient
10692         ishield_list(i)=ishield_list(i)+1
10693 C ishield_list is a list of non 0 side-chain that contribute to factor gradient
10694 C this list is essential otherwise problem would be O3
10695         shield_list(ishield_list(i),i)=k
10696 C Lets have the sscale value
10697         if (sh_frac_dist.gt.1.0) then
10698          scale_fac_dist=1.0d0
10699          do j=1,3
10700          sh_frac_dist_grad(j)=0.0d0
10701          enddo
10702         else
10703          scale_fac_dist=-sh_frac_dist*sh_frac_dist
10704      &                   *(2.0*sh_frac_dist-3.0d0)
10705          fac_help_scale=6.0*(sh_frac_dist-sh_frac_dist**2)
10706      &                  /dist_pep_side/buff_shield*0.5
10707 C remember for the final gradient multiply sh_frac_dist_grad(j)
10708 C for side_chain by factor -2 !
10709          do j=1,3
10710          sh_frac_dist_grad(j)=fac_help_scale*pep_side(j)
10711 C         print *,"jestem",scale_fac_dist,fac_help_scale,
10712 C     &                    sh_frac_dist_grad(j)
10713          enddo
10714         endif
10715 C        if ((i.eq.3).and.(k.eq.2)) then
10716 C        print *,i,sh_frac_dist,dist_pep,fac_help_scale,scale_fac_dist
10717 C     & ,"TU"
10718 C        endif
10719
10720 C this is what is now we have the distance scaling now volume...
10721       short=short_r_sidechain(itype(k))
10722       long=long_r_sidechain(itype(k))
10723       costhet=1.0d0/dsqrt(1.0+short**2/dist_pep_side**2)
10724 C now costhet_grad
10725 C       costhet=0.0d0
10726        costhet_fac=costhet**3*short**2*(-0.5)/dist_pep_side**4
10727 C       costhet_fac=0.0d0
10728        do j=1,3
10729          costhet_grad(j)=costhet_fac*pep_side(j)
10730        enddo
10731 C remember for the final gradient multiply costhet_grad(j)
10732 C for side_chain by factor -2 !
10733 C fac alfa is angle between CB_k,CA_k, CA_i,CA_i+1
10734 C pep_side0pept_group is vector multiplication
10735       pep_side0pept_group=0.0
10736       do j=1,3
10737       pep_side0pept_group=pep_side0pept_group+pep_side(j)*side_calf(j)
10738       enddo
10739       cosalfa=(pep_side0pept_group/
10740      & (dist_pep_side*dist_side_calf))
10741       fac_alfa_sin=1.0-cosalfa**2
10742       fac_alfa_sin=dsqrt(fac_alfa_sin)
10743       rkprim=fac_alfa_sin*(long-short)+short
10744 C now costhet_grad
10745        cosphi=1.0d0/dsqrt(1.0+rkprim**2/dist_pep_side**2)
10746        cosphi_fac=cosphi**3*rkprim**2*(-0.5)/dist_pep_side**4
10747
10748        do j=1,3
10749          cosphi_grad_long(j)=cosphi_fac*pep_side(j)
10750      &+cosphi**3*0.5/dist_pep_side**2*(-rkprim)
10751      &*(long-short)/fac_alfa_sin*cosalfa/
10752      &((dist_pep_side*dist_side_calf))*
10753      &((side_calf(j))-cosalfa*
10754      &((pep_side(j)/dist_pep_side)*dist_side_calf))
10755
10756         cosphi_grad_loc(j)=cosphi**3*0.5/dist_pep_side**2*(-rkprim)
10757      &*(long-short)/fac_alfa_sin*cosalfa
10758      &/((dist_pep_side*dist_side_calf))*
10759      &(pep_side(j)-
10760      &cosalfa*side_calf(j)/dist_side_calf*dist_pep_side)
10761        enddo
10762
10763       VofOverlap=VSolvSphere/2.0d0*(1.0-costhet)*(1.0-cosphi)
10764      &                    /VSolvSphere_div
10765 C now the gradient...
10766 C grad_shield is gradient of Calfa for peptide groups
10767       do j=1,3
10768       grad_shield(j,i)=grad_shield(j,i)
10769 C gradient po skalowaniu
10770      &                +(sh_frac_dist_grad(j)
10771 C  gradient po costhet
10772      &-scale_fac_dist*costhet_grad(j)/(1.0-costhet)
10773      &-scale_fac_dist*(cosphi_grad_long(j))
10774      &/(1.0-cosphi) )*div77_81
10775      &*VofOverlap
10776 C grad_shield_side is Cbeta sidechain gradient
10777       grad_shield_side(j,ishield_list(i),i)=
10778      &        (sh_frac_dist_grad(j)*-2.0d0
10779      &       +scale_fac_dist*costhet_grad(j)*2.0d0/(1.0-costhet)
10780      &       +scale_fac_dist*(cosphi_grad_long(j))
10781      &        *2.0d0/(1.0-cosphi))
10782      &        *div77_81*VofOverlap
10783
10784        grad_shield_loc(j,ishield_list(i),i)=
10785      &   scale_fac_dist*cosphi_grad_loc(j)
10786      &        *2.0d0/(1.0-cosphi)
10787      &        *div77_81*VofOverlap
10788       enddo
10789       VolumeTotal=VolumeTotal+VofOverlap*scale_fac_dist
10790       enddo
10791       fac_shield(i)=VolumeTotal*div77_81+div4_81
10792 C      write(2,*) "TOTAL VOLUME",i,VolumeTotal,fac_shield(i)
10793       enddo
10794       return
10795       end
10796