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       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
 550         enddo
 551       enddo
 552 #else
 553       do i=0,nct
 554         do j=1,3
 555           gradbufc(j,i)=wsc*gvdwc(j,i)+
 556      &                wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+
 557      &                welec*gelc_long(j,i)+
 558      &                wbond*gradb(j,i)+
 559      &                wel_loc*gel_loc_long(j,i)+
 560      &                wcorr*gradcorr_long(j,i)+
 561      &                wcorr5*gradcorr5_long(j,i)+
 562      &                wcorr6*gradcorr6_long(j,i)+
 563      &                wturn6*gcorr6_turn_long(j,i)+
 564      &                wstrain*ghpbc(j,i)
 565      &                +wliptran*gliptranc(j,i)
 566      &                +gradafm(j,i)
 567
 568         enddo
 569       enddo
 570 #endif
 571 #ifdef MPI
 572       if (nfgtasks.gt.1) then
 573       time00=MPI_Wtime()
 574 #ifdef DEBUG
 575       write (iout,*) "gradbufc before allreduce"
 576       do i=1,nres
 577         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 578       enddo
 579       call flush(iout)
 580 #endif
 581       do i=0,nres
 582         do j=1,3
 583           gradbufc_sum(j,i)=gradbufc(j,i)
 584         enddo
 585       enddo
 586 c      call MPI_AllReduce(gradbufc(1,1),gradbufc_sum(1,1),3*nres,
 587 c     &    MPI_DOUBLE_PRECISION,MPI_SUM,FG_COMM,IERR)
 588 c      time_reduce=time_reduce+MPI_Wtime()-time00
 589 #ifdef DEBUG
 590 c      write (iout,*) "gradbufc_sum after allreduce"
 591 c      do i=1,nres
 592 c        write (iout,'(i3,3f10.5)') i,(gradbufc_sum(j,i),j=1,3)
 593 c      enddo
 594 c      call flush(iout)
 595 #endif
 596 #ifdef TIMING
 597 c      time_allreduce=time_allreduce+MPI_Wtime()-time00
 598 #endif
 599       do i=nnt,nres
 600         do k=1,3
 601           gradbufc(k,i)=0.0d0
 602         enddo
 603       enddo
 604 #ifdef DEBUG
 605       write (iout,*) "igrad_start",igrad_start," igrad_end",igrad_end
 606       write (iout,*) (i," jgrad_start",jgrad_start(i),
 607      &                  " jgrad_end  ",jgrad_end(i),
 608      &                  i=igrad_start,igrad_end)
 609 #endif
 610 c
 611 c Obsolete and inefficient code; we can make the effort O(n) and, therefore,
 612 c do not parallelize this part.
 613 c
 614 c      do i=igrad_start,igrad_end
 615 c        do j=jgrad_start(i),jgrad_end(i)
 616 c          do k=1,3
 617 c            gradbufc(k,i)=gradbufc(k,i)+gradbufc_sum(k,j)
 618 c          enddo
 619 c        enddo
 620 c      enddo
 621       do j=1,3
 622         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
 623       enddo
 624       do i=nres-2,-1,-1
 625         do j=1,3
 626           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
 627         enddo
 628       enddo
 629 #ifdef DEBUG
 630       write (iout,*) "gradbufc after summing"
 631       do i=1,nres
 632         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 633       enddo
 634       call flush(iout)
 635 #endif
 636       else
 637 #endif
 638 #ifdef DEBUG
 639       write (iout,*) "gradbufc"
 640       do i=1,nres
 641         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 642       enddo
 643       call flush(iout)
 644 #endif
 645       do i=-1,nres
 646         do j=1,3
 647           gradbufc_sum(j,i)=gradbufc(j,i)
 648           gradbufc(j,i)=0.0d0
 649         enddo
 650       enddo
 651       do j=1,3
 652         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
 653       enddo
 654       do i=nres-2,-1,-1
 655         do j=1,3
 656           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
 657         enddo
 658       enddo
 659 c      do i=nnt,nres-1
 660 c        do k=1,3
 661 c          gradbufc(k,i)=0.0d0
 662 c        enddo
 663 c        do j=i+1,nres
 664 c          do k=1,3
 665 c            gradbufc(k,i)=gradbufc(k,i)+gradbufc(k,j)
 666 c          enddo
 667 c        enddo
 668 c      enddo
 669 #ifdef DEBUG
 670       write (iout,*) "gradbufc after summing"
 671       do i=1,nres
 672         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 673       enddo
 674       call flush(iout)
 675 #endif
 676 #ifdef MPI
 677       endif
 678 #endif
 679       do k=1,3
 680         gradbufc(k,nres)=0.0d0
 681       enddo
 682       do i=-1,nct
 683         do j=1,3
 684 #ifdef SPLITELE
 685           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+
 686      &                wel_loc*gel_loc(j,i)+
 687      &                0.5d0*(wscp*gvdwc_scpp(j,i)+
 688      &                welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+
 689      &                wel_loc*gel_loc_long(j,i)+
 690      &                wcorr*gradcorr_long(j,i)+
 691      &                wcorr5*gradcorr5_long(j,i)+
 692      &                wcorr6*gradcorr6_long(j,i)+
 693      &                wturn6*gcorr6_turn_long(j,i))+
 694      &                wbond*gradb(j,i)+
 695      &                wcorr*gradcorr(j,i)+
 696      &                wturn3*gcorr3_turn(j,i)+
 697      &                wturn4*gcorr4_turn(j,i)+
 698      &                wcorr5*gradcorr5(j,i)+
 699      &                wcorr6*gradcorr6(j,i)+
 700      &                wturn6*gcorr6_turn(j,i)+
 701      &                wsccor*gsccorc(j,i)
 702      &               +wscloc*gscloc(j,i)
 703      &               +wliptran*gliptranc(j,i)
 704      &                +gradafm(j,i)
 705 #else
 706           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+
 707      &                wel_loc*gel_loc(j,i)+
 708      &                0.5d0*(wscp*gvdwc_scpp(j,i)+
 709      &                welec*gelc_long(j,i)
 710      &                wel_loc*gel_loc_long(j,i)+
 711      &                wcorr*gcorr_long(j,i)+
 712      &                wcorr5*gradcorr5_long(j,i)+
 713      &                wcorr6*gradcorr6_long(j,i)+
 714      &                wturn6*gcorr6_turn_long(j,i))+
 715      &                wbond*gradb(j,i)+
 716      &                wcorr*gradcorr(j,i)+
 717      &                wturn3*gcorr3_turn(j,i)+
 718      &                wturn4*gcorr4_turn(j,i)+
 719      &                wcorr5*gradcorr5(j,i)+
 720      &                wcorr6*gradcorr6(j,i)+
 721      &                wturn6*gcorr6_turn(j,i)+
 722      &                wsccor*gsccorc(j,i)
 723      &               +wscloc*gscloc(j,i)
 724      &               +wliptran*gliptranc(j,i)
 725      &                +gradafm(j,i)
 726
 727 #endif
 728           gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+
 729      &                  wbond*gradbx(j,i)+
 730      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
 731      &                  wsccor*gsccorx(j,i)
 732      &                 +wscloc*gsclocx(j,i)
 733      &                 +wliptran*gliptranx(j,i)
 734         enddo
 735       enddo
 736 #ifdef DEBUG
 737       write (iout,*) "gloc before adding corr"
 738       do i=1,4*nres
 739         write (iout,*) i,gloc(i,icg)
 740       enddo
 741 #endif
 742       do i=1,nres-3
 743         gloc(i,icg)=gloc(i,icg)+wcorr*gcorr_loc(i)
 744      &   +wcorr5*g_corr5_loc(i)
 745      &   +wcorr6*g_corr6_loc(i)
 746      &   +wturn4*gel_loc_turn4(i)
 747      &   +wturn3*gel_loc_turn3(i)
 748      &   +wturn6*gel_loc_turn6(i)
 749      &   +wel_loc*gel_loc_loc(i)
 750       enddo
 751 #ifdef DEBUG
 752       write (iout,*) "gloc after adding corr"
 753       do i=1,4*nres
 754         write (iout,*) i,gloc(i,icg)
 755       enddo
 756 #endif
 757 #ifdef MPI
 758       if (nfgtasks.gt.1) then
 759         do j=1,3
 760           do i=1,nres
 761             gradbufc(j,i)=gradc(j,i,icg)
 762             gradbufx(j,i)=gradx(j,i,icg)
 763           enddo
 764         enddo
 765         do i=1,4*nres
 766           glocbuf(i)=gloc(i,icg)
 767         enddo
 768 c#define DEBUG
 769 #ifdef DEBUG
 770       write (iout,*) "gloc_sc before reduce"
 771       do i=1,nres
 772        do j=1,1
 773         write (iout,*) i,j,gloc_sc(j,i,icg)
 774        enddo
 775       enddo
 776 #endif
 777 c#undef DEBUG
 778         do i=1,nres
 779          do j=1,3
 780           gloc_scbuf(j,i)=gloc_sc(j,i,icg)
 781          enddo
 782         enddo
 783         time00=MPI_Wtime()
 784         call MPI_Barrier(FG_COMM,IERR)
 785         time_barrier_g=time_barrier_g+MPI_Wtime()-time00
 786         time00=MPI_Wtime()
 787         call MPI_Reduce(gradbufc(1,1),gradc(1,1,icg),3*nres,
 788      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 789         call MPI_Reduce(gradbufx(1,1),gradx(1,1,icg),3*nres,
 790      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 791         call MPI_Reduce(glocbuf(1),gloc(1,icg),4*nres,
 792      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 793         time_reduce=time_reduce+MPI_Wtime()-time00
 794         call MPI_Reduce(gloc_scbuf(1,1),gloc_sc(1,1,icg),3*nres,
 795      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 796         time_reduce=time_reduce+MPI_Wtime()-time00
 797 c#define DEBUG
 798 #ifdef DEBUG
 799       write (iout,*) "gloc_sc after reduce"
 800       do i=1,nres
 801        do j=1,1
 802         write (iout,*) i,j,gloc_sc(j,i,icg)
 803        enddo
 804       enddo
 805 #endif
 806 c#undef DEBUG
 807 #ifdef DEBUG
 808       write (iout,*) "gloc after reduce"
 809       do i=1,4*nres
 810         write (iout,*) i,gloc(i,icg)
 811       enddo
 812 #endif
 813       endif
 814 #endif
 815       if (gnorm_check) then
 816 c
 817 c Compute the maximum elements of the gradient
 818 c
 819       gvdwc_max=0.0d0
 820       gvdwc_scp_max=0.0d0
 821       gelc_max=0.0d0
 822       gvdwpp_max=0.0d0
 823       gradb_max=0.0d0
 824       ghpbc_max=0.0d0
 825       gradcorr_max=0.0d0
 826       gel_loc_max=0.0d0
 827       gcorr3_turn_max=0.0d0
 828       gcorr4_turn_max=0.0d0
 829       gradcorr5_max=0.0d0
 830       gradcorr6_max=0.0d0
 831       gcorr6_turn_max=0.0d0
 832       gsccorc_max=0.0d0
 833       gscloc_max=0.0d0
 834       gvdwx_max=0.0d0
 835       gradx_scp_max=0.0d0
 836       ghpbx_max=0.0d0
 837       gradxorr_max=0.0d0
 838       gsccorx_max=0.0d0
 839       gsclocx_max=0.0d0
 840       do i=1,nct
 841         gvdwc_norm=dsqrt(scalar(gvdwc(1,i),gvdwc(1,i)))
 842         if (gvdwc_norm.gt.gvdwc_max) gvdwc_max=gvdwc_norm
 843         gvdwc_scp_norm=dsqrt(scalar(gvdwc_scp(1,i),gvdwc_scp(1,i)))
 844         if (gvdwc_scp_norm.gt.gvdwc_scp_max)
 845      &   gvdwc_scp_max=gvdwc_scp_norm
 846         gelc_norm=dsqrt(scalar(gelc(1,i),gelc(1,i)))
 847         if (gelc_norm.gt.gelc_max) gelc_max=gelc_norm
 848         gvdwpp_norm=dsqrt(scalar(gvdwpp(1,i),gvdwpp(1,i)))
 849         if (gvdwpp_norm.gt.gvdwpp_max) gvdwpp_max=gvdwpp_norm
 850         gradb_norm=dsqrt(scalar(gradb(1,i),gradb(1,i)))
 851         if (gradb_norm.gt.gradb_max) gradb_max=gradb_norm
 852         ghpbc_norm=dsqrt(scalar(ghpbc(1,i),ghpbc(1,i)))
 853         if (ghpbc_norm.gt.ghpbc_max) ghpbc_max=ghpbc_norm
 854         gradcorr_norm=dsqrt(scalar(gradcorr(1,i),gradcorr(1,i)))
 855         if (gradcorr_norm.gt.gradcorr_max) gradcorr_max=gradcorr_norm
 856         gel_loc_norm=dsqrt(scalar(gel_loc(1,i),gel_loc(1,i)))
 857         if (gel_loc_norm.gt.gel_loc_max) gel_loc_max=gel_loc_norm
 858         gcorr3_turn_norm=dsqrt(scalar(gcorr3_turn(1,i),
 859      &    gcorr3_turn(1,i)))
 860         if (gcorr3_turn_norm.gt.gcorr3_turn_max)
 861      &    gcorr3_turn_max=gcorr3_turn_norm
 862         gcorr4_turn_norm=dsqrt(scalar(gcorr4_turn(1,i),
 863      &    gcorr4_turn(1,i)))
 864         if (gcorr4_turn_norm.gt.gcorr4_turn_max)
 865      &    gcorr4_turn_max=gcorr4_turn_norm
 866         gradcorr5_norm=dsqrt(scalar(gradcorr5(1,i),gradcorr5(1,i)))
 867         if (gradcorr5_norm.gt.gradcorr5_max)
 868      &    gradcorr5_max=gradcorr5_norm
 869         gradcorr6_norm=dsqrt(scalar(gradcorr6(1,i),gradcorr6(1,i)))
 870         if (gradcorr6_norm.gt.gradcorr6_max) gcorr6_max=gradcorr6_norm
 871         gcorr6_turn_norm=dsqrt(scalar(gcorr6_turn(1,i),
 872      &    gcorr6_turn(1,i)))
 873         if (gcorr6_turn_norm.gt.gcorr6_turn_max)
 874      &    gcorr6_turn_max=gcorr6_turn_norm
 875         gsccorr_norm=dsqrt(scalar(gsccorc(1,i),gsccorc(1,i)))
 876         if (gsccorr_norm.gt.gsccorr_max) gsccorr_max=gsccorr_norm
 877         gscloc_norm=dsqrt(scalar(gscloc(1,i),gscloc(1,i)))
 878         if (gscloc_norm.gt.gscloc_max) gscloc_max=gscloc_norm
 879         gvdwx_norm=dsqrt(scalar(gvdwx(1,i),gvdwx(1,i)))
 880         if (gvdwx_norm.gt.gvdwx_max) gvdwx_max=gvdwx_norm
 881         gradx_scp_norm=dsqrt(scalar(gradx_scp(1,i),gradx_scp(1,i)))
 882         if (gradx_scp_norm.gt.gradx_scp_max)
 883      &    gradx_scp_max=gradx_scp_norm
 884         ghpbx_norm=dsqrt(scalar(ghpbx(1,i),ghpbx(1,i)))
 885         if (ghpbx_norm.gt.ghpbx_max) ghpbx_max=ghpbx_norm
 886         gradxorr_norm=dsqrt(scalar(gradxorr(1,i),gradxorr(1,i)))
 887         if (gradxorr_norm.gt.gradxorr_max) gradxorr_max=gradxorr_norm
 888         gsccorrx_norm=dsqrt(scalar(gsccorx(1,i),gsccorx(1,i)))
 889         if (gsccorrx_norm.gt.gsccorrx_max) gsccorrx_max=gsccorrx_norm
 890         gsclocx_norm=dsqrt(scalar(gsclocx(1,i),gsclocx(1,i)))
 891         if (gsclocx_norm.gt.gsclocx_max) gsclocx_max=gsclocx_norm
 892       enddo
 893       if (gradout) then
 894 #ifdef AIX
 895         open(istat,file=statname,position="append")
 896 #else
 897         open(istat,file=statname,access="append")
 898 #endif
 899         write (istat,'(1h#,21f10.2)') gvdwc_max,gvdwc_scp_max,
 900      &     gelc_max,gvdwpp_max,gradb_max,ghpbc_max,
 901      &     gradcorr_max,gel_loc_max,gcorr3_turn_max,gcorr4_turn_max,
 902      &     gradcorr5_max,gradcorr6_max,gcorr6_turn_max,gsccorc_max,
 903      &     gscloc_max,gvdwx_max,gradx_scp_max,ghpbx_max,gradxorr_max,
 904      &     gsccorx_max,gsclocx_max
 905         close(istat)
 906         if (gvdwc_max.gt.1.0d4) then
 907           write (iout,*) "gvdwc gvdwx gradb gradbx"
 908           do i=nnt,nct
 909             write(iout,'(i5,4(3f10.2,5x))') i,(gvdwc(j,i),gvdwx(j,i),
 910      &        gradb(j,i),gradbx(j,i),j=1,3)
 911           enddo
 912           call pdbout(0.0d0,'cipiszcze',iout)
 913           call flush(iout)
 914         endif
 915       endif
 916       endif
 917 #ifdef DEBUG
 918       write (iout,*) "gradc gradx gloc"
 919       do i=1,nres
 920         write (iout,'(i5,3f10.5,5x,3f10.5,5x,f10.5)')
 921      &   i,(gradc(j,i,icg),j=1,3),(gradx(j,i,icg),j=1,3),gloc(i,icg)
 922       enddo
 923 #endif
 924 #ifdef TIMING
 925       time_sumgradient=time_sumgradient+MPI_Wtime()-time01
 926 #endif
 927       return
 928       end
 929 c-------------------------------------------------------------------------------
 930       subroutine rescale_weights(t_bath)
 931       implicit real*8 (a-h,o-z)
 932       include 'DIMENSIONS'
 933       include 'COMMON.IOUNITS'
 934       include 'COMMON.FFIELD'
 935       include 'COMMON.SBRIDGE'
 936       double precision kfac /2.4d0/
 937       double precision x,x2,x3,x4,x5,licznik /1.12692801104297249644/
 938 c      facT=temp0/t_bath
 939 c      facT=2*temp0/(t_bath+temp0)
 940       if (rescale_mode.eq.0) then
 941         facT=1.0d0
 942         facT2=1.0d0
 943         facT3=1.0d0
 944         facT4=1.0d0
 945         facT5=1.0d0
 946       else if (rescale_mode.eq.1) then
 947         facT=kfac/(kfac-1.0d0+t_bath/temp0)
 948         facT2=kfac**2/(kfac**2-1.0d0+(t_bath/temp0)**2)
 949         facT3=kfac**3/(kfac**3-1.0d0+(t_bath/temp0)**3)
 950         facT4=kfac**4/(kfac**4-1.0d0+(t_bath/temp0)**4)
 951         facT5=kfac**5/(kfac**5-1.0d0+(t_bath/temp0)**5)
 952       else if (rescale_mode.eq.2) then
 953         x=t_bath/temp0
 954         x2=x*x
 955         x3=x2*x
 956         x4=x3*x
 957         x5=x4*x
 958         facT=licznik/dlog(dexp(x)+dexp(-x))
 959         facT2=licznik/dlog(dexp(x2)+dexp(-x2))
 960         facT3=licznik/dlog(dexp(x3)+dexp(-x3))
 961         facT4=licznik/dlog(dexp(x4)+dexp(-x4))
 962         facT5=licznik/dlog(dexp(x5)+dexp(-x5))
 963       else
 964         write (iout,*) "Wrong RESCALE_MODE",rescale_mode
 965         write (*,*) "Wrong RESCALE_MODE",rescale_mode
 966 #ifdef MPI
 967        call MPI_Finalize(MPI_COMM_WORLD,IERROR)
 968 #endif
 969        stop 555
 970       endif
 971       welec=weights(3)*fact
 972       wcorr=weights(4)*fact3
 973       wcorr5=weights(5)*fact4
 974       wcorr6=weights(6)*fact5
 975       wel_loc=weights(7)*fact2
 976       wturn3=weights(8)*fact2
 977       wturn4=weights(9)*fact3
 978       wturn6=weights(10)*fact5
 979       wtor=weights(13)*fact
 980       wtor_d=weights(14)*fact2
 981       wsccor=weights(21)*fact
 982
 983       return
 984       end
 985 C------------------------------------------------------------------------
 986       subroutine enerprint(energia)
 987       implicit real*8 (a-h,o-z)
 988       include 'DIMENSIONS'
 989       include 'COMMON.IOUNITS'
 990       include 'COMMON.FFIELD'
 991       include 'COMMON.SBRIDGE'
 992       include 'COMMON.MD'
 993       double precision energia(0:n_ene)
 994       etot=energia(0)
 995       evdw=energia(1)
 996       evdw2=energia(2)
 997 #ifdef SCP14
 998       evdw2=energia(2)+energia(18)
 999 #else
1000       evdw2=energia(2)
1001 #endif
1002       ees=energia(3)
1003 #ifdef SPLITELE
1004       evdw1=energia(16)
1005 #endif
1006       ecorr=energia(4)
1007       ecorr5=energia(5)
1008       ecorr6=energia(6)
1009       eel_loc=energia(7)
1010       eello_turn3=energia(8)
1011       eello_turn4=energia(9)
1012       eello_turn6=energia(10)
1013       ebe=energia(11)
1014       escloc=energia(12)
1015       etors=energia(13)
1016       etors_d=energia(14)
1017       ehpb=energia(15)
1018       edihcnstr=energia(19)
1019       estr=energia(17)
1020       Uconst=energia(20)
1021       esccor=energia(21)
1022       eliptran=energia(22)
1023       Eafmforce=energia(23)
1024       ethetacnstr=energia(24)
1025 #ifdef SPLITELE
1026       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,evdw1,wvdwpp,
1027      &  estr,wbond,ebe,wang,
1028      &  escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,
1029      &  ecorr,wcorr,
1030      &  ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,
1031      &  eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccro,edihcnstr,
1032      &  ethetacnstr,ebr*nss,Uconst,eliptran,wliptran,Eafmforc,
1033      &  etot
1034    10 format (/'Virtual-chain energies:'//
1035      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
1036      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
1037      & 'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/
1038      & 'EVDWPP=',1pE16.6,' WEIGHT=',1pD16.6,' (p-p VDW)'/
1039      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
1040      & 'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
1041      & 'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
1042      & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
1043      & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
1044      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6,
1045      & ' (SS bridges & dist. cnstr.)'/
1046      & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1047      & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1048      & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1049      & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
1050      & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
1051      & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
1052      & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
1053      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
1054      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
1055      & 'ETHETC= ',1pE16.6,' (valence angle constraints)'/
1056      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
1057      & 'UCONST= ',1pE16.6,' (Constraint energy)'/
1058      & 'ELT=',1pE16.6, ' WEIGHT=',1pD16.6,' (Lipid transfer energy)'/
1059      & 'EAFM=  ',1pE16.6,' (atomic-force microscopy)'/
1060      & 'ETOT=  ',1pE16.6,' (total)')
1061
1062 #else
1063       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,
1064      &  estr,wbond,ebe,wang,
1065      &  escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,
1066      &  ecorr,wcorr,
1067      &  ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,
1068      &  eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccro,edihcnstr,
1069      &  ethetacnstr,ebr*nss,Uconst,eliptran,wliptran,Eafmforc,
1070      &  etot
1071    10 format (/'Virtual-chain energies:'//
1072      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
1073      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
1074      & 'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/
1075      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
1076      & 'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
1077      & 'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
1078      & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
1079      & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
1080      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6,
1081      & ' (SS bridges & dist. cnstr.)'/
1082      & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1083      & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1084      & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1085      & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
1086      & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
1087      & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
1088      & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
1089      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
1090      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
1091      & 'ETHETC= ',1pE16.6,' (valence angle constraints)'/
1092      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
1093      & 'UCONST=',1pE16.6,' (Constraint energy)'/
1094      & 'ELT=',1pE16.6, ' WEIGHT=',1pD16.6,' (Lipid transfer energy)'/
1095      & 'EAFM=  ',1pE16.6,' (atomic-force microscopy)'/
1096      & 'ETOT=  ',1pE16.6,' (total)')
1097 #endif
1098       return
1099       end
1100 C-----------------------------------------------------------------------
1101       subroutine elj(evdw)
1102 C
1103 C This subroutine calculates the interaction energy of nonbonded side chains
1104 C assuming the LJ potential of interaction.
1105 C
1106       implicit real*8 (a-h,o-z)
1107       include 'DIMENSIONS'
1108       parameter (accur=1.0d-10)
1109       include 'COMMON.GEO'
1110       include 'COMMON.VAR'
1111       include 'COMMON.LOCAL'
1112       include 'COMMON.CHAIN'
1113       include 'COMMON.DERIV'
1114       include 'COMMON.INTERACT'
1115       include 'COMMON.TORSION'
1116       include 'COMMON.SBRIDGE'
1117       include 'COMMON.NAMES'
1118       include 'COMMON.IOUNITS'
1119       include 'COMMON.CONTACTS'
1120       dimension gg(3)
1121 c      write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
1122       evdw=0.0D0
1123       do i=iatsc_s,iatsc_e
1124         itypi=iabs(itype(i))
1125         if (itypi.eq.ntyp1) cycle
1126         itypi1=iabs(itype(i+1))
1127         xi=c(1,nres+i)
1128         yi=c(2,nres+i)
1129         zi=c(3,nres+i)
1130 C Change 12/1/95
1131         num_conti=0
1132 C
1133 C Calculate SC interaction energy.
1134 C
1135         do iint=1,nint_gr(i)
1136 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
1137 cd   &                  'iend=',iend(i,iint)
1138           do j=istart(i,iint),iend(i,iint)
1139             itypj=iabs(itype(j))
1140             if (itypj.eq.ntyp1) cycle
1141             xj=c(1,nres+j)-xi
1142             yj=c(2,nres+j)-yi
1143             zj=c(3,nres+j)-zi
1144 C Change 12/1/95 to calculate four-body interactions
1145             rij=xj*xj+yj*yj+zj*zj
1146             rrij=1.0D0/rij
1147 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
1148             eps0ij=eps(itypi,itypj)
1149             fac=rrij**expon2
1150 C have you changed here?
1151             e1=fac*fac*aa
1152             e2=fac*bb
1153             evdwij=e1+e2
1154 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1155 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1156 cd          write (iout,'(2(a3,i3,2x),6(1pd12.4)/2(3(1pd12.4),5x)/)')
1157 cd   &        restyp(itypi),i,restyp(itypj),j,a(itypi,itypj),
1158 cd   &        bb(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,epsi,sigm,
1159 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1160             evdw=evdw+evdwij
1161 C
1162 C Calculate the components of the gradient in DC and X
1163 C
1164             fac=-rrij*(e1+evdwij)
1165             gg(1)=xj*fac
1166             gg(2)=yj*fac
1167             gg(3)=zj*fac
1168             do k=1,3
1169               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1170               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1171               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1172               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1173             enddo
1174 cgrad            do k=i,j-1
1175 cgrad              do l=1,3
1176 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1177 cgrad              enddo
1178 cgrad            enddo
1179 C
1180 C 12/1/95, revised on 5/20/97
1181 C
1182 C Calculate the contact function. The ith column of the array JCONT will
1183 C contain the numbers of atoms that make contacts with the atom I (of numbers
1184 C greater than I). The arrays FACONT and GACONT will contain the values of
1185 C the contact function and its derivative.
1186 C
1187 C Uncomment next line, if the correlation interactions include EVDW explicitly.
1188 c           if (j.gt.i+1 .and. evdwij.le.0.0D0) then
1189 C Uncomment next line, if the correlation interactions are contact function only
1190             if (j.gt.i+1.and. eps0ij.gt.0.0D0) then
1191               rij=dsqrt(rij)
1192               sigij=sigma(itypi,itypj)
1193               r0ij=rs0(itypi,itypj)
1194 C
1195 C Check whether the SC's are not too far to make a contact.
1196 C
1197               rcut=1.5d0*r0ij
1198               call gcont(rij,rcut,1.0d0,0.2d0*rcut,fcont,fprimcont)
1199 C Add a new contact, if the SC's are close enough, but not too close (r<sigma).
1200 C
1201               if (fcont.gt.0.0D0) then
1202 C If the SC-SC distance if close to sigma, apply spline.
1203 cAdam           call gcont(-rij,-1.03d0*sigij,2.0d0*sigij,1.0d0,
1204 cAdam &             fcont1,fprimcont1)
1205 cAdam           fcont1=1.0d0-fcont1
1206 cAdam           if (fcont1.gt.0.0d0) then
1207 cAdam             fprimcont=fprimcont*fcont1+fcont*fprimcont1
1208 cAdam             fcont=fcont*fcont1
1209 cAdam           endif
1210 C Uncomment following 4 lines to have the geometric average of the epsilon0's
1211 cga             eps0ij=1.0d0/dsqrt(eps0ij)
1212 cga             do k=1,3
1213 cga               gg(k)=gg(k)*eps0ij
1214 cga             enddo
1215 cga             eps0ij=-evdwij*eps0ij
1216 C Uncomment for AL's type of SC correlation interactions.
1217 cadam           eps0ij=-evdwij
1218                 num_conti=num_conti+1
1219                 jcont(num_conti,i)=j
1220                 facont(num_conti,i)=fcont*eps0ij
1221                 fprimcont=eps0ij*fprimcont/rij
1222                 fcont=expon*fcont
1223 cAdam           gacont(1,num_conti,i)=-fprimcont*xj+fcont*gg(1)
1224 cAdam           gacont(2,num_conti,i)=-fprimcont*yj+fcont*gg(2)
1225 cAdam           gacont(3,num_conti,i)=-fprimcont*zj+fcont*gg(3)
1226 C Uncomment following 3 lines for Skolnick's type of SC correlation.
1227                 gacont(1,num_conti,i)=-fprimcont*xj
1228                 gacont(2,num_conti,i)=-fprimcont*yj
1229                 gacont(3,num_conti,i)=-fprimcont*zj
1230 cd              write (iout,'(2i5,2f10.5)') i,j,rij,facont(num_conti,i)
1231 cd              write (iout,'(2i3,3f10.5)')
1232 cd   &           i,j,(gacont(kk,num_conti,i),kk=1,3)
1233               endif
1234             endif
1235           enddo      ! j
1236         enddo        ! iint
1237 C Change 12/1/95
1238         num_cont(i)=num_conti
1239       enddo          ! i
1240       do i=1,nct
1241         do j=1,3
1242           gvdwc(j,i)=expon*gvdwc(j,i)
1243           gvdwx(j,i)=expon*gvdwx(j,i)
1244         enddo
1245       enddo
1246 C******************************************************************************
1247 C
1248 C                              N O T E !!!
1249 C
1250 C To save time, the factor of EXPON has been extracted from ALL components
1251 C of GVDWC and GRADX. Remember to multiply them by this factor before further
1252 C use!
1253 C
1254 C******************************************************************************
1255       return
1256       end
1257 C-----------------------------------------------------------------------------
1258       subroutine eljk(evdw)
1259 C
1260 C This subroutine calculates the interaction energy of nonbonded side chains
1261 C assuming the LJK potential of interaction.
1262 C
1263       implicit real*8 (a-h,o-z)
1264       include 'DIMENSIONS'
1265       include 'COMMON.GEO'
1266       include 'COMMON.VAR'
1267       include 'COMMON.LOCAL'
1268       include 'COMMON.CHAIN'
1269       include 'COMMON.DERIV'
1270       include 'COMMON.INTERACT'
1271       include 'COMMON.IOUNITS'
1272       include 'COMMON.NAMES'
1273       dimension gg(3)
1274       logical scheck
1275 c     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
1276       evdw=0.0D0
1277       do i=iatsc_s,iatsc_e
1278         itypi=iabs(itype(i))
1279         if (itypi.eq.ntyp1) cycle
1280         itypi1=iabs(itype(i+1))
1281         xi=c(1,nres+i)
1282         yi=c(2,nres+i)
1283         zi=c(3,nres+i)
1284 C
1285 C Calculate SC interaction energy.
1286 C
1287         do iint=1,nint_gr(i)
1288           do j=istart(i,iint),iend(i,iint)
1289             itypj=iabs(itype(j))
1290             if (itypj.eq.ntyp1) cycle
1291             xj=c(1,nres+j)-xi
1292             yj=c(2,nres+j)-yi
1293             zj=c(3,nres+j)-zi
1294             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1295             fac_augm=rrij**expon
1296             e_augm=augm(itypi,itypj)*fac_augm
1297             r_inv_ij=dsqrt(rrij)
1298             rij=1.0D0/r_inv_ij
1299             r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
1300             fac=r_shift_inv**expon
1301 C have you changed here?
1302             e1=fac*fac*aa
1303             e2=fac*bb
1304             evdwij=e_augm+e1+e2
1305 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1306 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1307 cd          write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
1308 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
1309 cd   &        bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
1310 cd   &        sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
1311 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1312             evdw=evdw+evdwij
1313 C
1314 C Calculate the components of the gradient in DC and X
1315 C
1316             fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
1317             gg(1)=xj*fac
1318             gg(2)=yj*fac
1319             gg(3)=zj*fac
1320             do k=1,3
1321               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1322               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1323               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1324               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1325             enddo
1326 cgrad            do k=i,j-1
1327 cgrad              do l=1,3
1328 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1329 cgrad              enddo
1330 cgrad            enddo
1331           enddo      ! j
1332         enddo        ! iint
1333       enddo          ! i
1334       do i=1,nct
1335         do j=1,3
1336           gvdwc(j,i)=expon*gvdwc(j,i)
1337           gvdwx(j,i)=expon*gvdwx(j,i)
1338         enddo
1339       enddo
1340       return
1341       end
1342 C-----------------------------------------------------------------------------
1343       subroutine ebp(evdw)
1344 C
1345 C This subroutine calculates the interaction energy of nonbonded side chains
1346 C assuming the Berne-Pechukas potential of interaction.
1347 C
1348       implicit real*8 (a-h,o-z)
1349       include 'DIMENSIONS'
1350       include 'COMMON.GEO'
1351       include 'COMMON.VAR'
1352       include 'COMMON.LOCAL'
1353       include 'COMMON.CHAIN'
1354       include 'COMMON.DERIV'
1355       include 'COMMON.NAMES'
1356       include 'COMMON.INTERACT'
1357       include 'COMMON.IOUNITS'
1358       include 'COMMON.CALC'
1359       common /srutu/ icall
1360 c     double precision rrsave(maxdim)
1361       logical lprn
1362       evdw=0.0D0
1363 c     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
1364       evdw=0.0D0
1365 c     if (icall.eq.0) then
1366 c       lprn=.true.
1367 c     else
1368         lprn=.false.
1369 c     endif
1370       ind=0
1371       do i=iatsc_s,iatsc_e
1372         itypi=iabs(itype(i))
1373         if (itypi.eq.ntyp1) cycle
1374         itypi1=iabs(itype(i+1))
1375         xi=c(1,nres+i)
1376         yi=c(2,nres+i)
1377         zi=c(3,nres+i)
1378         dxi=dc_norm(1,nres+i)
1379         dyi=dc_norm(2,nres+i)
1380         dzi=dc_norm(3,nres+i)
1381 c        dsci_inv=dsc_inv(itypi)
1382         dsci_inv=vbld_inv(i+nres)
1383 C
1384 C Calculate SC interaction energy.
1385 C
1386         do iint=1,nint_gr(i)
1387           do j=istart(i,iint),iend(i,iint)
1388             ind=ind+1
1389             itypj=iabs(itype(j))
1390             if (itypj.eq.ntyp1) cycle
1391 c            dscj_inv=dsc_inv(itypj)
1392             dscj_inv=vbld_inv(j+nres)
1393             chi1=chi(itypi,itypj)
1394             chi2=chi(itypj,itypi)
1395             chi12=chi1*chi2
1396             chip1=chip(itypi)
1397             chip2=chip(itypj)
1398             chip12=chip1*chip2
1399             alf1=alp(itypi)
1400             alf2=alp(itypj)
1401             alf12=0.5D0*(alf1+alf2)
1402 C For diagnostics only!!!
1403 c           chi1=0.0D0
1404 c           chi2=0.0D0
1405 c           chi12=0.0D0
1406 c           chip1=0.0D0
1407 c           chip2=0.0D0
1408 c           chip12=0.0D0
1409 c           alf1=0.0D0
1410 c           alf2=0.0D0
1411 c           alf12=0.0D0
1412             xj=c(1,nres+j)-xi
1413             yj=c(2,nres+j)-yi
1414             zj=c(3,nres+j)-zi
1415             dxj=dc_norm(1,nres+j)
1416             dyj=dc_norm(2,nres+j)
1417             dzj=dc_norm(3,nres+j)
1418             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1419 cd          if (icall.eq.0) then
1420 cd            rrsave(ind)=rrij
1421 cd          else
1422 cd            rrij=rrsave(ind)
1423 cd          endif
1424             rij=dsqrt(rrij)
1425 C Calculate the angle-dependent terms of energy & contributions to derivatives.
1426             call sc_angular
1427 C Calculate whole angle-dependent part of epsilon and contributions
1428 C to its derivatives
1429 C have you changed here?
1430             fac=(rrij*sigsq)**expon2
1431             e1=fac*fac*aa
1432             e2=fac*bb
1433             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1434             eps2der=evdwij*eps3rt
1435             eps3der=evdwij*eps2rt
1436             evdwij=evdwij*eps2rt*eps3rt
1437             evdw=evdw+evdwij
1438             if (lprn) then
1439             sigm=dabs(aa/bb)**(1.0D0/6.0D0)
1440             epsi=bb**2/aa
1441 cd            write (iout,'(2(a3,i3,2x),15(0pf7.3))')
1442 cd     &        restyp(itypi),i,restyp(itypj),j,
1443 cd     &        epsi,sigm,chi1,chi2,chip1,chip2,
1444 cd     &        eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
1445 cd     &        om1,om2,om12,1.0D0/dsqrt(rrij),
1446 cd     &        evdwij
1447             endif
1448 C Calculate gradient components.
1449             e1=e1*eps1*eps2rt**2*eps3rt**2
1450             fac=-expon*(e1+evdwij)
1451             sigder=fac/sigsq
1452             fac=rrij*fac
1453 C Calculate radial part of the gradient
1454             gg(1)=xj*fac
1455             gg(2)=yj*fac
1456             gg(3)=zj*fac
1457 C Calculate the angular part of the gradient and sum add the contributions
1458 C to the appropriate components of the Cartesian gradient.
1459             call sc_grad
1460           enddo      ! j
1461         enddo        ! iint
1462       enddo          ! i
1463 c     stop
1464       return
1465       end
1466 C-----------------------------------------------------------------------------
1467       subroutine egb(evdw)
1468 C
1469 C This subroutine calculates the interaction energy of nonbonded side chains
1470 C assuming the Gay-Berne potential of interaction.
1471 C
1472       implicit real*8 (a-h,o-z)
1473       include 'DIMENSIONS'
1474       include 'COMMON.GEO'
1475       include 'COMMON.VAR'
1476       include 'COMMON.LOCAL'
1477       include 'COMMON.CHAIN'
1478       include 'COMMON.DERIV'
1479       include 'COMMON.NAMES'
1480       include 'COMMON.INTERACT'
1481       include 'COMMON.IOUNITS'
1482       include 'COMMON.CALC'
1483       include 'COMMON.CONTROL'
1484       include 'COMMON.SPLITELE'
1485       include 'COMMON.SBRIDGE'
1486       logical lprn
1487       integer xshift,yshift,zshift
1488
1489       evdw=0.0D0
1490 ccccc      energy_dec=.false.
1491 C      print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1492       evdw=0.0D0
1493       lprn=.false.
1494 c     if (icall.eq.0) lprn=.false.
1495       ind=0
1496 C the loop over all 27 posible neigbours (for xshift=0,yshift=0,zshift=0
1497 C we have the original box)
1498 C      do xshift=-1,1
1499 C      do yshift=-1,1
1500 C      do zshift=-1,1
1501       do i=iatsc_s,iatsc_e
1502         itypi=iabs(itype(i))
1503         if (itypi.eq.ntyp1) cycle
1504         itypi1=iabs(itype(i+1))
1505         xi=c(1,nres+i)
1506         yi=c(2,nres+i)
1507         zi=c(3,nres+i)
1508 C Return atom into box, boxxsize is size of box in x dimension
1509 c  134   continue
1510 c        if (xi.gt.((xshift+0.5d0)*boxxsize)) xi=xi-boxxsize
1511 c        if (xi.lt.((xshift-0.5d0)*boxxsize)) xi=xi+boxxsize
1512 C Condition for being inside the proper box
1513 c        if ((xi.gt.((xshift+0.5d0)*boxxsize)).or.
1514 c     &       (xi.lt.((xshift-0.5d0)*boxxsize))) then
1515 c        go to 134
1516 c        endif
1517 c  135   continue
1518 c        if (yi.gt.((yshift+0.5d0)*boxysize)) yi=yi-boxysize
1519 c        if (yi.lt.((yshift-0.5d0)*boxysize)) yi=yi+boxysize
1520 C Condition for being inside the proper box
1521 c        if ((yi.gt.((yshift+0.5d0)*boxysize)).or.
1522 c     &       (yi.lt.((yshift-0.5d0)*boxysize))) then
1523 c        go to 135
1524 c        endif
1525 c  136   continue
1526 c        if (zi.gt.((zshift+0.5d0)*boxzsize)) zi=zi-boxzsize
1527 c        if (zi.lt.((zshift-0.5d0)*boxzsize)) zi=zi+boxzsize
1528 C Condition for being inside the proper box
1529 c        if ((zi.gt.((zshift+0.5d0)*boxzsize)).or.
1530 c     &       (zi.lt.((zshift-0.5d0)*boxzsize))) then
1531 c        go to 136
1532 c        endif
1533           xi=mod(xi,boxxsize)
1534           if (xi.lt.0) xi=xi+boxxsize
1535           yi=mod(yi,boxysize)
1536           if (yi.lt.0) yi=yi+boxysize
1537           zi=mod(zi,boxzsize)
1538           if (zi.lt.0) zi=zi+boxzsize
1539 C define scaling factor for lipids
1540
1541 C        if (positi.le.0) positi=positi+boxzsize
1542 C        print *,i
1543 C first for peptide groups
1544 c for each residue check if it is in lipid or lipid water border area
1545        if ((zi.gt.bordlipbot)
1546      &.and.(zi.lt.bordliptop)) then
1547 C the energy transfer exist
1548         if (zi.lt.buflipbot) then
1549 C what fraction I am in
1550          fracinbuf=1.0d0-
1551      &        ((zi-bordlipbot)/lipbufthick)
1552 C lipbufthick is thickenes of lipid buffore
1553          sslipi=sscalelip(fracinbuf)
1554          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
1555         elseif (zi.gt.bufliptop) then
1556          fracinbuf=1.0d0-((bordliptop-zi)/lipbufthick)
1557          sslipi=sscalelip(fracinbuf)
1558          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
1559         else
1560          sslipi=1.0d0
1561          ssgradlipi=0.0
1562         endif
1563        else
1564          sslipi=0.0d0
1565          ssgradlipi=0.0
1566        endif
1567
1568 C          xi=xi+xshift*boxxsize
1569 C          yi=yi+yshift*boxysize
1570 C          zi=zi+zshift*boxzsize
1571
1572         dxi=dc_norm(1,nres+i)
1573         dyi=dc_norm(2,nres+i)
1574         dzi=dc_norm(3,nres+i)
1575 c        dsci_inv=dsc_inv(itypi)
1576         dsci_inv=vbld_inv(i+nres)
1577 c        write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)
1578 c        write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi
1579 C
1580 C Calculate SC interaction energy.
1581 C
1582         do iint=1,nint_gr(i)
1583           do j=istart(i,iint),iend(i,iint)
1584             IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN
1585
1586 c              write(iout,*) "PRZED ZWYKLE", evdwij
1587               call dyn_ssbond_ene(i,j,evdwij)
1588 c              write(iout,*) "PO ZWYKLE", evdwij
1589
1590               evdw=evdw+evdwij
1591               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)')
1592      &                        'evdw',i,j,evdwij,' ss'
1593 C triple bond artifac removal
1594              do k=j+1,iend(i,iint)
1595 C search over all next residues
1596               if (dyn_ss_mask(k)) then
1597 C check if they are cysteins
1598 C              write(iout,*) 'k=',k
1599
1600 c              write(iout,*) "PRZED TRI", evdwij
1601                evdwij_przed_tri=evdwij
1602               call triple_ssbond_ene(i,j,k,evdwij)
1603 c               if(evdwij_przed_tri.ne.evdwij) then
1604 c                 write (iout,*) "TRI:", evdwij, evdwij_przed_tri
1605 c               endif
1606
1607 c              write(iout,*) "PO TRI", evdwij
1608 C call the energy function that removes the artifical triple disulfide
1609 C bond the soubroutine is located in ssMD.F
1610               evdw=evdw+evdwij
1611               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)')
1612      &                        'evdw',i,j,evdwij,'tss'
1613               endif!dyn_ss_mask(k)
1614              enddo! k
1615             ELSE
1616             ind=ind+1
1617             itypj=iabs(itype(j))
1618             if (itypj.eq.ntyp1) cycle
1619 c            dscj_inv=dsc_inv(itypj)
1620             dscj_inv=vbld_inv(j+nres)
1621 c            write (iout,*) "j",j,dsc_inv(itypj),dscj_inv,
1622 c     &       1.0d0/vbld(j+nres)
1623 c            write (iout,*) "i",i," j", j," itype",itype(i),itype(j)
1624             sig0ij=sigma(itypi,itypj)
1625             chi1=chi(itypi,itypj)
1626             chi2=chi(itypj,itypi)
1627             chi12=chi1*chi2
1628             chip1=chip(itypi)
1629             chip2=chip(itypj)
1630             chip12=chip1*chip2
1631             alf1=alp(itypi)
1632             alf2=alp(itypj)
1633             alf12=0.5D0*(alf1+alf2)
1634 C For diagnostics only!!!
1635 c           chi1=0.0D0
1636 c           chi2=0.0D0
1637 c           chi12=0.0D0
1638 c           chip1=0.0D0
1639 c           chip2=0.0D0
1640 c           chip12=0.0D0
1641 c           alf1=0.0D0
1642 c           alf2=0.0D0
1643 c           alf12=0.0D0
1644             xj=c(1,nres+j)
1645             yj=c(2,nres+j)
1646             zj=c(3,nres+j)
1647 C Return atom J into box the original box
1648 c  137   continue
1649 c        if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
1650 c        if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
1651 C Condition for being inside the proper box
1652 c        if ((xj.gt.((0.5d0)*boxxsize)).or.
1653 c     &       (xj.lt.((-0.5d0)*boxxsize))) then
1654 c        go to 137
1655 c        endif
1656 c  138   continue
1657 c        if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
1658 c        if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
1659 C Condition for being inside the proper box
1660 c        if ((yj.gt.((0.5d0)*boxysize)).or.
1661 c     &       (yj.lt.((-0.5d0)*boxysize))) then
1662 c        go to 138
1663 c        endif
1664 c  139   continue
1665 c        if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
1666 c        if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
1667 C Condition for being inside the proper box
1668 c        if ((zj.gt.((0.5d0)*boxzsize)).or.
1669 c     &       (zj.lt.((-0.5d0)*boxzsize))) then
1670 c        go to 139
1671 c        endif
1672           xj=mod(xj,boxxsize)
1673           if (xj.lt.0) xj=xj+boxxsize
1674           yj=mod(yj,boxysize)
1675           if (yj.lt.0) yj=yj+boxysize
1676           zj=mod(zj,boxzsize)
1677           if (zj.lt.0) zj=zj+boxzsize
1678        if ((zj.gt.bordlipbot)
1679      &.and.(zj.lt.bordliptop)) then
1680 C the energy transfer exist
1681         if (zj.lt.buflipbot) then
1682 C what fraction I am in
1683          fracinbuf=1.0d0-
1684      &        ((zj-bordlipbot)/lipbufthick)
1685 C lipbufthick is thickenes of lipid buffore
1686          sslipj=sscalelip(fracinbuf)
1687          ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
1688         elseif (zj.gt.bufliptop) then
1689          fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
1690          sslipj=sscalelip(fracinbuf)
1691          ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
1692         else
1693          sslipj=1.0d0
1694          ssgradlipj=0.0
1695         endif
1696        else
1697          sslipj=0.0d0
1698          ssgradlipj=0.0
1699        endif
1700       aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
1701      &  +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1702       bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
1703      &  +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1704 C      if (aa.ne.aa_aq(itypi,itypj)) write(63,'(2e10.5)')
1705 C     &(aa-aa_aq(itypi,itypj)),(bb-bb_aq(itypi,itypj))
1706 C      if (ssgradlipj.gt.0.0d0) print *,"??WTF??"
1707 C      print *,sslipi,sslipj,bordlipbot,zi,zj
1708       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
1709       xj_safe=xj
1710       yj_safe=yj
1711       zj_safe=zj
1712       subchap=0
1713       do xshift=-1,1
1714       do yshift=-1,1
1715       do zshift=-1,1
1716           xj=xj_safe+xshift*boxxsize
1717           yj=yj_safe+yshift*boxysize
1718           zj=zj_safe+zshift*boxzsize
1719           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
1720           if(dist_temp.lt.dist_init) then
1721             dist_init=dist_temp
1722             xj_temp=xj
1723             yj_temp=yj
1724             zj_temp=zj
1725             subchap=1
1726           endif
1727        enddo
1728        enddo
1729        enddo
1730        if (subchap.eq.1) then
1731           xj=xj_temp-xi
1732           yj=yj_temp-yi
1733           zj=zj_temp-zi
1734        else
1735           xj=xj_safe-xi
1736           yj=yj_safe-yi
1737           zj=zj_safe-zi
1738        endif
1739             dxj=dc_norm(1,nres+j)
1740             dyj=dc_norm(2,nres+j)
1741             dzj=dc_norm(3,nres+j)
1742 C            xj=xj-xi
1743 C            yj=yj-yi
1744 C            zj=zj-zi
1745 c            write (iout,*) "dcnorj",dxi*dxi+dyi*dyi+dzi*dzi
1746 c            write (iout,*) "j",j," dc_norm",
1747 c     &       dc_norm(1,nres+j),dc_norm(2,nres+j),dc_norm(3,nres+j)
1748             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1749             rij=dsqrt(rrij)
1750             sss=sscale((1.0d0/rij)/sigma(itypi,itypj))
1751             sssgrad=sscagrad((1.0d0/rij)/sigma(itypi,itypj))
1752
1753 c            write (iout,'(a7,4f8.3)')
1754 c    &      "ssscale",sss,((1.0d0/rij)/sigma(itypi,itypj)),r_cut,rlamb
1755             if (sss.gt.0.0d0) then
1756 C Calculate angle-dependent terms of energy and contributions to their
1757 C derivatives.
1758             call sc_angular
1759             sigsq=1.0D0/sigsq
1760             sig=sig0ij*dsqrt(sigsq)
1761             rij_shift=1.0D0/rij-sig+sig0ij
1762 c for diagnostics; uncomment
1763 c            rij_shift=1.2*sig0ij
1764 C I hate to put IF's in the loops, but here don't have another choice!!!!
1765             if (rij_shift.le.0.0D0) then
1766               evdw=1.0D20
1767 cd              write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1768 cd     &        restyp(itypi),i,restyp(itypj),j,
1769 cd     &        rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq)
1770               return
1771             endif
1772             sigder=-sig*sigsq
1773 c---------------------------------------------------------------
1774             rij_shift=1.0D0/rij_shift
1775             fac=rij_shift**expon
1776 C here to start with
1777 C            if (c(i,3).gt.
1778             faclip=fac
1779             e1=fac*fac*aa
1780             e2=fac*bb
1781             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1782             eps2der=evdwij*eps3rt
1783             eps3der=evdwij*eps2rt
1784 C       write(63,'(2i3,2e10.3,2f10.5)') i,j,aa,bb, evdwij,
1785 C     &((sslipi+sslipj)/2.0d0+
1786 C     &(2.0d0-sslipi-sslipj)/2.0d0)
1787 c            write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt,
1788 c     &        " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2
1789             evdwij=evdwij*eps2rt*eps3rt
1790             evdw=evdw+evdwij*sss
1791             if (lprn) then
1792             sigm=dabs(aa/bb)**(1.0D0/6.0D0)
1793             epsi=bb**2/aa
1794             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1795      &        restyp(itypi),i,restyp(itypj),j,
1796      &        epsi,sigm,chi1,chi2,chip1,chip2,
1797      &        eps1,eps2rt**2,eps3rt**2,sig,sig0ij,
1798      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1799      &        evdwij
1800             endif
1801
1802             if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
1803      &                        'evdw',i,j,evdwij
1804
1805 C Calculate gradient components.
1806             e1=e1*eps1*eps2rt**2*eps3rt**2
1807             fac=-expon*(e1+evdwij)*rij_shift
1808             sigder=fac*sigder
1809             fac=rij*fac
1810 c            print '(2i4,6f8.4)',i,j,sss,sssgrad*
1811 c     &      evdwij,fac,sigma(itypi,itypj),expon
1812             fac=fac+evdwij/sss*sssgrad/sigma(itypi,itypj)*rij
1813 c            fac=0.0d0
1814 C Calculate the radial part of the gradient
1815             gg_lipi(3)=eps1*(eps2rt*eps2rt)
1816      &*(eps3rt*eps3rt)*sss/2.0d0*(faclip*faclip*
1817      & (aa_lip(itypi,itypj)-aa_aq(itypi,itypj))
1818      &+faclip*(bb_lip(itypi,itypj)-bb_aq(itypi,itypj)))
1819             gg_lipj(3)=ssgradlipj*gg_lipi(3)
1820             gg_lipi(3)=gg_lipi(3)*ssgradlipi
1821 C            gg_lipi(3)=0.0d0
1822 C            gg_lipj(3)=0.0d0
1823             gg(1)=xj*fac
1824             gg(2)=yj*fac
1825             gg(3)=zj*fac
1826 C Calculate angular part of the gradient.
1827             call sc_grad
1828             endif
1829             ENDIF    ! dyn_ss
1830           enddo      ! j
1831         enddo        ! iint
1832       enddo          ! i
1833 C      enddo          ! zshift
1834 C      enddo          ! yshift
1835 C      enddo          ! xshift
1836 c      write (iout,*) "Number of loop steps in EGB:",ind
1837 cccc      energy_dec=.false.
1838       return
1839       end
1840 C-----------------------------------------------------------------------------
1841       subroutine egbv(evdw)
1842 C
1843 C This subroutine calculates the interaction energy of nonbonded side chains
1844 C assuming the Gay-Berne-Vorobjev potential of interaction.
1845 C
1846       implicit real*8 (a-h,o-z)
1847       include 'DIMENSIONS'
1848       include 'COMMON.GEO'
1849       include 'COMMON.VAR'
1850       include 'COMMON.LOCAL'
1851       include 'COMMON.CHAIN'
1852       include 'COMMON.DERIV'
1853       include 'COMMON.NAMES'
1854       include 'COMMON.INTERACT'
1855       include 'COMMON.IOUNITS'
1856       include 'COMMON.CALC'
1857       common /srutu/ icall
1858       logical lprn
1859       evdw=0.0D0
1860 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1861       evdw=0.0D0
1862       lprn=.false.
1863 c     if (icall.eq.0) lprn=.true.
1864       ind=0
1865       do i=iatsc_s,iatsc_e
1866         itypi=iabs(itype(i))
1867         if (itypi.eq.ntyp1) cycle
1868         itypi1=iabs(itype(i+1))
1869         xi=c(1,nres+i)
1870         yi=c(2,nres+i)
1871         zi=c(3,nres+i)
1872           xi=mod(xi,boxxsize)
1873           if (xi.lt.0) xi=xi+boxxsize
1874           yi=mod(yi,boxysize)
1875           if (yi.lt.0) yi=yi+boxysize
1876           zi=mod(zi,boxzsize)
1877           if (zi.lt.0) zi=zi+boxzsize
1878 C define scaling factor for lipids
1879
1880 C        if (positi.le.0) positi=positi+boxzsize
1881 C        print *,i
1882 C first for peptide groups
1883 c for each residue check if it is in lipid or lipid water border area
1884        if ((zi.gt.bordlipbot)
1885      &.and.(zi.lt.bordliptop)) then
1886 C the energy transfer exist
1887         if (zi.lt.buflipbot) then
1888 C what fraction I am in
1889          fracinbuf=1.0d0-
1890      &        ((zi-bordlipbot)/lipbufthick)
1891 C lipbufthick is thickenes of lipid buffore
1892          sslipi=sscalelip(fracinbuf)
1893          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
1894         elseif (zi.gt.bufliptop) then
1895          fracinbuf=1.0d0-((bordliptop-zi)/lipbufthick)
1896          sslipi=sscalelip(fracinbuf)
1897          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
1898         else
1899          sslipi=1.0d0
1900          ssgradlipi=0.0
1901         endif
1902        else
1903          sslipi=0.0d0
1904          ssgradlipi=0.0
1905        endif
1906
1907         dxi=dc_norm(1,nres+i)
1908         dyi=dc_norm(2,nres+i)
1909         dzi=dc_norm(3,nres+i)
1910 c        dsci_inv=dsc_inv(itypi)
1911         dsci_inv=vbld_inv(i+nres)
1912 C
1913 C Calculate SC interaction energy.
1914 C
1915         do iint=1,nint_gr(i)
1916           do j=istart(i,iint),iend(i,iint)
1917             ind=ind+1
1918             itypj=iabs(itype(j))
1919             if (itypj.eq.ntyp1) cycle
1920 c            dscj_inv=dsc_inv(itypj)
1921             dscj_inv=vbld_inv(j+nres)
1922             sig0ij=sigma(itypi,itypj)
1923             r0ij=r0(itypi,itypj)
1924             chi1=chi(itypi,itypj)
1925             chi2=chi(itypj,itypi)
1926             chi12=chi1*chi2
1927             chip1=chip(itypi)
1928             chip2=chip(itypj)
1929             chip12=chip1*chip2
1930             alf1=alp(itypi)
1931             alf2=alp(itypj)
1932             alf12=0.5D0*(alf1+alf2)
1933 C For diagnostics only!!!
1934 c           chi1=0.0D0
1935 c           chi2=0.0D0
1936 c           chi12=0.0D0
1937 c           chip1=0.0D0
1938 c           chip2=0.0D0
1939 c           chip12=0.0D0
1940 c           alf1=0.0D0
1941 c           alf2=0.0D0
1942 c           alf12=0.0D0
1943 C            xj=c(1,nres+j)-xi
1944 C            yj=c(2,nres+j)-yi
1945 C            zj=c(3,nres+j)-zi
1946           xj=mod(xj,boxxsize)
1947           if (xj.lt.0) xj=xj+boxxsize
1948           yj=mod(yj,boxysize)
1949           if (yj.lt.0) yj=yj+boxysize
1950           zj=mod(zj,boxzsize)
1951           if (zj.lt.0) zj=zj+boxzsize
1952        if ((zj.gt.bordlipbot)
1953      &.and.(zj.lt.bordliptop)) then
1954 C the energy transfer exist
1955         if (zj.lt.buflipbot) then
1956 C what fraction I am in
1957          fracinbuf=1.0d0-
1958      &        ((zj-bordlipbot)/lipbufthick)
1959 C lipbufthick is thickenes of lipid buffore
1960          sslipj=sscalelip(fracinbuf)
1961          ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
1962         elseif (zj.gt.bufliptop) then
1963          fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
1964          sslipj=sscalelip(fracinbuf)
1965          ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
1966         else
1967          sslipj=1.0d0
1968          ssgradlipj=0.0
1969         endif
1970        else
1971          sslipj=0.0d0
1972          ssgradlipj=0.0
1973        endif
1974       aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
1975      &  +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1976       bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
1977      &  +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1978 C      if (aa.ne.aa_aq(itypi,itypj)) write(63,'2e10.5')
1979 C     &(aa-aa_aq(itypi,itypj)),(bb-bb_aq(itypi,itypj))
1980       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
1981       xj_safe=xj
1982       yj_safe=yj
1983       zj_safe=zj
1984       subchap=0
1985       do xshift=-1,1
1986       do yshift=-1,1
1987       do zshift=-1,1
1988           xj=xj_safe+xshift*boxxsize
1989           yj=yj_safe+yshift*boxysize
1990           zj=zj_safe+zshift*boxzsize
1991           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
1992           if(dist_temp.lt.dist_init) then
1993             dist_init=dist_temp
1994             xj_temp=xj
1995             yj_temp=yj
1996             zj_temp=zj
1997             subchap=1
1998           endif
1999        enddo
2000        enddo
2001        enddo
2002        if (subchap.eq.1) then
2003           xj=xj_temp-xi
2004           yj=yj_temp-yi
2005           zj=zj_temp-zi
2006        else
2007           xj=xj_safe-xi
2008           yj=yj_safe-yi
2009           zj=zj_safe-zi
2010        endif
2011             dxj=dc_norm(1,nres+j)
2012             dyj=dc_norm(2,nres+j)
2013             dzj=dc_norm(3,nres+j)
2014             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
2015             rij=dsqrt(rrij)
2016 C Calculate angle-dependent terms of energy and contributions to their
2017 C derivatives.
2018             call sc_angular
2019             sigsq=1.0D0/sigsq
2020             sig=sig0ij*dsqrt(sigsq)
2021             rij_shift=1.0D0/rij-sig+r0ij
2022 C I hate to put IF's in the loops, but here don't have another choice!!!!
2023             if (rij_shift.le.0.0D0) then
2024               evdw=1.0D20
2025               return
2026             endif
2027             sigder=-sig*sigsq
2028 c---------------------------------------------------------------
2029             rij_shift=1.0D0/rij_shift
2030             fac=rij_shift**expon
2031             e1=fac*fac*aa
2032             e2=fac*bb
2033             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
2034             eps2der=evdwij*eps3rt
2035             eps3der=evdwij*eps2rt
2036             fac_augm=rrij**expon
2037             e_augm=augm(itypi,itypj)*fac_augm
2038             evdwij=evdwij*eps2rt*eps3rt
2039             evdw=evdw+evdwij+e_augm
2040             if (lprn) then
2041             sigm=dabs(aa/bb)**(1.0D0/6.0D0)
2042             epsi=bb**2/aa
2043             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
2044      &        restyp(itypi),i,restyp(itypj),j,
2045      &        epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),
2046      &        chi1,chi2,chip1,chip2,
2047      &        eps1,eps2rt**2,eps3rt**2,
2048      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
2049      &        evdwij+e_augm
2050             endif
2051 C Calculate gradient components.
2052             e1=e1*eps1*eps2rt**2*eps3rt**2
2053             fac=-expon*(e1+evdwij)*rij_shift
2054             sigder=fac*sigder
2055             fac=rij*fac-2*expon*rrij*e_augm
2056             fac=fac+evdwij/sss*sssgrad/sigma(itypi,itypj)*rij
2057 C Calculate the radial part of the gradient
2058             gg(1)=xj*fac
2059             gg(2)=yj*fac
2060             gg(3)=zj*fac
2061 C Calculate angular part of the gradient.
2062             call sc_grad
2063           enddo      ! j
2064         enddo        ! iint
2065       enddo          ! i
2066       end
2067 C-----------------------------------------------------------------------------
2068       subroutine sc_angular
2069 C Calculate eps1,eps2,eps3,sigma, and parts of their derivatives in om1,om2,
2070 C om12. Called by ebp, egb, and egbv.
2071       implicit none
2072       include 'COMMON.CALC'
2073       include 'COMMON.IOUNITS'
2074       erij(1)=xj*rij
2075       erij(2)=yj*rij
2076       erij(3)=zj*rij
2077       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
2078       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
2079       om12=dxi*dxj+dyi*dyj+dzi*dzj
2080       chiom12=chi12*om12
2081 C Calculate eps1(om12) and its derivative in om12
2082       faceps1=1.0D0-om12*chiom12
2083       faceps1_inv=1.0D0/faceps1
2084       eps1=dsqrt(faceps1_inv)
2085 C Following variable is eps1*deps1/dom12
2086       eps1_om12=faceps1_inv*chiom12
2087 c diagnostics only
2088 c      faceps1_inv=om12
2089 c      eps1=om12
2090 c      eps1_om12=1.0d0
2091 c      write (iout,*) "om12",om12," eps1",eps1
2092 C Calculate sigma(om1,om2,om12) and the derivatives of sigma**2 in om1,om2,
2093 C and om12.
2094       om1om2=om1*om2
2095       chiom1=chi1*om1
2096       chiom2=chi2*om2
2097       facsig=om1*chiom1+om2*chiom2-2.0D0*om1om2*chiom12
2098       sigsq=1.0D0-facsig*faceps1_inv
2099       sigsq_om1=(chiom1-chiom12*om2)*faceps1_inv
2100       sigsq_om2=(chiom2-chiom12*om1)*faceps1_inv
2101       sigsq_om12=-chi12*(om1om2*faceps1-om12*facsig)*faceps1_inv**2
2102 c diagnostics only
2103 c      sigsq=1.0d0
2104 c      sigsq_om1=0.0d0
2105 c      sigsq_om2=0.0d0
2106 c      sigsq_om12=0.0d0
2107 c      write (iout,*) "chiom1",chiom1," chiom2",chiom2," chiom12",chiom12
2108 c      write (iout,*) "faceps1",faceps1," faceps1_inv",faceps1_inv,
2109 c     &    " eps1",eps1
2110 C Calculate eps2 and its derivatives in om1, om2, and om12.
2111       chipom1=chip1*om1
2112       chipom2=chip2*om2
2113       chipom12=chip12*om12
2114       facp=1.0D0-om12*chipom12
2115       facp_inv=1.0D0/facp
2116       facp1=om1*chipom1+om2*chipom2-2.0D0*om1om2*chipom12
2117 c      write (iout,*) "chipom1",chipom1," chipom2",chipom2,
2118 c     &  " chipom12",chipom12," facp",facp," facp_inv",facp_inv
2119 C Following variable is the square root of eps2
2120       eps2rt=1.0D0-facp1*facp_inv
2121 C Following three variables are the derivatives of the square root of eps
2122 C in om1, om2, and om12.
2123       eps2rt_om1=-4.0D0*(chipom1-chipom12*om2)*facp_inv
2124       eps2rt_om2=-4.0D0*(chipom2-chipom12*om1)*facp_inv
2125       eps2rt_om12=4.0D0*chip12*(om1om2*facp-om12*facp1)*facp_inv**2
2126 C Evaluate the "asymmetric" factor in the VDW constant, eps3
2127       eps3rt=1.0D0-alf1*om1+alf2*om2-alf12*om12
2128 c      write (iout,*) "eps2rt",eps2rt," eps3rt",eps3rt
2129 c      write (iout,*) "eps2rt_om1",eps2rt_om1," eps2rt_om2",eps2rt_om2,
2130 c     &  " eps2rt_om12",eps2rt_om12
2131 C Calculate whole angle-dependent part of epsilon and contributions
2132 C to its derivatives
2133       return
2134       end
2135 C----------------------------------------------------------------------------
2136       subroutine sc_grad
2137       implicit real*8 (a-h,o-z)
2138       include 'DIMENSIONS'
2139       include 'COMMON.CHAIN'
2140       include 'COMMON.DERIV'
2141       include 'COMMON.CALC'
2142       include 'COMMON.IOUNITS'
2143       double precision dcosom1(3),dcosom2(3)
2144 cc      print *,'sss=',sss
2145       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
2146       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
2147       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12
2148      &     -2.0D0*alf12*eps3der+sigder*sigsq_om12
2149 c diagnostics only
2150 c      eom1=0.0d0
2151 c      eom2=0.0d0
2152 c      eom12=evdwij*eps1_om12
2153 c end diagnostics
2154 c      write (iout,*) "eps2der",eps2der," eps3der",eps3der,
2155 c     &  " sigder",sigder
2156 c      write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12
2157 c      write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12
2158       do k=1,3
2159         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
2160         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
2161       enddo
2162       do k=1,3
2163         gg(k)=(gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k))*sss
2164       enddo
2165 c      write (iout,*) "gg",(gg(k),k=1,3)
2166       do k=1,3
2167         gvdwx(k,i)=gvdwx(k,i)-gg(k)+gg_lipi(k)
2168      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
2169      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv*sss
2170         gvdwx(k,j)=gvdwx(k,j)+gg(k)+gg_lipj(k)
2171      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
2172      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv*sss
2173 c        write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
2174 c     &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
2175 c        write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
2176 c     &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
2177       enddo
2178 C
2179 C Calculate the components of the gradient in DC and X
2180 C
2181 cgrad      do k=i,j-1
2182 cgrad        do l=1,3
2183 cgrad          gvdwc(l,k)=gvdwc(l,k)+gg(l)
2184 cgrad        enddo
2185 cgrad      enddo
2186       do l=1,3
2187         gvdwc(l,i)=gvdwc(l,i)-gg(l)+gg_lipi(l)
2188         gvdwc(l,j)=gvdwc(l,j)+gg(l)+gg_lipj(l)
2189       enddo
2190       return
2191       end
2192 C-----------------------------------------------------------------------
2193       subroutine e_softsphere(evdw)
2194 C
2195 C This subroutine calculates the interaction energy of nonbonded side chains
2196 C assuming the LJ potential of interaction.
2197 C
2198       implicit real*8 (a-h,o-z)
2199       include 'DIMENSIONS'
2200       parameter (accur=1.0d-10)
2201       include 'COMMON.GEO'
2202       include 'COMMON.VAR'
2203       include 'COMMON.LOCAL'
2204       include 'COMMON.CHAIN'
2205       include 'COMMON.DERIV'
2206       include 'COMMON.INTERACT'
2207       include 'COMMON.TORSION'
2208       include 'COMMON.SBRIDGE'
2209       include 'COMMON.NAMES'
2210       include 'COMMON.IOUNITS'
2211       include 'COMMON.CONTACTS'
2212       dimension gg(3)
2213 cd    print *,'Entering Esoft_sphere nnt=',nnt,' nct=',nct
2214       evdw=0.0D0
2215       do i=iatsc_s,iatsc_e
2216         itypi=iabs(itype(i))
2217         if (itypi.eq.ntyp1) cycle
2218         itypi1=iabs(itype(i+1))
2219         xi=c(1,nres+i)
2220         yi=c(2,nres+i)
2221         zi=c(3,nres+i)
2222 C
2223 C Calculate SC interaction energy.
2224 C
2225         do iint=1,nint_gr(i)
2226 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
2227 cd   &                  'iend=',iend(i,iint)
2228           do j=istart(i,iint),iend(i,iint)
2229             itypj=iabs(itype(j))
2230             if (itypj.eq.ntyp1) cycle
2231             xj=c(1,nres+j)-xi
2232             yj=c(2,nres+j)-yi
2233             zj=c(3,nres+j)-zi
2234             rij=xj*xj+yj*yj+zj*zj
2235 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
2236             r0ij=r0(itypi,itypj)
2237             r0ijsq=r0ij*r0ij
2238 c            print *,i,j,r0ij,dsqrt(rij)
2239             if (rij.lt.r0ijsq) then
2240               evdwij=0.25d0*(rij-r0ijsq)**2
2241               fac=rij-r0ijsq
2242             else
2243               evdwij=0.0d0
2244               fac=0.0d0
2245             endif
2246             evdw=evdw+evdwij
2247 C
2248 C Calculate the components of the gradient in DC and X
2249 C
2250             gg(1)=xj*fac
2251             gg(2)=yj*fac
2252             gg(3)=zj*fac
2253             do k=1,3
2254               gvdwx(k,i)=gvdwx(k,i)-gg(k)
2255               gvdwx(k,j)=gvdwx(k,j)+gg(k)
2256               gvdwc(k,i)=gvdwc(k,i)-gg(k)
2257               gvdwc(k,j)=gvdwc(k,j)+gg(k)
2258             enddo
2259 cgrad            do k=i,j-1
2260 cgrad              do l=1,3
2261 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
2262 cgrad              enddo
2263 cgrad            enddo
2264           enddo ! j
2265         enddo ! iint
2266       enddo ! i
2267       return
2268       end
2269 C--------------------------------------------------------------------------
2270       subroutine eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,
2271      &              eello_turn4)
2272 C
2273 C Soft-sphere potential of p-p interaction
2274 C
2275       implicit real*8 (a-h,o-z)
2276       include 'DIMENSIONS'
2277       include 'COMMON.CONTROL'
2278       include 'COMMON.IOUNITS'
2279       include 'COMMON.GEO'
2280       include 'COMMON.VAR'
2281       include 'COMMON.LOCAL'
2282       include 'COMMON.CHAIN'
2283       include 'COMMON.DERIV'
2284       include 'COMMON.INTERACT'
2285       include 'COMMON.CONTACTS'
2286       include 'COMMON.TORSION'
2287       include 'COMMON.VECTORS'
2288       include 'COMMON.FFIELD'
2289       dimension ggg(3)
2290 C      write(iout,*) 'In EELEC_soft_sphere'
2291       ees=0.0D0
2292       evdw1=0.0D0
2293       eel_loc=0.0d0
2294       eello_turn3=0.0d0
2295       eello_turn4=0.0d0
2296       ind=0
2297       do i=iatel_s,iatel_e
2298         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
2299         dxi=dc(1,i)
2300         dyi=dc(2,i)
2301         dzi=dc(3,i)
2302         xmedi=c(1,i)+0.5d0*dxi
2303         ymedi=c(2,i)+0.5d0*dyi
2304         zmedi=c(3,i)+0.5d0*dzi
2305           xmedi=mod(xmedi,boxxsize)
2306           if (xmedi.lt.0) xmedi=xmedi+boxxsize
2307           ymedi=mod(ymedi,boxysize)
2308           if (ymedi.lt.0) ymedi=ymedi+boxysize
2309           zmedi=mod(zmedi,boxzsize)
2310           if (zmedi.lt.0) zmedi=zmedi+boxzsize
2311         num_conti=0
2312 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
2313         do j=ielstart(i),ielend(i)
2314           if (itype(j).eq.ntyp1 .or. itype(j+1).eq.ntyp1) cycle
2315           ind=ind+1
2316           iteli=itel(i)
2317           itelj=itel(j)
2318           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
2319           r0ij=rpp(iteli,itelj)
2320           r0ijsq=r0ij*r0ij
2321           dxj=dc(1,j)
2322           dyj=dc(2,j)
2323           dzj=dc(3,j)
2324           xj=c(1,j)+0.5D0*dxj
2325           yj=c(2,j)+0.5D0*dyj
2326           zj=c(3,j)+0.5D0*dzj
2327           xj=mod(xj,boxxsize)
2328           if (xj.lt.0) xj=xj+boxxsize
2329           yj=mod(yj,boxysize)
2330           if (yj.lt.0) yj=yj+boxysize
2331           zj=mod(zj,boxzsize)
2332           if (zj.lt.0) zj=zj+boxzsize
2333       dist_init=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
2334       xj_safe=xj
2335       yj_safe=yj
2336       zj_safe=zj
2337       isubchap=0
2338       do xshift=-1,1
2339       do yshift=-1,1
2340       do zshift=-1,1
2341           xj=xj_safe+xshift*boxxsize
2342           yj=yj_safe+yshift*boxysize
2343           zj=zj_safe+zshift*boxzsize
2344           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
2345           if(dist_temp.lt.dist_init) then
2346             dist_init=dist_temp
2347             xj_temp=xj
2348             yj_temp=yj
2349             zj_temp=zj
2350             isubchap=1
2351           endif
2352        enddo
2353        enddo
2354        enddo
2355        if (isubchap.eq.1) then
2356           xj=xj_temp-xmedi
2357           yj=yj_temp-ymedi
2358           zj=zj_temp-zmedi
2359        else
2360           xj=xj_safe-xmedi
2361           yj=yj_safe-ymedi
2362           zj=zj_safe-zmedi
2363        endif
2364           rij=xj*xj+yj*yj+zj*zj
2365             sss=sscale(sqrt(rij))
2366             sssgrad=sscagrad(sqrt(rij))
2367           if (rij.lt.r0ijsq) then
2368             evdw1ij=0.25d0*(rij-r0ijsq)**2
2369             fac=rij-r0ijsq
2370           else
2371             evdw1ij=0.0d0
2372             fac=0.0d0
2373           endif
2374           evdw1=evdw1+evdw1ij*sss
2375 C
2376 C Calculate contributions to the Cartesian gradient.
2377 C
2378           ggg(1)=fac*xj*sssgrad
2379           ggg(2)=fac*yj*sssgrad
2380           ggg(3)=fac*zj*sssgrad
2381           do k=1,3
2382             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
2383             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
2384           enddo
2385 *
2386 * Loop over residues i+1 thru j-1.
2387 *
2388 cgrad          do k=i+1,j-1
2389 cgrad            do l=1,3
2390 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
2391 cgrad            enddo
2392 cgrad          enddo
2393         enddo ! j
2394       enddo   ! i
2395 cgrad      do i=nnt,nct-1
2396 cgrad        do k=1,3
2397 cgrad          gelc(k,i)=gelc(k,i)+0.5d0*gelc(k,i)
2398 cgrad        enddo
2399 cgrad        do j=i+1,nct-1
2400 cgrad          do k=1,3
2401 cgrad            gelc(k,i)=gelc(k,i)+gelc(k,j)
2402 cgrad          enddo
2403 cgrad        enddo
2404 cgrad      enddo
2405       return
2406       end
2407 c------------------------------------------------------------------------------
2408       subroutine vec_and_deriv
2409       implicit real*8 (a-h,o-z)
2410       include 'DIMENSIONS'
2411 #ifdef MPI
2412       include 'mpif.h'
2413 #endif
2414       include 'COMMON.IOUNITS'
2415       include 'COMMON.GEO'
2416       include 'COMMON.VAR'
2417       include 'COMMON.LOCAL'
2418       include 'COMMON.CHAIN'
2419       include 'COMMON.VECTORS'
2420       include 'COMMON.SETUP'
2421       include 'COMMON.TIME1'
2422       dimension uyder(3,3,2),uzder(3,3,2),vbld_inv_temp(2)
2423 C Compute the local reference systems. For reference system (i), the
2424 C X-axis points from CA(i) to CA(i+1), the Y axis is in the
2425 C CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
2426 #ifdef PARVEC
2427       do i=ivec_start,ivec_end
2428 #else
2429       do i=1,nres-1
2430 #endif
2431           if (i.eq.nres-1) then
2432 C Case of the last full residue
2433 C Compute the Z-axis
2434             call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
2435             costh=dcos(pi-theta(nres))
2436             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2437             do k=1,3
2438               uz(k,i)=fac*uz(k,i)
2439             enddo
2440 C Compute the derivatives of uz
2441             uzder(1,1,1)= 0.0d0
2442             uzder(2,1,1)=-dc_norm(3,i-1)
2443             uzder(3,1,1)= dc_norm(2,i-1)
2444             uzder(1,2,1)= dc_norm(3,i-1)
2445             uzder(2,2,1)= 0.0d0
2446             uzder(3,2,1)=-dc_norm(1,i-1)
2447             uzder(1,3,1)=-dc_norm(2,i-1)
2448             uzder(2,3,1)= dc_norm(1,i-1)
2449             uzder(3,3,1)= 0.0d0
2450             uzder(1,1,2)= 0.0d0
2451             uzder(2,1,2)= dc_norm(3,i)
2452             uzder(3,1,2)=-dc_norm(2,i)
2453             uzder(1,2,2)=-dc_norm(3,i)
2454             uzder(2,2,2)= 0.0d0
2455             uzder(3,2,2)= dc_norm(1,i)
2456             uzder(1,3,2)= dc_norm(2,i)
2457             uzder(2,3,2)=-dc_norm(1,i)
2458             uzder(3,3,2)= 0.0d0
2459 C Compute the Y-axis
2460             facy=fac
2461             do k=1,3
2462               uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
2463             enddo
2464 C Compute the derivatives of uy
2465             do j=1,3
2466               do k=1,3
2467                 uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i)
2468      &                        -dc_norm(k,i)*dc_norm(j,i-1)
2469                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2470               enddo
2471               uyder(j,j,1)=uyder(j,j,1)-costh
2472               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2473             enddo
2474             do j=1,2
2475               do k=1,3
2476                 do l=1,3
2477                   uygrad(l,k,j,i)=uyder(l,k,j)
2478                   uzgrad(l,k,j,i)=uzder(l,k,j)
2479                 enddo
2480               enddo
2481             enddo
2482             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2483             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2484             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2485             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2486           else
2487 C Other residues
2488 C Compute the Z-axis
2489             call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
2490             costh=dcos(pi-theta(i+2))
2491             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2492             do k=1,3
2493               uz(k,i)=fac*uz(k,i)
2494             enddo
2495 C Compute the derivatives of uz
2496             uzder(1,1,1)= 0.0d0
2497             uzder(2,1,1)=-dc_norm(3,i+1)
2498             uzder(3,1,1)= dc_norm(2,i+1)
2499             uzder(1,2,1)= dc_norm(3,i+1)
2500             uzder(2,2,1)= 0.0d0
2501             uzder(3,2,1)=-dc_norm(1,i+1)
2502             uzder(1,3,1)=-dc_norm(2,i+1)
2503             uzder(2,3,1)= dc_norm(1,i+1)
2504             uzder(3,3,1)= 0.0d0
2505             uzder(1,1,2)= 0.0d0
2506             uzder(2,1,2)= dc_norm(3,i)
2507             uzder(3,1,2)=-dc_norm(2,i)
2508             uzder(1,2,2)=-dc_norm(3,i)
2509             uzder(2,2,2)= 0.0d0
2510             uzder(3,2,2)= dc_norm(1,i)
2511             uzder(1,3,2)= dc_norm(2,i)
2512             uzder(2,3,2)=-dc_norm(1,i)
2513             uzder(3,3,2)= 0.0d0
2514 C Compute the Y-axis
2515             facy=fac
2516             do k=1,3
2517               uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
2518             enddo
2519 C Compute the derivatives of uy
2520             do j=1,3
2521               do k=1,3
2522                 uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i)
2523      &                        -dc_norm(k,i)*dc_norm(j,i+1)
2524                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2525               enddo
2526               uyder(j,j,1)=uyder(j,j,1)-costh
2527               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2528             enddo
2529             do j=1,2
2530               do k=1,3
2531                 do l=1,3
2532                   uygrad(l,k,j,i)=uyder(l,k,j)
2533                   uzgrad(l,k,j,i)=uzder(l,k,j)
2534                 enddo
2535               enddo
2536             enddo
2537             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2538             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2539             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2540             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2541           endif
2542       enddo
2543       do i=1,nres-1
2544         vbld_inv_temp(1)=vbld_inv(i+1)
2545         if (i.lt.nres-1) then
2546           vbld_inv_temp(2)=vbld_inv(i+2)
2547           else
2548           vbld_inv_temp(2)=vbld_inv(i)
2549           endif
2550         do j=1,2
2551           do k=1,3
2552             do l=1,3
2553               uygrad(l,k,j,i)=vbld_inv_temp(j)*uygrad(l,k,j,i)
2554               uzgrad(l,k,j,i)=vbld_inv_temp(j)*uzgrad(l,k,j,i)
2555             enddo
2556           enddo
2557         enddo
2558       enddo
2559 #if defined(PARVEC) && defined(MPI)
2560       if (nfgtasks1.gt.1) then
2561         time00=MPI_Wtime()
2562 c        print *,"Processor",fg_rank1,kolor1," ivec_start",ivec_start,
2563 c     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks1-1),
2564 c     &   " ivec_count",(ivec_count(i),i=0,nfgtasks1-1)
2565         call MPI_Allgatherv(uy(1,ivec_start),ivec_count(fg_rank1),
2566      &   MPI_UYZ,uy(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
2567      &   FG_COMM1,IERR)
2568         call MPI_Allgatherv(uz(1,ivec_start),ivec_count(fg_rank1),
2569      &   MPI_UYZ,uz(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
2570      &   FG_COMM1,IERR)
2571         call MPI_Allgatherv(uygrad(1,1,1,ivec_start),
2572      &   ivec_count(fg_rank1),MPI_UYZGRAD,uygrad(1,1,1,1),ivec_count(0),
2573      &   ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2574         call MPI_Allgatherv(uzgrad(1,1,1,ivec_start),
2575      &   ivec_count(fg_rank1),MPI_UYZGRAD,uzgrad(1,1,1,1),ivec_count(0),
2576      &   ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2577         time_gather=time_gather+MPI_Wtime()-time00
2578       endif
2579 c      if (fg_rank.eq.0) then
2580 c        write (iout,*) "Arrays UY and UZ"
2581 c        do i=1,nres-1
2582 c          write (iout,'(i5,3f10.5,5x,3f10.5)') i,(uy(k,i),k=1,3),
2583 c     &     (uz(k,i),k=1,3)
2584 c        enddo
2585 c      endif
2586 #endif
2587       return
2588       end
2589 C-----------------------------------------------------------------------------
2590       subroutine check_vecgrad
2591       implicit real*8 (a-h,o-z)
2592       include 'DIMENSIONS'
2593       include 'COMMON.IOUNITS'
2594       include 'COMMON.GEO'
2595       include 'COMMON.VAR'
2596       include 'COMMON.LOCAL'
2597       include 'COMMON.CHAIN'
2598       include 'COMMON.VECTORS'
2599       dimension uygradt(3,3,2,maxres),uzgradt(3,3,2,maxres)
2600       dimension uyt(3,maxres),uzt(3,maxres)
2601       dimension uygradn(3,3,2),uzgradn(3,3,2),erij(3)
2602       double precision delta /1.0d-7/
2603       call vec_and_deriv
2604 cd      do i=1,nres
2605 crc          write(iout,'(2i5,2(3f10.5,5x))') i,1,dc_norm(:,i)
2606 crc          write(iout,'(2i5,2(3f10.5,5x))') i,2,uy(:,i)
2607 crc          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,uz(:,i)
2608 cd          write(iout,'(2i5,2(3f10.5,5x))') i,1,
2609 cd     &     (dc_norm(if90,i),if90=1,3)
2610 cd          write(iout,'(2i5,2(3f10.5,5x))') i,2,(uy(if90,i),if90=1,3)
2611 cd          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,(uz(if90,i),if90=1,3)
2612 cd          write(iout,'(a)')
2613 cd      enddo
2614       do i=1,nres
2615         do j=1,2
2616           do k=1,3
2617             do l=1,3
2618               uygradt(l,k,j,i)=uygrad(l,k,j,i)
2619               uzgradt(l,k,j,i)=uzgrad(l,k,j,i)
2620             enddo
2621           enddo
2622         enddo
2623       enddo
2624       call vec_and_deriv
2625       do i=1,nres
2626         do j=1,3
2627           uyt(j,i)=uy(j,i)
2628           uzt(j,i)=uz(j,i)
2629         enddo
2630       enddo
2631       do i=1,nres
2632 cd        write (iout,*) 'i=',i
2633         do k=1,3
2634           erij(k)=dc_norm(k,i)
2635         enddo
2636         do j=1,3
2637           do k=1,3
2638             dc_norm(k,i)=erij(k)
2639           enddo
2640           dc_norm(j,i)=dc_norm(j,i)+delta
2641 c          fac=dsqrt(scalar(dc_norm(1,i),dc_norm(1,i)))
2642 c          do k=1,3
2643 c            dc_norm(k,i)=dc_norm(k,i)/fac
2644 c          enddo
2645 c          write (iout,*) (dc_norm(k,i),k=1,3)
2646 c          write (iout,*) (erij(k),k=1,3)
2647           call vec_and_deriv
2648           do k=1,3
2649             uygradn(k,j,1)=(uy(k,i)-uyt(k,i))/delta
2650             uygradn(k,j,2)=(uy(k,i-1)-uyt(k,i-1))/delta
2651             uzgradn(k,j,1)=(uz(k,i)-uzt(k,i))/delta
2652             uzgradn(k,j,2)=(uz(k,i-1)-uzt(k,i-1))/delta
2653           enddo
2654 c          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2655 c     &      j,(uzgradt(k,j,1,i),k=1,3),(uzgradn(k,j,1),k=1,3),
2656 c     &      (uzgradt(k,j,2,i-1),k=1,3),(uzgradn(k,j,2),k=1,3)
2657         enddo
2658         do k=1,3
2659           dc_norm(k,i)=erij(k)
2660         enddo
2661 cd        do k=1,3
2662 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2663 cd     &      k,(uygradt(k,l,1,i),l=1,3),(uygradn(k,l,1),l=1,3),
2664 cd     &      (uygradt(k,l,2,i-1),l=1,3),(uygradn(k,l,2),l=1,3)
2665 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2666 cd     &      k,(uzgradt(k,l,1,i),l=1,3),(uzgradn(k,l,1),l=1,3),
2667 cd     &      (uzgradt(k,l,2,i-1),l=1,3),(uzgradn(k,l,2),l=1,3)
2668 cd          write (iout,'(a)')
2669 cd        enddo
2670       enddo
2671       return
2672       end
2673 C--------------------------------------------------------------------------
2674       subroutine set_matrices
2675       implicit real*8 (a-h,o-z)
2676       include 'DIMENSIONS'
2677 #ifdef MPI
2678       include "mpif.h"
2679       include "COMMON.SETUP"
2680       integer IERR
2681       integer status(MPI_STATUS_SIZE)
2682 #endif
2683       include 'COMMON.IOUNITS'
2684       include 'COMMON.GEO'
2685       include 'COMMON.VAR'
2686       include 'COMMON.LOCAL'
2687       include 'COMMON.CHAIN'
2688       include 'COMMON.DERIV'
2689       include 'COMMON.INTERACT'
2690       include 'COMMON.CONTACTS'
2691       include 'COMMON.TORSION'
2692       include 'COMMON.VECTORS'
2693       include 'COMMON.FFIELD'
2694       double precision auxvec(2),auxmat(2,2)
2695 C
2696 C Compute the virtual-bond-torsional-angle dependent quantities needed
2697 C to calculate the el-loc multibody terms of various order.
2698 C
2699 c      write(iout,*) 'nphi=',nphi,nres
2700 #ifdef PARMAT
2701       do i=ivec_start+2,ivec_end+2
2702 #else
2703       do i=3,nres+1
2704 #endif
2705 #ifdef NEWCORR
2706         if (i.gt. nnt+2 .and. i.lt.nct+2) then
2707           iti = itortyp(itype(i-2))
2708         else
2709           iti=ntortyp+1
2710         endif
2711 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2712         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2713           iti1 = itortyp(itype(i-1))
2714         else
2715           iti1=ntortyp+1
2716         endif
2717 c        write(iout,*),i
2718         b1(1,i-2)=bnew1(1,1,iti)*dsin(theta(i-1)/2.0)
2719      &           +bnew1(2,1,iti)*dsin(theta(i-1))
2720      &           +bnew1(3,1,iti)*dcos(theta(i-1)/2.0)
2721         gtb1(1,i-2)=bnew1(1,1,iti)*dcos(theta(i-1)/2.0d0)/2.0d0
2722      &             +bnew1(2,1,iti)*dcos(theta(i-1))
2723      &             -bnew1(3,1,iti)*dsin(theta(i-1)/2.0d0)/2.0d0
2724 c     &           +bnew1(3,1,iti)*sin(alpha(i))*cos(beta(i))
2725 c     &*(cos(theta(i)/2.0)
2726         b2(1,i-2)=bnew2(1,1,iti)*dsin(theta(i-1)/2.0)
2727      &           +bnew2(2,1,iti)*dsin(theta(i-1))
2728      &           +bnew2(3,1,iti)*dcos(theta(i-1)/2.0)
2729 c     &           +bnew2(3,1,iti)*sin(alpha(i))*cos(beta(i))
2730 c     &*(cos(theta(i)/2.0)
2731         gtb2(1,i-2)=bnew2(1,1,iti)*dcos(theta(i-1)/2.0d0)/2.0d0
2732      &             +bnew2(2,1,iti)*dcos(theta(i-1))
2733      &             -bnew2(3,1,iti)*dsin(theta(i-1)/2.0d0)/2.0d0
2734 c        if (ggb1(1,i).eq.0.0d0) then
2735 c        write(iout,*) 'i=',i,ggb1(1,i),
2736 c     &bnew1(1,1,iti)*cos(theta(i)/2.0)/2.0,
2737 c     &bnew1(2,1,iti)*cos(theta(i)),
2738 c     &bnew1(3,1,iti)*sin(theta(i)/2.0)/2.0
2739 c        endif
2740         b1(2,i-2)=bnew1(1,2,iti)
2741         gtb1(2,i-2)=0.0
2742         b2(2,i-2)=bnew2(1,2,iti)
2743         gtb2(2,i-2)=0.0
2744         EE(1,1,i-2)=eenew(1,iti)*dcos(theta(i-1))
2745         EE(1,2,i-2)=eeold(1,2,iti)
2746         EE(2,1,i-2)=eeold(2,1,iti)
2747         EE(2,2,i-2)=eeold(2,2,iti)
2748         gtEE(1,1,i-2)=-eenew(1,iti)*dsin(theta(i-1))
2749         gtEE(1,2,i-2)=0.0d0
2750         gtEE(2,2,i-2)=0.0d0
2751         gtEE(2,1,i-2)=0.0d0
2752 c        EE(2,2,iti)=0.0d0
2753 c        EE(1,2,iti)=0.5d0*eenew(1,iti)
2754 c        EE(2,1,iti)=0.5d0*eenew(1,iti)
2755 c        b1(2,iti)=bnew1(1,2,iti)*sin(alpha(i))*sin(beta(i))
2756 c        b2(2,iti)=bnew2(1,2,iti)*sin(alpha(i))*sin(beta(i))
2757        b1tilde(1,i-2)=b1(1,i-2)
2758        b1tilde(2,i-2)=-b1(2,i-2)
2759        b2tilde(1,i-2)=b2(1,i-2)
2760        b2tilde(2,i-2)=-b2(2,i-2)
2761 c       write (iout,*) 'i=',i-2,gtb1(2,i-2),gtb1(1,i-2)
2762 c       write(iout,*)  'b1=',b1(1,i-2)
2763 c       write (iout,*) 'theta=', theta(i-1)
2764        enddo
2765 #else
2766         b1(1,i-2)=b(3,iti)
2767         b1(2,i-2)=b(5,iti)
2768         b2(1,i-2)=b(2,iti)
2769         b2(2,i-2)=b(4,iti)
2770        b1tilde(1,i-2)=b1(1,i-2)
2771        b1tilde(2,i-2)=-b1(2,i-2)
2772        b2tilde(1,i-2)=b2(1,i-2)
2773        b2tilde(2,i-2)=-b2(2,i-2)
2774         EE(1,2,i-2)=eeold(1,2,iti)
2775         EE(2,1,i-2)=eeold(2,1,iti)
2776         EE(2,2,i-2)=eeold(2,2,iti)
2777         EE(1,1,i-2)=eeold(1,1,iti)
2778       enddo
2779 #endif
2780 #ifdef PARMAT
2781       do i=ivec_start+2,ivec_end+2
2782 #else
2783       do i=3,nres+1
2784 #endif
2785         if (i .lt. nres+1) then
2786           sin1=dsin(phi(i))
2787           cos1=dcos(phi(i))
2788           sintab(i-2)=sin1
2789           costab(i-2)=cos1
2790           obrot(1,i-2)=cos1
2791           obrot(2,i-2)=sin1
2792           sin2=dsin(2*phi(i))
2793           cos2=dcos(2*phi(i))
2794           sintab2(i-2)=sin2
2795           costab2(i-2)=cos2
2796           obrot2(1,i-2)=cos2
2797           obrot2(2,i-2)=sin2
2798           Ug(1,1,i-2)=-cos1
2799           Ug(1,2,i-2)=-sin1
2800           Ug(2,1,i-2)=-sin1
2801           Ug(2,2,i-2)= cos1
2802           Ug2(1,1,i-2)=-cos2
2803           Ug2(1,2,i-2)=-sin2
2804           Ug2(2,1,i-2)=-sin2
2805           Ug2(2,2,i-2)= cos2
2806         else
2807           costab(i-2)=1.0d0
2808           sintab(i-2)=0.0d0
2809           obrot(1,i-2)=1.0d0
2810           obrot(2,i-2)=0.0d0
2811           obrot2(1,i-2)=0.0d0
2812           obrot2(2,i-2)=0.0d0
2813           Ug(1,1,i-2)=1.0d0
2814           Ug(1,2,i-2)=0.0d0
2815           Ug(2,1,i-2)=0.0d0
2816           Ug(2,2,i-2)=1.0d0
2817           Ug2(1,1,i-2)=0.0d0
2818           Ug2(1,2,i-2)=0.0d0
2819           Ug2(2,1,i-2)=0.0d0
2820           Ug2(2,2,i-2)=0.0d0
2821         endif
2822         if (i .gt. 3 .and. i .lt. nres+1) then
2823           obrot_der(1,i-2)=-sin1
2824           obrot_der(2,i-2)= cos1
2825           Ugder(1,1,i-2)= sin1
2826           Ugder(1,2,i-2)=-cos1
2827           Ugder(2,1,i-2)=-cos1
2828           Ugder(2,2,i-2)=-sin1
2829           dwacos2=cos2+cos2
2830           dwasin2=sin2+sin2
2831           obrot2_der(1,i-2)=-dwasin2
2832           obrot2_der(2,i-2)= dwacos2
2833           Ug2der(1,1,i-2)= dwasin2
2834           Ug2der(1,2,i-2)=-dwacos2
2835           Ug2der(2,1,i-2)=-dwacos2
2836           Ug2der(2,2,i-2)=-dwasin2
2837         else
2838           obrot_der(1,i-2)=0.0d0
2839           obrot_der(2,i-2)=0.0d0
2840           Ugder(1,1,i-2)=0.0d0
2841           Ugder(1,2,i-2)=0.0d0
2842           Ugder(2,1,i-2)=0.0d0
2843           Ugder(2,2,i-2)=0.0d0
2844           obrot2_der(1,i-2)=0.0d0
2845           obrot2_der(2,i-2)=0.0d0
2846           Ug2der(1,1,i-2)=0.0d0
2847           Ug2der(1,2,i-2)=0.0d0
2848           Ug2der(2,1,i-2)=0.0d0
2849           Ug2der(2,2,i-2)=0.0d0
2850         endif
2851 c        if (i.gt. iatel_s+2 .and. i.lt.iatel_e+5) then
2852         if (i.gt. nnt+2 .and. i.lt.nct+2) then
2853           iti = itortyp(itype(i-2))
2854         else
2855           iti=ntortyp
2856         endif
2857 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2858         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2859           iti1 = itortyp(itype(i-1))
2860         else
2861           iti1=ntortyp
2862         endif
2863 cd        write (iout,*) '*******i',i,' iti1',iti
2864 cd        write (iout,*) 'b1',b1(:,iti)
2865 cd        write (iout,*) 'b2',b2(:,iti)
2866 cd        write (iout,*) 'Ug',Ug(:,:,i-2)
2867 c        if (i .gt. iatel_s+2) then
2868         if (i .gt. nnt+2) then
2869           call matvec2(Ug(1,1,i-2),b2(1,i-2),Ub2(1,i-2))
2870 #ifdef NEWCORR
2871           call matvec2(Ug(1,1,i-2),gtb2(1,i-2),gUb2(1,i-2))
2872 c          write (iout,*) Ug(1,1,i-2),gtb2(1,i-2),gUb2(1,i-2),"chuj"
2873 #endif
2874 c          write(iout,*) "co jest kurwa", iti, EE(1,1,iti),EE(2,1,iti),
2875 c     &    EE(1,2,iti),EE(2,2,iti)
2876           call matmat2(EE(1,1,i-2),Ug(1,1,i-2),EUg(1,1,i-2))
2877           call matmat2(gtEE(1,1,i-2),Ug(1,1,i-2),gtEUg(1,1,i-2))
2878 c          write(iout,*) "Macierz EUG",
2879 c     &    eug(1,1,i-2),eug(1,2,i-2),eug(2,1,i-2),
2880 c     &    eug(2,2,i-2)
2881           if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2882      &    then
2883           call matmat2(CC(1,1,iti),Ug(1,1,i-2),CUg(1,1,i-2))
2884           call matmat2(DD(1,1,iti),Ug(1,1,i-2),DUg(1,1,i-2))
2885           call matmat2(Dtilde(1,1,iti),Ug2(1,1,i-2),DtUg2(1,1,i-2))
2886           call matvec2(Ctilde(1,1,iti1),obrot(1,i-2),Ctobr(1,i-2))
2887           call matvec2(Dtilde(1,1,iti),obrot2(1,i-2),Dtobr2(1,i-2))
2888           endif
2889         else
2890           do k=1,2
2891             Ub2(k,i-2)=0.0d0
2892             Ctobr(k,i-2)=0.0d0
2893             Dtobr2(k,i-2)=0.0d0
2894             do l=1,2
2895               EUg(l,k,i-2)=0.0d0
2896               CUg(l,k,i-2)=0.0d0
2897               DUg(l,k,i-2)=0.0d0
2898               DtUg2(l,k,i-2)=0.0d0
2899             enddo
2900           enddo
2901         endif
2902         call matvec2(Ugder(1,1,i-2),b2(1,i-2),Ub2der(1,i-2))
2903         call matmat2(EE(1,1,i-2),Ugder(1,1,i-2),EUgder(1,1,i-2))
2904         do k=1,2
2905           muder(k,i-2)=Ub2der(k,i-2)
2906         enddo
2907 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2908         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2909           if (itype(i-1).le.ntyp) then
2910             iti1 = itortyp(itype(i-1))
2911           else
2912             iti1=ntortyp
2913           endif
2914         else
2915           iti1=ntortyp
2916         endif
2917         do k=1,2
2918           mu(k,i-2)=Ub2(k,i-2)+b1(k,i-1)
2919         enddo
2920 c        write (iout,*) 'mu ',mu(:,i-2),i-2
2921 cd        write (iout,*) 'mu1',mu1(:,i-2)
2922 cd        write (iout,*) 'mu2',mu2(:,i-2)
2923         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
2924      &  then
2925         call matmat2(CC(1,1,iti1),Ugder(1,1,i-2),CUgder(1,1,i-2))
2926         call matmat2(DD(1,1,iti),Ugder(1,1,i-2),DUgder(1,1,i-2))
2927         call matmat2(Dtilde(1,1,iti),Ug2der(1,1,i-2),DtUg2der(1,1,i-2))
2928         call matvec2(Ctilde(1,1,iti1),obrot_der(1,i-2),Ctobrder(1,i-2))
2929         call matvec2(Dtilde(1,1,iti),obrot2_der(1,i-2),Dtobr2der(1,i-2))
2930 C Vectors and matrices dependent on a single virtual-bond dihedral.
2931         call matvec2(DD(1,1,iti),b1tilde(1,i-1),auxvec(1))
2932         call matvec2(Ug2(1,1,i-2),auxvec(1),Ug2Db1t(1,i-2))
2933         call matvec2(Ug2der(1,1,i-2),auxvec(1),Ug2Db1tder(1,i-2))
2934         call matvec2(CC(1,1,iti1),Ub2(1,i-2),CUgb2(1,i-2))
2935         call matvec2(CC(1,1,iti1),Ub2der(1,i-2),CUgb2der(1,i-2))
2936         call matmat2(EUg(1,1,i-2),CC(1,1,iti1),EUgC(1,1,i-2))
2937         call matmat2(EUgder(1,1,i-2),CC(1,1,iti1),EUgCder(1,1,i-2))
2938         call matmat2(EUg(1,1,i-2),DD(1,1,iti1),EUgD(1,1,i-2))
2939         call matmat2(EUgder(1,1,i-2),DD(1,1,iti1),EUgDder(1,1,i-2))
2940         endif
2941       enddo
2942 C Matrices dependent on two consecutive virtual-bond dihedrals.
2943 C The order of matrices is from left to right.
2944       if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
2945      &then
2946 c      do i=max0(ivec_start,2),ivec_end
2947       do i=2,nres-1
2948         call matmat2(DtUg2(1,1,i-1),EUg(1,1,i),DtUg2EUg(1,1,i))
2949         call matmat2(DtUg2der(1,1,i-1),EUg(1,1,i),DtUg2EUgder(1,1,1,i))
2950         call matmat2(DtUg2(1,1,i-1),EUgder(1,1,i),DtUg2EUgder(1,1,2,i))
2951         call transpose2(DtUg2(1,1,i-1),auxmat(1,1))
2952         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUg(1,1,i))
2953         call matmat2(auxmat(1,1),EUgder(1,1,i),Ug2DtEUgder(1,1,2,i))
2954         call transpose2(DtUg2der(1,1,i-1),auxmat(1,1))
2955         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUgder(1,1,1,i))
2956       enddo
2957       endif
2958 #if defined(MPI) && defined(PARMAT)
2959 #ifdef DEBUG
2960 c      if (fg_rank.eq.0) then
2961         write (iout,*) "Arrays UG and UGDER before GATHER"
2962         do i=1,nres-1
2963           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2964      &     ((ug(l,k,i),l=1,2),k=1,2),
2965      &     ((ugder(l,k,i),l=1,2),k=1,2)
2966         enddo
2967         write (iout,*) "Arrays UG2 and UG2DER"
2968         do i=1,nres-1
2969           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2970      &     ((ug2(l,k,i),l=1,2),k=1,2),
2971      &     ((ug2der(l,k,i),l=1,2),k=1,2)
2972         enddo
2973         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
2974         do i=1,nres-1
2975           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2976      &     (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
2977      &     (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
2978         enddo
2979         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
2980         do i=1,nres-1
2981           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2982      &     costab(i),sintab(i),costab2(i),sintab2(i)
2983         enddo
2984         write (iout,*) "Array MUDER"
2985         do i=1,nres-1
2986           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
2987         enddo
2988 c      endif
2989 #endif
2990       if (nfgtasks.gt.1) then
2991         time00=MPI_Wtime()
2992 c        write(iout,*)"Processor",fg_rank,kolor," ivec_start",ivec_start,
2993 c     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks-1),
2994 c     &   " ivec_count",(ivec_count(i),i=0,nfgtasks-1)
2995 #ifdef MATGATHER
2996         call MPI_Allgatherv(Ub2(1,ivec_start),ivec_count(fg_rank1),
2997      &   MPI_MU,Ub2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2998      &   FG_COMM1,IERR)
2999         call MPI_Allgatherv(Ub2der(1,ivec_start),ivec_count(fg_rank1),
3000      &   MPI_MU,Ub2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3001      &   FG_COMM1,IERR)
3002         call MPI_Allgatherv(mu(1,ivec_start),ivec_count(fg_rank1),
3003      &   MPI_MU,mu(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3004      &   FG_COMM1,IERR)
3005         call MPI_Allgatherv(muder(1,ivec_start),ivec_count(fg_rank1),
3006      &   MPI_MU,muder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3007      &   FG_COMM1,IERR)
3008         call MPI_Allgatherv(Eug(1,1,ivec_start),ivec_count(fg_rank1),
3009      &   MPI_MAT1,Eug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3010      &   FG_COMM1,IERR)
3011         call MPI_Allgatherv(Eugder(1,1,ivec_start),ivec_count(fg_rank1),
3012      &   MPI_MAT1,Eugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3013      &   FG_COMM1,IERR)
3014         call MPI_Allgatherv(costab(ivec_start),ivec_count(fg_rank1),
3015      &   MPI_DOUBLE_PRECISION,costab(1),ivec_count(0),ivec_displ(0),
3016      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3017         call MPI_Allgatherv(sintab(ivec_start),ivec_count(fg_rank1),
3018      &   MPI_DOUBLE_PRECISION,sintab(1),ivec_count(0),ivec_displ(0),
3019      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3020         call MPI_Allgatherv(costab2(ivec_start),ivec_count(fg_rank1),
3021      &   MPI_DOUBLE_PRECISION,costab2(1),ivec_count(0),ivec_displ(0),
3022      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3023         call MPI_Allgatherv(sintab2(ivec_start),ivec_count(fg_rank1),
3024      &   MPI_DOUBLE_PRECISION,sintab2(1),ivec_count(0),ivec_displ(0),
3025      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3026         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
3027      &  then
3028         call MPI_Allgatherv(Ctobr(1,ivec_start),ivec_count(fg_rank1),
3029      &   MPI_MU,Ctobr(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3030      &   FG_COMM1,IERR)
3031         call MPI_Allgatherv(Ctobrder(1,ivec_start),ivec_count(fg_rank1),
3032      &   MPI_MU,Ctobrder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3033      &   FG_COMM1,IERR)
3034         call MPI_Allgatherv(Dtobr2(1,ivec_start),ivec_count(fg_rank1),
3035      &   MPI_MU,Dtobr2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3036      &   FG_COMM1,IERR)
3037        call MPI_Allgatherv(Dtobr2der(1,ivec_start),ivec_count(fg_rank1),
3038      &   MPI_MU,Dtobr2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3039      &   FG_COMM1,IERR)
3040         call MPI_Allgatherv(Ug2Db1t(1,ivec_start),ivec_count(fg_rank1),
3041      &   MPI_MU,Ug2Db1t(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3042      &   FG_COMM1,IERR)
3043         call MPI_Allgatherv(Ug2Db1tder(1,ivec_start),
3044      &   ivec_count(fg_rank1),
3045      &   MPI_MU,Ug2Db1tder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3046      &   FG_COMM1,IERR)
3047         call MPI_Allgatherv(CUgb2(1,ivec_start),ivec_count(fg_rank1),
3048      &   MPI_MU,CUgb2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3049      &   FG_COMM1,IERR)
3050         call MPI_Allgatherv(CUgb2der(1,ivec_start),ivec_count(fg_rank1),
3051      &   MPI_MU,CUgb2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3052      &   FG_COMM1,IERR)
3053         call MPI_Allgatherv(Cug(1,1,ivec_start),ivec_count(fg_rank1),
3054      &   MPI_MAT1,Cug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3055      &   FG_COMM1,IERR)
3056         call MPI_Allgatherv(Cugder(1,1,ivec_start),ivec_count(fg_rank1),
3057      &   MPI_MAT1,Cugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3058      &   FG_COMM1,IERR)
3059         call MPI_Allgatherv(Dug(1,1,ivec_start),ivec_count(fg_rank1),
3060      &   MPI_MAT1,Dug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3061      &   FG_COMM1,IERR)
3062         call MPI_Allgatherv(Dugder(1,1,ivec_start),ivec_count(fg_rank1),
3063      &   MPI_MAT1,Dugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3064      &   FG_COMM1,IERR)
3065         call MPI_Allgatherv(Dtug2(1,1,ivec_start),ivec_count(fg_rank1),
3066      &   MPI_MAT1,Dtug2(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3067      &   FG_COMM1,IERR)
3068         call MPI_Allgatherv(Dtug2der(1,1,ivec_start),
3069      &   ivec_count(fg_rank1),
3070      &   MPI_MAT1,Dtug2der(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3071      &   FG_COMM1,IERR)
3072         call MPI_Allgatherv(EugC(1,1,ivec_start),ivec_count(fg_rank1),
3073      &   MPI_MAT1,EugC(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3074      &   FG_COMM1,IERR)
3075        call MPI_Allgatherv(EugCder(1,1,ivec_start),ivec_count(fg_rank1),
3076      &   MPI_MAT1,EugCder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3077      &   FG_COMM1,IERR)
3078         call MPI_Allgatherv(EugD(1,1,ivec_start),ivec_count(fg_rank1),
3079      &   MPI_MAT1,EugD(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3080      &   FG_COMM1,IERR)
3081        call MPI_Allgatherv(EugDder(1,1,ivec_start),ivec_count(fg_rank1),
3082      &   MPI_MAT1,EugDder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3083      &   FG_COMM1,IERR)
3084         call MPI_Allgatherv(DtUg2EUg(1,1,ivec_start),
3085      &   ivec_count(fg_rank1),
3086      &   MPI_MAT1,DtUg2EUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3087      &   FG_COMM1,IERR)
3088         call MPI_Allgatherv(Ug2DtEUg(1,1,ivec_start),
3089      &   ivec_count(fg_rank1),
3090      &   MPI_MAT1,Ug2DtEUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3091      &   FG_COMM1,IERR)
3092         call MPI_Allgatherv(DtUg2EUgder(1,1,1,ivec_start),
3093      &   ivec_count(fg_rank1),
3094      &   MPI_MAT2,DtUg2EUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
3095      &   MPI_MAT2,FG_COMM1,IERR)
3096         call MPI_Allgatherv(Ug2DtEUgder(1,1,1,ivec_start),
3097      &   ivec_count(fg_rank1),
3098      &   MPI_MAT2,Ug2DtEUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
3099      &   MPI_MAT2,FG_COMM1,IERR)
3100         endif
3101 #else
3102 c Passes matrix info through the ring
3103       isend=fg_rank1
3104       irecv=fg_rank1-1
3105       if (irecv.lt.0) irecv=nfgtasks1-1
3106       iprev=irecv
3107       inext=fg_rank1+1
3108       if (inext.ge.nfgtasks1) inext=0
3109       do i=1,nfgtasks1-1
3110 c        write (iout,*) "isend",isend," irecv",irecv
3111 c        call flush(iout)
3112         lensend=lentyp(isend)
3113         lenrecv=lentyp(irecv)
3114 c        write (iout,*) "lensend",lensend," lenrecv",lenrecv
3115 c        call MPI_SENDRECV(ug(1,1,ivec_displ(isend)+1),1,
3116 c     &   MPI_ROTAT1(lensend),inext,2200+isend,
3117 c     &   ug(1,1,ivec_displ(irecv)+1),1,MPI_ROTAT1(lenrecv),
3118 c     &   iprev,2200+irecv,FG_COMM,status,IERR)
3119 c        write (iout,*) "Gather ROTAT1"
3120 c        call flush(iout)
3121 c        call MPI_SENDRECV(obrot(1,ivec_displ(isend)+1),1,
3122 c     &   MPI_ROTAT2(lensend),inext,3300+isend,
3123 c     &   obrot(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
3124 c     &   iprev,3300+irecv,FG_COMM,status,IERR)
3125 c        write (iout,*) "Gather ROTAT2"
3126 c        call flush(iout)
3127         call MPI_SENDRECV(costab(ivec_displ(isend)+1),1,
3128      &   MPI_ROTAT_OLD(lensend),inext,4400+isend,
3129      &   costab(ivec_displ(irecv)+1),1,MPI_ROTAT_OLD(lenrecv),
3130      &   iprev,4400+irecv,FG_COMM,status,IERR)
3131 c        write (iout,*) "Gather ROTAT_OLD"
3132 c        call flush(iout)
3133         call MPI_SENDRECV(mu(1,ivec_displ(isend)+1),1,
3134      &   MPI_PRECOMP11(lensend),inext,5500+isend,
3135      &   mu(1,ivec_displ(irecv)+1),1,MPI_PRECOMP11(lenrecv),
3136      &   iprev,5500+irecv,FG_COMM,status,IERR)
3137 c        write (iout,*) "Gather PRECOMP11"
3138 c        call flush(iout)
3139         call MPI_SENDRECV(Eug(1,1,ivec_displ(isend)+1),1,
3140      &   MPI_PRECOMP12(lensend),inext,6600+isend,
3141      &   Eug(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP12(lenrecv),
3142      &   iprev,6600+irecv,FG_COMM,status,IERR)
3143 c        write (iout,*) "Gather PRECOMP12"
3144 c        call flush(iout)
3145         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
3146      &  then
3147         call MPI_SENDRECV(ug2db1t(1,ivec_displ(isend)+1),1,
3148      &   MPI_ROTAT2(lensend),inext,7700+isend,
3149      &   ug2db1t(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
3150      &   iprev,7700+irecv,FG_COMM,status,IERR)
3151 c        write (iout,*) "Gather PRECOMP21"
3152 c        call flush(iout)
3153         call MPI_SENDRECV(EUgC(1,1,ivec_displ(isend)+1),1,
3154      &   MPI_PRECOMP22(lensend),inext,8800+isend,
3155      &   EUgC(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP22(lenrecv),
3156      &   iprev,8800+irecv,FG_COMM,status,IERR)
3157 c        write (iout,*) "Gather PRECOMP22"
3158 c        call flush(iout)
3159         call MPI_SENDRECV(Ug2DtEUgder(1,1,1,ivec_displ(isend)+1),1,
3160      &   MPI_PRECOMP23(lensend),inext,9900+isend,
3161      &   Ug2DtEUgder(1,1,1,ivec_displ(irecv)+1),1,
3162      &   MPI_PRECOMP23(lenrecv),
3163      &   iprev,9900+irecv,FG_COMM,status,IERR)
3164 c        write (iout,*) "Gather PRECOMP23"
3165 c        call flush(iout)
3166         endif
3167         isend=irecv
3168         irecv=irecv-1
3169         if (irecv.lt.0) irecv=nfgtasks1-1
3170       enddo
3171 #endif
3172         time_gather=time_gather+MPI_Wtime()-time00
3173       endif
3174 #ifdef DEBUG
3175 c      if (fg_rank.eq.0) then
3176         write (iout,*) "Arrays UG and UGDER"
3177         do i=1,nres-1
3178           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3179      &     ((ug(l,k,i),l=1,2),k=1,2),
3180      &     ((ugder(l,k,i),l=1,2),k=1,2)
3181         enddo
3182         write (iout,*) "Arrays UG2 and UG2DER"
3183         do i=1,nres-1
3184           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3185      &     ((ug2(l,k,i),l=1,2),k=1,2),
3186      &     ((ug2der(l,k,i),l=1,2),k=1,2)
3187         enddo
3188         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
3189         do i=1,nres-1
3190           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3191      &     (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
3192      &     (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
3193         enddo
3194         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
3195         do i=1,nres-1
3196           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3197      &     costab(i),sintab(i),costab2(i),sintab2(i)
3198         enddo
3199         write (iout,*) "Array MUDER"
3200         do i=1,nres-1
3201           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
3202         enddo
3203 c      endif
3204 #endif
3205 #endif
3206 cd      do i=1,nres
3207 cd        iti = itortyp(itype(i))
3208 cd        write (iout,*) i
3209 cd        do j=1,2
3210 cd        write (iout,'(2f10.5,5x,2f10.5,5x,2f10.5)')
3211 cd     &  (EE(j,k,iti),k=1,2),(Ug(j,k,i),k=1,2),(EUg(j,k,i),k=1,2)
3212 cd        enddo
3213 cd      enddo
3214       return
3215       end
3216 C--------------------------------------------------------------------------
3217       subroutine eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
3218 C
3219 C This subroutine calculates the average interaction energy and its gradient
3220 C in the virtual-bond vectors between non-adjacent peptide groups, based on
3221 C the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
3222 C The potential depends both on the distance of peptide-group centers and on
3223 C the orientation of the CA-CA virtual bonds.
3224 C
3225       implicit real*8 (a-h,o-z)
3226 #ifdef MPI
3227       include 'mpif.h'
3228 #endif
3229       include 'DIMENSIONS'
3230       include 'COMMON.CONTROL'
3231       include 'COMMON.SETUP'
3232       include 'COMMON.IOUNITS'
3233       include 'COMMON.GEO'
3234       include 'COMMON.VAR'
3235       include 'COMMON.LOCAL'
3236       include 'COMMON.CHAIN'
3237       include 'COMMON.DERIV'
3238       include 'COMMON.INTERACT'
3239       include 'COMMON.CONTACTS'
3240       include 'COMMON.TORSION'
3241       include 'COMMON.VECTORS'
3242       include 'COMMON.FFIELD'
3243       include 'COMMON.TIME1'
3244       include 'COMMON.SPLITELE'
3245       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
3246      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
3247       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
3248      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4),gmuij(4)
3249       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3250      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3251      &    num_conti,j1,j2
3252 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
3253 #ifdef MOMENT
3254       double precision scal_el /1.0d0/
3255 #else
3256       double precision scal_el /0.5d0/
3257 #endif
3258 C 12/13/98
3259 C 13-go grudnia roku pamietnego...
3260       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
3261      &                   0.0d0,1.0d0,0.0d0,
3262      &                   0.0d0,0.0d0,1.0d0/
3263 cd      write(iout,*) 'In EELEC'
3264 cd      do i=1,nloctyp
3265 cd        write(iout,*) 'Type',i
3266 cd        write(iout,*) 'B1',B1(:,i)
3267 cd        write(iout,*) 'B2',B2(:,i)
3268 cd        write(iout,*) 'CC',CC(:,:,i)
3269 cd        write(iout,*) 'DD',DD(:,:,i)
3270 cd        write(iout,*) 'EE',EE(:,:,i)
3271 cd      enddo
3272 cd      call check_vecgrad
3273 cd      stop
3274       if (icheckgrad.eq.1) then
3275         do i=1,nres-1
3276           fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
3277           do k=1,3
3278             dc_norm(k,i)=dc(k,i)*fac
3279           enddo
3280 c          write (iout,*) 'i',i,' fac',fac
3281         enddo
3282       endif
3283       if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
3284      &    .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or.
3285      &    wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
3286 c        call vec_and_deriv
3287 #ifdef TIMING
3288         time01=MPI_Wtime()
3289 #endif
3290         call set_matrices
3291 #ifdef TIMING
3292         time_mat=time_mat+MPI_Wtime()-time01
3293 #endif
3294       endif
3295 cd      do i=1,nres-1
3296 cd        write (iout,*) 'i=',i
3297 cd        do k=1,3
3298 cd        write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
3299 cd        enddo
3300 cd        do k=1,3
3301 cd          write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
3302 cd     &     uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
3303 cd        enddo
3304 cd      enddo
3305       t_eelecij=0.0d0
3306       ees=0.0D0
3307       evdw1=0.0D0
3308       eel_loc=0.0d0
3309       eello_turn3=0.0d0
3310       eello_turn4=0.0d0
3311       ind=0
3312       do i=1,nres
3313         num_cont_hb(i)=0
3314       enddo
3315 cd      print '(a)','Enter EELEC'
3316 cd      write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
3317       do i=1,nres
3318         gel_loc_loc(i)=0.0d0
3319         gcorr_loc(i)=0.0d0
3320       enddo
3321 c
3322 c
3323 c 9/27/08 AL Split the interaction loop to ensure load balancing of turn terms
3324 C
3325 C Loop over i,i+2 and i,i+3 pairs of the peptide groups
3326 C
3327 C 14/01/2014 TURN3,TUNR4 does no go under periodic boundry condition
3328       do i=iturn3_start,iturn3_end
3329         if (i.le.1) cycle
3330 C        write(iout,*) "tu jest i",i
3331         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
3332 C changes suggested by Ana to avoid out of bounds
3333      & .or.((i+4).gt.nres)
3334      & .or.((i-1).le.0)
3335 C end of changes by Ana
3336      &  .or. itype(i+2).eq.ntyp1
3337      &  .or. itype(i+3).eq.ntyp1) cycle
3338         if(i.gt.1)then
3339           if(itype(i-1).eq.ntyp1)cycle
3340         end if
3341         if(i.LT.nres-3)then
3342           if (itype(i+4).eq.ntyp1) cycle
3343         end if
3344         dxi=dc(1,i)
3345         dyi=dc(2,i)
3346         dzi=dc(3,i)
3347         dx_normi=dc_norm(1,i)
3348         dy_normi=dc_norm(2,i)
3349         dz_normi=dc_norm(3,i)
3350         xmedi=c(1,i)+0.5d0*dxi
3351         ymedi=c(2,i)+0.5d0*dyi
3352         zmedi=c(3,i)+0.5d0*dzi
3353           xmedi=mod(xmedi,boxxsize)
3354           if (xmedi.lt.0) xmedi=xmedi+boxxsize
3355           ymedi=mod(ymedi,boxysize)
3356           if (ymedi.lt.0) ymedi=ymedi+boxysize
3357           zmedi=mod(zmedi,boxzsize)
3358           if (zmedi.lt.0) zmedi=zmedi+boxzsize
3359         num_conti=0
3360         call eelecij(i,i+2,ees,evdw1,eel_loc)
3361         if (wturn3.gt.0.0d0) call eturn3(i,eello_turn3)
3362         num_cont_hb(i)=num_conti
3363       enddo
3364       do i=iturn4_start,iturn4_end
3365         if (i.le.1) cycle
3366         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
3367 C changes suggested by Ana to avoid out of bounds
3368      & .or.((i+5).gt.nres)
3369      & .or.((i-1).le.0)
3370 C end of changes suggested by Ana
3371      &    .or. itype(i+3).eq.ntyp1
3372      &    .or. itype(i+4).eq.ntyp1
3373      &    .or. itype(i+5).eq.ntyp1
3374      &    .or. itype(i).eq.ntyp1
3375      &    .or. itype(i-1).eq.ntyp1
3376      &                             ) cycle
3377         dxi=dc(1,i)
3378         dyi=dc(2,i)
3379         dzi=dc(3,i)
3380         dx_normi=dc_norm(1,i)
3381         dy_normi=dc_norm(2,i)
3382         dz_normi=dc_norm(3,i)
3383         xmedi=c(1,i)+0.5d0*dxi
3384         ymedi=c(2,i)+0.5d0*dyi
3385         zmedi=c(3,i)+0.5d0*dzi
3386 C Return atom into box, boxxsize is size of box in x dimension
3387 c  194   continue
3388 c        if (xmedi.gt.((0.5d0)*boxxsize)) xmedi=xmedi-boxxsize
3389 c        if (xmedi.lt.((-0.5d0)*boxxsize)) xmedi=xmedi+boxxsize
3390 C Condition for being inside the proper box
3391 c        if ((xmedi.gt.((0.5d0)*boxxsize)).or.
3392 c     &       (xmedi.lt.((-0.5d0)*boxxsize))) then
3393 c        go to 194
3394 c        endif
3395 c  195   continue
3396 c        if (ymedi.gt.((0.5d0)*boxysize)) ymedi=ymedi-boxysize
3397 c        if (ymedi.lt.((-0.5d0)*boxysize)) ymedi=ymedi+boxysize
3398 C Condition for being inside the proper box
3399 c        if ((ymedi.gt.((0.5d0)*boxysize)).or.
3400 c     &       (ymedi.lt.((-0.5d0)*boxysize))) then
3401 c        go to 195
3402 c        endif
3403 c  196   continue
3404 c        if (zmedi.gt.((0.5d0)*boxzsize)) zmedi=zmedi-boxzsize
3405 c        if (zmedi.lt.((-0.5d0)*boxzsize)) zmedi=zmedi+boxzsize
3406 C Condition for being inside the proper box
3407 c        if ((zmedi.gt.((0.5d0)*boxzsize)).or.
3408 c     &       (zmedi.lt.((-0.5d0)*boxzsize))) then
3409 c        go to 196
3410 c        endif
3411           xmedi=mod(xmedi,boxxsize)
3412           if (xmedi.lt.0) xmedi=xmedi+boxxsize
3413           ymedi=mod(ymedi,boxysize)
3414           if (ymedi.lt.0) ymedi=ymedi+boxysize
3415           zmedi=mod(zmedi,boxzsize)
3416           if (zmedi.lt.0) zmedi=zmedi+boxzsize
3417
3418         num_conti=num_cont_hb(i)
3419 c        write(iout,*) "JESTEM W PETLI"
3420         call eelecij(i,i+3,ees,evdw1,eel_loc)
3421         if (wturn4.gt.0.0d0 .and. itype(i+2).ne.ntyp1)
3422      &   call eturn4(i,eello_turn4)
3423         num_cont_hb(i)=num_conti
3424       enddo   ! i
3425 C Loop over all neighbouring boxes
3426 C      do xshift=-1,1
3427 C      do yshift=-1,1
3428 C      do zshift=-1,1
3429 c
3430 c Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
3431 c
3432       do i=iatel_s,iatel_e
3433         if (i.le.1) cycle
3434         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
3435 C changes suggested by Ana to avoid out of bounds
3436      & .or.((i+2).gt.nres)
3437      & .or.((i-1).le.0)
3438 C end of changes by Ana
3439      &  .or. itype(i+2).eq.ntyp1
3440      &  .or. itype(i-1).eq.ntyp1
3441      &                ) cycle
3442         dxi=dc(1,i)
3443         dyi=dc(2,i)
3444         dzi=dc(3,i)
3445         dx_normi=dc_norm(1,i)
3446         dy_normi=dc_norm(2,i)
3447         dz_normi=dc_norm(3,i)
3448         xmedi=c(1,i)+0.5d0*dxi
3449         ymedi=c(2,i)+0.5d0*dyi
3450         zmedi=c(3,i)+0.5d0*dzi
3451           xmedi=mod(xmedi,boxxsize)
3452           if (xmedi.lt.0) xmedi=xmedi+boxxsize
3453           ymedi=mod(ymedi,boxysize)
3454           if (ymedi.lt.0) ymedi=ymedi+boxysize
3455           zmedi=mod(zmedi,boxzsize)
3456           if (zmedi.lt.0) zmedi=zmedi+boxzsize
3457 C          xmedi=xmedi+xshift*boxxsize
3458 C          ymedi=ymedi+yshift*boxysize
3459 C          zmedi=zmedi+zshift*boxzsize
3460
3461 C Return tom into box, boxxsize is size of box in x dimension
3462 c  164   continue
3463 c        if (xmedi.gt.((xshift+0.5d0)*boxxsize)) xmedi=xmedi-boxxsize
3464 c        if (xmedi.lt.((xshift-0.5d0)*boxxsize)) xmedi=xmedi+boxxsize
3465 C Condition for being inside the proper box
3466 c        if ((xmedi.gt.((xshift+0.5d0)*boxxsize)).or.
3467 c     &       (xmedi.lt.((xshift-0.5d0)*boxxsize))) then
3468 c        go to 164
3469 c        endif
3470 c  165   continue
3471 c        if (ymedi.gt.((yshift+0.5d0)*boxysize)) ymedi=ymedi-boxysize
3472 c        if (ymedi.lt.((yshift-0.5d0)*boxysize)) ymedi=ymedi+boxysize
3473 C Condition for being inside the proper box
3474 c        if ((ymedi.gt.((yshift+0.5d0)*boxysize)).or.
3475 c     &       (ymedi.lt.((yshift-0.5d0)*boxysize))) then
3476 c        go to 165
3477 c        endif
3478 c  166   continue
3479 c        if (zmedi.gt.((zshift+0.5d0)*boxzsize)) zmedi=zmedi-boxzsize
3480 c        if (zmedi.lt.((zshift-0.5d0)*boxzsize)) zmedi=zmedi+boxzsize
3481 cC Condition for being inside the proper box
3482 c        if ((zmedi.gt.((zshift+0.5d0)*boxzsize)).or.
3483 c     &       (zmedi.lt.((zshift-0.5d0)*boxzsize))) then
3484 c        go to 166
3485 c        endif
3486
3487 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
3488         num_conti=num_cont_hb(i)
3489         do j=ielstart(i),ielend(i)
3490 C          write (iout,*) i,j
3491          if (j.le.1) cycle
3492           if (itype(j).eq.ntyp1.or. itype(j+1).eq.ntyp1
3493 C changes suggested by Ana to avoid out of bounds
3494      & .or.((j+2).gt.nres)
3495      & .or.((j-1).le.0)
3496 C end of changes by Ana
3497      & .or.itype(j+2).eq.ntyp1
3498      & .or.itype(j-1).eq.ntyp1
3499      &) cycle
3500           call eelecij(i,j,ees,evdw1,eel_loc)
3501         enddo ! j
3502         num_cont_hb(i)=num_conti
3503       enddo   ! i
3504 C     enddo   ! zshift
3505 C      enddo   ! yshift
3506 C      enddo   ! xshift
3507
3508 c      write (iout,*) "Number of loop steps in EELEC:",ind
3509 cd      do i=1,nres
3510 cd        write (iout,'(i3,3f10.5,5x,3f10.5)')
3511 cd     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
3512 cd      enddo
3513 c 12/7/99 Adam eello_turn3 will be considered as a separate energy term
3514 ccc      eel_loc=eel_loc+eello_turn3
3515 cd      print *,"Processor",fg_rank," t_eelecij",t_eelecij
3516       return
3517       end
3518 C-------------------------------------------------------------------------------
3519       subroutine eelecij(i,j,ees,evdw1,eel_loc)
3520       implicit real*8 (a-h,o-z)
3521       include 'DIMENSIONS'
3522 #ifdef MPI
3523       include "mpif.h"
3524 #endif
3525       include 'COMMON.CONTROL'
3526       include 'COMMON.IOUNITS'
3527       include 'COMMON.GEO'
3528       include 'COMMON.VAR'
3529       include 'COMMON.LOCAL'
3530       include 'COMMON.CHAIN'
3531       include 'COMMON.DERIV'
3532       include 'COMMON.INTERACT'
3533       include 'COMMON.CONTACTS'
3534       include 'COMMON.TORSION'
3535       include 'COMMON.VECTORS'
3536       include 'COMMON.FFIELD'
3537       include 'COMMON.TIME1'
3538       include 'COMMON.SPLITELE'
3539       include 'COMMON.SHIELD'
3540       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
3541      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
3542       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
3543      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4),gmuij1(4),gmuji1(4),
3544      &    gmuij2(4),gmuji2(4)
3545       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3546      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3547      &    num_conti,j1,j2
3548 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
3549 #ifdef MOMENT
3550       double precision scal_el /1.0d0/
3551 #else
3552       double precision scal_el /0.5d0/
3553 #endif
3554 C 12/13/98
3555 C 13-go grudnia roku pamietnego...
3556       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
3557      &                   0.0d0,1.0d0,0.0d0,
3558      &                   0.0d0,0.0d0,1.0d0/
3559 c          time00=MPI_Wtime()
3560 cd      write (iout,*) "eelecij",i,j
3561 c          ind=ind+1
3562           iteli=itel(i)
3563           itelj=itel(j)
3564           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
3565           aaa=app(iteli,itelj)
3566           bbb=bpp(iteli,itelj)
3567           ael6i=ael6(iteli,itelj)
3568           ael3i=ael3(iteli,itelj)
3569           dxj=dc(1,j)
3570           dyj=dc(2,j)
3571           dzj=dc(3,j)
3572           dx_normj=dc_norm(1,j)
3573           dy_normj=dc_norm(2,j)
3574           dz_normj=dc_norm(3,j)
3575 C          xj=c(1,j)+0.5D0*dxj-xmedi
3576 C          yj=c(2,j)+0.5D0*dyj-ymedi
3577 C          zj=c(3,j)+0.5D0*dzj-zmedi
3578           xj=c(1,j)+0.5D0*dxj
3579           yj=c(2,j)+0.5D0*dyj
3580           zj=c(3,j)+0.5D0*dzj
3581           xj=mod(xj,boxxsize)
3582           if (xj.lt.0) xj=xj+boxxsize
3583           yj=mod(yj,boxysize)
3584           if (yj.lt.0) yj=yj+boxysize
3585           zj=mod(zj,boxzsize)
3586           if (zj.lt.0) zj=zj+boxzsize
3587           if ((zj.lt.0).or.(xj.lt.0).or.(yj.lt.0)) write (*,*) "CHUJ"
3588       dist_init=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
3589       xj_safe=xj
3590       yj_safe=yj
3591       zj_safe=zj
3592       isubchap=0
3593       do xshift=-1,1
3594       do yshift=-1,1
3595       do zshift=-1,1
3596           xj=xj_safe+xshift*boxxsize
3597           yj=yj_safe+yshift*boxysize
3598           zj=zj_safe+zshift*boxzsize
3599           dist_temp=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
3600           if(dist_temp.lt.dist_init) then
3601             dist_init=dist_temp
3602             xj_temp=xj
3603             yj_temp=yj
3604             zj_temp=zj
3605             isubchap=1
3606           endif
3607        enddo
3608        enddo
3609        enddo
3610        if (isubchap.eq.1) then
3611           xj=xj_temp-xmedi
3612           yj=yj_temp-ymedi
3613           zj=zj_temp-zmedi
3614        else
3615           xj=xj_safe-xmedi
3616           yj=yj_safe-ymedi
3617           zj=zj_safe-zmedi
3618        endif
3619 C        if ((i+3).lt.j) then !this condition keeps for turn3 and turn4 not subject to PBC
3620 c  174   continue
3621 c        if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
3622 c        if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
3623 C Condition for being inside the proper box
3624 c        if ((xj.gt.((0.5d0)*boxxsize)).or.
3625 c     &       (xj.lt.((-0.5d0)*boxxsize))) then
3626 c        go to 174
3627 c        endif
3628 c  175   continue
3629 c        if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
3630 c        if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
3631 C Condition for being inside the proper box
3632 c        if ((yj.gt.((0.5d0)*boxysize)).or.
3633 c     &       (yj.lt.((-0.5d0)*boxysize))) then
3634 c        go to 175
3635 c        endif
3636 c  176   continue
3637 c        if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
3638 c        if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
3639 C Condition for being inside the proper box
3640 c        if ((zj.gt.((0.5d0)*boxzsize)).or.
3641 c     &       (zj.lt.((-0.5d0)*boxzsize))) then
3642 c        go to 176
3643 c        endif
3644 C        endif !endPBC condintion
3645 C        xj=xj-xmedi
3646 C        yj=yj-ymedi
3647 C        zj=zj-zmedi
3648           rij=xj*xj+yj*yj+zj*zj
3649
3650             sss=sscale(sqrt(rij))
3651             sssgrad=sscagrad(sqrt(rij))
3652 c            if (sss.gt.0.0d0) then
3653           rrmij=1.0D0/rij
3654           rij=dsqrt(rij)
3655           rmij=1.0D0/rij
3656           r3ij=rrmij*rmij
3657           r6ij=r3ij*r3ij
3658           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
3659           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
3660           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
3661           fac=cosa-3.0D0*cosb*cosg
3662           ev1=aaa*r6ij*r6ij
3663 c 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
3664           if (j.eq.i+2) ev1=scal_el*ev1
3665           ev2=bbb*r6ij
3666           fac3=ael6i*r6ij
3667           fac4=ael3i*r3ij
3668           evdwij=(ev1+ev2)
3669           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
3670           el2=fac4*fac
3671 C MARYSIA
3672           eesij=(el1+el2)
3673 C 12/26/95 - for the evaluation of multi-body H-bonding interactions
3674           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
3675           if (shield_mode.gt.0) then
3676           ees=ees+eesij*fac_shield(i)*fac_shield(j)
3677           else
3678           ees=ees+eesij
3679           endif
3680           evdw1=evdw1+evdwij*sss
3681 cd          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
3682 cd     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
3683 cd     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
3684 cd     &      xmedi,ymedi,zmedi,xj,yj,zj
3685
3686           if (energy_dec) then
3687               write (iout,'(a6,2i5,0pf7.3,2i5,2e11.3)')
3688      &'evdw1',i,j,evdwij
3689      &,iteli,itelj,aaa,evdw1
3690               write (iout,'(a6,2i5,0pf7.3)') 'ees',i,j,eesij
3691           endif
3692
3693 C
3694 C Calculate contributions to the Cartesian gradient.
3695 C
3696 #ifdef SPLITELE
3697           facvdw=-6*rrmij*(ev1+evdwij)*sss
3698           facel=-3*rrmij*(el1+eesij)
3699           fac1=fac
3700           erij(1)=xj*rmij
3701           erij(2)=yj*rmij
3702           erij(3)=zj*rmij
3703 *
3704 * Radial derivatives. First process both termini of the fragment (i,j)
3705 *
3706           ggg(1)=facel*xj
3707           ggg(2)=facel*yj
3708           ggg(3)=facel*zj
3709 c          do k=1,3
3710 c            ghalf=0.5D0*ggg(k)
3711 c            gelc(k,i)=gelc(k,i)+ghalf
3712 c            gelc(k,j)=gelc(k,j)+ghalf
3713 c          enddo
3714 c 9/28/08 AL Gradient compotents will be summed only at the end
3715           do k=1,3
3716             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
3717             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
3718           enddo
3719 *
3720 * Loop over residues i+1 thru j-1.
3721 *
3722 cgrad          do k=i+1,j-1
3723 cgrad            do l=1,3
3724 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3725 cgrad            enddo
3726 cgrad          enddo
3727           if (sss.gt.0.0) then
3728           ggg(1)=facvdw*xj+sssgrad*rmij*evdwij*xj
3729           ggg(2)=facvdw*yj+sssgrad*rmij*evdwij*yj
3730           ggg(3)=facvdw*zj+sssgrad*rmij*evdwij*zj
3731           else
3732           ggg(1)=0.0
3733           ggg(2)=0.0
3734           ggg(3)=0.0
3735           endif
3736 c          do k=1,3
3737 c            ghalf=0.5D0*ggg(k)
3738 c            gvdwpp(k,i)=gvdwpp(k,i)+ghalf
3739 c            gvdwpp(k,j)=gvdwpp(k,j)+ghalf
3740 c          enddo
3741 c 9/28/08 AL Gradient compotents will be summed only at the end
3742           do k=1,3
3743             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
3744             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
3745           enddo
3746 *
3747 * Loop over residues i+1 thru j-1.
3748 *
3749 cgrad          do k=i+1,j-1
3750 cgrad            do l=1,3
3751 cgrad              gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
3752 cgrad            enddo
3753 cgrad          enddo
3754 #else
3755 C MARYSIA
3756           facvdw=(ev1+evdwij)*sss
3757           facel=(el1+eesij)
3758           fac1=fac
3759           fac=-3*rrmij*(facvdw+facvdw+facel)
3760           erij(1)=xj*rmij
3761           erij(2)=yj*rmij
3762           erij(3)=zj*rmij
3763 *
3764 * Radial derivatives. First process both termini of the fragment (i,j)
3765 *
3766           ggg(1)=fac*xj
3767           ggg(2)=fac*yj
3768           ggg(3)=fac*zj
3769 c          do k=1,3
3770 c            ghalf=0.5D0*ggg(k)
3771 c            gelc(k,i)=gelc(k,i)+ghalf
3772 c            gelc(k,j)=gelc(k,j)+ghalf
3773 c          enddo
3774 c 9/28/08 AL Gradient compotents will be summed only at the end
3775           do k=1,3
3776             gelc_long(k,j)=gelc(k,j)+ggg(k)
3777             gelc_long(k,i)=gelc(k,i)-ggg(k)
3778           enddo
3779 *
3780 * Loop over residues i+1 thru j-1.
3781 *
3782 cgrad          do k=i+1,j-1
3783 cgrad            do l=1,3
3784 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3785 cgrad            enddo
3786 cgrad          enddo
3787 c 9/28/08 AL Gradient compotents will be summed only at the end
3788           ggg(1)=facvdw*xj+sssgrad*rmij*evdwij*xj
3789           ggg(2)=facvdw*yj+sssgrad*rmij*evdwij*yj
3790           ggg(3)=facvdw*zj+sssgrad*rmij*evdwij*zj
3791           do k=1,3
3792             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
3793             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
3794           enddo
3795 #endif
3796 *
3797 * Angular part
3798 *
3799           ecosa=2.0D0*fac3*fac1+fac4
3800           fac4=-3.0D0*fac4
3801           fac3=-6.0D0*fac3
3802           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
3803           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
3804           do k=1,3
3805             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
3806             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
3807           enddo
3808 cd        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
3809 cd   &          (dcosg(k),k=1,3)
3810           do k=1,3
3811             ggg(k)=ecosb*dcosb(k)+ecosg*dcosg(k)
3812           enddo
3813 c          do k=1,3
3814 c            ghalf=0.5D0*ggg(k)
3815 c            gelc(k,i)=gelc(k,i)+ghalf
3816 c     &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
3817 c     &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3818 c            gelc(k,j)=gelc(k,j)+ghalf
3819 c     &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
3820 c     &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3821 c          enddo
3822 cgrad          do k=i+1,j-1
3823 cgrad            do l=1,3
3824 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3825 cgrad            enddo
3826 cgrad          enddo
3827           do k=1,3
3828             gelc(k,i)=gelc(k,i)
3829      &           +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
3830      &           + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3831             gelc(k,j)=gelc(k,j)
3832      &           +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
3833      &           + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3834             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
3835             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
3836           enddo
3837 C MARYSIA
3838 c          endif !sscale
3839           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
3840      &        .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0
3841      &        .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
3842 C
3843 C 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
3844 C   energy of a peptide unit is assumed in the form of a second-order
3845 C   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
3846 C   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
3847 C   are computed for EVERY pair of non-contiguous peptide groups.
3848 C
3849
3850           if (j.lt.nres-1) then
3851             j1=j+1
3852             j2=j-1
3853           else
3854             j1=j-1
3855             j2=j-2
3856           endif
3857           kkk=0
3858           lll=0
3859           do k=1,2
3860             do l=1,2
3861               kkk=kkk+1
3862               muij(kkk)=mu(k,i)*mu(l,j)
3863 c              write(iout,*) 'mumu=', mu(k,i),mu(l,j),i,j,k,l
3864 #ifdef NEWCORR
3865              gmuij1(kkk)=gtb1(k,i+1)*mu(l,j)
3866 c             write(iout,*) 'k=',k,i,gtb1(k,i+1),gtb1(k,i+1)*mu(l,j)
3867              gmuij2(kkk)=gUb2(k,i)*mu(l,j)
3868              gmuji1(kkk)=mu(k,i)*gtb1(l,j+1)
3869 c             write(iout,*) 'l=',l,j,gtb1(l,j+1),gtb1(l,j+1)*mu(k,i)
3870              gmuji2(kkk)=mu(k,i)*gUb2(l,j)
3871 #endif
3872             enddo
3873           enddo
3874 cd         write (iout,*) 'EELEC: i',i,' j',j
3875 cd          write (iout,*) 'j',j,' j1',j1,' j2',j2
3876 cd          write(iout,*) 'muij',muij
3877           ury=scalar(uy(1,i),erij)
3878           urz=scalar(uz(1,i),erij)
3879           vry=scalar(uy(1,j),erij)
3880           vrz=scalar(uz(1,j),erij)
3881           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
3882           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
3883           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
3884           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
3885           fac=dsqrt(-ael6i)*r3ij
3886           a22=a22*fac
3887           a23=a23*fac
3888           a32=a32*fac
3889           a33=a33*fac
3890 cd          write (iout,'(4i5,4f10.5)')
3891 cd     &     i,itortyp(itype(i)),j,itortyp(itype(j)),a22,a23,a32,a33
3892 cd          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
3893 cd          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') uy(:,i),uz(:,i),
3894 cd     &      uy(:,j),uz(:,j)
3895 cd          write (iout,'(4f10.5)')
3896 cd     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
3897 cd     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
3898 cd          write (iout,'(4f10.5)') ury,urz,vry,vrz
3899 cd           write (iout,'(9f10.5/)')
3900 cd     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
3901 C Derivatives of the elements of A in virtual-bond vectors
3902           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
3903           do k=1,3
3904             uryg(k,1)=scalar(erder(1,k),uy(1,i))
3905             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
3906             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
3907             urzg(k,1)=scalar(erder(1,k),uz(1,i))
3908             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
3909             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
3910             vryg(k,1)=scalar(erder(1,k),uy(1,j))
3911             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
3912             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
3913             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
3914             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
3915             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
3916           enddo
3917 C Compute radial contributions to the gradient
3918           facr=-3.0d0*rrmij
3919           a22der=a22*facr
3920           a23der=a23*facr
3921           a32der=a32*facr
3922           a33der=a33*facr
3923           agg(1,1)=a22der*xj
3924           agg(2,1)=a22der*yj
3925           agg(3,1)=a22der*zj
3926           agg(1,2)=a23der*xj
3927           agg(2,2)=a23der*yj
3928           agg(3,2)=a23der*zj
3929           agg(1,3)=a32der*xj
3930           agg(2,3)=a32der*yj
3931           agg(3,3)=a32der*zj
3932           agg(1,4)=a33der*xj
3933           agg(2,4)=a33der*yj
3934           agg(3,4)=a33der*zj
3935 C Add the contributions coming from er
3936           fac3=-3.0d0*fac
3937           do k=1,3
3938             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
3939             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
3940             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
3941             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
3942           enddo
3943           do k=1,3
3944 C Derivatives in DC(i)
3945 cgrad            ghalf1=0.5d0*agg(k,1)
3946 cgrad            ghalf2=0.5d0*agg(k,2)
3947 cgrad            ghalf3=0.5d0*agg(k,3)
3948 cgrad            ghalf4=0.5d0*agg(k,4)
3949             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j))
3950      &      -3.0d0*uryg(k,2)*vry)!+ghalf1
3951             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j))
3952      &      -3.0d0*uryg(k,2)*vrz)!+ghalf2
3953             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j))
3954      &      -3.0d0*urzg(k,2)*vry)!+ghalf3
3955             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j))
3956      &      -3.0d0*urzg(k,2)*vrz)!+ghalf4
3957 C Derivatives in DC(i+1)
3958             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j))
3959      &      -3.0d0*uryg(k,3)*vry)!+agg(k,1)
3960             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j))
3961      &      -3.0d0*uryg(k,3)*vrz)!+agg(k,2)
3962             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j))
3963      &      -3.0d0*urzg(k,3)*vry)!+agg(k,3)
3964             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j))
3965      &      -3.0d0*urzg(k,3)*vrz)!+agg(k,4)
3966 C Derivatives in DC(j)
3967             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i))
3968      &      -3.0d0*vryg(k,2)*ury)!+ghalf1
3969             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i))
3970      &      -3.0d0*vrzg(k,2)*ury)!+ghalf2
3971             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i))
3972      &      -3.0d0*vryg(k,2)*urz)!+ghalf3
3973             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i))
3974      &      -3.0d0*vrzg(k,2)*urz)!+ghalf4
3975 C Derivatives in DC(j+1) or DC(nres-1)
3976             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i))
3977      &      -3.0d0*vryg(k,3)*ury)
3978             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i))
3979      &      -3.0d0*vrzg(k,3)*ury)
3980             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i))
3981      &      -3.0d0*vryg(k,3)*urz)
3982             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i))
3983      &      -3.0d0*vrzg(k,3)*urz)
3984 cgrad            if (j.eq.nres-1 .and. i.lt.j-2) then
3985 cgrad              do l=1,4
3986 cgrad                aggj1(k,l)=aggj1(k,l)+agg(k,l)
3987 cgrad              enddo
3988 cgrad            endif
3989           enddo
3990           acipa(1,1)=a22
3991           acipa(1,2)=a23
3992           acipa(2,1)=a32
3993           acipa(2,2)=a33
3994           a22=-a22
3995           a23=-a23
3996           do l=1,2
3997             do k=1,3
3998               agg(k,l)=-agg(k,l)
3999               aggi(k,l)=-aggi(k,l)
4000               aggi1(k,l)=-aggi1(k,l)
4001               aggj(k,l)=-aggj(k,l)
4002               aggj1(k,l)=-aggj1(k,l)
4003             enddo
4004           enddo
4005           if (j.lt.nres-1) then
4006             a22=-a22
4007             a32=-a32
4008             do l=1,3,2
4009               do k=1,3
4010                 agg(k,l)=-agg(k,l)
4011                 aggi(k,l)=-aggi(k,l)
4012                 aggi1(k,l)=-aggi1(k,l)
4013                 aggj(k,l)=-aggj(k,l)
4014                 aggj1(k,l)=-aggj1(k,l)
4015               enddo
4016             enddo
4017           else
4018             a22=-a22
4019             a23=-a23
4020             a32=-a32
4021             a33=-a33
4022             do l=1,4
4023               do k=1,3
4024                 agg(k,l)=-agg(k,l)
4025                 aggi(k,l)=-aggi(k,l)
4026                 aggi1(k,l)=-aggi1(k,l)
4027                 aggj(k,l)=-aggj(k,l)
4028                 aggj1(k,l)=-aggj1(k,l)
4029               enddo
4030             enddo
4031           endif
4032           ENDIF ! WCORR
4033           IF (wel_loc.gt.0.0d0) THEN
4034 C Contribution to the local-electrostatic energy coming from the i-j pair
4035           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3)
4036      &     +a33*muij(4)
4037 c          write (iout,*) 'i',i,' j',j,itype(i),itype(j),
4038 c     &                     ' eel_loc_ij',eel_loc_ij
4039 c          write(iout,*) 'muije=',muij(1),muij(2),muij(3),muij(4)
4040 C Calculate patrial derivative for theta angle
4041 #ifdef NEWCORR
4042          geel_loc_ij=a22*gmuij1(1)
4043      &     +a23*gmuij1(2)
4044      &     +a32*gmuij1(3)
4045      &     +a33*gmuij1(4)
4046 c         write(iout,*) "derivative over thatai"
4047 c         write(iout,*) a22*gmuij1(1), a23*gmuij1(2) ,a32*gmuij1(3),
4048 c     &   a33*gmuij1(4)
4049          gloc(nphi+i,icg)=gloc(nphi+i,icg)+
4050      &      geel_loc_ij*wel_loc
4051 c         write(iout,*) "derivative over thatai-1"
4052 c         write(iout,*) a22*gmuij2(1), a23*gmuij2(2) ,a32*gmuij2(3),
4053 c     &   a33*gmuij2(4)
4054          geel_loc_ij=
4055      &     a22*gmuij2(1)
4056      &     +a23*gmuij2(2)
4057      &     +a32*gmuij2(3)
4058      &     +a33*gmuij2(4)
4059          gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
4060      &      geel_loc_ij*wel_loc
4061 c  Derivative over j residue
4062          geel_loc_ji=a22*gmuji1(1)
4063      &     +a23*gmuji1(2)
4064      &     +a32*gmuji1(3)
4065      &     +a33*gmuji1(4)
4066 c         write(iout,*) "derivative over thataj"
4067 c         write(iout,*) a22*gmuji1(1), a23*gmuji1(2) ,a32*gmuji1(3),
4068 c     &   a33*gmuji1(4)
4069
4070         gloc(nphi+j,icg)=gloc(nphi+j,icg)+
4071      &      geel_loc_ji*wel_loc
4072          geel_loc_ji=
4073      &     +a22*gmuji2(1)
4074      &     +a23*gmuji2(2)
4075      &     +a32*gmuji2(3)
4076      &     +a33*gmuji2(4)
4077 c         write(iout,*) "derivative over thataj-1"
4078 c         write(iout,*) a22*gmuji2(1), a23*gmuji2(2) ,a32*gmuji2(3),
4079 c     &   a33*gmuji2(4)
4080          gloc(nphi+j-1,icg)=gloc(nphi+j-1,icg)+
4081      &      geel_loc_ji*wel_loc
4082 #endif
4083 cd          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
4084
4085           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
4086      &            'eelloc',i,j,eel_loc_ij
4087 c           if (eel_loc_ij.ne.0)
4088 c     &      write (iout,'(a4,2i4,8f9.5)')'chuj',
4089 c     &     i,j,a22,muij(1),a23,muij(2),a32,muij(3),a33,muij(4)
4090
4091           eel_loc=eel_loc+eel_loc_ij
4092 C Partial derivatives in virtual-bond dihedral angles gamma
4093           if (i.gt.1)
4094      &    gel_loc_loc(i-1)=gel_loc_loc(i-1)+
4095      &            a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j)
4096      &           +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j)
4097           gel_loc_loc(j-1)=gel_loc_loc(j-1)+
4098      &            a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j)
4099      &           +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j)
4100 C Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
4101           do l=1,3
4102             ggg(l)=agg(l,1)*muij(1)+
4103      &          agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4)
4104             gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l)
4105             gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l)
4106 cgrad            ghalf=0.5d0*ggg(l)
4107 cgrad            gel_loc(l,i)=gel_loc(l,i)+ghalf
4108 cgrad            gel_loc(l,j)=gel_loc(l,j)+ghalf
4109           enddo
4110 cgrad          do k=i+1,j2
4111 cgrad            do l=1,3
4112 cgrad              gel_loc(l,k)=gel_loc(l,k)+ggg(l)
4113 cgrad            enddo
4114 cgrad          enddo
4115 C Remaining derivatives of eello
4116           do l=1,3
4117             gel_loc(l,i)=gel_loc(l,i)+(aggi(l,1)*muij(1)+
4118      &        aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4))
4119             gel_loc(l,i+1)=gel_loc(l,i+1)+(aggi1(l,1)*muij(1)+
4120      &     aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4))
4121             gel_loc(l,j)=gel_loc(l,j)+(aggj(l,1)*muij(1)+
4122      &       aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4))
4123             gel_loc(l,j1)=gel_loc(l,j1)+(aggj1(l,1)*muij(1)+
4124      &     aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4))
4125           enddo
4126           ENDIF
4127 C Change 12/26/95 to calculate four-body contributions to H-bonding energy
4128 c          if (j.gt.i+1 .and. num_conti.le.maxconts) then
4129           if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0
4130      &       .and. num_conti.le.maxconts) then
4131 c            write (iout,*) i,j," entered corr"
4132 C
4133 C Calculate the contact function. The ith column of the array JCONT will
4134 C contain the numbers of atoms that make contacts with the atom I (of numbers
4135 C greater than I). The arrays FACONT and GACONT will contain the values of
4136 C the contact function and its derivative.
4137 c           r0ij=1.02D0*rpp(iteli,itelj)
4138 c           r0ij=1.11D0*rpp(iteli,itelj)
4139             r0ij=2.20D0*rpp(iteli,itelj)
4140 c           r0ij=1.55D0*rpp(iteli,itelj)
4141             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
4142             if (fcont.gt.0.0D0) then
4143               num_conti=num_conti+1
4144               if (num_conti.gt.maxconts) then
4145                 write (iout,*) 'WARNING - max. # of contacts exceeded;',
4146      &                         ' will skip next contacts for this conf.'
4147               else
4148                 jcont_hb(num_conti,i)=j
4149 cd                write (iout,*) "i",i," j",j," num_conti",num_conti,
4150 cd     &           " jcont_hb",jcont_hb(num_conti,i)
4151                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.
4152      &          wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
4153 C 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
4154 C  terms.
4155                 d_cont(num_conti,i)=rij
4156 cd                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
4157 C     --- Electrostatic-interaction matrix ---
4158                 a_chuj(1,1,num_conti,i)=a22
4159                 a_chuj(1,2,num_conti,i)=a23
4160                 a_chuj(2,1,num_conti,i)=a32
4161                 a_chuj(2,2,num_conti,i)=a33
4162 C     --- Gradient of rij
4163                 do kkk=1,3
4164                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
4165                 enddo
4166                 kkll=0
4167                 do k=1,2
4168                   do l=1,2
4169                     kkll=kkll+1
4170                     do m=1,3
4171                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
4172                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
4173                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
4174                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
4175                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
4176                     enddo
4177                   enddo
4178                 enddo
4179                 ENDIF
4180                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
4181 C Calculate contact energies
4182                 cosa4=4.0D0*cosa
4183                 wij=cosa-3.0D0*cosb*cosg
4184                 cosbg1=cosb+cosg
4185                 cosbg2=cosb-cosg
4186 c               fac3=dsqrt(-ael6i)/r0ij**3
4187                 fac3=dsqrt(-ael6i)*r3ij
4188 c                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
4189                 ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
4190                 if (ees0tmp.gt.0) then
4191                   ees0pij=dsqrt(ees0tmp)
4192                 else
4193                   ees0pij=0
4194                 endif
4195 c                ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
4196                 ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
4197                 if (ees0tmp.gt.0) then
4198                   ees0mij=dsqrt(ees0tmp)
4199                 else
4200                   ees0mij=0
4201                 endif
4202 c               ees0mij=0.0D0
4203                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij)
4204                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij)
4205 C Diagnostics. Comment out or remove after debugging!
4206 c               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
4207 c               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
4208 c               ees0m(num_conti,i)=0.0D0
4209 C End diagnostics.
4210 c               write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
4211 c    & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
4212 C Angular derivatives of the contact function
4213                 ees0pij1=fac3/ees0pij
4214                 ees0mij1=fac3/ees0mij
4215                 fac3p=-3.0D0*fac3*rrmij
4216                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
4217                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
4218 c               ees0mij1=0.0D0
4219                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
4220                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
4221                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
4222                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
4223                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
4224                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
4225                 ecosap=ecosa1+ecosa2
4226                 ecosbp=ecosb1+ecosb2
4227                 ecosgp=ecosg1+ecosg2
4228                 ecosam=ecosa1-ecosa2
4229                 ecosbm=ecosb1-ecosb2
4230                 ecosgm=ecosg1-ecosg2
4231 C Diagnostics
4232 c               ecosap=ecosa1
4233 c               ecosbp=ecosb1
4234 c               ecosgp=ecosg1
4235 c               ecosam=0.0D0
4236 c               ecosbm=0.0D0
4237 c               ecosgm=0.0D0
4238 C End diagnostics
4239                 facont_hb(num_conti,i)=fcont
4240                 fprimcont=fprimcont/rij
4241 cd              facont_hb(num_conti,i)=1.0D0
4242 C Following line is for diagnostics.
4243 cd              fprimcont=0.0D0
4244                 do k=1,3
4245                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
4246                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
4247                 enddo
4248                 do k=1,3
4249                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
4250                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
4251                 enddo
4252                 gggp(1)=gggp(1)+ees0pijp*xj
4253                 gggp(2)=gggp(2)+ees0pijp*yj
4254                 gggp(3)=gggp(3)+ees0pijp*zj
4255                 gggm(1)=gggm(1)+ees0mijp*xj
4256                 gggm(2)=gggm(2)+ees0mijp*yj
4257                 gggm(3)=gggm(3)+ees0mijp*zj
4258 C Derivatives due to the contact function
4259                 gacont_hbr(1,num_conti,i)=fprimcont*xj
4260                 gacont_hbr(2,num_conti,i)=fprimcont*yj
4261                 gacont_hbr(3,num_conti,i)=fprimcont*zj
4262                 do k=1,3
4263 c
4264 c 10/24/08 cgrad and ! comments indicate the parts of the code removed
4265 c          following the change of gradient-summation algorithm.
4266 c
4267 cgrad                  ghalfp=0.5D0*gggp(k)
4268 cgrad                  ghalfm=0.5D0*gggm(k)
4269                   gacontp_hb1(k,num_conti,i)=!ghalfp
4270      &              +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i))
4271      &              + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
4272                   gacontp_hb2(k,num_conti,i)=!ghalfp
4273      &              +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j))
4274      &              + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
4275                   gacontp_hb3(k,num_conti,i)=gggp(k)
4276                   gacontm_hb1(k,num_conti,i)=!ghalfm
4277      &              +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i))
4278      &              + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
4279                   gacontm_hb2(k,num_conti,i)=!ghalfm
4280      &              +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j))
4281      &              + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
4282                   gacontm_hb3(k,num_conti,i)=gggm(k)
4283                 enddo
4284 C Diagnostics. Comment out or remove after debugging!
4285 cdiag           do k=1,3
4286 cdiag             gacontp_hb1(k,num_conti,i)=0.0D0
4287 cdiag             gacontp_hb2(k,num_conti,i)=0.0D0
4288 cdiag             gacontp_hb3(k,num_conti,i)=0.0D0
4289 cdiag             gacontm_hb1(k,num_conti,i)=0.0D0
4290 cdiag             gacontm_hb2(k,num_conti,i)=0.0D0
4291 cdiag             gacontm_hb3(k,num_conti,i)=0.0D0
4292 cdiag           enddo
4293               ENDIF ! wcorr
4294               endif  ! num_conti.le.maxconts
4295             endif  ! fcont.gt.0
4296           endif    ! j.gt.i+1
4297           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
4298             do k=1,4
4299               do l=1,3
4300                 ghalf=0.5d0*agg(l,k)
4301                 aggi(l,k)=aggi(l,k)+ghalf
4302                 aggi1(l,k)=aggi1(l,k)+agg(l,k)
4303                 aggj(l,k)=aggj(l,k)+ghalf
4304               enddo
4305             enddo
4306             if (j.eq.nres-1 .and. i.lt.j-2) then
4307               do k=1,4
4308                 do l=1,3
4309                   aggj1(l,k)=aggj1(l,k)+agg(l,k)
4310                 enddo
4311               enddo
4312             endif
4313           endif
4314 c          t_eelecij=t_eelecij+MPI_Wtime()-time00
4315       return
4316       end
4317 C-----------------------------------------------------------------------------
4318       subroutine eturn3(i,eello_turn3)
4319 C Third- and fourth-order contributions from turns
4320       implicit real*8 (a-h,o-z)
4321       include 'DIMENSIONS'
4322       include 'COMMON.IOUNITS'
4323       include 'COMMON.GEO'
4324       include 'COMMON.VAR'
4325       include 'COMMON.LOCAL'
4326       include 'COMMON.CHAIN'
4327       include 'COMMON.DERIV'
4328       include 'COMMON.INTERACT'
4329       include 'COMMON.CONTACTS'
4330       include 'COMMON.TORSION'
4331       include 'COMMON.VECTORS'
4332       include 'COMMON.FFIELD'
4333       include 'COMMON.CONTROL'
4334       dimension ggg(3)
4335       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
4336      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
4337      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2),gpizda1(2,2),
4338      &  gpizda2(2,2),auxgmat1(2,2),auxgmatt1(2,2),
4339      &  auxgmat2(2,2),auxgmatt2(2,2)
4340       double precision agg(3,4),aggi(3,4),aggi1(3,4),
4341      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
4342       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
4343      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
4344      &    num_conti,j1,j2
4345       j=i+2
4346 c      write (iout,*) "eturn3",i,j,j1,j2
4347       a_temp(1,1)=a22
4348       a_temp(1,2)=a23
4349       a_temp(2,1)=a32
4350       a_temp(2,2)=a33
4351 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4352 C
4353 C               Third-order contributions
4354 C
4355 C                 (i+2)o----(i+3)
4356 C                      | |
4357 C                      | |
4358 C                 (i+1)o----i
4359 C
4360 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4361 cd        call checkint_turn3(i,a_temp,eello_turn3_num)
4362         call matmat2(EUg(1,1,i+1),EUg(1,1,i+2),auxmat(1,1))
4363 c auxalary matices for theta gradient
4364 c auxalary matrix for i+1 and constant i+2
4365         call matmat2(gtEUg(1,1,i+1),EUg(1,1,i+2),auxgmat1(1,1))
4366 c auxalary matrix for i+2 and constant i+1
4367         call matmat2(EUg(1,1,i+1),gtEUg(1,1,i+2),auxgmat2(1,1))
4368         call transpose2(auxmat(1,1),auxmat1(1,1))
4369         call transpose2(auxgmat1(1,1),auxgmatt1(1,1))
4370         call transpose2(auxgmat2(1,1),auxgmatt2(1,1))
4371         call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4372         call matmat2(a_temp(1,1),auxgmatt1(1,1),gpizda1(1,1))
4373         call matmat2(a_temp(1,1),auxgmatt2(1,1),gpizda2(1,1))
4374         eello_turn3=eello_turn3+0.5d0*(pizda(1,1)+pizda(2,2))
4375 C Derivatives in theta
4376         gloc(nphi+i,icg)=gloc(nphi+i,icg)
4377      &  +0.5d0*(gpizda1(1,1)+gpizda1(2,2))*wturn3
4378         gloc(nphi+i+1,icg)=gloc(nphi+i+1,icg)
4379      &  +0.5d0*(gpizda2(1,1)+gpizda2(2,2))*wturn3
4380
4381         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
4382      &          'eturn3',i,j,0.5d0*(pizda(1,1)+pizda(2,2))
4383 cd        write (2,*) 'i,',i,' j',j,'eello_turn3',
4384 cd     &    0.5d0*(pizda(1,1)+pizda(2,2)),
4385 cd     &    ' eello_turn3_num',4*eello_turn3_num
4386 C Derivatives in gamma(i)
4387         call matmat2(EUgder(1,1,i+1),EUg(1,1,i+2),auxmat2(1,1))
4388         call transpose2(auxmat2(1,1),auxmat3(1,1))
4389         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
4390         gel_loc_turn3(i)=gel_loc_turn3(i)+0.5d0*(pizda(1,1)+pizda(2,2))
4391 C Derivatives in gamma(i+1)
4392         call matmat2(EUg(1,1,i+1),EUgder(1,1,i+2),auxmat2(1,1))
4393         call transpose2(auxmat2(1,1),auxmat3(1,1))
4394         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
4395         gel_loc_turn3(i+1)=gel_loc_turn3(i+1)
4396      &    +0.5d0*(pizda(1,1)+pizda(2,2))
4397 C Cartesian derivatives
4398         do l=1,3
4399 c            ghalf1=0.5d0*agg(l,1)
4400 c            ghalf2=0.5d0*agg(l,2)
4401 c            ghalf3=0.5d0*agg(l,3)
4402 c            ghalf4=0.5d0*agg(l,4)
4403           a_temp(1,1)=aggi(l,1)!+ghalf1
4404           a_temp(1,2)=aggi(l,2)!+ghalf2
4405           a_temp(2,1)=aggi(l,3)!+ghalf3
4406           a_temp(2,2)=aggi(l,4)!+ghalf4
4407           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4408           gcorr3_turn(l,i)=gcorr3_turn(l,i)
4409      &      +0.5d0*(pizda(1,1)+pizda(2,2))
4410           a_temp(1,1)=aggi1(l,1)!+agg(l,1)
4411           a_temp(1,2)=aggi1(l,2)!+agg(l,2)
4412           a_temp(2,1)=aggi1(l,3)!+agg(l,3)
4413           a_temp(2,2)=aggi1(l,4)!+agg(l,4)
4414           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4415           gcorr3_turn(l,i+1)=gcorr3_turn(l,i+1)
4416      &      +0.5d0*(pizda(1,1)+pizda(2,2))
4417           a_temp(1,1)=aggj(l,1)!+ghalf1
4418           a_temp(1,2)=aggj(l,2)!+ghalf2
4419           a_temp(2,1)=aggj(l,3)!+ghalf3
4420           a_temp(2,2)=aggj(l,4)!+ghalf4
4421           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4422           gcorr3_turn(l,j)=gcorr3_turn(l,j)
4423      &      +0.5d0*(pizda(1,1)+pizda(2,2))
4424           a_temp(1,1)=aggj1(l,1)
4425           a_temp(1,2)=aggj1(l,2)
4426           a_temp(2,1)=aggj1(l,3)
4427           a_temp(2,2)=aggj1(l,4)
4428           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4429           gcorr3_turn(l,j1)=gcorr3_turn(l,j1)
4430      &      +0.5d0*(pizda(1,1)+pizda(2,2))
4431         enddo
4432       return
4433       end
4434 C-------------------------------------------------------------------------------
4435       subroutine eturn4(i,eello_turn4)
4436 C Third- and fourth-order contributions from turns
4437       implicit real*8 (a-h,o-z)
4438       include 'DIMENSIONS'
4439       include 'COMMON.IOUNITS'
4440       include 'COMMON.GEO'
4441       include 'COMMON.VAR'
4442       include 'COMMON.LOCAL'
4443       include 'COMMON.CHAIN'
4444       include 'COMMON.DERIV'
4445       include 'COMMON.INTERACT'
4446       include 'COMMON.CONTACTS'
4447       include 'COMMON.TORSION'
4448       include 'COMMON.VECTORS'
4449       include 'COMMON.FFIELD'
4450       include 'COMMON.CONTROL'
4451       dimension ggg(3)
4452       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
4453      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
4454      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2),auxgvec(2),
4455      &  auxgEvec1(2),auxgEvec2(2),auxgEvec3(2),
4456      &  gte1t(2,2),gte2t(2,2),gte3t(2,2),
4457      &  gte1a(2,2),gtae3(2,2),gtae3e2(2,2), ae3gte2(2,2),
4458      &  gtEpizda1(2,2),gtEpizda2(2,2),gtEpizda3(2,2)
4459       double precision agg(3,4),aggi(3,4),aggi1(3,4),
4460      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
4461       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
4462      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
4463      &    num_conti,j1,j2
4464       j=i+3
4465 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4466 C
4467 C               Fourth-order contributions
4468 C
4469 C                 (i+3)o----(i+4)
4470 C                     /  |
4471 C               (i+2)o   |
4472 C                     \  |
4473 C                 (i+1)o----i
4474 C
4475 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4476 cd        call checkint_turn4(i,a_temp,eello_turn4_num)
4477 c        write (iout,*) "eturn4 i",i," j",j," j1",j1," j2",j2
4478 c        write(iout,*)"WCHODZE W PROGRAM"
4479         a_temp(1,1)=a22
4480         a_temp(1,2)=a23
4481         a_temp(2,1)=a32
4482         a_temp(2,2)=a33
4483         iti1=itortyp(itype(i+1))
4484         iti2=itortyp(itype(i+2))
4485         iti3=itortyp(itype(i+3))
4486 c        write(iout,*) "iti1",iti1," iti2",iti2," iti3",iti3
4487         call transpose2(EUg(1,1,i+1),e1t(1,1))
4488         call transpose2(Eug(1,1,i+2),e2t(1,1))
4489         call transpose2(Eug(1,1,i+3),e3t(1,1))
4490 C Ematrix derivative in theta
4491         call transpose2(gtEUg(1,1,i+1),gte1t(1,1))
4492         call transpose2(gtEug(1,1,i+2),gte2t(1,1))
4493         call transpose2(gtEug(1,1,i+3),gte3t(1,1))
4494         call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4495 c       eta1 in derivative theta
4496         call matmat2(gte1t(1,1),a_temp(1,1),gte1a(1,1))
4497         call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4498 c       auxgvec is derivative of Ub2 so i+3 theta
4499         call matvec2(e1a(1,1),gUb2(1,i+3),auxgvec(1))
4500 c       auxalary matrix of E i+1
4501         call matvec2(gte1a(1,1),Ub2(1,i+3),auxgEvec1(1))
4502 c        s1=0.0
4503 c        gs1=0.0
4504         s1=scalar2(b1(1,i+2),auxvec(1))
4505 c derivative of theta i+2 with constant i+3
4506         gs23=scalar2(gtb1(1,i+2),auxvec(1))
4507 c derivative of theta i+2 with constant i+2
4508         gs32=scalar2(b1(1,i+2),auxgvec(1))
4509 c derivative of E matix in theta of i+1
4510         gsE13=scalar2(b1(1,i+2),auxgEvec1(1))
4511
4512         call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4513 c       ea31 in derivative theta
4514         call matmat2(a_temp(1,1),gte3t(1,1),gtae3(1,1))
4515         call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4516 c auxilary matrix auxgvec of Ub2 with constant E matirx
4517         call matvec2(ae3(1,1),gUb2(1,i+2),auxgvec(1))
4518 c auxilary matrix auxgEvec1 of E matix with Ub2 constant
4519         call matvec2(gtae3(1,1),Ub2(1,i+2),auxgEvec3(1))
4520
4521 c        s2=0.0
4522 c        gs2=0.0
4523         s2=scalar2(b1(1,i+1),auxvec(1))
4524 c derivative of theta i+1 with constant i+3
4525         gs13=scalar2(gtb1(1,i+1),auxvec(1))
4526 c derivative of theta i+2 with constant i+1
4527         gs21=scalar2(b1(1,i+1),auxgvec(1))
4528 c derivative of theta i+3 with constant i+1
4529         gsE31=scalar2(b1(1,i+1),auxgEvec3(1))
4530 c        write(iout,*) gs1,gs2,'i=',i,auxgvec(1),gUb2(1,i+2),gtb1(1,i+2),
4531 c     &  gtb1(1,i+1)
4532         call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4533 c two derivatives over diffetent matrices
4534 c gtae3e2 is derivative over i+3
4535         call matmat2(gtae3(1,1),e2t(1,1),gtae3e2(1,1))
4536 c ae3gte2 is derivative over i+2
4537         call matmat2(ae3(1,1),gte2t(1,1),ae3gte2(1,1))
4538         call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4539 c three possible derivative over theta E matices
4540 c i+1
4541         call matmat2(ae3e2(1,1),gte1t(1,1),gtEpizda1(1,1))
4542 c i+2
4543         call matmat2(ae3gte2(1,1),e1t(1,1),gtEpizda2(1,1))
4544 c i+3
4545         call matmat2(gtae3e2(1,1),e1t(1,1),gtEpizda3(1,1))
4546         s3=0.5d0*(pizda(1,1)+pizda(2,2))
4547
4548         gsEE1=0.5d0*(gtEpizda1(1,1)+gtEpizda1(2,2))
4549         gsEE2=0.5d0*(gtEpizda2(1,1)+gtEpizda2(2,2))
4550         gsEE3=0.5d0*(gtEpizda3(1,1)+gtEpizda3(2,2))
4551
4552         eello_turn4=eello_turn4-(s1+s2+s3)
4553 c             write(iout,*)'chujOWO', auxvec(1),b1(1,iti2)
4554         if (energy_dec) write (iout,'(a6,2i5,0pf7.3,3f7.3)')
4555      &      'eturn4',i,j,-(s1+s2+s3),s1,s2,s3
4556 cd        write (2,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
4557 cd     &    ' eello_turn4_num',8*eello_turn4_num
4558 #ifdef NEWCORR
4559         gloc(nphi+i,icg)=gloc(nphi+i,icg)
4560      &                  -(gs13+gsE13+gsEE1)*wturn4
4561         gloc(nphi+i+1,icg)= gloc(nphi+i+1,icg)
4562      &                    -(gs23+gs21+gsEE2)*wturn4
4563         gloc(nphi+i+2,icg)= gloc(nphi+i+2,icg)
4564      &                    -(gs32+gsE31+gsEE3)*wturn4
4565 c         gloc(nphi+i+1,icg)=gloc(nphi+i+1,icg)-
4566 c     &   gs2
4567 #endif
4568         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
4569      &      'eturn4',i,j,-(s1+s2+s3)
4570 c        write (iout,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
4571 c     &    ' eello_turn4_num',8*eello_turn4_num
4572 C Derivatives in gamma(i)
4573         call transpose2(EUgder(1,1,i+1),e1tder(1,1))
4574         call matmat2(e1tder(1,1),a_temp(1,1),auxmat(1,1))
4575         call matvec2(auxmat(1,1),Ub2(1,i+3),auxvec(1))
4576         s1=scalar2(b1(1,i+2),auxvec(1))
4577         call matmat2(ae3e2(1,1),e1tder(1,1),pizda(1,1))
4578         s3=0.5d0*(pizda(1,1)+pizda(2,2))
4579         gel_loc_turn4(i)=gel_loc_turn4(i)-(s1+s3)
4580 C Derivatives in gamma(i+1)
4581         call transpose2(EUgder(1,1,i+2),e2tder(1,1))
4582         call matvec2(ae3(1,1),Ub2der(1,i+2),auxvec(1))
4583         s2=scalar2(b1(1,i+1),auxvec(1))
4584         call matmat2(ae3(1,1),e2tder(1,1),auxmat(1,1))
4585         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
4586         s3=0.5d0*(pizda(1,1)+pizda(2,2))
4587         gel_loc_turn4(i+1)=gel_loc_turn4(i+1)-(s2+s3)
4588 C Derivatives in gamma(i+2)
4589         call transpose2(EUgder(1,1,i+3),e3tder(1,1))
4590         call matvec2(e1a(1,1),Ub2der(1,i+3),auxvec(1))
4591         s1=scalar2(b1(1,i+2),auxvec(1))
4592         call matmat2(a_temp(1,1),e3tder(1,1),auxmat(1,1))
4593         call matvec2(auxmat(1,1),Ub2(1,i+2),auxvec(1))
4594         s2=scalar2(b1(1,i+1),auxvec(1))
4595         call matmat2(auxmat(1,1),e2t(1,1),auxmat3(1,1))
4596         call matmat2(auxmat3(1,1),e1t(1,1),pizda(1,1))
4597         s3=0.5d0*(pizda(1,1)+pizda(2,2))
4598         gel_loc_turn4(i+2)=gel_loc_turn4(i+2)-(s1+s2+s3)
4599 C Cartesian derivatives
4600 C Derivatives of this turn contributions in DC(i+2)
4601         if (j.lt.nres-1) then
4602           do l=1,3
4603             a_temp(1,1)=agg(l,1)
4604             a_temp(1,2)=agg(l,2)
4605             a_temp(2,1)=agg(l,3)
4606             a_temp(2,2)=agg(l,4)
4607             call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4608             call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4609             s1=scalar2(b1(1,i+2),auxvec(1))
4610             call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4611             call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4612             s2=scalar2(b1(1,i+1),auxvec(1))
4613             call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4614             call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4615             s3=0.5d0*(pizda(1,1)+pizda(2,2))
4616             ggg(l)=-(s1+s2+s3)
4617             gcorr4_turn(l,i+2)=gcorr4_turn(l,i+2)-(s1+s2+s3)
4618           enddo
4619         endif
4620 C Remaining derivatives of this turn contribution
4621         do l=1,3
4622           a_temp(1,1)=aggi(l,1)
4623           a_temp(1,2)=aggi(l,2)
4624           a_temp(2,1)=aggi(l,3)
4625           a_temp(2,2)=aggi(l,4)
4626           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4627           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4628           s1=scalar2(b1(1,i+2),auxvec(1))
4629           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4630           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4631           s2=scalar2(b1(1,i+1),auxvec(1))
4632           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4633           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4634           s3=0.5d0*(pizda(1,1)+pizda(2,2))
4635           gcorr4_turn(l,i)=gcorr4_turn(l,i)-(s1+s2+s3)
4636           a_temp(1,1)=aggi1(l,1)
4637           a_temp(1,2)=aggi1(l,2)
4638           a_temp(2,1)=aggi1(l,3)
4639           a_temp(2,2)=aggi1(l,4)
4640           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4641           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4642           s1=scalar2(b1(1,i+2),auxvec(1))
4643           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4644           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4645           s2=scalar2(b1(1,i+1),auxvec(1))
4646           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4647           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4648           s3=0.5d0*(pizda(1,1)+pizda(2,2))
4649           gcorr4_turn(l,i+1)=gcorr4_turn(l,i+1)-(s1+s2+s3)
4650           a_temp(1,1)=aggj(l,1)
4651           a_temp(1,2)=aggj(l,2)
4652           a_temp(2,1)=aggj(l,3)
4653           a_temp(2,2)=aggj(l,4)
4654           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4655           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4656           s1=scalar2(b1(1,i+2),auxvec(1))
4657           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4658           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4659           s2=scalar2(b1(1,i+1),auxvec(1))
4660           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4661           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4662           s3=0.5d0*(pizda(1,1)+pizda(2,2))
4663           gcorr4_turn(l,j)=gcorr4_turn(l,j)-(s1+s2+s3)
4664           a_temp(1,1)=aggj1(l,1)
4665           a_temp(1,2)=aggj1(l,2)
4666           a_temp(2,1)=aggj1(l,3)
4667           a_temp(2,2)=aggj1(l,4)
4668           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4669           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4670           s1=scalar2(b1(1,i+2),auxvec(1))
4671           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4672           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4673           s2=scalar2(b1(1,i+1),auxvec(1))
4674           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4675           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4676           s3=0.5d0*(pizda(1,1)+pizda(2,2))
4677 c          write (iout,*) "s1",s1," s2",s2," s3",s3," s1+s2+s3",s1+s2+s3
4678           gcorr4_turn(l,j1)=gcorr4_turn(l,j1)-(s1+s2+s3)
4679         enddo
4680       return
4681       end
4682 C-----------------------------------------------------------------------------
4683       subroutine vecpr(u,v,w)
4684       implicit real*8(a-h,o-z)
4685       dimension u(3),v(3),w(3)
4686       w(1)=u(2)*v(3)-u(3)*v(2)
4687       w(2)=-u(1)*v(3)+u(3)*v(1)
4688       w(3)=u(1)*v(2)-u(2)*v(1)
4689       return
4690       end
4691 C-----------------------------------------------------------------------------
4692       subroutine unormderiv(u,ugrad,unorm,ungrad)
4693 C This subroutine computes the derivatives of a normalized vector u, given
4694 C the derivatives computed without normalization conditions, ugrad. Returns
4695 C ungrad.
4696       implicit none
4697       double precision u(3),ugrad(3,3),unorm,ungrad(3,3)
4698       double precision vec(3)
4699       double precision scalar
4700       integer i,j
4701 c      write (2,*) 'ugrad',ugrad
4702 c      write (2,*) 'u',u
4703       do i=1,3
4704         vec(i)=scalar(ugrad(1,i),u(1))
4705       enddo
4706 c      write (2,*) 'vec',vec
4707       do i=1,3
4708         do j=1,3
4709           ungrad(j,i)=(ugrad(j,i)-u(j)*vec(i))*unorm
4710         enddo
4711       enddo
4712 c      write (2,*) 'ungrad',ungrad
4713       return
4714       end
4715 C-----------------------------------------------------------------------------
4716       subroutine escp_soft_sphere(evdw2,evdw2_14)
4717 C
4718 C This subroutine calculates the excluded-volume interaction energy between
4719 C peptide-group centers and side chains and its gradient in virtual-bond and
4720 C side-chain vectors.
4721 C
4722       implicit real*8 (a-h,o-z)
4723       include 'DIMENSIONS'
4724       include 'COMMON.GEO'
4725       include 'COMMON.VAR'
4726       include 'COMMON.LOCAL'
4727       include 'COMMON.CHAIN'
4728       include 'COMMON.DERIV'
4729       include 'COMMON.INTERACT'
4730       include 'COMMON.FFIELD'
4731       include 'COMMON.IOUNITS'
4732       include 'COMMON.CONTROL'
4733       dimension ggg(3)
4734       evdw2=0.0D0
4735       evdw2_14=0.0d0
4736       r0_scp=4.5d0
4737 cd    print '(a)','Enter ESCP'
4738 cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
4739 C      do xshift=-1,1
4740 C      do yshift=-1,1
4741 C      do zshift=-1,1
4742       do i=iatscp_s,iatscp_e
4743         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
4744         iteli=itel(i)
4745         xi=0.5D0*(c(1,i)+c(1,i+1))
4746         yi=0.5D0*(c(2,i)+c(2,i+1))
4747         zi=0.5D0*(c(3,i)+c(3,i+1))
4748 C Return atom into box, boxxsize is size of box in x dimension
4749 c  134   continue
4750 c        if (xi.gt.((xshift+0.5d0)*boxxsize)) xi=xi-boxxsize
4751 c        if (xi.lt.((xshift-0.5d0)*boxxsize)) xi=xi+boxxsize
4752 C Condition for being inside the proper box
4753 c        if ((xi.gt.((xshift+0.5d0)*boxxsize)).or.
4754 c     &       (xi.lt.((xshift-0.5d0)*boxxsize))) then
4755 c        go to 134
4756 c        endif
4757 c  135   continue
4758 c        if (yi.gt.((yshift+0.5d0)*boxysize)) yi=yi-boxysize
4759 c        if (yi.lt.((yshift-0.5d0)*boxysize)) yi=yi+boxysize
4760 C Condition for being inside the proper box
4761 c        if ((yi.gt.((yshift+0.5d0)*boxysize)).or.
4762 c     &       (yi.lt.((yshift-0.5d0)*boxysize))) then
4763 c        go to 135
4764 c c       endif
4765 c  136   continue
4766 c        if (zi.gt.((zshift+0.5d0)*boxzsize)) zi=zi-boxzsize
4767 c        if (zi.lt.((zshift-0.5d0)*boxzsize)) zi=zi+boxzsize
4768 cC Condition for being inside the proper box
4769 c        if ((zi.gt.((zshift+0.5d0)*boxzsize)).or.
4770 c     &       (zi.lt.((zshift-0.5d0)*boxzsize))) then
4771 c        go to 136
4772 c        endif
4773           xi=mod(xi,boxxsize)
4774           if (xi.lt.0) xi=xi+boxxsize
4775           yi=mod(yi,boxysize)
4776           if (yi.lt.0) yi=yi+boxysize
4777           zi=mod(zi,boxzsize)
4778           if (zi.lt.0) zi=zi+boxzsize
4779 C          xi=xi+xshift*boxxsize
4780 C          yi=yi+yshift*boxysize
4781 C          zi=zi+zshift*boxzsize
4782         do iint=1,nscp_gr(i)
4783
4784         do j=iscpstart(i,iint),iscpend(i,iint)
4785           if (itype(j).eq.ntyp1) cycle
4786           itypj=iabs(itype(j))
4787 C Uncomment following three lines for SC-p interactions
4788 c         xj=c(1,nres+j)-xi
4789 c         yj=c(2,nres+j)-yi
4790 c         zj=c(3,nres+j)-zi
4791 C Uncomment following three lines for Ca-p interactions
4792           xj=c(1,j)
4793           yj=c(2,j)
4794           zj=c(3,j)
4795 c  174   continue
4796 c        if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
4797 c        if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
4798 C Condition for being inside the proper box
4799 c        if ((xj.gt.((0.5d0)*boxxsize)).or.
4800 c     &       (xj.lt.((-0.5d0)*boxxsize))) then
4801 c        go to 174
4802 c        endif
4803 c  175   continue
4804 c        if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
4805 c        if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
4806 cC Condition for being inside the proper box
4807 c        if ((yj.gt.((0.5d0)*boxysize)).or.
4808 c     &       (yj.lt.((-0.5d0)*boxysize))) then
4809 c        go to 175
4810 c        endif
4811 c  176   continue
4812 c        if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
4813 c        if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
4814 C Condition for being inside the proper box
4815 c        if ((zj.gt.((0.5d0)*boxzsize)).or.
4816 c     &       (zj.lt.((-0.5d0)*boxzsize))) then
4817 c        go to 176
4818           xj=mod(xj,boxxsize)
4819           if (xj.lt.0) xj=xj+boxxsize
4820           yj=mod(yj,boxysize)
4821           if (yj.lt.0) yj=yj+boxysize
4822           zj=mod(zj,boxzsize)
4823           if (zj.lt.0) zj=zj+boxzsize
4824       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
4825       xj_safe=xj
4826       yj_safe=yj
4827       zj_safe=zj
4828       subchap=0
4829       do xshift=-1,1
4830       do yshift=-1,1
4831       do zshift=-1,1
4832           xj=xj_safe+xshift*boxxsize
4833           yj=yj_safe+yshift*boxysize
4834           zj=zj_safe+zshift*boxzsize
4835           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
4836           if(dist_temp.lt.dist_init) then
4837             dist_init=dist_temp
4838             xj_temp=xj
4839             yj_temp=yj
4840             zj_temp=zj
4841             subchap=1
4842           endif
4843        enddo
4844        enddo
4845        enddo
4846        if (subchap.eq.1) then
4847           xj=xj_temp-xi
4848           yj=yj_temp-yi
4849           zj=zj_temp-zi
4850        else
4851           xj=xj_safe-xi
4852           yj=yj_safe-yi
4853           zj=zj_safe-zi
4854        endif
4855 c c       endif
4856 C          xj=xj-xi
4857 C          yj=yj-yi
4858 C          zj=zj-zi
4859           rij=xj*xj+yj*yj+zj*zj
4860
4861           r0ij=r0_scp
4862           r0ijsq=r0ij*r0ij
4863           if (rij.lt.r0ijsq) then
4864             evdwij=0.25d0*(rij-r0ijsq)**2
4865             fac=rij-r0ijsq
4866           else
4867             evdwij=0.0d0
4868             fac=0.0d0
4869           endif
4870           evdw2=evdw2+evdwij
4871 C
4872 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
4873 C
4874           ggg(1)=xj*fac
4875           ggg(2)=yj*fac
4876           ggg(3)=zj*fac
4877 cgrad          if (j.lt.i) then
4878 cd          write (iout,*) 'j<i'
4879 C Uncomment following three lines for SC-p interactions
4880 c           do k=1,3
4881 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
4882 c           enddo
4883 cgrad          else
4884 cd          write (iout,*) 'j>i'
4885 cgrad            do k=1,3
4886 cgrad              ggg(k)=-ggg(k)
4887 C Uncomment following line for SC-p interactions
4888 c             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
4889 cgrad            enddo
4890 cgrad          endif
4891 cgrad          do k=1,3
4892 cgrad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
4893 cgrad          enddo
4894 cgrad          kstart=min0(i+1,j)
4895 cgrad          kend=max0(i-1,j-1)
4896 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
4897 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
4898 cgrad          do k=kstart,kend
4899 cgrad            do l=1,3
4900 cgrad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
4901 cgrad            enddo
4902 cgrad          enddo
4903           do k=1,3
4904             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
4905             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
4906           enddo
4907         enddo
4908
4909         enddo ! iint
4910       enddo ! i
4911 C      enddo !zshift
4912 C      enddo !yshift
4913 C      enddo !xshift
4914       return
4915       end
4916 C-----------------------------------------------------------------------------
4917       subroutine escp(evdw2,evdw2_14)
4918 C
4919 C This subroutine calculates the excluded-volume interaction energy between
4920 C peptide-group centers and side chains and its gradient in virtual-bond and
4921 C side-chain vectors.
4922 C
4923       implicit real*8 (a-h,o-z)
4924       include 'DIMENSIONS'
4925       include 'COMMON.GEO'
4926       include 'COMMON.VAR'
4927       include 'COMMON.LOCAL'
4928       include 'COMMON.CHAIN'
4929       include 'COMMON.DERIV'
4930       include 'COMMON.INTERACT'
4931       include 'COMMON.FFIELD'
4932       include 'COMMON.IOUNITS'
4933       include 'COMMON.CONTROL'
4934       include 'COMMON.SPLITELE'
4935       dimension ggg(3)
4936       evdw2=0.0D0
4937       evdw2_14=0.0d0
4938 c        print *,boxxsize,boxysize,boxzsize,'wymiary pudla'
4939 cd    print '(a)','Enter ESCP'
4940 cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
4941 C      do xshift=-1,1
4942 C      do yshift=-1,1
4943 C      do zshift=-1,1
4944       do i=iatscp_s,iatscp_e
4945         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
4946         iteli=itel(i)
4947         xi=0.5D0*(c(1,i)+c(1,i+1))
4948         yi=0.5D0*(c(2,i)+c(2,i+1))
4949         zi=0.5D0*(c(3,i)+c(3,i+1))
4950           xi=mod(xi,boxxsize)
4951           if (xi.lt.0) xi=xi+boxxsize
4952           yi=mod(yi,boxysize)
4953           if (yi.lt.0) yi=yi+boxysize
4954           zi=mod(zi,boxzsize)
4955           if (zi.lt.0) zi=zi+boxzsize
4956 c          xi=xi+xshift*boxxsize
4957 c          yi=yi+yshift*boxysize
4958 c          zi=zi+zshift*boxzsize
4959 c        print *,xi,yi,zi,'polozenie i'
4960 C Return atom into box, boxxsize is size of box in x dimension
4961 c  134   continue
4962 c        if (xi.gt.((xshift+0.5d0)*boxxsize)) xi=xi-boxxsize
4963 c        if (xi.lt.((xshift-0.5d0)*boxxsize)) xi=xi+boxxsize
4964 C Condition for being inside the proper box
4965 c        if ((xi.gt.((xshift+0.5d0)*boxxsize)).or.
4966 c     &       (xi.lt.((xshift-0.5d0)*boxxsize))) then
4967 c        go to 134
4968 c        endif
4969 c  135   continue
4970 c          print *,xi,boxxsize,"pierwszy"
4971
4972 c        if (yi.gt.((yshift+0.5d0)*boxysize)) yi=yi-boxysize
4973 c        if (yi.lt.((yshift-0.5d0)*boxysize)) yi=yi+boxysize
4974 C Condition for being inside the proper box
4975 c        if ((yi.gt.((yshift+0.5d0)*boxysize)).or.
4976 c     &       (yi.lt.((yshift-0.5d0)*boxysize))) then
4977 c        go to 135
4978 c        endif
4979 c  136   continue
4980 c        if (zi.gt.((zshift+0.5d0)*boxzsize)) zi=zi-boxzsize
4981 c        if (zi.lt.((zshift-0.5d0)*boxzsize)) zi=zi+boxzsize
4982 C Condition for being inside the proper box
4983 c        if ((zi.gt.((zshift+0.5d0)*boxzsize)).or.
4984 c     &       (zi.lt.((zshift-0.5d0)*boxzsize))) then
4985 c        go to 136
4986 c        endif
4987         do iint=1,nscp_gr(i)
4988
4989         do j=iscpstart(i,iint),iscpend(i,iint)
4990           itypj=iabs(itype(j))
4991           if (itypj.eq.ntyp1) cycle
4992 C Uncomment following three lines for SC-p interactions
4993 c         xj=c(1,nres+j)-xi
4994 c         yj=c(2,nres+j)-yi
4995 c         zj=c(3,nres+j)-zi
4996 C Uncomment following three lines for Ca-p interactions
4997           xj=c(1,j)
4998           yj=c(2,j)
4999           zj=c(3,j)
5000           xj=mod(xj,boxxsize)
5001           if (xj.lt.0) xj=xj+boxxsize
5002           yj=mod(yj,boxysize)
5003           if (yj.lt.0) yj=yj+boxysize
5004           zj=mod(zj,boxzsize)
5005           if (zj.lt.0) zj=zj+boxzsize
5006 c  174   continue
5007 c        if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
5008 c        if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
5009 C Condition for being inside the proper box
5010 c        if ((xj.gt.((0.5d0)*boxxsize)).or.
5011 c     &       (xj.lt.((-0.5d0)*boxxsize))) then
5012 c        go to 174
5013 c        endif
5014 c  175   continue
5015 c        if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
5016 c        if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
5017 cC Condition for being inside the proper box
5018 c        if ((yj.gt.((0.5d0)*boxysize)).or.
5019 c     &       (yj.lt.((-0.5d0)*boxysize))) then
5020 c        go to 175
5021 c        endif
5022 c  176   continue
5023 c        if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
5024 c        if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
5025 C Condition for being inside the proper box
5026 c        if ((zj.gt.((0.5d0)*boxzsize)).or.
5027 c     &       (zj.lt.((-0.5d0)*boxzsize))) then
5028 c        go to 176
5029 c        endif
5030 CHERE IS THE CALCULATION WHICH MIRROR IMAGE IS THE CLOSEST ONE
5031       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
5032       xj_safe=xj
5033       yj_safe=yj
5034       zj_safe=zj
5035       subchap=0
5036       do xshift=-1,1
5037       do yshift=-1,1
5038       do zshift=-1,1
5039           xj=xj_safe+xshift*boxxsize
5040           yj=yj_safe+yshift*boxysize
5041           zj=zj_safe+zshift*boxzsize
5042           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
5043           if(dist_temp.lt.dist_init) then
5044             dist_init=dist_temp
5045             xj_temp=xj
5046             yj_temp=yj
5047             zj_temp=zj
5048             subchap=1
5049           endif
5050        enddo
5051        enddo
5052        enddo
5053        if (subchap.eq.1) then
5054           xj=xj_temp-xi
5055           yj=yj_temp-yi
5056           zj=zj_temp-zi
5057        else
5058           xj=xj_safe-xi
5059           yj=yj_safe-yi
5060           zj=zj_safe-zi
5061        endif
5062 c          print *,xj,yj,zj,'polozenie j'
5063           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
5064 c          print *,rrij
5065           sss=sscale(1.0d0/(dsqrt(rrij)))
5066 c          print *,r_cut,1.0d0/dsqrt(rrij),sss,'tu patrz'
5067 c          if (sss.eq.0) print *,'czasem jest OK'
5068           if (sss.le.0.0d0) cycle
5069           sssgrad=sscagrad(1.0d0/(dsqrt(rrij)))
5070           fac=rrij**expon2
5071           e1=fac*fac*aad(itypj,iteli)
5072           e2=fac*bad(itypj,iteli)
5073           if (iabs(j-i) .le. 2) then
5074             e1=scal14*e1
5075             e2=scal14*e2
5076             evdw2_14=evdw2_14+(e1+e2)*sss
5077           endif
5078           evdwij=e1+e2
5079           evdw2=evdw2+evdwij*sss
5080           if (energy_dec) write (iout,'(a6,2i5,0pf7.3,2i3,3e11.3)')
5081      &        'evdw2',i,j,evdwij,iteli,itypj,fac,aad(itypj,iteli),
5082      &       bad(itypj,iteli)
5083 C
5084 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
5085 C
5086           fac=-(evdwij+e1)*rrij*sss
5087           fac=fac+(evdwij)*sssgrad*dsqrt(rrij)/expon
5088           ggg(1)=xj*fac
5089           ggg(2)=yj*fac
5090           ggg(3)=zj*fac
5091 cgrad          if (j.lt.i) then
5092 cd          write (iout,*) 'j<i'
5093 C Uncomment following three lines for SC-p interactions
5094 c           do k=1,3
5095 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
5096 c           enddo
5097 cgrad          else
5098 cd          write (iout,*) 'j>i'
5099 cgrad            do k=1,3
5100 cgrad              ggg(k)=-ggg(k)
5101 C Uncomment following line for SC-p interactions
5102 ccgrad             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
5103 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
5104 cgrad            enddo
5105 cgrad          endif
5106 cgrad          do k=1,3
5107 cgrad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
5108 cgrad          enddo
5109 cgrad          kstart=min0(i+1,j)
5110 cgrad          kend=max0(i-1,j-1)
5111 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
5112 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
5113 cgrad          do k=kstart,kend
5114 cgrad            do l=1,3
5115 cgrad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
5116 cgrad            enddo
5117 cgrad          enddo
5118           do k=1,3
5119             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
5120             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
5121           enddo
5122 c        endif !endif for sscale cutoff
5123         enddo ! j
5124
5125         enddo ! iint
5126       enddo ! i
5127 c      enddo !zshift
5128 c      enddo !yshift
5129 c      enddo !xshift
5130       do i=1,nct
5131         do j=1,3
5132           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
5133           gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
5134           gradx_scp(j,i)=expon*gradx_scp(j,i)
5135         enddo
5136       enddo
5137 C******************************************************************************
5138 C
5139 C                              N O T E !!!
5140 C
5141 C To save time the factor EXPON has been extracted from ALL components
5142 C of GVDWC and GRADX. Remember to multiply them by this factor before further
5143 C use!
5144 C
5145 C******************************************************************************
5146       return
5147       end
5148 C--------------------------------------------------------------------------
5149       subroutine edis(ehpb)
5150 C
5151 C Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors.
5152 C
5153       implicit real*8 (a-h,o-z)
5154       include 'DIMENSIONS'
5155       include 'COMMON.SBRIDGE'
5156       include 'COMMON.CHAIN'
5157       include 'COMMON.DERIV'
5158       include 'COMMON.VAR'
5159       include 'COMMON.INTERACT'
5160       include 'COMMON.IOUNITS'
5161       include 'COMMON.CONTROL'
5162       dimension ggg(3)
5163       ehpb=0.0D0
5164       do i=1,3
5165        ggg(i)=0.0d0
5166       enddo
5167 C      write (iout,*) ,"link_end",link_end,constr_dist
5168 cd      write(iout,*)'edis: nhpb=',nhpb,' fbr=',fbr
5169 cd      write(iout,*)'link_start=',link_start,' link_end=',link_end
5170       if (link_end.eq.0) return
5171       do i=link_start,link_end
5172 C If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a
5173 C CA-CA distance used in regularization of structure.
5174         ii=ihpb(i)
5175         jj=jhpb(i)
5176 C iii and jjj point to the residues for which the distance is assigned.
5177         if (ii.gt.nres) then
5178           iii=ii-nres
5179           jjj=jj-nres
5180         else
5181           iii=ii
5182           jjj=jj
5183         endif
5184 c        write (iout,*) "i",i," ii",ii," iii",iii," jj",jj," jjj",jjj,
5185 c     &    dhpb(i),dhpb1(i),forcon(i)
5186 C 24/11/03 AL: SS bridges handled separately because of introducing a specific
5187 C    distance and angle dependent SS bond potential.
5188 C        if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and.
5189 C     & iabs(itype(jjj)).eq.1) then
5190 cmc        if (ii.gt.nres .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then
5191 C 18/07/06 MC: Use the convention that the first nss pairs are SS bonds
5192         if (.not.dyn_ss .and. i.le.nss) then
5193 C 15/02/13 CC dynamic SSbond - additional check
5194          if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and.
5195      & iabs(itype(jjj)).eq.1) then
5196           call ssbond_ene(iii,jjj,eij)
5197           ehpb=ehpb+2*eij
5198          endif
5199 cd          write (iout,*) "eij",eij
5200 cd   &   ' waga=',waga,' fac=',fac
5201         else if (ii.gt.nres .and. jj.gt.nres) then
5202 c Restraints from contact prediction
5203           dd=dist(ii,jj)
5204           if (constr_dist.eq.11) then
5205             ehpb=ehpb+fordepth(i)**4.0d0
5206      &          *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i))
5207             fac=fordepth(i)**4.0d0
5208      &          *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd
5209           if (energy_dec) write (iout,'(a6,2i5,3f8.3)') "edisl",ii,jj,
5210      &    ehpb,fordepth(i),dd
5211            else
5212           if (dhpb1(i).gt.0.0d0) then
5213             ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
5214             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
5215 c            write (iout,*) "beta nmr",
5216 c     &        dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
5217           else
5218             dd=dist(ii,jj)
5219             rdis=dd-dhpb(i)
5220 C Get the force constant corresponding to this distance.
5221             waga=forcon(i)
5222 C Calculate the contribution to energy.
5223             ehpb=ehpb+waga*rdis*rdis
5224 c            write (iout,*) "beta reg",dd,waga*rdis*rdis
5225 C
5226 C Evaluate gradient.
5227 C
5228             fac=waga*rdis/dd
5229           endif
5230           endif
5231           do j=1,3
5232             ggg(j)=fac*(c(j,jj)-c(j,ii))
5233           enddo
5234           do j=1,3
5235             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
5236             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
5237           enddo
5238           do k=1,3
5239             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
5240             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
5241           enddo
5242         else
5243 C Calculate the distance between the two points and its difference from the
5244 C target distance.
5245           dd=dist(ii,jj)
5246           if (constr_dist.eq.11) then
5247             ehpb=ehpb+fordepth(i)**4.0d0
5248      &           *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i))
5249             fac=fordepth(i)**4.0d0
5250      &           *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd
5251           if (energy_dec) write (iout,'(a6,2i5,3f8.3)') "edisl",ii,jj,
5252      &    ehpb,fordepth(i),dd
5253            else
5254           if (dhpb1(i).gt.0.0d0) then
5255             ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
5256             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
5257 c            write (iout,*) "alph nmr",
5258 c     &        dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
5259           else
5260             rdis=dd-dhpb(i)
5261 C Get the force constant corresponding to this distance.
5262             waga=forcon(i)
5263 C Calculate the contribution to energy.
5264             ehpb=ehpb+waga*rdis*rdis
5265 c            write (iout,*) "alpha reg",dd,waga*rdis*rdis
5266 C
5267 C Evaluate gradient.
5268 C
5269             fac=waga*rdis/dd
5270           endif
5271           endif
5272             do j=1,3
5273               ggg(j)=fac*(c(j,jj)-c(j,ii))
5274             enddo
5275 cd      print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
5276 C If this is a SC-SC distance, we need to calculate the contributions to the
5277 C Cartesian gradient in the SC vectors (ghpbx).
5278           if (iii.lt.ii) then
5279           do j=1,3
5280             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
5281             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
5282           enddo
5283           endif
5284 cgrad        do j=iii,jjj-1
5285 cgrad          do k=1,3
5286 cgrad            ghpbc(k,j)=ghpbc(k,j)+ggg(k)
5287 cgrad          enddo
5288 cgrad        enddo
5289           do k=1,3
5290             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
5291             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
5292           enddo
5293         endif
5294       enddo
5295       if (constr_dist.ne.11) ehpb=0.5D0*ehpb
5296       return
5297       end
5298 C--------------------------------------------------------------------------
5299       subroutine ssbond_ene(i,j,eij)
5300 C
5301 C Calculate the distance and angle dependent SS-bond potential energy
5302 C using a free-energy function derived based on RHF/6-31G** ab initio
5303 C calculations of diethyl disulfide.
5304 C
5305 C A. Liwo and U. Kozlowska, 11/24/03
5306 C
5307       implicit real*8 (a-h,o-z)
5308       include 'DIMENSIONS'
5309       include 'COMMON.SBRIDGE'
5310       include 'COMMON.CHAIN'
5311       include 'COMMON.DERIV'
5312       include 'COMMON.LOCAL'
5313       include 'COMMON.INTERACT'
5314       include 'COMMON.VAR'
5315       include 'COMMON.IOUNITS'
5316       double precision erij(3),dcosom1(3),dcosom2(3),gg(3)
5317       itypi=iabs(itype(i))
5318       xi=c(1,nres+i)
5319       yi=c(2,nres+i)
5320       zi=c(3,nres+i)
5321       dxi=dc_norm(1,nres+i)
5322       dyi=dc_norm(2,nres+i)
5323       dzi=dc_norm(3,nres+i)
5324 c      dsci_inv=dsc_inv(itypi)
5325       dsci_inv=vbld_inv(nres+i)
5326       itypj=iabs(itype(j))
5327 c      dscj_inv=dsc_inv(itypj)
5328       dscj_inv=vbld_inv(nres+j)
5329       xj=c(1,nres+j)-xi
5330       yj=c(2,nres+j)-yi
5331       zj=c(3,nres+j)-zi
5332       dxj=dc_norm(1,nres+j)
5333       dyj=dc_norm(2,nres+j)
5334       dzj=dc_norm(3,nres+j)
5335       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
5336       rij=dsqrt(rrij)
5337       erij(1)=xj*rij
5338       erij(2)=yj*rij
5339       erij(3)=zj*rij
5340       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
5341       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
5342       om12=dxi*dxj+dyi*dyj+dzi*dzj
5343       do k=1,3
5344         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
5345         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
5346       enddo
5347       rij=1.0d0/rij
5348       deltad=rij-d0cm
5349       deltat1=1.0d0-om1
5350       deltat2=1.0d0+om2
5351       deltat12=om2-om1+2.0d0
5352       cosphi=om12-om1*om2
5353       eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2)
5354      &  +akct*deltad*deltat12
5355      &  +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi+ebr
5356 c      write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth,
5357 c     &  " akct",akct," deltad",deltad," deltat",deltat1,deltat2,
5358 c     &  " deltat12",deltat12," eij",eij
5359       ed=2*akcm*deltad+akct*deltat12
5360       pom1=akct*deltad
5361       pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
5362       eom1=-2*akth*deltat1-pom1-om2*pom2
5363       eom2= 2*akth*deltat2+pom1-om1*pom2
5364       eom12=pom2
5365       do k=1,3
5366         ggk=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
5367         ghpbx(k,i)=ghpbx(k,i)-ggk
5368      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
5369      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
5370         ghpbx(k,j)=ghpbx(k,j)+ggk
5371      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
5372      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
5373         ghpbc(k,i)=ghpbc(k,i)-ggk
5374         ghpbc(k,j)=ghpbc(k,j)+ggk
5375       enddo
5376 C
5377 C Calculate the components of the gradient in DC and X
5378 C
5379 cgrad      do k=i,j-1
5380 cgrad        do l=1,3
5381 cgrad          ghpbc(l,k)=ghpbc(l,k)+gg(l)
5382 cgrad        enddo
5383 cgrad      enddo
5384       return
5385       end
5386 C--------------------------------------------------------------------------
5387       subroutine ebond(estr)
5388 c
5389 c Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
5390 c
5391       implicit real*8 (a-h,o-z)
5392       include 'DIMENSIONS'
5393       include 'COMMON.LOCAL'
5394       include 'COMMON.GEO'
5395       include 'COMMON.INTERACT'
5396       include 'COMMON.DERIV'
5397       include 'COMMON.VAR'
5398       include 'COMMON.CHAIN'
5399       include 'COMMON.IOUNITS'
5400       include 'COMMON.NAMES'
5401       include 'COMMON.FFIELD'
5402       include 'COMMON.CONTROL'
5403       include 'COMMON.SETUP'
5404       double precision u(3),ud(3)
5405       estr=0.0d0
5406       estr1=0.0d0
5407       do i=ibondp_start,ibondp_end
5408         if (itype(i-1).eq.ntyp1 .and. itype(i).eq.ntyp1) cycle
5409 c          estr1=estr1+gnmr1(vbld(i),-1.0d0,distchainmax)
5410 c          do j=1,3
5411 c          gradb(j,i-1)=gnmr1prim(vbld(i),-1.0d0,distchainmax)
5412 c     &      *dc(j,i-1)/vbld(i)
5413 c          enddo
5414 c          if (energy_dec) write(iout,*)
5415 c     &       "estr1",i,gnmr1(vbld(i),-1.0d0,distchainmax)
5416 c        else
5417 C       Checking if it involves dummy (NH3+ or COO-) group
5418          if (itype(i-1).eq.ntyp1 .or. itype(i).eq.ntyp1) then
5419 C YES   vbldpDUM is the equlibrium length of spring for Dummy atom
5420         diff = vbld(i)-vbldpDUM
5421          else
5422 C NO    vbldp0 is the equlibrium lenght of spring for peptide group
5423         diff = vbld(i)-vbldp0
5424          endif
5425         if (energy_dec)    write (iout,'(a7,i5,4f7.3)')
5426      &     "estr bb",i,vbld(i),vbldp0,diff,AKP*diff*diff
5427         estr=estr+diff*diff
5428         do j=1,3
5429           gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)
5430         enddo
5431 c        write (iout,'(i5,3f10.5)') i,(gradb(j,i-1),j=1,3)
5432 c        endif
5433       enddo
5434       estr=0.5d0*AKP*estr+estr1
5435 c
5436 c 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included
5437 c
5438       do i=ibond_start,ibond_end
5439         iti=iabs(itype(i))
5440         if (iti.ne.10 .and. iti.ne.ntyp1) then
5441           nbi=nbondterm(iti)
5442           if (nbi.eq.1) then
5443             diff=vbld(i+nres)-vbldsc0(1,iti)
5444             if (energy_dec)  write (iout,*)
5445      &      "estr sc",i,iti,vbld(i+nres),vbldsc0(1,iti),diff,
5446      &      AKSC(1,iti),AKSC(1,iti)*diff*diff
5447             estr=estr+0.5d0*AKSC(1,iti)*diff*diff
5448             do j=1,3
5449               gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
5450             enddo
5451           else
5452             do j=1,nbi
5453               diff=vbld(i+nres)-vbldsc0(j,iti)
5454               ud(j)=aksc(j,iti)*diff
5455               u(j)=abond0(j,iti)+0.5d0*ud(j)*diff
5456             enddo
5457             uprod=u(1)
5458             do j=2,nbi
5459               uprod=uprod*u(j)
5460             enddo
5461             usum=0.0d0
5462             usumsqder=0.0d0
5463             do j=1,nbi
5464               uprod1=1.0d0
5465               uprod2=1.0d0
5466               do k=1,nbi
5467                 if (k.ne.j) then
5468                   uprod1=uprod1*u(k)
5469                   uprod2=uprod2*u(k)*u(k)
5470                 endif
5471               enddo
5472               usum=usum+uprod1
5473               usumsqder=usumsqder+ud(j)*uprod2
5474             enddo
5475             estr=estr+uprod/usum
5476             do j=1,3
5477              gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
5478             enddo
5479           endif
5480         endif
5481       enddo
5482       return
5483       end
5484 #ifdef CRYST_THETA
5485 C--------------------------------------------------------------------------
5486       subroutine ebend(etheta,ethetacnstr)
5487 C
5488 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
5489 C angles gamma and its derivatives in consecutive thetas and gammas.
5490 C
5491       implicit real*8 (a-h,o-z)
5492       include 'DIMENSIONS'
5493       include 'COMMON.LOCAL'
5494       include 'COMMON.GEO'
5495       include 'COMMON.INTERACT'
5496       include 'COMMON.DERIV'
5497       include 'COMMON.VAR'
5498       include 'COMMON.CHAIN'
5499       include 'COMMON.IOUNITS'
5500       include 'COMMON.NAMES'
5501       include 'COMMON.FFIELD'
5502       include 'COMMON.CONTROL'
5503       include 'COMMON.TORCNSTR'
5504       common /calcthet/ term1,term2,termm,diffak,ratak,
5505      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
5506      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
5507       double precision y(2),z(2)
5508       delta=0.02d0*pi
5509 c      time11=dexp(-2*time)
5510 c      time12=1.0d0
5511       etheta=0.0D0
5512 c     write (*,'(a,i2)') 'EBEND ICG=',icg
5513       do i=ithet_start,ithet_end
5514         if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
5515      &  .or.itype(i).eq.ntyp1) cycle
5516 C Zero the energy function and its derivative at 0 or pi.
5517         call splinthet(theta(i),0.5d0*delta,ss,ssd)
5518         it=itype(i-1)
5519         ichir1=isign(1,itype(i-2))
5520         ichir2=isign(1,itype(i))
5521          if (itype(i-2).eq.10) ichir1=isign(1,itype(i-1))
5522          if (itype(i).eq.10) ichir2=isign(1,itype(i-1))
5523          if (itype(i-1).eq.10) then
5524           itype1=isign(10,itype(i-2))
5525           ichir11=isign(1,itype(i-2))
5526           ichir12=isign(1,itype(i-2))
5527           itype2=isign(10,itype(i))
5528           ichir21=isign(1,itype(i))
5529           ichir22=isign(1,itype(i))
5530          endif
5531
5532         if (i.gt.3 .and. itype(i-3).ne.ntyp1) then
5533 #ifdef OSF
5534           phii=phi(i)
5535           if (phii.ne.phii) phii=150.0
5536 #else
5537           phii=phi(i)
5538 #endif
5539           y(1)=dcos(phii)
5540           y(2)=dsin(phii)
5541         else
5542           y(1)=0.0D0
5543           y(2)=0.0D0
5544         endif
5545         if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
5546 #ifdef OSF
5547           phii1=phi(i+1)
5548           if (phii1.ne.phii1) phii1=150.0
5549           phii1=pinorm(phii1)
5550           z(1)=cos(phii1)
5551 #else
5552           phii1=phi(i+1)
5553 #endif
5554           z(1)=dcos(phii1)
5555           z(2)=dsin(phii1)
5556         else
5557           z(1)=0.0D0
5558           z(2)=0.0D0
5559         endif
5560 C Calculate the "mean" value of theta from the part of the distribution
5561 C dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2).
5562 C In following comments this theta will be referred to as t_c.
5563         thet_pred_mean=0.0d0
5564         do k=1,2
5565             athetk=athet(k,it,ichir1,ichir2)
5566             bthetk=bthet(k,it,ichir1,ichir2)
5567           if (it.eq.10) then
5568              athetk=athet(k,itype1,ichir11,ichir12)
5569              bthetk=bthet(k,itype2,ichir21,ichir22)
5570           endif
5571          thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k)
5572 c         write(iout,*) 'chuj tu', y(k),z(k)
5573         enddo
5574         dthett=thet_pred_mean*ssd
5575         thet_pred_mean=thet_pred_mean*ss+a0thet(it)
5576 C Derivatives of the "mean" values in gamma1 and gamma2.
5577         dthetg1=(-athet(1,it,ichir1,ichir2)*y(2)
5578      &+athet(2,it,ichir1,ichir2)*y(1))*ss
5579          dthetg2=(-bthet(1,it,ichir1,ichir2)*z(2)
5580      &          +bthet(2,it,ichir1,ichir2)*z(1))*ss
5581          if (it.eq.10) then
5582       dthetg1=(-athet(1,itype1,ichir11,ichir12)*y(2)
5583      &+athet(2,itype1,ichir11,ichir12)*y(1))*ss
5584         dthetg2=(-bthet(1,itype2,ichir21,ichir22)*z(2)
5585      &         +bthet(2,itype2,ichir21,ichir22)*z(1))*ss
5586          endif
5587         if (theta(i).gt.pi-delta) then
5588           call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,
5589      &         E_tc0)
5590           call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0)
5591           call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
5592           call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,
5593      &        E_theta)
5594           call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,
5595      &        E_tc)
5596         else if (theta(i).lt.delta) then
5597           call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0)
5598           call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
5599           call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,
5600      &        E_theta)
5601           call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0)
5602           call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,
5603      &        E_tc)
5604         else
5605           call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,
5606      &        E_theta,E_tc)
5607         endif
5608         etheta=etheta+ethetai
5609         if (energy_dec) write (iout,'(a6,i5,0pf7.3,f7.3,i5)')
5610      &      'ebend',i,ethetai,theta(i),itype(i)
5611         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1
5612         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2
5613         gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)+gloc(nphi+i-2,icg)
5614       enddo
5615       ethetacnstr=0.0d0
5616 C      print *,ithetaconstr_start,ithetaconstr_end,"TU"
5617       do i=ithetaconstr_start,ithetaconstr_end
5618         itheta=itheta_constr(i)
5619         thetiii=theta(itheta)
5620         difi=pinorm(thetiii-theta_constr0(i))
5621         if (difi.gt.theta_drange(i)) then
5622           difi=difi-theta_drange(i)
5623           ethetacnstr=ethetcnstr+0.25d0*for_thet_constr(i)*difi**4
5624           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
5625      &    +for_thet_constr(i)*difi**3
5626         else if (difi.lt.-drange(i)) then
5627           difi=difi+drange(i)
5628           ethetacnstr=ethetcnstr+0.25d0*for_thet_constr(i)*difi**4
5629           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
5630      &    +for_thet_constr(i)*difi**3
5631         else
5632           difi=0.0
5633         endif
5634        if (energy_dec) then
5635         write (iout,'(a6,2i5,4f8.3,2e14.5)') "ethetc",
5636      &    i,itheta,rad2deg*thetiii,
5637      &    rad2deg*theta_constr0(i),  rad2deg*theta_drange(i),
5638      &    rad2deg*difi,0.25d0*for_thet_constr(i)*difi**4,
5639      &    gloc(itheta+nphi-2,icg)
5640         endif
5641       enddo
5642
5643 C Ufff.... We've done all this!!!
5644       return
5645       end
5646 C---------------------------------------------------------------------------
5647       subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,
5648      &     E_tc)
5649       implicit real*8 (a-h,o-z)
5650       include 'DIMENSIONS'
5651       include 'COMMON.LOCAL'
5652       include 'COMMON.IOUNITS'
5653       common /calcthet/ term1,term2,termm,diffak,ratak,
5654      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
5655      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
5656 C Calculate the contributions to both Gaussian lobes.
5657 C 6/6/97 - Deform the Gaussians using the factor of 1/(1+time)
5658 C The "polynomial part" of the "standard deviation" of this part of
5659 C the distributioni.
5660 ccc        write (iout,*) thetai,thet_pred_mean
5661         sig=polthet(3,it)
5662         do j=2,0,-1
5663           sig=sig*thet_pred_mean+polthet(j,it)
5664         enddo
5665 C Derivative of the "interior part" of the "standard deviation of the"
5666 C gamma-dependent Gaussian lobe in t_c.
5667         sigtc=3*polthet(3,it)
5668         do j=2,1,-1
5669           sigtc=sigtc*thet_pred_mean+j*polthet(j,it)
5670         enddo
5671         sigtc=sig*sigtc
5672 C Set the parameters of both Gaussian lobes of the distribution.
5673 C "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc)
5674         fac=sig*sig+sigc0(it)
5675         sigcsq=fac+fac
5676         sigc=1.0D0/sigcsq
5677 C Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c
5678         sigsqtc=-4.0D0*sigcsq*sigtc
5679 c       print *,i,sig,sigtc,sigsqtc
5680 C Following variable (sigtc) is d[sigma(t_c)]/dt_c
5681         sigtc=-sigtc/(fac*fac)
5682 C Following variable is sigma(t_c)**(-2)
5683         sigcsq=sigcsq*sigcsq
5684         sig0i=sig0(it)
5685         sig0inv=1.0D0/sig0i**2
5686         delthec=thetai-thet_pred_mean
5687         delthe0=thetai-theta0i
5688         term1=-0.5D0*sigcsq*delthec*delthec
5689         term2=-0.5D0*sig0inv*delthe0*delthe0
5690 C        write (iout,*)'term1',term1,term2,sigcsq,delthec,sig0inv,delthe0
5691 C Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and
5692 C NaNs in taking the logarithm. We extract the largest exponent which is added
5693 C to the energy (this being the log of the distribution) at the end of energy
5694 C term evaluation for this virtual-bond angle.
5695         if (term1.gt.term2) then
5696           termm=term1
5697           term2=dexp(term2-termm)
5698           term1=1.0d0
5699         else
5700           termm=term2
5701           term1=dexp(term1-termm)
5702           term2=1.0d0
5703         endif
5704 C The ratio between the gamma-independent and gamma-dependent lobes of
5705 C the distribution is a Gaussian function of thet_pred_mean too.
5706         diffak=gthet(2,it)-thet_pred_mean
5707         ratak=diffak/gthet(3,it)**2
5708         ak=dexp(gthet(1,it)-0.5D0*diffak*ratak)
5709 C Let's differentiate it in thet_pred_mean NOW.
5710         aktc=ak*ratak
5711 C Now put together the distribution terms to make complete distribution.
5712         termexp=term1+ak*term2
5713         termpre=sigc+ak*sig0i
5714 C Contribution of the bending energy from this theta is just the -log of
5715 C the sum of the contributions from the two lobes and the pre-exponential
5716 C factor. Simple enough, isn't it?
5717         ethetai=(-dlog(termexp)-termm+dlog(termpre))
5718 C       write (iout,*) 'termexp',termexp,termm,termpre,i
5719 C NOW the derivatives!!!
5720 C 6/6/97 Take into account the deformation.
5721         E_theta=(delthec*sigcsq*term1
5722      &       +ak*delthe0*sig0inv*term2)/termexp
5723         E_tc=((sigtc+aktc*sig0i)/termpre
5724      &      -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+
5725      &       aktc*term2)/termexp)
5726       return
5727       end
5728 c-----------------------------------------------------------------------------
5729       subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)
5730       implicit real*8 (a-h,o-z)
5731       include 'DIMENSIONS'
5732       include 'COMMON.LOCAL'
5733       include 'COMMON.IOUNITS'
5734       common /calcthet/ term1,term2,termm,diffak,ratak,
5735      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
5736      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
5737       delthec=thetai-thet_pred_mean
5738       delthe0=thetai-theta0i
5739 C "Thank you" to MAPLE (probably spared one day of hand-differentiation).
5740       t3 = thetai-thet_pred_mean
5741       t6 = t3**2
5742       t9 = term1
5743       t12 = t3*sigcsq
5744       t14 = t12+t6*sigsqtc
5745       t16 = 1.0d0
5746       t21 = thetai-theta0i
5747       t23 = t21**2
5748       t26 = term2
5749       t27 = t21*t26
5750       t32 = termexp
5751       t40 = t32**2
5752       E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9
5753      & -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40
5754      & *(-t12*t9-ak*sig0inv*t27)
5755       return
5756       end
5757 #else
5758 C--------------------------------------------------------------------------
5759       subroutine ebend(etheta,ethetacnstr)
5760 C
5761 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
5762 C angles gamma and its derivatives in consecutive thetas and gammas.
5763 C ab initio-derived potentials from
5764 c Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203
5765 C
5766       implicit real*8 (a-h,o-z)
5767       include 'DIMENSIONS'
5768       include 'COMMON.LOCAL'
5769       include 'COMMON.GEO'
5770       include 'COMMON.INTERACT'
5771       include 'COMMON.DERIV'
5772       include 'COMMON.VAR'
5773       include 'COMMON.CHAIN'
5774       include 'COMMON.IOUNITS'
5775       include 'COMMON.NAMES'
5776       include 'COMMON.FFIELD'
5777       include 'COMMON.CONTROL'
5778       include 'COMMON.TORCNSTR'
5779       double precision coskt(mmaxtheterm),sinkt(mmaxtheterm),
5780      & cosph1(maxsingle),sinph1(maxsingle),cosph2(maxsingle),
5781      & sinph2(maxsingle),cosph1ph2(maxdouble,maxdouble),
5782      & sinph1ph2(maxdouble,maxdouble)
5783       logical lprn /.false./, lprn1 /.false./
5784       etheta=0.0D0
5785       do i=ithet_start,ithet_end
5786 c        print *,i,itype(i-1),itype(i),itype(i-2)
5787         if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
5788      &  .or.itype(i).eq.ntyp1) cycle
5789 C        print *,i,theta(i)
5790         if (iabs(itype(i+1)).eq.20) iblock=2
5791         if (iabs(itype(i+1)).ne.20) iblock=1
5792         dethetai=0.0d0
5793         dephii=0.0d0
5794         dephii1=0.0d0
5795         theti2=0.5d0*theta(i)
5796         ityp2=ithetyp((itype(i-1)))
5797         do k=1,nntheterm
5798           coskt(k)=dcos(k*theti2)
5799           sinkt(k)=dsin(k*theti2)
5800         enddo
5801 C        print *,ethetai
5802         if (i.gt.3 .and. itype(i-3).ne.ntyp1) then
5803 #ifdef OSF
5804           phii=phi(i)
5805           if (phii.ne.phii) phii=150.0
5806 #else
5807           phii=phi(i)
5808 #endif
5809           ityp1=ithetyp((itype(i-2)))
5810 C propagation of chirality for glycine type
5811           do k=1,nsingle
5812             cosph1(k)=dcos(k*phii)
5813             sinph1(k)=dsin(k*phii)
5814           enddo
5815         else
5816           phii=0.0d0
5817           do k=1,nsingle
5818           ityp1=ithetyp((itype(i-2)))
5819             cosph1(k)=0.0d0
5820             sinph1(k)=0.0d0
5821           enddo
5822         endif
5823         if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
5824 #ifdef OSF
5825           phii1=phi(i+1)
5826           if (phii1.ne.phii1) phii1=150.0
5827           phii1=pinorm(phii1)
5828 #else
5829           phii1=phi(i+1)
5830 #endif
5831           ityp3=ithetyp((itype(i)))
5832           do k=1,nsingle
5833             cosph2(k)=dcos(k*phii1)
5834             sinph2(k)=dsin(k*phii1)
5835           enddo
5836         else
5837           phii1=0.0d0
5838           ityp3=ithetyp((itype(i)))
5839           do k=1,nsingle
5840             cosph2(k)=0.0d0
5841             sinph2(k)=0.0d0
5842           enddo
5843         endif
5844         ethetai=aa0thet(ityp1,ityp2,ityp3,iblock)
5845         do k=1,ndouble
5846           do l=1,k-1
5847             ccl=cosph1(l)*cosph2(k-l)
5848             ssl=sinph1(l)*sinph2(k-l)
5849             scl=sinph1(l)*cosph2(k-l)
5850             csl=cosph1(l)*sinph2(k-l)
5851             cosph1ph2(l,k)=ccl-ssl
5852             cosph1ph2(k,l)=ccl+ssl
5853             sinph1ph2(l,k)=scl+csl
5854             sinph1ph2(k,l)=scl-csl
5855           enddo
5856         enddo
5857         if (lprn) then
5858         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,
5859      &    " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
5860         write (iout,*) "coskt and sinkt"
5861         do k=1,nntheterm
5862           write (iout,*) k,coskt(k),sinkt(k)
5863         enddo
5864         endif
5865         do k=1,ntheterm
5866           ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3,iblock)*sinkt(k)
5867           dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3,iblock)
5868      &      *coskt(k)
5869           if (lprn)
5870      &    write (iout,*) "k",k,"
5871      &     aathet",aathet(k,ityp1,ityp2,ityp3,iblock),
5872      &     " ethetai",ethetai
5873         enddo
5874         if (lprn) then
5875         write (iout,*) "cosph and sinph"
5876         do k=1,nsingle
5877           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
5878         enddo
5879         write (iout,*) "cosph1ph2 and sinph2ph2"
5880         do k=2,ndouble
5881           do l=1,k-1
5882             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),
5883      &         sinph1ph2(l,k),sinph1ph2(k,l)
5884           enddo
5885         enddo
5886         write(iout,*) "ethetai",ethetai
5887         endif
5888 C       print *,ethetai
5889         do m=1,ntheterm2
5890           do k=1,nsingle
5891             aux=bbthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)
5892      &         +ccthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k)
5893      &         +ddthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)
5894      &         +eethet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k)
5895             ethetai=ethetai+sinkt(m)*aux
5896             dethetai=dethetai+0.5d0*m*aux*coskt(m)
5897             dephii=dephii+k*sinkt(m)*(
5898      &          ccthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)-
5899      &          bbthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k))
5900             dephii1=dephii1+k*sinkt(m)*(
5901      &          eethet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)-
5902      &          ddthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k))
5903             if (lprn)
5904      &      write (iout,*) "m",m," k",k," bbthet",
5905      &         bbthet(k,m,ityp1,ityp2,ityp3,iblock)," ccthet",
5906      &         ccthet(k,m,ityp1,ityp2,ityp3,iblock)," ddthet",
5907      &         ddthet(k,m,ityp1,ityp2,ityp3,iblock)," eethet",
5908      &         eethet(k,m,ityp1,ityp2,ityp3,iblock)," ethetai",ethetai
5909 C        print *,"tu",cosph1(k),sinph1(k),cosph2(k),sinph2(k)
5910           enddo
5911         enddo
5912 C        print *,"cosph1", (cosph1(k), k=1,nsingle)
5913 C        print *,"cosph2", (cosph2(k), k=1,nsingle)
5914 C        print *,"sinph1", (sinph1(k), k=1,nsingle)
5915 C        print *,"sinph2", (sinph2(k), k=1,nsingle)
5916         if (lprn)
5917      &  write(iout,*) "ethetai",ethetai
5918 C        print *,"tu",cosph1(k),sinph1(k),cosph2(k),sinph2(k)
5919         do m=1,ntheterm3
5920           do k=2,ndouble
5921             do l=1,k-1
5922               aux=ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
5923      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l)+
5924      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
5925      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)
5926               ethetai=ethetai+sinkt(m)*aux
5927               dethetai=dethetai+0.5d0*m*coskt(m)*aux
5928               dephii=dephii+l*sinkt(m)*(
5929      &           -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)-
5930      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
5931      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
5932      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
5933               dephii1=dephii1+(k-l)*sinkt(m)*(
5934      &           -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
5935      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
5936      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)-
5937      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
5938               if (lprn) then
5939               write (iout,*) "m",m," k",k," l",l," ffthet",
5940      &            ffthet(l,k,m,ityp1,ityp2,ityp3,iblock),
5941      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)," ggthet",
5942      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock),
5943      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock),
5944      &            " ethetai",ethetai
5945               write (iout,*) cosph1ph2(l,k)*sinkt(m),
5946      &            cosph1ph2(k,l)*sinkt(m),
5947      &            sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
5948               endif
5949             enddo
5950           enddo
5951         enddo
5952 10      continue
5953 c        lprn1=.true.
5954 C        print *,ethetai
5955         if (lprn1)
5956      &    write (iout,'(i2,3f8.1,9h ethetai ,f10.5)')
5957      &   i,theta(i)*rad2deg,phii*rad2deg,
5958      &   phii1*rad2deg,ethetai
5959 c        lprn1=.false.
5960         etheta=etheta+ethetai
5961         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
5962         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
5963         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)+wang*dethetai
5964       enddo
5965 C now constrains
5966       ethetacnstr=0.0d0
5967 C      print *,ithetaconstr_start,ithetaconstr_end,"TU"
5968       do i=ithetaconstr_start,ithetaconstr_end
5969         itheta=itheta_constr(i)
5970         thetiii=theta(itheta)
5971         difi=pinorm(thetiii-theta_constr0(i))
5972         if (difi.gt.theta_drange(i)) then
5973           difi=difi-theta_drange(i)
5974           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
5975           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
5976      &    +for_thet_constr(i)*difi**3
5977         else if (difi.lt.-drange(i)) then
5978           difi=difi+drange(i)
5979           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
5980           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
5981      &    +for_thet_constr(i)*difi**3
5982         else
5983           difi=0.0
5984         endif
5985        if (energy_dec) then
5986         write (iout,'(a6,2i5,4f8.3,2e14.5)') "ethetc",
5987      &    i,itheta,rad2deg*thetiii,
5988      &    rad2deg*theta_constr0(i),  rad2deg*theta_drange(i),
5989      &    rad2deg*difi,0.25d0*for_thet_constr(i)*difi**4,
5990      &    gloc(itheta+nphi-2,icg)
5991         endif
5992       enddo
5993
5994       return
5995       end
5996 #endif
5997 #ifdef CRYST_SC
5998 c-----------------------------------------------------------------------------
5999       subroutine esc(escloc)
6000 C Calculate the local energy of a side chain and its derivatives in the
6001 C corresponding virtual-bond valence angles THETA and the spherical angles
6002 C ALPHA and OMEGA.
6003       implicit real*8 (a-h,o-z)
6004       include 'DIMENSIONS'
6005       include 'COMMON.GEO'
6006       include 'COMMON.LOCAL'
6007       include 'COMMON.VAR'
6008       include 'COMMON.INTERACT'
6009       include 'COMMON.DERIV'
6010       include 'COMMON.CHAIN'
6011       include 'COMMON.IOUNITS'
6012       include 'COMMON.NAMES'
6013       include 'COMMON.FFIELD'
6014       include 'COMMON.CONTROL'
6015       double precision x(3),dersc(3),xemp(3),dersc0(3),dersc1(3),
6016      &     ddersc0(3),ddummy(3),xtemp(3),temp(3)
6017       common /sccalc/ time11,time12,time112,theti,it,nlobit
6018       delta=0.02d0*pi
6019       escloc=0.0D0
6020 c     write (iout,'(a)') 'ESC'
6021       do i=loc_start,loc_end
6022         it=itype(i)
6023         if (it.eq.ntyp1) cycle
6024         if (it.eq.10) goto 1
6025         nlobit=nlob(iabs(it))
6026 c       print *,'i=',i,' it=',it,' nlobit=',nlobit
6027 c       write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
6028         theti=theta(i+1)-pipol
6029         x(1)=dtan(theti)
6030         x(2)=alph(i)
6031         x(3)=omeg(i)
6032
6033         if (x(2).gt.pi-delta) then
6034           xtemp(1)=x(1)
6035           xtemp(2)=pi-delta
6036           xtemp(3)=x(3)
6037           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
6038           xtemp(2)=pi
6039           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
6040           call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),
6041      &        escloci,dersc(2))
6042           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
6043      &        ddersc0(1),dersc(1))
6044           call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),
6045      &        ddersc0(3),dersc(3))
6046           xtemp(2)=pi-delta
6047           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
6048           xtemp(2)=pi
6049           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
6050           call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,
6051      &            dersc0(2),esclocbi,dersc02)
6052           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
6053      &            dersc12,dersc01)
6054           call splinthet(x(2),0.5d0*delta,ss,ssd)
6055           dersc0(1)=dersc01
6056           dersc0(2)=dersc02
6057           dersc0(3)=0.0d0
6058           do k=1,3
6059             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
6060           enddo
6061           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
6062 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
6063 c    &             esclocbi,ss,ssd
6064           escloci=ss*escloci+(1.0d0-ss)*esclocbi
6065 c         escloci=esclocbi
6066 c         write (iout,*) escloci
6067         else if (x(2).lt.delta) then
6068           xtemp(1)=x(1)
6069           xtemp(2)=delta
6070           xtemp(3)=x(3)
6071           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
6072           xtemp(2)=0.0d0
6073           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
6074           call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),
6075      &        escloci,dersc(2))
6076           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
6077      &        ddersc0(1),dersc(1))
6078           call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),
6079      &        ddersc0(3),dersc(3))
6080           xtemp(2)=delta
6081           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
6082           xtemp(2)=0.0d0
6083           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
6084           call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,
6085      &            dersc0(2),esclocbi,dersc02)
6086           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
6087      &            dersc12,dersc01)
6088           dersc0(1)=dersc01
6089           dersc0(2)=dersc02
6090           dersc0(3)=0.0d0
6091           call splinthet(x(2),0.5d0*delta,ss,ssd)
6092           do k=1,3
6093             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
6094           enddo
6095           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
6096 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
6097 c    &             esclocbi,ss,ssd
6098           escloci=ss*escloci+(1.0d0-ss)*esclocbi
6099 c         write (iout,*) escloci
6100         else
6101           call enesc(x,escloci,dersc,ddummy,.false.)
6102         endif
6103
6104         escloc=escloc+escloci
6105         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
6106      &     'escloc',i,escloci
6107 c       write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
6108
6109         gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
6110      &   wscloc*dersc(1)
6111         gloc(ialph(i,1),icg)=wscloc*dersc(2)
6112         gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
6113     1   continue
6114       enddo
6115       return
6116       end
6117 C---------------------------------------------------------------------------
6118       subroutine enesc(x,escloci,dersc,ddersc,mixed)
6119       implicit real*8 (a-h,o-z)
6120       include 'DIMENSIONS'
6121       include 'COMMON.GEO'
6122       include 'COMMON.LOCAL'
6123       include 'COMMON.IOUNITS'
6124       common /sccalc/ time11,time12,time112,theti,it,nlobit
6125       double precision x(3),z(3),Ax(3,maxlob,-1:1),dersc(3),ddersc(3)
6126       double precision contr(maxlob,-1:1)
6127       logical mixed
6128 c       write (iout,*) 'it=',it,' nlobit=',nlobit
6129         escloc_i=0.0D0
6130         do j=1,3
6131           dersc(j)=0.0D0
6132           if (mixed) ddersc(j)=0.0d0
6133         enddo
6134         x3=x(3)
6135
6136 C Because of periodicity of the dependence of the SC energy in omega we have
6137 C to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
6138 C To avoid underflows, first compute & store the exponents.
6139
6140         do iii=-1,1
6141
6142           x(3)=x3+iii*dwapi
6143
6144           do j=1,nlobit
6145             do k=1,3
6146               z(k)=x(k)-censc(k,j,it)
6147             enddo
6148             do k=1,3
6149               Axk=0.0D0
6150               do l=1,3
6151                 Axk=Axk+gaussc(l,k,j,it)*z(l)
6152               enddo
6153               Ax(k,j,iii)=Axk
6154             enddo
6155             expfac=0.0D0
6156             do k=1,3
6157               expfac=expfac+Ax(k,j,iii)*z(k)
6158             enddo
6159             contr(j,iii)=expfac
6160           enddo ! j
6161
6162         enddo ! iii
6163
6164         x(3)=x3
6165 C As in the case of ebend, we want to avoid underflows in exponentiation and
6166 C subsequent NaNs and INFs in energy calculation.
6167 C Find the largest exponent
6168         emin=contr(1,-1)
6169         do iii=-1,1
6170           do j=1,nlobit
6171             if (emin.gt.contr(j,iii)) emin=contr(j,iii)
6172           enddo
6173         enddo
6174         emin=0.5D0*emin
6175 cd      print *,'it=',it,' emin=',emin
6176
6177 C Compute the contribution to SC energy and derivatives
6178         do iii=-1,1
6179
6180           do j=1,nlobit
6181 #ifdef OSF
6182             adexp=bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin
6183             if(adexp.ne.adexp) adexp=1.0
6184             expfac=dexp(adexp)
6185 #else
6186             expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin)
6187 #endif
6188 cd          print *,'j=',j,' expfac=',expfac
6189             escloc_i=escloc_i+expfac
6190             do k=1,3
6191               dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
6192             enddo
6193             if (mixed) then
6194               do k=1,3,2
6195                 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii)
6196      &            +gaussc(k,2,j,it))*expfac
6197               enddo
6198             endif
6199           enddo
6200
6201         enddo ! iii
6202
6203         dersc(1)=dersc(1)/cos(theti)**2
6204         ddersc(1)=ddersc(1)/cos(theti)**2
6205         ddersc(3)=ddersc(3)
6206
6207         escloci=-(dlog(escloc_i)-emin)
6208         do j=1,3
6209           dersc(j)=dersc(j)/escloc_i
6210         enddo
6211         if (mixed) then
6212           do j=1,3,2
6213             ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
6214           enddo
6215         endif
6216       return
6217       end
6218 C------------------------------------------------------------------------------
6219       subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
6220       implicit real*8 (a-h,o-z)
6221       include 'DIMENSIONS'
6222       include 'COMMON.GEO'
6223       include 'COMMON.LOCAL'
6224       include 'COMMON.IOUNITS'
6225       common /sccalc/ time11,time12,time112,theti,it,nlobit
6226       double precision x(3),z(3),Ax(3,maxlob),dersc(3)
6227       double precision contr(maxlob)
6228       logical mixed
6229
6230       escloc_i=0.0D0
6231
6232       do j=1,3
6233         dersc(j)=0.0D0
6234       enddo
6235
6236       do j=1,nlobit
6237         do k=1,2
6238           z(k)=x(k)-censc(k,j,it)
6239         enddo
6240         z(3)=dwapi
6241         do k=1,3
6242           Axk=0.0D0
6243           do l=1,3
6244             Axk=Axk+gaussc(l,k,j,it)*z(l)
6245           enddo
6246           Ax(k,j)=Axk
6247         enddo
6248         expfac=0.0D0
6249         do k=1,3
6250           expfac=expfac+Ax(k,j)*z(k)
6251         enddo
6252         contr(j)=expfac
6253       enddo ! j
6254
6255 C As in the case of ebend, we want to avoid underflows in exponentiation and
6256 C subsequent NaNs and INFs in energy calculation.
6257 C Find the largest exponent
6258       emin=contr(1)
6259       do j=1,nlobit
6260         if (emin.gt.contr(j)) emin=contr(j)
6261       enddo
6262       emin=0.5D0*emin
6263
6264 C Compute the contribution to SC energy and derivatives
6265
6266       dersc12=0.0d0
6267       do j=1,nlobit
6268         expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j)+emin)
6269         escloc_i=escloc_i+expfac
6270         do k=1,2
6271           dersc(k)=dersc(k)+Ax(k,j)*expfac
6272         enddo
6273         if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j)
6274      &            +gaussc(1,2,j,it))*expfac
6275         dersc(3)=0.0d0
6276       enddo
6277
6278       dersc(1)=dersc(1)/cos(theti)**2
6279       dersc12=dersc12/cos(theti)**2
6280       escloci=-(dlog(escloc_i)-emin)
6281       do j=1,2
6282         dersc(j)=dersc(j)/escloc_i
6283       enddo
6284       if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
6285       return
6286       end
6287 #else
6288 c----------------------------------------------------------------------------------
6289       subroutine esc(escloc)
6290 C Calculate the local energy of a side chain and its derivatives in the
6291 C corresponding virtual-bond valence angles THETA and the spherical angles
6292 C ALPHA and OMEGA derived from AM1 all-atom calculations.
6293 C added by Urszula Kozlowska. 07/11/2007
6294 C
6295       implicit real*8 (a-h,o-z)
6296       include 'DIMENSIONS'
6297       include 'COMMON.GEO'
6298       include 'COMMON.LOCAL'
6299       include 'COMMON.VAR'
6300       include 'COMMON.SCROT'
6301       include 'COMMON.INTERACT'
6302       include 'COMMON.DERIV'
6303       include 'COMMON.CHAIN'
6304       include 'COMMON.IOUNITS'
6305       include 'COMMON.NAMES'
6306       include 'COMMON.FFIELD'
6307       include 'COMMON.CONTROL'
6308       include 'COMMON.VECTORS'
6309       double precision x_prime(3),y_prime(3),z_prime(3)
6310      &    , sumene,dsc_i,dp2_i,x(65),
6311      &     xx,yy,zz,sumene1,sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6,
6312      &    de_dxx,de_dyy,de_dzz,de_dt
6313       double precision s1_t,s1_6_t,s2_t,s2_6_t
6314       double precision
6315      & dXX_Ci1(3),dYY_Ci1(3),dZZ_Ci1(3),dXX_Ci(3),
6316      & dYY_Ci(3),dZZ_Ci(3),dXX_XYZ(3),dYY_XYZ(3),dZZ_XYZ(3),
6317      & dt_dCi(3),dt_dCi1(3)
6318       common /sccalc/ time11,time12,time112,theti,it,nlobit
6319       delta=0.02d0*pi
6320       escloc=0.0D0
6321       do i=loc_start,loc_end
6322         if (itype(i).eq.ntyp1) cycle
6323         costtab(i+1) =dcos(theta(i+1))
6324         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
6325         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
6326         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
6327         cosfac2=0.5d0/(1.0d0+costtab(i+1))
6328         cosfac=dsqrt(cosfac2)
6329         sinfac2=0.5d0/(1.0d0-costtab(i+1))
6330         sinfac=dsqrt(sinfac2)
6331         it=iabs(itype(i))
6332         if (it.eq.10) goto 1
6333 c
6334 C  Compute the axes of tghe local cartesian coordinates system; store in
6335 c   x_prime, y_prime and z_prime
6336 c
6337         do j=1,3
6338           x_prime(j) = 0.00
6339           y_prime(j) = 0.00
6340           z_prime(j) = 0.00
6341         enddo
6342 C        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
6343 C     &   dc_norm(3,i+nres)
6344         do j = 1,3
6345           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
6346           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
6347         enddo
6348         do j = 1,3
6349           z_prime(j) = -uz(j,i-1)*dsign(1.0d0,dfloat(itype(i)))
6350         enddo
6351 c       write (2,*) "i",i
6352 c       write (2,*) "x_prime",(x_prime(j),j=1,3)
6353 c       write (2,*) "y_prime",(y_prime(j),j=1,3)
6354 c       write (2,*) "z_prime",(z_prime(j),j=1,3)
6355 c       write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
6356 c      & " xy",scalar(x_prime(1),y_prime(1)),
6357 c      & " xz",scalar(x_prime(1),z_prime(1)),
6358 c      & " yy",scalar(y_prime(1),y_prime(1)),
6359 c      & " yz",scalar(y_prime(1),z_prime(1)),
6360 c      & " zz",scalar(z_prime(1),z_prime(1))
6361 c
6362 C Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
6363 C to local coordinate system. Store in xx, yy, zz.
6364 c
6365         xx=0.0d0
6366         yy=0.0d0
6367         zz=0.0d0
6368         do j = 1,3
6369           xx = xx + x_prime(j)*dc_norm(j,i+nres)
6370           yy = yy + y_prime(j)*dc_norm(j,i+nres)
6371           zz = zz + z_prime(j)*dc_norm(j,i+nres)
6372         enddo
6373
6374         xxtab(i)=xx
6375         yytab(i)=yy
6376         zztab(i)=zz
6377 C
6378 C Compute the energy of the ith side cbain
6379 C
6380 c        write (2,*) "xx",xx," yy",yy," zz",zz
6381         it=iabs(itype(i))
6382         do j = 1,65
6383           x(j) = sc_parmin(j,it)
6384         enddo
6385 #ifdef CHECK_COORD
6386 Cc diagnostics - remove later
6387         xx1 = dcos(alph(2))
6388         yy1 = dsin(alph(2))*dcos(omeg(2))
6389         zz1 = -dsign(1.0,dfloat(itype(i)))*dsin(alph(2))*dsin(omeg(2))
6390         write(2,'(3f8.1,3f9.3,1x,3f9.3)')
6391      &    alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,
6392      &    xx1,yy1,zz1
6393 C,"  --- ", xx_w,yy_w,zz_w
6394 c end diagnostics
6395 #endif
6396         sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
6397      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
6398      &   + x(10)*yy*zz
6399         sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
6400      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
6401      & + x(20)*yy*zz
6402         sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
6403      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
6404      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
6405      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
6406      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
6407      &  +x(40)*xx*yy*zz
6408         sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
6409      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
6410      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
6411      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
6412      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
6413      &  +x(60)*xx*yy*zz
6414         dsc_i   = 0.743d0+x(61)
6415         dp2_i   = 1.9d0+x(62)
6416         dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
6417      &          *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
6418         dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
6419      &          *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
6420         s1=(1+x(63))/(0.1d0 + dscp1)
6421         s1_6=(1+x(64))/(0.1d0 + dscp1**6)
6422         s2=(1+x(65))/(0.1d0 + dscp2)
6423         s2_6=(1+x(65))/(0.1d0 + dscp2**6)
6424         sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6)
6425      & + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
6426 c        write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
6427 c     &   sumene4,
6428 c     &   dscp1,dscp2,sumene
6429 c        sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6430         escloc = escloc + sumene
6431 c        write (2,*) "i",i," escloc",sumene,escloc,it,itype(i)
6432 c     & ,zz,xx,yy
6433 c#define DEBUG
6434 #ifdef DEBUG
6435 C
6436 C This section to check the numerical derivatives of the energy of ith side
6437 C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
6438 C #define DEBUG in the code to turn it on.
6439 C
6440         write (2,*) "sumene               =",sumene
6441         aincr=1.0d-7
6442         xxsave=xx
6443         xx=xx+aincr
6444         write (2,*) xx,yy,zz
6445         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6446         de_dxx_num=(sumenep-sumene)/aincr
6447         xx=xxsave
6448         write (2,*) "xx+ sumene from enesc=",sumenep
6449         yysave=yy
6450         yy=yy+aincr
6451         write (2,*) xx,yy,zz
6452         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6453         de_dyy_num=(sumenep-sumene)/aincr
6454         yy=yysave
6455         write (2,*) "yy+ sumene from enesc=",sumenep
6456         zzsave=zz
6457         zz=zz+aincr
6458         write (2,*) xx,yy,zz
6459         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6460         de_dzz_num=(sumenep-sumene)/aincr
6461         zz=zzsave
6462         write (2,*) "zz+ sumene from enesc=",sumenep
6463         costsave=cost2tab(i+1)
6464         sintsave=sint2tab(i+1)
6465         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
6466         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
6467         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6468         de_dt_num=(sumenep-sumene)/aincr
6469         write (2,*) " t+ sumene from enesc=",sumenep
6470         cost2tab(i+1)=costsave
6471         sint2tab(i+1)=sintsave
6472 C End of diagnostics section.
6473 #endif
6474 C
6475 C Compute the gradient of esc
6476 C
6477 c        zz=zz*dsign(1.0,dfloat(itype(i)))
6478         pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
6479         pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
6480         pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
6481         pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
6482         pom_dx=dsc_i*dp2_i*cost2tab(i+1)
6483         pom_dy=dsc_i*dp2_i*sint2tab(i+1)
6484         pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
6485         pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
6486         pom1=(sumene3*sint2tab(i+1)+sumene1)
6487      &     *(pom_s1/dscp1+pom_s16*dscp1**4)
6488         pom2=(sumene4*cost2tab(i+1)+sumene2)
6489      &     *(pom_s2/dscp2+pom_s26*dscp2**4)
6490         sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
6491         sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2
6492      &  +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2)
6493      &  +x(40)*yy*zz
6494         sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
6495         sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2
6496      &  +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2)
6497      &  +x(60)*yy*zz
6498         de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6)
6499      &        +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6)
6500      &        +(pom1+pom2)*pom_dx
6501 #ifdef DEBUG
6502         write(2,*), "de_dxx = ", de_dxx,de_dxx_num,itype(i)
6503 #endif
6504 C
6505         sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
6506         sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2
6507      &  +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2)
6508      &  +x(40)*xx*zz
6509         sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
6510         sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz
6511      &  +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz
6512      &  +x(59)*zz**2 +x(60)*xx*zz
6513         de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6)
6514      &        +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6)
6515      &        +(pom1-pom2)*pom_dy
6516 #ifdef DEBUG
6517         write(2,*), "de_dyy = ", de_dyy,de_dyy_num,itype(i)
6518 #endif
6519 C
6520         de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy
6521      &  +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx
6522      &  +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6)
6523      &  +(x(4) + 2*x(7)*zz+  x(8)*xx + x(10)*yy)*(s1+s1_6)
6524      &  +(x(44)+2*x(47)*zz +x(48)*xx   +x(50)*yy  +3*x(53)*zz**2
6525      &  +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy
6526      &  +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6)
6527      &  + ( x(14) + 2*x(17)*zz+  x(18)*xx + x(20)*yy)*(s2+s2_6)
6528 #ifdef DEBUG
6529         write(2,*), "de_dzz = ", de_dzz,de_dzz_num,itype(i)
6530 #endif
6531 C
6532         de_dt =  0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6)
6533      &  -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6)
6534      &  +pom1*pom_dt1+pom2*pom_dt2
6535 #ifdef DEBUG
6536         write(2,*), "de_dt = ", de_dt,de_dt_num,itype(i)
6537 #endif
6538 c#undef DEBUG
6539 c
6540 C
6541        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
6542        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
6543        cosfac2xx=cosfac2*xx
6544        sinfac2yy=sinfac2*yy
6545        do k = 1,3
6546          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))*
6547      &      vbld_inv(i+1)
6548          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))*
6549      &      vbld_inv(i)
6550          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
6551          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
6552 c         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
6553 c     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
6554 c         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
6555 c     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
6556          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
6557          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
6558          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
6559          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
6560          dZZ_Ci1(k)=0.0d0
6561          dZZ_Ci(k)=0.0d0
6562          do j=1,3
6563            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)
6564      &     *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
6565            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)
6566      &     *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
6567          enddo
6568
6569          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
6570          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
6571          dZZ_XYZ(k)=vbld_inv(i+nres)*
6572      &   (z_prime(k)-zz*dC_norm(k,i+nres))
6573 c
6574          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
6575          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
6576        enddo
6577
6578        do k=1,3
6579          dXX_Ctab(k,i)=dXX_Ci(k)
6580          dXX_C1tab(k,i)=dXX_Ci1(k)
6581          dYY_Ctab(k,i)=dYY_Ci(k)
6582          dYY_C1tab(k,i)=dYY_Ci1(k)
6583          dZZ_Ctab(k,i)=dZZ_Ci(k)
6584          dZZ_C1tab(k,i)=dZZ_Ci1(k)
6585          dXX_XYZtab(k,i)=dXX_XYZ(k)
6586          dYY_XYZtab(k,i)=dYY_XYZ(k)
6587          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
6588        enddo
6589
6590        do k = 1,3
6591 c         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
6592 c     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
6593 c         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
6594 c     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
6595 c         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
6596 c     &    dt_dci(k)
6597 c         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
6598 c     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
6599          gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k)
6600      &    +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
6601          gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k)
6602      &    +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
6603          gsclocx(k,i)=                 de_dxx*dxx_XYZ(k)
6604      &    +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
6605        enddo
6606 c       write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
6607 c     &  (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
6608
6609 C to check gradient call subroutine check_grad
6610
6611     1 continue
6612       enddo
6613       return
6614       end
6615 c------------------------------------------------------------------------------
6616       double precision function enesc(x,xx,yy,zz,cost2,sint2)
6617       implicit none
6618       double precision x(65),xx,yy,zz,cost2,sint2,sumene1,sumene2,
6619      & sumene3,sumene4,sumene,dsc_i,dp2_i,dscp1,dscp2,s1,s1_6,s2,s2_6
6620       sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
6621      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
6622      &   + x(10)*yy*zz
6623       sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
6624      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
6625      & + x(20)*yy*zz
6626       sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
6627      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
6628      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
6629      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
6630      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
6631      &  +x(40)*xx*yy*zz
6632       sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
6633      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
6634      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
6635      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
6636      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
6637      &  +x(60)*xx*yy*zz
6638       dsc_i   = 0.743d0+x(61)
6639       dp2_i   = 1.9d0+x(62)
6640       dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
6641      &          *(xx*cost2+yy*sint2))
6642       dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
6643      &          *(xx*cost2-yy*sint2))
6644       s1=(1+x(63))/(0.1d0 + dscp1)
6645       s1_6=(1+x(64))/(0.1d0 + dscp1**6)
6646       s2=(1+x(65))/(0.1d0 + dscp2)
6647       s2_6=(1+x(65))/(0.1d0 + dscp2**6)
6648       sumene = ( sumene3*sint2 + sumene1)*(s1+s1_6)
6649      & + (sumene4*cost2 +sumene2)*(s2+s2_6)
6650       enesc=sumene
6651       return
6652       end
6653 #endif
6654 c------------------------------------------------------------------------------
6655       subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
6656 C
6657 C This procedure calculates two-body contact function g(rij) and its derivative:
6658 C
6659 C           eps0ij                                     !       x < -1
6660 C g(rij) =  esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5)  ! -1 =< x =< 1
6661 C            0                                         !       x > 1
6662 C
6663 C where x=(rij-r0ij)/delta
6664 C
6665 C rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
6666 C
6667       implicit none
6668       double precision rij,r0ij,eps0ij,fcont,fprimcont
6669       double precision x,x2,x4,delta
6670 c     delta=0.02D0*r0ij
6671 c      delta=0.2D0*r0ij
6672       x=(rij-r0ij)/delta
6673       if (x.lt.-1.0D0) then
6674         fcont=eps0ij
6675         fprimcont=0.0D0
6676       else if (x.le.1.0D0) then
6677         x2=x*x
6678         x4=x2*x2
6679         fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
6680         fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
6681       else
6682         fcont=0.0D0
6683         fprimcont=0.0D0
6684       endif
6685       return
6686       end
6687 c------------------------------------------------------------------------------
6688       subroutine splinthet(theti,delta,ss,ssder)
6689       implicit real*8 (a-h,o-z)
6690       include 'DIMENSIONS'
6691       include 'COMMON.VAR'
6692       include 'COMMON.GEO'
6693       thetup=pi-delta
6694       thetlow=delta
6695       if (theti.gt.pipol) then
6696         call gcont(theti,thetup,1.0d0,delta,ss,ssder)
6697       else
6698         call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
6699         ssder=-ssder
6700       endif
6701       return
6702       end
6703 c------------------------------------------------------------------------------
6704       subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
6705       implicit none
6706       double precision x,x0,delta,f0,f1,fprim0,f,fprim
6707       double precision ksi,ksi2,ksi3,a1,a2,a3
6708       a1=fprim0*delta/(f1-f0)
6709       a2=3.0d0-2.0d0*a1
6710       a3=a1-2.0d0
6711       ksi=(x-x0)/delta
6712       ksi2=ksi*ksi
6713       ksi3=ksi2*ksi
6714       f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
6715       fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
6716       return
6717       end
6718 c------------------------------------------------------------------------------
6719       subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
6720       implicit none
6721       double precision x,x0,delta,f0x,f1x,fprim0x,fx
6722       double precision ksi,ksi2,ksi3,a1,a2,a3
6723       ksi=(x-x0)/delta
6724       ksi2=ksi*ksi
6725       ksi3=ksi2*ksi
6726       a1=fprim0x*delta
6727       a2=3*(f1x-f0x)-2*fprim0x*delta
6728       a3=fprim0x*delta-2*(f1x-f0x)
6729       fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
6730       return
6731       end
6732 C-----------------------------------------------------------------------------
6733 #ifdef CRYST_TOR
6734 C-----------------------------------------------------------------------------
6735       subroutine etor(etors,edihcnstr)
6736       implicit real*8 (a-h,o-z)
6737       include 'DIMENSIONS'
6738       include 'COMMON.VAR'
6739       include 'COMMON.GEO'
6740       include 'COMMON.LOCAL'
6741       include 'COMMON.TORSION'
6742       include 'COMMON.INTERACT'
6743       include 'COMMON.DERIV'
6744       include 'COMMON.CHAIN'
6745       include 'COMMON.NAMES'
6746       include 'COMMON.IOUNITS'
6747       include 'COMMON.FFIELD'
6748       include 'COMMON.TORCNSTR'
6749       include 'COMMON.CONTROL'
6750       logical lprn
6751 C Set lprn=.true. for debugging
6752       lprn=.false.
6753 c      lprn=.true.
6754       etors=0.0D0
6755       do i=iphi_start,iphi_end
6756       etors_ii=0.0D0
6757         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
6758      &      .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
6759         itori=itortyp(itype(i-2))
6760         itori1=itortyp(itype(i-1))
6761         phii=phi(i)
6762         gloci=0.0D0
6763 C Proline-Proline pair is a special case...
6764         if (itori.eq.3 .and. itori1.eq.3) then
6765           if (phii.gt.-dwapi3) then
6766             cosphi=dcos(3*phii)
6767             fac=1.0D0/(1.0D0-cosphi)
6768             etorsi=v1(1,3,3)*fac
6769             etorsi=etorsi+etorsi
6770             etors=etors+etorsi-v1(1,3,3)
6771             if (energy_dec) etors_ii=etors_ii+etorsi-v1(1,3,3)
6772             gloci=gloci-3*fac*etorsi*dsin(3*phii)
6773           endif
6774           do j=1,3
6775             v1ij=v1(j+1,itori,itori1)
6776             v2ij=v2(j+1,itori,itori1)
6777             cosphi=dcos(j*phii)
6778             sinphi=dsin(j*phii)
6779             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
6780             if (energy_dec) etors_ii=etors_ii+
6781      &                              v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
6782             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
6783           enddo
6784         else
6785           do j=1,nterm_old
6786             v1ij=v1(j,itori,itori1)
6787             v2ij=v2(j,itori,itori1)
6788             cosphi=dcos(j*phii)
6789             sinphi=dsin(j*phii)
6790             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
6791             if (energy_dec) etors_ii=etors_ii+
6792      &                  v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
6793             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
6794           enddo
6795         endif
6796         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
6797              'etor',i,etors_ii
6798         if (lprn)
6799      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
6800      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
6801      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
6802         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
6803 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
6804       enddo
6805 ! 6/20/98 - dihedral angle constraints
6806       edihcnstr=0.0d0
6807       do i=1,ndih_constr
6808         itori=idih_constr(i)
6809         phii=phi(itori)
6810         difi=phii-phi0(i)
6811         if (difi.gt.drange(i)) then
6812           difi=difi-drange(i)
6813           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
6814           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
6815         else if (difi.lt.-drange(i)) then
6816           difi=difi+drange(i)
6817           edihcnstr=edihcnstr+0.25d0*ftors(i)**difi**4
6818           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
6819         endif
6820 !        write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii,
6821 !     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
6822       enddo
6823 !      write (iout,*) 'edihcnstr',edihcnstr
6824       return
6825       end
6826 c------------------------------------------------------------------------------
6827       subroutine etor_d(etors_d)
6828       etors_d=0.0d0
6829       return
6830       end
6831 c----------------------------------------------------------------------------
6832 #else
6833       subroutine etor(etors,edihcnstr)
6834       implicit real*8 (a-h,o-z)
6835       include 'DIMENSIONS'
6836       include 'COMMON.VAR'
6837       include 'COMMON.GEO'
6838       include 'COMMON.LOCAL'
6839       include 'COMMON.TORSION'
6840       include 'COMMON.INTERACT'
6841       include 'COMMON.DERIV'
6842       include 'COMMON.CHAIN'
6843       include 'COMMON.NAMES'
6844       include 'COMMON.IOUNITS'
6845       include 'COMMON.FFIELD'
6846       include 'COMMON.TORCNSTR'
6847       include 'COMMON.CONTROL'
6848       logical lprn
6849 C Set lprn=.true. for debugging
6850       lprn=.false.
6851 c     lprn=.true.
6852       etors=0.0D0
6853       do i=iphi_start,iphi_end
6854 C ANY TWO ARE DUMMY ATOMS in row CYCLE
6855 c        if (((itype(i-3).eq.ntyp1).and.(itype(i-2).eq.ntyp1)).or.
6856 c     &      ((itype(i-2).eq.ntyp1).and.(itype(i-1).eq.ntyp1))  .or.
6857 c     &      ((itype(i-1).eq.ntyp1).and.(itype(i).eq.ntyp1))) cycle
6858         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
6859      &      .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
6860 C In current verion the ALL DUMMY ATOM POTENTIALS ARE OFF
6861 C For introducing the NH3+ and COO- group please check the etor_d for reference
6862 C and guidance
6863         etors_ii=0.0D0
6864          if (iabs(itype(i)).eq.20) then
6865          iblock=2
6866          else
6867          iblock=1
6868          endif
6869         itori=itortyp(itype(i-2))
6870         itori1=itortyp(itype(i-1))
6871         phii=phi(i)
6872         gloci=0.0D0
6873 C Regular cosine and sine terms
6874         do j=1,nterm(itori,itori1,iblock)
6875           v1ij=v1(j,itori,itori1,iblock)
6876           v2ij=v2(j,itori,itori1,iblock)
6877           cosphi=dcos(j*phii)
6878           sinphi=dsin(j*phii)
6879           etors=etors+v1ij*cosphi+v2ij*sinphi
6880           if (energy_dec) etors_ii=etors_ii+
6881      &                v1ij*cosphi+v2ij*sinphi
6882           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
6883         enddo
6884 C Lorentz terms
6885 C                         v1
6886 C  E = SUM ----------------------------------- - v1
6887 C          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
6888 C
6889         cosphi=dcos(0.5d0*phii)
6890         sinphi=dsin(0.5d0*phii)
6891         do j=1,nlor(itori,itori1,iblock)
6892           vl1ij=vlor1(j,itori,itori1)
6893           vl2ij=vlor2(j,itori,itori1)
6894           vl3ij=vlor3(j,itori,itori1)
6895           pom=vl2ij*cosphi+vl3ij*sinphi
6896           pom1=1.0d0/(pom*pom+1.0d0)
6897           etors=etors+vl1ij*pom1
6898           if (energy_dec) etors_ii=etors_ii+
6899      &                vl1ij*pom1
6900           pom=-pom*pom1*pom1
6901           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
6902         enddo
6903 C Subtract the constant term
6904         etors=etors-v0(itori,itori1,iblock)
6905           if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
6906      &         'etor',i,etors_ii-v0(itori,itori1,iblock)
6907         if (lprn)
6908      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
6909      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
6910      &  (v1(j,itori,itori1,iblock),j=1,6),
6911      &  (v2(j,itori,itori1,iblock),j=1,6)
6912         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
6913 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
6914       enddo
6915 ! 6/20/98 - dihedral angle constraints
6916       edihcnstr=0.0d0
6917 c      do i=1,ndih_constr
6918       do i=idihconstr_start,idihconstr_end
6919         itori=idih_constr(i)
6920         phii=phi(itori)
6921         difi=pinorm(phii-phi0(i))
6922         if (difi.gt.drange(i)) then
6923           difi=difi-drange(i)
6924           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
6925           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
6926         else if (difi.lt.-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
6931           difi=0.0
6932         endif
6933        if (energy_dec) then
6934         write (iout,'(a6,2i5,4f8.3,2e14.5)') "edihc",
6935      &    i,itori,rad2deg*phii,
6936      &    rad2deg*phi0(i),  rad2deg*drange(i),
6937      &    rad2deg*difi,0.25d0*ftors(i)*difi**4,gloc(itori-3,icg)
6938         endif
6939       enddo
6940 cd       write (iout,*) 'edihcnstr',edihcnstr
6941       return
6942       end
6943 c----------------------------------------------------------------------------
6944       subroutine etor_d(etors_d)
6945 C 6/23/01 Compute double torsional energy
6946       implicit real*8 (a-h,o-z)
6947       include 'DIMENSIONS'
6948       include 'COMMON.VAR'
6949       include 'COMMON.GEO'
6950       include 'COMMON.LOCAL'
6951       include 'COMMON.TORSION'
6952       include 'COMMON.INTERACT'
6953       include 'COMMON.DERIV'
6954       include 'COMMON.CHAIN'
6955       include 'COMMON.NAMES'
6956       include 'COMMON.IOUNITS'
6957       include 'COMMON.FFIELD'
6958       include 'COMMON.TORCNSTR'
6959       logical lprn
6960 C Set lprn=.true. for debugging
6961       lprn=.false.
6962 c     lprn=.true.
6963       etors_d=0.0D0
6964 c      write(iout,*) "a tu??"
6965       do i=iphid_start,iphid_end
6966 C ANY TWO ARE DUMMY ATOMS in row CYCLE
6967 C        if (((itype(i-3).eq.ntyp1).and.(itype(i-2).eq.ntyp1)).or.
6968 C     &      ((itype(i-2).eq.ntyp1).and.(itype(i-1).eq.ntyp1)).or.
6969 C     &      ((itype(i-1).eq.ntyp1).and.(itype(i).eq.ntyp1))  .or.
6970 C     &      ((itype(i).eq.ntyp1).and.(itype(i+1).eq.ntyp1))) cycle
6971          if ((itype(i-2).eq.ntyp1).or.itype(i-3).eq.ntyp1.or.
6972      &  (itype(i-1).eq.ntyp1).or.(itype(i).eq.ntyp1).or.
6973      &  (itype(i+1).eq.ntyp1)) cycle
6974 C In current verion the ALL DUMMY ATOM POTENTIALS ARE OFF
6975         itori=itortyp(itype(i-2))
6976         itori1=itortyp(itype(i-1))
6977         itori2=itortyp(itype(i))
6978         phii=phi(i)
6979         phii1=phi(i+1)
6980         gloci1=0.0D0
6981         gloci2=0.0D0
6982         iblock=1
6983         if (iabs(itype(i+1)).eq.20) iblock=2
6984 C Iblock=2 Proline type
6985 C ADASKO: WHEN PARAMETERS FOR THIS TYPE OF BLOCKING GROUP IS READY UNCOMMENT
6986 C CHECK WEATHER THERE IS NECCESITY FOR iblock=3 for COO-
6987 C        if (itype(i+1).eq.ntyp1) iblock=3
6988 C The problem of NH3+ group can be resolved by adding new parameters please note if there
6989 C IS or IS NOT need for this
6990 C IF Yes uncomment below and add to parmread.F appropriate changes and to v1cij and so on
6991 C        is (itype(i-3).eq.ntyp1) ntblock=2
6992 C        ntblock is N-terminal blocking group
6993
6994 C Regular cosine and sine terms
6995         do j=1,ntermd_1(itori,itori1,itori2,iblock)
6996 C Example of changes for NH3+ blocking group
6997 C       do j=1,ntermd_1(itori,itori1,itori2,iblock,ntblock)
6998 C          v1cij=v1c(1,j,itori,itori1,itori2,iblock,ntblock)
6999           v1cij=v1c(1,j,itori,itori1,itori2,iblock)
7000           v1sij=v1s(1,j,itori,itori1,itori2,iblock)
7001           v2cij=v1c(2,j,itori,itori1,itori2,iblock)
7002           v2sij=v1s(2,j,itori,itori1,itori2,iblock)
7003           cosphi1=dcos(j*phii)
7004           sinphi1=dsin(j*phii)
7005           cosphi2=dcos(j*phii1)
7006           sinphi2=dsin(j*phii1)
7007           etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+
7008      &     v2cij*cosphi2+v2sij*sinphi2
7009           gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
7010           gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
7011         enddo
7012         do k=2,ntermd_2(itori,itori1,itori2,iblock)
7013           do l=1,k-1
7014             v1cdij = v2c(k,l,itori,itori1,itori2,iblock)
7015             v2cdij = v2c(l,k,itori,itori1,itori2,iblock)
7016             v1sdij = v2s(k,l,itori,itori1,itori2,iblock)
7017             v2sdij = v2s(l,k,itori,itori1,itori2,iblock)
7018             cosphi1p2=dcos(l*phii+(k-l)*phii1)
7019             cosphi1m2=dcos(l*phii-(k-l)*phii1)
7020             sinphi1p2=dsin(l*phii+(k-l)*phii1)
7021             sinphi1m2=dsin(l*phii-(k-l)*phii1)
7022             etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+
7023      &        v1sdij*sinphi1p2+v2sdij*sinphi1m2
7024             gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2
7025      &        -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
7026             gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2
7027      &        -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
7028           enddo
7029         enddo
7030         gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*gloci1
7031         gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*gloci2
7032       enddo
7033       return
7034       end
7035 #endif
7036 c------------------------------------------------------------------------------
7037       subroutine eback_sc_corr(esccor)
7038 c 7/21/2007 Correlations between the backbone-local and side-chain-local
7039 c        conformational states; temporarily implemented as differences
7040 c        between UNRES torsional potentials (dependent on three types of
7041 c        residues) and the torsional potentials dependent on all 20 types
7042 c        of residues computed from AM1  energy surfaces of terminally-blocked
7043 c        amino-acid residues.
7044       implicit real*8 (a-h,o-z)
7045       include 'DIMENSIONS'
7046       include 'COMMON.VAR'
7047       include 'COMMON.GEO'
7048       include 'COMMON.LOCAL'
7049       include 'COMMON.TORSION'
7050       include 'COMMON.SCCOR'
7051       include 'COMMON.INTERACT'
7052       include 'COMMON.DERIV'
7053       include 'COMMON.CHAIN'
7054       include 'COMMON.NAMES'
7055       include 'COMMON.IOUNITS'
7056       include 'COMMON.FFIELD'
7057       include 'COMMON.CONTROL'
7058       logical lprn
7059 C Set lprn=.true. for debugging
7060       lprn=.false.
7061 c      lprn=.true.
7062 c      write (iout,*) "EBACK_SC_COR",itau_start,itau_end
7063       esccor=0.0D0
7064       do i=itau_start,itau_end
7065         if ((itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)) cycle
7066         esccor_ii=0.0D0
7067         isccori=isccortyp(itype(i-2))
7068         isccori1=isccortyp(itype(i-1))
7069 c      write (iout,*) "EBACK_SC_COR",i,nterm_sccor(isccori,isccori1)
7070         phii=phi(i)
7071         do intertyp=1,3 !intertyp
7072 cc Added 09 May 2012 (Adasko)
7073 cc  Intertyp means interaction type of backbone mainchain correlation:
7074 c   1 = SC...Ca...Ca...Ca
7075 c   2 = Ca...Ca...Ca...SC
7076 c   3 = SC...Ca...Ca...SCi
7077         gloci=0.0D0
7078         if (((intertyp.eq.3).and.((itype(i-2).eq.10).or.
7079      &      (itype(i-1).eq.10).or.(itype(i-2).eq.ntyp1).or.
7080      &      (itype(i-1).eq.ntyp1)))
7081      &    .or. ((intertyp.eq.1).and.((itype(i-2).eq.10)
7082      &     .or.(itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)
7083      &     .or.(itype(i).eq.ntyp1)))
7084      &    .or.((intertyp.eq.2).and.((itype(i-1).eq.10).or.
7085      &      (itype(i-1).eq.ntyp1).or.(itype(i-2).eq.ntyp1).or.
7086      &      (itype(i-3).eq.ntyp1)))) cycle
7087         if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1).eq.ntyp1)) cycle
7088         if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres).eq.ntyp1))
7089      & cycle
7090        do j=1,nterm_sccor(isccori,isccori1)
7091           v1ij=v1sccor(j,intertyp,isccori,isccori1)
7092           v2ij=v2sccor(j,intertyp,isccori,isccori1)
7093           cosphi=dcos(j*tauangle(intertyp,i))
7094           sinphi=dsin(j*tauangle(intertyp,i))
7095           esccor=esccor+v1ij*cosphi+v2ij*sinphi
7096           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7097         enddo
7098 c      write (iout,*) "EBACK_SC_COR",i,v1ij*cosphi+v2ij*sinphi,intertyp
7099         gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci
7100         if (lprn)
7101      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
7102      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,isccori,isccori1,
7103      &  (v1sccor(j,intertyp,isccori,isccori1),j=1,6)
7104      & ,(v2sccor(j,intertyp,isccori,isccori1),j=1,6)
7105         gsccor_loc(i-3)=gsccor_loc(i-3)+gloci
7106        enddo !intertyp
7107       enddo
7108
7109       return
7110       end
7111 c----------------------------------------------------------------------------
7112       subroutine multibody(ecorr)
7113 C This subroutine calculates multi-body contributions to energy following
7114 C the idea of Skolnick et al. If side chains I and J make a contact and
7115 C at the same time side chains I+1 and J+1 make a contact, an extra
7116 C contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
7117       implicit real*8 (a-h,o-z)
7118       include 'DIMENSIONS'
7119       include 'COMMON.IOUNITS'
7120       include 'COMMON.DERIV'
7121       include 'COMMON.INTERACT'
7122       include 'COMMON.CONTACTS'
7123       double precision gx(3),gx1(3)
7124       logical lprn
7125
7126 C Set lprn=.true. for debugging
7127       lprn=.false.
7128
7129       if (lprn) then
7130         write (iout,'(a)') 'Contact function values:'
7131         do i=nnt,nct-2
7132           write (iout,'(i2,20(1x,i2,f10.5))')
7133      &        i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
7134         enddo
7135       endif
7136       ecorr=0.0D0
7137       do i=nnt,nct
7138         do j=1,3
7139           gradcorr(j,i)=0.0D0
7140           gradxorr(j,i)=0.0D0
7141         enddo
7142       enddo
7143       do i=nnt,nct-2
7144
7145         DO ISHIFT = 3,4
7146
7147         i1=i+ishift
7148         num_conti=num_cont(i)
7149         num_conti1=num_cont(i1)
7150         do jj=1,num_conti
7151           j=jcont(jj,i)
7152           do kk=1,num_conti1
7153             j1=jcont(kk,i1)
7154             if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
7155 cd          write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
7156 cd   &                   ' ishift=',ishift
7157 C Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
7158 C The system gains extra energy.
7159               ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
7160             endif   ! j1==j+-ishift
7161           enddo     ! kk
7162         enddo       ! jj
7163
7164         ENDDO ! ISHIFT
7165
7166       enddo         ! i
7167       return
7168       end
7169 c------------------------------------------------------------------------------
7170       double precision function esccorr(i,j,k,l,jj,kk)
7171       implicit real*8 (a-h,o-z)
7172       include 'DIMENSIONS'
7173       include 'COMMON.IOUNITS'
7174       include 'COMMON.DERIV'
7175       include 'COMMON.INTERACT'
7176       include 'COMMON.CONTACTS'
7177       double precision gx(3),gx1(3)
7178       logical lprn
7179       lprn=.false.
7180       eij=facont(jj,i)
7181       ekl=facont(kk,k)
7182 cd    write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
7183 C Calculate the multi-body contribution to energy.
7184 C Calculate multi-body contributions to the gradient.
7185 cd    write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
7186 cd   & k,l,(gacont(m,kk,k),m=1,3)
7187       do m=1,3
7188         gx(m) =ekl*gacont(m,jj,i)
7189         gx1(m)=eij*gacont(m,kk,k)
7190         gradxorr(m,i)=gradxorr(m,i)-gx(m)
7191         gradxorr(m,j)=gradxorr(m,j)+gx(m)
7192         gradxorr(m,k)=gradxorr(m,k)-gx1(m)
7193         gradxorr(m,l)=gradxorr(m,l)+gx1(m)
7194       enddo
7195       do m=i,j-1
7196         do ll=1,3
7197           gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
7198         enddo
7199       enddo
7200       do m=k,l-1
7201         do ll=1,3
7202           gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
7203         enddo
7204       enddo
7205       esccorr=-eij*ekl
7206       return
7207       end
7208 c------------------------------------------------------------------------------
7209       subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
7210 C This subroutine calculates multi-body contributions to hydrogen-bonding
7211       implicit real*8 (a-h,o-z)
7212       include 'DIMENSIONS'
7213       include 'COMMON.IOUNITS'
7214 #ifdef MPI
7215       include "mpif.h"
7216       parameter (max_cont=maxconts)
7217       parameter (max_dim=26)
7218       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
7219       double precision zapas(max_dim,maxconts,max_fg_procs),
7220      &  zapas_recv(max_dim,maxconts,max_fg_procs)
7221       common /przechowalnia/ zapas
7222       integer status(MPI_STATUS_SIZE),req(maxconts*2),
7223      &  status_array(MPI_STATUS_SIZE,maxconts*2)
7224 #endif
7225       include 'COMMON.SETUP'
7226       include 'COMMON.FFIELD'
7227       include 'COMMON.DERIV'
7228       include 'COMMON.INTERACT'
7229       include 'COMMON.CONTACTS'
7230       include 'COMMON.CONTROL'
7231       include 'COMMON.LOCAL'
7232       double precision gx(3),gx1(3),time00
7233       logical lprn,ldone
7234
7235 C Set lprn=.true. for debugging
7236       lprn=.false.
7237 #ifdef MPI
7238       n_corr=0
7239       n_corr1=0
7240       if (nfgtasks.le.1) goto 30
7241       if (lprn) then
7242         write (iout,'(a)') 'Contact function values before RECEIVE:'
7243         do i=nnt,nct-2
7244           write (iout,'(2i3,50(1x,i2,f5.2))')
7245      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
7246      &    j=1,num_cont_hb(i))
7247         enddo
7248       endif
7249       call flush(iout)
7250       do i=1,ntask_cont_from
7251         ncont_recv(i)=0
7252       enddo
7253       do i=1,ntask_cont_to
7254         ncont_sent(i)=0
7255       enddo
7256 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
7257 c     & ntask_cont_to
7258 C Make the list of contacts to send to send to other procesors
7259 c      write (iout,*) "limits",max0(iturn4_end-1,iatel_s),iturn3_end
7260 c      call flush(iout)
7261       do i=iturn3_start,iturn3_end
7262 c        write (iout,*) "make contact list turn3",i," num_cont",
7263 c     &    num_cont_hb(i)
7264         call add_hb_contact(i,i+2,iturn3_sent_local(1,i))
7265       enddo
7266       do i=iturn4_start,iturn4_end
7267 c        write (iout,*) "make contact list turn4",i," num_cont",
7268 c     &   num_cont_hb(i)
7269         call add_hb_contact(i,i+3,iturn4_sent_local(1,i))
7270       enddo
7271       do ii=1,nat_sent
7272         i=iat_sent(ii)
7273 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
7274 c     &    num_cont_hb(i)
7275         do j=1,num_cont_hb(i)
7276         do k=1,4
7277           jjc=jcont_hb(j,i)
7278           iproc=iint_sent_local(k,jjc,ii)
7279 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
7280           if (iproc.gt.0) then
7281             ncont_sent(iproc)=ncont_sent(iproc)+1
7282             nn=ncont_sent(iproc)
7283             zapas(1,nn,iproc)=i
7284             zapas(2,nn,iproc)=jjc
7285             zapas(3,nn,iproc)=facont_hb(j,i)
7286             zapas(4,nn,iproc)=ees0p(j,i)
7287             zapas(5,nn,iproc)=ees0m(j,i)
7288             zapas(6,nn,iproc)=gacont_hbr(1,j,i)
7289             zapas(7,nn,iproc)=gacont_hbr(2,j,i)
7290             zapas(8,nn,iproc)=gacont_hbr(3,j,i)
7291             zapas(9,nn,iproc)=gacontm_hb1(1,j,i)
7292             zapas(10,nn,iproc)=gacontm_hb1(2,j,i)
7293             zapas(11,nn,iproc)=gacontm_hb1(3,j,i)
7294             zapas(12,nn,iproc)=gacontp_hb1(1,j,i)
7295             zapas(13,nn,iproc)=gacontp_hb1(2,j,i)
7296             zapas(14,nn,iproc)=gacontp_hb1(3,j,i)
7297             zapas(15,nn,iproc)=gacontm_hb2(1,j,i)
7298             zapas(16,nn,iproc)=gacontm_hb2(2,j,i)
7299             zapas(17,nn,iproc)=gacontm_hb2(3,j,i)
7300             zapas(18,nn,iproc)=gacontp_hb2(1,j,i)
7301             zapas(19,nn,iproc)=gacontp_hb2(2,j,i)
7302             zapas(20,nn,iproc)=gacontp_hb2(3,j,i)
7303             zapas(21,nn,iproc)=gacontm_hb3(1,j,i)
7304             zapas(22,nn,iproc)=gacontm_hb3(2,j,i)
7305             zapas(23,nn,iproc)=gacontm_hb3(3,j,i)
7306             zapas(24,nn,iproc)=gacontp_hb3(1,j,i)
7307             zapas(25,nn,iproc)=gacontp_hb3(2,j,i)
7308             zapas(26,nn,iproc)=gacontp_hb3(3,j,i)
7309           endif
7310         enddo
7311         enddo
7312       enddo
7313       if (lprn) then
7314       write (iout,*)
7315      &  "Numbers of contacts to be sent to other processors",
7316      &  (ncont_sent(i),i=1,ntask_cont_to)
7317       write (iout,*) "Contacts sent"
7318       do ii=1,ntask_cont_to
7319         nn=ncont_sent(ii)
7320         iproc=itask_cont_to(ii)
7321         write (iout,*) nn," contacts to processor",iproc,
7322      &   " of CONT_TO_COMM group"
7323         do i=1,nn
7324           write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
7325         enddo
7326       enddo
7327       call flush(iout)
7328       endif
7329       CorrelType=477
7330       CorrelID=fg_rank+1
7331       CorrelType1=478
7332       CorrelID1=nfgtasks+fg_rank+1
7333       ireq=0
7334 C Receive the numbers of needed contacts from other processors
7335       do ii=1,ntask_cont_from
7336         iproc=itask_cont_from(ii)
7337         ireq=ireq+1
7338         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
7339      &    FG_COMM,req(ireq),IERR)
7340       enddo
7341 c      write (iout,*) "IRECV ended"
7342 c      call flush(iout)
7343 C Send the number of contacts needed by other processors
7344       do ii=1,ntask_cont_to
7345         iproc=itask_cont_to(ii)
7346         ireq=ireq+1
7347         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
7348      &    FG_COMM,req(ireq),IERR)
7349       enddo
7350 c      write (iout,*) "ISEND ended"
7351 c      write (iout,*) "number of requests (nn)",ireq
7352       call flush(iout)
7353       if (ireq.gt.0)
7354      &  call MPI_Waitall(ireq,req,status_array,ierr)
7355 c      write (iout,*)
7356 c     &  "Numbers of contacts to be received from other processors",
7357 c     &  (ncont_recv(i),i=1,ntask_cont_from)
7358 c      call flush(iout)
7359 C Receive contacts
7360       ireq=0
7361       do ii=1,ntask_cont_from
7362         iproc=itask_cont_from(ii)
7363         nn=ncont_recv(ii)
7364 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
7365 c     &   " of CONT_TO_COMM group"
7366         call flush(iout)
7367         if (nn.gt.0) then
7368           ireq=ireq+1
7369           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
7370      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
7371 c          write (iout,*) "ireq,req",ireq,req(ireq)
7372         endif
7373       enddo
7374 C Send the contacts to processors that need them
7375       do ii=1,ntask_cont_to
7376         iproc=itask_cont_to(ii)
7377         nn=ncont_sent(ii)
7378 c        write (iout,*) nn," contacts to processor",iproc,
7379 c     &   " of CONT_TO_COMM group"
7380         if (nn.gt.0) then
7381           ireq=ireq+1
7382           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
7383      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
7384 c          write (iout,*) "ireq,req",ireq,req(ireq)
7385 c          do i=1,nn
7386 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
7387 c          enddo
7388         endif
7389       enddo
7390 c      write (iout,*) "number of requests (contacts)",ireq
7391 c      write (iout,*) "req",(req(i),i=1,4)
7392 c      call flush(iout)
7393       if (ireq.gt.0)
7394      & call MPI_Waitall(ireq,req,status_array,ierr)
7395       do iii=1,ntask_cont_from
7396         iproc=itask_cont_from(iii)
7397         nn=ncont_recv(iii)
7398         if (lprn) then
7399         write (iout,*) "Received",nn," contacts from processor",iproc,
7400      &   " of CONT_FROM_COMM group"
7401         call flush(iout)
7402         do i=1,nn
7403           write(iout,'(2f5.0,4f10.5)')(zapas_recv(j,i,iii),j=1,5)
7404         enddo
7405         call flush(iout)
7406         endif
7407         do i=1,nn
7408           ii=zapas_recv(1,i,iii)
7409 c Flag the received contacts to prevent double-counting
7410           jj=-zapas_recv(2,i,iii)
7411 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
7412 c          call flush(iout)
7413           nnn=num_cont_hb(ii)+1
7414           num_cont_hb(ii)=nnn
7415           jcont_hb(nnn,ii)=jj
7416           facont_hb(nnn,ii)=zapas_recv(3,i,iii)
7417           ees0p(nnn,ii)=zapas_recv(4,i,iii)
7418           ees0m(nnn,ii)=zapas_recv(5,i,iii)
7419           gacont_hbr(1,nnn,ii)=zapas_recv(6,i,iii)
7420           gacont_hbr(2,nnn,ii)=zapas_recv(7,i,iii)
7421           gacont_hbr(3,nnn,ii)=zapas_recv(8,i,iii)
7422           gacontm_hb1(1,nnn,ii)=zapas_recv(9,i,iii)
7423           gacontm_hb1(2,nnn,ii)=zapas_recv(10,i,iii)
7424           gacontm_hb1(3,nnn,ii)=zapas_recv(11,i,iii)
7425           gacontp_hb1(1,nnn,ii)=zapas_recv(12,i,iii)
7426           gacontp_hb1(2,nnn,ii)=zapas_recv(13,i,iii)
7427           gacontp_hb1(3,nnn,ii)=zapas_recv(14,i,iii)
7428           gacontm_hb2(1,nnn,ii)=zapas_recv(15,i,iii)
7429           gacontm_hb2(2,nnn,ii)=zapas_recv(16,i,iii)
7430           gacontm_hb2(3,nnn,ii)=zapas_recv(17,i,iii)
7431           gacontp_hb2(1,nnn,ii)=zapas_recv(18,i,iii)
7432           gacontp_hb2(2,nnn,ii)=zapas_recv(19,i,iii)
7433           gacontp_hb2(3,nnn,ii)=zapas_recv(20,i,iii)
7434           gacontm_hb3(1,nnn,ii)=zapas_recv(21,i,iii)
7435           gacontm_hb3(2,nnn,ii)=zapas_recv(22,i,iii)
7436           gacontm_hb3(3,nnn,ii)=zapas_recv(23,i,iii)
7437           gacontp_hb3(1,nnn,ii)=zapas_recv(24,i,iii)
7438           gacontp_hb3(2,nnn,ii)=zapas_recv(25,i,iii)
7439           gacontp_hb3(3,nnn,ii)=zapas_recv(26,i,iii)
7440         enddo
7441       enddo
7442       call flush(iout)
7443       if (lprn) then
7444         write (iout,'(a)') 'Contact function values after receive:'
7445         do i=nnt,nct-2
7446           write (iout,'(2i3,50(1x,i3,f5.2))')
7447      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
7448      &    j=1,num_cont_hb(i))
7449         enddo
7450         call flush(iout)
7451       endif
7452    30 continue
7453 #endif
7454       if (lprn) then
7455         write (iout,'(a)') 'Contact function values:'
7456         do i=nnt,nct-2
7457           write (iout,'(2i3,50(1x,i3,f5.2))')
7458      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
7459      &    j=1,num_cont_hb(i))
7460         enddo
7461       endif
7462       ecorr=0.0D0
7463 C Remove the loop below after debugging !!!
7464       do i=nnt,nct
7465         do j=1,3
7466           gradcorr(j,i)=0.0D0
7467           gradxorr(j,i)=0.0D0
7468         enddo
7469       enddo
7470 C Calculate the local-electrostatic correlation terms
7471       do i=min0(iatel_s,iturn4_start),max0(iatel_e,iturn3_end)
7472         i1=i+1
7473         num_conti=num_cont_hb(i)
7474         num_conti1=num_cont_hb(i+1)
7475         do jj=1,num_conti
7476           j=jcont_hb(jj,i)
7477           jp=iabs(j)
7478           do kk=1,num_conti1
7479             j1=jcont_hb(kk,i1)
7480             jp1=iabs(j1)
7481 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
7482 c     &         ' jj=',jj,' kk=',kk
7483             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
7484      &          .or. j.lt.0 .and. j1.gt.0) .and.
7485      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
7486 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
7487 C The system gains extra energy.
7488               ecorr=ecorr+ehbcorr(i,jp,i+1,jp1,jj,kk,0.72D0,0.32D0)
7489               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
7490      &            'ecorrh',i,j,ehbcorr(i,j,i+1,j1,jj,kk,0.72D0,0.32D0)
7491               n_corr=n_corr+1
7492             else if (j1.eq.j) then
7493 C Contacts I-J and I-(J+1) occur simultaneously.
7494 C The system loses extra energy.
7495 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
7496             endif
7497           enddo ! kk
7498           do kk=1,num_conti
7499             j1=jcont_hb(kk,i)
7500 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
7501 c    &         ' jj=',jj,' kk=',kk
7502             if (j1.eq.j+1) then
7503 C Contacts I-J and (I+1)-J occur simultaneously.
7504 C The system loses extra energy.
7505 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
7506             endif ! j1==j+1
7507           enddo ! kk
7508         enddo ! jj
7509       enddo ! i
7510       return
7511       end
7512 c------------------------------------------------------------------------------
7513       subroutine add_hb_contact(ii,jj,itask)
7514       implicit real*8 (a-h,o-z)
7515       include "DIMENSIONS"
7516       include "COMMON.IOUNITS"
7517       integer max_cont
7518       integer max_dim
7519       parameter (max_cont=maxconts)
7520       parameter (max_dim=26)
7521       include "COMMON.CONTACTS"
7522       double precision zapas(max_dim,maxconts,max_fg_procs),
7523      &  zapas_recv(max_dim,maxconts,max_fg_procs)
7524       common /przechowalnia/ zapas
7525       integer i,j,ii,jj,iproc,itask(4),nn
7526 c      write (iout,*) "itask",itask
7527       do i=1,2
7528         iproc=itask(i)
7529         if (iproc.gt.0) then
7530           do j=1,num_cont_hb(ii)
7531             jjc=jcont_hb(j,ii)
7532 c            write (iout,*) "i",ii," j",jj," jjc",jjc
7533             if (jjc.eq.jj) then
7534               ncont_sent(iproc)=ncont_sent(iproc)+1
7535               nn=ncont_sent(iproc)
7536               zapas(1,nn,iproc)=ii
7537               zapas(2,nn,iproc)=jjc
7538               zapas(3,nn,iproc)=facont_hb(j,ii)
7539               zapas(4,nn,iproc)=ees0p(j,ii)
7540               zapas(5,nn,iproc)=ees0m(j,ii)
7541               zapas(6,nn,iproc)=gacont_hbr(1,j,ii)
7542               zapas(7,nn,iproc)=gacont_hbr(2,j,ii)
7543               zapas(8,nn,iproc)=gacont_hbr(3,j,ii)
7544               zapas(9,nn,iproc)=gacontm_hb1(1,j,ii)
7545               zapas(10,nn,iproc)=gacontm_hb1(2,j,ii)
7546               zapas(11,nn,iproc)=gacontm_hb1(3,j,ii)
7547               zapas(12,nn,iproc)=gacontp_hb1(1,j,ii)
7548               zapas(13,nn,iproc)=gacontp_hb1(2,j,ii)
7549               zapas(14,nn,iproc)=gacontp_hb1(3,j,ii)
7550               zapas(15,nn,iproc)=gacontm_hb2(1,j,ii)
7551               zapas(16,nn,iproc)=gacontm_hb2(2,j,ii)
7552               zapas(17,nn,iproc)=gacontm_hb2(3,j,ii)
7553               zapas(18,nn,iproc)=gacontp_hb2(1,j,ii)
7554               zapas(19,nn,iproc)=gacontp_hb2(2,j,ii)
7555               zapas(20,nn,iproc)=gacontp_hb2(3,j,ii)
7556               zapas(21,nn,iproc)=gacontm_hb3(1,j,ii)
7557               zapas(22,nn,iproc)=gacontm_hb3(2,j,ii)
7558               zapas(23,nn,iproc)=gacontm_hb3(3,j,ii)
7559               zapas(24,nn,iproc)=gacontp_hb3(1,j,ii)
7560               zapas(25,nn,iproc)=gacontp_hb3(2,j,ii)
7561               zapas(26,nn,iproc)=gacontp_hb3(3,j,ii)
7562               exit
7563             endif
7564           enddo
7565         endif
7566       enddo
7567       return
7568       end
7569 c------------------------------------------------------------------------------
7570       subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,
7571      &  n_corr1)
7572 C This subroutine calculates multi-body contributions to hydrogen-bonding
7573       implicit real*8 (a-h,o-z)
7574       include 'DIMENSIONS'
7575       include 'COMMON.IOUNITS'
7576 #ifdef MPI
7577       include "mpif.h"
7578       parameter (max_cont=maxconts)
7579       parameter (max_dim=70)
7580       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
7581       double precision zapas(max_dim,maxconts,max_fg_procs),
7582      &  zapas_recv(max_dim,maxconts,max_fg_procs)
7583       common /przechowalnia/ zapas
7584       integer status(MPI_STATUS_SIZE),req(maxconts*2),
7585      &  status_array(MPI_STATUS_SIZE,maxconts*2)
7586 #endif
7587       include 'COMMON.SETUP'
7588       include 'COMMON.FFIELD'
7589       include 'COMMON.DERIV'
7590       include 'COMMON.LOCAL'
7591       include 'COMMON.INTERACT'
7592       include 'COMMON.CONTACTS'
7593       include 'COMMON.CHAIN'
7594       include 'COMMON.CONTROL'
7595       double precision gx(3),gx1(3)
7596       integer num_cont_hb_old(maxres)
7597       logical lprn,ldone
7598       double precision eello4,eello5,eelo6,eello_turn6
7599       external eello4,eello5,eello6,eello_turn6
7600 C Set lprn=.true. for debugging
7601       lprn=.false.
7602       eturn6=0.0d0
7603 #ifdef MPI
7604       do i=1,nres
7605         num_cont_hb_old(i)=num_cont_hb(i)
7606       enddo
7607       n_corr=0
7608       n_corr1=0
7609       if (nfgtasks.le.1) goto 30
7610       if (lprn) then
7611         write (iout,'(a)') 'Contact function values before RECEIVE:'
7612         do i=nnt,nct-2
7613           write (iout,'(2i3,50(1x,i2,f5.2))')
7614      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
7615      &    j=1,num_cont_hb(i))
7616         enddo
7617       endif
7618       call flush(iout)
7619       do i=1,ntask_cont_from
7620         ncont_recv(i)=0
7621       enddo
7622       do i=1,ntask_cont_to
7623         ncont_sent(i)=0
7624       enddo
7625 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
7626 c     & ntask_cont_to
7627 C Make the list of contacts to send to send to other procesors
7628       do i=iturn3_start,iturn3_end
7629 c        write (iout,*) "make contact list turn3",i," num_cont",
7630 c     &    num_cont_hb(i)
7631         call add_hb_contact_eello(i,i+2,iturn3_sent_local(1,i))
7632       enddo
7633       do i=iturn4_start,iturn4_end
7634 c        write (iout,*) "make contact list turn4",i," num_cont",
7635 c     &   num_cont_hb(i)
7636         call add_hb_contact_eello(i,i+3,iturn4_sent_local(1,i))
7637       enddo
7638       do ii=1,nat_sent
7639         i=iat_sent(ii)
7640 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
7641 c     &    num_cont_hb(i)
7642         do j=1,num_cont_hb(i)
7643         do k=1,4
7644           jjc=jcont_hb(j,i)
7645           iproc=iint_sent_local(k,jjc,ii)
7646 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
7647           if (iproc.ne.0) then
7648             ncont_sent(iproc)=ncont_sent(iproc)+1
7649             nn=ncont_sent(iproc)
7650             zapas(1,nn,iproc)=i
7651             zapas(2,nn,iproc)=jjc
7652             zapas(3,nn,iproc)=d_cont(j,i)
7653             ind=3
7654             do kk=1,3
7655               ind=ind+1
7656               zapas(ind,nn,iproc)=grij_hb_cont(kk,j,i)
7657             enddo
7658             do kk=1,2
7659               do ll=1,2
7660                 ind=ind+1
7661                 zapas(ind,nn,iproc)=a_chuj(ll,kk,j,i)
7662               enddo
7663             enddo
7664             do jj=1,5
7665               do kk=1,3
7666                 do ll=1,2
7667                   do mm=1,2
7668                     ind=ind+1
7669                     zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,i)
7670                   enddo
7671                 enddo
7672               enddo
7673             enddo
7674           endif
7675         enddo
7676         enddo
7677       enddo
7678       if (lprn) then
7679       write (iout,*)
7680      &  "Numbers of contacts to be sent to other processors",
7681      &  (ncont_sent(i),i=1,ntask_cont_to)
7682       write (iout,*) "Contacts sent"
7683       do ii=1,ntask_cont_to
7684         nn=ncont_sent(ii)
7685         iproc=itask_cont_to(ii)
7686         write (iout,*) nn," contacts to processor",iproc,
7687      &   " of CONT_TO_COMM group"
7688         do i=1,nn
7689           write(iout,'(2f5.0,10f10.5)')(zapas(j,i,ii),j=1,10)
7690         enddo
7691       enddo
7692       call flush(iout)
7693       endif
7694       CorrelType=477
7695       CorrelID=fg_rank+1
7696       CorrelType1=478
7697       CorrelID1=nfgtasks+fg_rank+1
7698       ireq=0
7699 C Receive the numbers of needed contacts from other processors
7700       do ii=1,ntask_cont_from
7701         iproc=itask_cont_from(ii)
7702         ireq=ireq+1
7703         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
7704      &    FG_COMM,req(ireq),IERR)
7705       enddo
7706 c      write (iout,*) "IRECV ended"
7707 c      call flush(iout)
7708 C Send the number of contacts needed by other processors
7709       do ii=1,ntask_cont_to
7710         iproc=itask_cont_to(ii)
7711         ireq=ireq+1
7712         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
7713      &    FG_COMM,req(ireq),IERR)
7714       enddo
7715 c      write (iout,*) "ISEND ended"
7716 c      write (iout,*) "number of requests (nn)",ireq
7717       call flush(iout)
7718       if (ireq.gt.0)
7719      &  call MPI_Waitall(ireq,req,status_array,ierr)
7720 c      write (iout,*)
7721 c     &  "Numbers of contacts to be received from other processors",
7722 c     &  (ncont_recv(i),i=1,ntask_cont_from)
7723 c      call flush(iout)
7724 C Receive contacts
7725       ireq=0
7726       do ii=1,ntask_cont_from
7727         iproc=itask_cont_from(ii)
7728         nn=ncont_recv(ii)
7729 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
7730 c     &   " of CONT_TO_COMM group"
7731         call flush(iout)
7732         if (nn.gt.0) then
7733           ireq=ireq+1
7734           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
7735      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
7736 c          write (iout,*) "ireq,req",ireq,req(ireq)
7737         endif
7738       enddo
7739 C Send the contacts to processors that need them
7740       do ii=1,ntask_cont_to
7741         iproc=itask_cont_to(ii)
7742         nn=ncont_sent(ii)
7743 c        write (iout,*) nn," contacts to processor",iproc,
7744 c     &   " of CONT_TO_COMM group"
7745         if (nn.gt.0) then
7746           ireq=ireq+1
7747           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
7748      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
7749 c          write (iout,*) "ireq,req",ireq,req(ireq)
7750 c          do i=1,nn
7751 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
7752 c          enddo
7753         endif
7754       enddo
7755 c      write (iout,*) "number of requests (contacts)",ireq
7756 c      write (iout,*) "req",(req(i),i=1,4)
7757 c      call flush(iout)
7758       if (ireq.gt.0)
7759      & call MPI_Waitall(ireq,req,status_array,ierr)
7760       do iii=1,ntask_cont_from
7761         iproc=itask_cont_from(iii)
7762         nn=ncont_recv(iii)
7763         if (lprn) then
7764         write (iout,*) "Received",nn," contacts from processor",iproc,
7765      &   " of CONT_FROM_COMM group"
7766         call flush(iout)
7767         do i=1,nn
7768           write(iout,'(2f5.0,10f10.5)')(zapas_recv(j,i,iii),j=1,10)
7769         enddo
7770         call flush(iout)
7771         endif
7772         do i=1,nn
7773           ii=zapas_recv(1,i,iii)
7774 c Flag the received contacts to prevent double-counting
7775           jj=-zapas_recv(2,i,iii)
7776 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
7777 c          call flush(iout)
7778           nnn=num_cont_hb(ii)+1
7779           num_cont_hb(ii)=nnn
7780           jcont_hb(nnn,ii)=jj
7781           d_cont(nnn,ii)=zapas_recv(3,i,iii)
7782           ind=3
7783           do kk=1,3
7784             ind=ind+1
7785             grij_hb_cont(kk,nnn,ii)=zapas_recv(ind,i,iii)
7786           enddo
7787           do kk=1,2
7788             do ll=1,2
7789               ind=ind+1
7790               a_chuj(ll,kk,nnn,ii)=zapas_recv(ind,i,iii)
7791             enddo
7792           enddo
7793           do jj=1,5
7794             do kk=1,3
7795               do ll=1,2
7796                 do mm=1,2
7797                   ind=ind+1
7798                   a_chuj_der(mm,ll,kk,jj,nnn,ii)=zapas_recv(ind,i,iii)
7799                 enddo
7800               enddo
7801             enddo
7802           enddo
7803         enddo
7804       enddo
7805       call flush(iout)
7806       if (lprn) then
7807         write (iout,'(a)') 'Contact function values after receive:'
7808         do i=nnt,nct-2
7809           write (iout,'(2i3,50(1x,i3,5f6.3))')
7810      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
7811      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
7812         enddo
7813         call flush(iout)
7814       endif
7815    30 continue
7816 #endif
7817       if (lprn) then
7818         write (iout,'(a)') 'Contact function values:'
7819         do i=nnt,nct-2
7820           write (iout,'(2i3,50(1x,i2,5f6.3))')
7821      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
7822      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
7823         enddo
7824       endif
7825       ecorr=0.0D0
7826       ecorr5=0.0d0
7827       ecorr6=0.0d0
7828 C Remove the loop below after debugging !!!
7829       do i=nnt,nct
7830         do j=1,3
7831           gradcorr(j,i)=0.0D0
7832           gradxorr(j,i)=0.0D0
7833         enddo
7834       enddo
7835 C Calculate the dipole-dipole interaction energies
7836       if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
7837       do i=iatel_s,iatel_e+1
7838         num_conti=num_cont_hb(i)
7839         do jj=1,num_conti
7840           j=jcont_hb(jj,i)
7841 #ifdef MOMENT
7842           call dipole(i,j,jj)
7843 #endif
7844         enddo
7845       enddo
7846       endif
7847 C Calculate the local-electrostatic correlation terms
7848 c                write (iout,*) "gradcorr5 in eello5 before loop"
7849 c                do iii=1,nres
7850 c                  write (iout,'(i5,3f10.5)')
7851 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
7852 c                enddo
7853       do i=min0(iatel_s,iturn4_start),max0(iatel_e+1,iturn3_end+1)
7854 c        write (iout,*) "corr loop i",i
7855         i1=i+1
7856         num_conti=num_cont_hb(i)
7857         num_conti1=num_cont_hb(i+1)
7858         do jj=1,num_conti
7859           j=jcont_hb(jj,i)
7860           jp=iabs(j)
7861           do kk=1,num_conti1
7862             j1=jcont_hb(kk,i1)
7863             jp1=iabs(j1)
7864 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
7865 c     &         ' jj=',jj,' kk=',kk
7866 c            if (j1.eq.j+1 .or. j1.eq.j-1) then
7867             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
7868      &          .or. j.lt.0 .and. j1.gt.0) .and.
7869      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
7870 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
7871 C The system gains extra energy.
7872               n_corr=n_corr+1
7873               sqd1=dsqrt(d_cont(jj,i))
7874               sqd2=dsqrt(d_cont(kk,i1))
7875               sred_geom = sqd1*sqd2
7876               IF (sred_geom.lt.cutoff_corr) THEN
7877                 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,
7878      &            ekont,fprimcont)
7879 cd               write (iout,*) 'i=',i,' j=',jp,' i1=',i1,' j1=',jp1,
7880 cd     &         ' jj=',jj,' kk=',kk
7881                 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
7882                 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
7883                 do l=1,3
7884                   g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
7885                   g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
7886                 enddo
7887                 n_corr1=n_corr1+1
7888 cd               write (iout,*) 'sred_geom=',sred_geom,
7889 cd     &          ' ekont=',ekont,' fprim=',fprimcont,
7890 cd     &          ' fac_prim1',fac_prim1,' fac_prim2',fac_prim2
7891 cd               write (iout,*) "g_contij",g_contij
7892 cd               write (iout,*) "grij_hb_cont i",grij_hb_cont(:,jj,i)
7893 cd               write (iout,*) "grij_hb_cont i1",grij_hb_cont(:,jj,i1)
7894                 call calc_eello(i,jp,i+1,jp1,jj,kk)
7895                 if (wcorr4.gt.0.0d0)
7896      &            ecorr=ecorr+eello4(i,jp,i+1,jp1,jj,kk)
7897                   if (energy_dec.and.wcorr4.gt.0.0d0)
7898      1                 write (iout,'(a6,4i5,0pf7.3)')
7899      2                'ecorr4',i,j,i+1,j1,eello4(i,jp,i+1,jp1,jj,kk)
7900 c                write (iout,*) "gradcorr5 before eello5"
7901 c                do iii=1,nres
7902 c                  write (iout,'(i5,3f10.5)')
7903 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
7904 c                enddo
7905                 if (wcorr5.gt.0.0d0)
7906      &            ecorr5=ecorr5+eello5(i,jp,i+1,jp1,jj,kk)
7907 c                write (iout,*) "gradcorr5 after eello5"
7908 c                do iii=1,nres
7909 c                  write (iout,'(i5,3f10.5)')
7910 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
7911 c                enddo
7912                   if (energy_dec.and.wcorr5.gt.0.0d0)
7913      1                 write (iout,'(a6,4i5,0pf7.3)')
7914      2                'ecorr5',i,j,i+1,j1,eello5(i,jp,i+1,jp1,jj,kk)
7915 cd                write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
7916 cd                write(2,*)'ijkl',i,jp,i+1,jp1
7917                 if (wcorr6.gt.0.0d0 .and. (jp.ne.i+4 .or. jp1.ne.i+3
7918      &               .or. wturn6.eq.0.0d0))then
7919 cd                  write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
7920                   ecorr6=ecorr6+eello6(i,jp,i+1,jp1,jj,kk)
7921                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
7922      1                'ecorr6',i,j,i+1,j1,eello6(i,jp,i+1,jp1,jj,kk)
7923 cd                write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
7924 cd     &            'ecorr6=',ecorr6
7925 cd                write (iout,'(4e15.5)') sred_geom,
7926 cd     &          dabs(eello4(i,jp,i+1,jp1,jj,kk)),
7927 cd     &          dabs(eello5(i,jp,i+1,jp1,jj,kk)),
7928 cd     &          dabs(eello6(i,jp,i+1,jp1,jj,kk))
7929                 else if (wturn6.gt.0.0d0
7930      &            .and. (jp.eq.i+4 .and. jp1.eq.i+3)) then
7931 cd                  write (iout,*) '******eturn6: i,j,i+1,j1',i,jip,i+1,jp1
7932                   eturn6=eturn6+eello_turn6(i,jj,kk)
7933                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
7934      1                 'eturn6',i,j,i+1,j1,eello_turn6(i,jj,kk)
7935 cd                  write (2,*) 'multibody_eello:eturn6',eturn6
7936                 endif
7937               ENDIF
7938 1111          continue
7939             endif
7940           enddo ! kk
7941         enddo ! jj
7942       enddo ! i
7943       do i=1,nres
7944         num_cont_hb(i)=num_cont_hb_old(i)
7945       enddo
7946 c                write (iout,*) "gradcorr5 in eello5"
7947 c                do iii=1,nres
7948 c                  write (iout,'(i5,3f10.5)')
7949 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
7950 c                enddo
7951       return
7952       end
7953 c------------------------------------------------------------------------------
7954       subroutine add_hb_contact_eello(ii,jj,itask)
7955       implicit real*8 (a-h,o-z)
7956       include "DIMENSIONS"
7957       include "COMMON.IOUNITS"
7958       integer max_cont
7959       integer max_dim
7960       parameter (max_cont=maxconts)
7961       parameter (max_dim=70)
7962       include "COMMON.CONTACTS"
7963       double precision zapas(max_dim,maxconts,max_fg_procs),
7964      &  zapas_recv(max_dim,maxconts,max_fg_procs)
7965       common /przechowalnia/ zapas
7966       integer i,j,ii,jj,iproc,itask(4),nn
7967 c      write (iout,*) "itask",itask
7968       do i=1,2
7969         iproc=itask(i)
7970         if (iproc.gt.0) then
7971           do j=1,num_cont_hb(ii)
7972             jjc=jcont_hb(j,ii)
7973 c            write (iout,*) "send turns i",ii," j",jj," jjc",jjc
7974             if (jjc.eq.jj) then
7975               ncont_sent(iproc)=ncont_sent(iproc)+1
7976               nn=ncont_sent(iproc)
7977               zapas(1,nn,iproc)=ii
7978               zapas(2,nn,iproc)=jjc
7979               zapas(3,nn,iproc)=d_cont(j,ii)
7980               ind=3
7981               do kk=1,3
7982                 ind=ind+1
7983                 zapas(ind,nn,iproc)=grij_hb_cont(kk,j,ii)
7984               enddo
7985               do kk=1,2
7986                 do ll=1,2
7987                   ind=ind+1
7988                   zapas(ind,nn,iproc)=a_chuj(ll,kk,j,ii)
7989                 enddo
7990               enddo
7991               do jj=1,5
7992                 do kk=1,3
7993                   do ll=1,2
7994                     do mm=1,2
7995                       ind=ind+1
7996                       zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,ii)
7997                     enddo
7998                   enddo
7999                 enddo
8000               enddo
8001               exit
8002             endif
8003           enddo
8004         endif
8005       enddo
8006       return
8007       end
8008 c------------------------------------------------------------------------------
8009       double precision function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
8010       implicit real*8 (a-h,o-z)
8011       include 'DIMENSIONS'
8012       include 'COMMON.IOUNITS'
8013       include 'COMMON.DERIV'
8014       include 'COMMON.INTERACT'
8015       include 'COMMON.CONTACTS'
8016       double precision gx(3),gx1(3)
8017       logical lprn
8018       lprn=.false.
8019       eij=facont_hb(jj,i)
8020       ekl=facont_hb(kk,k)
8021       ees0pij=ees0p(jj,i)
8022       ees0pkl=ees0p(kk,k)
8023       ees0mij=ees0m(jj,i)
8024       ees0mkl=ees0m(kk,k)
8025       ekont=eij*ekl
8026       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
8027 cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
8028 C Following 4 lines for diagnostics.
8029 cd    ees0pkl=0.0D0
8030 cd    ees0pij=1.0D0
8031 cd    ees0mkl=0.0D0
8032 cd    ees0mij=1.0D0
8033 c      write (iout,'(2(a,2i3,a,f10.5,a,2f10.5),a,f10.5,a,$)')
8034 c     & 'Contacts ',i,j,
8035 c     & ' eij',eij,' eesij',ees0pij,ees0mij,' and ',k,l
8036 c     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' energy=',ekont*ees,
8037 c     & 'gradcorr_long'
8038 C Calculate the multi-body contribution to energy.
8039 c      ecorr=ecorr+ekont*ees
8040 C Calculate multi-body contributions to the gradient.
8041       coeffpees0pij=coeffp*ees0pij
8042       coeffmees0mij=coeffm*ees0mij
8043       coeffpees0pkl=coeffp*ees0pkl
8044       coeffmees0mkl=coeffm*ees0mkl
8045       do ll=1,3
8046 cgrad        ghalfi=ees*ekl*gacont_hbr(ll,jj,i)
8047         gradcorr(ll,i)=gradcorr(ll,i)!+0.5d0*ghalfi
8048      &  -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+
8049      &  coeffmees0mkl*gacontm_hb1(ll,jj,i))
8050         gradcorr(ll,j)=gradcorr(ll,j)!+0.5d0*ghalfi
8051      &  -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+
8052      &  coeffmees0mkl*gacontm_hb2(ll,jj,i))
8053 cgrad        ghalfk=ees*eij*gacont_hbr(ll,kk,k)
8054         gradcorr(ll,k)=gradcorr(ll,k)!+0.5d0*ghalfk
8055      &  -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+
8056      &  coeffmees0mij*gacontm_hb1(ll,kk,k))
8057         gradcorr(ll,l)=gradcorr(ll,l)!+0.5d0*ghalfk
8058      &  -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+
8059      &  coeffmees0mij*gacontm_hb2(ll,kk,k))
8060         gradlongij=ees*ekl*gacont_hbr(ll,jj,i)-
8061      &     ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+
8062      &     coeffmees0mkl*gacontm_hb3(ll,jj,i))
8063         gradcorr_long(ll,j)=gradcorr_long(ll,j)+gradlongij
8064         gradcorr_long(ll,i)=gradcorr_long(ll,i)-gradlongij
8065         gradlongkl=ees*eij*gacont_hbr(ll,kk,k)-
8066      &     ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+
8067      &     coeffmees0mij*gacontm_hb3(ll,kk,k))
8068         gradcorr_long(ll,l)=gradcorr_long(ll,l)+gradlongkl
8069         gradcorr_long(ll,k)=gradcorr_long(ll,k)-gradlongkl
8070 c        write (iout,'(2f10.5,2x,$)') gradlongij,gradlongkl
8071       enddo
8072 c      write (iout,*)
8073 cgrad      do m=i+1,j-1
8074 cgrad        do ll=1,3
8075 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
8076 cgrad     &     ees*ekl*gacont_hbr(ll,jj,i)-
8077 cgrad     &     ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
8078 cgrad     &     coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
8079 cgrad        enddo
8080 cgrad      enddo
8081 cgrad      do m=k+1,l-1
8082 cgrad        do ll=1,3
8083 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
8084 cgrad     &     ees*eij*gacont_hbr(ll,kk,k)-
8085 cgrad     &     ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
8086 cgrad     &     coeffm*ees0mij*gacontm_hb3(ll,kk,k))
8087 cgrad        enddo
8088 cgrad      enddo
8089 c      write (iout,*) "ehbcorr",ekont*ees
8090       ehbcorr=ekont*ees
8091       return
8092       end
8093 #ifdef MOMENT
8094 C---------------------------------------------------------------------------
8095       subroutine dipole(i,j,jj)
8096       implicit real*8 (a-h,o-z)
8097       include 'DIMENSIONS'
8098       include 'COMMON.IOUNITS'
8099       include 'COMMON.CHAIN'
8100       include 'COMMON.FFIELD'
8101       include 'COMMON.DERIV'
8102       include 'COMMON.INTERACT'
8103       include 'COMMON.CONTACTS'
8104       include 'COMMON.TORSION'
8105       include 'COMMON.VAR'
8106       include 'COMMON.GEO'
8107       dimension dipi(2,2),dipj(2,2),dipderi(2),dipderj(2),auxvec(2),
8108      &  auxmat(2,2)
8109       iti1 = itortyp(itype(i+1))
8110       if (j.lt.nres-1) then
8111         itj1 = itortyp(itype(j+1))
8112       else
8113         itj1=ntortyp
8114       endif
8115       do iii=1,2
8116         dipi(iii,1)=Ub2(iii,i)
8117         dipderi(iii)=Ub2der(iii,i)
8118         dipi(iii,2)=b1(iii,i+1)
8119         dipj(iii,1)=Ub2(iii,j)
8120         dipderj(iii)=Ub2der(iii,j)
8121         dipj(iii,2)=b1(iii,j+1)
8122       enddo
8123       kkk=0
8124       do iii=1,2
8125         call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
8126         do jjj=1,2
8127           kkk=kkk+1
8128           dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
8129         enddo
8130       enddo
8131       do kkk=1,5
8132         do lll=1,3
8133           mmm=0
8134           do iii=1,2
8135             call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),
8136      &        auxvec(1))
8137             do jjj=1,2
8138               mmm=mmm+1
8139               dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
8140             enddo
8141           enddo
8142         enddo
8143       enddo
8144       call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
8145       call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
8146       do iii=1,2
8147         dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
8148       enddo
8149       call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
8150       do iii=1,2
8151         dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
8152       enddo
8153       return
8154       end
8155 #endif
8156 C---------------------------------------------------------------------------
8157       subroutine calc_eello(i,j,k,l,jj,kk)
8158 C
8159 C This subroutine computes matrices and vectors needed to calculate
8160 C the fourth-, fifth-, and sixth-order local-electrostatic terms.
8161 C
8162       implicit real*8 (a-h,o-z)
8163       include 'DIMENSIONS'
8164       include 'COMMON.IOUNITS'
8165       include 'COMMON.CHAIN'
8166       include 'COMMON.DERIV'
8167       include 'COMMON.INTERACT'
8168       include 'COMMON.CONTACTS'
8169       include 'COMMON.TORSION'
8170       include 'COMMON.VAR'
8171       include 'COMMON.GEO'
8172       include 'COMMON.FFIELD'
8173       double precision aa1(2,2),aa2(2,2),aa1t(2,2),aa2t(2,2),
8174      &  aa1tder(2,2,3,5),aa2tder(2,2,3,5),auxmat(2,2)
8175       logical lprn
8176       common /kutas/ lprn
8177 cd      write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
8178 cd     & ' jj=',jj,' kk=',kk
8179 cd      if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
8180 cd      write (iout,*) "a_chujij",((a_chuj(iii,jjj,jj,i),iii=1,2),jjj=1,2)
8181 cd      write (iout,*) "a_chujkl",((a_chuj(iii,jjj,kk,k),iii=1,2),jjj=1,2)
8182       do iii=1,2
8183         do jjj=1,2
8184           aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
8185           aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
8186         enddo
8187       enddo
8188       call transpose2(aa1(1,1),aa1t(1,1))
8189       call transpose2(aa2(1,1),aa2t(1,1))
8190       do kkk=1,5
8191         do lll=1,3
8192           call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),
8193      &      aa1tder(1,1,lll,kkk))
8194           call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),
8195      &      aa2tder(1,1,lll,kkk))
8196         enddo
8197       enddo
8198       if (l.eq.j+1) then
8199 C parallel orientation of the two CA-CA-CA frames.
8200         if (i.gt.1) then
8201           iti=itortyp(itype(i))
8202         else
8203           iti=ntortyp
8204         endif
8205         itk1=itortyp(itype(k+1))
8206         itj=itortyp(itype(j))
8207         if (l.lt.nres-1) then
8208           itl1=itortyp(itype(l+1))
8209         else
8210           itl1=ntortyp
8211         endif
8212 C A1 kernel(j+1) A2T
8213 cd        do iii=1,2
8214 cd          write (iout,'(3f10.5,5x,3f10.5)')
8215 cd     &     (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
8216 cd        enddo
8217         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
8218      &   aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),
8219      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
8220 C Following matrices are needed only for 6-th order cumulants
8221         IF (wcorr6.gt.0.0d0) THEN
8222         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
8223      &   aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),
8224      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
8225         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
8226      &   aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),
8227      &   Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
8228      &   ADtEAderx(1,1,1,1,1,1))
8229         lprn=.false.
8230         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
8231      &   aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),
8232      &   DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
8233      &   ADtEA1derx(1,1,1,1,1,1))
8234         ENDIF
8235 C End 6-th order cumulants
8236 cd        lprn=.false.
8237 cd        if (lprn) then
8238 cd        write (2,*) 'In calc_eello6'
8239 cd        do iii=1,2
8240 cd          write (2,*) 'iii=',iii
8241 cd          do kkk=1,5
8242 cd            write (2,*) 'kkk=',kkk
8243 cd            do jjj=1,2
8244 cd              write (2,'(3(2f10.5),5x)')
8245 cd     &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
8246 cd            enddo
8247 cd          enddo
8248 cd        enddo
8249 cd        endif
8250         call transpose2(EUgder(1,1,k),auxmat(1,1))
8251         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
8252         call transpose2(EUg(1,1,k),auxmat(1,1))
8253         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
8254         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
8255         do iii=1,2
8256           do kkk=1,5
8257             do lll=1,3
8258               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
8259      &          EAEAderx(1,1,lll,kkk,iii,1))
8260             enddo
8261           enddo
8262         enddo
8263 C A1T kernel(i+1) A2
8264         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
8265      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),
8266      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
8267 C Following matrices are needed only for 6-th order cumulants
8268         IF (wcorr6.gt.0.0d0) THEN
8269         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
8270      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),
8271      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
8272         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
8273      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),
8274      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
8275      &   ADtEAderx(1,1,1,1,1,2))
8276         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
8277      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),
8278      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
8279      &   ADtEA1derx(1,1,1,1,1,2))
8280         ENDIF
8281 C End 6-th order cumulants
8282         call transpose2(EUgder(1,1,l),auxmat(1,1))
8283         call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
8284         call transpose2(EUg(1,1,l),auxmat(1,1))
8285         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
8286         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
8287         do iii=1,2
8288           do kkk=1,5
8289             do lll=1,3
8290               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
8291      &          EAEAderx(1,1,lll,kkk,iii,2))
8292             enddo
8293           enddo
8294         enddo
8295 C AEAb1 and AEAb2
8296 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
8297 C They are needed only when the fifth- or the sixth-order cumulants are
8298 C indluded.
8299         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
8300         call transpose2(AEA(1,1,1),auxmat(1,1))
8301         call matvec2(auxmat(1,1),b1(1,i),AEAb1(1,1,1))
8302         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
8303         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
8304         call transpose2(AEAderg(1,1,1),auxmat(1,1))
8305         call matvec2(auxmat(1,1),b1(1,i),AEAb1derg(1,1,1))
8306         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
8307         call matvec2(AEA(1,1,1),b1(1,k+1),AEAb1(1,2,1))
8308         call matvec2(AEAderg(1,1,1),b1(1,k+1),AEAb1derg(1,2,1))
8309         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
8310         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
8311         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
8312         call transpose2(AEA(1,1,2),auxmat(1,1))
8313         call matvec2(auxmat(1,1),b1(1,j),AEAb1(1,1,2))
8314         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
8315         call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
8316         call transpose2(AEAderg(1,1,2),auxmat(1,1))
8317         call matvec2(auxmat(1,1),b1(1,j),AEAb1derg(1,1,2))
8318         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
8319         call matvec2(AEA(1,1,2),b1(1,l+1),AEAb1(1,2,2))
8320         call matvec2(AEAderg(1,1,2),b1(1,l+1),AEAb1derg(1,2,2))
8321         call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
8322         call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
8323         call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
8324 C Calculate the Cartesian derivatives of the vectors.
8325         do iii=1,2
8326           do kkk=1,5
8327             do lll=1,3
8328               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
8329               call matvec2(auxmat(1,1),b1(1,i),
8330      &          AEAb1derx(1,lll,kkk,iii,1,1))
8331               call matvec2(auxmat(1,1),Ub2(1,i),
8332      &          AEAb2derx(1,lll,kkk,iii,1,1))
8333               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
8334      &          AEAb1derx(1,lll,kkk,iii,2,1))
8335               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
8336      &          AEAb2derx(1,lll,kkk,iii,2,1))
8337               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
8338               call matvec2(auxmat(1,1),b1(1,j),
8339      &          AEAb1derx(1,lll,kkk,iii,1,2))
8340               call matvec2(auxmat(1,1),Ub2(1,j),
8341      &          AEAb2derx(1,lll,kkk,iii,1,2))
8342               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,l+1),
8343      &          AEAb1derx(1,lll,kkk,iii,2,2))
8344               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),
8345      &          AEAb2derx(1,lll,kkk,iii,2,2))
8346             enddo
8347           enddo
8348         enddo
8349         ENDIF
8350 C End vectors
8351       else
8352 C Antiparallel orientation of the two CA-CA-CA frames.
8353         if (i.gt.1) then
8354           iti=itortyp(itype(i))
8355         else
8356           iti=ntortyp
8357         endif
8358         itk1=itortyp(itype(k+1))
8359         itl=itortyp(itype(l))
8360         itj=itortyp(itype(j))
8361         if (j.lt.nres-1) then
8362           itj1=itortyp(itype(j+1))
8363         else
8364           itj1=ntortyp
8365         endif
8366 C A2 kernel(j-1)T A1T
8367         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
8368      &   aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),
8369      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
8370 C Following matrices are needed only for 6-th order cumulants
8371         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
8372      &     j.eq.i+4 .and. l.eq.i+3)) THEN
8373         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
8374      &   aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),
8375      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
8376         call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
8377      &   aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),
8378      &   Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
8379      &   ADtEAderx(1,1,1,1,1,1))
8380         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
8381      &   aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),
8382      &   DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
8383      &   ADtEA1derx(1,1,1,1,1,1))
8384         ENDIF
8385 C End 6-th order cumulants
8386         call transpose2(EUgder(1,1,k),auxmat(1,1))
8387         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
8388         call transpose2(EUg(1,1,k),auxmat(1,1))
8389         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
8390         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
8391         do iii=1,2
8392           do kkk=1,5
8393             do lll=1,3
8394               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
8395      &          EAEAderx(1,1,lll,kkk,iii,1))
8396             enddo
8397           enddo
8398         enddo
8399 C A2T kernel(i+1)T A1
8400         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
8401      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),
8402      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
8403 C Following matrices are needed only for 6-th order cumulants
8404         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
8405      &     j.eq.i+4 .and. l.eq.i+3)) THEN
8406         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
8407      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),
8408      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
8409         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
8410      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),
8411      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
8412      &   ADtEAderx(1,1,1,1,1,2))
8413         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
8414      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),
8415      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
8416      &   ADtEA1derx(1,1,1,1,1,2))
8417         ENDIF
8418 C End 6-th order cumulants
8419         call transpose2(EUgder(1,1,j),auxmat(1,1))
8420         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
8421         call transpose2(EUg(1,1,j),auxmat(1,1))
8422         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
8423         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
8424         do iii=1,2
8425           do kkk=1,5
8426             do lll=1,3
8427               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
8428      &          EAEAderx(1,1,lll,kkk,iii,2))
8429             enddo
8430           enddo
8431         enddo
8432 C AEAb1 and AEAb2
8433 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
8434 C They are needed only when the fifth- or the sixth-order cumulants are
8435 C indluded.
8436         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or.
8437      &    (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
8438         call transpose2(AEA(1,1,1),auxmat(1,1))
8439         call matvec2(auxmat(1,1),b1(1,i),AEAb1(1,1,1))
8440         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
8441         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
8442         call transpose2(AEAderg(1,1,1),auxmat(1,1))
8443         call matvec2(auxmat(1,1),b1(1,i),AEAb1derg(1,1,1))
8444         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
8445         call matvec2(AEA(1,1,1),b1(1,k+1),AEAb1(1,2,1))
8446         call matvec2(AEAderg(1,1,1),b1(1,k+1),AEAb1derg(1,2,1))
8447         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
8448         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
8449         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
8450         call transpose2(AEA(1,1,2),auxmat(1,1))
8451         call matvec2(auxmat(1,1),b1(1,j+1),AEAb1(1,1,2))
8452         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
8453         call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
8454         call transpose2(AEAderg(1,1,2),auxmat(1,1))
8455         call matvec2(auxmat(1,1),b1(1,l),AEAb1(1,1,2))
8456         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
8457         call matvec2(AEA(1,1,2),b1(1,j+1),AEAb1(1,2,2))
8458         call matvec2(AEAderg(1,1,2),b1(1,j+1),AEAb1derg(1,2,2))
8459         call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
8460         call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
8461         call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
8462 C Calculate the Cartesian derivatives of the vectors.
8463         do iii=1,2
8464           do kkk=1,5
8465             do lll=1,3
8466               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
8467               call matvec2(auxmat(1,1),b1(1,i),
8468      &          AEAb1derx(1,lll,kkk,iii,1,1))
8469               call matvec2(auxmat(1,1),Ub2(1,i),
8470      &          AEAb2derx(1,lll,kkk,iii,1,1))
8471               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
8472      &          AEAb1derx(1,lll,kkk,iii,2,1))
8473               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
8474      &          AEAb2derx(1,lll,kkk,iii,2,1))
8475               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
8476               call matvec2(auxmat(1,1),b1(1,l),
8477      &          AEAb1derx(1,lll,kkk,iii,1,2))
8478               call matvec2(auxmat(1,1),Ub2(1,l),
8479      &          AEAb2derx(1,lll,kkk,iii,1,2))
8480               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,j+1),
8481      &          AEAb1derx(1,lll,kkk,iii,2,2))
8482               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),
8483      &          AEAb2derx(1,lll,kkk,iii,2,2))
8484             enddo
8485           enddo
8486         enddo
8487         ENDIF
8488 C End vectors
8489       endif
8490       return
8491       end
8492 C---------------------------------------------------------------------------
8493       subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,
8494      &  KK,KKderg,AKA,AKAderg,AKAderx)
8495       implicit none
8496       integer nderg
8497       logical transp
8498       double precision aa1(2,2),aa2t(2,2),aa1derx(2,2,3,5),
8499      &  aa2tderx(2,2,3,5),KK(2,2),KKderg(2,2,nderg),AKA(2,2),
8500      &  AKAderg(2,2,nderg),AKAderx(2,2,3,5,2)
8501       integer iii,kkk,lll
8502       integer jjj,mmm
8503       logical lprn
8504       common /kutas/ lprn
8505       call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
8506       do iii=1,nderg
8507         call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,
8508      &    AKAderg(1,1,iii))
8509       enddo
8510 cd      if (lprn) write (2,*) 'In kernel'
8511       do kkk=1,5
8512 cd        if (lprn) write (2,*) 'kkk=',kkk
8513         do lll=1,3
8514           call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),
8515      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
8516 cd          if (lprn) then
8517 cd            write (2,*) 'lll=',lll
8518 cd            write (2,*) 'iii=1'
8519 cd            do jjj=1,2
8520 cd              write (2,'(3(2f10.5),5x)')
8521 cd     &        (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
8522 cd            enddo
8523 cd          endif
8524           call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),
8525      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
8526 cd          if (lprn) then
8527 cd            write (2,*) 'lll=',lll
8528 cd            write (2,*) 'iii=2'
8529 cd            do jjj=1,2
8530 cd              write (2,'(3(2f10.5),5x)')
8531 cd     &        (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
8532 cd            enddo
8533 cd          endif
8534         enddo
8535       enddo
8536       return
8537       end
8538 C---------------------------------------------------------------------------
8539       double precision function eello4(i,j,k,l,jj,kk)
8540       implicit real*8 (a-h,o-z)
8541       include 'DIMENSIONS'
8542       include 'COMMON.IOUNITS'
8543       include 'COMMON.CHAIN'
8544       include 'COMMON.DERIV'
8545       include 'COMMON.INTERACT'
8546       include 'COMMON.CONTACTS'
8547       include 'COMMON.TORSION'
8548       include 'COMMON.VAR'
8549       include 'COMMON.GEO'
8550       double precision pizda(2,2),ggg1(3),ggg2(3)
8551 cd      if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
8552 cd        eello4=0.0d0
8553 cd        return
8554 cd      endif
8555 cd      print *,'eello4:',i,j,k,l,jj,kk
8556 cd      write (2,*) 'i',i,' j',j,' k',k,' l',l
8557 cd      call checkint4(i,j,k,l,jj,kk,eel4_num)
8558 cold      eij=facont_hb(jj,i)
8559 cold      ekl=facont_hb(kk,k)
8560 cold      ekont=eij*ekl
8561       eel4=-EAEA(1,1,1)-EAEA(2,2,1)
8562 cd      eel41=-EAEA(1,1,2)-EAEA(2,2,2)
8563       gcorr_loc(k-1)=gcorr_loc(k-1)
8564      &   -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
8565       if (l.eq.j+1) then
8566         gcorr_loc(l-1)=gcorr_loc(l-1)
8567      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
8568       else
8569         gcorr_loc(j-1)=gcorr_loc(j-1)
8570      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
8571       endif
8572       do iii=1,2
8573         do kkk=1,5
8574           do lll=1,3
8575             derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1)
8576      &                        -EAEAderx(2,2,lll,kkk,iii,1)
8577 cd            derx(lll,kkk,iii)=0.0d0
8578           enddo
8579         enddo
8580       enddo
8581 cd      gcorr_loc(l-1)=0.0d0
8582 cd      gcorr_loc(j-1)=0.0d0
8583 cd      gcorr_loc(k-1)=0.0d0
8584 cd      eel4=1.0d0
8585 cd      write (iout,*)'Contacts have occurred for peptide groups',
8586 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l,
8587 cd     &  ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
8588       if (j.lt.nres-1) then
8589         j1=j+1
8590         j2=j-1
8591       else
8592         j1=j-1
8593         j2=j-2
8594       endif
8595       if (l.lt.nres-1) then
8596         l1=l+1
8597         l2=l-1
8598       else
8599         l1=l-1
8600         l2=l-2
8601       endif
8602       do ll=1,3
8603 cgrad        ggg1(ll)=eel4*g_contij(ll,1)
8604 cgrad        ggg2(ll)=eel4*g_contij(ll,2)
8605         glongij=eel4*g_contij(ll,1)+ekont*derx(ll,1,1)
8606         glongkl=eel4*g_contij(ll,2)+ekont*derx(ll,1,2)
8607 cgrad        ghalf=0.5d0*ggg1(ll)
8608         gradcorr(ll,i)=gradcorr(ll,i)+ekont*derx(ll,2,1)
8609         gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
8610         gradcorr(ll,j)=gradcorr(ll,j)+ekont*derx(ll,4,1)
8611         gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
8612         gradcorr_long(ll,j)=gradcorr_long(ll,j)+glongij
8613         gradcorr_long(ll,i)=gradcorr_long(ll,i)-glongij
8614 cgrad        ghalf=0.5d0*ggg2(ll)
8615         gradcorr(ll,k)=gradcorr(ll,k)+ekont*derx(ll,2,2)
8616         gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
8617         gradcorr(ll,l)=gradcorr(ll,l)+ekont*derx(ll,4,2)
8618         gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
8619         gradcorr_long(ll,l)=gradcorr_long(ll,l)+glongkl
8620         gradcorr_long(ll,k)=gradcorr_long(ll,k)-glongkl
8621       enddo
8622 cgrad      do m=i+1,j-1
8623 cgrad        do ll=1,3
8624 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
8625 cgrad        enddo
8626 cgrad      enddo
8627 cgrad      do m=k+1,l-1
8628 cgrad        do ll=1,3
8629 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
8630 cgrad        enddo
8631 cgrad      enddo
8632 cgrad      do m=i+2,j2
8633 cgrad        do ll=1,3
8634 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
8635 cgrad        enddo
8636 cgrad      enddo
8637 cgrad      do m=k+2,l2
8638 cgrad        do ll=1,3
8639 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
8640 cgrad        enddo
8641 cgrad      enddo
8642 cd      do iii=1,nres-3
8643 cd        write (2,*) iii,gcorr_loc(iii)
8644 cd      enddo
8645       eello4=ekont*eel4
8646 cd      write (2,*) 'ekont',ekont
8647 cd      write (iout,*) 'eello4',ekont*eel4
8648       return
8649       end
8650 C---------------------------------------------------------------------------
8651       double precision function eello5(i,j,k,l,jj,kk)
8652       implicit real*8 (a-h,o-z)
8653       include 'DIMENSIONS'
8654       include 'COMMON.IOUNITS'
8655       include 'COMMON.CHAIN'
8656       include 'COMMON.DERIV'
8657       include 'COMMON.INTERACT'
8658       include 'COMMON.CONTACTS'
8659       include 'COMMON.TORSION'
8660       include 'COMMON.VAR'
8661       include 'COMMON.GEO'
8662       double precision pizda(2,2),auxmat(2,2),auxmat1(2,2),vv(2)
8663       double precision ggg1(3),ggg2(3)
8664 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8665 C                                                                              C
8666 C                            Parallel chains                                   C
8667 C                                                                              C
8668 C          o             o                   o             o                   C
8669 C         /l\           / \             \   / \           / \   /              C
8670 C        /   \         /   \             \ /   \         /   \ /               C
8671 C       j| o |l1       | o |              o| o |         | o |o                C
8672 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
8673 C      \i/   \         /   \ /             /   \         /   \                 C
8674 C       o    k1             o                                                  C
8675 C         (I)          (II)                (III)          (IV)                 C
8676 C                                                                              C
8677 C      eello5_1        eello5_2            eello5_3       eello5_4             C
8678 C                                                                              C
8679 C                            Antiparallel chains                               C
8680 C                                                                              C
8681 C          o             o                   o             o                   C
8682 C         /j\           / \             \   / \           / \   /              C
8683 C        /   \         /   \             \ /   \         /   \ /               C
8684 C      j1| o |l        | o |              o| o |         | o |o                C
8685 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
8686 C      \i/   \         /   \ /             /   \         /   \                 C
8687 C       o     k1            o                                                  C
8688 C         (I)          (II)                (III)          (IV)                 C
8689 C                                                                              C
8690 C      eello5_1        eello5_2            eello5_3       eello5_4             C
8691 C                                                                              C
8692 C o denotes a local interaction, vertical lines an electrostatic interaction.  C
8693 C                                                                              C
8694 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8695 cd      if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
8696 cd        eello5=0.0d0
8697 cd        return
8698 cd      endif
8699 cd      write (iout,*)
8700 cd     &   'EELLO5: Contacts have occurred for peptide groups',i,j,
8701 cd     &   ' and',k,l
8702       itk=itortyp(itype(k))
8703       itl=itortyp(itype(l))
8704       itj=itortyp(itype(j))
8705       eello5_1=0.0d0
8706       eello5_2=0.0d0
8707       eello5_3=0.0d0
8708       eello5_4=0.0d0
8709 cd      call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
8710 cd     &   eel5_3_num,eel5_4_num)
8711       do iii=1,2
8712         do kkk=1,5
8713           do lll=1,3
8714             derx(lll,kkk,iii)=0.0d0
8715           enddo
8716         enddo
8717       enddo
8718 cd      eij=facont_hb(jj,i)
8719 cd      ekl=facont_hb(kk,k)
8720 cd      ekont=eij*ekl
8721 cd      write (iout,*)'Contacts have occurred for peptide groups',
8722 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l
8723 cd      goto 1111
8724 C Contribution from the graph I.
8725 cd      write (2,*) 'AEA  ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
8726 cd      write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
8727       call transpose2(EUg(1,1,k),auxmat(1,1))
8728       call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
8729       vv(1)=pizda(1,1)-pizda(2,2)
8730       vv(2)=pizda(1,2)+pizda(2,1)
8731       eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k))
8732      & +0.5d0*scalar2(vv(1),Dtobr2(1,i))
8733 C Explicit gradient in virtual-dihedral angles.
8734       if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1)
8735      & +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k))
8736      & +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
8737       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8738       call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
8739       vv(1)=pizda(1,1)-pizda(2,2)
8740       vv(2)=pizda(1,2)+pizda(2,1)
8741       g_corr5_loc(k-1)=g_corr5_loc(k-1)
8742      & +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k))
8743      & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
8744       call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
8745       vv(1)=pizda(1,1)-pizda(2,2)
8746       vv(2)=pizda(1,2)+pizda(2,1)
8747       if (l.eq.j+1) then
8748         if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1)
8749      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
8750      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
8751       else
8752         if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1)
8753      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
8754      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
8755       endif
8756 C Cartesian gradient
8757       do iii=1,2
8758         do kkk=1,5
8759           do lll=1,3
8760             call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),
8761      &        pizda(1,1))
8762             vv(1)=pizda(1,1)-pizda(2,2)
8763             vv(2)=pizda(1,2)+pizda(2,1)
8764             derx(lll,kkk,iii)=derx(lll,kkk,iii)
8765      &       +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k))
8766      &       +0.5d0*scalar2(vv(1),Dtobr2(1,i))
8767           enddo
8768         enddo
8769       enddo
8770 c      goto 1112
8771 c1111  continue
8772 C Contribution from graph II
8773       call transpose2(EE(1,1,itk),auxmat(1,1))
8774       call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
8775       vv(1)=pizda(1,1)+pizda(2,2)
8776       vv(2)=pizda(2,1)-pizda(1,2)
8777       eello5_2=scalar2(AEAb1(1,2,1),b1(1,k))
8778      & -0.5d0*scalar2(vv(1),Ctobr(1,k))
8779 C Explicit gradient in virtual-dihedral angles.
8780       g_corr5_loc(k-1)=g_corr5_loc(k-1)
8781      & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
8782       call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
8783       vv(1)=pizda(1,1)+pizda(2,2)
8784       vv(2)=pizda(2,1)-pizda(1,2)
8785       if (l.eq.j+1) then
8786         g_corr5_loc(l-1)=g_corr5_loc(l-1)
8787      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,k))
8788      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
8789       else
8790         g_corr5_loc(j-1)=g_corr5_loc(j-1)
8791      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,k))
8792      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
8793       endif
8794 C Cartesian gradient
8795       do iii=1,2
8796         do kkk=1,5
8797           do lll=1,3
8798             call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
8799      &        pizda(1,1))
8800             vv(1)=pizda(1,1)+pizda(2,2)
8801             vv(2)=pizda(2,1)-pizda(1,2)
8802             derx(lll,kkk,iii)=derx(lll,kkk,iii)
8803      &       +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,k))
8804      &       -0.5d0*scalar2(vv(1),Ctobr(1,k))
8805           enddo
8806         enddo
8807       enddo
8808 cd      goto 1112
8809 cd1111  continue
8810       if (l.eq.j+1) then
8811 cd        goto 1110
8812 C Parallel orientation
8813 C Contribution from graph III
8814         call transpose2(EUg(1,1,l),auxmat(1,1))
8815         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
8816         vv(1)=pizda(1,1)-pizda(2,2)
8817         vv(2)=pizda(1,2)+pizda(2,1)
8818         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l))
8819      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j))
8820 C Explicit gradient in virtual-dihedral angles.
8821         g_corr5_loc(j-1)=g_corr5_loc(j-1)
8822      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l))
8823      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
8824         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
8825         vv(1)=pizda(1,1)-pizda(2,2)
8826         vv(2)=pizda(1,2)+pizda(2,1)
8827         g_corr5_loc(k-1)=g_corr5_loc(k-1)
8828      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l))
8829      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
8830         call transpose2(EUgder(1,1,l),auxmat1(1,1))
8831         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
8832         vv(1)=pizda(1,1)-pizda(2,2)
8833         vv(2)=pizda(1,2)+pizda(2,1)
8834         g_corr5_loc(l-1)=g_corr5_loc(l-1)
8835      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l))
8836      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
8837 C Cartesian gradient
8838         do iii=1,2
8839           do kkk=1,5
8840             do lll=1,3
8841               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
8842      &          pizda(1,1))
8843               vv(1)=pizda(1,1)-pizda(2,2)
8844               vv(2)=pizda(1,2)+pizda(2,1)
8845               derx(lll,kkk,iii)=derx(lll,kkk,iii)
8846      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l))
8847      &         +0.5d0*scalar2(vv(1),Dtobr2(1,j))
8848             enddo
8849           enddo
8850         enddo
8851 cd        goto 1112
8852 C Contribution from graph IV
8853 cd1110    continue
8854         call transpose2(EE(1,1,itl),auxmat(1,1))
8855         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
8856         vv(1)=pizda(1,1)+pizda(2,2)
8857         vv(2)=pizda(2,1)-pizda(1,2)
8858         eello5_4=scalar2(AEAb1(1,2,2),b1(1,l))
8859      &   -0.5d0*scalar2(vv(1),Ctobr(1,l))
8860 C Explicit gradient in virtual-dihedral angles.
8861         g_corr5_loc(l-1)=g_corr5_loc(l-1)
8862      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
8863         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
8864         vv(1)=pizda(1,1)+pizda(2,2)
8865         vv(2)=pizda(2,1)-pizda(1,2)
8866         g_corr5_loc(k-1)=g_corr5_loc(k-1)
8867      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,l))
8868      &   -0.5d0*scalar2(vv(1),Ctobr(1,l)))
8869 C Cartesian gradient
8870         do iii=1,2
8871           do kkk=1,5
8872             do lll=1,3
8873               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
8874      &          pizda(1,1))
8875               vv(1)=pizda(1,1)+pizda(2,2)
8876               vv(2)=pizda(2,1)-pizda(1,2)
8877               derx(lll,kkk,iii)=derx(lll,kkk,iii)
8878      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,l))
8879      &         -0.5d0*scalar2(vv(1),Ctobr(1,l))
8880             enddo
8881           enddo
8882         enddo
8883       else
8884 C Antiparallel orientation
8885 C Contribution from graph III
8886 c        goto 1110
8887         call transpose2(EUg(1,1,j),auxmat(1,1))
8888         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
8889         vv(1)=pizda(1,1)-pizda(2,2)
8890         vv(2)=pizda(1,2)+pizda(2,1)
8891         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j))
8892      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l))
8893 C Explicit gradient in virtual-dihedral angles.
8894         g_corr5_loc(l-1)=g_corr5_loc(l-1)
8895      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j))
8896      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
8897         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
8898         vv(1)=pizda(1,1)-pizda(2,2)
8899         vv(2)=pizda(1,2)+pizda(2,1)
8900         g_corr5_loc(k-1)=g_corr5_loc(k-1)
8901      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j))
8902      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
8903         call transpose2(EUgder(1,1,j),auxmat1(1,1))
8904         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
8905         vv(1)=pizda(1,1)-pizda(2,2)
8906         vv(2)=pizda(1,2)+pizda(2,1)
8907         g_corr5_loc(j-1)=g_corr5_loc(j-1)
8908      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j))
8909      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
8910 C Cartesian gradient
8911         do iii=1,2
8912           do kkk=1,5
8913             do lll=1,3
8914               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
8915      &          pizda(1,1))
8916               vv(1)=pizda(1,1)-pizda(2,2)
8917               vv(2)=pizda(1,2)+pizda(2,1)
8918               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
8919      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j))
8920      &         +0.5d0*scalar2(vv(1),Dtobr2(1,l))
8921             enddo
8922           enddo
8923         enddo
8924 cd        goto 1112
8925 C Contribution from graph IV
8926 1110    continue
8927         call transpose2(EE(1,1,itj),auxmat(1,1))
8928         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
8929         vv(1)=pizda(1,1)+pizda(2,2)
8930         vv(2)=pizda(2,1)-pizda(1,2)
8931         eello5_4=scalar2(AEAb1(1,2,2),b1(1,j))
8932      &   -0.5d0*scalar2(vv(1),Ctobr(1,j))
8933 C Explicit gradient in virtual-dihedral angles.
8934         g_corr5_loc(j-1)=g_corr5_loc(j-1)
8935      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
8936         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
8937         vv(1)=pizda(1,1)+pizda(2,2)
8938         vv(2)=pizda(2,1)-pizda(1,2)
8939         g_corr5_loc(k-1)=g_corr5_loc(k-1)
8940      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,j))
8941      &   -0.5d0*scalar2(vv(1),Ctobr(1,j)))
8942 C Cartesian gradient
8943         do iii=1,2
8944           do kkk=1,5
8945             do lll=1,3
8946               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
8947      &          pizda(1,1))
8948               vv(1)=pizda(1,1)+pizda(2,2)
8949               vv(2)=pizda(2,1)-pizda(1,2)
8950               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
8951      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,j))
8952      &         -0.5d0*scalar2(vv(1),Ctobr(1,j))
8953             enddo
8954           enddo
8955         enddo
8956       endif
8957 1112  continue
8958       eel5=eello5_1+eello5_2+eello5_3+eello5_4
8959 cd      if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
8960 cd        write (2,*) 'ijkl',i,j,k,l
8961 cd        write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
8962 cd     &     ' eello5_3',eello5_3,' eello5_4',eello5_4
8963 cd      endif
8964 cd      write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
8965 cd      write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
8966 cd      write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
8967 cd      write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
8968       if (j.lt.nres-1) then
8969         j1=j+1
8970         j2=j-1
8971       else
8972         j1=j-1
8973         j2=j-2
8974       endif
8975       if (l.lt.nres-1) then
8976         l1=l+1
8977         l2=l-1
8978       else
8979         l1=l-1
8980         l2=l-2
8981       endif
8982 cd      eij=1.0d0
8983 cd      ekl=1.0d0
8984 cd      ekont=1.0d0
8985 cd      write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
8986 C 2/11/08 AL Gradients over DC's connecting interacting sites will be
8987 C        summed up outside the subrouine as for the other subroutines
8988 C        handling long-range interactions. The old code is commented out
8989 C        with "cgrad" to keep track of changes.
8990       do ll=1,3
8991 cgrad        ggg1(ll)=eel5*g_contij(ll,1)
8992 cgrad        ggg2(ll)=eel5*g_contij(ll,2)
8993         gradcorr5ij=eel5*g_contij(ll,1)+ekont*derx(ll,1,1)
8994         gradcorr5kl=eel5*g_contij(ll,2)+ekont*derx(ll,1,2)
8995 c        write (iout,'(a,3i3,a,5f8.3,2i3,a,5f8.3,a,f8.3)')
8996 c     &   "ecorr5",ll,i,j," derx",derx(ll,2,1),derx(ll,3,1),derx(ll,4,1),
8997 c     &   derx(ll,5,1),k,l," derx",derx(ll,2,2),derx(ll,3,2),
8998 c     &   derx(ll,4,2),derx(ll,5,2)," ekont",ekont
8999 c        write (iout,'(a,3i3,a,3f8.3,2i3,a,3f8.3)')
9000 c     &   "ecorr5",ll,i,j," gradcorr5",g_contij(ll,1),derx(ll,1,1),
9001 c     &   gradcorr5ij,
9002 c     &   k,l," gradcorr5",g_contij(ll,2),derx(ll,1,2),gradcorr5kl
9003 cold        ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
9004 cgrad        ghalf=0.5d0*ggg1(ll)
9005 cd        ghalf=0.0d0
9006         gradcorr5(ll,i)=gradcorr5(ll,i)+ekont*derx(ll,2,1)
9007         gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
9008         gradcorr5(ll,j)=gradcorr5(ll,j)+ekont*derx(ll,4,1)
9009         gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
9010         gradcorr5_long(ll,j)=gradcorr5_long(ll,j)+gradcorr5ij
9011         gradcorr5_long(ll,i)=gradcorr5_long(ll,i)-gradcorr5ij
9012 cold        ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
9013 cgrad        ghalf=0.5d0*ggg2(ll)
9014 cd        ghalf=0.0d0
9015         gradcorr5(ll,k)=gradcorr5(ll,k)+ekont*derx(ll,2,2)
9016         gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
9017         gradcorr5(ll,l)=gradcorr5(ll,l)+ekont*derx(ll,4,2)
9018         gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
9019         gradcorr5_long(ll,l)=gradcorr5_long(ll,l)+gradcorr5kl
9020         gradcorr5_long(ll,k)=gradcorr5_long(ll,k)-gradcorr5kl
9021       enddo
9022 cd      goto 1112
9023 cgrad      do m=i+1,j-1
9024 cgrad        do ll=1,3
9025 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
9026 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
9027 cgrad        enddo
9028 cgrad      enddo
9029 cgrad      do m=k+1,l-1
9030 cgrad        do ll=1,3
9031 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
9032 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
9033 cgrad        enddo
9034 cgrad      enddo
9035 c1112  continue
9036 cgrad      do m=i+2,j2
9037 cgrad        do ll=1,3
9038 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
9039 cgrad        enddo
9040 cgrad      enddo
9041 cgrad      do m=k+2,l2
9042 cgrad        do ll=1,3
9043 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
9044 cgrad        enddo
9045 cgrad      enddo
9046 cd      do iii=1,nres-3
9047 cd        write (2,*) iii,g_corr5_loc(iii)
9048 cd      enddo
9049       eello5=ekont*eel5
9050 cd      write (2,*) 'ekont',ekont
9051 cd      write (iout,*) 'eello5',ekont*eel5
9052       return
9053       end
9054 c--------------------------------------------------------------------------
9055       double precision function eello6(i,j,k,l,jj,kk)
9056       implicit real*8 (a-h,o-z)
9057       include 'DIMENSIONS'
9058       include 'COMMON.IOUNITS'
9059       include 'COMMON.CHAIN'
9060       include 'COMMON.DERIV'
9061       include 'COMMON.INTERACT'
9062       include 'COMMON.CONTACTS'
9063       include 'COMMON.TORSION'
9064       include 'COMMON.VAR'
9065       include 'COMMON.GEO'
9066       include 'COMMON.FFIELD'
9067       double precision ggg1(3),ggg2(3)
9068 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
9069 cd        eello6=0.0d0
9070 cd        return
9071 cd      endif
9072 cd      write (iout,*)
9073 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
9074 cd     &   ' and',k,l
9075       eello6_1=0.0d0
9076       eello6_2=0.0d0
9077       eello6_3=0.0d0
9078       eello6_4=0.0d0
9079       eello6_5=0.0d0
9080       eello6_6=0.0d0
9081 cd      call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
9082 cd     &   eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
9083       do iii=1,2
9084         do kkk=1,5
9085           do lll=1,3
9086             derx(lll,kkk,iii)=0.0d0
9087           enddo
9088         enddo
9089       enddo
9090 cd      eij=facont_hb(jj,i)
9091 cd      ekl=facont_hb(kk,k)
9092 cd      ekont=eij*ekl
9093 cd      eij=1.0d0
9094 cd      ekl=1.0d0
9095 cd      ekont=1.0d0
9096       if (l.eq.j+1) then
9097         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
9098         eello6_2=eello6_graph1(j,i,l,k,2,.false.)
9099         eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
9100         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
9101         eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
9102         eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
9103       else
9104         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
9105         eello6_2=eello6_graph1(l,k,j,i,2,.true.)
9106         eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
9107         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
9108         if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
9109           eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
9110         else
9111           eello6_5=0.0d0
9112         endif
9113         eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
9114       endif
9115 C If turn contributions are considered, they will be handled separately.
9116       eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
9117 cd      write(iout,*) 'eello6_1',eello6_1!,' eel6_1_num',16*eel6_1_num
9118 cd      write(iout,*) 'eello6_2',eello6_2!,' eel6_2_num',16*eel6_2_num
9119 cd      write(iout,*) 'eello6_3',eello6_3!,' eel6_3_num',16*eel6_3_num
9120 cd      write(iout,*) 'eello6_4',eello6_4!,' eel6_4_num',16*eel6_4_num
9121 cd      write(iout,*) 'eello6_5',eello6_5!,' eel6_5_num',16*eel6_5_num
9122 cd      write(iout,*) 'eello6_6',eello6_6!,' eel6_6_num',16*eel6_6_num
9123 cd      goto 1112
9124       if (j.lt.nres-1) then
9125         j1=j+1
9126         j2=j-1
9127       else
9128         j1=j-1
9129         j2=j-2
9130       endif
9131       if (l.lt.nres-1) then
9132         l1=l+1
9133         l2=l-1
9134       else
9135         l1=l-1
9136         l2=l-2
9137       endif
9138       do ll=1,3
9139 cgrad        ggg1(ll)=eel6*g_contij(ll,1)
9140 cgrad        ggg2(ll)=eel6*g_contij(ll,2)
9141 cold        ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
9142 cgrad        ghalf=0.5d0*ggg1(ll)
9143 cd        ghalf=0.0d0
9144         gradcorr6ij=eel6*g_contij(ll,1)+ekont*derx(ll,1,1)
9145         gradcorr6kl=eel6*g_contij(ll,2)+ekont*derx(ll,1,2)
9146         gradcorr6(ll,i)=gradcorr6(ll,i)+ekont*derx(ll,2,1)
9147         gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
9148         gradcorr6(ll,j)=gradcorr6(ll,j)+ekont*derx(ll,4,1)
9149         gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
9150         gradcorr6_long(ll,j)=gradcorr6_long(ll,j)+gradcorr6ij
9151         gradcorr6_long(ll,i)=gradcorr6_long(ll,i)-gradcorr6ij
9152 cgrad        ghalf=0.5d0*ggg2(ll)
9153 cold        ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
9154 cd        ghalf=0.0d0
9155         gradcorr6(ll,k)=gradcorr6(ll,k)+ekont*derx(ll,2,2)
9156         gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
9157         gradcorr6(ll,l)=gradcorr6(ll,l)+ekont*derx(ll,4,2)
9158         gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
9159         gradcorr6_long(ll,l)=gradcorr6_long(ll,l)+gradcorr6kl
9160         gradcorr6_long(ll,k)=gradcorr6_long(ll,k)-gradcorr6kl
9161       enddo
9162 cd      goto 1112
9163 cgrad      do m=i+1,j-1
9164 cgrad        do ll=1,3
9165 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
9166 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
9167 cgrad        enddo
9168 cgrad      enddo
9169 cgrad      do m=k+1,l-1
9170 cgrad        do ll=1,3
9171 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
9172 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
9173 cgrad        enddo
9174 cgrad      enddo
9175 cgrad1112  continue
9176 cgrad      do m=i+2,j2
9177 cgrad        do ll=1,3
9178 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
9179 cgrad        enddo
9180 cgrad      enddo
9181 cgrad      do m=k+2,l2
9182 cgrad        do ll=1,3
9183 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
9184 cgrad        enddo
9185 cgrad      enddo
9186 cd      do iii=1,nres-3
9187 cd        write (2,*) iii,g_corr6_loc(iii)
9188 cd      enddo
9189       eello6=ekont*eel6
9190 cd      write (2,*) 'ekont',ekont
9191 cd      write (iout,*) 'eello6',ekont*eel6
9192       return
9193       end
9194 c--------------------------------------------------------------------------
9195       double precision function eello6_graph1(i,j,k,l,imat,swap)
9196       implicit real*8 (a-h,o-z)
9197       include 'DIMENSIONS'
9198       include 'COMMON.IOUNITS'
9199       include 'COMMON.CHAIN'
9200       include 'COMMON.DERIV'
9201       include 'COMMON.INTERACT'
9202       include 'COMMON.CONTACTS'
9203       include 'COMMON.TORSION'
9204       include 'COMMON.VAR'
9205       include 'COMMON.GEO'
9206       double precision vv(2),vv1(2),pizda(2,2),auxmat(2,2),pizda1(2,2)
9207       logical swap
9208       logical lprn
9209       common /kutas/ lprn
9210 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9211 C                                                                              C
9212 C      Parallel       Antiparallel                                             C
9213 C                                                                              C
9214 C          o             o                                                     C
9215 C         /l\           /j\                                                    C
9216 C        /   \         /   \                                                   C
9217 C       /| o |         | o |\                                                  C
9218 C     \ j|/k\|  /   \  |/k\|l /                                                C
9219 C      \ /   \ /     \ /   \ /                                                 C
9220 C       o     o       o     o                                                  C
9221 C       i             i                                                        C
9222 C                                                                              C
9223 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9224       itk=itortyp(itype(k))
9225       s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
9226       s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
9227       s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
9228       call transpose2(EUgC(1,1,k),auxmat(1,1))
9229       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
9230       vv1(1)=pizda1(1,1)-pizda1(2,2)
9231       vv1(2)=pizda1(1,2)+pizda1(2,1)
9232       s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
9233       vv(1)=AEAb1(1,2,imat)*b1(1,k)-AEAb1(2,2,imat)*b1(2,k)
9234       vv(2)=AEAb1(1,2,imat)*b1(2,k)+AEAb1(2,2,imat)*b1(1,k)
9235       s5=scalar2(vv(1),Dtobr2(1,i))
9236 cd      write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
9237       eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
9238       if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1)
9239      & -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i))
9240      & -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k))
9241      & +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k))
9242      & +0.5d0*scalar2(vv1(1),Dtobr2der(1,i))
9243      & +scalar2(vv(1),Dtobr2der(1,i)))
9244       call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
9245       vv1(1)=pizda1(1,1)-pizda1(2,2)
9246       vv1(2)=pizda1(1,2)+pizda1(2,1)
9247       vv(1)=AEAb1derg(1,2,imat)*b1(1,k)-AEAb1derg(2,2,imat)*b1(2,k)
9248       vv(2)=AEAb1derg(1,2,imat)*b1(2,k)+AEAb1derg(2,2,imat)*b1(1,k)
9249       if (l.eq.j+1) then
9250         g_corr6_loc(l-1)=g_corr6_loc(l-1)
9251      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
9252      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
9253      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
9254      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
9255       else
9256         g_corr6_loc(j-1)=g_corr6_loc(j-1)
9257      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
9258      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
9259      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
9260      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
9261       endif
9262       call transpose2(EUgCder(1,1,k),auxmat(1,1))
9263       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
9264       vv1(1)=pizda1(1,1)-pizda1(2,2)
9265       vv1(2)=pizda1(1,2)+pizda1(2,1)
9266       if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1)
9267      & +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k))
9268      & +scalar2(AEAb2(1,1,imat),CUgb2der(1,k))
9269      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
9270       do iii=1,2
9271         if (swap) then
9272           ind=3-iii
9273         else
9274           ind=iii
9275         endif
9276         do kkk=1,5
9277           do lll=1,3
9278             s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
9279             s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
9280             s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
9281             call transpose2(EUgC(1,1,k),auxmat(1,1))
9282             call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
9283      &        pizda1(1,1))
9284             vv1(1)=pizda1(1,1)-pizda1(2,2)
9285             vv1(2)=pizda1(1,2)+pizda1(2,1)
9286             s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
9287             vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,k)
9288      &       -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,k)
9289             vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,k)
9290      &       +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,k)
9291             s5=scalar2(vv(1),Dtobr2(1,i))
9292             derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
9293           enddo
9294         enddo
9295       enddo
9296       return
9297       end
9298 c----------------------------------------------------------------------------
9299       double precision function eello6_graph2(i,j,k,l,jj,kk,swap)
9300       implicit real*8 (a-h,o-z)
9301       include 'DIMENSIONS'
9302       include 'COMMON.IOUNITS'
9303       include 'COMMON.CHAIN'
9304       include 'COMMON.DERIV'
9305       include 'COMMON.INTERACT'
9306       include 'COMMON.CONTACTS'
9307       include 'COMMON.TORSION'
9308       include 'COMMON.VAR'
9309       include 'COMMON.GEO'
9310       logical swap
9311       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
9312      & auxvec1(2),auxvec2(2),auxmat1(2,2)
9313       logical lprn
9314       common /kutas/ lprn
9315 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9316 C                                                                              C
9317 C      Parallel       Antiparallel                                             C
9318 C                                                                              C
9319 C          o             o                                                     C
9320 C     \   /l\           /j\   /                                                C
9321 C      \ /   \         /   \ /                                                 C
9322 C       o| o |         | o |o                                                  C
9323 C     \ j|/k\|      \  |/k\|l                                                  C
9324 C      \ /   \       \ /   \                                                   C
9325 C       o             o                                                        C
9326 C       i             i                                                        C
9327 C                                                                              C
9328 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9329 cd      write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
9330 C AL 7/4/01 s1 would occur in the sixth-order moment,
9331 C           but not in a cluster cumulant
9332 #ifdef MOMENT
9333       s1=dip(1,jj,i)*dip(1,kk,k)
9334 #endif
9335       call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
9336       s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
9337       call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
9338       s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
9339       call transpose2(EUg(1,1,k),auxmat(1,1))
9340       call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
9341       vv(1)=pizda(1,1)-pizda(2,2)
9342       vv(2)=pizda(1,2)+pizda(2,1)
9343       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
9344 cd      write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
9345 #ifdef MOMENT
9346       eello6_graph2=-(s1+s2+s3+s4)
9347 #else
9348       eello6_graph2=-(s2+s3+s4)
9349 #endif
9350 c      eello6_graph2=-s3
9351 C Derivatives in gamma(i-1)
9352       if (i.gt.1) then
9353 #ifdef MOMENT
9354         s1=dipderg(1,jj,i)*dip(1,kk,k)
9355 #endif
9356         s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
9357         call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
9358         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
9359         s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
9360 #ifdef MOMENT
9361         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
9362 #else
9363         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
9364 #endif
9365 c        g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
9366       endif
9367 C Derivatives in gamma(k-1)
9368 #ifdef MOMENT
9369       s1=dip(1,jj,i)*dipderg(1,kk,k)
9370 #endif
9371       call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
9372       s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
9373       call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
9374       s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
9375       call transpose2(EUgder(1,1,k),auxmat1(1,1))
9376       call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
9377       vv(1)=pizda(1,1)-pizda(2,2)
9378       vv(2)=pizda(1,2)+pizda(2,1)
9379       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
9380 #ifdef MOMENT
9381       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
9382 #else
9383       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
9384 #endif
9385 c      g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
9386 C Derivatives in gamma(j-1) or gamma(l-1)
9387       if (j.gt.1) then
9388 #ifdef MOMENT
9389         s1=dipderg(3,jj,i)*dip(1,kk,k)
9390 #endif
9391         call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
9392         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
9393         s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
9394         call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
9395         vv(1)=pizda(1,1)-pizda(2,2)
9396         vv(2)=pizda(1,2)+pizda(2,1)
9397         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
9398 #ifdef MOMENT
9399         if (swap) then
9400           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
9401         else
9402           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
9403         endif
9404 #endif
9405         g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
9406 c        g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
9407       endif
9408 C Derivatives in gamma(l-1) or gamma(j-1)
9409       if (l.gt.1) then
9410 #ifdef MOMENT
9411         s1=dip(1,jj,i)*dipderg(3,kk,k)
9412 #endif
9413         call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
9414         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
9415         call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
9416         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
9417         call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
9418         vv(1)=pizda(1,1)-pizda(2,2)
9419         vv(2)=pizda(1,2)+pizda(2,1)
9420         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
9421 #ifdef MOMENT
9422         if (swap) then
9423           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
9424         else
9425           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
9426         endif
9427 #endif
9428         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
9429 c        g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
9430       endif
9431 C Cartesian derivatives.
9432       if (lprn) then
9433         write (2,*) 'In eello6_graph2'
9434         do iii=1,2
9435           write (2,*) 'iii=',iii
9436           do kkk=1,5
9437             write (2,*) 'kkk=',kkk
9438             do jjj=1,2
9439               write (2,'(3(2f10.5),5x)')
9440      &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
9441             enddo
9442           enddo
9443         enddo
9444       endif
9445       do iii=1,2
9446         do kkk=1,5
9447           do lll=1,3
9448 #ifdef MOMENT
9449             if (iii.eq.1) then
9450               s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
9451             else
9452               s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
9453             endif
9454 #endif
9455             call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),
9456      &        auxvec(1))
9457             s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
9458             call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),
9459      &        auxvec(1))
9460             s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
9461             call transpose2(EUg(1,1,k),auxmat(1,1))
9462             call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),
9463      &        pizda(1,1))
9464             vv(1)=pizda(1,1)-pizda(2,2)
9465             vv(2)=pizda(1,2)+pizda(2,1)
9466             s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
9467 cd            write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
9468 #ifdef MOMENT
9469             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
9470 #else
9471             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
9472 #endif
9473             if (swap) then
9474               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
9475             else
9476               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
9477             endif
9478           enddo
9479         enddo
9480       enddo
9481       return
9482       end
9483 c----------------------------------------------------------------------------
9484       double precision function eello6_graph3(i,j,k,l,jj,kk,swap)
9485       implicit real*8 (a-h,o-z)
9486       include 'DIMENSIONS'
9487       include 'COMMON.IOUNITS'
9488       include 'COMMON.CHAIN'
9489       include 'COMMON.DERIV'
9490       include 'COMMON.INTERACT'
9491       include 'COMMON.CONTACTS'
9492       include 'COMMON.TORSION'
9493       include 'COMMON.VAR'
9494       include 'COMMON.GEO'
9495       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2)
9496       logical swap
9497 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9498 C                                                                              C
9499 C      Parallel       Antiparallel                                             C
9500 C                                                                              C
9501 C          o             o                                                     C
9502 C         /l\   /   \   /j\                                                    C
9503 C        /   \ /     \ /   \                                                   C
9504 C       /| o |o       o| o |\                                                  C
9505 C       j|/k\|  /      |/k\|l /                                                C
9506 C        /   \ /       /   \ /                                                 C
9507 C       /     o       /     o                                                  C
9508 C       i             i                                                        C
9509 C                                                                              C
9510 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9511 C
9512 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
9513 C           energy moment and not to the cluster cumulant.
9514       iti=itortyp(itype(i))
9515       if (j.lt.nres-1) then
9516         itj1=itortyp(itype(j+1))
9517       else
9518         itj1=ntortyp
9519       endif
9520       itk=itortyp(itype(k))
9521       itk1=itortyp(itype(k+1))
9522       if (l.lt.nres-1) then
9523         itl1=itortyp(itype(l+1))
9524       else
9525         itl1=ntortyp
9526       endif
9527 #ifdef MOMENT
9528       s1=dip(4,jj,i)*dip(4,kk,k)
9529 #endif
9530       call matvec2(AECA(1,1,1),b1(1,k+1),auxvec(1))
9531       s2=0.5d0*scalar2(b1(1,k),auxvec(1))
9532       call matvec2(AECA(1,1,2),b1(1,l+1),auxvec(1))
9533       s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
9534       call transpose2(EE(1,1,itk),auxmat(1,1))
9535       call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
9536       vv(1)=pizda(1,1)+pizda(2,2)
9537       vv(2)=pizda(2,1)-pizda(1,2)
9538       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
9539 cd      write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4,
9540 cd     & "sum",-(s2+s3+s4)
9541 #ifdef MOMENT
9542       eello6_graph3=-(s1+s2+s3+s4)
9543 #else
9544       eello6_graph3=-(s2+s3+s4)
9545 #endif
9546 c      eello6_graph3=-s4
9547 C Derivatives in gamma(k-1)
9548       call matvec2(AECAderg(1,1,2),b1(1,l+1),auxvec(1))
9549       s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
9550       s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
9551       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
9552 C Derivatives in gamma(l-1)
9553       call matvec2(AECAderg(1,1,1),b1(1,k+1),auxvec(1))
9554       s2=0.5d0*scalar2(b1(1,k),auxvec(1))
9555       call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
9556       vv(1)=pizda(1,1)+pizda(2,2)
9557       vv(2)=pizda(2,1)-pizda(1,2)
9558       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
9559       g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
9560 C Cartesian derivatives.
9561       do iii=1,2
9562         do kkk=1,5
9563           do lll=1,3
9564 #ifdef MOMENT
9565             if (iii.eq.1) then
9566               s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
9567             else
9568               s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
9569             endif
9570 #endif
9571             call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
9572      &        auxvec(1))
9573             s2=0.5d0*scalar2(b1(1,k),auxvec(1))
9574             call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,l+1),
9575      &        auxvec(1))
9576             s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
9577             call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),
9578      &        pizda(1,1))
9579             vv(1)=pizda(1,1)+pizda(2,2)
9580             vv(2)=pizda(2,1)-pizda(1,2)
9581             s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
9582 #ifdef MOMENT
9583             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
9584 #else
9585             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
9586 #endif
9587             if (swap) then
9588               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
9589             else
9590               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
9591             endif
9592 c            derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
9593           enddo
9594         enddo
9595       enddo
9596       return
9597       end
9598 c----------------------------------------------------------------------------
9599       double precision function eello6_graph4(i,j,k,l,jj,kk,imat,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       include 'COMMON.FFIELD'
9611       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
9612      & auxvec1(2),auxmat1(2,2)
9613       logical swap
9614 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9615 C                                                                              C
9616 C      Parallel       Antiparallel                                             C
9617 C                                                                              C
9618 C          o             o                                                     C
9619 C         /l\   /   \   /j\                                                    C
9620 C        /   \ /     \ /   \                                                   C
9621 C       /| o |o       o| o |\                                                  C
9622 C     \ j|/k\|      \  |/k\|l                                                  C
9623 C      \ /   \       \ /   \                                                   C
9624 C       o     \       o     \                                                  C
9625 C       i             i                                                        C
9626 C                                                                              C
9627 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9628 C
9629 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
9630 C           energy moment and not to the cluster cumulant.
9631 cd      write (2,*) 'eello_graph4: wturn6',wturn6
9632       iti=itortyp(itype(i))
9633       itj=itortyp(itype(j))
9634       if (j.lt.nres-1) then
9635         itj1=itortyp(itype(j+1))
9636       else
9637         itj1=ntortyp
9638       endif
9639       itk=itortyp(itype(k))
9640       if (k.lt.nres-1) then
9641         itk1=itortyp(itype(k+1))
9642       else
9643         itk1=ntortyp
9644       endif
9645       itl=itortyp(itype(l))
9646       if (l.lt.nres-1) then
9647         itl1=itortyp(itype(l+1))
9648       else
9649         itl1=ntortyp
9650       endif
9651 cd      write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
9652 cd      write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
9653 cd     & ' itl',itl,' itl1',itl1
9654 #ifdef MOMENT
9655       if (imat.eq.1) then
9656         s1=dip(3,jj,i)*dip(3,kk,k)
9657       else
9658         s1=dip(2,jj,j)*dip(2,kk,l)
9659       endif
9660 #endif
9661       call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
9662       s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
9663       if (j.eq.l+1) then
9664         call matvec2(ADtEA1(1,1,3-imat),b1(1,j+1),auxvec1(1))
9665         s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
9666       else
9667         call matvec2(ADtEA1(1,1,3-imat),b1(1,l+1),auxvec1(1))
9668         s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
9669       endif
9670       call transpose2(EUg(1,1,k),auxmat(1,1))
9671       call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
9672       vv(1)=pizda(1,1)-pizda(2,2)
9673       vv(2)=pizda(2,1)+pizda(1,2)
9674       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9675 cd      write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
9676 #ifdef MOMENT
9677       eello6_graph4=-(s1+s2+s3+s4)
9678 #else
9679       eello6_graph4=-(s2+s3+s4)
9680 #endif
9681 C Derivatives in gamma(i-1)
9682       if (i.gt.1) then
9683 #ifdef MOMENT
9684         if (imat.eq.1) then
9685           s1=dipderg(2,jj,i)*dip(3,kk,k)
9686         else
9687           s1=dipderg(4,jj,j)*dip(2,kk,l)
9688         endif
9689 #endif
9690         s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
9691         if (j.eq.l+1) then
9692           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,j+1),auxvec1(1))
9693           s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
9694         else
9695           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,l+1),auxvec1(1))
9696           s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
9697         endif
9698         s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
9699         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
9700 cd          write (2,*) 'turn6 derivatives'
9701 #ifdef MOMENT
9702           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
9703 #else
9704           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
9705 #endif
9706         else
9707 #ifdef MOMENT
9708           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
9709 #else
9710           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
9711 #endif
9712         endif
9713       endif
9714 C Derivatives in gamma(k-1)
9715 #ifdef MOMENT
9716       if (imat.eq.1) then
9717         s1=dip(3,jj,i)*dipderg(2,kk,k)
9718       else
9719         s1=dip(2,jj,j)*dipderg(4,kk,l)
9720       endif
9721 #endif
9722       call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
9723       s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
9724       if (j.eq.l+1) then
9725         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,j+1),auxvec1(1))
9726         s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
9727       else
9728         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,l+1),auxvec1(1))
9729         s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
9730       endif
9731       call transpose2(EUgder(1,1,k),auxmat1(1,1))
9732       call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
9733       vv(1)=pizda(1,1)-pizda(2,2)
9734       vv(2)=pizda(2,1)+pizda(1,2)
9735       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9736       if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
9737 #ifdef MOMENT
9738         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
9739 #else
9740         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
9741 #endif
9742       else
9743 #ifdef MOMENT
9744         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
9745 #else
9746         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
9747 #endif
9748       endif
9749 C Derivatives in gamma(j-1) or gamma(l-1)
9750       if (l.eq.j+1 .and. l.gt.1) then
9751         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
9752         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
9753         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
9754         vv(1)=pizda(1,1)-pizda(2,2)
9755         vv(2)=pizda(2,1)+pizda(1,2)
9756         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9757         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
9758       else if (j.gt.1) then
9759         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
9760         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
9761         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
9762         vv(1)=pizda(1,1)-pizda(2,2)
9763         vv(2)=pizda(2,1)+pizda(1,2)
9764         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9765         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
9766           gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
9767         else
9768           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
9769         endif
9770       endif
9771 C Cartesian derivatives.
9772       do iii=1,2
9773         do kkk=1,5
9774           do lll=1,3
9775 #ifdef MOMENT
9776             if (iii.eq.1) then
9777               if (imat.eq.1) then
9778                 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
9779               else
9780                 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
9781               endif
9782             else
9783               if (imat.eq.1) then
9784                 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
9785               else
9786                 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
9787               endif
9788             endif
9789 #endif
9790             call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),
9791      &        auxvec(1))
9792             s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
9793             if (j.eq.l+1) then
9794               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
9795      &          b1(1,j+1),auxvec(1))
9796               s3=-0.5d0*scalar2(b1(1,j),auxvec(1))
9797             else
9798               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
9799      &          b1(1,l+1),auxvec(1))
9800               s3=-0.5d0*scalar2(b1(1,l),auxvec(1))
9801             endif
9802             call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
9803      &        pizda(1,1))
9804             vv(1)=pizda(1,1)-pizda(2,2)
9805             vv(2)=pizda(2,1)+pizda(1,2)
9806             s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9807             if (swap) then
9808               if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
9809 #ifdef MOMENT
9810                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
9811      &             -(s1+s2+s4)
9812 #else
9813                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
9814      &             -(s2+s4)
9815 #endif
9816                 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
9817               else
9818 #ifdef MOMENT
9819                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
9820 #else
9821                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
9822 #endif
9823                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
9824               endif
9825             else
9826 #ifdef MOMENT
9827               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
9828 #else
9829               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
9830 #endif
9831               if (l.eq.j+1) then
9832                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
9833               else
9834                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
9835               endif
9836             endif
9837           enddo
9838         enddo
9839       enddo
9840       return
9841       end
9842 c----------------------------------------------------------------------------
9843       double precision function eello_turn6(i,jj,kk)
9844       implicit real*8 (a-h,o-z)
9845       include 'DIMENSIONS'
9846       include 'COMMON.IOUNITS'
9847       include 'COMMON.CHAIN'
9848       include 'COMMON.DERIV'
9849       include 'COMMON.INTERACT'
9850       include 'COMMON.CONTACTS'
9851       include 'COMMON.TORSION'
9852       include 'COMMON.VAR'
9853       include 'COMMON.GEO'
9854       double precision vtemp1(2),vtemp2(2),vtemp3(2),vtemp4(2),
9855      &  atemp(2,2),auxmat(2,2),achuj_temp(2,2),gtemp(2,2),gvec(2),
9856      &  ggg1(3),ggg2(3)
9857       double precision vtemp1d(2),vtemp2d(2),vtemp3d(2),vtemp4d(2),
9858      &  atempd(2,2),auxmatd(2,2),achuj_tempd(2,2),gtempd(2,2),gvecd(2)
9859 C 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
9860 C           the respective energy moment and not to the cluster cumulant.
9861       s1=0.0d0
9862       s8=0.0d0
9863       s13=0.0d0
9864 c
9865       eello_turn6=0.0d0
9866       j=i+4
9867       k=i+1
9868       l=i+3
9869       iti=itortyp(itype(i))
9870       itk=itortyp(itype(k))
9871       itk1=itortyp(itype(k+1))
9872       itl=itortyp(itype(l))
9873       itj=itortyp(itype(j))
9874 cd      write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
9875 cd      write (2,*) 'i',i,' k',k,' j',j,' l',l
9876 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
9877 cd        eello6=0.0d0
9878 cd        return
9879 cd      endif
9880 cd      write (iout,*)
9881 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
9882 cd     &   ' and',k,l
9883 cd      call checkint_turn6(i,jj,kk,eel_turn6_num)
9884       do iii=1,2
9885         do kkk=1,5
9886           do lll=1,3
9887             derx_turn(lll,kkk,iii)=0.0d0
9888           enddo
9889         enddo
9890       enddo
9891 cd      eij=1.0d0
9892 cd      ekl=1.0d0
9893 cd      ekont=1.0d0
9894       eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
9895 cd      eello6_5=0.0d0
9896 cd      write (2,*) 'eello6_5',eello6_5
9897 #ifdef MOMENT
9898       call transpose2(AEA(1,1,1),auxmat(1,1))
9899       call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
9900       ss1=scalar2(Ub2(1,i+2),b1(1,l))
9901       s1 = (auxmat(1,1)+auxmat(2,2))*ss1
9902 #endif
9903       call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1(1))
9904       call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
9905       s2 = scalar2(b1(1,k),vtemp1(1))
9906 #ifdef MOMENT
9907       call transpose2(AEA(1,1,2),atemp(1,1))
9908       call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
9909       call matvec2(Ug2(1,1,i+2),dd(1,1,itk1),vtemp2(1))
9910       s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
9911 #endif
9912       call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
9913       call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
9914       s12 = scalar2(Ub2(1,i+2),vtemp3(1))
9915 #ifdef MOMENT
9916       call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
9917       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
9918       call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
9919       call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
9920       ss13 = scalar2(b1(1,k),vtemp4(1))
9921       s13 = (gtemp(1,1)+gtemp(2,2))*ss13
9922 #endif
9923 c      write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
9924 c      s1=0.0d0
9925 c      s2=0.0d0
9926 c      s8=0.0d0
9927 c      s12=0.0d0
9928 c      s13=0.0d0
9929       eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
9930 C Derivatives in gamma(i+2)
9931       s1d =0.0d0
9932       s8d =0.0d0
9933 #ifdef MOMENT
9934       call transpose2(AEA(1,1,1),auxmatd(1,1))
9935       call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
9936       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
9937       call transpose2(AEAderg(1,1,2),atempd(1,1))
9938       call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
9939       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
9940 #endif
9941       call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
9942       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
9943       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
9944 c      s1d=0.0d0
9945 c      s2d=0.0d0
9946 c      s8d=0.0d0
9947 c      s12d=0.0d0
9948 c      s13d=0.0d0
9949       gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
9950 C Derivatives in gamma(i+3)
9951 #ifdef MOMENT
9952       call transpose2(AEA(1,1,1),auxmatd(1,1))
9953       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
9954       ss1d=scalar2(Ub2der(1,i+2),b1(1,l))
9955       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
9956 #endif
9957       call matvec2(EUgder(1,1,i+2),b1(1,l),vtemp1d(1))
9958       call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
9959       s2d = scalar2(b1(1,k),vtemp1d(1))
9960 #ifdef MOMENT
9961       call matvec2(Ug2der(1,1,i+2),dd(1,1,itk1),vtemp2d(1))
9962       s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2d(1))
9963 #endif
9964       s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
9965 #ifdef MOMENT
9966       call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
9967       call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
9968       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
9969 #endif
9970 c      s1d=0.0d0
9971 c      s2d=0.0d0
9972 c      s8d=0.0d0
9973 c      s12d=0.0d0
9974 c      s13d=0.0d0
9975 #ifdef MOMENT
9976       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
9977      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
9978 #else
9979       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
9980      &               -0.5d0*ekont*(s2d+s12d)
9981 #endif
9982 C Derivatives in gamma(i+4)
9983       call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
9984       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
9985       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
9986 #ifdef MOMENT
9987       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
9988       call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
9989       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
9990 #endif
9991 c      s1d=0.0d0
9992 c      s2d=0.0d0
9993 c      s8d=0.0d0
9994 C      s12d=0.0d0
9995 c      s13d=0.0d0
9996 #ifdef MOMENT
9997       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
9998 #else
9999       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
10000 #endif
10001 C Derivatives in gamma(i+5)
10002 #ifdef MOMENT
10003       call transpose2(AEAderg(1,1,1),auxmatd(1,1))
10004       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
10005       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
10006 #endif
10007       call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1d(1))
10008       call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
10009       s2d = scalar2(b1(1,k),vtemp1d(1))
10010 #ifdef MOMENT
10011       call transpose2(AEA(1,1,2),atempd(1,1))
10012       call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
10013       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
10014 #endif
10015       call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
10016       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
10017 #ifdef MOMENT
10018       call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
10019       ss13d = scalar2(b1(1,k),vtemp4d(1))
10020       s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
10021 #endif
10022 c      s1d=0.0d0
10023 c      s2d=0.0d0
10024 c      s8d=0.0d0
10025 c      s12d=0.0d0
10026 c      s13d=0.0d0
10027 #ifdef MOMENT
10028       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
10029      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
10030 #else
10031       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
10032      &               -0.5d0*ekont*(s2d+s12d)
10033 #endif
10034 C Cartesian derivatives
10035       do iii=1,2
10036         do kkk=1,5
10037           do lll=1,3
10038 #ifdef MOMENT
10039             call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
10040             call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
10041             s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
10042 #endif
10043             call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1(1))
10044             call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),
10045      &          vtemp1d(1))
10046             s2d = scalar2(b1(1,k),vtemp1d(1))
10047 #ifdef MOMENT
10048             call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
10049             call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
10050             s8d = -(atempd(1,1)+atempd(2,2))*
10051      &           scalar2(cc(1,1,itl),vtemp2(1))
10052 #endif
10053             call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),
10054      &           auxmatd(1,1))
10055             call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
10056             s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
10057 c      s1d=0.0d0
10058 c      s2d=0.0d0
10059 c      s8d=0.0d0
10060 c      s12d=0.0d0
10061 c      s13d=0.0d0
10062 #ifdef MOMENT
10063             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
10064      &        - 0.5d0*(s1d+s2d)
10065 #else
10066             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
10067      &        - 0.5d0*s2d
10068 #endif
10069 #ifdef MOMENT
10070             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
10071      &        - 0.5d0*(s8d+s12d)
10072 #else
10073             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
10074      &        - 0.5d0*s12d
10075 #endif
10076           enddo
10077         enddo
10078       enddo
10079 #ifdef MOMENT
10080       do kkk=1,5
10081         do lll=1,3
10082           call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),
10083      &      achuj_tempd(1,1))
10084           call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
10085           call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
10086           s13d=(gtempd(1,1)+gtempd(2,2))*ss13
10087           derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
10088           call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),
10089      &      vtemp4d(1))
10090           ss13d = scalar2(b1(1,k),vtemp4d(1))
10091           s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
10092           derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
10093         enddo
10094       enddo
10095 #endif
10096 cd      write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
10097 cd     &  16*eel_turn6_num
10098 cd      goto 1112
10099       if (j.lt.nres-1) then
10100         j1=j+1
10101         j2=j-1
10102       else
10103         j1=j-1
10104         j2=j-2
10105       endif
10106       if (l.lt.nres-1) then
10107         l1=l+1
10108         l2=l-1
10109       else
10110         l1=l-1
10111         l2=l-2
10112       endif
10113       do ll=1,3
10114 cgrad        ggg1(ll)=eel_turn6*g_contij(ll,1)
10115 cgrad        ggg2(ll)=eel_turn6*g_contij(ll,2)
10116 cgrad        ghalf=0.5d0*ggg1(ll)
10117 cd        ghalf=0.0d0
10118         gturn6ij=eel_turn6*g_contij(ll,1)+ekont*derx_turn(ll,1,1)
10119         gturn6kl=eel_turn6*g_contij(ll,2)+ekont*derx_turn(ll,1,2)
10120         gcorr6_turn(ll,i)=gcorr6_turn(ll,i)!+ghalf
10121      &    +ekont*derx_turn(ll,2,1)
10122         gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
10123         gcorr6_turn(ll,j)=gcorr6_turn(ll,j)!+ghalf
10124      &    +ekont*derx_turn(ll,4,1)
10125         gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
10126         gcorr6_turn_long(ll,j)=gcorr6_turn_long(ll,j)+gturn6ij
10127         gcorr6_turn_long(ll,i)=gcorr6_turn_long(ll,i)-gturn6ij
10128 cgrad        ghalf=0.5d0*ggg2(ll)
10129 cd        ghalf=0.0d0
10130         gcorr6_turn(ll,k)=gcorr6_turn(ll,k)!+ghalf
10131      &    +ekont*derx_turn(ll,2,2)
10132         gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
10133         gcorr6_turn(ll,l)=gcorr6_turn(ll,l)!+ghalf
10134      &    +ekont*derx_turn(ll,4,2)
10135         gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
10136         gcorr6_turn_long(ll,l)=gcorr6_turn_long(ll,l)+gturn6kl
10137         gcorr6_turn_long(ll,k)=gcorr6_turn_long(ll,k)-gturn6kl
10138       enddo
10139 cd      goto 1112
10140 cgrad      do m=i+1,j-1
10141 cgrad        do ll=1,3
10142 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
10143 cgrad        enddo
10144 cgrad      enddo
10145 cgrad      do m=k+1,l-1
10146 cgrad        do ll=1,3
10147 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
10148 cgrad        enddo
10149 cgrad      enddo
10150 cgrad1112  continue
10151 cgrad      do m=i+2,j2
10152 cgrad        do ll=1,3
10153 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
10154 cgrad        enddo
10155 cgrad      enddo
10156 cgrad      do m=k+2,l2
10157 cgrad        do ll=1,3
10158 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
10159 cgrad        enddo
10160 cgrad      enddo
10161 cd      do iii=1,nres-3
10162 cd        write (2,*) iii,g_corr6_loc(iii)
10163 cd      enddo
10164       eello_turn6=ekont*eel_turn6
10165 cd      write (2,*) 'ekont',ekont
10166 cd      write (2,*) 'eel_turn6',ekont*eel_turn6
10167       return
10168       end
10169
10170 C-----------------------------------------------------------------------------
10171       double precision function scalar(u,v)
10172 !DIR$ INLINEALWAYS scalar
10173 #ifndef OSF
10174 cDEC$ ATTRIBUTES FORCEINLINE::scalar
10175 #endif
10176       implicit none
10177       double precision u(3),v(3)
10178 cd      double precision sc
10179 cd      integer i
10180 cd      sc=0.0d0
10181 cd      do i=1,3
10182 cd        sc=sc+u(i)*v(i)
10183 cd      enddo
10184 cd      scalar=sc
10185
10186       scalar=u(1)*v(1)+u(2)*v(2)+u(3)*v(3)
10187       return
10188       end
10189 crc-------------------------------------------------
10190       SUBROUTINE MATVEC2(A1,V1,V2)
10191 !DIR$ INLINEALWAYS MATVEC2
10192 #ifndef OSF
10193 cDEC$ ATTRIBUTES FORCEINLINE::MATVEC2
10194 #endif
10195       implicit real*8 (a-h,o-z)
10196       include 'DIMENSIONS'
10197       DIMENSION A1(2,2),V1(2),V2(2)
10198 c      DO 1 I=1,2
10199 c        VI=0.0
10200 c        DO 3 K=1,2
10201 c    3     VI=VI+A1(I,K)*V1(K)
10202 c        Vaux(I)=VI
10203 c    1 CONTINUE
10204
10205       vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
10206       vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
10207
10208       v2(1)=vaux1
10209       v2(2)=vaux2
10210       END
10211 C---------------------------------------
10212       SUBROUTINE MATMAT2(A1,A2,A3)
10213 #ifndef OSF
10214 cDEC$ ATTRIBUTES FORCEINLINE::MATMAT2
10215 #endif
10216       implicit real*8 (a-h,o-z)
10217       include 'DIMENSIONS'
10218       DIMENSION A1(2,2),A2(2,2),A3(2,2)
10219 c      DIMENSION AI3(2,2)
10220 c        DO  J=1,2
10221 c          A3IJ=0.0
10222 c          DO K=1,2
10223 c           A3IJ=A3IJ+A1(I,K)*A2(K,J)
10224 c          enddo
10225 c          A3(I,J)=A3IJ
10226 c       enddo
10227 c      enddo
10228
10229       ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
10230       ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
10231       ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
10232       ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
10233
10234       A3(1,1)=AI3_11
10235       A3(2,1)=AI3_21
10236       A3(1,2)=AI3_12
10237       A3(2,2)=AI3_22
10238       END
10239
10240 c-------------------------------------------------------------------------
10241       double precision function scalar2(u,v)
10242 !DIR$ INLINEALWAYS scalar2
10243       implicit none
10244       double precision u(2),v(2)
10245       double precision sc
10246       integer i
10247       scalar2=u(1)*v(1)+u(2)*v(2)
10248       return
10249       end
10250
10251 C-----------------------------------------------------------------------------
10252
10253       subroutine transpose2(a,at)
10254 !DIR$ INLINEALWAYS transpose2
10255 #ifndef OSF
10256 cDEC$ ATTRIBUTES FORCEINLINE::transpose2
10257 #endif
10258       implicit none
10259       double precision a(2,2),at(2,2)
10260       at(1,1)=a(1,1)
10261       at(1,2)=a(2,1)
10262       at(2,1)=a(1,2)
10263       at(2,2)=a(2,2)
10264       return
10265       end
10266 c--------------------------------------------------------------------------
10267       subroutine transpose(n,a,at)
10268       implicit none
10269       integer n,i,j
10270       double precision a(n,n),at(n,n)
10271       do i=1,n
10272         do j=1,n
10273           at(j,i)=a(i,j)
10274         enddo
10275       enddo
10276       return
10277       end
10278 C---------------------------------------------------------------------------
10279       subroutine prodmat3(a1,a2,kk,transp,prod)
10280 !DIR$ INLINEALWAYS prodmat3
10281 #ifndef OSF
10282 cDEC$ ATTRIBUTES FORCEINLINE::prodmat3
10283 #endif
10284       implicit none
10285       integer i,j
10286       double precision a1(2,2),a2(2,2),a2t(2,2),kk(2,2),prod(2,2)
10287       logical transp
10288 crc      double precision auxmat(2,2),prod_(2,2)
10289
10290       if (transp) then
10291 crc        call transpose2(kk(1,1),auxmat(1,1))
10292 crc        call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
10293 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
10294
10295            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1)
10296      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
10297            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2)
10298      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
10299            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1)
10300      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
10301            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2)
10302      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
10303
10304       else
10305 crc        call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
10306 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
10307
10308            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1)
10309      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
10310            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2)
10311      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
10312            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1)
10313      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
10314            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2)
10315      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
10316
10317       endif
10318 c      call transpose2(a2(1,1),a2t(1,1))
10319
10320 crc      print *,transp
10321 crc      print *,((prod_(i,j),i=1,2),j=1,2)
10322 crc      print *,((prod(i,j),i=1,2),j=1,2)
10323
10324       return
10325       end
10326 CCC----------------------------------------------
10327       subroutine Eliptransfer(eliptran)
10328       implicit real*8 (a-h,o-z)
10329       include 'DIMENSIONS'
10330       include 'COMMON.GEO'
10331       include 'COMMON.VAR'
10332       include 'COMMON.LOCAL'
10333       include 'COMMON.CHAIN'
10334       include 'COMMON.DERIV'
10335       include 'COMMON.NAMES'
10336       include 'COMMON.INTERACT'
10337       include 'COMMON.IOUNITS'
10338       include 'COMMON.CALC'
10339       include 'COMMON.CONTROL'
10340       include 'COMMON.SPLITELE'
10341       include 'COMMON.SBRIDGE'
10342 C this is done by Adasko
10343 C      print *,"wchodze"
10344 C structure of box:
10345 C      water
10346 C--bordliptop-- buffore starts
10347 C--bufliptop--- here true lipid starts
10348 C      lipid
10349 C--buflipbot--- lipid ends buffore starts
10350 C--bordlipbot--buffore ends
10351       eliptran=0.0
10352       do i=ilip_start,ilip_end
10353 C       do i=1,1
10354         if (itype(i).eq.ntyp1) cycle
10355
10356         positi=(mod(((c(3,i)+c(3,i+1))/2.0d0),boxzsize))
10357         if (positi.le.0) positi=positi+boxzsize
10358 C        print *,i
10359 C first for peptide groups
10360 c for each residue check if it is in lipid or lipid water border area
10361        if ((positi.gt.bordlipbot)
10362      &.and.(positi.lt.bordliptop)) then
10363 C the energy transfer exist
10364         if (positi.lt.buflipbot) then
10365 C what fraction I am in
10366          fracinbuf=1.0d0-
10367      &        ((positi-bordlipbot)/lipbufthick)
10368 C lipbufthick is thickenes of lipid buffore
10369          sslip=sscalelip(fracinbuf)
10370          ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
10371          eliptran=eliptran+sslip*pepliptran
10372          gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
10373          gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
10374 C         gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
10375
10376 C        print *,"doing sccale for lower part"
10377 C         print *,i,sslip,fracinbuf,ssgradlip
10378         elseif (positi.gt.bufliptop) then
10379          fracinbuf=1.0d0-((bordliptop-positi)/lipbufthick)
10380          sslip=sscalelip(fracinbuf)
10381          ssgradlip=sscagradlip(fracinbuf)/lipbufthick
10382          eliptran=eliptran+sslip*pepliptran
10383          gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
10384          gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
10385 C         gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
10386 C          print *, "doing sscalefor top part"
10387 C         print *,i,sslip,fracinbuf,ssgradlip
10388         else
10389          eliptran=eliptran+pepliptran
10390 C         print *,"I am in true lipid"
10391         endif
10392 C       else
10393 C       eliptran=elpitran+0.0 ! I am in water
10394        endif
10395        enddo
10396 C       print *, "nic nie bylo w lipidzie?"
10397 C now multiply all by the peptide group transfer factor
10398 C       eliptran=eliptran*pepliptran
10399 C now the same for side chains
10400 CV       do i=1,1
10401        do i=ilip_start,ilip_end
10402         if (itype(i).eq.ntyp1) cycle
10403         positi=(mod(c(3,i+nres),boxzsize))
10404         if (positi.le.0) positi=positi+boxzsize
10405 C       print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop
10406 c for each residue check if it is in lipid or lipid water border area
10407 C       respos=mod(c(3,i+nres),boxzsize)
10408 C       print *,positi,bordlipbot,buflipbot
10409        if ((positi.gt.bordlipbot)
10410      & .and.(positi.lt.bordliptop)) then
10411 C the energy transfer exist
10412         if (positi.lt.buflipbot) then
10413          fracinbuf=1.0d0-
10414      &     ((positi-bordlipbot)/lipbufthick)
10415 C lipbufthick is thickenes of lipid buffore
10416          sslip=sscalelip(fracinbuf)
10417          ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
10418          eliptran=eliptran+sslip*liptranene(itype(i))
10419          gliptranx(3,i)=gliptranx(3,i)
10420      &+ssgradlip*liptranene(itype(i))
10421          gliptranc(3,i-1)= gliptranc(3,i-1)
10422      &+ssgradlip*liptranene(itype(i))
10423 C         print *,"doing sccale for lower part"
10424         elseif (positi.gt.bufliptop) then
10425          fracinbuf=1.0d0-
10426      &((bordliptop-positi)/lipbufthick)
10427          sslip=sscalelip(fracinbuf)
10428          ssgradlip=sscagradlip(fracinbuf)/lipbufthick
10429          eliptran=eliptran+sslip*liptranene(itype(i))
10430          gliptranx(3,i)=gliptranx(3,i)
10431      &+ssgradlip*liptranene(itype(i))
10432          gliptranc(3,i-1)= gliptranc(3,i-1)
10433      &+ssgradlip*liptranene(itype(i))
10434 C          print *, "doing sscalefor top part",sslip,fracinbuf
10435         else
10436          eliptran=eliptran+liptranene(itype(i))
10437 C         print *,"I am in true lipid"
10438         endif
10439         endif ! if in lipid or buffor
10440 C       else
10441 C       eliptran=elpitran+0.0 ! I am in water
10442        enddo
10443        return
10444        end
10445 C---------------------------------------------------------
10446 C AFM soubroutine for constant force
10447        subroutine AFMforce(Eafmforce)
10448        implicit real*8 (a-h,o-z)
10449       include 'DIMENSIONS'
10450       include 'COMMON.GEO'
10451       include 'COMMON.VAR'
10452       include 'COMMON.LOCAL'
10453       include 'COMMON.CHAIN'
10454       include 'COMMON.DERIV'
10455       include 'COMMON.NAMES'
10456       include 'COMMON.INTERACT'
10457       include 'COMMON.IOUNITS'
10458       include 'COMMON.CALC'
10459       include 'COMMON.CONTROL'
10460       include 'COMMON.SPLITELE'
10461       include 'COMMON.SBRIDGE'
10462       real*8 diffafm(3)
10463       dist=0.0d0
10464       Eafmforce=0.0d0
10465       do i=1,3
10466       diffafm(i)=c(i,afmend)-c(i,afmbeg)
10467       dist=dist+diffafm(i)**2
10468       enddo
10469       dist=dsqrt(dist)
10470       Eafmforce=-forceAFMconst*(dist-distafminit)
10471       do i=1,3
10472       gradafm(i,afmend-1)=-forceAFMconst*diffafm(i)/dist
10473       gradafm(i,afmbeg-1)=forceAFMconst*diffafm(i)/dist
10474       enddo
10475 C      print *,'AFM',Eafmforce
10476       return
10477       end
10478 C---------------------------------------------------------
10479 C AFM subroutine with pseudoconstant velocity
10480        subroutine AFMvel(Eafmforce)
10481        implicit real*8 (a-h,o-z)
10482       include 'DIMENSIONS'
10483       include 'COMMON.GEO'
10484       include 'COMMON.VAR'
10485       include 'COMMON.LOCAL'
10486       include 'COMMON.CHAIN'
10487       include 'COMMON.DERIV'
10488       include 'COMMON.NAMES'
10489       include 'COMMON.INTERACT'
10490       include 'COMMON.IOUNITS'
10491       include 'COMMON.CALC'
10492       include 'COMMON.CONTROL'
10493       include 'COMMON.SPLITELE'
10494       include 'COMMON.SBRIDGE'
10495       real*8 diffafm(3)
10496 C Only for check grad COMMENT if not used for checkgrad
10497 C      totT=3.0d0
10498 C--------------------------------------------------------
10499 C      print *,"wchodze"
10500       dist=0.0d0
10501       Eafmforce=0.0d0
10502       do i=1,3
10503       diffafm(i)=c(i,afmend)-c(i,afmbeg)
10504       dist=dist+diffafm(i)**2
10505       enddo
10506       dist=dsqrt(dist)
10507       Eafmforce=0.5d0*forceAFMconst
10508      & *(distafminit+totTafm*velAFMconst-dist)**2
10509 C      Eafmforce=-forceAFMconst*(dist-distafminit)
10510       do i=1,3
10511       gradafm(i,afmend-1)=-forceAFMconst*
10512      &(distafminit+totTafm*velAFMconst-dist)
10513      &*diffafm(i)/dist
10514       gradafm(i,afmbeg-1)=forceAFMconst*
10515      &(distafminit+totTafm*velAFMconst-dist)
10516      &*diffafm(i)/dist
10517       enddo
10518 C      print *,'AFM',Eafmforce,totTafm*velAFMconst,dist
10519       return
10520       end
10521 C-----------------------------------------------------------
10522 C first for shielding is setting of function of side-chains
10523        subroutine set_shield_fac
10524       implicit real*8 (a-h,o-z)
10525       include 'DIMENSIONS'
10526       include 'COMMON.CHAIN'
10527       include 'COMMON.DERIV'
10528       include 'COMMON.IOUNITS'
10529       include 'COMMON.SHIELD'
10530       include 'COMMON.INTERACT'
10531 C this is the squar root 77 devided by 81 the epislion in lipid (in protein)
10532       double precision div77_81/0.974996043d0/,
10533      &div4_81/0.2222222222d0/
10534
10535 C the vector between center of side_chain and peptide group
10536        double precision pep_side(3),long,side_calf(3),
10537      &pept_group(3)
10538 C the line belowe needs to be changed for FGPROC>1
10539       do i=1,nres-1
10540       if ((itype(i).eq.ntyp1).and.itype(i+1).eq.ntyp1) cycle
10541       ishield_list(i)=0
10542 Cif there two consequtive dummy atoms there is no peptide group between them
10543 C the line below has to be changed for FGPROC>1
10544       VolumeTotal=0.0
10545       do k=1,nres
10546        dist_pep_side=0.0
10547        dist_side_calf=0.0
10548        do j=1,3
10549 C first lets set vector conecting the ithe side-chain with kth side-chain
10550       pep_side(j)=c(k+nres,j)-(c(i,j)+c(i+1,j))/2.0d0
10551 C and vector conecting the side-chain with its proper calfa
10552       side_calf(j)=c(k+nres,j)-c(k,j)
10553       pept_group(j)=c(i,j)-c(i+1,j)
10554 C lets have their lenght
10555       dist_pep_side=pep_side(j)**2+dist_pep_side
10556       dist_side_calf=dist_side_calf+side_calf(j)**2
10557       dist_pept_group=dist_pept_group+pept_group(j)**2
10558       enddo
10559        dist_pep_side=dsqrt(dist_pep_side)
10560        dist_pept_group=dsqrt(dist_pept_group)
10561 C now sscale fraction
10562        sh_frac_dist=-(dist_pep_side-rpp(1,1)-buff_shield)/buff_shield
10563 C now sscale
10564         if (sh_frac_dist.le.0.0) cycle
10565 C If we reach here it means that this side chain reaches the shielding sphere
10566 C Lets add him to the list for gradient
10567         ishield_list(i)=ishield_list(i)+1
10568 C ishield_list is a list of non 0 side-chain that contribute to factor gradient
10569 C this list is essential otherwise problem would be O3
10570         shield_list(ishield_list)=k
10571 C Lets have the sscale value
10572         if (sh_frac_dist.gt.1.0) then
10573          scale_fac_dist=1.0d0
10574          do j=1,3
10575          sh_frac_dist_grad(j)=0.0d0
10576          enddo
10577         else
10578          scale_fac_dist=-sh_frac_dist*sh_frac_dist
10579      &                   *(2.0*sh_frac_dist-3.0d0)
10580          fac_help_scale=6.0*(scale_fac_dist-scale_fac_dist**2)
10581      &                  /dist_pep_side/buff_shield*0.5
10582 C remember for the final gradient multiply sh_frac_dist_grad(j)
10583 C for side_chain by factor -2 !
10584          do j=1,3
10585          sh_frac_dist_grad(j)=fac_help_scale*pep_side(j)
10586          enddo
10587         endif
10588 C this is what is now we have the distance scaling now volume...
10589       short=short_r_sidechain(itype(k))
10590       long=long_r_sidechain(itype(k))
10591       costhet=1.0d0/dsqrt(1+short**2/dist_pep_side**2)
10592 C now costhet_grad
10593        costhet_fac=costhet**3*short**2*(-0.5)/dist_pep_side
10594        do j=1,3
10595          costhet_grad(j)=costhet_fac*pep_side(j)
10596        enddo
10597 C remember for the final gradient multiply costhet_grad(j)
10598 C for side_chain by factor -2 !
10599 C fac alfa is angle between CB_k,CA_k, CA_i,CA_i+1
10600 C pep_side0pept_group is vector multiplication
10601       pep_side0pept_group=0.0
10602       do j=1,3
10603       pep_side0pept_group=pep_side0pept_group+pep_side(j)*side_calf(j)
10604       enddo
10605       fac_alfa_sin=1.0-(pep_side0pept_group/
10606      & (dist_pep_side*dist_side_calf))**2
10607       fac_alfa_sin=dsqrt(fac_alfa_sin)
10608       rkprim=fac_alfa_sin*(long-short)+short
10609       cosphi=1.0d0/dsqrt(1+rkprim**2/dist_pep_side**2)
10610       VofOverlap=VSolvSphere/2.0d0*(1.0-costhet)*(1.0-cosphi)
10611      &                    /VSolvSphere_div
10612       VolumeTotal=VolumeTotal+VofOverlap*scale_fac_dist
10613 C      if ((cosphi.le.0.0).or.(costhet.le.0.0)) write(iout,*) "ERROR",
10614 C     & cosphi,costhet
10615 C now should be fac_side_grad(k) which will be gradient of factor k which also
10616 C affect the gradient of peptide group i fac_pept_grad(i) and i+1
10617       write(2,*) "myvolume",VofOverlap,VSolvSphere_div,VolumeTotal
10618       enddo
10619 C      write(2,*) "TOTAL VOLUME",i,VolumeTotal
10620 C the scaling factor of the shielding effect
10621       fac_shield(i)=VolumeTotal*div77_81+div4_81
10622       write(2,*) "TOTAL VOLUME",i,VolumeTotal,fac_shield(i)
10623       enddo
10624       return
10625       end
10626