source/unres/src_MD-M/energy_p_new_barrier.F

   1       subroutine etotal(energia)
   2       implicit real*8 (a-h,o-z)
   3       include 'DIMENSIONS'
   4 #ifndef ISNAN
   5       external proc_proc
   6 #ifdef WINPGI
   7 cMS$ATTRIBUTES C ::  proc_proc
   8 #endif
   9 #endif
  10 #ifdef MPI
  11       include "mpif.h"
  12       double precision weights_(n_ene)
  13 #endif
  14       include 'COMMON.SETUP'
  15       include 'COMMON.IOUNITS'
  16       double precision energia(0:n_ene)
  17       include 'COMMON.LOCAL'
  18       include 'COMMON.FFIELD'
  19       include 'COMMON.DERIV'
  20       include 'COMMON.INTERACT'
  21       include 'COMMON.SBRIDGE'
  22       include 'COMMON.CHAIN'
  23       include 'COMMON.VAR'
  24       include 'COMMON.MD'
  25       include 'COMMON.CONTROL'
  26       include 'COMMON.TIME1'
  27       include 'COMMON.SPLITELE'
  28 #ifdef MPI
  29 c      print*,"ETOTAL Processor",fg_rank," absolute rank",myrank,
  30 c     & " nfgtasks",nfgtasks
  31       if (nfgtasks.gt.1) then
  32         time00=MPI_Wtime()
  33 C FG slaves call the following matching MPI_Bcast in ERGASTULUM
  34         if (fg_rank.eq.0) then
  35           call MPI_Bcast(0,1,MPI_INTEGER,king,FG_COMM,IERROR)
  36 c          print *,"Processor",myrank," BROADCAST iorder"
  37 C FG master sets up the WEIGHTS_ array which will be broadcast to the
  38 C FG slaves as WEIGHTS array.
  39           weights_(1)=wsc
  40           weights_(2)=wscp
  41           weights_(3)=welec
  42           weights_(4)=wcorr
  43           weights_(5)=wcorr5
  44           weights_(6)=wcorr6
  45           weights_(7)=wel_loc
  46           weights_(8)=wturn3
  47           weights_(9)=wturn4
  48           weights_(10)=wturn6
  49           weights_(11)=wang
  50           weights_(12)=wscloc
  51           weights_(13)=wtor
  52           weights_(14)=wtor_d
  53           weights_(15)=wstrain
  54           weights_(16)=wvdwpp
  55           weights_(17)=wbond
  56           weights_(18)=scal14
  57           weights_(21)=wsccor
  58 C FG Master broadcasts the WEIGHTS_ array
  59           call MPI_Bcast(weights_(1),n_ene,
  60      &        MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
  61         else
  62 C FG slaves receive the WEIGHTS array
  63           call MPI_Bcast(weights(1),n_ene,
  64      &        MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
  65           wsc=weights(1)
  66           wscp=weights(2)
  67           welec=weights(3)
  68           wcorr=weights(4)
  69           wcorr5=weights(5)
  70           wcorr6=weights(6)
  71           wel_loc=weights(7)
  72           wturn3=weights(8)
  73           wturn4=weights(9)
  74           wturn6=weights(10)
  75           wang=weights(11)
  76           wscloc=weights(12)
  77           wtor=weights(13)
  78           wtor_d=weights(14)
  79           wstrain=weights(15)
  80           wvdwpp=weights(16)
  81           wbond=weights(17)
  82           scal14=weights(18)
  83           wsccor=weights(21)
  84         endif
  85         time_Bcast=time_Bcast+MPI_Wtime()-time00
  86         time_Bcastw=time_Bcastw+MPI_Wtime()-time00
  87 c        call chainbuild_cart
  88       endif
  89 c      print *,'Processor',myrank,' calling etotal ipot=',ipot
  90 c      print *,'Processor',myrank,' nnt=',nnt,' nct=',nct
  91 #else
  92 c      if (modecalc.eq.12.or.modecalc.eq.14) then
  93 c        call int_from_cart1(.false.)
  94 c      endif
  95 #endif
  96 #ifdef TIMING
  97       time00=MPI_Wtime()
  98 #endif
  99 C
 100 C Compute the side-chain and electrostatic interaction energy
 101 C
 102 C      print *,ipot
 103       goto (101,102,103,104,105,106) ipot
 104 C Lennard-Jones potential.
 105   101 call elj(evdw)
 106 cd    print '(a)','Exit ELJ'
 107       goto 107
 108 C Lennard-Jones-Kihara potential (shifted).
 109   102 call eljk(evdw)
 110       goto 107
 111 C Berne-Pechukas potential (dilated LJ, angular dependence).
 112   103 call ebp(evdw)
 113       goto 107
 114 C Gay-Berne potential (shifted LJ, angular dependence).
 115   104 call egb(evdw)
 116 C      print *,"bylem w egb"
 117       goto 107
 118 C Gay-Berne-Vorobjev potential (shifted LJ, angular dependence).
 119   105 call egbv(evdw)
 120       goto 107
 121 C Soft-sphere potential
 122   106 call e_softsphere(evdw)
 123 C
 124 C Calculate electrostatic (H-bonding) energy of the main chain.
 125 C
 126   107 continue
 127 cmc
 128 cmc Sep-06: egb takes care of dynamic ss bonds too
 129 cmc
 130 c      if (dyn_ss) call dyn_set_nss
 131
 132 c      print *,"Processor",myrank," computed USCSC"
 133 #ifdef TIMING
 134       time01=MPI_Wtime()
 135 #endif
 136       call vec_and_deriv
 137 #ifdef TIMING
 138       time_vec=time_vec+MPI_Wtime()-time01
 139 #endif
 140 C Introduction of shielding effect first for each peptide group
 141 C the shielding factor is set this factor is describing how each
 142 C peptide group is shielded by side-chains
 143 C the matrix - shield_fac(i) the i index describe the ith between i and i+1
 144 C      write (iout,*) "shield_mode",shield_mode
 145       if (shield_mode.gt.0) then
 146        call set_shield_fac
 147       endif
 148 c      print *,"Processor",myrank," left VEC_AND_DERIV"
 149       if (ipot.lt.6) then
 150 #ifdef SPLITELE
 151          if (welec.gt.0d0.or.wvdwpp.gt.0d0.or.wel_loc.gt.0d0.or.
 152      &       wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0
 153      &       .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0
 154      &       .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
 155 #else
 156          if (welec.gt.0d0.or.wel_loc.gt.0d0.or.
 157      &       wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0
 158      &       .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0
 159      &       .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
 160 #endif
 161             call eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
 162          else
 163             ees=0.0d0
 164             evdw1=0.0d0
 165             eel_loc=0.0d0
 166             eello_turn3=0.0d0
 167             eello_turn4=0.0d0
 168          endif
 169       else
 170         write (iout,*) "Soft-spheer ELEC potential"
 171 c        call eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,
 172 c     &   eello_turn4)
 173       endif
 174 c      print *,"Processor",myrank," computed UELEC"
 175 C
 176 C Calculate excluded-volume interaction energy between peptide groups
 177 C and side chains.
 178 C
 179       if (ipot.lt.6) then
 180        if(wscp.gt.0d0) then
 181         call escp(evdw2,evdw2_14)
 182        else
 183         evdw2=0
 184         evdw2_14=0
 185        endif
 186       else
 187 c        write (iout,*) "Soft-sphere SCP potential"
 188         call escp_soft_sphere(evdw2,evdw2_14)
 189       endif
 190 c
 191 c Calculate the bond-stretching energy
 192 c
 193       call ebond(estr)
 194 C
 195 C Calculate the disulfide-bridge and other energy and the contributions
 196 C from other distance constraints.
 197 cd    print *,'Calling EHPB'
 198       call edis(ehpb)
 199 cd    print *,'EHPB exitted succesfully.'
 200 C
 201 C Calculate the virtual-bond-angle energy.
 202 C
 203       if (wang.gt.0d0) then
 204         call ebend(ebe,ethetacnstr)
 205       else
 206         ebe=0
 207         ethetacnstr=0
 208       endif
 209 c      print *,"Processor",myrank," computed UB"
 210 C
 211 C Calculate the SC local energy.
 212 C
 213 C      print *,"TU DOCHODZE?"
 214       call esc(escloc)
 215 c      print *,"Processor",myrank," computed USC"
 216 C
 217 C Calculate the virtual-bond torsional energy.
 218 C
 219 cd    print *,'nterm=',nterm
 220       if (wtor.gt.0) then
 221        call etor(etors,edihcnstr)
 222       else
 223        etors=0
 224        edihcnstr=0
 225       endif
 226 c      print *,"Processor",myrank," computed Utor"
 227 C
 228 C 6/23/01 Calculate double-torsional energy
 229 C
 230       if (wtor_d.gt.0) then
 231        call etor_d(etors_d)
 232       else
 233        etors_d=0
 234       endif
 235 c      print *,"Processor",myrank," computed Utord"
 236 C
 237 C 21/5/07 Calculate local sicdechain correlation energy
 238 C
 239       if (wsccor.gt.0.0d0) then
 240         call eback_sc_corr(esccor)
 241       else
 242         esccor=0.0d0
 243       endif
 244 C      print *,"PRZED MULIt"
 245 c      print *,"Processor",myrank," computed Usccorr"
 246 C
 247 C 12/1/95 Multi-body terms
 248 C
 249       n_corr=0
 250       n_corr1=0
 251       if ((wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0
 252      &    .or. wturn6.gt.0.0d0) .and. ipot.lt.6) then
 253          call multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1)
 254 cd         write(2,*)'multibody_eello n_corr=',n_corr,' n_corr1=',n_corr1,
 255 cd     &" ecorr",ecorr," ecorr5",ecorr5," ecorr6",ecorr6," eturn6",eturn6
 256       else
 257          ecorr=0.0d0
 258          ecorr5=0.0d0
 259          ecorr6=0.0d0
 260          eturn6=0.0d0
 261       endif
 262       if ((wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) .and. ipot.lt.6) then
 263          call multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
 264 cd         write (iout,*) "multibody_hb ecorr",ecorr
 265       endif
 266 c      print *,"Processor",myrank," computed Ucorr"
 267 C
 268 C If performing constraint dynamics, call the constraint energy
 269 C  after the equilibration time
 270       if(usampl.and.totT.gt.eq_time) then
 271          call EconstrQ
 272          call Econstr_back
 273       else
 274          Uconst=0.0d0
 275          Uconst_back=0.0d0
 276       endif
 277 C 01/27/2015 added by adasko
 278 C the energy component below is energy transfer into lipid environment
 279 C based on partition function
 280 C      print *,"przed lipidami"
 281       if (wliptran.gt.0) then
 282         call Eliptransfer(eliptran)
 283       endif
 284 C      print *,"za lipidami"
 285       if (AFMlog.gt.0) then
 286         call AFMforce(Eafmforce)
 287       else if (selfguide.gt.0) then
 288         call AFMvel(Eafmforce)
 289       endif
 290 #ifdef TIMING
 291       time_enecalc=time_enecalc+MPI_Wtime()-time00
 292 #endif
 293 c      print *,"Processor",myrank," computed Uconstr"
 294 #ifdef TIMING
 295       time00=MPI_Wtime()
 296 #endif
 297 c
 298 C Sum the energies
 299 C
 300       energia(1)=evdw
 301 #ifdef SCP14
 302       energia(2)=evdw2-evdw2_14
 303       energia(18)=evdw2_14
 304 #else
 305       energia(2)=evdw2
 306       energia(18)=0.0d0
 307 #endif
 308 #ifdef SPLITELE
 309       energia(3)=ees
 310       energia(16)=evdw1
 311 #else
 312       energia(3)=ees+evdw1
 313       energia(16)=0.0d0
 314 #endif
 315       energia(4)=ecorr
 316       energia(5)=ecorr5
 317       energia(6)=ecorr6
 318       energia(7)=eel_loc
 319       energia(8)=eello_turn3
 320       energia(9)=eello_turn4
 321       energia(10)=eturn6
 322       energia(11)=ebe
 323       energia(12)=escloc
 324       energia(13)=etors
 325       energia(14)=etors_d
 326       energia(15)=ehpb
 327       energia(19)=edihcnstr
 328       energia(17)=estr
 329       energia(20)=Uconst+Uconst_back
 330       energia(21)=esccor
 331       energia(22)=eliptran
 332       energia(23)=Eafmforce
 333       energia(24)=ethetacnstr
 334 c    Here are the energies showed per procesor if the are more processors
 335 c    per molecule then we sum it up in sum_energy subroutine
 336 c      print *," Processor",myrank," calls SUM_ENERGY"
 337       call sum_energy(energia,.true.)
 338       if (dyn_ss) call dyn_set_nss
 339 c      print *," Processor",myrank," left SUM_ENERGY"
 340 #ifdef TIMING
 341       time_sumene=time_sumene+MPI_Wtime()-time00
 342 #endif
 343       return
 344       end
 345 c-------------------------------------------------------------------------------
 346       subroutine sum_energy(energia,reduce)
 347       implicit real*8 (a-h,o-z)
 348       include 'DIMENSIONS'
 349 #ifndef ISNAN
 350       external proc_proc
 351 #ifdef WINPGI
 352 cMS$ATTRIBUTES C ::  proc_proc
 353 #endif
 354 #endif
 355 #ifdef MPI
 356       include "mpif.h"
 357 #endif
 358       include 'COMMON.SETUP'
 359       include 'COMMON.IOUNITS'
 360       double precision energia(0:n_ene),enebuff(0:n_ene+1)
 361       include 'COMMON.FFIELD'
 362       include 'COMMON.DERIV'
 363       include 'COMMON.INTERACT'
 364       include 'COMMON.SBRIDGE'
 365       include 'COMMON.CHAIN'
 366       include 'COMMON.VAR'
 367       include 'COMMON.CONTROL'
 368       include 'COMMON.TIME1'
 369       logical reduce
 370 #ifdef MPI
 371       if (nfgtasks.gt.1 .and. reduce) then
 372 #ifdef DEBUG
 373         write (iout,*) "energies before REDUCE"
 374         call enerprint(energia)
 375         call flush(iout)
 376 #endif
 377         do i=0,n_ene
 378           enebuff(i)=energia(i)
 379         enddo
 380         time00=MPI_Wtime()
 381         call MPI_Barrier(FG_COMM,IERR)
 382         time_barrier_e=time_barrier_e+MPI_Wtime()-time00
 383         time00=MPI_Wtime()
 384         call MPI_Reduce(enebuff(0),energia(0),n_ene+1,
 385      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 386 #ifdef DEBUG
 387         write (iout,*) "energies after REDUCE"
 388         call enerprint(energia)
 389         call flush(iout)
 390 #endif
 391         time_Reduce=time_Reduce+MPI_Wtime()-time00
 392       endif
 393       if (fg_rank.eq.0) then
 394 #endif
 395       evdw=energia(1)
 396 #ifdef SCP14
 397       evdw2=energia(2)+energia(18)
 398       evdw2_14=energia(18)
 399 #else
 400       evdw2=energia(2)
 401 #endif
 402 #ifdef SPLITELE
 403       ees=energia(3)
 404       evdw1=energia(16)
 405 #else
 406       ees=energia(3)
 407       evdw1=0.0d0
 408 #endif
 409       ecorr=energia(4)
 410       ecorr5=energia(5)
 411       ecorr6=energia(6)
 412       eel_loc=energia(7)
 413       eello_turn3=energia(8)
 414       eello_turn4=energia(9)
 415       eturn6=energia(10)
 416       ebe=energia(11)
 417       escloc=energia(12)
 418       etors=energia(13)
 419       etors_d=energia(14)
 420       ehpb=energia(15)
 421       edihcnstr=energia(19)
 422       estr=energia(17)
 423       Uconst=energia(20)
 424       esccor=energia(21)
 425       eliptran=energia(22)
 426       Eafmforce=energia(23)
 427       ethetacnstr=energia(24)
 428 #ifdef SPLITELE
 429       etot=wsc*evdw+wscp*evdw2+welec*ees+wvdwpp*evdw1
 430      & +wang*ebe+wtor*etors+wscloc*escloc
 431      & +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5
 432      & +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3
 433      & +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d
 434      & +wbond*estr+Uconst+wsccor*esccor+wliptran*eliptran+Eafmforce
 435      & +ethetacnstr
 436 #else
 437       etot=wsc*evdw+wscp*evdw2+welec*(ees+evdw1)
 438      & +wang*ebe+wtor*etors+wscloc*escloc
 439      & +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5
 440      & +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3
 441      & +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d
 442      & +wbond*estr+Uconst+wsccor*esccor+wliptran*eliptran
 443      & +Eafmforce
 444      & +ethetacnstr
 445 #endif
 446       energia(0)=etot
 447 c detecting NaNQ
 448 #ifdef ISNAN
 449 #ifdef AIX
 450       if (isnan(etot).ne.0) energia(0)=1.0d+99
 451 #else
 452       if (isnan(etot)) energia(0)=1.0d+99
 453 #endif
 454 #else
 455       i=0
 456 #ifdef WINPGI
 457       idumm=proc_proc(etot,i)
 458 #else
 459       call proc_proc(etot,i)
 460 #endif
 461       if(i.eq.1)energia(0)=1.0d+99
 462 #endif
 463 #ifdef MPI
 464       endif
 465 #endif
 466       return
 467       end
 468 c-------------------------------------------------------------------------------
 469       subroutine sum_gradient
 470       implicit real*8 (a-h,o-z)
 471       include 'DIMENSIONS'
 472 #ifndef ISNAN
 473       external proc_proc
 474 #ifdef WINPGI
 475 cMS$ATTRIBUTES C ::  proc_proc
 476 #endif
 477 #endif
 478 #ifdef MPI
 479       include 'mpif.h'
 480 #endif
 481       double precision gradbufc(3,-1:maxres),gradbufx(3,-1:maxres),
 482      & glocbuf(4*maxres),gradbufc_sum(3,-1:maxres)
 483      & ,gloc_scbuf(3,-1:maxres)
 484       include 'COMMON.SETUP'
 485       include 'COMMON.IOUNITS'
 486       include 'COMMON.FFIELD'
 487       include 'COMMON.DERIV'
 488       include 'COMMON.INTERACT'
 489       include 'COMMON.SBRIDGE'
 490       include 'COMMON.CHAIN'
 491       include 'COMMON.VAR'
 492       include 'COMMON.CONTROL'
 493       include 'COMMON.TIME1'
 494       include 'COMMON.MAXGRAD'
 495       include 'COMMON.SCCOR'
 496 #ifdef TIMING
 497       time01=MPI_Wtime()
 498 #endif
 499 #ifdef DEBUG
 500       write (iout,*) "sum_gradient gvdwc, gvdwx"
 501       do i=1,nres
 502         write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)')
 503      &   i,(gvdwx(j,i),j=1,3),(gvdwc(j,i),j=1,3)
 504       enddo
 505       call flush(iout)
 506 #endif
 507 #ifdef MPI
 508 C FG slaves call the following matching MPI_Bcast in ERGASTULUM
 509         if (nfgtasks.gt.1 .and. fg_rank.eq.0)
 510      &    call MPI_Bcast(1,1,MPI_INTEGER,king,FG_COMM,IERROR)
 511 #endif
 512 C
 513 C 9/29/08 AL Transform parts of gradients in site coordinates to the gradient
 514 C            in virtual-bond-vector coordinates
 515 C
 516 #ifdef DEBUG
 517 c      write (iout,*) "gel_loc gel_loc_long and gel_loc_loc"
 518 c      do i=1,nres-1
 519 c        write (iout,'(i5,3f10.5,2x,3f10.5,2x,f10.5)')
 520 c     &   i,(gel_loc(j,i),j=1,3),(gel_loc_long(j,i),j=1,3),gel_loc_loc(i)
 521 c      enddo
 522 c      write (iout,*) "gel_loc_tur3 gel_loc_turn4"
 523 c      do i=1,nres-1
 524 c        write (iout,'(i5,3f10.5,2x,f10.5)')
 525 c     &  i,(gcorr4_turn(j,i),j=1,3),gel_loc_turn4(i)
 526 c      enddo
 527       write (iout,*) "gradcorr5 gradcorr5_long gradcorr5_loc"
 528       do i=1,nres
 529         write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)')
 530      &   i,(gradcorr5(j,i),j=1,3),(gradcorr5_long(j,i),j=1,3),
 531      &   g_corr5_loc(i)
 532       enddo
 533       call flush(iout)
 534 #endif
 535 #ifdef SPLITELE
 536       do i=0,nct
 537         do j=1,3
 538           gradbufc(j,i)=wsc*gvdwc(j,i)+
 539      &                wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+
 540      &                welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+
 541      &                wel_loc*gel_loc_long(j,i)+
 542      &                wcorr*gradcorr_long(j,i)+
 543      &                wcorr5*gradcorr5_long(j,i)+
 544      &                wcorr6*gradcorr6_long(j,i)+
 545      &                wturn6*gcorr6_turn_long(j,i)+
 546      &                wstrain*ghpbc(j,i)
 547      &                +wliptran*gliptranc(j,i)
 548      &                +gradafm(j,i)
 549      &                 +welec*gshieldc(j,i)
 550      &                 +wcorr*gshieldc_ec(j,i)
 551      &                 +wturn3*gshieldc_t3(j,i)
 552      &                 +wturn4*gshieldc_t4(j,i)
 553      &                 +wel_loc*gshieldc_ll(j,i)
 554
 555
 556         enddo
 557       enddo
 558 #else
 559       do i=0,nct
 560         do j=1,3
 561           gradbufc(j,i)=wsc*gvdwc(j,i)+
 562      &                wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+
 563      &                welec*gelc_long(j,i)+
 564      &                wbond*gradb(j,i)+
 565      &                wel_loc*gel_loc_long(j,i)+
 566      &                wcorr*gradcorr_long(j,i)+
 567      &                wcorr5*gradcorr5_long(j,i)+
 568      &                wcorr6*gradcorr6_long(j,i)+
 569      &                wturn6*gcorr6_turn_long(j,i)+
 570      &                wstrain*ghpbc(j,i)
 571      &                +wliptran*gliptranc(j,i)
 572      &                +gradafm(j,i)
 573      &                 +welec*gshieldc(j,i)
 574      &                 +wcorr*gshieldc_ec(j,i)
 575      &                 +wturn4*gshieldc_t4(j,i)
 576      &                 +wel_loc*gshieldc_ll(j,i)
 577
 578
 579         enddo
 580       enddo
 581 #endif
 582 #ifdef MPI
 583       if (nfgtasks.gt.1) then
 584       time00=MPI_Wtime()
 585 #ifdef DEBUG
 586       write (iout,*) "gradbufc before allreduce"
 587       do i=1,nres
 588         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 589       enddo
 590       call flush(iout)
 591 #endif
 592       do i=0,nres
 593         do j=1,3
 594           gradbufc_sum(j,i)=gradbufc(j,i)
 595         enddo
 596       enddo
 597 c      call MPI_AllReduce(gradbufc(1,1),gradbufc_sum(1,1),3*nres,
 598 c     &    MPI_DOUBLE_PRECISION,MPI_SUM,FG_COMM,IERR)
 599 c      time_reduce=time_reduce+MPI_Wtime()-time00
 600 #ifdef DEBUG
 601 c      write (iout,*) "gradbufc_sum after allreduce"
 602 c      do i=1,nres
 603 c        write (iout,'(i3,3f10.5)') i,(gradbufc_sum(j,i),j=1,3)
 604 c      enddo
 605 c      call flush(iout)
 606 #endif
 607 #ifdef TIMING
 608 c      time_allreduce=time_allreduce+MPI_Wtime()-time00
 609 #endif
 610       do i=nnt,nres
 611         do k=1,3
 612           gradbufc(k,i)=0.0d0
 613         enddo
 614       enddo
 615 #ifdef DEBUG
 616       write (iout,*) "igrad_start",igrad_start," igrad_end",igrad_end
 617       write (iout,*) (i," jgrad_start",jgrad_start(i),
 618      &                  " jgrad_end  ",jgrad_end(i),
 619      &                  i=igrad_start,igrad_end)
 620 #endif
 621 c
 622 c Obsolete and inefficient code; we can make the effort O(n) and, therefore,
 623 c do not parallelize this part.
 624 c
 625 c      do i=igrad_start,igrad_end
 626 c        do j=jgrad_start(i),jgrad_end(i)
 627 c          do k=1,3
 628 c            gradbufc(k,i)=gradbufc(k,i)+gradbufc_sum(k,j)
 629 c          enddo
 630 c        enddo
 631 c      enddo
 632       do j=1,3
 633         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
 634       enddo
 635       do i=nres-2,-1,-1
 636         do j=1,3
 637           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
 638         enddo
 639       enddo
 640 #ifdef DEBUG
 641       write (iout,*) "gradbufc after summing"
 642       do i=1,nres
 643         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 644       enddo
 645       call flush(iout)
 646 #endif
 647       else
 648 #endif
 649 #ifdef DEBUG
 650       write (iout,*) "gradbufc"
 651       do i=1,nres
 652         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 653       enddo
 654       call flush(iout)
 655 #endif
 656       do i=-1,nres
 657         do j=1,3
 658           gradbufc_sum(j,i)=gradbufc(j,i)
 659           gradbufc(j,i)=0.0d0
 660         enddo
 661       enddo
 662       do j=1,3
 663         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
 664       enddo
 665       do i=nres-2,-1,-1
 666         do j=1,3
 667           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
 668         enddo
 669       enddo
 670 c      do i=nnt,nres-1
 671 c        do k=1,3
 672 c          gradbufc(k,i)=0.0d0
 673 c        enddo
 674 c        do j=i+1,nres
 675 c          do k=1,3
 676 c            gradbufc(k,i)=gradbufc(k,i)+gradbufc(k,j)
 677 c          enddo
 678 c        enddo
 679 c      enddo
 680 #ifdef DEBUG
 681       write (iout,*) "gradbufc after summing"
 682       do i=1,nres
 683         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 684       enddo
 685       call flush(iout)
 686 #endif
 687 #ifdef MPI
 688       endif
 689 #endif
 690       do k=1,3
 691         gradbufc(k,nres)=0.0d0
 692       enddo
 693       do i=-1,nct
 694         do j=1,3
 695 #ifdef SPLITELE
 696 C          print *,gradbufc(1,13)
 697 C          print *,welec*gelc(1,13)
 698 C          print *,wel_loc*gel_loc(1,13)
 699 C          print *,0.5d0*(wscp*gvdwc_scpp(1,13))
 700 C          print *,welec*gelc_long(1,13)+wvdwpp*gvdwpp(1,13)
 701 C          print *,wel_loc*gel_loc_long(1,13)
 702 C          print *,gradafm(1,13),"AFM"
 703           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+
 704      &                wel_loc*gel_loc(j,i)+
 705      &                0.5d0*(wscp*gvdwc_scpp(j,i)+
 706      &                welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+
 707      &                wel_loc*gel_loc_long(j,i)+
 708      &                wcorr*gradcorr_long(j,i)+
 709      &                wcorr5*gradcorr5_long(j,i)+
 710      &                wcorr6*gradcorr6_long(j,i)+
 711      &                wturn6*gcorr6_turn_long(j,i))+
 712      &                wbond*gradb(j,i)+
 713      &                wcorr*gradcorr(j,i)+
 714      &                wturn3*gcorr3_turn(j,i)+
 715      &                wturn4*gcorr4_turn(j,i)+
 716      &                wcorr5*gradcorr5(j,i)+
 717      &                wcorr6*gradcorr6(j,i)+
 718      &                wturn6*gcorr6_turn(j,i)+
 719      &                wsccor*gsccorc(j,i)
 720      &               +wscloc*gscloc(j,i)
 721      &               +wliptran*gliptranc(j,i)
 722      &                +gradafm(j,i)
 723      &                 +welec*gshieldc(j,i)
 724      &                 +welec*gshieldc_loc(j,i)
 725      &                 +wcorr*gshieldc_ec(j,i)
 726      &                 +wcorr*gshieldc_loc_ec(j,i)
 727      &                 +wturn3*gshieldc_t3(j,i)
 728      &                 +wturn3*gshieldc_loc_t3(j,i)
 729      &                 +wturn4*gshieldc_t4(j,i)
 730      &                 +wturn4*gshieldc_loc_t4(j,i)
 731      &                 +wel_loc*gshieldc_ll(j,i)
 732      &                 +wel_loc*gshieldc_loc_ll(j,i)
 733
 734
 735
 736
 737
 738
 739 #else
 740           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+
 741      &                wel_loc*gel_loc(j,i)+
 742      &                0.5d0*(wscp*gvdwc_scpp(j,i)+
 743      &                welec*gelc_long(j,i)+
 744      &                wel_loc*gel_loc_long(j,i)+
 745      &                wcorr*gcorr_long(j,i)+
 746      &                wcorr5*gradcorr5_long(j,i)+
 747      &                wcorr6*gradcorr6_long(j,i)+
 748      &                wturn6*gcorr6_turn_long(j,i))+
 749      &                wbond*gradb(j,i)+
 750      &                wcorr*gradcorr(j,i)+
 751      &                wturn3*gcorr3_turn(j,i)+
 752      &                wturn4*gcorr4_turn(j,i)+
 753      &                wcorr5*gradcorr5(j,i)+
 754      &                wcorr6*gradcorr6(j,i)+
 755      &                wturn6*gcorr6_turn(j,i)+
 756      &                wsccor*gsccorc(j,i)
 757      &               +wscloc*gscloc(j,i)
 758      &               +wliptran*gliptranc(j,i)
 759      &                +gradafm(j,i)
 760      &                 +welec*gshieldc(j,i)
 761      &                 +welec*gshieldc_loc(j,i)
 762      &                 +wcorr*gshieldc_ec(j,i)
 763      &                 +wcorr*gshieldc_loc_ec(j,i)
 764      &                 +wturn3*gshieldc_t3(j,i)
 765      &                 +wturn3*gshieldc_loc_t3(j,i)
 766      &                 +wturn4*gshieldc_t4(j,i)
 767      &                 +wturn4*gshieldc_loc_t4(j,i)
 768      &                 +wel_loc*gshieldc_ll(j,i)
 769      &                 +wel_loc*gshieldc_loc_ll(j,i)
 770
 771
 772
 773
 774
 775 #endif
 776           gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+
 777      &                  wbond*gradbx(j,i)+
 778      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
 779      &                  wsccor*gsccorx(j,i)
 780      &                 +wscloc*gsclocx(j,i)
 781      &                 +wliptran*gliptranx(j,i)
 782      &                 +welec*gshieldx(j,i)
 783      &                 +wcorr*gshieldx_ec(j,i)
 784      &                 +wturn3*gshieldx_t3(j,i)
 785      &                 +wturn4*gshieldx_t4(j,i)
 786      &                 +wel_loc*gshieldx_ll(j,i)
 787
 788
 789
 790         enddo
 791       enddo
 792 #ifdef DEBUG
 793       write (iout,*) "gloc before adding corr"
 794       do i=1,4*nres
 795         write (iout,*) i,gloc(i,icg)
 796       enddo
 797 #endif
 798       do i=1,nres-3
 799         gloc(i,icg)=gloc(i,icg)+wcorr*gcorr_loc(i)
 800      &   +wcorr5*g_corr5_loc(i)
 801      &   +wcorr6*g_corr6_loc(i)
 802      &   +wturn4*gel_loc_turn4(i)
 803      &   +wturn3*gel_loc_turn3(i)
 804      &   +wturn6*gel_loc_turn6(i)
 805      &   +wel_loc*gel_loc_loc(i)
 806       enddo
 807 #ifdef DEBUG
 808       write (iout,*) "gloc after adding corr"
 809       do i=1,4*nres
 810         write (iout,*) i,gloc(i,icg)
 811       enddo
 812 #endif
 813 #ifdef MPI
 814       if (nfgtasks.gt.1) then
 815         do j=1,3
 816           do i=1,nres
 817             gradbufc(j,i)=gradc(j,i,icg)
 818             gradbufx(j,i)=gradx(j,i,icg)
 819           enddo
 820         enddo
 821         do i=1,4*nres
 822           glocbuf(i)=gloc(i,icg)
 823         enddo
 824 c#define DEBUG
 825 #ifdef DEBUG
 826       write (iout,*) "gloc_sc before reduce"
 827       do i=1,nres
 828        do j=1,1
 829         write (iout,*) i,j,gloc_sc(j,i,icg)
 830        enddo
 831       enddo
 832 #endif
 833 c#undef DEBUG
 834         do i=1,nres
 835          do j=1,3
 836           gloc_scbuf(j,i)=gloc_sc(j,i,icg)
 837          enddo
 838         enddo
 839         time00=MPI_Wtime()
 840         call MPI_Barrier(FG_COMM,IERR)
 841         time_barrier_g=time_barrier_g+MPI_Wtime()-time00
 842         time00=MPI_Wtime()
 843         call MPI_Reduce(gradbufc(1,1),gradc(1,1,icg),3*nres,
 844      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 845         call MPI_Reduce(gradbufx(1,1),gradx(1,1,icg),3*nres,
 846      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 847         call MPI_Reduce(glocbuf(1),gloc(1,icg),4*nres,
 848      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 849         time_reduce=time_reduce+MPI_Wtime()-time00
 850         call MPI_Reduce(gloc_scbuf(1,1),gloc_sc(1,1,icg),3*nres,
 851      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 852         time_reduce=time_reduce+MPI_Wtime()-time00
 853 c#define DEBUG
 854 #ifdef DEBUG
 855       write (iout,*) "gloc_sc after reduce"
 856       do i=1,nres
 857        do j=1,1
 858         write (iout,*) i,j,gloc_sc(j,i,icg)
 859        enddo
 860       enddo
 861 #endif
 862 c#undef DEBUG
 863 #ifdef DEBUG
 864       write (iout,*) "gloc after reduce"
 865       do i=1,4*nres
 866         write (iout,*) i,gloc(i,icg)
 867       enddo
 868 #endif
 869       endif
 870 #endif
 871       if (gnorm_check) then
 872 c
 873 c Compute the maximum elements of the gradient
 874 c
 875       gvdwc_max=0.0d0
 876       gvdwc_scp_max=0.0d0
 877       gelc_max=0.0d0
 878       gvdwpp_max=0.0d0
 879       gradb_max=0.0d0
 880       ghpbc_max=0.0d0
 881       gradcorr_max=0.0d0
 882       gel_loc_max=0.0d0
 883       gcorr3_turn_max=0.0d0
 884       gcorr4_turn_max=0.0d0
 885       gradcorr5_max=0.0d0
 886       gradcorr6_max=0.0d0
 887       gcorr6_turn_max=0.0d0
 888       gsccorc_max=0.0d0
 889       gscloc_max=0.0d0
 890       gvdwx_max=0.0d0
 891       gradx_scp_max=0.0d0
 892       ghpbx_max=0.0d0
 893       gradxorr_max=0.0d0
 894       gsccorx_max=0.0d0
 895       gsclocx_max=0.0d0
 896       do i=1,nct
 897         gvdwc_norm=dsqrt(scalar(gvdwc(1,i),gvdwc(1,i)))
 898         if (gvdwc_norm.gt.gvdwc_max) gvdwc_max=gvdwc_norm
 899         gvdwc_scp_norm=dsqrt(scalar(gvdwc_scp(1,i),gvdwc_scp(1,i)))
 900         if (gvdwc_scp_norm.gt.gvdwc_scp_max)
 901      &   gvdwc_scp_max=gvdwc_scp_norm
 902         gelc_norm=dsqrt(scalar(gelc(1,i),gelc(1,i)))
 903         if (gelc_norm.gt.gelc_max) gelc_max=gelc_norm
 904         gvdwpp_norm=dsqrt(scalar(gvdwpp(1,i),gvdwpp(1,i)))
 905         if (gvdwpp_norm.gt.gvdwpp_max) gvdwpp_max=gvdwpp_norm
 906         gradb_norm=dsqrt(scalar(gradb(1,i),gradb(1,i)))
 907         if (gradb_norm.gt.gradb_max) gradb_max=gradb_norm
 908         ghpbc_norm=dsqrt(scalar(ghpbc(1,i),ghpbc(1,i)))
 909         if (ghpbc_norm.gt.ghpbc_max) ghpbc_max=ghpbc_norm
 910         gradcorr_norm=dsqrt(scalar(gradcorr(1,i),gradcorr(1,i)))
 911         if (gradcorr_norm.gt.gradcorr_max) gradcorr_max=gradcorr_norm
 912         gel_loc_norm=dsqrt(scalar(gel_loc(1,i),gel_loc(1,i)))
 913         if (gel_loc_norm.gt.gel_loc_max) gel_loc_max=gel_loc_norm
 914         gcorr3_turn_norm=dsqrt(scalar(gcorr3_turn(1,i),
 915      &    gcorr3_turn(1,i)))
 916         if (gcorr3_turn_norm.gt.gcorr3_turn_max)
 917      &    gcorr3_turn_max=gcorr3_turn_norm
 918         gcorr4_turn_norm=dsqrt(scalar(gcorr4_turn(1,i),
 919      &    gcorr4_turn(1,i)))
 920         if (gcorr4_turn_norm.gt.gcorr4_turn_max)
 921      &    gcorr4_turn_max=gcorr4_turn_norm
 922         gradcorr5_norm=dsqrt(scalar(gradcorr5(1,i),gradcorr5(1,i)))
 923         if (gradcorr5_norm.gt.gradcorr5_max)
 924      &    gradcorr5_max=gradcorr5_norm
 925         gradcorr6_norm=dsqrt(scalar(gradcorr6(1,i),gradcorr6(1,i)))
 926         if (gradcorr6_norm.gt.gradcorr6_max) gcorr6_max=gradcorr6_norm
 927         gcorr6_turn_norm=dsqrt(scalar(gcorr6_turn(1,i),
 928      &    gcorr6_turn(1,i)))
 929         if (gcorr6_turn_norm.gt.gcorr6_turn_max)
 930      &    gcorr6_turn_max=gcorr6_turn_norm
 931         gsccorr_norm=dsqrt(scalar(gsccorc(1,i),gsccorc(1,i)))
 932         if (gsccorr_norm.gt.gsccorr_max) gsccorr_max=gsccorr_norm
 933         gscloc_norm=dsqrt(scalar(gscloc(1,i),gscloc(1,i)))
 934         if (gscloc_norm.gt.gscloc_max) gscloc_max=gscloc_norm
 935         gvdwx_norm=dsqrt(scalar(gvdwx(1,i),gvdwx(1,i)))
 936         if (gvdwx_norm.gt.gvdwx_max) gvdwx_max=gvdwx_norm
 937         gradx_scp_norm=dsqrt(scalar(gradx_scp(1,i),gradx_scp(1,i)))
 938         if (gradx_scp_norm.gt.gradx_scp_max)
 939      &    gradx_scp_max=gradx_scp_norm
 940         ghpbx_norm=dsqrt(scalar(ghpbx(1,i),ghpbx(1,i)))
 941         if (ghpbx_norm.gt.ghpbx_max) ghpbx_max=ghpbx_norm
 942         gradxorr_norm=dsqrt(scalar(gradxorr(1,i),gradxorr(1,i)))
 943         if (gradxorr_norm.gt.gradxorr_max) gradxorr_max=gradxorr_norm
 944         gsccorrx_norm=dsqrt(scalar(gsccorx(1,i),gsccorx(1,i)))
 945         if (gsccorrx_norm.gt.gsccorrx_max) gsccorrx_max=gsccorrx_norm
 946         gsclocx_norm=dsqrt(scalar(gsclocx(1,i),gsclocx(1,i)))
 947         if (gsclocx_norm.gt.gsclocx_max) gsclocx_max=gsclocx_norm
 948       enddo
 949       if (gradout) then
 950 #ifdef AIX
 951         open(istat,file=statname,position="append")
 952 #else
 953         open(istat,file=statname,access="append")
 954 #endif
 955         write (istat,'(1h#,21f10.2)') gvdwc_max,gvdwc_scp_max,
 956      &     gelc_max,gvdwpp_max,gradb_max,ghpbc_max,
 957      &     gradcorr_max,gel_loc_max,gcorr3_turn_max,gcorr4_turn_max,
 958      &     gradcorr5_max,gradcorr6_max,gcorr6_turn_max,gsccorc_max,
 959      &     gscloc_max,gvdwx_max,gradx_scp_max,ghpbx_max,gradxorr_max,
 960      &     gsccorx_max,gsclocx_max
 961         close(istat)
 962         if (gvdwc_max.gt.1.0d4) then
 963           write (iout,*) "gvdwc gvdwx gradb gradbx"
 964           do i=nnt,nct
 965             write(iout,'(i5,4(3f10.2,5x))') i,(gvdwc(j,i),gvdwx(j,i),
 966      &        gradb(j,i),gradbx(j,i),j=1,3)
 967           enddo
 968           call pdbout(0.0d0,'cipiszcze',iout)
 969           call flush(iout)
 970         endif
 971       endif
 972       endif
 973 #ifdef DEBUG
 974       write (iout,*) "gradc gradx gloc"
 975       do i=1,nres
 976         write (iout,'(i5,3f10.5,5x,3f10.5,5x,f10.5)')
 977      &   i,(gradc(j,i,icg),j=1,3),(gradx(j,i,icg),j=1,3),gloc(i,icg)
 978       enddo
 979 #endif
 980 #ifdef TIMING
 981       time_sumgradient=time_sumgradient+MPI_Wtime()-time01
 982 #endif
 983       return
 984       end
 985 c-------------------------------------------------------------------------------
 986       subroutine rescale_weights(t_bath)
 987       implicit real*8 (a-h,o-z)
 988       include 'DIMENSIONS'
 989       include 'COMMON.IOUNITS'
 990       include 'COMMON.FFIELD'
 991       include 'COMMON.SBRIDGE'
 992       double precision kfac /2.4d0/
 993       double precision x,x2,x3,x4,x5,licznik /1.12692801104297249644/
 994 c      facT=temp0/t_bath
 995 c      facT=2*temp0/(t_bath+temp0)
 996       if (rescale_mode.eq.0) then
 997         facT=1.0d0
 998         facT2=1.0d0
 999         facT3=1.0d0
1000         facT4=1.0d0
1001         facT5=1.0d0
1002       else if (rescale_mode.eq.1) then
1003         facT=kfac/(kfac-1.0d0+t_bath/temp0)
1004         facT2=kfac**2/(kfac**2-1.0d0+(t_bath/temp0)**2)
1005         facT3=kfac**3/(kfac**3-1.0d0+(t_bath/temp0)**3)
1006         facT4=kfac**4/(kfac**4-1.0d0+(t_bath/temp0)**4)
1007         facT5=kfac**5/(kfac**5-1.0d0+(t_bath/temp0)**5)
1008       else if (rescale_mode.eq.2) then
1009         x=t_bath/temp0
1010         x2=x*x
1011         x3=x2*x
1012         x4=x3*x
1013         x5=x4*x
1014         facT=licznik/dlog(dexp(x)+dexp(-x))
1015         facT2=licznik/dlog(dexp(x2)+dexp(-x2))
1016         facT3=licznik/dlog(dexp(x3)+dexp(-x3))
1017         facT4=licznik/dlog(dexp(x4)+dexp(-x4))
1018         facT5=licznik/dlog(dexp(x5)+dexp(-x5))
1019       else
1020         write (iout,*) "Wrong RESCALE_MODE",rescale_mode
1021         write (*,*) "Wrong RESCALE_MODE",rescale_mode
1022 #ifdef MPI
1023        call MPI_Finalize(MPI_COMM_WORLD,IERROR)
1024 #endif
1025        stop 555
1026       endif
1027       welec=weights(3)*fact
1028       wcorr=weights(4)*fact3
1029       wcorr5=weights(5)*fact4
1030       wcorr6=weights(6)*fact5
1031       wel_loc=weights(7)*fact2
1032       wturn3=weights(8)*fact2
1033       wturn4=weights(9)*fact3
1034       wturn6=weights(10)*fact5
1035       wtor=weights(13)*fact
1036       wtor_d=weights(14)*fact2
1037       wsccor=weights(21)*fact
1038
1039       return
1040       end
1041 C------------------------------------------------------------------------
1042       subroutine enerprint(energia)
1043       implicit real*8 (a-h,o-z)
1044       include 'DIMENSIONS'
1045       include 'COMMON.IOUNITS'
1046       include 'COMMON.FFIELD'
1047       include 'COMMON.SBRIDGE'
1048       include 'COMMON.MD'
1049       double precision energia(0:n_ene)
1050       etot=energia(0)
1051       evdw=energia(1)
1052       evdw2=energia(2)
1053 #ifdef SCP14
1054       evdw2=energia(2)+energia(18)
1055 #else
1056       evdw2=energia(2)
1057 #endif
1058       ees=energia(3)
1059 #ifdef SPLITELE
1060       evdw1=energia(16)
1061 #endif
1062       ecorr=energia(4)
1063       ecorr5=energia(5)
1064       ecorr6=energia(6)
1065       eel_loc=energia(7)
1066       eello_turn3=energia(8)
1067       eello_turn4=energia(9)
1068       eello_turn6=energia(10)
1069       ebe=energia(11)
1070       escloc=energia(12)
1071       etors=energia(13)
1072       etors_d=energia(14)
1073       ehpb=energia(15)
1074       edihcnstr=energia(19)
1075       estr=energia(17)
1076       Uconst=energia(20)
1077       esccor=energia(21)
1078       eliptran=energia(22)
1079       Eafmforce=energia(23)
1080       ethetacnstr=energia(24)
1081 #ifdef SPLITELE
1082       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,evdw1,wvdwpp,
1083      &  estr,wbond,ebe,wang,
1084      &  escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,
1085      &  ecorr,wcorr,
1086      &  ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,
1087      &  eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccro,edihcnstr,
1088      &  ethetacnstr,ebr*nss,Uconst,eliptran,wliptran,Eafmforc,
1089      &  etot
1090    10 format (/'Virtual-chain energies:'//
1091      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
1092      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
1093      & 'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/
1094      & 'EVDWPP=',1pE16.6,' WEIGHT=',1pD16.6,' (p-p VDW)'/
1095      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
1096      & 'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
1097      & 'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
1098      & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
1099      & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
1100      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6,
1101      & ' (SS bridges & dist. cnstr.)'/
1102      & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1103      & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1104      & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1105      & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
1106      & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
1107      & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
1108      & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
1109      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
1110      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
1111      & 'ETHETC= ',1pE16.6,' (valence angle constraints)'/
1112      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
1113      & 'UCONST= ',1pE16.6,' (Constraint energy)'/
1114      & 'ELT=',1pE16.6, ' WEIGHT=',1pD16.6,' (Lipid transfer energy)'/
1115      & 'EAFM=  ',1pE16.6,' (atomic-force microscopy)'/
1116      & 'ETOT=  ',1pE16.6,' (total)')
1117
1118 #else
1119       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,
1120      &  estr,wbond,ebe,wang,
1121      &  escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,
1122      &  ecorr,wcorr,
1123      &  ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,
1124      &  eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccro,edihcnstr,
1125      &  ethetacnstr,ebr*nss,Uconst,eliptran,wliptran,Eafmforc,
1126      &  etot
1127    10 format (/'Virtual-chain energies:'//
1128      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
1129      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
1130      & 'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/
1131      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
1132      & 'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
1133      & 'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
1134      & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
1135      & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
1136      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6,
1137      & ' (SS bridges & dist. cnstr.)'/
1138      & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1139      & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1140      & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1141      & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
1142      & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
1143      & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
1144      & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
1145      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
1146      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
1147      & 'ETHETC= ',1pE16.6,' (valence angle constraints)'/
1148      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
1149      & 'UCONST=',1pE16.6,' (Constraint energy)'/
1150      & 'ELT=',1pE16.6, ' WEIGHT=',1pD16.6,' (Lipid transfer energy)'/
1151      & 'EAFM=  ',1pE16.6,' (atomic-force microscopy)'/
1152      & 'ETOT=  ',1pE16.6,' (total)')
1153 #endif
1154       return
1155       end
1156 C-----------------------------------------------------------------------
1157       subroutine elj(evdw)
1158 C
1159 C This subroutine calculates the interaction energy of nonbonded side chains
1160 C assuming the LJ potential of interaction.
1161 C
1162       implicit real*8 (a-h,o-z)
1163       include 'DIMENSIONS'
1164       parameter (accur=1.0d-10)
1165       include 'COMMON.GEO'
1166       include 'COMMON.VAR'
1167       include 'COMMON.LOCAL'
1168       include 'COMMON.CHAIN'
1169       include 'COMMON.DERIV'
1170       include 'COMMON.INTERACT'
1171       include 'COMMON.TORSION'
1172       include 'COMMON.SBRIDGE'
1173       include 'COMMON.NAMES'
1174       include 'COMMON.IOUNITS'
1175       include 'COMMON.CONTACTS'
1176       dimension gg(3)
1177 c      write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
1178       evdw=0.0D0
1179       do i=iatsc_s,iatsc_e
1180         itypi=iabs(itype(i))
1181         if (itypi.eq.ntyp1) cycle
1182         itypi1=iabs(itype(i+1))
1183         xi=c(1,nres+i)
1184         yi=c(2,nres+i)
1185         zi=c(3,nres+i)
1186 C Change 12/1/95
1187         num_conti=0
1188 C
1189 C Calculate SC interaction energy.
1190 C
1191         do iint=1,nint_gr(i)
1192 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
1193 cd   &                  'iend=',iend(i,iint)
1194           do j=istart(i,iint),iend(i,iint)
1195             itypj=iabs(itype(j))
1196             if (itypj.eq.ntyp1) cycle
1197             xj=c(1,nres+j)-xi
1198             yj=c(2,nres+j)-yi
1199             zj=c(3,nres+j)-zi
1200 C Change 12/1/95 to calculate four-body interactions
1201             rij=xj*xj+yj*yj+zj*zj
1202             rrij=1.0D0/rij
1203 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
1204             eps0ij=eps(itypi,itypj)
1205             fac=rrij**expon2
1206 C have you changed here?
1207             e1=fac*fac*aa
1208             e2=fac*bb
1209             evdwij=e1+e2
1210 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1211 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1212 cd          write (iout,'(2(a3,i3,2x),6(1pd12.4)/2(3(1pd12.4),5x)/)')
1213 cd   &        restyp(itypi),i,restyp(itypj),j,a(itypi,itypj),
1214 cd   &        bb(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,epsi,sigm,
1215 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1216             evdw=evdw+evdwij
1217 C
1218 C Calculate the components of the gradient in DC and X
1219 C
1220             fac=-rrij*(e1+evdwij)
1221             gg(1)=xj*fac
1222             gg(2)=yj*fac
1223             gg(3)=zj*fac
1224             do k=1,3
1225               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1226               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1227               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1228               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1229             enddo
1230 cgrad            do k=i,j-1
1231 cgrad              do l=1,3
1232 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1233 cgrad              enddo
1234 cgrad            enddo
1235 C
1236 C 12/1/95, revised on 5/20/97
1237 C
1238 C Calculate the contact function. The ith column of the array JCONT will
1239 C contain the numbers of atoms that make contacts with the atom I (of numbers
1240 C greater than I). The arrays FACONT and GACONT will contain the values of
1241 C the contact function and its derivative.
1242 C
1243 C Uncomment next line, if the correlation interactions include EVDW explicitly.
1244 c           if (j.gt.i+1 .and. evdwij.le.0.0D0) then
1245 C Uncomment next line, if the correlation interactions are contact function only
1246             if (j.gt.i+1.and. eps0ij.gt.0.0D0) then
1247               rij=dsqrt(rij)
1248               sigij=sigma(itypi,itypj)
1249               r0ij=rs0(itypi,itypj)
1250 C
1251 C Check whether the SC's are not too far to make a contact.
1252 C
1253               rcut=1.5d0*r0ij
1254               call gcont(rij,rcut,1.0d0,0.2d0*rcut,fcont,fprimcont)
1255 C Add a new contact, if the SC's are close enough, but not too close (r<sigma).
1256 C
1257               if (fcont.gt.0.0D0) then
1258 C If the SC-SC distance if close to sigma, apply spline.
1259 cAdam           call gcont(-rij,-1.03d0*sigij,2.0d0*sigij,1.0d0,
1260 cAdam &             fcont1,fprimcont1)
1261 cAdam           fcont1=1.0d0-fcont1
1262 cAdam           if (fcont1.gt.0.0d0) then
1263 cAdam             fprimcont=fprimcont*fcont1+fcont*fprimcont1
1264 cAdam             fcont=fcont*fcont1
1265 cAdam           endif
1266 C Uncomment following 4 lines to have the geometric average of the epsilon0's
1267 cga             eps0ij=1.0d0/dsqrt(eps0ij)
1268 cga             do k=1,3
1269 cga               gg(k)=gg(k)*eps0ij
1270 cga             enddo
1271 cga             eps0ij=-evdwij*eps0ij
1272 C Uncomment for AL's type of SC correlation interactions.
1273 cadam           eps0ij=-evdwij
1274                 num_conti=num_conti+1
1275                 jcont(num_conti,i)=j
1276                 facont(num_conti,i)=fcont*eps0ij
1277                 fprimcont=eps0ij*fprimcont/rij
1278                 fcont=expon*fcont
1279 cAdam           gacont(1,num_conti,i)=-fprimcont*xj+fcont*gg(1)
1280 cAdam           gacont(2,num_conti,i)=-fprimcont*yj+fcont*gg(2)
1281 cAdam           gacont(3,num_conti,i)=-fprimcont*zj+fcont*gg(3)
1282 C Uncomment following 3 lines for Skolnick's type of SC correlation.
1283                 gacont(1,num_conti,i)=-fprimcont*xj
1284                 gacont(2,num_conti,i)=-fprimcont*yj
1285                 gacont(3,num_conti,i)=-fprimcont*zj
1286 cd              write (iout,'(2i5,2f10.5)') i,j,rij,facont(num_conti,i)
1287 cd              write (iout,'(2i3,3f10.5)')
1288 cd   &           i,j,(gacont(kk,num_conti,i),kk=1,3)
1289               endif
1290             endif
1291           enddo      ! j
1292         enddo        ! iint
1293 C Change 12/1/95
1294         num_cont(i)=num_conti
1295       enddo          ! i
1296       do i=1,nct
1297         do j=1,3
1298           gvdwc(j,i)=expon*gvdwc(j,i)
1299           gvdwx(j,i)=expon*gvdwx(j,i)
1300         enddo
1301       enddo
1302 C******************************************************************************
1303 C
1304 C                              N O T E !!!
1305 C
1306 C To save time, the factor of EXPON has been extracted from ALL components
1307 C of GVDWC and GRADX. Remember to multiply them by this factor before further
1308 C use!
1309 C
1310 C******************************************************************************
1311       return
1312       end
1313 C-----------------------------------------------------------------------------
1314       subroutine eljk(evdw)
1315 C
1316 C This subroutine calculates the interaction energy of nonbonded side chains
1317 C assuming the LJK potential of interaction.
1318 C
1319       implicit real*8 (a-h,o-z)
1320       include 'DIMENSIONS'
1321       include 'COMMON.GEO'
1322       include 'COMMON.VAR'
1323       include 'COMMON.LOCAL'
1324       include 'COMMON.CHAIN'
1325       include 'COMMON.DERIV'
1326       include 'COMMON.INTERACT'
1327       include 'COMMON.IOUNITS'
1328       include 'COMMON.NAMES'
1329       dimension gg(3)
1330       logical scheck
1331 c     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
1332       evdw=0.0D0
1333       do i=iatsc_s,iatsc_e
1334         itypi=iabs(itype(i))
1335         if (itypi.eq.ntyp1) cycle
1336         itypi1=iabs(itype(i+1))
1337         xi=c(1,nres+i)
1338         yi=c(2,nres+i)
1339         zi=c(3,nres+i)
1340 C
1341 C Calculate SC interaction energy.
1342 C
1343         do iint=1,nint_gr(i)
1344           do j=istart(i,iint),iend(i,iint)
1345             itypj=iabs(itype(j))
1346             if (itypj.eq.ntyp1) cycle
1347             xj=c(1,nres+j)-xi
1348             yj=c(2,nres+j)-yi
1349             zj=c(3,nres+j)-zi
1350             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1351             fac_augm=rrij**expon
1352             e_augm=augm(itypi,itypj)*fac_augm
1353             r_inv_ij=dsqrt(rrij)
1354             rij=1.0D0/r_inv_ij
1355             r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
1356             fac=r_shift_inv**expon
1357 C have you changed here?
1358             e1=fac*fac*aa
1359             e2=fac*bb
1360             evdwij=e_augm+e1+e2
1361 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1362 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1363 cd          write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
1364 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
1365 cd   &        bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
1366 cd   &        sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
1367 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1368             evdw=evdw+evdwij
1369 C
1370 C Calculate the components of the gradient in DC and X
1371 C
1372             fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
1373             gg(1)=xj*fac
1374             gg(2)=yj*fac
1375             gg(3)=zj*fac
1376             do k=1,3
1377               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1378               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1379               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1380               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1381             enddo
1382 cgrad            do k=i,j-1
1383 cgrad              do l=1,3
1384 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1385 cgrad              enddo
1386 cgrad            enddo
1387           enddo      ! j
1388         enddo        ! iint
1389       enddo          ! i
1390       do i=1,nct
1391         do j=1,3
1392           gvdwc(j,i)=expon*gvdwc(j,i)
1393           gvdwx(j,i)=expon*gvdwx(j,i)
1394         enddo
1395       enddo
1396       return
1397       end
1398 C-----------------------------------------------------------------------------
1399       subroutine ebp(evdw)
1400 C
1401 C This subroutine calculates the interaction energy of nonbonded side chains
1402 C assuming the Berne-Pechukas potential of interaction.
1403 C
1404       implicit real*8 (a-h,o-z)
1405       include 'DIMENSIONS'
1406       include 'COMMON.GEO'
1407       include 'COMMON.VAR'
1408       include 'COMMON.LOCAL'
1409       include 'COMMON.CHAIN'
1410       include 'COMMON.DERIV'
1411       include 'COMMON.NAMES'
1412       include 'COMMON.INTERACT'
1413       include 'COMMON.IOUNITS'
1414       include 'COMMON.CALC'
1415       common /srutu/ icall
1416 c     double precision rrsave(maxdim)
1417       logical lprn
1418       evdw=0.0D0
1419 c     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
1420       evdw=0.0D0
1421 c     if (icall.eq.0) then
1422 c       lprn=.true.
1423 c     else
1424         lprn=.false.
1425 c     endif
1426       ind=0
1427       do i=iatsc_s,iatsc_e
1428         itypi=iabs(itype(i))
1429         if (itypi.eq.ntyp1) cycle
1430         itypi1=iabs(itype(i+1))
1431         xi=c(1,nres+i)
1432         yi=c(2,nres+i)
1433         zi=c(3,nres+i)
1434         dxi=dc_norm(1,nres+i)
1435         dyi=dc_norm(2,nres+i)
1436         dzi=dc_norm(3,nres+i)
1437 c        dsci_inv=dsc_inv(itypi)
1438         dsci_inv=vbld_inv(i+nres)
1439 C
1440 C Calculate SC interaction energy.
1441 C
1442         do iint=1,nint_gr(i)
1443           do j=istart(i,iint),iend(i,iint)
1444             ind=ind+1
1445             itypj=iabs(itype(j))
1446             if (itypj.eq.ntyp1) cycle
1447 c            dscj_inv=dsc_inv(itypj)
1448             dscj_inv=vbld_inv(j+nres)
1449             chi1=chi(itypi,itypj)
1450             chi2=chi(itypj,itypi)
1451             chi12=chi1*chi2
1452             chip1=chip(itypi)
1453             chip2=chip(itypj)
1454             chip12=chip1*chip2
1455             alf1=alp(itypi)
1456             alf2=alp(itypj)
1457             alf12=0.5D0*(alf1+alf2)
1458 C For diagnostics only!!!
1459 c           chi1=0.0D0
1460 c           chi2=0.0D0
1461 c           chi12=0.0D0
1462 c           chip1=0.0D0
1463 c           chip2=0.0D0
1464 c           chip12=0.0D0
1465 c           alf1=0.0D0
1466 c           alf2=0.0D0
1467 c           alf12=0.0D0
1468             xj=c(1,nres+j)-xi
1469             yj=c(2,nres+j)-yi
1470             zj=c(3,nres+j)-zi
1471             dxj=dc_norm(1,nres+j)
1472             dyj=dc_norm(2,nres+j)
1473             dzj=dc_norm(3,nres+j)
1474             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1475 cd          if (icall.eq.0) then
1476 cd            rrsave(ind)=rrij
1477 cd          else
1478 cd            rrij=rrsave(ind)
1479 cd          endif
1480             rij=dsqrt(rrij)
1481 C Calculate the angle-dependent terms of energy & contributions to derivatives.
1482             call sc_angular
1483 C Calculate whole angle-dependent part of epsilon and contributions
1484 C to its derivatives
1485 C have you changed here?
1486             fac=(rrij*sigsq)**expon2
1487             e1=fac*fac*aa
1488             e2=fac*bb
1489             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1490             eps2der=evdwij*eps3rt
1491             eps3der=evdwij*eps2rt
1492             evdwij=evdwij*eps2rt*eps3rt
1493             evdw=evdw+evdwij
1494             if (lprn) then
1495             sigm=dabs(aa/bb)**(1.0D0/6.0D0)
1496             epsi=bb**2/aa
1497 cd            write (iout,'(2(a3,i3,2x),15(0pf7.3))')
1498 cd     &        restyp(itypi),i,restyp(itypj),j,
1499 cd     &        epsi,sigm,chi1,chi2,chip1,chip2,
1500 cd     &        eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
1501 cd     &        om1,om2,om12,1.0D0/dsqrt(rrij),
1502 cd     &        evdwij
1503             endif
1504 C Calculate gradient components.
1505             e1=e1*eps1*eps2rt**2*eps3rt**2
1506             fac=-expon*(e1+evdwij)
1507             sigder=fac/sigsq
1508             fac=rrij*fac
1509 C Calculate radial part of the gradient
1510             gg(1)=xj*fac
1511             gg(2)=yj*fac
1512             gg(3)=zj*fac
1513 C Calculate the angular part of the gradient and sum add the contributions
1514 C to the appropriate components of the Cartesian gradient.
1515             call sc_grad
1516           enddo      ! j
1517         enddo        ! iint
1518       enddo          ! i
1519 c     stop
1520       return
1521       end
1522 C-----------------------------------------------------------------------------
1523       subroutine egb(evdw)
1524 C
1525 C This subroutine calculates the interaction energy of nonbonded side chains
1526 C assuming the Gay-Berne potential of interaction.
1527 C
1528       implicit real*8 (a-h,o-z)
1529       include 'DIMENSIONS'
1530       include 'COMMON.GEO'
1531       include 'COMMON.VAR'
1532       include 'COMMON.LOCAL'
1533       include 'COMMON.CHAIN'
1534       include 'COMMON.DERIV'
1535       include 'COMMON.NAMES'
1536       include 'COMMON.INTERACT'
1537       include 'COMMON.IOUNITS'
1538       include 'COMMON.CALC'
1539       include 'COMMON.CONTROL'
1540       include 'COMMON.SPLITELE'
1541       include 'COMMON.SBRIDGE'
1542       logical lprn
1543       integer xshift,yshift,zshift
1544
1545       evdw=0.0D0
1546 ccccc      energy_dec=.false.
1547 C      print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1548       evdw=0.0D0
1549       lprn=.false.
1550 c     if (icall.eq.0) lprn=.false.
1551       ind=0
1552 C the loop over all 27 posible neigbours (for xshift=0,yshift=0,zshift=0
1553 C we have the original box)
1554 C      do xshift=-1,1
1555 C      do yshift=-1,1
1556 C      do zshift=-1,1
1557       do i=iatsc_s,iatsc_e
1558         itypi=iabs(itype(i))
1559         if (itypi.eq.ntyp1) cycle
1560         itypi1=iabs(itype(i+1))
1561         xi=c(1,nres+i)
1562         yi=c(2,nres+i)
1563         zi=c(3,nres+i)
1564 C Return atom into box, boxxsize is size of box in x dimension
1565 c  134   continue
1566 c        if (xi.gt.((xshift+0.5d0)*boxxsize)) xi=xi-boxxsize
1567 c        if (xi.lt.((xshift-0.5d0)*boxxsize)) xi=xi+boxxsize
1568 C Condition for being inside the proper box
1569 c        if ((xi.gt.((xshift+0.5d0)*boxxsize)).or.
1570 c     &       (xi.lt.((xshift-0.5d0)*boxxsize))) then
1571 c        go to 134
1572 c        endif
1573 c  135   continue
1574 c        if (yi.gt.((yshift+0.5d0)*boxysize)) yi=yi-boxysize
1575 c        if (yi.lt.((yshift-0.5d0)*boxysize)) yi=yi+boxysize
1576 C Condition for being inside the proper box
1577 c        if ((yi.gt.((yshift+0.5d0)*boxysize)).or.
1578 c     &       (yi.lt.((yshift-0.5d0)*boxysize))) then
1579 c        go to 135
1580 c        endif
1581 c  136   continue
1582 c        if (zi.gt.((zshift+0.5d0)*boxzsize)) zi=zi-boxzsize
1583 c        if (zi.lt.((zshift-0.5d0)*boxzsize)) zi=zi+boxzsize
1584 C Condition for being inside the proper box
1585 c        if ((zi.gt.((zshift+0.5d0)*boxzsize)).or.
1586 c     &       (zi.lt.((zshift-0.5d0)*boxzsize))) then
1587 c        go to 136
1588 c        endif
1589           xi=mod(xi,boxxsize)
1590           if (xi.lt.0) xi=xi+boxxsize
1591           yi=mod(yi,boxysize)
1592           if (yi.lt.0) yi=yi+boxysize
1593           zi=mod(zi,boxzsize)
1594           if (zi.lt.0) zi=zi+boxzsize
1595 C define scaling factor for lipids
1596
1597 C        if (positi.le.0) positi=positi+boxzsize
1598 C        print *,i
1599 C first for peptide groups
1600 c for each residue check if it is in lipid or lipid water border area
1601        if ((zi.gt.bordlipbot)
1602      &.and.(zi.lt.bordliptop)) then
1603 C the energy transfer exist
1604         if (zi.lt.buflipbot) then
1605 C what fraction I am in
1606          fracinbuf=1.0d0-
1607      &        ((zi-bordlipbot)/lipbufthick)
1608 C lipbufthick is thickenes of lipid buffore
1609          sslipi=sscalelip(fracinbuf)
1610          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
1611         elseif (zi.gt.bufliptop) then
1612          fracinbuf=1.0d0-((bordliptop-zi)/lipbufthick)
1613          sslipi=sscalelip(fracinbuf)
1614          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
1615         else
1616          sslipi=1.0d0
1617          ssgradlipi=0.0
1618         endif
1619        else
1620          sslipi=0.0d0
1621          ssgradlipi=0.0
1622        endif
1623
1624 C          xi=xi+xshift*boxxsize
1625 C          yi=yi+yshift*boxysize
1626 C          zi=zi+zshift*boxzsize
1627
1628         dxi=dc_norm(1,nres+i)
1629         dyi=dc_norm(2,nres+i)
1630         dzi=dc_norm(3,nres+i)
1631 c        dsci_inv=dsc_inv(itypi)
1632         dsci_inv=vbld_inv(i+nres)
1633 c        write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)
1634 c        write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi
1635 C
1636 C Calculate SC interaction energy.
1637 C
1638         do iint=1,nint_gr(i)
1639           do j=istart(i,iint),iend(i,iint)
1640             IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN
1641
1642 c              write(iout,*) "PRZED ZWYKLE", evdwij
1643               call dyn_ssbond_ene(i,j,evdwij)
1644 c              write(iout,*) "PO ZWYKLE", evdwij
1645
1646               evdw=evdw+evdwij
1647               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)')
1648      &                        'evdw',i,j,evdwij,' ss'
1649 C triple bond artifac removal
1650              do k=j+1,iend(i,iint)
1651 C search over all next residues
1652               if (dyn_ss_mask(k)) then
1653 C check if they are cysteins
1654 C              write(iout,*) 'k=',k
1655
1656 c              write(iout,*) "PRZED TRI", evdwij
1657                evdwij_przed_tri=evdwij
1658               call triple_ssbond_ene(i,j,k,evdwij)
1659 c               if(evdwij_przed_tri.ne.evdwij) then
1660 c                 write (iout,*) "TRI:", evdwij, evdwij_przed_tri
1661 c               endif
1662
1663 c              write(iout,*) "PO TRI", evdwij
1664 C call the energy function that removes the artifical triple disulfide
1665 C bond the soubroutine is located in ssMD.F
1666               evdw=evdw+evdwij
1667               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)')
1668      &                        'evdw',i,j,evdwij,'tss'
1669               endif!dyn_ss_mask(k)
1670              enddo! k
1671             ELSE
1672             ind=ind+1
1673             itypj=iabs(itype(j))
1674             if (itypj.eq.ntyp1) cycle
1675 c            dscj_inv=dsc_inv(itypj)
1676             dscj_inv=vbld_inv(j+nres)
1677 c            write (iout,*) "j",j,dsc_inv(itypj),dscj_inv,
1678 c     &       1.0d0/vbld(j+nres)
1679 c            write (iout,*) "i",i," j", j," itype",itype(i),itype(j)
1680             sig0ij=sigma(itypi,itypj)
1681             chi1=chi(itypi,itypj)
1682             chi2=chi(itypj,itypi)
1683             chi12=chi1*chi2
1684             chip1=chip(itypi)
1685             chip2=chip(itypj)
1686             chip12=chip1*chip2
1687             alf1=alp(itypi)
1688             alf2=alp(itypj)
1689             alf12=0.5D0*(alf1+alf2)
1690 C For diagnostics only!!!
1691 c           chi1=0.0D0
1692 c           chi2=0.0D0
1693 c           chi12=0.0D0
1694 c           chip1=0.0D0
1695 c           chip2=0.0D0
1696 c           chip12=0.0D0
1697 c           alf1=0.0D0
1698 c           alf2=0.0D0
1699 c           alf12=0.0D0
1700             xj=c(1,nres+j)
1701             yj=c(2,nres+j)
1702             zj=c(3,nres+j)
1703 C Return atom J into box the original box
1704 c  137   continue
1705 c        if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
1706 c        if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
1707 C Condition for being inside the proper box
1708 c        if ((xj.gt.((0.5d0)*boxxsize)).or.
1709 c     &       (xj.lt.((-0.5d0)*boxxsize))) then
1710 c        go to 137
1711 c        endif
1712 c  138   continue
1713 c        if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
1714 c        if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
1715 C Condition for being inside the proper box
1716 c        if ((yj.gt.((0.5d0)*boxysize)).or.
1717 c     &       (yj.lt.((-0.5d0)*boxysize))) then
1718 c        go to 138
1719 c        endif
1720 c  139   continue
1721 c        if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
1722 c        if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
1723 C Condition for being inside the proper box
1724 c        if ((zj.gt.((0.5d0)*boxzsize)).or.
1725 c     &       (zj.lt.((-0.5d0)*boxzsize))) then
1726 c        go to 139
1727 c        endif
1728           xj=mod(xj,boxxsize)
1729           if (xj.lt.0) xj=xj+boxxsize
1730           yj=mod(yj,boxysize)
1731           if (yj.lt.0) yj=yj+boxysize
1732           zj=mod(zj,boxzsize)
1733           if (zj.lt.0) zj=zj+boxzsize
1734        if ((zj.gt.bordlipbot)
1735      &.and.(zj.lt.bordliptop)) then
1736 C the energy transfer exist
1737         if (zj.lt.buflipbot) then
1738 C what fraction I am in
1739          fracinbuf=1.0d0-
1740      &        ((zj-bordlipbot)/lipbufthick)
1741 C lipbufthick is thickenes of lipid buffore
1742          sslipj=sscalelip(fracinbuf)
1743          ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
1744         elseif (zj.gt.bufliptop) then
1745          fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
1746          sslipj=sscalelip(fracinbuf)
1747          ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
1748         else
1749          sslipj=1.0d0
1750          ssgradlipj=0.0
1751         endif
1752        else
1753          sslipj=0.0d0
1754          ssgradlipj=0.0
1755        endif
1756       aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
1757      &  +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1758       bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
1759      &  +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1760 C      if (aa.ne.aa_aq(itypi,itypj)) write(63,'(2e10.5)')
1761 C     &(aa-aa_aq(itypi,itypj)),(bb-bb_aq(itypi,itypj))
1762 C      if (ssgradlipj.gt.0.0d0) print *,"??WTF??"
1763 C      print *,sslipi,sslipj,bordlipbot,zi,zj
1764       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
1765       xj_safe=xj
1766       yj_safe=yj
1767       zj_safe=zj
1768       subchap=0
1769       do xshift=-1,1
1770       do yshift=-1,1
1771       do zshift=-1,1
1772           xj=xj_safe+xshift*boxxsize
1773           yj=yj_safe+yshift*boxysize
1774           zj=zj_safe+zshift*boxzsize
1775           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
1776           if(dist_temp.lt.dist_init) then
1777             dist_init=dist_temp
1778             xj_temp=xj
1779             yj_temp=yj
1780             zj_temp=zj
1781             subchap=1
1782           endif
1783        enddo
1784        enddo
1785        enddo
1786        if (subchap.eq.1) then
1787           xj=xj_temp-xi
1788           yj=yj_temp-yi
1789           zj=zj_temp-zi
1790        else
1791           xj=xj_safe-xi
1792           yj=yj_safe-yi
1793           zj=zj_safe-zi
1794        endif
1795             dxj=dc_norm(1,nres+j)
1796             dyj=dc_norm(2,nres+j)
1797             dzj=dc_norm(3,nres+j)
1798 C            xj=xj-xi
1799 C            yj=yj-yi
1800 C            zj=zj-zi
1801 c            write (iout,*) "dcnorj",dxi*dxi+dyi*dyi+dzi*dzi
1802 c            write (iout,*) "j",j," dc_norm",
1803 c     &       dc_norm(1,nres+j),dc_norm(2,nres+j),dc_norm(3,nres+j)
1804             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1805             rij=dsqrt(rrij)
1806             sss=sscale((1.0d0/rij)/sigma(itypi,itypj))
1807             sssgrad=sscagrad((1.0d0/rij)/sigma(itypi,itypj))
1808
1809 c            write (iout,'(a7,4f8.3)')
1810 c    &      "ssscale",sss,((1.0d0/rij)/sigma(itypi,itypj)),r_cut,rlamb
1811             if (sss.gt.0.0d0) then
1812 C Calculate angle-dependent terms of energy and contributions to their
1813 C derivatives.
1814             call sc_angular
1815             sigsq=1.0D0/sigsq
1816             sig=sig0ij*dsqrt(sigsq)
1817             rij_shift=1.0D0/rij-sig+sig0ij
1818 c for diagnostics; uncomment
1819 c            rij_shift=1.2*sig0ij
1820 C I hate to put IF's in the loops, but here don't have another choice!!!!
1821             if (rij_shift.le.0.0D0) then
1822               evdw=1.0D20
1823 cd              write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1824 cd     &        restyp(itypi),i,restyp(itypj),j,
1825 cd     &        rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq)
1826               return
1827             endif
1828             sigder=-sig*sigsq
1829 c---------------------------------------------------------------
1830             rij_shift=1.0D0/rij_shift
1831             fac=rij_shift**expon
1832 C here to start with
1833 C            if (c(i,3).gt.
1834             faclip=fac
1835             e1=fac*fac*aa
1836             e2=fac*bb
1837             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1838             eps2der=evdwij*eps3rt
1839             eps3der=evdwij*eps2rt
1840 C       write(63,'(2i3,2e10.3,2f10.5)') i,j,aa,bb, evdwij,
1841 C     &((sslipi+sslipj)/2.0d0+
1842 C     &(2.0d0-sslipi-sslipj)/2.0d0)
1843 c            write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt,
1844 c     &        " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2
1845             evdwij=evdwij*eps2rt*eps3rt
1846             evdw=evdw+evdwij*sss
1847             if (lprn) then
1848             sigm=dabs(aa/bb)**(1.0D0/6.0D0)
1849             epsi=bb**2/aa
1850             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1851      &        restyp(itypi),i,restyp(itypj),j,
1852      &        epsi,sigm,chi1,chi2,chip1,chip2,
1853      &        eps1,eps2rt**2,eps3rt**2,sig,sig0ij,
1854      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1855      &        evdwij
1856             endif
1857
1858             if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
1859      &                        'evdw',i,j,evdwij
1860
1861 C Calculate gradient components.
1862             e1=e1*eps1*eps2rt**2*eps3rt**2
1863             fac=-expon*(e1+evdwij)*rij_shift
1864             sigder=fac*sigder
1865             fac=rij*fac
1866 c            print '(2i4,6f8.4)',i,j,sss,sssgrad*
1867 c     &      evdwij,fac,sigma(itypi,itypj),expon
1868             fac=fac+evdwij/sss*sssgrad/sigma(itypi,itypj)*rij
1869 c            fac=0.0d0
1870 C Calculate the radial part of the gradient
1871             gg_lipi(3)=eps1*(eps2rt*eps2rt)
1872      &*(eps3rt*eps3rt)*sss/2.0d0*(faclip*faclip*
1873      & (aa_lip(itypi,itypj)-aa_aq(itypi,itypj))
1874      &+faclip*(bb_lip(itypi,itypj)-bb_aq(itypi,itypj)))
1875             gg_lipj(3)=ssgradlipj*gg_lipi(3)
1876             gg_lipi(3)=gg_lipi(3)*ssgradlipi
1877 C            gg_lipi(3)=0.0d0
1878 C            gg_lipj(3)=0.0d0
1879             gg(1)=xj*fac
1880             gg(2)=yj*fac
1881             gg(3)=zj*fac
1882 C Calculate angular part of the gradient.
1883             call sc_grad
1884             endif
1885             ENDIF    ! dyn_ss
1886           enddo      ! j
1887         enddo        ! iint
1888       enddo          ! i
1889 C      enddo          ! zshift
1890 C      enddo          ! yshift
1891 C      enddo          ! xshift
1892 c      write (iout,*) "Number of loop steps in EGB:",ind
1893 cccc      energy_dec=.false.
1894       return
1895       end
1896 C-----------------------------------------------------------------------------
1897       subroutine egbv(evdw)
1898 C
1899 C This subroutine calculates the interaction energy of nonbonded side chains
1900 C assuming the Gay-Berne-Vorobjev potential of interaction.
1901 C
1902       implicit real*8 (a-h,o-z)
1903       include 'DIMENSIONS'
1904       include 'COMMON.GEO'
1905       include 'COMMON.VAR'
1906       include 'COMMON.LOCAL'
1907       include 'COMMON.CHAIN'
1908       include 'COMMON.DERIV'
1909       include 'COMMON.NAMES'
1910       include 'COMMON.INTERACT'
1911       include 'COMMON.IOUNITS'
1912       include 'COMMON.CALC'
1913       common /srutu/ icall
1914       logical lprn
1915       evdw=0.0D0
1916 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1917       evdw=0.0D0
1918       lprn=.false.
1919 c     if (icall.eq.0) lprn=.true.
1920       ind=0
1921       do i=iatsc_s,iatsc_e
1922         itypi=iabs(itype(i))
1923         if (itypi.eq.ntyp1) cycle
1924         itypi1=iabs(itype(i+1))
1925         xi=c(1,nres+i)
1926         yi=c(2,nres+i)
1927         zi=c(3,nres+i)
1928           xi=mod(xi,boxxsize)
1929           if (xi.lt.0) xi=xi+boxxsize
1930           yi=mod(yi,boxysize)
1931           if (yi.lt.0) yi=yi+boxysize
1932           zi=mod(zi,boxzsize)
1933           if (zi.lt.0) zi=zi+boxzsize
1934 C define scaling factor for lipids
1935
1936 C        if (positi.le.0) positi=positi+boxzsize
1937 C        print *,i
1938 C first for peptide groups
1939 c for each residue check if it is in lipid or lipid water border area
1940        if ((zi.gt.bordlipbot)
1941      &.and.(zi.lt.bordliptop)) then
1942 C the energy transfer exist
1943         if (zi.lt.buflipbot) then
1944 C what fraction I am in
1945          fracinbuf=1.0d0-
1946      &        ((zi-bordlipbot)/lipbufthick)
1947 C lipbufthick is thickenes of lipid buffore
1948          sslipi=sscalelip(fracinbuf)
1949          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
1950         elseif (zi.gt.bufliptop) then
1951          fracinbuf=1.0d0-((bordliptop-zi)/lipbufthick)
1952          sslipi=sscalelip(fracinbuf)
1953          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
1954         else
1955          sslipi=1.0d0
1956          ssgradlipi=0.0
1957         endif
1958        else
1959          sslipi=0.0d0
1960          ssgradlipi=0.0
1961        endif
1962
1963         dxi=dc_norm(1,nres+i)
1964         dyi=dc_norm(2,nres+i)
1965         dzi=dc_norm(3,nres+i)
1966 c        dsci_inv=dsc_inv(itypi)
1967         dsci_inv=vbld_inv(i+nres)
1968 C
1969 C Calculate SC interaction energy.
1970 C
1971         do iint=1,nint_gr(i)
1972           do j=istart(i,iint),iend(i,iint)
1973             ind=ind+1
1974             itypj=iabs(itype(j))
1975             if (itypj.eq.ntyp1) cycle
1976 c            dscj_inv=dsc_inv(itypj)
1977             dscj_inv=vbld_inv(j+nres)
1978             sig0ij=sigma(itypi,itypj)
1979             r0ij=r0(itypi,itypj)
1980             chi1=chi(itypi,itypj)
1981             chi2=chi(itypj,itypi)
1982             chi12=chi1*chi2
1983             chip1=chip(itypi)
1984             chip2=chip(itypj)
1985             chip12=chip1*chip2
1986             alf1=alp(itypi)
1987             alf2=alp(itypj)
1988             alf12=0.5D0*(alf1+alf2)
1989 C For diagnostics only!!!
1990 c           chi1=0.0D0
1991 c           chi2=0.0D0
1992 c           chi12=0.0D0
1993 c           chip1=0.0D0
1994 c           chip2=0.0D0
1995 c           chip12=0.0D0
1996 c           alf1=0.0D0
1997 c           alf2=0.0D0
1998 c           alf12=0.0D0
1999 C            xj=c(1,nres+j)-xi
2000 C            yj=c(2,nres+j)-yi
2001 C            zj=c(3,nres+j)-zi
2002           xj=mod(xj,boxxsize)
2003           if (xj.lt.0) xj=xj+boxxsize
2004           yj=mod(yj,boxysize)
2005           if (yj.lt.0) yj=yj+boxysize
2006           zj=mod(zj,boxzsize)
2007           if (zj.lt.0) zj=zj+boxzsize
2008        if ((zj.gt.bordlipbot)
2009      &.and.(zj.lt.bordliptop)) then
2010 C the energy transfer exist
2011         if (zj.lt.buflipbot) then
2012 C what fraction I am in
2013          fracinbuf=1.0d0-
2014      &        ((zj-bordlipbot)/lipbufthick)
2015 C lipbufthick is thickenes of lipid buffore
2016          sslipj=sscalelip(fracinbuf)
2017          ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
2018         elseif (zj.gt.bufliptop) then
2019          fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
2020          sslipj=sscalelip(fracinbuf)
2021          ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
2022         else
2023          sslipj=1.0d0
2024          ssgradlipj=0.0
2025         endif
2026        else
2027          sslipj=0.0d0
2028          ssgradlipj=0.0
2029        endif
2030       aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
2031      &  +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
2032       bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
2033      &  +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
2034 C      if (aa.ne.aa_aq(itypi,itypj)) write(63,'2e10.5')
2035 C     &(aa-aa_aq(itypi,itypj)),(bb-bb_aq(itypi,itypj))
2036       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
2037       xj_safe=xj
2038       yj_safe=yj
2039       zj_safe=zj
2040       subchap=0
2041       do xshift=-1,1
2042       do yshift=-1,1
2043       do zshift=-1,1
2044           xj=xj_safe+xshift*boxxsize
2045           yj=yj_safe+yshift*boxysize
2046           zj=zj_safe+zshift*boxzsize
2047           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
2048           if(dist_temp.lt.dist_init) then
2049             dist_init=dist_temp
2050             xj_temp=xj
2051             yj_temp=yj
2052             zj_temp=zj
2053             subchap=1
2054           endif
2055        enddo
2056        enddo
2057        enddo
2058        if (subchap.eq.1) then
2059           xj=xj_temp-xi
2060           yj=yj_temp-yi
2061           zj=zj_temp-zi
2062        else
2063           xj=xj_safe-xi
2064           yj=yj_safe-yi
2065           zj=zj_safe-zi
2066        endif
2067             dxj=dc_norm(1,nres+j)
2068             dyj=dc_norm(2,nres+j)
2069             dzj=dc_norm(3,nres+j)
2070             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
2071             rij=dsqrt(rrij)
2072 C Calculate angle-dependent terms of energy and contributions to their
2073 C derivatives.
2074             call sc_angular
2075             sigsq=1.0D0/sigsq
2076             sig=sig0ij*dsqrt(sigsq)
2077             rij_shift=1.0D0/rij-sig+r0ij
2078 C I hate to put IF's in the loops, but here don't have another choice!!!!
2079             if (rij_shift.le.0.0D0) then
2080               evdw=1.0D20
2081               return
2082             endif
2083             sigder=-sig*sigsq
2084 c---------------------------------------------------------------
2085             rij_shift=1.0D0/rij_shift
2086             fac=rij_shift**expon
2087             e1=fac*fac*aa
2088             e2=fac*bb
2089             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
2090             eps2der=evdwij*eps3rt
2091             eps3der=evdwij*eps2rt
2092             fac_augm=rrij**expon
2093             e_augm=augm(itypi,itypj)*fac_augm
2094             evdwij=evdwij*eps2rt*eps3rt
2095             evdw=evdw+evdwij+e_augm
2096             if (lprn) then
2097             sigm=dabs(aa/bb)**(1.0D0/6.0D0)
2098             epsi=bb**2/aa
2099             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
2100      &        restyp(itypi),i,restyp(itypj),j,
2101      &        epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),
2102      &        chi1,chi2,chip1,chip2,
2103      &        eps1,eps2rt**2,eps3rt**2,
2104      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
2105      &        evdwij+e_augm
2106             endif
2107 C Calculate gradient components.
2108             e1=e1*eps1*eps2rt**2*eps3rt**2
2109             fac=-expon*(e1+evdwij)*rij_shift
2110             sigder=fac*sigder
2111             fac=rij*fac-2*expon*rrij*e_augm
2112             fac=fac+evdwij/sss*sssgrad/sigma(itypi,itypj)*rij
2113 C Calculate the radial part of the gradient
2114             gg(1)=xj*fac
2115             gg(2)=yj*fac
2116             gg(3)=zj*fac
2117 C Calculate angular part of the gradient.
2118             call sc_grad
2119           enddo      ! j
2120         enddo        ! iint
2121       enddo          ! i
2122       end
2123 C-----------------------------------------------------------------------------
2124       subroutine sc_angular
2125 C Calculate eps1,eps2,eps3,sigma, and parts of their derivatives in om1,om2,
2126 C om12. Called by ebp, egb, and egbv.
2127       implicit none
2128       include 'COMMON.CALC'
2129       include 'COMMON.IOUNITS'
2130       erij(1)=xj*rij
2131       erij(2)=yj*rij
2132       erij(3)=zj*rij
2133       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
2134       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
2135       om12=dxi*dxj+dyi*dyj+dzi*dzj
2136       chiom12=chi12*om12
2137 C Calculate eps1(om12) and its derivative in om12
2138       faceps1=1.0D0-om12*chiom12
2139       faceps1_inv=1.0D0/faceps1
2140       eps1=dsqrt(faceps1_inv)
2141 C Following variable is eps1*deps1/dom12
2142       eps1_om12=faceps1_inv*chiom12
2143 c diagnostics only
2144 c      faceps1_inv=om12
2145 c      eps1=om12
2146 c      eps1_om12=1.0d0
2147 c      write (iout,*) "om12",om12," eps1",eps1
2148 C Calculate sigma(om1,om2,om12) and the derivatives of sigma**2 in om1,om2,
2149 C and om12.
2150       om1om2=om1*om2
2151       chiom1=chi1*om1
2152       chiom2=chi2*om2
2153       facsig=om1*chiom1+om2*chiom2-2.0D0*om1om2*chiom12
2154       sigsq=1.0D0-facsig*faceps1_inv
2155       sigsq_om1=(chiom1-chiom12*om2)*faceps1_inv
2156       sigsq_om2=(chiom2-chiom12*om1)*faceps1_inv
2157       sigsq_om12=-chi12*(om1om2*faceps1-om12*facsig)*faceps1_inv**2
2158 c diagnostics only
2159 c      sigsq=1.0d0
2160 c      sigsq_om1=0.0d0
2161 c      sigsq_om2=0.0d0
2162 c      sigsq_om12=0.0d0
2163 c      write (iout,*) "chiom1",chiom1," chiom2",chiom2," chiom12",chiom12
2164 c      write (iout,*) "faceps1",faceps1," faceps1_inv",faceps1_inv,
2165 c     &    " eps1",eps1
2166 C Calculate eps2 and its derivatives in om1, om2, and om12.
2167       chipom1=chip1*om1
2168       chipom2=chip2*om2
2169       chipom12=chip12*om12
2170       facp=1.0D0-om12*chipom12
2171       facp_inv=1.0D0/facp
2172       facp1=om1*chipom1+om2*chipom2-2.0D0*om1om2*chipom12
2173 c      write (iout,*) "chipom1",chipom1," chipom2",chipom2,
2174 c     &  " chipom12",chipom12," facp",facp," facp_inv",facp_inv
2175 C Following variable is the square root of eps2
2176       eps2rt=1.0D0-facp1*facp_inv
2177 C Following three variables are the derivatives of the square root of eps
2178 C in om1, om2, and om12.
2179       eps2rt_om1=-4.0D0*(chipom1-chipom12*om2)*facp_inv
2180       eps2rt_om2=-4.0D0*(chipom2-chipom12*om1)*facp_inv
2181       eps2rt_om12=4.0D0*chip12*(om1om2*facp-om12*facp1)*facp_inv**2
2182 C Evaluate the "asymmetric" factor in the VDW constant, eps3
2183       eps3rt=1.0D0-alf1*om1+alf2*om2-alf12*om12
2184 c      write (iout,*) "eps2rt",eps2rt," eps3rt",eps3rt
2185 c      write (iout,*) "eps2rt_om1",eps2rt_om1," eps2rt_om2",eps2rt_om2,
2186 c     &  " eps2rt_om12",eps2rt_om12
2187 C Calculate whole angle-dependent part of epsilon and contributions
2188 C to its derivatives
2189       return
2190       end
2191 C----------------------------------------------------------------------------
2192       subroutine sc_grad
2193       implicit real*8 (a-h,o-z)
2194       include 'DIMENSIONS'
2195       include 'COMMON.CHAIN'
2196       include 'COMMON.DERIV'
2197       include 'COMMON.CALC'
2198       include 'COMMON.IOUNITS'
2199       double precision dcosom1(3),dcosom2(3)
2200 cc      print *,'sss=',sss
2201       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
2202       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
2203       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12
2204      &     -2.0D0*alf12*eps3der+sigder*sigsq_om12
2205 c diagnostics only
2206 c      eom1=0.0d0
2207 c      eom2=0.0d0
2208 c      eom12=evdwij*eps1_om12
2209 c end diagnostics
2210 c      write (iout,*) "eps2der",eps2der," eps3der",eps3der,
2211 c     &  " sigder",sigder
2212 c      write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12
2213 c      write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12
2214       do k=1,3
2215         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
2216         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
2217       enddo
2218       do k=1,3
2219         gg(k)=(gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k))*sss
2220       enddo
2221 c      write (iout,*) "gg",(gg(k),k=1,3)
2222       do k=1,3
2223         gvdwx(k,i)=gvdwx(k,i)-gg(k)+gg_lipi(k)
2224      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
2225      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv*sss
2226         gvdwx(k,j)=gvdwx(k,j)+gg(k)+gg_lipj(k)
2227      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
2228      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv*sss
2229 c        write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
2230 c     &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
2231 c        write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
2232 c     &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
2233       enddo
2234 C
2235 C Calculate the components of the gradient in DC and X
2236 C
2237 cgrad      do k=i,j-1
2238 cgrad        do l=1,3
2239 cgrad          gvdwc(l,k)=gvdwc(l,k)+gg(l)
2240 cgrad        enddo
2241 cgrad      enddo
2242       do l=1,3
2243         gvdwc(l,i)=gvdwc(l,i)-gg(l)+gg_lipi(l)
2244         gvdwc(l,j)=gvdwc(l,j)+gg(l)+gg_lipj(l)
2245       enddo
2246       return
2247       end
2248 C-----------------------------------------------------------------------
2249       subroutine e_softsphere(evdw)
2250 C
2251 C This subroutine calculates the interaction energy of nonbonded side chains
2252 C assuming the LJ potential of interaction.
2253 C
2254       implicit real*8 (a-h,o-z)
2255       include 'DIMENSIONS'
2256       parameter (accur=1.0d-10)
2257       include 'COMMON.GEO'
2258       include 'COMMON.VAR'
2259       include 'COMMON.LOCAL'
2260       include 'COMMON.CHAIN'
2261       include 'COMMON.DERIV'
2262       include 'COMMON.INTERACT'
2263       include 'COMMON.TORSION'
2264       include 'COMMON.SBRIDGE'
2265       include 'COMMON.NAMES'
2266       include 'COMMON.IOUNITS'
2267       include 'COMMON.CONTACTS'
2268       dimension gg(3)
2269 cd    print *,'Entering Esoft_sphere nnt=',nnt,' nct=',nct
2270       evdw=0.0D0
2271       do i=iatsc_s,iatsc_e
2272         itypi=iabs(itype(i))
2273         if (itypi.eq.ntyp1) cycle
2274         itypi1=iabs(itype(i+1))
2275         xi=c(1,nres+i)
2276         yi=c(2,nres+i)
2277         zi=c(3,nres+i)
2278 C
2279 C Calculate SC interaction energy.
2280 C
2281         do iint=1,nint_gr(i)
2282 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
2283 cd   &                  'iend=',iend(i,iint)
2284           do j=istart(i,iint),iend(i,iint)
2285             itypj=iabs(itype(j))
2286             if (itypj.eq.ntyp1) cycle
2287             xj=c(1,nres+j)-xi
2288             yj=c(2,nres+j)-yi
2289             zj=c(3,nres+j)-zi
2290             rij=xj*xj+yj*yj+zj*zj
2291 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
2292             r0ij=r0(itypi,itypj)
2293             r0ijsq=r0ij*r0ij
2294 c            print *,i,j,r0ij,dsqrt(rij)
2295             if (rij.lt.r0ijsq) then
2296               evdwij=0.25d0*(rij-r0ijsq)**2
2297               fac=rij-r0ijsq
2298             else
2299               evdwij=0.0d0
2300               fac=0.0d0
2301             endif
2302             evdw=evdw+evdwij
2303 C
2304 C Calculate the components of the gradient in DC and X
2305 C
2306             gg(1)=xj*fac
2307             gg(2)=yj*fac
2308             gg(3)=zj*fac
2309             do k=1,3
2310               gvdwx(k,i)=gvdwx(k,i)-gg(k)
2311               gvdwx(k,j)=gvdwx(k,j)+gg(k)
2312               gvdwc(k,i)=gvdwc(k,i)-gg(k)
2313               gvdwc(k,j)=gvdwc(k,j)+gg(k)
2314             enddo
2315 cgrad            do k=i,j-1
2316 cgrad              do l=1,3
2317 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
2318 cgrad              enddo
2319 cgrad            enddo
2320           enddo ! j
2321         enddo ! iint
2322       enddo ! i
2323       return
2324       end
2325 C--------------------------------------------------------------------------
2326       subroutine eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,
2327      &              eello_turn4)
2328 C
2329 C Soft-sphere potential of p-p interaction
2330 C
2331       implicit real*8 (a-h,o-z)
2332       include 'DIMENSIONS'
2333       include 'COMMON.CONTROL'
2334       include 'COMMON.IOUNITS'
2335       include 'COMMON.GEO'
2336       include 'COMMON.VAR'
2337       include 'COMMON.LOCAL'
2338       include 'COMMON.CHAIN'
2339       include 'COMMON.DERIV'
2340       include 'COMMON.INTERACT'
2341       include 'COMMON.CONTACTS'
2342       include 'COMMON.TORSION'
2343       include 'COMMON.VECTORS'
2344       include 'COMMON.FFIELD'
2345       dimension ggg(3)
2346 C      write(iout,*) 'In EELEC_soft_sphere'
2347       ees=0.0D0
2348       evdw1=0.0D0
2349       eel_loc=0.0d0
2350       eello_turn3=0.0d0
2351       eello_turn4=0.0d0
2352       ind=0
2353       do i=iatel_s,iatel_e
2354         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
2355         dxi=dc(1,i)
2356         dyi=dc(2,i)
2357         dzi=dc(3,i)
2358         xmedi=c(1,i)+0.5d0*dxi
2359         ymedi=c(2,i)+0.5d0*dyi
2360         zmedi=c(3,i)+0.5d0*dzi
2361           xmedi=mod(xmedi,boxxsize)
2362           if (xmedi.lt.0) xmedi=xmedi+boxxsize
2363           ymedi=mod(ymedi,boxysize)
2364           if (ymedi.lt.0) ymedi=ymedi+boxysize
2365           zmedi=mod(zmedi,boxzsize)
2366           if (zmedi.lt.0) zmedi=zmedi+boxzsize
2367         num_conti=0
2368 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
2369         do j=ielstart(i),ielend(i)
2370           if (itype(j).eq.ntyp1 .or. itype(j+1).eq.ntyp1) cycle
2371           ind=ind+1
2372           iteli=itel(i)
2373           itelj=itel(j)
2374           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
2375           r0ij=rpp(iteli,itelj)
2376           r0ijsq=r0ij*r0ij
2377           dxj=dc(1,j)
2378           dyj=dc(2,j)
2379           dzj=dc(3,j)
2380           xj=c(1,j)+0.5D0*dxj
2381           yj=c(2,j)+0.5D0*dyj
2382           zj=c(3,j)+0.5D0*dzj
2383           xj=mod(xj,boxxsize)
2384           if (xj.lt.0) xj=xj+boxxsize
2385           yj=mod(yj,boxysize)
2386           if (yj.lt.0) yj=yj+boxysize
2387           zj=mod(zj,boxzsize)
2388           if (zj.lt.0) zj=zj+boxzsize
2389       dist_init=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
2390       xj_safe=xj
2391       yj_safe=yj
2392       zj_safe=zj
2393       isubchap=0
2394       do xshift=-1,1
2395       do yshift=-1,1
2396       do zshift=-1,1
2397           xj=xj_safe+xshift*boxxsize
2398           yj=yj_safe+yshift*boxysize
2399           zj=zj_safe+zshift*boxzsize
2400           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
2401           if(dist_temp.lt.dist_init) then
2402             dist_init=dist_temp
2403             xj_temp=xj
2404             yj_temp=yj
2405             zj_temp=zj
2406             isubchap=1
2407           endif
2408        enddo
2409        enddo
2410        enddo
2411        if (isubchap.eq.1) then
2412           xj=xj_temp-xmedi
2413           yj=yj_temp-ymedi
2414           zj=zj_temp-zmedi
2415        else
2416           xj=xj_safe-xmedi
2417           yj=yj_safe-ymedi
2418           zj=zj_safe-zmedi
2419        endif
2420           rij=xj*xj+yj*yj+zj*zj
2421             sss=sscale(sqrt(rij))
2422             sssgrad=sscagrad(sqrt(rij))
2423           if (rij.lt.r0ijsq) then
2424             evdw1ij=0.25d0*(rij-r0ijsq)**2
2425             fac=rij-r0ijsq
2426           else
2427             evdw1ij=0.0d0
2428             fac=0.0d0
2429           endif
2430           evdw1=evdw1+evdw1ij*sss
2431 C
2432 C Calculate contributions to the Cartesian gradient.
2433 C
2434           ggg(1)=fac*xj*sssgrad
2435           ggg(2)=fac*yj*sssgrad
2436           ggg(3)=fac*zj*sssgrad
2437           do k=1,3
2438             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
2439             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
2440           enddo
2441 *
2442 * Loop over residues i+1 thru j-1.
2443 *
2444 cgrad          do k=i+1,j-1
2445 cgrad            do l=1,3
2446 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
2447 cgrad            enddo
2448 cgrad          enddo
2449         enddo ! j
2450       enddo   ! i
2451 cgrad      do i=nnt,nct-1
2452 cgrad        do k=1,3
2453 cgrad          gelc(k,i)=gelc(k,i)+0.5d0*gelc(k,i)
2454 cgrad        enddo
2455 cgrad        do j=i+1,nct-1
2456 cgrad          do k=1,3
2457 cgrad            gelc(k,i)=gelc(k,i)+gelc(k,j)
2458 cgrad          enddo
2459 cgrad        enddo
2460 cgrad      enddo
2461       return
2462       end
2463 c------------------------------------------------------------------------------
2464       subroutine vec_and_deriv
2465       implicit real*8 (a-h,o-z)
2466       include 'DIMENSIONS'
2467 #ifdef MPI
2468       include 'mpif.h'
2469 #endif
2470       include 'COMMON.IOUNITS'
2471       include 'COMMON.GEO'
2472       include 'COMMON.VAR'
2473       include 'COMMON.LOCAL'
2474       include 'COMMON.CHAIN'
2475       include 'COMMON.VECTORS'
2476       include 'COMMON.SETUP'
2477       include 'COMMON.TIME1'
2478       dimension uyder(3,3,2),uzder(3,3,2),vbld_inv_temp(2)
2479 C Compute the local reference systems. For reference system (i), the
2480 C X-axis points from CA(i) to CA(i+1), the Y axis is in the
2481 C CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
2482 #ifdef PARVEC
2483       do i=ivec_start,ivec_end
2484 #else
2485       do i=1,nres-1
2486 #endif
2487           if (i.eq.nres-1) then
2488 C Case of the last full residue
2489 C Compute the Z-axis
2490             call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
2491             costh=dcos(pi-theta(nres))
2492             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2493             do k=1,3
2494               uz(k,i)=fac*uz(k,i)
2495             enddo
2496 C Compute the derivatives of uz
2497             uzder(1,1,1)= 0.0d0
2498             uzder(2,1,1)=-dc_norm(3,i-1)
2499             uzder(3,1,1)= dc_norm(2,i-1)
2500             uzder(1,2,1)= dc_norm(3,i-1)
2501             uzder(2,2,1)= 0.0d0
2502             uzder(3,2,1)=-dc_norm(1,i-1)
2503             uzder(1,3,1)=-dc_norm(2,i-1)
2504             uzder(2,3,1)= dc_norm(1,i-1)
2505             uzder(3,3,1)= 0.0d0
2506             uzder(1,1,2)= 0.0d0
2507             uzder(2,1,2)= dc_norm(3,i)
2508             uzder(3,1,2)=-dc_norm(2,i)
2509             uzder(1,2,2)=-dc_norm(3,i)
2510             uzder(2,2,2)= 0.0d0
2511             uzder(3,2,2)= dc_norm(1,i)
2512             uzder(1,3,2)= dc_norm(2,i)
2513             uzder(2,3,2)=-dc_norm(1,i)
2514             uzder(3,3,2)= 0.0d0
2515 C Compute the Y-axis
2516             facy=fac
2517             do k=1,3
2518               uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
2519             enddo
2520 C Compute the derivatives of uy
2521             do j=1,3
2522               do k=1,3
2523                 uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i)
2524      &                        -dc_norm(k,i)*dc_norm(j,i-1)
2525                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2526               enddo
2527               uyder(j,j,1)=uyder(j,j,1)-costh
2528               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2529             enddo
2530             do j=1,2
2531               do k=1,3
2532                 do l=1,3
2533                   uygrad(l,k,j,i)=uyder(l,k,j)
2534                   uzgrad(l,k,j,i)=uzder(l,k,j)
2535                 enddo
2536               enddo
2537             enddo
2538             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2539             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2540             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2541             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2542           else
2543 C Other residues
2544 C Compute the Z-axis
2545             call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
2546             costh=dcos(pi-theta(i+2))
2547             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2548             do k=1,3
2549               uz(k,i)=fac*uz(k,i)
2550             enddo
2551 C Compute the derivatives of uz
2552             uzder(1,1,1)= 0.0d0
2553             uzder(2,1,1)=-dc_norm(3,i+1)
2554             uzder(3,1,1)= dc_norm(2,i+1)
2555             uzder(1,2,1)= dc_norm(3,i+1)
2556             uzder(2,2,1)= 0.0d0
2557             uzder(3,2,1)=-dc_norm(1,i+1)
2558             uzder(1,3,1)=-dc_norm(2,i+1)
2559             uzder(2,3,1)= dc_norm(1,i+1)
2560             uzder(3,3,1)= 0.0d0
2561             uzder(1,1,2)= 0.0d0
2562             uzder(2,1,2)= dc_norm(3,i)
2563             uzder(3,1,2)=-dc_norm(2,i)
2564             uzder(1,2,2)=-dc_norm(3,i)
2565             uzder(2,2,2)= 0.0d0
2566             uzder(3,2,2)= dc_norm(1,i)
2567             uzder(1,3,2)= dc_norm(2,i)
2568             uzder(2,3,2)=-dc_norm(1,i)
2569             uzder(3,3,2)= 0.0d0
2570 C Compute the Y-axis
2571             facy=fac
2572             do k=1,3
2573               uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
2574             enddo
2575 C Compute the derivatives of uy
2576             do j=1,3
2577               do k=1,3
2578                 uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i)
2579      &                        -dc_norm(k,i)*dc_norm(j,i+1)
2580                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2581               enddo
2582               uyder(j,j,1)=uyder(j,j,1)-costh
2583               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2584             enddo
2585             do j=1,2
2586               do k=1,3
2587                 do l=1,3
2588                   uygrad(l,k,j,i)=uyder(l,k,j)
2589                   uzgrad(l,k,j,i)=uzder(l,k,j)
2590                 enddo
2591               enddo
2592             enddo
2593             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2594             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2595             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2596             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2597           endif
2598       enddo
2599       do i=1,nres-1
2600         vbld_inv_temp(1)=vbld_inv(i+1)
2601         if (i.lt.nres-1) then
2602           vbld_inv_temp(2)=vbld_inv(i+2)
2603           else
2604           vbld_inv_temp(2)=vbld_inv(i)
2605           endif
2606         do j=1,2
2607           do k=1,3
2608             do l=1,3
2609               uygrad(l,k,j,i)=vbld_inv_temp(j)*uygrad(l,k,j,i)
2610               uzgrad(l,k,j,i)=vbld_inv_temp(j)*uzgrad(l,k,j,i)
2611             enddo
2612           enddo
2613         enddo
2614       enddo
2615 #if defined(PARVEC) && defined(MPI)
2616       if (nfgtasks1.gt.1) then
2617         time00=MPI_Wtime()
2618 c        print *,"Processor",fg_rank1,kolor1," ivec_start",ivec_start,
2619 c     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks1-1),
2620 c     &   " ivec_count",(ivec_count(i),i=0,nfgtasks1-1)
2621         call MPI_Allgatherv(uy(1,ivec_start),ivec_count(fg_rank1),
2622      &   MPI_UYZ,uy(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
2623      &   FG_COMM1,IERR)
2624         call MPI_Allgatherv(uz(1,ivec_start),ivec_count(fg_rank1),
2625      &   MPI_UYZ,uz(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
2626      &   FG_COMM1,IERR)
2627         call MPI_Allgatherv(uygrad(1,1,1,ivec_start),
2628      &   ivec_count(fg_rank1),MPI_UYZGRAD,uygrad(1,1,1,1),ivec_count(0),
2629      &   ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2630         call MPI_Allgatherv(uzgrad(1,1,1,ivec_start),
2631      &   ivec_count(fg_rank1),MPI_UYZGRAD,uzgrad(1,1,1,1),ivec_count(0),
2632      &   ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2633         time_gather=time_gather+MPI_Wtime()-time00
2634       endif
2635 c      if (fg_rank.eq.0) then
2636 c        write (iout,*) "Arrays UY and UZ"
2637 c        do i=1,nres-1
2638 c          write (iout,'(i5,3f10.5,5x,3f10.5)') i,(uy(k,i),k=1,3),
2639 c     &     (uz(k,i),k=1,3)
2640 c        enddo
2641 c      endif
2642 #endif
2643       return
2644       end
2645 C-----------------------------------------------------------------------------
2646       subroutine check_vecgrad
2647       implicit real*8 (a-h,o-z)
2648       include 'DIMENSIONS'
2649       include 'COMMON.IOUNITS'
2650       include 'COMMON.GEO'
2651       include 'COMMON.VAR'
2652       include 'COMMON.LOCAL'
2653       include 'COMMON.CHAIN'
2654       include 'COMMON.VECTORS'
2655       dimension uygradt(3,3,2,maxres),uzgradt(3,3,2,maxres)
2656       dimension uyt(3,maxres),uzt(3,maxres)
2657       dimension uygradn(3,3,2),uzgradn(3,3,2),erij(3)
2658       double precision delta /1.0d-7/
2659       call vec_and_deriv
2660 cd      do i=1,nres
2661 crc          write(iout,'(2i5,2(3f10.5,5x))') i,1,dc_norm(:,i)
2662 crc          write(iout,'(2i5,2(3f10.5,5x))') i,2,uy(:,i)
2663 crc          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,uz(:,i)
2664 cd          write(iout,'(2i5,2(3f10.5,5x))') i,1,
2665 cd     &     (dc_norm(if90,i),if90=1,3)
2666 cd          write(iout,'(2i5,2(3f10.5,5x))') i,2,(uy(if90,i),if90=1,3)
2667 cd          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,(uz(if90,i),if90=1,3)
2668 cd          write(iout,'(a)')
2669 cd      enddo
2670       do i=1,nres
2671         do j=1,2
2672           do k=1,3
2673             do l=1,3
2674               uygradt(l,k,j,i)=uygrad(l,k,j,i)
2675               uzgradt(l,k,j,i)=uzgrad(l,k,j,i)
2676             enddo
2677           enddo
2678         enddo
2679       enddo
2680       call vec_and_deriv
2681       do i=1,nres
2682         do j=1,3
2683           uyt(j,i)=uy(j,i)
2684           uzt(j,i)=uz(j,i)
2685         enddo
2686       enddo
2687       do i=1,nres
2688 cd        write (iout,*) 'i=',i
2689         do k=1,3
2690           erij(k)=dc_norm(k,i)
2691         enddo
2692         do j=1,3
2693           do k=1,3
2694             dc_norm(k,i)=erij(k)
2695           enddo
2696           dc_norm(j,i)=dc_norm(j,i)+delta
2697 c          fac=dsqrt(scalar(dc_norm(1,i),dc_norm(1,i)))
2698 c          do k=1,3
2699 c            dc_norm(k,i)=dc_norm(k,i)/fac
2700 c          enddo
2701 c          write (iout,*) (dc_norm(k,i),k=1,3)
2702 c          write (iout,*) (erij(k),k=1,3)
2703           call vec_and_deriv
2704           do k=1,3
2705             uygradn(k,j,1)=(uy(k,i)-uyt(k,i))/delta
2706             uygradn(k,j,2)=(uy(k,i-1)-uyt(k,i-1))/delta
2707             uzgradn(k,j,1)=(uz(k,i)-uzt(k,i))/delta
2708             uzgradn(k,j,2)=(uz(k,i-1)-uzt(k,i-1))/delta
2709           enddo
2710 c          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2711 c     &      j,(uzgradt(k,j,1,i),k=1,3),(uzgradn(k,j,1),k=1,3),
2712 c     &      (uzgradt(k,j,2,i-1),k=1,3),(uzgradn(k,j,2),k=1,3)
2713         enddo
2714         do k=1,3
2715           dc_norm(k,i)=erij(k)
2716         enddo
2717 cd        do k=1,3
2718 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2719 cd     &      k,(uygradt(k,l,1,i),l=1,3),(uygradn(k,l,1),l=1,3),
2720 cd     &      (uygradt(k,l,2,i-1),l=1,3),(uygradn(k,l,2),l=1,3)
2721 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2722 cd     &      k,(uzgradt(k,l,1,i),l=1,3),(uzgradn(k,l,1),l=1,3),
2723 cd     &      (uzgradt(k,l,2,i-1),l=1,3),(uzgradn(k,l,2),l=1,3)
2724 cd          write (iout,'(a)')
2725 cd        enddo
2726       enddo
2727       return
2728       end
2729 C--------------------------------------------------------------------------
2730       subroutine set_matrices
2731       implicit real*8 (a-h,o-z)
2732       include 'DIMENSIONS'
2733 #ifdef MPI
2734       include "mpif.h"
2735       include "COMMON.SETUP"
2736       integer IERR
2737       integer status(MPI_STATUS_SIZE)
2738 #endif
2739       include 'COMMON.IOUNITS'
2740       include 'COMMON.GEO'
2741       include 'COMMON.VAR'
2742       include 'COMMON.LOCAL'
2743       include 'COMMON.CHAIN'
2744       include 'COMMON.DERIV'
2745       include 'COMMON.INTERACT'
2746       include 'COMMON.CONTACTS'
2747       include 'COMMON.TORSION'
2748       include 'COMMON.VECTORS'
2749       include 'COMMON.FFIELD'
2750       double precision auxvec(2),auxmat(2,2)
2751 C
2752 C Compute the virtual-bond-torsional-angle dependent quantities needed
2753 C to calculate the el-loc multibody terms of various order.
2754 C
2755 c      write(iout,*) 'nphi=',nphi,nres
2756 #ifdef PARMAT
2757       do i=ivec_start+2,ivec_end+2
2758 #else
2759       do i=3,nres+1
2760 #endif
2761 #ifdef NEWCORR
2762         if (i.gt. nnt+2 .and. i.lt.nct+2) then
2763           iti = itortyp(itype(i-2))
2764         else
2765           iti=ntortyp+1
2766         endif
2767 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2768         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2769           iti1 = itortyp(itype(i-1))
2770         else
2771           iti1=ntortyp+1
2772         endif
2773 c        write(iout,*),i
2774         b1(1,i-2)=bnew1(1,1,iti)*dsin(theta(i-1)/2.0)
2775      &           +bnew1(2,1,iti)*dsin(theta(i-1))
2776      &           +bnew1(3,1,iti)*dcos(theta(i-1)/2.0)
2777         gtb1(1,i-2)=bnew1(1,1,iti)*dcos(theta(i-1)/2.0d0)/2.0d0
2778      &             +bnew1(2,1,iti)*dcos(theta(i-1))
2779      &             -bnew1(3,1,iti)*dsin(theta(i-1)/2.0d0)/2.0d0
2780 c     &           +bnew1(3,1,iti)*sin(alpha(i))*cos(beta(i))
2781 c     &*(cos(theta(i)/2.0)
2782         b2(1,i-2)=bnew2(1,1,iti)*dsin(theta(i-1)/2.0)
2783      &           +bnew2(2,1,iti)*dsin(theta(i-1))
2784      &           +bnew2(3,1,iti)*dcos(theta(i-1)/2.0)
2785 c     &           +bnew2(3,1,iti)*sin(alpha(i))*cos(beta(i))
2786 c     &*(cos(theta(i)/2.0)
2787         gtb2(1,i-2)=bnew2(1,1,iti)*dcos(theta(i-1)/2.0d0)/2.0d0
2788      &             +bnew2(2,1,iti)*dcos(theta(i-1))
2789      &             -bnew2(3,1,iti)*dsin(theta(i-1)/2.0d0)/2.0d0
2790 c        if (ggb1(1,i).eq.0.0d0) then
2791 c        write(iout,*) 'i=',i,ggb1(1,i),
2792 c     &bnew1(1,1,iti)*cos(theta(i)/2.0)/2.0,
2793 c     &bnew1(2,1,iti)*cos(theta(i)),
2794 c     &bnew1(3,1,iti)*sin(theta(i)/2.0)/2.0
2795 c        endif
2796         b1(2,i-2)=bnew1(1,2,iti)
2797         gtb1(2,i-2)=0.0
2798         b2(2,i-2)=bnew2(1,2,iti)
2799         gtb2(2,i-2)=0.0
2800         EE(1,1,i-2)=eenew(1,iti)*dcos(theta(i-1))
2801         EE(1,2,i-2)=eeold(1,2,iti)
2802         EE(2,1,i-2)=eeold(2,1,iti)
2803         EE(2,2,i-2)=eeold(2,2,iti)
2804         gtEE(1,1,i-2)=-eenew(1,iti)*dsin(theta(i-1))
2805         gtEE(1,2,i-2)=0.0d0
2806         gtEE(2,2,i-2)=0.0d0
2807         gtEE(2,1,i-2)=0.0d0
2808 c        EE(2,2,iti)=0.0d0
2809 c        EE(1,2,iti)=0.5d0*eenew(1,iti)
2810 c        EE(2,1,iti)=0.5d0*eenew(1,iti)
2811 c        b1(2,iti)=bnew1(1,2,iti)*sin(alpha(i))*sin(beta(i))
2812 c        b2(2,iti)=bnew2(1,2,iti)*sin(alpha(i))*sin(beta(i))
2813        b1tilde(1,i-2)=b1(1,i-2)
2814        b1tilde(2,i-2)=-b1(2,i-2)
2815        b2tilde(1,i-2)=b2(1,i-2)
2816        b2tilde(2,i-2)=-b2(2,i-2)
2817 c       write (iout,*) 'i=',i-2,gtb1(2,i-2),gtb1(1,i-2)
2818 c       write(iout,*)  'b1=',b1(1,i-2)
2819 c       write (iout,*) 'theta=', theta(i-1)
2820        enddo
2821 #else
2822         if (i.gt. nnt+2 .and. i.lt.nct+2) then
2823           iti = itortyp(itype(i-2))
2824         else
2825           iti=ntortyp+1
2826         endif
2827 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2828         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2829           iti1 = itortyp(itype(i-1))
2830         else
2831           iti1=ntortyp+1
2832         endif
2833         b1(1,i-2)=b(3,iti)
2834         b1(2,i-2)=b(5,iti)
2835         b2(1,i-2)=b(2,iti)
2836         b2(2,i-2)=b(4,iti)
2837        b1tilde(1,i-2)=b1(1,i-2)
2838        b1tilde(2,i-2)=-b1(2,i-2)
2839        b2tilde(1,i-2)=b2(1,i-2)
2840        b2tilde(2,i-2)=-b2(2,i-2)
2841         EE(1,2,i-2)=eeold(1,2,iti)
2842         EE(2,1,i-2)=eeold(2,1,iti)
2843         EE(2,2,i-2)=eeold(2,2,iti)
2844         EE(1,1,i-2)=eeold(1,1,iti)
2845       enddo
2846 #endif
2847 #ifdef PARMAT
2848       do i=ivec_start+2,ivec_end+2
2849 #else
2850       do i=3,nres+1
2851 #endif
2852         if (i .lt. nres+1) then
2853           sin1=dsin(phi(i))
2854           cos1=dcos(phi(i))
2855           sintab(i-2)=sin1
2856           costab(i-2)=cos1
2857           obrot(1,i-2)=cos1
2858           obrot(2,i-2)=sin1
2859           sin2=dsin(2*phi(i))
2860           cos2=dcos(2*phi(i))
2861           sintab2(i-2)=sin2
2862           costab2(i-2)=cos2
2863           obrot2(1,i-2)=cos2
2864           obrot2(2,i-2)=sin2
2865           Ug(1,1,i-2)=-cos1
2866           Ug(1,2,i-2)=-sin1
2867           Ug(2,1,i-2)=-sin1
2868           Ug(2,2,i-2)= cos1
2869           Ug2(1,1,i-2)=-cos2
2870           Ug2(1,2,i-2)=-sin2
2871           Ug2(2,1,i-2)=-sin2
2872           Ug2(2,2,i-2)= cos2
2873         else
2874           costab(i-2)=1.0d0
2875           sintab(i-2)=0.0d0
2876           obrot(1,i-2)=1.0d0
2877           obrot(2,i-2)=0.0d0
2878           obrot2(1,i-2)=0.0d0
2879           obrot2(2,i-2)=0.0d0
2880           Ug(1,1,i-2)=1.0d0
2881           Ug(1,2,i-2)=0.0d0
2882           Ug(2,1,i-2)=0.0d0
2883           Ug(2,2,i-2)=1.0d0
2884           Ug2(1,1,i-2)=0.0d0
2885           Ug2(1,2,i-2)=0.0d0
2886           Ug2(2,1,i-2)=0.0d0
2887           Ug2(2,2,i-2)=0.0d0
2888         endif
2889         if (i .gt. 3 .and. i .lt. nres+1) then
2890           obrot_der(1,i-2)=-sin1
2891           obrot_der(2,i-2)= cos1
2892           Ugder(1,1,i-2)= sin1
2893           Ugder(1,2,i-2)=-cos1
2894           Ugder(2,1,i-2)=-cos1
2895           Ugder(2,2,i-2)=-sin1
2896           dwacos2=cos2+cos2
2897           dwasin2=sin2+sin2
2898           obrot2_der(1,i-2)=-dwasin2
2899           obrot2_der(2,i-2)= dwacos2
2900           Ug2der(1,1,i-2)= dwasin2
2901           Ug2der(1,2,i-2)=-dwacos2
2902           Ug2der(2,1,i-2)=-dwacos2
2903           Ug2der(2,2,i-2)=-dwasin2
2904         else
2905           obrot_der(1,i-2)=0.0d0
2906           obrot_der(2,i-2)=0.0d0
2907           Ugder(1,1,i-2)=0.0d0
2908           Ugder(1,2,i-2)=0.0d0
2909           Ugder(2,1,i-2)=0.0d0
2910           Ugder(2,2,i-2)=0.0d0
2911           obrot2_der(1,i-2)=0.0d0
2912           obrot2_der(2,i-2)=0.0d0
2913           Ug2der(1,1,i-2)=0.0d0
2914           Ug2der(1,2,i-2)=0.0d0
2915           Ug2der(2,1,i-2)=0.0d0
2916           Ug2der(2,2,i-2)=0.0d0
2917         endif
2918 c        if (i.gt. iatel_s+2 .and. i.lt.iatel_e+5) then
2919         if (i.gt. nnt+2 .and. i.lt.nct+2) then
2920           iti = itortyp(itype(i-2))
2921         else
2922           iti=ntortyp
2923         endif
2924 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2925         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2926           iti1 = itortyp(itype(i-1))
2927         else
2928           iti1=ntortyp
2929         endif
2930 cd        write (iout,*) '*******i',i,' iti1',iti
2931 cd        write (iout,*) 'b1',b1(:,iti)
2932 cd        write (iout,*) 'b2',b2(:,iti)
2933 cd        write (iout,*) 'Ug',Ug(:,:,i-2)
2934 c        if (i .gt. iatel_s+2) then
2935         if (i .gt. nnt+2) then
2936           call matvec2(Ug(1,1,i-2),b2(1,i-2),Ub2(1,i-2))
2937 #ifdef NEWCORR
2938           call matvec2(Ug(1,1,i-2),gtb2(1,i-2),gUb2(1,i-2))
2939 c          write (iout,*) Ug(1,1,i-2),gtb2(1,i-2),gUb2(1,i-2),"chuj"
2940 #endif
2941 c          write(iout,*) "co jest kurwa", iti, EE(1,1,iti),EE(2,1,iti),
2942 c     &    EE(1,2,iti),EE(2,2,iti)
2943           call matmat2(EE(1,1,i-2),Ug(1,1,i-2),EUg(1,1,i-2))
2944           call matmat2(gtEE(1,1,i-2),Ug(1,1,i-2),gtEUg(1,1,i-2))
2945 c          write(iout,*) "Macierz EUG",
2946 c     &    eug(1,1,i-2),eug(1,2,i-2),eug(2,1,i-2),
2947 c     &    eug(2,2,i-2)
2948           if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2949      &    then
2950           call matmat2(CC(1,1,iti),Ug(1,1,i-2),CUg(1,1,i-2))
2951           call matmat2(DD(1,1,iti),Ug(1,1,i-2),DUg(1,1,i-2))
2952           call matmat2(Dtilde(1,1,iti),Ug2(1,1,i-2),DtUg2(1,1,i-2))
2953           call matvec2(Ctilde(1,1,iti1),obrot(1,i-2),Ctobr(1,i-2))
2954           call matvec2(Dtilde(1,1,iti),obrot2(1,i-2),Dtobr2(1,i-2))
2955           endif
2956         else
2957           do k=1,2
2958             Ub2(k,i-2)=0.0d0
2959             Ctobr(k,i-2)=0.0d0
2960             Dtobr2(k,i-2)=0.0d0
2961             do l=1,2
2962               EUg(l,k,i-2)=0.0d0
2963               CUg(l,k,i-2)=0.0d0
2964               DUg(l,k,i-2)=0.0d0
2965               DtUg2(l,k,i-2)=0.0d0
2966             enddo
2967           enddo
2968         endif
2969         call matvec2(Ugder(1,1,i-2),b2(1,i-2),Ub2der(1,i-2))
2970         call matmat2(EE(1,1,i-2),Ugder(1,1,i-2),EUgder(1,1,i-2))
2971         do k=1,2
2972           muder(k,i-2)=Ub2der(k,i-2)
2973         enddo
2974 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2975         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2976           if (itype(i-1).le.ntyp) then
2977             iti1 = itortyp(itype(i-1))
2978           else
2979             iti1=ntortyp
2980           endif
2981         else
2982           iti1=ntortyp
2983         endif
2984         do k=1,2
2985           mu(k,i-2)=Ub2(k,i-2)+b1(k,i-1)
2986         enddo
2987 C        write (iout,*) 'mumu',i,b1(1,i-1),Ub2(1,i-2)
2988 c        write (iout,*) 'mu ',mu(:,i-2),i-2
2989 cd        write (iout,*) 'mu1',mu1(:,i-2)
2990 cd        write (iout,*) 'mu2',mu2(:,i-2)
2991         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
2992      &  then
2993         call matmat2(CC(1,1,iti1),Ugder(1,1,i-2),CUgder(1,1,i-2))
2994         call matmat2(DD(1,1,iti),Ugder(1,1,i-2),DUgder(1,1,i-2))
2995         call matmat2(Dtilde(1,1,iti),Ug2der(1,1,i-2),DtUg2der(1,1,i-2))
2996         call matvec2(Ctilde(1,1,iti1),obrot_der(1,i-2),Ctobrder(1,i-2))
2997         call matvec2(Dtilde(1,1,iti),obrot2_der(1,i-2),Dtobr2der(1,i-2))
2998 C Vectors and matrices dependent on a single virtual-bond dihedral.
2999         call matvec2(DD(1,1,iti),b1tilde(1,i-1),auxvec(1))
3000         call matvec2(Ug2(1,1,i-2),auxvec(1),Ug2Db1t(1,i-2))
3001         call matvec2(Ug2der(1,1,i-2),auxvec(1),Ug2Db1tder(1,i-2))
3002         call matvec2(CC(1,1,iti1),Ub2(1,i-2),CUgb2(1,i-2))
3003         call matvec2(CC(1,1,iti1),Ub2der(1,i-2),CUgb2der(1,i-2))
3004         call matmat2(EUg(1,1,i-2),CC(1,1,iti1),EUgC(1,1,i-2))
3005         call matmat2(EUgder(1,1,i-2),CC(1,1,iti1),EUgCder(1,1,i-2))
3006         call matmat2(EUg(1,1,i-2),DD(1,1,iti1),EUgD(1,1,i-2))
3007         call matmat2(EUgder(1,1,i-2),DD(1,1,iti1),EUgDder(1,1,i-2))
3008         endif
3009       enddo
3010 C Matrices dependent on two consecutive virtual-bond dihedrals.
3011 C The order of matrices is from left to right.
3012       if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
3013      &then
3014 c      do i=max0(ivec_start,2),ivec_end
3015       do i=2,nres-1
3016         call matmat2(DtUg2(1,1,i-1),EUg(1,1,i),DtUg2EUg(1,1,i))
3017         call matmat2(DtUg2der(1,1,i-1),EUg(1,1,i),DtUg2EUgder(1,1,1,i))
3018         call matmat2(DtUg2(1,1,i-1),EUgder(1,1,i),DtUg2EUgder(1,1,2,i))
3019         call transpose2(DtUg2(1,1,i-1),auxmat(1,1))
3020         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUg(1,1,i))
3021         call matmat2(auxmat(1,1),EUgder(1,1,i),Ug2DtEUgder(1,1,2,i))
3022         call transpose2(DtUg2der(1,1,i-1),auxmat(1,1))
3023         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUgder(1,1,1,i))
3024       enddo
3025       endif
3026 #if defined(MPI) && defined(PARMAT)
3027 #ifdef DEBUG
3028 c      if (fg_rank.eq.0) then
3029         write (iout,*) "Arrays UG and UGDER before GATHER"
3030         do i=1,nres-1
3031           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3032      &     ((ug(l,k,i),l=1,2),k=1,2),
3033      &     ((ugder(l,k,i),l=1,2),k=1,2)
3034         enddo
3035         write (iout,*) "Arrays UG2 and UG2DER"
3036         do i=1,nres-1
3037           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3038      &     ((ug2(l,k,i),l=1,2),k=1,2),
3039      &     ((ug2der(l,k,i),l=1,2),k=1,2)
3040         enddo
3041         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
3042         do i=1,nres-1
3043           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3044      &     (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
3045      &     (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
3046         enddo
3047         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
3048         do i=1,nres-1
3049           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3050      &     costab(i),sintab(i),costab2(i),sintab2(i)
3051         enddo
3052         write (iout,*) "Array MUDER"
3053         do i=1,nres-1
3054           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
3055         enddo
3056 c      endif
3057 #endif
3058       if (nfgtasks.gt.1) then
3059         time00=MPI_Wtime()
3060 c        write(iout,*)"Processor",fg_rank,kolor," ivec_start",ivec_start,
3061 c     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks-1),
3062 c     &   " ivec_count",(ivec_count(i),i=0,nfgtasks-1)
3063 #ifdef MATGATHER
3064         call MPI_Allgatherv(Ub2(1,ivec_start),ivec_count(fg_rank1),
3065      &   MPI_MU,Ub2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3066      &   FG_COMM1,IERR)
3067         call MPI_Allgatherv(Ub2der(1,ivec_start),ivec_count(fg_rank1),
3068      &   MPI_MU,Ub2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3069      &   FG_COMM1,IERR)
3070         call MPI_Allgatherv(mu(1,ivec_start),ivec_count(fg_rank1),
3071      &   MPI_MU,mu(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3072      &   FG_COMM1,IERR)
3073         call MPI_Allgatherv(muder(1,ivec_start),ivec_count(fg_rank1),
3074      &   MPI_MU,muder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3075      &   FG_COMM1,IERR)
3076         call MPI_Allgatherv(Eug(1,1,ivec_start),ivec_count(fg_rank1),
3077      &   MPI_MAT1,Eug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3078      &   FG_COMM1,IERR)
3079         call MPI_Allgatherv(Eugder(1,1,ivec_start),ivec_count(fg_rank1),
3080      &   MPI_MAT1,Eugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3081      &   FG_COMM1,IERR)
3082         call MPI_Allgatherv(costab(ivec_start),ivec_count(fg_rank1),
3083      &   MPI_DOUBLE_PRECISION,costab(1),ivec_count(0),ivec_displ(0),
3084      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3085         call MPI_Allgatherv(sintab(ivec_start),ivec_count(fg_rank1),
3086      &   MPI_DOUBLE_PRECISION,sintab(1),ivec_count(0),ivec_displ(0),
3087      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3088         call MPI_Allgatherv(costab2(ivec_start),ivec_count(fg_rank1),
3089      &   MPI_DOUBLE_PRECISION,costab2(1),ivec_count(0),ivec_displ(0),
3090      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3091         call MPI_Allgatherv(sintab2(ivec_start),ivec_count(fg_rank1),
3092      &   MPI_DOUBLE_PRECISION,sintab2(1),ivec_count(0),ivec_displ(0),
3093      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3094         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
3095      &  then
3096         call MPI_Allgatherv(Ctobr(1,ivec_start),ivec_count(fg_rank1),
3097      &   MPI_MU,Ctobr(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3098      &   FG_COMM1,IERR)
3099         call MPI_Allgatherv(Ctobrder(1,ivec_start),ivec_count(fg_rank1),
3100      &   MPI_MU,Ctobrder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3101      &   FG_COMM1,IERR)
3102         call MPI_Allgatherv(Dtobr2(1,ivec_start),ivec_count(fg_rank1),
3103      &   MPI_MU,Dtobr2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3104      &   FG_COMM1,IERR)
3105        call MPI_Allgatherv(Dtobr2der(1,ivec_start),ivec_count(fg_rank1),
3106      &   MPI_MU,Dtobr2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3107      &   FG_COMM1,IERR)
3108         call MPI_Allgatherv(Ug2Db1t(1,ivec_start),ivec_count(fg_rank1),
3109      &   MPI_MU,Ug2Db1t(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3110      &   FG_COMM1,IERR)
3111         call MPI_Allgatherv(Ug2Db1tder(1,ivec_start),
3112      &   ivec_count(fg_rank1),
3113      &   MPI_MU,Ug2Db1tder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3114      &   FG_COMM1,IERR)
3115         call MPI_Allgatherv(CUgb2(1,ivec_start),ivec_count(fg_rank1),
3116      &   MPI_MU,CUgb2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3117      &   FG_COMM1,IERR)
3118         call MPI_Allgatherv(CUgb2der(1,ivec_start),ivec_count(fg_rank1),
3119      &   MPI_MU,CUgb2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3120      &   FG_COMM1,IERR)
3121         call MPI_Allgatherv(Cug(1,1,ivec_start),ivec_count(fg_rank1),
3122      &   MPI_MAT1,Cug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3123      &   FG_COMM1,IERR)
3124         call MPI_Allgatherv(Cugder(1,1,ivec_start),ivec_count(fg_rank1),
3125      &   MPI_MAT1,Cugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3126      &   FG_COMM1,IERR)
3127         call MPI_Allgatherv(Dug(1,1,ivec_start),ivec_count(fg_rank1),
3128      &   MPI_MAT1,Dug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3129      &   FG_COMM1,IERR)
3130         call MPI_Allgatherv(Dugder(1,1,ivec_start),ivec_count(fg_rank1),
3131      &   MPI_MAT1,Dugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3132      &   FG_COMM1,IERR)
3133         call MPI_Allgatherv(Dtug2(1,1,ivec_start),ivec_count(fg_rank1),
3134      &   MPI_MAT1,Dtug2(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3135      &   FG_COMM1,IERR)
3136         call MPI_Allgatherv(Dtug2der(1,1,ivec_start),
3137      &   ivec_count(fg_rank1),
3138      &   MPI_MAT1,Dtug2der(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3139      &   FG_COMM1,IERR)
3140         call MPI_Allgatherv(EugC(1,1,ivec_start),ivec_count(fg_rank1),
3141      &   MPI_MAT1,EugC(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3142      &   FG_COMM1,IERR)
3143        call MPI_Allgatherv(EugCder(1,1,ivec_start),ivec_count(fg_rank1),
3144      &   MPI_MAT1,EugCder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3145      &   FG_COMM1,IERR)
3146         call MPI_Allgatherv(EugD(1,1,ivec_start),ivec_count(fg_rank1),
3147      &   MPI_MAT1,EugD(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3148      &   FG_COMM1,IERR)
3149        call MPI_Allgatherv(EugDder(1,1,ivec_start),ivec_count(fg_rank1),
3150      &   MPI_MAT1,EugDder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3151      &   FG_COMM1,IERR)
3152         call MPI_Allgatherv(DtUg2EUg(1,1,ivec_start),
3153      &   ivec_count(fg_rank1),
3154      &   MPI_MAT1,DtUg2EUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3155      &   FG_COMM1,IERR)
3156         call MPI_Allgatherv(Ug2DtEUg(1,1,ivec_start),
3157      &   ivec_count(fg_rank1),
3158      &   MPI_MAT1,Ug2DtEUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3159      &   FG_COMM1,IERR)
3160         call MPI_Allgatherv(DtUg2EUgder(1,1,1,ivec_start),
3161      &   ivec_count(fg_rank1),
3162      &   MPI_MAT2,DtUg2EUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
3163      &   MPI_MAT2,FG_COMM1,IERR)
3164         call MPI_Allgatherv(Ug2DtEUgder(1,1,1,ivec_start),
3165      &   ivec_count(fg_rank1),
3166      &   MPI_MAT2,Ug2DtEUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
3167      &   MPI_MAT2,FG_COMM1,IERR)
3168         endif
3169 #else
3170 c Passes matrix info through the ring
3171       isend=fg_rank1
3172       irecv=fg_rank1-1
3173       if (irecv.lt.0) irecv=nfgtasks1-1
3174       iprev=irecv
3175       inext=fg_rank1+1
3176       if (inext.ge.nfgtasks1) inext=0
3177       do i=1,nfgtasks1-1
3178 c        write (iout,*) "isend",isend," irecv",irecv
3179 c        call flush(iout)
3180         lensend=lentyp(isend)
3181         lenrecv=lentyp(irecv)
3182 c        write (iout,*) "lensend",lensend," lenrecv",lenrecv
3183 c        call MPI_SENDRECV(ug(1,1,ivec_displ(isend)+1),1,
3184 c     &   MPI_ROTAT1(lensend),inext,2200+isend,
3185 c     &   ug(1,1,ivec_displ(irecv)+1),1,MPI_ROTAT1(lenrecv),
3186 c     &   iprev,2200+irecv,FG_COMM,status,IERR)
3187 c        write (iout,*) "Gather ROTAT1"
3188 c        call flush(iout)
3189 c        call MPI_SENDRECV(obrot(1,ivec_displ(isend)+1),1,
3190 c     &   MPI_ROTAT2(lensend),inext,3300+isend,
3191 c     &   obrot(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
3192 c     &   iprev,3300+irecv,FG_COMM,status,IERR)
3193 c        write (iout,*) "Gather ROTAT2"
3194 c        call flush(iout)
3195         call MPI_SENDRECV(costab(ivec_displ(isend)+1),1,
3196      &   MPI_ROTAT_OLD(lensend),inext,4400+isend,
3197      &   costab(ivec_displ(irecv)+1),1,MPI_ROTAT_OLD(lenrecv),
3198      &   iprev,4400+irecv,FG_COMM,status,IERR)
3199 c        write (iout,*) "Gather ROTAT_OLD"
3200 c        call flush(iout)
3201         call MPI_SENDRECV(mu(1,ivec_displ(isend)+1),1,
3202      &   MPI_PRECOMP11(lensend),inext,5500+isend,
3203      &   mu(1,ivec_displ(irecv)+1),1,MPI_PRECOMP11(lenrecv),
3204      &   iprev,5500+irecv,FG_COMM,status,IERR)
3205 c        write (iout,*) "Gather PRECOMP11"
3206 c        call flush(iout)
3207         call MPI_SENDRECV(Eug(1,1,ivec_displ(isend)+1),1,
3208      &   MPI_PRECOMP12(lensend),inext,6600+isend,
3209      &   Eug(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP12(lenrecv),
3210      &   iprev,6600+irecv,FG_COMM,status,IERR)
3211 c        write (iout,*) "Gather PRECOMP12"
3212 c        call flush(iout)
3213         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
3214      &  then
3215         call MPI_SENDRECV(ug2db1t(1,ivec_displ(isend)+1),1,
3216      &   MPI_ROTAT2(lensend),inext,7700+isend,
3217      &   ug2db1t(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
3218      &   iprev,7700+irecv,FG_COMM,status,IERR)
3219 c        write (iout,*) "Gather PRECOMP21"
3220 c        call flush(iout)
3221         call MPI_SENDRECV(EUgC(1,1,ivec_displ(isend)+1),1,
3222      &   MPI_PRECOMP22(lensend),inext,8800+isend,
3223      &   EUgC(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP22(lenrecv),
3224      &   iprev,8800+irecv,FG_COMM,status,IERR)
3225 c        write (iout,*) "Gather PRECOMP22"
3226 c        call flush(iout)
3227         call MPI_SENDRECV(Ug2DtEUgder(1,1,1,ivec_displ(isend)+1),1,
3228      &   MPI_PRECOMP23(lensend),inext,9900+isend,
3229      &   Ug2DtEUgder(1,1,1,ivec_displ(irecv)+1),1,
3230      &   MPI_PRECOMP23(lenrecv),
3231      &   iprev,9900+irecv,FG_COMM,status,IERR)
3232 c        write (iout,*) "Gather PRECOMP23"
3233 c        call flush(iout)
3234         endif
3235         isend=irecv
3236         irecv=irecv-1
3237         if (irecv.lt.0) irecv=nfgtasks1-1
3238       enddo
3239 #endif
3240         time_gather=time_gather+MPI_Wtime()-time00
3241       endif
3242 #ifdef DEBUG
3243 c      if (fg_rank.eq.0) then
3244         write (iout,*) "Arrays UG and UGDER"
3245         do i=1,nres-1
3246           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3247      &     ((ug(l,k,i),l=1,2),k=1,2),
3248      &     ((ugder(l,k,i),l=1,2),k=1,2)
3249         enddo
3250         write (iout,*) "Arrays UG2 and UG2DER"
3251         do i=1,nres-1
3252           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3253      &     ((ug2(l,k,i),l=1,2),k=1,2),
3254      &     ((ug2der(l,k,i),l=1,2),k=1,2)
3255         enddo
3256         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
3257         do i=1,nres-1
3258           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3259      &     (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
3260      &     (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
3261         enddo
3262         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
3263         do i=1,nres-1
3264           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3265      &     costab(i),sintab(i),costab2(i),sintab2(i)
3266         enddo
3267         write (iout,*) "Array MUDER"
3268         do i=1,nres-1
3269           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
3270         enddo
3271 c      endif
3272 #endif
3273 #endif
3274 cd      do i=1,nres
3275 cd        iti = itortyp(itype(i))
3276 cd        write (iout,*) i
3277 cd        do j=1,2
3278 cd        write (iout,'(2f10.5,5x,2f10.5,5x,2f10.5)')
3279 cd     &  (EE(j,k,iti),k=1,2),(Ug(j,k,i),k=1,2),(EUg(j,k,i),k=1,2)
3280 cd        enddo
3281 cd      enddo
3282       return
3283       end
3284 C--------------------------------------------------------------------------
3285       subroutine eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
3286 C
3287 C This subroutine calculates the average interaction energy and its gradient
3288 C in the virtual-bond vectors between non-adjacent peptide groups, based on
3289 C the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
3290 C The potential depends both on the distance of peptide-group centers and on
3291 C the orientation of the CA-CA virtual bonds.
3292 C
3293       implicit real*8 (a-h,o-z)
3294 #ifdef MPI
3295       include 'mpif.h'
3296 #endif
3297       include 'DIMENSIONS'
3298       include 'COMMON.CONTROL'
3299       include 'COMMON.SETUP'
3300       include 'COMMON.IOUNITS'
3301       include 'COMMON.GEO'
3302       include 'COMMON.VAR'
3303       include 'COMMON.LOCAL'
3304       include 'COMMON.CHAIN'
3305       include 'COMMON.DERIV'
3306       include 'COMMON.INTERACT'
3307       include 'COMMON.CONTACTS'
3308       include 'COMMON.TORSION'
3309       include 'COMMON.VECTORS'
3310       include 'COMMON.FFIELD'
3311       include 'COMMON.TIME1'
3312       include 'COMMON.SPLITELE'
3313       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
3314      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
3315       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
3316      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4),gmuij(4)
3317       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3318      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3319      &    num_conti,j1,j2
3320 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
3321 #ifdef MOMENT
3322       double precision scal_el /1.0d0/
3323 #else
3324       double precision scal_el /0.5d0/
3325 #endif
3326 C 12/13/98
3327 C 13-go grudnia roku pamietnego...
3328       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
3329      &                   0.0d0,1.0d0,0.0d0,
3330      &                   0.0d0,0.0d0,1.0d0/
3331 cd      write(iout,*) 'In EELEC'
3332 cd      do i=1,nloctyp
3333 cd        write(iout,*) 'Type',i
3334 cd        write(iout,*) 'B1',B1(:,i)
3335 cd        write(iout,*) 'B2',B2(:,i)
3336 cd        write(iout,*) 'CC',CC(:,:,i)
3337 cd        write(iout,*) 'DD',DD(:,:,i)
3338 cd        write(iout,*) 'EE',EE(:,:,i)
3339 cd      enddo
3340 cd      call check_vecgrad
3341 cd      stop
3342       if (icheckgrad.eq.1) then
3343         do i=1,nres-1
3344           fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
3345           do k=1,3
3346             dc_norm(k,i)=dc(k,i)*fac
3347           enddo
3348 c          write (iout,*) 'i',i,' fac',fac
3349         enddo
3350       endif
3351       if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
3352      &    .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or.
3353      &    wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
3354 c        call vec_and_deriv
3355 #ifdef TIMING
3356         time01=MPI_Wtime()
3357 #endif
3358         call set_matrices
3359 #ifdef TIMING
3360         time_mat=time_mat+MPI_Wtime()-time01
3361 #endif
3362       endif
3363 cd      do i=1,nres-1
3364 cd        write (iout,*) 'i=',i
3365 cd        do k=1,3
3366 cd        write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
3367 cd        enddo
3368 cd        do k=1,3
3369 cd          write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
3370 cd     &     uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
3371 cd        enddo
3372 cd      enddo
3373       t_eelecij=0.0d0
3374       ees=0.0D0
3375       evdw1=0.0D0
3376       eel_loc=0.0d0
3377       eello_turn3=0.0d0
3378       eello_turn4=0.0d0
3379       ind=0
3380       do i=1,nres
3381         num_cont_hb(i)=0
3382       enddo
3383 cd      print '(a)','Enter EELEC'
3384 cd      write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
3385       do i=1,nres
3386         gel_loc_loc(i)=0.0d0
3387         gcorr_loc(i)=0.0d0
3388       enddo
3389 c
3390 c
3391 c 9/27/08 AL Split the interaction loop to ensure load balancing of turn terms
3392 C
3393 C Loop over i,i+2 and i,i+3 pairs of the peptide groups
3394 C
3395 C 14/01/2014 TURN3,TUNR4 does no go under periodic boundry condition
3396       do i=iturn3_start,iturn3_end
3397         if (i.le.1) cycle
3398 C        write(iout,*) "tu jest i",i
3399         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
3400 C changes suggested by Ana to avoid out of bounds
3401      & .or.((i+4).gt.nres)
3402      & .or.((i-1).le.0)
3403 C end of changes by Ana
3404      &  .or. itype(i+2).eq.ntyp1
3405      &  .or. itype(i+3).eq.ntyp1) cycle
3406         if(i.gt.1)then
3407           if(itype(i-1).eq.ntyp1)cycle
3408         end if
3409         if(i.LT.nres-3)then
3410           if (itype(i+4).eq.ntyp1) cycle
3411         end if
3412         dxi=dc(1,i)
3413         dyi=dc(2,i)
3414         dzi=dc(3,i)
3415         dx_normi=dc_norm(1,i)
3416         dy_normi=dc_norm(2,i)
3417         dz_normi=dc_norm(3,i)
3418         xmedi=c(1,i)+0.5d0*dxi
3419         ymedi=c(2,i)+0.5d0*dyi
3420         zmedi=c(3,i)+0.5d0*dzi
3421           xmedi=mod(xmedi,boxxsize)
3422           if (xmedi.lt.0) xmedi=xmedi+boxxsize
3423           ymedi=mod(ymedi,boxysize)
3424           if (ymedi.lt.0) ymedi=ymedi+boxysize
3425           zmedi=mod(zmedi,boxzsize)
3426           if (zmedi.lt.0) zmedi=zmedi+boxzsize
3427         num_conti=0
3428         call eelecij(i,i+2,ees,evdw1,eel_loc)
3429         if (wturn3.gt.0.0d0) call eturn3(i,eello_turn3)
3430         num_cont_hb(i)=num_conti
3431       enddo
3432       do i=iturn4_start,iturn4_end
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+5).gt.nres)
3437      & .or.((i-1).le.0)
3438 C end of changes suggested by Ana
3439      &    .or. itype(i+3).eq.ntyp1
3440      &    .or. itype(i+4).eq.ntyp1
3441      &    .or. itype(i+5).eq.ntyp1
3442      &    .or. itype(i).eq.ntyp1
3443      &    .or. itype(i-1).eq.ntyp1
3444      &                             ) cycle
3445         dxi=dc(1,i)
3446         dyi=dc(2,i)
3447         dzi=dc(3,i)
3448         dx_normi=dc_norm(1,i)
3449         dy_normi=dc_norm(2,i)
3450         dz_normi=dc_norm(3,i)
3451         xmedi=c(1,i)+0.5d0*dxi
3452         ymedi=c(2,i)+0.5d0*dyi
3453         zmedi=c(3,i)+0.5d0*dzi
3454 C Return atom into box, boxxsize is size of box in x dimension
3455 c  194   continue
3456 c        if (xmedi.gt.((0.5d0)*boxxsize)) xmedi=xmedi-boxxsize
3457 c        if (xmedi.lt.((-0.5d0)*boxxsize)) xmedi=xmedi+boxxsize
3458 C Condition for being inside the proper box
3459 c        if ((xmedi.gt.((0.5d0)*boxxsize)).or.
3460 c     &       (xmedi.lt.((-0.5d0)*boxxsize))) then
3461 c        go to 194
3462 c        endif
3463 c  195   continue
3464 c        if (ymedi.gt.((0.5d0)*boxysize)) ymedi=ymedi-boxysize
3465 c        if (ymedi.lt.((-0.5d0)*boxysize)) ymedi=ymedi+boxysize
3466 C Condition for being inside the proper box
3467 c        if ((ymedi.gt.((0.5d0)*boxysize)).or.
3468 c     &       (ymedi.lt.((-0.5d0)*boxysize))) then
3469 c        go to 195
3470 c        endif
3471 c  196   continue
3472 c        if (zmedi.gt.((0.5d0)*boxzsize)) zmedi=zmedi-boxzsize
3473 c        if (zmedi.lt.((-0.5d0)*boxzsize)) zmedi=zmedi+boxzsize
3474 C Condition for being inside the proper box
3475 c        if ((zmedi.gt.((0.5d0)*boxzsize)).or.
3476 c     &       (zmedi.lt.((-0.5d0)*boxzsize))) then
3477 c        go to 196
3478 c        endif
3479           xmedi=mod(xmedi,boxxsize)
3480           if (xmedi.lt.0) xmedi=xmedi+boxxsize
3481           ymedi=mod(ymedi,boxysize)
3482           if (ymedi.lt.0) ymedi=ymedi+boxysize
3483           zmedi=mod(zmedi,boxzsize)
3484           if (zmedi.lt.0) zmedi=zmedi+boxzsize
3485
3486         num_conti=num_cont_hb(i)
3487 c        write(iout,*) "JESTEM W PETLI"
3488         call eelecij(i,i+3,ees,evdw1,eel_loc)
3489         if (wturn4.gt.0.0d0 .and. itype(i+2).ne.ntyp1)
3490      &   call eturn4(i,eello_turn4)
3491         num_cont_hb(i)=num_conti
3492       enddo   ! i
3493 C Loop over all neighbouring boxes
3494 C      do xshift=-1,1
3495 C      do yshift=-1,1
3496 C      do zshift=-1,1
3497 c
3498 c Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
3499 c
3500 CTU KURWA
3501       do i=iatel_s,iatel_e
3502 C        do i=75,75
3503         if (i.le.1) cycle
3504         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
3505 C changes suggested by Ana to avoid out of bounds
3506      & .or.((i+2).gt.nres)
3507      & .or.((i-1).le.0)
3508 C end of changes by Ana
3509      &  .or. itype(i+2).eq.ntyp1
3510      &  .or. itype(i-1).eq.ntyp1
3511      &                ) cycle
3512         dxi=dc(1,i)
3513         dyi=dc(2,i)
3514         dzi=dc(3,i)
3515         dx_normi=dc_norm(1,i)
3516         dy_normi=dc_norm(2,i)
3517         dz_normi=dc_norm(3,i)
3518         xmedi=c(1,i)+0.5d0*dxi
3519         ymedi=c(2,i)+0.5d0*dyi
3520         zmedi=c(3,i)+0.5d0*dzi
3521           xmedi=mod(xmedi,boxxsize)
3522           if (xmedi.lt.0) xmedi=xmedi+boxxsize
3523           ymedi=mod(ymedi,boxysize)
3524           if (ymedi.lt.0) ymedi=ymedi+boxysize
3525           zmedi=mod(zmedi,boxzsize)
3526           if (zmedi.lt.0) zmedi=zmedi+boxzsize
3527 C          xmedi=xmedi+xshift*boxxsize
3528 C          ymedi=ymedi+yshift*boxysize
3529 C          zmedi=zmedi+zshift*boxzsize
3530
3531 C Return tom into box, boxxsize is size of box in x dimension
3532 c  164   continue
3533 c        if (xmedi.gt.((xshift+0.5d0)*boxxsize)) xmedi=xmedi-boxxsize
3534 c        if (xmedi.lt.((xshift-0.5d0)*boxxsize)) xmedi=xmedi+boxxsize
3535 C Condition for being inside the proper box
3536 c        if ((xmedi.gt.((xshift+0.5d0)*boxxsize)).or.
3537 c     &       (xmedi.lt.((xshift-0.5d0)*boxxsize))) then
3538 c        go to 164
3539 c        endif
3540 c  165   continue
3541 c        if (ymedi.gt.((yshift+0.5d0)*boxysize)) ymedi=ymedi-boxysize
3542 c        if (ymedi.lt.((yshift-0.5d0)*boxysize)) ymedi=ymedi+boxysize
3543 C Condition for being inside the proper box
3544 c        if ((ymedi.gt.((yshift+0.5d0)*boxysize)).or.
3545 c     &       (ymedi.lt.((yshift-0.5d0)*boxysize))) then
3546 c        go to 165
3547 c        endif
3548 c  166   continue
3549 c        if (zmedi.gt.((zshift+0.5d0)*boxzsize)) zmedi=zmedi-boxzsize
3550 c        if (zmedi.lt.((zshift-0.5d0)*boxzsize)) zmedi=zmedi+boxzsize
3551 cC Condition for being inside the proper box
3552 c        if ((zmedi.gt.((zshift+0.5d0)*boxzsize)).or.
3553 c     &       (zmedi.lt.((zshift-0.5d0)*boxzsize))) then
3554 c        go to 166
3555 c        endif
3556
3557 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
3558         num_conti=num_cont_hb(i)
3559 C I TU KURWA
3560         do j=ielstart(i),ielend(i)
3561 C          do j=16,17
3562 C          write (iout,*) i,j
3563          if (j.le.1) cycle
3564           if (itype(j).eq.ntyp1.or. itype(j+1).eq.ntyp1
3565 C changes suggested by Ana to avoid out of bounds
3566      & .or.((j+2).gt.nres)
3567      & .or.((j-1).le.0)
3568 C end of changes by Ana
3569      & .or.itype(j+2).eq.ntyp1
3570      & .or.itype(j-1).eq.ntyp1
3571      &) cycle
3572           call eelecij(i,j,ees,evdw1,eel_loc)
3573         enddo ! j
3574         num_cont_hb(i)=num_conti
3575       enddo   ! i
3576 C     enddo   ! zshift
3577 C      enddo   ! yshift
3578 C      enddo   ! xshift
3579
3580 c      write (iout,*) "Number of loop steps in EELEC:",ind
3581 cd      do i=1,nres
3582 cd        write (iout,'(i3,3f10.5,5x,3f10.5)')
3583 cd     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
3584 cd      enddo
3585 c 12/7/99 Adam eello_turn3 will be considered as a separate energy term
3586 ccc      eel_loc=eel_loc+eello_turn3
3587 cd      print *,"Processor",fg_rank," t_eelecij",t_eelecij
3588       return
3589       end
3590 C-------------------------------------------------------------------------------
3591       subroutine eelecij(i,j,ees,evdw1,eel_loc)
3592       implicit real*8 (a-h,o-z)
3593       include 'DIMENSIONS'
3594 #ifdef MPI
3595       include "mpif.h"
3596 #endif
3597       include 'COMMON.CONTROL'
3598       include 'COMMON.IOUNITS'
3599       include 'COMMON.GEO'
3600       include 'COMMON.VAR'
3601       include 'COMMON.LOCAL'
3602       include 'COMMON.CHAIN'
3603       include 'COMMON.DERIV'
3604       include 'COMMON.INTERACT'
3605       include 'COMMON.CONTACTS'
3606       include 'COMMON.TORSION'
3607       include 'COMMON.VECTORS'
3608       include 'COMMON.FFIELD'
3609       include 'COMMON.TIME1'
3610       include 'COMMON.SPLITELE'
3611       include 'COMMON.SHIELD'
3612       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
3613      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
3614       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
3615      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4),gmuij1(4),gmuji1(4),
3616      &    gmuij2(4),gmuji2(4)
3617       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3618      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3619      &    num_conti,j1,j2
3620 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
3621 #ifdef MOMENT
3622       double precision scal_el /1.0d0/
3623 #else
3624       double precision scal_el /0.5d0/
3625 #endif
3626 C 12/13/98
3627 C 13-go grudnia roku pamietnego...
3628       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
3629      &                   0.0d0,1.0d0,0.0d0,
3630      &                   0.0d0,0.0d0,1.0d0/
3631 c          time00=MPI_Wtime()
3632 cd      write (iout,*) "eelecij",i,j
3633 c          ind=ind+1
3634           iteli=itel(i)
3635           itelj=itel(j)
3636           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
3637           aaa=app(iteli,itelj)
3638           bbb=bpp(iteli,itelj)
3639           ael6i=ael6(iteli,itelj)
3640           ael3i=ael3(iteli,itelj)
3641           dxj=dc(1,j)
3642           dyj=dc(2,j)
3643           dzj=dc(3,j)
3644           dx_normj=dc_norm(1,j)
3645           dy_normj=dc_norm(2,j)
3646           dz_normj=dc_norm(3,j)
3647 C          xj=c(1,j)+0.5D0*dxj-xmedi
3648 C          yj=c(2,j)+0.5D0*dyj-ymedi
3649 C          zj=c(3,j)+0.5D0*dzj-zmedi
3650           xj=c(1,j)+0.5D0*dxj
3651           yj=c(2,j)+0.5D0*dyj
3652           zj=c(3,j)+0.5D0*dzj
3653           xj=mod(xj,boxxsize)
3654           if (xj.lt.0) xj=xj+boxxsize
3655           yj=mod(yj,boxysize)
3656           if (yj.lt.0) yj=yj+boxysize
3657           zj=mod(zj,boxzsize)
3658           if (zj.lt.0) zj=zj+boxzsize
3659           if ((zj.lt.0).or.(xj.lt.0).or.(yj.lt.0)) write (*,*) "CHUJ"
3660       dist_init=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
3661       xj_safe=xj
3662       yj_safe=yj
3663       zj_safe=zj
3664       isubchap=0
3665       do xshift=-1,1
3666       do yshift=-1,1
3667       do zshift=-1,1
3668           xj=xj_safe+xshift*boxxsize
3669           yj=yj_safe+yshift*boxysize
3670           zj=zj_safe+zshift*boxzsize
3671           dist_temp=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
3672           if(dist_temp.lt.dist_init) then
3673             dist_init=dist_temp
3674             xj_temp=xj
3675             yj_temp=yj
3676             zj_temp=zj
3677             isubchap=1
3678           endif
3679        enddo
3680        enddo
3681        enddo
3682        if (isubchap.eq.1) then
3683           xj=xj_temp-xmedi
3684           yj=yj_temp-ymedi
3685           zj=zj_temp-zmedi
3686        else
3687           xj=xj_safe-xmedi
3688           yj=yj_safe-ymedi
3689           zj=zj_safe-zmedi
3690        endif
3691 C        if ((i+3).lt.j) then !this condition keeps for turn3 and turn4 not subject to PBC
3692 c  174   continue
3693 c        if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
3694 c        if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
3695 C Condition for being inside the proper box
3696 c        if ((xj.gt.((0.5d0)*boxxsize)).or.
3697 c     &       (xj.lt.((-0.5d0)*boxxsize))) then
3698 c        go to 174
3699 c        endif
3700 c  175   continue
3701 c        if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
3702 c        if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
3703 C Condition for being inside the proper box
3704 c        if ((yj.gt.((0.5d0)*boxysize)).or.
3705 c     &       (yj.lt.((-0.5d0)*boxysize))) then
3706 c        go to 175
3707 c        endif
3708 c  176   continue
3709 c        if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
3710 c        if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
3711 C Condition for being inside the proper box
3712 c        if ((zj.gt.((0.5d0)*boxzsize)).or.
3713 c     &       (zj.lt.((-0.5d0)*boxzsize))) then
3714 c        go to 176
3715 c        endif
3716 C        endif !endPBC condintion
3717 C        xj=xj-xmedi
3718 C        yj=yj-ymedi
3719 C        zj=zj-zmedi
3720           rij=xj*xj+yj*yj+zj*zj
3721
3722             sss=sscale(sqrt(rij))
3723             sssgrad=sscagrad(sqrt(rij))
3724 c            if (sss.gt.0.0d0) then
3725           rrmij=1.0D0/rij
3726           rij=dsqrt(rij)
3727           rmij=1.0D0/rij
3728           r3ij=rrmij*rmij
3729           r6ij=r3ij*r3ij
3730           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
3731           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
3732           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
3733           fac=cosa-3.0D0*cosb*cosg
3734           ev1=aaa*r6ij*r6ij
3735 c 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
3736           if (j.eq.i+2) ev1=scal_el*ev1
3737           ev2=bbb*r6ij
3738           fac3=ael6i*r6ij
3739           fac4=ael3i*r3ij
3740           evdwij=(ev1+ev2)
3741           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
3742           el2=fac4*fac
3743 C MARYSIA
3744 C          eesij=(el1+el2)
3745 C 12/26/95 - for the evaluation of multi-body H-bonding interactions
3746           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
3747           if (shield_mode.gt.0) then
3748 C          fac_shield(i)=0.4
3749 C          fac_shield(j)=0.6
3750           el1=el1*fac_shield(i)**2*fac_shield(j)**2
3751           el2=el2*fac_shield(i)**2*fac_shield(j)**2
3752           eesij=(el1+el2)
3753           ees=ees+eesij
3754           else
3755           fac_shield(i)=1.0
3756           fac_shield(j)=1.0
3757           eesij=(el1+el2)
3758           ees=ees+eesij
3759           endif
3760           evdw1=evdw1+evdwij*sss
3761 cd          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
3762 cd     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
3763 cd     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
3764 cd     &      xmedi,ymedi,zmedi,xj,yj,zj
3765
3766           if (energy_dec) then
3767               write (iout,'(a6,2i5,0pf7.3,2i5,2e11.3)')
3768      &'evdw1',i,j,evdwij
3769      &,iteli,itelj,aaa,evdw1
3770               write (iout,'(a6,2i5,0pf7.3,2f8.3)') 'ees',i,j,eesij,
3771      &fac_shield(i),fac_shield(j)
3772           endif
3773
3774 C
3775 C Calculate contributions to the Cartesian gradient.
3776 C
3777 #ifdef SPLITELE
3778           facvdw=-6*rrmij*(ev1+evdwij)*sss
3779           facel=-3*rrmij*(el1+eesij)
3780           fac1=fac
3781           erij(1)=xj*rmij
3782           erij(2)=yj*rmij
3783           erij(3)=zj*rmij
3784
3785 *
3786 * Radial derivatives. First process both termini of the fragment (i,j)
3787 *
3788           ggg(1)=facel*xj
3789           ggg(2)=facel*yj
3790           ggg(3)=facel*zj
3791           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
3792      &  (shield_mode.gt.0)) then
3793 C          print *,i,j
3794           do ilist=1,ishield_list(i)
3795            iresshield=shield_list(ilist,i)
3796            do k=1,3
3797            rlocshield=grad_shield_side(k,ilist,i)*eesij/fac_shield(i)
3798      &      *2.0
3799            gshieldx(k,iresshield)=gshieldx(k,iresshield)+
3800      &              rlocshield
3801      & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)*2.0
3802             gshieldc(k,iresshield-1)=gshieldc(k,iresshield-1)+rlocshield
3803 C           gshieldc_loc(k,iresshield)=gshieldc_loc(k,iresshield)
3804 C     & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)
3805 C             if (iresshield.gt.i) then
3806 C               do ishi=i+1,iresshield-1
3807 C                gshieldc(k,ishi)=gshieldc(k,ishi)+rlocshield
3808 C     & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)
3809 C
3810 C              enddo
3811 C             else
3812 C               do ishi=iresshield,i
3813 C                gshieldc(k,ishi)=gshieldc(k,ishi)-rlocshield
3814 C     & -grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)
3815 C
3816 C               enddo
3817 C              endif
3818            enddo
3819           enddo
3820           do ilist=1,ishield_list(j)
3821            iresshield=shield_list(ilist,j)
3822            do k=1,3
3823            rlocshield=grad_shield_side(k,ilist,j)*eesij/fac_shield(j)
3824      &     *2.0
3825            gshieldx(k,iresshield)=gshieldx(k,iresshield)+
3826      &              rlocshield
3827      & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)*2.0
3828            gshieldc(k,iresshield-1)=gshieldc(k,iresshield-1)+rlocshield
3829
3830 C     & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
3831 C           gshieldc_loc(k,iresshield)=gshieldc_loc(k,iresshield)
3832 C     & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
3833 C             if (iresshield.gt.j) then
3834 C               do ishi=j+1,iresshield-1
3835 C                gshieldc(k,ishi)=gshieldc(k,ishi)+rlocshield
3836 C     & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
3837 C
3838 C               enddo
3839 C            else
3840 C               do ishi=iresshield,j
3841 C                gshieldc(k,ishi)=gshieldc(k,ishi)-rlocshield
3842 C     & -grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
3843 C               enddo
3844 C              endif
3845            enddo
3846           enddo
3847
3848           do k=1,3
3849             gshieldc(k,i)=gshieldc(k,i)+
3850      &              grad_shield(k,i)*eesij/fac_shield(i)*2.0
3851             gshieldc(k,j)=gshieldc(k,j)+
3852      &              grad_shield(k,j)*eesij/fac_shield(j)*2.0
3853             gshieldc(k,i-1)=gshieldc(k,i-1)+
3854      &              grad_shield(k,i)*eesij/fac_shield(i)*2.0
3855             gshieldc(k,j-1)=gshieldc(k,j-1)+
3856      &              grad_shield(k,j)*eesij/fac_shield(j)*2.0
3857
3858            enddo
3859            endif
3860 c          do k=1,3
3861 c            ghalf=0.5D0*ggg(k)
3862 c            gelc(k,i)=gelc(k,i)+ghalf
3863 c            gelc(k,j)=gelc(k,j)+ghalf
3864 c          enddo
3865 c 9/28/08 AL Gradient compotents will be summed only at the end
3866 C           print *,"before", gelc_long(1,i), gelc_long(1,j)
3867           do k=1,3
3868             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
3869 C     &                    +grad_shield(k,j)*eesij/fac_shield(j)
3870             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
3871 C     &                    +grad_shield(k,i)*eesij/fac_shield(i)
3872 C            gelc_long(k,i-1)=gelc_long(k,i-1)
3873 C     &                    +grad_shield(k,i)*eesij/fac_shield(i)
3874 C            gelc_long(k,j-1)=gelc_long(k,j-1)
3875 C     &                    +grad_shield(k,j)*eesij/fac_shield(j)
3876           enddo
3877 C           print *,"bafter", gelc_long(1,i), gelc_long(1,j)
3878
3879 *
3880 * Loop over residues i+1 thru j-1.
3881 *
3882 cgrad          do k=i+1,j-1
3883 cgrad            do l=1,3
3884 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3885 cgrad            enddo
3886 cgrad          enddo
3887           if (sss.gt.0.0) then
3888           ggg(1)=facvdw*xj+sssgrad*rmij*evdwij*xj
3889           ggg(2)=facvdw*yj+sssgrad*rmij*evdwij*yj
3890           ggg(3)=facvdw*zj+sssgrad*rmij*evdwij*zj
3891           else
3892           ggg(1)=0.0
3893           ggg(2)=0.0
3894           ggg(3)=0.0
3895           endif
3896 c          do k=1,3
3897 c            ghalf=0.5D0*ggg(k)
3898 c            gvdwpp(k,i)=gvdwpp(k,i)+ghalf
3899 c            gvdwpp(k,j)=gvdwpp(k,j)+ghalf
3900 c          enddo
3901 c 9/28/08 AL Gradient compotents will be summed only at the end
3902           do k=1,3
3903             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
3904             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
3905           enddo
3906 *
3907 * Loop over residues i+1 thru j-1.
3908 *
3909 cgrad          do k=i+1,j-1
3910 cgrad            do l=1,3
3911 cgrad              gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
3912 cgrad            enddo
3913 cgrad          enddo
3914 #else
3915 C MARYSIA
3916           facvdw=(ev1+evdwij)*sss
3917           facel=(el1+eesij)
3918           fac1=fac
3919           fac=-3*rrmij*(facvdw+facvdw+facel)
3920           erij(1)=xj*rmij
3921           erij(2)=yj*rmij
3922           erij(3)=zj*rmij
3923 *
3924 * Radial derivatives. First process both termini of the fragment (i,j)
3925 *
3926           ggg(1)=fac*xj
3927 C+eesij*grad_shield(1,i)+eesij*grad_shield(1,j)
3928           ggg(2)=fac*yj
3929 C+eesij*grad_shield(2,i)+eesij*grad_shield(2,j)
3930           ggg(3)=fac*zj
3931 C+eesij*grad_shield(3,i)+eesij*grad_shield(3,j)
3932 c          do k=1,3
3933 c            ghalf=0.5D0*ggg(k)
3934 c            gelc(k,i)=gelc(k,i)+ghalf
3935 c            gelc(k,j)=gelc(k,j)+ghalf
3936 c          enddo
3937 c 9/28/08 AL Gradient compotents will be summed only at the end
3938           do k=1,3
3939             gelc_long(k,j)=gelc(k,j)+ggg(k)
3940             gelc_long(k,i)=gelc(k,i)-ggg(k)
3941           enddo
3942 *
3943 * Loop over residues i+1 thru j-1.
3944 *
3945 cgrad          do k=i+1,j-1
3946 cgrad            do l=1,3
3947 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3948 cgrad            enddo
3949 cgrad          enddo
3950 c 9/28/08 AL Gradient compotents will be summed only at the end
3951           ggg(1)=facvdw*xj+sssgrad*rmij*evdwij*xj
3952           ggg(2)=facvdw*yj+sssgrad*rmij*evdwij*yj
3953           ggg(3)=facvdw*zj+sssgrad*rmij*evdwij*zj
3954           do k=1,3
3955             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
3956             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
3957           enddo
3958 #endif
3959 *
3960 * Angular part
3961 *
3962           ecosa=2.0D0*fac3*fac1+fac4
3963           fac4=-3.0D0*fac4
3964           fac3=-6.0D0*fac3
3965           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
3966           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
3967           do k=1,3
3968             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
3969             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
3970           enddo
3971 cd        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
3972 cd   &          (dcosg(k),k=1,3)
3973           do k=1,3
3974             ggg(k)=(ecosb*dcosb(k)+ecosg*dcosg(k))*
3975      &      fac_shield(i)**2*fac_shield(j)**2
3976           enddo
3977 c          do k=1,3
3978 c            ghalf=0.5D0*ggg(k)
3979 c            gelc(k,i)=gelc(k,i)+ghalf
3980 c     &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
3981 c     &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3982 c            gelc(k,j)=gelc(k,j)+ghalf
3983 c     &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
3984 c     &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3985 c          enddo
3986 cgrad          do k=i+1,j-1
3987 cgrad            do l=1,3
3988 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3989 cgrad            enddo
3990 cgrad          enddo
3991 C                     print *,"before22", gelc_long(1,i), gelc_long(1,j)
3992           do k=1,3
3993             gelc(k,i)=gelc(k,i)
3994      &           +((ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
3995      &           + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1))
3996      &           *fac_shield(i)**2*fac_shield(j)**2
3997             gelc(k,j)=gelc(k,j)
3998      &           +((ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
3999      &           + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1))
4000      &           *fac_shield(i)**2*fac_shield(j)**2
4001             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
4002             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
4003           enddo
4004 C           print *,"before33", gelc_long(1,i), gelc_long(1,j)
4005
4006 C MARYSIA
4007 c          endif !sscale
4008           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
4009      &        .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0
4010      &        .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
4011 C
4012 C 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
4013 C   energy of a peptide unit is assumed in the form of a second-order
4014 C   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
4015 C   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
4016 C   are computed for EVERY pair of non-contiguous peptide groups.
4017 C
4018
4019           if (j.lt.nres-1) then
4020             j1=j+1
4021             j2=j-1
4022           else
4023             j1=j-1
4024             j2=j-2
4025           endif
4026           kkk=0
4027           lll=0
4028           do k=1,2
4029             do l=1,2
4030               kkk=kkk+1
4031               muij(kkk)=mu(k,i)*mu(l,j)
4032 c              write(iout,*) 'mumu=', mu(k,i),mu(l,j),i,j,k,l
4033 #ifdef NEWCORR
4034              gmuij1(kkk)=gtb1(k,i+1)*mu(l,j)
4035 c             write(iout,*) 'k=',k,i,gtb1(k,i+1),gtb1(k,i+1)*mu(l,j)
4036              gmuij2(kkk)=gUb2(k,i)*mu(l,j)
4037              gmuji1(kkk)=mu(k,i)*gtb1(l,j+1)
4038 c             write(iout,*) 'l=',l,j,gtb1(l,j+1),gtb1(l,j+1)*mu(k,i)
4039              gmuji2(kkk)=mu(k,i)*gUb2(l,j)
4040 #endif
4041             enddo
4042           enddo
4043 cd         write (iout,*) 'EELEC: i',i,' j',j
4044 cd          write (iout,*) 'j',j,' j1',j1,' j2',j2
4045 cd          write(iout,*) 'muij',muij
4046           ury=scalar(uy(1,i),erij)
4047           urz=scalar(uz(1,i),erij)
4048           vry=scalar(uy(1,j),erij)
4049           vrz=scalar(uz(1,j),erij)
4050           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
4051           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
4052           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
4053           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
4054           fac=dsqrt(-ael6i)*r3ij
4055           a22=a22*fac
4056           a23=a23*fac
4057           a32=a32*fac
4058           a33=a33*fac
4059 cd          write (iout,'(4i5,4f10.5)')
4060 cd     &     i,itortyp(itype(i)),j,itortyp(itype(j)),a22,a23,a32,a33
4061 cd          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
4062 cd          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') uy(:,i),uz(:,i),
4063 cd     &      uy(:,j),uz(:,j)
4064 cd          write (iout,'(4f10.5)')
4065 cd     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
4066 cd     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
4067 cd          write (iout,'(4f10.5)') ury,urz,vry,vrz
4068 cd           write (iout,'(9f10.5/)')
4069 cd     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
4070 C Derivatives of the elements of A in virtual-bond vectors
4071           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
4072           do k=1,3
4073             uryg(k,1)=scalar(erder(1,k),uy(1,i))
4074             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
4075             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
4076             urzg(k,1)=scalar(erder(1,k),uz(1,i))
4077             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
4078             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
4079             vryg(k,1)=scalar(erder(1,k),uy(1,j))
4080             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
4081             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
4082             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
4083             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
4084             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
4085           enddo
4086 C Compute radial contributions to the gradient
4087           facr=-3.0d0*rrmij
4088           a22der=a22*facr
4089           a23der=a23*facr
4090           a32der=a32*facr
4091           a33der=a33*facr
4092           agg(1,1)=a22der*xj
4093           agg(2,1)=a22der*yj
4094           agg(3,1)=a22der*zj
4095           agg(1,2)=a23der*xj
4096           agg(2,2)=a23der*yj
4097           agg(3,2)=a23der*zj
4098           agg(1,3)=a32der*xj
4099           agg(2,3)=a32der*yj
4100           agg(3,3)=a32der*zj
4101           agg(1,4)=a33der*xj
4102           agg(2,4)=a33der*yj
4103           agg(3,4)=a33der*zj
4104 C Add the contributions coming from er
4105           fac3=-3.0d0*fac
4106           do k=1,3
4107             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
4108             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
4109             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
4110             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
4111           enddo
4112           do k=1,3
4113 C Derivatives in DC(i)
4114 cgrad            ghalf1=0.5d0*agg(k,1)
4115 cgrad            ghalf2=0.5d0*agg(k,2)
4116 cgrad            ghalf3=0.5d0*agg(k,3)
4117 cgrad            ghalf4=0.5d0*agg(k,4)
4118             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j))
4119      &      -3.0d0*uryg(k,2)*vry)!+ghalf1
4120             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j))
4121      &      -3.0d0*uryg(k,2)*vrz)!+ghalf2
4122             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j))
4123      &      -3.0d0*urzg(k,2)*vry)!+ghalf3
4124             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j))
4125      &      -3.0d0*urzg(k,2)*vrz)!+ghalf4
4126 C Derivatives in DC(i+1)
4127             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j))
4128      &      -3.0d0*uryg(k,3)*vry)!+agg(k,1)
4129             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j))
4130      &      -3.0d0*uryg(k,3)*vrz)!+agg(k,2)
4131             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j))
4132      &      -3.0d0*urzg(k,3)*vry)!+agg(k,3)
4133             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j))
4134      &      -3.0d0*urzg(k,3)*vrz)!+agg(k,4)
4135 C Derivatives in DC(j)
4136             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i))
4137      &      -3.0d0*vryg(k,2)*ury)!+ghalf1
4138             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i))
4139      &      -3.0d0*vrzg(k,2)*ury)!+ghalf2
4140             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i))
4141      &      -3.0d0*vryg(k,2)*urz)!+ghalf3
4142             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i))
4143      &      -3.0d0*vrzg(k,2)*urz)!+ghalf4
4144 C Derivatives in DC(j+1) or DC(nres-1)
4145             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i))
4146      &      -3.0d0*vryg(k,3)*ury)
4147             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i))
4148      &      -3.0d0*vrzg(k,3)*ury)
4149             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i))
4150      &      -3.0d0*vryg(k,3)*urz)
4151             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i))
4152      &      -3.0d0*vrzg(k,3)*urz)
4153 cgrad            if (j.eq.nres-1 .and. i.lt.j-2) then
4154 cgrad              do l=1,4
4155 cgrad                aggj1(k,l)=aggj1(k,l)+agg(k,l)
4156 cgrad              enddo
4157 cgrad            endif
4158           enddo
4159           acipa(1,1)=a22
4160           acipa(1,2)=a23
4161           acipa(2,1)=a32
4162           acipa(2,2)=a33
4163           a22=-a22
4164           a23=-a23
4165           do l=1,2
4166             do k=1,3
4167               agg(k,l)=-agg(k,l)
4168               aggi(k,l)=-aggi(k,l)
4169               aggi1(k,l)=-aggi1(k,l)
4170               aggj(k,l)=-aggj(k,l)
4171               aggj1(k,l)=-aggj1(k,l)
4172             enddo
4173           enddo
4174           if (j.lt.nres-1) then
4175             a22=-a22
4176             a32=-a32
4177             do l=1,3,2
4178               do k=1,3
4179                 agg(k,l)=-agg(k,l)
4180                 aggi(k,l)=-aggi(k,l)
4181                 aggi1(k,l)=-aggi1(k,l)
4182                 aggj(k,l)=-aggj(k,l)
4183                 aggj1(k,l)=-aggj1(k,l)
4184               enddo
4185             enddo
4186           else
4187             a22=-a22
4188             a23=-a23
4189             a32=-a32
4190             a33=-a33
4191             do l=1,4
4192               do k=1,3
4193                 agg(k,l)=-agg(k,l)
4194                 aggi(k,l)=-aggi(k,l)
4195                 aggi1(k,l)=-aggi1(k,l)
4196                 aggj(k,l)=-aggj(k,l)
4197                 aggj1(k,l)=-aggj1(k,l)
4198               enddo
4199             enddo
4200           endif
4201           ENDIF ! WCORR
4202           IF (wel_loc.gt.0.0d0) THEN
4203 C Contribution to the local-electrostatic energy coming from the i-j pair
4204           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3)
4205      &     +a33*muij(4)
4206           if (shield_mode.eq.0) then
4207            fac_shield(i)=1.0
4208            fac_shield(j)=1.0
4209 C          else
4210 C           fac_shield(i)=0.4
4211 C           fac_shield(j)=0.6
4212           endif
4213           eel_loc_ij=eel_loc_ij
4214      &    *fac_shield(i)*fac_shield(j)
4215 C Now derivative over eel_loc
4216           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
4217      &  (shield_mode.gt.0)) then
4218 C          print *,i,j
4219
4220           do ilist=1,ishield_list(i)
4221            iresshield=shield_list(ilist,i)
4222            do k=1,3
4223            rlocshield=grad_shield_side(k,ilist,i)*eel_loc_ij
4224      &                                          /fac_shield(i)
4225 C     &      *2.0
4226            gshieldx_ll(k,iresshield)=gshieldx_ll(k,iresshield)+
4227      &              rlocshield
4228      & +grad_shield_loc(k,ilist,i)*eel_loc_ij/fac_shield(i)
4229             gshieldc_ll(k,iresshield-1)=gshieldc_ll(k,iresshield-1)
4230      &      +rlocshield
4231            enddo
4232           enddo
4233           do ilist=1,ishield_list(j)
4234            iresshield=shield_list(ilist,j)
4235            do k=1,3
4236            rlocshield=grad_shield_side(k,ilist,j)*eel_loc_ij
4237      &                                       /fac_shield(j)
4238 C     &     *2.0
4239            gshieldx_ll(k,iresshield)=gshieldx_ll(k,iresshield)+
4240      &              rlocshield
4241      & +grad_shield_loc(k,ilist,j)*eel_loc_ij/fac_shield(j)
4242            gshieldc_ll(k,iresshield-1)=gshieldc_ll(k,iresshield-1)
4243      &             +rlocshield
4244
4245            enddo
4246           enddo
4247
4248           do k=1,3
4249             gshieldc_ll(k,i)=gshieldc_ll(k,i)+
4250      &              grad_shield(k,i)*eel_loc_ij/fac_shield(i)
4251             gshieldc_ll(k,j)=gshieldc_ll(k,j)+
4252      &              grad_shield(k,j)*eel_loc_ij/fac_shield(j)
4253             gshieldc_ll(k,i-1)=gshieldc_ll(k,i-1)+
4254      &              grad_shield(k,i)*eel_loc_ij/fac_shield(i)
4255             gshieldc_ll(k,j-1)=gshieldc_ll(k,j-1)+
4256      &              grad_shield(k,j)*eel_loc_ij/fac_shield(j)
4257            enddo
4258            endif
4259
4260
4261 c          write (iout,*) 'i',i,' j',j,itype(i),itype(j),
4262 c     &                     ' eel_loc_ij',eel_loc_ij
4263 C          write(iout,*) 'muije=',i,j,muij(1),muij(2),muij(3),muij(4)
4264 C Calculate patrial derivative for theta angle
4265 #ifdef NEWCORR
4266          geel_loc_ij=(a22*gmuij1(1)
4267      &     +a23*gmuij1(2)
4268      &     +a32*gmuij1(3)
4269      &     +a33*gmuij1(4))
4270      &    *fac_shield(i)*fac_shield(j)
4271 c         write(iout,*) "derivative over thatai"
4272 c         write(iout,*) a22*gmuij1(1), a23*gmuij1(2) ,a32*gmuij1(3),
4273 c     &   a33*gmuij1(4)
4274          gloc(nphi+i,icg)=gloc(nphi+i,icg)+
4275      &      geel_loc_ij*wel_loc
4276 c         write(iout,*) "derivative over thatai-1"
4277 c         write(iout,*) a22*gmuij2(1), a23*gmuij2(2) ,a32*gmuij2(3),
4278 c     &   a33*gmuij2(4)
4279          geel_loc_ij=
4280      &     a22*gmuij2(1)
4281      &     +a23*gmuij2(2)
4282      &     +a32*gmuij2(3)
4283      &     +a33*gmuij2(4)
4284          gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
4285      &      geel_loc_ij*wel_loc
4286      &    *fac_shield(i)*fac_shield(j)
4287
4288 c  Derivative over j residue
4289          geel_loc_ji=a22*gmuji1(1)
4290      &     +a23*gmuji1(2)
4291      &     +a32*gmuji1(3)
4292      &     +a33*gmuji1(4)
4293 c         write(iout,*) "derivative over thataj"
4294 c         write(iout,*) a22*gmuji1(1), a23*gmuji1(2) ,a32*gmuji1(3),
4295 c     &   a33*gmuji1(4)
4296
4297         gloc(nphi+j,icg)=gloc(nphi+j,icg)+
4298      &      geel_loc_ji*wel_loc
4299      &    *fac_shield(i)*fac_shield(j)
4300
4301          geel_loc_ji=
4302      &     +a22*gmuji2(1)
4303      &     +a23*gmuji2(2)
4304      &     +a32*gmuji2(3)
4305      &     +a33*gmuji2(4)
4306 c         write(iout,*) "derivative over thataj-1"
4307 c         write(iout,*) a22*gmuji2(1), a23*gmuji2(2) ,a32*gmuji2(3),
4308 c     &   a33*gmuji2(4)
4309          gloc(nphi+j-1,icg)=gloc(nphi+j-1,icg)+
4310      &      geel_loc_ji*wel_loc
4311      &    *fac_shield(i)*fac_shield(j)
4312 #endif
4313 cd          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
4314
4315           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
4316      &            'eelloc',i,j,eel_loc_ij
4317 c           if (eel_loc_ij.ne.0)
4318 c     &      write (iout,'(a4,2i4,8f9.5)')'chuj',
4319 c     &     i,j,a22,muij(1),a23,muij(2),a32,muij(3),a33,muij(4)
4320
4321           eel_loc=eel_loc+eel_loc_ij
4322 C Partial derivatives in virtual-bond dihedral angles gamma
4323           if (i.gt.1)
4324      &    gel_loc_loc(i-1)=gel_loc_loc(i-1)+
4325      &            (a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j)
4326      &           +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j))
4327      &    *fac_shield(i)*fac_shield(j)
4328
4329           gel_loc_loc(j-1)=gel_loc_loc(j-1)+
4330      &           (a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j)
4331      &           +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j))
4332      &    *fac_shield(i)*fac_shield(j)
4333 C Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
4334           do l=1,3
4335             ggg(l)=(agg(l,1)*muij(1)+
4336      &          agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4))
4337      &    *fac_shield(i)*fac_shield(j)
4338             gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l)
4339             gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l)
4340 cgrad            ghalf=0.5d0*ggg(l)
4341 cgrad            gel_loc(l,i)=gel_loc(l,i)+ghalf
4342 cgrad            gel_loc(l,j)=gel_loc(l,j)+ghalf
4343           enddo
4344 cgrad          do k=i+1,j2
4345 cgrad            do l=1,3
4346 cgrad              gel_loc(l,k)=gel_loc(l,k)+ggg(l)
4347 cgrad            enddo
4348 cgrad          enddo
4349 C Remaining derivatives of eello
4350           do l=1,3
4351             gel_loc(l,i)=gel_loc(l,i)+(aggi(l,1)*muij(1)+
4352      &        aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4))
4353      &    *fac_shield(i)*fac_shield(j)
4354
4355             gel_loc(l,i+1)=gel_loc(l,i+1)+(aggi1(l,1)*muij(1)+
4356      &     aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4))
4357      &    *fac_shield(i)*fac_shield(j)
4358
4359             gel_loc(l,j)=gel_loc(l,j)+(aggj(l,1)*muij(1)+
4360      &       aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4))
4361      &    *fac_shield(i)*fac_shield(j)
4362
4363             gel_loc(l,j1)=gel_loc(l,j1)+(aggj1(l,1)*muij(1)+
4364      &     aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4))
4365      &    *fac_shield(i)*fac_shield(j)
4366
4367           enddo
4368           ENDIF
4369 C Change 12/26/95 to calculate four-body contributions to H-bonding energy
4370 c          if (j.gt.i+1 .and. num_conti.le.maxconts) then
4371           if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0
4372      &       .and. num_conti.le.maxconts) then
4373 c            write (iout,*) i,j," entered corr"
4374 C
4375 C Calculate the contact function. The ith column of the array JCONT will
4376 C contain the numbers of atoms that make contacts with the atom I (of numbers
4377 C greater than I). The arrays FACONT and GACONT will contain the values of
4378 C the contact function and its derivative.
4379 c           r0ij=1.02D0*rpp(iteli,itelj)
4380 c           r0ij=1.11D0*rpp(iteli,itelj)
4381             r0ij=2.20D0*rpp(iteli,itelj)
4382 c           r0ij=1.55D0*rpp(iteli,itelj)
4383             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
4384             if (fcont.gt.0.0D0) then
4385               num_conti=num_conti+1
4386               if (num_conti.gt.maxconts) then
4387                 write (iout,*) 'WARNING - max. # of contacts exceeded;',
4388      &                         ' will skip next contacts for this conf.'
4389               else
4390                 jcont_hb(num_conti,i)=j
4391 cd                write (iout,*) "i",i," j",j," num_conti",num_conti,
4392 cd     &           " jcont_hb",jcont_hb(num_conti,i)
4393                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.
4394      &          wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
4395 C 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
4396 C  terms.
4397                 d_cont(num_conti,i)=rij
4398 cd                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
4399 C     --- Electrostatic-interaction matrix ---
4400                 a_chuj(1,1,num_conti,i)=a22
4401                 a_chuj(1,2,num_conti,i)=a23
4402                 a_chuj(2,1,num_conti,i)=a32
4403                 a_chuj(2,2,num_conti,i)=a33
4404 C     --- Gradient of rij
4405                 do kkk=1,3
4406                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
4407                 enddo
4408                 kkll=0
4409                 do k=1,2
4410                   do l=1,2
4411                     kkll=kkll+1
4412                     do m=1,3
4413                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
4414                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
4415                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
4416                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
4417                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
4418                     enddo
4419                   enddo
4420                 enddo
4421                 ENDIF
4422                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
4423 C Calculate contact energies
4424                 cosa4=4.0D0*cosa
4425                 wij=cosa-3.0D0*cosb*cosg
4426                 cosbg1=cosb+cosg
4427                 cosbg2=cosb-cosg
4428 c               fac3=dsqrt(-ael6i)/r0ij**3
4429                 fac3=dsqrt(-ael6i)*r3ij
4430 c                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
4431                 ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
4432                 if (ees0tmp.gt.0) then
4433                   ees0pij=dsqrt(ees0tmp)
4434                 else
4435                   ees0pij=0
4436                 endif
4437 c                ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
4438                 ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
4439                 if (ees0tmp.gt.0) then
4440                   ees0mij=dsqrt(ees0tmp)
4441                 else
4442                   ees0mij=0
4443                 endif
4444 c               ees0mij=0.0D0
4445                 if (shield_mode.eq.0) then
4446                 fac_shield(i)=1.0d0
4447                 fac_shield(j)=1.0d0
4448                 else
4449                 ees0plist(num_conti,i)=j
4450 C                fac_shield(i)=0.4d0
4451 C                fac_shield(j)=0.6d0
4452                 endif
4453                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij)
4454      &          *fac_shield(i)*fac_shield(j)
4455                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij)
4456      &          *fac_shield(i)*fac_shield(j)
4457 C Diagnostics. Comment out or remove after debugging!
4458 c               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
4459 c               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
4460 c               ees0m(num_conti,i)=0.0D0
4461 C End diagnostics.
4462 c               write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
4463 c    & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
4464 C Angular derivatives of the contact function
4465                 ees0pij1=fac3/ees0pij
4466                 ees0mij1=fac3/ees0mij
4467                 fac3p=-3.0D0*fac3*rrmij
4468                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
4469                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
4470 c               ees0mij1=0.0D0
4471                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
4472                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
4473                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
4474                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
4475                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
4476                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
4477                 ecosap=ecosa1+ecosa2
4478                 ecosbp=ecosb1+ecosb2
4479                 ecosgp=ecosg1+ecosg2
4480                 ecosam=ecosa1-ecosa2
4481                 ecosbm=ecosb1-ecosb2
4482                 ecosgm=ecosg1-ecosg2
4483 C Diagnostics
4484 c               ecosap=ecosa1
4485 c               ecosbp=ecosb1
4486 c               ecosgp=ecosg1
4487 c               ecosam=0.0D0
4488 c               ecosbm=0.0D0
4489 c               ecosgm=0.0D0
4490 C End diagnostics
4491                 facont_hb(num_conti,i)=fcont
4492                 fprimcont=fprimcont/rij
4493 cd              facont_hb(num_conti,i)=1.0D0
4494 C Following line is for diagnostics.
4495 cd              fprimcont=0.0D0
4496                 do k=1,3
4497                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
4498                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
4499                 enddo
4500                 do k=1,3
4501                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
4502                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
4503                 enddo
4504                 gggp(1)=gggp(1)+ees0pijp*xj
4505                 gggp(2)=gggp(2)+ees0pijp*yj
4506                 gggp(3)=gggp(3)+ees0pijp*zj
4507                 gggm(1)=gggm(1)+ees0mijp*xj
4508                 gggm(2)=gggm(2)+ees0mijp*yj
4509                 gggm(3)=gggm(3)+ees0mijp*zj
4510 C Derivatives due to the contact function
4511                 gacont_hbr(1,num_conti,i)=fprimcont*xj
4512                 gacont_hbr(2,num_conti,i)=fprimcont*yj
4513                 gacont_hbr(3,num_conti,i)=fprimcont*zj
4514                 do k=1,3
4515 c
4516 c 10/24/08 cgrad and ! comments indicate the parts of the code removed
4517 c          following the change of gradient-summation algorithm.
4518 c
4519 cgrad                  ghalfp=0.5D0*gggp(k)
4520 cgrad                  ghalfm=0.5D0*gggm(k)
4521                   gacontp_hb1(k,num_conti,i)=!ghalfp
4522      &              +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i))
4523      &              + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
4524      &          *fac_shield(i)*fac_shield(j)
4525
4526                   gacontp_hb2(k,num_conti,i)=!ghalfp
4527      &              +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j))
4528      &              + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
4529      &          *fac_shield(i)*fac_shield(j)
4530
4531                   gacontp_hb3(k,num_conti,i)=gggp(k)
4532      &          *fac_shield(i)*fac_shield(j)
4533
4534                   gacontm_hb1(k,num_conti,i)=!ghalfm
4535      &              +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i))
4536      &              + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
4537      &          *fac_shield(i)*fac_shield(j)
4538
4539                   gacontm_hb2(k,num_conti,i)=!ghalfm
4540      &              +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j))
4541      &              + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
4542      &          *fac_shield(i)*fac_shield(j)
4543
4544                   gacontm_hb3(k,num_conti,i)=gggm(k)
4545      &          *fac_shield(i)*fac_shield(j)
4546
4547                 enddo
4548 C Diagnostics. Comment out or remove after debugging!
4549 cdiag           do k=1,3
4550 cdiag             gacontp_hb1(k,num_conti,i)=0.0D0
4551 cdiag             gacontp_hb2(k,num_conti,i)=0.0D0
4552 cdiag             gacontp_hb3(k,num_conti,i)=0.0D0
4553 cdiag             gacontm_hb1(k,num_conti,i)=0.0D0
4554 cdiag             gacontm_hb2(k,num_conti,i)=0.0D0
4555 cdiag             gacontm_hb3(k,num_conti,i)=0.0D0
4556 cdiag           enddo
4557               ENDIF ! wcorr
4558               endif  ! num_conti.le.maxconts
4559             endif  ! fcont.gt.0
4560           endif    ! j.gt.i+1
4561           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
4562             do k=1,4
4563               do l=1,3
4564                 ghalf=0.5d0*agg(l,k)
4565                 aggi(l,k)=aggi(l,k)+ghalf
4566                 aggi1(l,k)=aggi1(l,k)+agg(l,k)
4567                 aggj(l,k)=aggj(l,k)+ghalf
4568               enddo
4569             enddo
4570             if (j.eq.nres-1 .and. i.lt.j-2) then
4571               do k=1,4
4572                 do l=1,3
4573                   aggj1(l,k)=aggj1(l,k)+agg(l,k)
4574                 enddo
4575               enddo
4576             endif
4577           endif
4578 c          t_eelecij=t_eelecij+MPI_Wtime()-time00
4579       return
4580       end
4581 C-----------------------------------------------------------------------------
4582       subroutine eturn3(i,eello_turn3)
4583 C Third- and fourth-order contributions from turns
4584       implicit real*8 (a-h,o-z)
4585       include 'DIMENSIONS'
4586       include 'COMMON.IOUNITS'
4587       include 'COMMON.GEO'
4588       include 'COMMON.VAR'
4589       include 'COMMON.LOCAL'
4590       include 'COMMON.CHAIN'
4591       include 'COMMON.DERIV'
4592       include 'COMMON.INTERACT'
4593       include 'COMMON.CONTACTS'
4594       include 'COMMON.TORSION'
4595       include 'COMMON.VECTORS'
4596       include 'COMMON.FFIELD'
4597       include 'COMMON.CONTROL'
4598       include 'COMMON.SHIELD'
4599       dimension ggg(3)
4600       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
4601      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
4602      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2),gpizda1(2,2),
4603      &  gpizda2(2,2),auxgmat1(2,2),auxgmatt1(2,2),
4604      &  auxgmat2(2,2),auxgmatt2(2,2)
4605       double precision agg(3,4),aggi(3,4),aggi1(3,4),
4606      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
4607       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
4608      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
4609      &    num_conti,j1,j2
4610       j=i+2
4611 c      write (iout,*) "eturn3",i,j,j1,j2
4612       a_temp(1,1)=a22
4613       a_temp(1,2)=a23
4614       a_temp(2,1)=a32
4615       a_temp(2,2)=a33
4616 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4617 C
4618 C               Third-order contributions
4619 C
4620 C                 (i+2)o----(i+3)
4621 C                      | |
4622 C                      | |
4623 C                 (i+1)o----i
4624 C
4625 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4626 cd        call checkint_turn3(i,a_temp,eello_turn3_num)
4627         call matmat2(EUg(1,1,i+1),EUg(1,1,i+2),auxmat(1,1))
4628 c auxalary matices for theta gradient
4629 c auxalary matrix for i+1 and constant i+2
4630         call matmat2(gtEUg(1,1,i+1),EUg(1,1,i+2),auxgmat1(1,1))
4631 c auxalary matrix for i+2 and constant i+1
4632         call matmat2(EUg(1,1,i+1),gtEUg(1,1,i+2),auxgmat2(1,1))
4633         call transpose2(auxmat(1,1),auxmat1(1,1))
4634         call transpose2(auxgmat1(1,1),auxgmatt1(1,1))
4635         call transpose2(auxgmat2(1,1),auxgmatt2(1,1))
4636         call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4637         call matmat2(a_temp(1,1),auxgmatt1(1,1),gpizda1(1,1))
4638         call matmat2(a_temp(1,1),auxgmatt2(1,1),gpizda2(1,1))
4639         if (shield_mode.eq.0) then
4640         fac_shield(i)=1.0
4641         fac_shield(j)=1.0
4642 C        else
4643 C        fac_shield(i)=0.4
4644 C        fac_shield(j)=0.6
4645         endif
4646         eello_turn3=eello_turn3+0.5d0*(pizda(1,1)+pizda(2,2))
4647      &  *fac_shield(i)*fac_shield(j)
4648         eello_t3=0.5d0*(pizda(1,1)+pizda(2,2))
4649      &  *fac_shield(i)*fac_shield(j)
4650 C Derivatives in theta
4651         gloc(nphi+i,icg)=gloc(nphi+i,icg)
4652      &  +0.5d0*(gpizda1(1,1)+gpizda1(2,2))*wturn3
4653      &   *fac_shield(i)*fac_shield(j)
4654         gloc(nphi+i+1,icg)=gloc(nphi+i+1,icg)
4655      &  +0.5d0*(gpizda2(1,1)+gpizda2(2,2))*wturn3
4656      &   *fac_shield(i)*fac_shield(j)
4657
4658
4659 C        if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
4660 C Derivatives in shield mode
4661           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
4662      &  (shield_mode.gt.0)) then
4663 C          print *,i,j
4664
4665           do ilist=1,ishield_list(i)
4666            iresshield=shield_list(ilist,i)
4667            do k=1,3
4668            rlocshield=grad_shield_side(k,ilist,i)*eello_t3/fac_shield(i)
4669 C     &      *2.0
4670            gshieldx_t3(k,iresshield)=gshieldx_t3(k,iresshield)+
4671      &              rlocshield
4672      & +grad_shield_loc(k,ilist,i)*eello_t3/fac_shield(i)
4673             gshieldc_t3(k,iresshield-1)=gshieldc_t3(k,iresshield-1)
4674      &      +rlocshield
4675            enddo
4676           enddo
4677           do ilist=1,ishield_list(j)
4678            iresshield=shield_list(ilist,j)
4679            do k=1,3
4680            rlocshield=grad_shield_side(k,ilist,j)*eello_t3/fac_shield(j)
4681 C     &     *2.0
4682            gshieldx_t3(k,iresshield)=gshieldx_t3(k,iresshield)+
4683      &              rlocshield
4684      & +grad_shield_loc(k,ilist,j)*eello_t3/fac_shield(j)
4685            gshieldc_t3(k,iresshield-1)=gshieldc_t3(k,iresshield-1)
4686      &             +rlocshield
4687
4688            enddo
4689           enddo
4690
4691           do k=1,3
4692             gshieldc_t3(k,i)=gshieldc_t3(k,i)+
4693      &              grad_shield(k,i)*eello_t3/fac_shield(i)
4694             gshieldc_t3(k,j)=gshieldc_t3(k,j)+
4695      &              grad_shield(k,j)*eello_t3/fac_shield(j)
4696             gshieldc_t3(k,i-1)=gshieldc_t3(k,i-1)+
4697      &              grad_shield(k,i)*eello_t3/fac_shield(i)
4698             gshieldc_t3(k,j-1)=gshieldc_t3(k,j-1)+
4699      &              grad_shield(k,j)*eello_t3/fac_shield(j)
4700            enddo
4701            endif
4702
4703 C        if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
4704 cd        write (2,*) 'i,',i,' j',j,'eello_turn3',
4705 cd     &    0.5d0*(pizda(1,1)+pizda(2,2)),
4706 cd     &    ' eello_turn3_num',4*eello_turn3_num
4707 C Derivatives in gamma(i)
4708         call matmat2(EUgder(1,1,i+1),EUg(1,1,i+2),auxmat2(1,1))
4709         call transpose2(auxmat2(1,1),auxmat3(1,1))
4710         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
4711         gel_loc_turn3(i)=gel_loc_turn3(i)+0.5d0*(pizda(1,1)+pizda(2,2))
4712      &   *fac_shield(i)*fac_shield(j)
4713 C Derivatives in gamma(i+1)
4714         call matmat2(EUg(1,1,i+1),EUgder(1,1,i+2),auxmat2(1,1))
4715         call transpose2(auxmat2(1,1),auxmat3(1,1))
4716         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
4717         gel_loc_turn3(i+1)=gel_loc_turn3(i+1)
4718      &    +0.5d0*(pizda(1,1)+pizda(2,2))
4719      &   *fac_shield(i)*fac_shield(j)
4720 C Cartesian derivatives
4721         do l=1,3
4722 c            ghalf1=0.5d0*agg(l,1)
4723 c            ghalf2=0.5d0*agg(l,2)
4724 c            ghalf3=0.5d0*agg(l,3)
4725 c            ghalf4=0.5d0*agg(l,4)
4726           a_temp(1,1)=aggi(l,1)!+ghalf1
4727           a_temp(1,2)=aggi(l,2)!+ghalf2
4728           a_temp(2,1)=aggi(l,3)!+ghalf3
4729           a_temp(2,2)=aggi(l,4)!+ghalf4
4730           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4731           gcorr3_turn(l,i)=gcorr3_turn(l,i)
4732      &      +0.5d0*(pizda(1,1)+pizda(2,2))
4733      &   *fac_shield(i)*fac_shield(j)
4734
4735           a_temp(1,1)=aggi1(l,1)!+agg(l,1)
4736           a_temp(1,2)=aggi1(l,2)!+agg(l,2)
4737           a_temp(2,1)=aggi1(l,3)!+agg(l,3)
4738           a_temp(2,2)=aggi1(l,4)!+agg(l,4)
4739           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4740           gcorr3_turn(l,i+1)=gcorr3_turn(l,i+1)
4741      &      +0.5d0*(pizda(1,1)+pizda(2,2))
4742      &   *fac_shield(i)*fac_shield(j)
4743           a_temp(1,1)=aggj(l,1)!+ghalf1
4744           a_temp(1,2)=aggj(l,2)!+ghalf2
4745           a_temp(2,1)=aggj(l,3)!+ghalf3
4746           a_temp(2,2)=aggj(l,4)!+ghalf4
4747           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4748           gcorr3_turn(l,j)=gcorr3_turn(l,j)
4749      &      +0.5d0*(pizda(1,1)+pizda(2,2))
4750      &   *fac_shield(i)*fac_shield(j)
4751           a_temp(1,1)=aggj1(l,1)
4752           a_temp(1,2)=aggj1(l,2)
4753           a_temp(2,1)=aggj1(l,3)
4754           a_temp(2,2)=aggj1(l,4)
4755           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4756           gcorr3_turn(l,j1)=gcorr3_turn(l,j1)
4757      &      +0.5d0*(pizda(1,1)+pizda(2,2))
4758      &   *fac_shield(i)*fac_shield(j)
4759         enddo
4760       return
4761       end
4762 C-------------------------------------------------------------------------------
4763       subroutine eturn4(i,eello_turn4)
4764 C Third- and fourth-order contributions from turns
4765       implicit real*8 (a-h,o-z)
4766       include 'DIMENSIONS'
4767       include 'COMMON.IOUNITS'
4768       include 'COMMON.GEO'
4769       include 'COMMON.VAR'
4770       include 'COMMON.LOCAL'
4771       include 'COMMON.CHAIN'
4772       include 'COMMON.DERIV'
4773       include 'COMMON.INTERACT'
4774       include 'COMMON.CONTACTS'
4775       include 'COMMON.TORSION'
4776       include 'COMMON.VECTORS'
4777       include 'COMMON.FFIELD'
4778       include 'COMMON.CONTROL'
4779       include 'COMMON.SHIELD'
4780       dimension ggg(3)
4781       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
4782      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
4783      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2),auxgvec(2),
4784      &  auxgEvec1(2),auxgEvec2(2),auxgEvec3(2),
4785      &  gte1t(2,2),gte2t(2,2),gte3t(2,2),
4786      &  gte1a(2,2),gtae3(2,2),gtae3e2(2,2), ae3gte2(2,2),
4787      &  gtEpizda1(2,2),gtEpizda2(2,2),gtEpizda3(2,2)
4788       double precision agg(3,4),aggi(3,4),aggi1(3,4),
4789      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
4790       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
4791      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
4792      &    num_conti,j1,j2
4793       j=i+3
4794 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4795 C
4796 C               Fourth-order contributions
4797 C
4798 C                 (i+3)o----(i+4)
4799 C                     /  |
4800 C               (i+2)o   |
4801 C                     \  |
4802 C                 (i+1)o----i
4803 C
4804 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4805 cd        call checkint_turn4(i,a_temp,eello_turn4_num)
4806 c        write (iout,*) "eturn4 i",i," j",j," j1",j1," j2",j2
4807 c        write(iout,*)"WCHODZE W PROGRAM"
4808         a_temp(1,1)=a22
4809         a_temp(1,2)=a23
4810         a_temp(2,1)=a32
4811         a_temp(2,2)=a33
4812         iti1=itortyp(itype(i+1))
4813         iti2=itortyp(itype(i+2))
4814         iti3=itortyp(itype(i+3))
4815 c        write(iout,*) "iti1",iti1," iti2",iti2," iti3",iti3
4816         call transpose2(EUg(1,1,i+1),e1t(1,1))
4817         call transpose2(Eug(1,1,i+2),e2t(1,1))
4818         call transpose2(Eug(1,1,i+3),e3t(1,1))
4819 C Ematrix derivative in theta
4820         call transpose2(gtEUg(1,1,i+1),gte1t(1,1))
4821         call transpose2(gtEug(1,1,i+2),gte2t(1,1))
4822         call transpose2(gtEug(1,1,i+3),gte3t(1,1))
4823         call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4824 c       eta1 in derivative theta
4825         call matmat2(gte1t(1,1),a_temp(1,1),gte1a(1,1))
4826         call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4827 c       auxgvec is derivative of Ub2 so i+3 theta
4828         call matvec2(e1a(1,1),gUb2(1,i+3),auxgvec(1))
4829 c       auxalary matrix of E i+1
4830         call matvec2(gte1a(1,1),Ub2(1,i+3),auxgEvec1(1))
4831 c        s1=0.0
4832 c        gs1=0.0
4833         s1=scalar2(b1(1,i+2),auxvec(1))
4834 c derivative of theta i+2 with constant i+3
4835         gs23=scalar2(gtb1(1,i+2),auxvec(1))
4836 c derivative of theta i+2 with constant i+2
4837         gs32=scalar2(b1(1,i+2),auxgvec(1))
4838 c derivative of E matix in theta of i+1
4839         gsE13=scalar2(b1(1,i+2),auxgEvec1(1))
4840
4841         call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4842 c       ea31 in derivative theta
4843         call matmat2(a_temp(1,1),gte3t(1,1),gtae3(1,1))
4844         call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4845 c auxilary matrix auxgvec of Ub2 with constant E matirx
4846         call matvec2(ae3(1,1),gUb2(1,i+2),auxgvec(1))
4847 c auxilary matrix auxgEvec1 of E matix with Ub2 constant
4848         call matvec2(gtae3(1,1),Ub2(1,i+2),auxgEvec3(1))
4849
4850 c        s2=0.0
4851 c        gs2=0.0
4852         s2=scalar2(b1(1,i+1),auxvec(1))
4853 c derivative of theta i+1 with constant i+3
4854         gs13=scalar2(gtb1(1,i+1),auxvec(1))
4855 c derivative of theta i+2 with constant i+1
4856         gs21=scalar2(b1(1,i+1),auxgvec(1))
4857 c derivative of theta i+3 with constant i+1
4858         gsE31=scalar2(b1(1,i+1),auxgEvec3(1))
4859 c        write(iout,*) gs1,gs2,'i=',i,auxgvec(1),gUb2(1,i+2),gtb1(1,i+2),
4860 c     &  gtb1(1,i+1)
4861         call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4862 c two derivatives over diffetent matrices
4863 c gtae3e2 is derivative over i+3
4864         call matmat2(gtae3(1,1),e2t(1,1),gtae3e2(1,1))
4865 c ae3gte2 is derivative over i+2
4866         call matmat2(ae3(1,1),gte2t(1,1),ae3gte2(1,1))
4867         call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4868 c three possible derivative over theta E matices
4869 c i+1
4870         call matmat2(ae3e2(1,1),gte1t(1,1),gtEpizda1(1,1))
4871 c i+2
4872         call matmat2(ae3gte2(1,1),e1t(1,1),gtEpizda2(1,1))
4873 c i+3
4874         call matmat2(gtae3e2(1,1),e1t(1,1),gtEpizda3(1,1))
4875         s3=0.5d0*(pizda(1,1)+pizda(2,2))
4876
4877         gsEE1=0.5d0*(gtEpizda1(1,1)+gtEpizda1(2,2))
4878         gsEE2=0.5d0*(gtEpizda2(1,1)+gtEpizda2(2,2))
4879         gsEE3=0.5d0*(gtEpizda3(1,1)+gtEpizda3(2,2))
4880         if (shield_mode.eq.0) then
4881         fac_shield(i)=1.0
4882         fac_shield(j)=1.0
4883 C        else
4884 C        fac_shield(i)=0.6
4885 C        fac_shield(j)=0.4
4886         endif
4887         eello_turn4=eello_turn4-(s1+s2+s3)
4888      &  *fac_shield(i)*fac_shield(j)
4889         eello_t4=-(s1+s2+s3)
4890      &  *fac_shield(i)*fac_shield(j)
4891 c             write(iout,*)'chujOWO', auxvec(1),b1(1,iti2)
4892         if (energy_dec) write (iout,'(a6,2i5,0pf7.3,3f7.3)')
4893      &      'eturn4',i,j,-(s1+s2+s3),s1,s2,s3
4894 C Now derivative over shield:
4895           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
4896      &  (shield_mode.gt.0)) then
4897 C          print *,i,j
4898
4899           do ilist=1,ishield_list(i)
4900            iresshield=shield_list(ilist,i)
4901            do k=1,3
4902            rlocshield=grad_shield_side(k,ilist,i)*eello_t4/fac_shield(i)
4903 C     &      *2.0
4904            gshieldx_t4(k,iresshield)=gshieldx_t4(k,iresshield)+
4905      &              rlocshield
4906      & +grad_shield_loc(k,ilist,i)*eello_t4/fac_shield(i)
4907             gshieldc_t4(k,iresshield-1)=gshieldc_t4(k,iresshield-1)
4908      &      +rlocshield
4909            enddo
4910           enddo
4911           do ilist=1,ishield_list(j)
4912            iresshield=shield_list(ilist,j)
4913            do k=1,3
4914            rlocshield=grad_shield_side(k,ilist,j)*eello_t4/fac_shield(j)
4915 C     &     *2.0
4916            gshieldx_t4(k,iresshield)=gshieldx_t4(k,iresshield)+
4917      &              rlocshield
4918      & +grad_shield_loc(k,ilist,j)*eello_t4/fac_shield(j)
4919            gshieldc_t4(k,iresshield-1)=gshieldc_t4(k,iresshield-1)
4920      &             +rlocshield
4921
4922            enddo
4923           enddo
4924
4925           do k=1,3
4926             gshieldc_t4(k,i)=gshieldc_t4(k,i)+
4927      &              grad_shield(k,i)*eello_t4/fac_shield(i)
4928             gshieldc_t4(k,j)=gshieldc_t4(k,j)+
4929      &              grad_shield(k,j)*eello_t4/fac_shield(j)
4930             gshieldc_t4(k,i-1)=gshieldc_t4(k,i-1)+
4931      &              grad_shield(k,i)*eello_t4/fac_shield(i)
4932             gshieldc_t4(k,j-1)=gshieldc_t4(k,j-1)+
4933      &              grad_shield(k,j)*eello_t4/fac_shield(j)
4934            enddo
4935            endif
4936
4937
4938
4939
4940
4941
4942 cd        write (2,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
4943 cd     &    ' eello_turn4_num',8*eello_turn4_num
4944 #ifdef NEWCORR
4945         gloc(nphi+i,icg)=gloc(nphi+i,icg)
4946      &                  -(gs13+gsE13+gsEE1)*wturn4
4947      &  *fac_shield(i)*fac_shield(j)
4948         gloc(nphi+i+1,icg)= gloc(nphi+i+1,icg)
4949      &                    -(gs23+gs21+gsEE2)*wturn4
4950      &  *fac_shield(i)*fac_shield(j)
4951
4952         gloc(nphi+i+2,icg)= gloc(nphi+i+2,icg)
4953      &                    -(gs32+gsE31+gsEE3)*wturn4
4954      &  *fac_shield(i)*fac_shield(j)
4955
4956 c         gloc(nphi+i+1,icg)=gloc(nphi+i+1,icg)-
4957 c     &   gs2
4958 #endif
4959         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
4960      &      'eturn4',i,j,-(s1+s2+s3)
4961 c        write (iout,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
4962 c     &    ' eello_turn4_num',8*eello_turn4_num
4963 C Derivatives in gamma(i)
4964         call transpose2(EUgder(1,1,i+1),e1tder(1,1))
4965         call matmat2(e1tder(1,1),a_temp(1,1),auxmat(1,1))
4966         call matvec2(auxmat(1,1),Ub2(1,i+3),auxvec(1))
4967         s1=scalar2(b1(1,i+2),auxvec(1))
4968         call matmat2(ae3e2(1,1),e1tder(1,1),pizda(1,1))
4969         s3=0.5d0*(pizda(1,1)+pizda(2,2))
4970         gel_loc_turn4(i)=gel_loc_turn4(i)-(s1+s3)
4971      &  *fac_shield(i)*fac_shield(j)
4972 C Derivatives in gamma(i+1)
4973         call transpose2(EUgder(1,1,i+2),e2tder(1,1))
4974         call matvec2(ae3(1,1),Ub2der(1,i+2),auxvec(1))
4975         s2=scalar2(b1(1,i+1),auxvec(1))
4976         call matmat2(ae3(1,1),e2tder(1,1),auxmat(1,1))
4977         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
4978         s3=0.5d0*(pizda(1,1)+pizda(2,2))
4979         gel_loc_turn4(i+1)=gel_loc_turn4(i+1)-(s2+s3)
4980      &  *fac_shield(i)*fac_shield(j)
4981 C Derivatives in gamma(i+2)
4982         call transpose2(EUgder(1,1,i+3),e3tder(1,1))
4983         call matvec2(e1a(1,1),Ub2der(1,i+3),auxvec(1))
4984         s1=scalar2(b1(1,i+2),auxvec(1))
4985         call matmat2(a_temp(1,1),e3tder(1,1),auxmat(1,1))
4986         call matvec2(auxmat(1,1),Ub2(1,i+2),auxvec(1))
4987         s2=scalar2(b1(1,i+1),auxvec(1))
4988         call matmat2(auxmat(1,1),e2t(1,1),auxmat3(1,1))
4989         call matmat2(auxmat3(1,1),e1t(1,1),pizda(1,1))
4990         s3=0.5d0*(pizda(1,1)+pizda(2,2))
4991         gel_loc_turn4(i+2)=gel_loc_turn4(i+2)-(s1+s2+s3)
4992      &  *fac_shield(i)*fac_shield(j)
4993 C Cartesian derivatives
4994 C Derivatives of this turn contributions in DC(i+2)
4995         if (j.lt.nres-1) then
4996           do l=1,3
4997             a_temp(1,1)=agg(l,1)
4998             a_temp(1,2)=agg(l,2)
4999             a_temp(2,1)=agg(l,3)
5000             a_temp(2,2)=agg(l,4)
5001             call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5002             call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5003             s1=scalar2(b1(1,i+2),auxvec(1))
5004             call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5005             call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5006             s2=scalar2(b1(1,i+1),auxvec(1))
5007             call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5008             call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5009             s3=0.5d0*(pizda(1,1)+pizda(2,2))
5010             ggg(l)=-(s1+s2+s3)
5011             gcorr4_turn(l,i+2)=gcorr4_turn(l,i+2)-(s1+s2+s3)
5012      &  *fac_shield(i)*fac_shield(j)
5013           enddo
5014         endif
5015 C Remaining derivatives of this turn contribution
5016         do l=1,3
5017           a_temp(1,1)=aggi(l,1)
5018           a_temp(1,2)=aggi(l,2)
5019           a_temp(2,1)=aggi(l,3)
5020           a_temp(2,2)=aggi(l,4)
5021           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5022           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5023           s1=scalar2(b1(1,i+2),auxvec(1))
5024           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5025           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5026           s2=scalar2(b1(1,i+1),auxvec(1))
5027           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5028           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5029           s3=0.5d0*(pizda(1,1)+pizda(2,2))
5030           gcorr4_turn(l,i)=gcorr4_turn(l,i)-(s1+s2+s3)
5031      &  *fac_shield(i)*fac_shield(j)
5032           a_temp(1,1)=aggi1(l,1)
5033           a_temp(1,2)=aggi1(l,2)
5034           a_temp(2,1)=aggi1(l,3)
5035           a_temp(2,2)=aggi1(l,4)
5036           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5037           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5038           s1=scalar2(b1(1,i+2),auxvec(1))
5039           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5040           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5041           s2=scalar2(b1(1,i+1),auxvec(1))
5042           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5043           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5044           s3=0.5d0*(pizda(1,1)+pizda(2,2))
5045           gcorr4_turn(l,i+1)=gcorr4_turn(l,i+1)-(s1+s2+s3)
5046      &  *fac_shield(i)*fac_shield(j)
5047           a_temp(1,1)=aggj(l,1)
5048           a_temp(1,2)=aggj(l,2)
5049           a_temp(2,1)=aggj(l,3)
5050           a_temp(2,2)=aggj(l,4)
5051           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5052           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5053           s1=scalar2(b1(1,i+2),auxvec(1))
5054           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5055           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5056           s2=scalar2(b1(1,i+1),auxvec(1))
5057           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5058           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5059           s3=0.5d0*(pizda(1,1)+pizda(2,2))
5060           gcorr4_turn(l,j)=gcorr4_turn(l,j)-(s1+s2+s3)
5061      &  *fac_shield(i)*fac_shield(j)
5062           a_temp(1,1)=aggj1(l,1)
5063           a_temp(1,2)=aggj1(l,2)
5064           a_temp(2,1)=aggj1(l,3)
5065           a_temp(2,2)=aggj1(l,4)
5066           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5067           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5068           s1=scalar2(b1(1,i+2),auxvec(1))
5069           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5070           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5071           s2=scalar2(b1(1,i+1),auxvec(1))
5072           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5073           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5074           s3=0.5d0*(pizda(1,1)+pizda(2,2))
5075 c          write (iout,*) "s1",s1," s2",s2," s3",s3," s1+s2+s3",s1+s2+s3
5076           gcorr4_turn(l,j1)=gcorr4_turn(l,j1)-(s1+s2+s3)
5077      &  *fac_shield(i)*fac_shield(j)
5078         enddo
5079       return
5080       end
5081 C-----------------------------------------------------------------------------
5082       subroutine vecpr(u,v,w)
5083       implicit real*8(a-h,o-z)
5084       dimension u(3),v(3),w(3)
5085       w(1)=u(2)*v(3)-u(3)*v(2)
5086       w(2)=-u(1)*v(3)+u(3)*v(1)
5087       w(3)=u(1)*v(2)-u(2)*v(1)
5088       return
5089       end
5090 C-----------------------------------------------------------------------------
5091       subroutine unormderiv(u,ugrad,unorm,ungrad)
5092 C This subroutine computes the derivatives of a normalized vector u, given
5093 C the derivatives computed without normalization conditions, ugrad. Returns
5094 C ungrad.
5095       implicit none
5096       double precision u(3),ugrad(3,3),unorm,ungrad(3,3)
5097       double precision vec(3)
5098       double precision scalar
5099       integer i,j
5100 c      write (2,*) 'ugrad',ugrad
5101 c      write (2,*) 'u',u
5102       do i=1,3
5103         vec(i)=scalar(ugrad(1,i),u(1))
5104       enddo
5105 c      write (2,*) 'vec',vec
5106       do i=1,3
5107         do j=1,3
5108           ungrad(j,i)=(ugrad(j,i)-u(j)*vec(i))*unorm
5109         enddo
5110       enddo
5111 c      write (2,*) 'ungrad',ungrad
5112       return
5113       end
5114 C-----------------------------------------------------------------------------
5115       subroutine escp_soft_sphere(evdw2,evdw2_14)
5116 C
5117 C This subroutine calculates the excluded-volume interaction energy between
5118 C peptide-group centers and side chains and its gradient in virtual-bond and
5119 C side-chain vectors.
5120 C
5121       implicit real*8 (a-h,o-z)
5122       include 'DIMENSIONS'
5123       include 'COMMON.GEO'
5124       include 'COMMON.VAR'
5125       include 'COMMON.LOCAL'
5126       include 'COMMON.CHAIN'
5127       include 'COMMON.DERIV'
5128       include 'COMMON.INTERACT'
5129       include 'COMMON.FFIELD'
5130       include 'COMMON.IOUNITS'
5131       include 'COMMON.CONTROL'
5132       dimension ggg(3)
5133       evdw2=0.0D0
5134       evdw2_14=0.0d0
5135       r0_scp=4.5d0
5136 cd    print '(a)','Enter ESCP'
5137 cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
5138 C      do xshift=-1,1
5139 C      do yshift=-1,1
5140 C      do zshift=-1,1
5141       do i=iatscp_s,iatscp_e
5142         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
5143         iteli=itel(i)
5144         xi=0.5D0*(c(1,i)+c(1,i+1))
5145         yi=0.5D0*(c(2,i)+c(2,i+1))
5146         zi=0.5D0*(c(3,i)+c(3,i+1))
5147 C Return atom into box, boxxsize is size of box in x dimension
5148 c  134   continue
5149 c        if (xi.gt.((xshift+0.5d0)*boxxsize)) xi=xi-boxxsize
5150 c        if (xi.lt.((xshift-0.5d0)*boxxsize)) xi=xi+boxxsize
5151 C Condition for being inside the proper box
5152 c        if ((xi.gt.((xshift+0.5d0)*boxxsize)).or.
5153 c     &       (xi.lt.((xshift-0.5d0)*boxxsize))) then
5154 c        go to 134
5155 c        endif
5156 c  135   continue
5157 c        if (yi.gt.((yshift+0.5d0)*boxysize)) yi=yi-boxysize
5158 c        if (yi.lt.((yshift-0.5d0)*boxysize)) yi=yi+boxysize
5159 C Condition for being inside the proper box
5160 c        if ((yi.gt.((yshift+0.5d0)*boxysize)).or.
5161 c     &       (yi.lt.((yshift-0.5d0)*boxysize))) then
5162 c        go to 135
5163 c c       endif
5164 c  136   continue
5165 c        if (zi.gt.((zshift+0.5d0)*boxzsize)) zi=zi-boxzsize
5166 c        if (zi.lt.((zshift-0.5d0)*boxzsize)) zi=zi+boxzsize
5167 cC Condition for being inside the proper box
5168 c        if ((zi.gt.((zshift+0.5d0)*boxzsize)).or.
5169 c     &       (zi.lt.((zshift-0.5d0)*boxzsize))) then
5170 c        go to 136
5171 c        endif
5172           xi=mod(xi,boxxsize)
5173           if (xi.lt.0) xi=xi+boxxsize
5174           yi=mod(yi,boxysize)
5175           if (yi.lt.0) yi=yi+boxysize
5176           zi=mod(zi,boxzsize)
5177           if (zi.lt.0) zi=zi+boxzsize
5178 C          xi=xi+xshift*boxxsize
5179 C          yi=yi+yshift*boxysize
5180 C          zi=zi+zshift*boxzsize
5181         do iint=1,nscp_gr(i)
5182
5183         do j=iscpstart(i,iint),iscpend(i,iint)
5184           if (itype(j).eq.ntyp1) cycle
5185           itypj=iabs(itype(j))
5186 C Uncomment following three lines for SC-p interactions
5187 c         xj=c(1,nres+j)-xi
5188 c         yj=c(2,nres+j)-yi
5189 c         zj=c(3,nres+j)-zi
5190 C Uncomment following three lines for Ca-p interactions
5191           xj=c(1,j)
5192           yj=c(2,j)
5193           zj=c(3,j)
5194 c  174   continue
5195 c        if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
5196 c        if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
5197 C Condition for being inside the proper box
5198 c        if ((xj.gt.((0.5d0)*boxxsize)).or.
5199 c     &       (xj.lt.((-0.5d0)*boxxsize))) then
5200 c        go to 174
5201 c        endif
5202 c  175   continue
5203 c        if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
5204 c        if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
5205 cC Condition for being inside the proper box
5206 c        if ((yj.gt.((0.5d0)*boxysize)).or.
5207 c     &       (yj.lt.((-0.5d0)*boxysize))) then
5208 c        go to 175
5209 c        endif
5210 c  176   continue
5211 c        if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
5212 c        if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
5213 C Condition for being inside the proper box
5214 c        if ((zj.gt.((0.5d0)*boxzsize)).or.
5215 c     &       (zj.lt.((-0.5d0)*boxzsize))) then
5216 c        go to 176
5217           xj=mod(xj,boxxsize)
5218           if (xj.lt.0) xj=xj+boxxsize
5219           yj=mod(yj,boxysize)
5220           if (yj.lt.0) yj=yj+boxysize
5221           zj=mod(zj,boxzsize)
5222           if (zj.lt.0) zj=zj+boxzsize
5223       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
5224       xj_safe=xj
5225       yj_safe=yj
5226       zj_safe=zj
5227       subchap=0
5228       do xshift=-1,1
5229       do yshift=-1,1
5230       do zshift=-1,1
5231           xj=xj_safe+xshift*boxxsize
5232           yj=yj_safe+yshift*boxysize
5233           zj=zj_safe+zshift*boxzsize
5234           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
5235           if(dist_temp.lt.dist_init) then
5236             dist_init=dist_temp
5237             xj_temp=xj
5238             yj_temp=yj
5239             zj_temp=zj
5240             subchap=1
5241           endif
5242        enddo
5243        enddo
5244        enddo
5245        if (subchap.eq.1) then
5246           xj=xj_temp-xi
5247           yj=yj_temp-yi
5248           zj=zj_temp-zi
5249        else
5250           xj=xj_safe-xi
5251           yj=yj_safe-yi
5252           zj=zj_safe-zi
5253        endif
5254 c c       endif
5255 C          xj=xj-xi
5256 C          yj=yj-yi
5257 C          zj=zj-zi
5258           rij=xj*xj+yj*yj+zj*zj
5259
5260           r0ij=r0_scp
5261           r0ijsq=r0ij*r0ij
5262           if (rij.lt.r0ijsq) then
5263             evdwij=0.25d0*(rij-r0ijsq)**2
5264             fac=rij-r0ijsq
5265           else
5266             evdwij=0.0d0
5267             fac=0.0d0
5268           endif
5269           evdw2=evdw2+evdwij
5270 C
5271 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
5272 C
5273           ggg(1)=xj*fac
5274           ggg(2)=yj*fac
5275           ggg(3)=zj*fac
5276 cgrad          if (j.lt.i) then
5277 cd          write (iout,*) 'j<i'
5278 C Uncomment following three lines for SC-p interactions
5279 c           do k=1,3
5280 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
5281 c           enddo
5282 cgrad          else
5283 cd          write (iout,*) 'j>i'
5284 cgrad            do k=1,3
5285 cgrad              ggg(k)=-ggg(k)
5286 C Uncomment following line for SC-p interactions
5287 c             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
5288 cgrad            enddo
5289 cgrad          endif
5290 cgrad          do k=1,3
5291 cgrad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
5292 cgrad          enddo
5293 cgrad          kstart=min0(i+1,j)
5294 cgrad          kend=max0(i-1,j-1)
5295 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
5296 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
5297 cgrad          do k=kstart,kend
5298 cgrad            do l=1,3
5299 cgrad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
5300 cgrad            enddo
5301 cgrad          enddo
5302           do k=1,3
5303             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
5304             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
5305           enddo
5306         enddo
5307
5308         enddo ! iint
5309       enddo ! i
5310 C      enddo !zshift
5311 C      enddo !yshift
5312 C      enddo !xshift
5313       return
5314       end
5315 C-----------------------------------------------------------------------------
5316       subroutine escp(evdw2,evdw2_14)
5317 C
5318 C This subroutine calculates the excluded-volume interaction energy between
5319 C peptide-group centers and side chains and its gradient in virtual-bond and
5320 C side-chain vectors.
5321 C
5322       implicit real*8 (a-h,o-z)
5323       include 'DIMENSIONS'
5324       include 'COMMON.GEO'
5325       include 'COMMON.VAR'
5326       include 'COMMON.LOCAL'
5327       include 'COMMON.CHAIN'
5328       include 'COMMON.DERIV'
5329       include 'COMMON.INTERACT'
5330       include 'COMMON.FFIELD'
5331       include 'COMMON.IOUNITS'
5332       include 'COMMON.CONTROL'
5333       include 'COMMON.SPLITELE'
5334       dimension ggg(3)
5335       evdw2=0.0D0
5336       evdw2_14=0.0d0
5337 c        print *,boxxsize,boxysize,boxzsize,'wymiary pudla'
5338 cd    print '(a)','Enter ESCP'
5339 cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
5340 C      do xshift=-1,1
5341 C      do yshift=-1,1
5342 C      do zshift=-1,1
5343       do i=iatscp_s,iatscp_e
5344         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
5345         iteli=itel(i)
5346         xi=0.5D0*(c(1,i)+c(1,i+1))
5347         yi=0.5D0*(c(2,i)+c(2,i+1))
5348         zi=0.5D0*(c(3,i)+c(3,i+1))
5349           xi=mod(xi,boxxsize)
5350           if (xi.lt.0) xi=xi+boxxsize
5351           yi=mod(yi,boxysize)
5352           if (yi.lt.0) yi=yi+boxysize
5353           zi=mod(zi,boxzsize)
5354           if (zi.lt.0) zi=zi+boxzsize
5355 c          xi=xi+xshift*boxxsize
5356 c          yi=yi+yshift*boxysize
5357 c          zi=zi+zshift*boxzsize
5358 c        print *,xi,yi,zi,'polozenie i'
5359 C Return atom into box, boxxsize is size of box in x dimension
5360 c  134   continue
5361 c        if (xi.gt.((xshift+0.5d0)*boxxsize)) xi=xi-boxxsize
5362 c        if (xi.lt.((xshift-0.5d0)*boxxsize)) xi=xi+boxxsize
5363 C Condition for being inside the proper box
5364 c        if ((xi.gt.((xshift+0.5d0)*boxxsize)).or.
5365 c     &       (xi.lt.((xshift-0.5d0)*boxxsize))) then
5366 c        go to 134
5367 c        endif
5368 c  135   continue
5369 c          print *,xi,boxxsize,"pierwszy"
5370
5371 c        if (yi.gt.((yshift+0.5d0)*boxysize)) yi=yi-boxysize
5372 c        if (yi.lt.((yshift-0.5d0)*boxysize)) yi=yi+boxysize
5373 C Condition for being inside the proper box
5374 c        if ((yi.gt.((yshift+0.5d0)*boxysize)).or.
5375 c     &       (yi.lt.((yshift-0.5d0)*boxysize))) then
5376 c        go to 135
5377 c        endif
5378 c  136   continue
5379 c        if (zi.gt.((zshift+0.5d0)*boxzsize)) zi=zi-boxzsize
5380 c        if (zi.lt.((zshift-0.5d0)*boxzsize)) zi=zi+boxzsize
5381 C Condition for being inside the proper box
5382 c        if ((zi.gt.((zshift+0.5d0)*boxzsize)).or.
5383 c     &       (zi.lt.((zshift-0.5d0)*boxzsize))) then
5384 c        go to 136
5385 c        endif
5386         do iint=1,nscp_gr(i)
5387
5388         do j=iscpstart(i,iint),iscpend(i,iint)
5389           itypj=iabs(itype(j))
5390           if (itypj.eq.ntyp1) cycle
5391 C Uncomment following three lines for SC-p interactions
5392 c         xj=c(1,nres+j)-xi
5393 c         yj=c(2,nres+j)-yi
5394 c         zj=c(3,nres+j)-zi
5395 C Uncomment following three lines for Ca-p interactions
5396           xj=c(1,j)
5397           yj=c(2,j)
5398           zj=c(3,j)
5399           xj=mod(xj,boxxsize)
5400           if (xj.lt.0) xj=xj+boxxsize
5401           yj=mod(yj,boxysize)
5402           if (yj.lt.0) yj=yj+boxysize
5403           zj=mod(zj,boxzsize)
5404           if (zj.lt.0) zj=zj+boxzsize
5405 c  174   continue
5406 c        if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
5407 c        if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
5408 C Condition for being inside the proper box
5409 c        if ((xj.gt.((0.5d0)*boxxsize)).or.
5410 c     &       (xj.lt.((-0.5d0)*boxxsize))) then
5411 c        go to 174
5412 c        endif
5413 c  175   continue
5414 c        if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
5415 c        if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
5416 cC Condition for being inside the proper box
5417 c        if ((yj.gt.((0.5d0)*boxysize)).or.
5418 c     &       (yj.lt.((-0.5d0)*boxysize))) then
5419 c        go to 175
5420 c        endif
5421 c  176   continue
5422 c        if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
5423 c        if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
5424 C Condition for being inside the proper box
5425 c        if ((zj.gt.((0.5d0)*boxzsize)).or.
5426 c     &       (zj.lt.((-0.5d0)*boxzsize))) then
5427 c        go to 176
5428 c        endif
5429 CHERE IS THE CALCULATION WHICH MIRROR IMAGE IS THE CLOSEST ONE
5430       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
5431       xj_safe=xj
5432       yj_safe=yj
5433       zj_safe=zj
5434       subchap=0
5435       do xshift=-1,1
5436       do yshift=-1,1
5437       do zshift=-1,1
5438           xj=xj_safe+xshift*boxxsize
5439           yj=yj_safe+yshift*boxysize
5440           zj=zj_safe+zshift*boxzsize
5441           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
5442           if(dist_temp.lt.dist_init) then
5443             dist_init=dist_temp
5444             xj_temp=xj
5445             yj_temp=yj
5446             zj_temp=zj
5447             subchap=1
5448           endif
5449        enddo
5450        enddo
5451        enddo
5452        if (subchap.eq.1) then
5453           xj=xj_temp-xi
5454           yj=yj_temp-yi
5455           zj=zj_temp-zi
5456        else
5457           xj=xj_safe-xi
5458           yj=yj_safe-yi
5459           zj=zj_safe-zi
5460        endif
5461 c          print *,xj,yj,zj,'polozenie j'
5462           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
5463 c          print *,rrij
5464           sss=sscale(1.0d0/(dsqrt(rrij)))
5465 c          print *,r_cut,1.0d0/dsqrt(rrij),sss,'tu patrz'
5466 c          if (sss.eq.0) print *,'czasem jest OK'
5467           if (sss.le.0.0d0) cycle
5468           sssgrad=sscagrad(1.0d0/(dsqrt(rrij)))
5469           fac=rrij**expon2
5470           e1=fac*fac*aad(itypj,iteli)
5471           e2=fac*bad(itypj,iteli)
5472           if (iabs(j-i) .le. 2) then
5473             e1=scal14*e1
5474             e2=scal14*e2
5475             evdw2_14=evdw2_14+(e1+e2)*sss
5476           endif
5477           evdwij=e1+e2
5478           evdw2=evdw2+evdwij*sss
5479           if (energy_dec) write (iout,'(a6,2i5,0pf7.3,2i3,3e11.3)')
5480      &        'evdw2',i,j,evdwij,iteli,itypj,fac,aad(itypj,iteli),
5481      &       bad(itypj,iteli)
5482 C
5483 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
5484 C
5485           fac=-(evdwij+e1)*rrij*sss
5486           fac=fac+(evdwij)*sssgrad*dsqrt(rrij)/expon
5487           ggg(1)=xj*fac
5488           ggg(2)=yj*fac
5489           ggg(3)=zj*fac
5490 cgrad          if (j.lt.i) then
5491 cd          write (iout,*) 'j<i'
5492 C Uncomment following three lines for SC-p interactions
5493 c           do k=1,3
5494 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
5495 c           enddo
5496 cgrad          else
5497 cd          write (iout,*) 'j>i'
5498 cgrad            do k=1,3
5499 cgrad              ggg(k)=-ggg(k)
5500 C Uncomment following line for SC-p interactions
5501 ccgrad             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
5502 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
5503 cgrad            enddo
5504 cgrad          endif
5505 cgrad          do k=1,3
5506 cgrad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
5507 cgrad          enddo
5508 cgrad          kstart=min0(i+1,j)
5509 cgrad          kend=max0(i-1,j-1)
5510 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
5511 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
5512 cgrad          do k=kstart,kend
5513 cgrad            do l=1,3
5514 cgrad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
5515 cgrad            enddo
5516 cgrad          enddo
5517           do k=1,3
5518             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
5519             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
5520           enddo
5521 c        endif !endif for sscale cutoff
5522         enddo ! j
5523
5524         enddo ! iint
5525       enddo ! i
5526 c      enddo !zshift
5527 c      enddo !yshift
5528 c      enddo !xshift
5529       do i=1,nct
5530         do j=1,3
5531           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
5532           gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
5533           gradx_scp(j,i)=expon*gradx_scp(j,i)
5534         enddo
5535       enddo
5536 C******************************************************************************
5537 C
5538 C                              N O T E !!!
5539 C
5540 C To save time the factor EXPON has been extracted from ALL components
5541 C of GVDWC and GRADX. Remember to multiply them by this factor before further
5542 C use!
5543 C
5544 C******************************************************************************
5545       return
5546       end
5547 C--------------------------------------------------------------------------
5548       subroutine edis(ehpb)
5549 C
5550 C Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors.
5551 C
5552       implicit real*8 (a-h,o-z)
5553       include 'DIMENSIONS'
5554       include 'COMMON.SBRIDGE'
5555       include 'COMMON.CHAIN'
5556       include 'COMMON.DERIV'
5557       include 'COMMON.VAR'
5558       include 'COMMON.INTERACT'
5559       include 'COMMON.IOUNITS'
5560       include 'COMMON.CONTROL'
5561       dimension ggg(3)
5562       ehpb=0.0D0
5563       do i=1,3
5564        ggg(i)=0.0d0
5565       enddo
5566 C      write (iout,*) ,"link_end",link_end,constr_dist
5567 cd      write(iout,*)'edis: nhpb=',nhpb,' fbr=',fbr
5568 cd      write(iout,*)'link_start=',link_start,' link_end=',link_end
5569       if (link_end.eq.0) return
5570       do i=link_start,link_end
5571 C If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a
5572 C CA-CA distance used in regularization of structure.
5573         ii=ihpb(i)
5574         jj=jhpb(i)
5575 C iii and jjj point to the residues for which the distance is assigned.
5576         if (ii.gt.nres) then
5577           iii=ii-nres
5578           jjj=jj-nres
5579         else
5580           iii=ii
5581           jjj=jj
5582         endif
5583 c        write (iout,*) "i",i," ii",ii," iii",iii," jj",jj," jjj",jjj,
5584 c     &    dhpb(i),dhpb1(i),forcon(i)
5585 C 24/11/03 AL: SS bridges handled separately because of introducing a specific
5586 C    distance and angle dependent SS bond potential.
5587 C        if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and.
5588 C     & iabs(itype(jjj)).eq.1) then
5589 cmc        if (ii.gt.nres .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then
5590 C 18/07/06 MC: Use the convention that the first nss pairs are SS bonds
5591         if (.not.dyn_ss .and. i.le.nss) then
5592 C 15/02/13 CC dynamic SSbond - additional check
5593          if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and.
5594      & iabs(itype(jjj)).eq.1) then
5595           call ssbond_ene(iii,jjj,eij)
5596           ehpb=ehpb+2*eij
5597          endif
5598 cd          write (iout,*) "eij",eij
5599 cd   &   ' waga=',waga,' fac=',fac
5600         else if (ii.gt.nres .and. jj.gt.nres) then
5601 c Restraints from contact prediction
5602           dd=dist(ii,jj)
5603           if (constr_dist.eq.11) then
5604             ehpb=ehpb+fordepth(i)**4.0d0
5605      &          *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i))
5606             fac=fordepth(i)**4.0d0
5607      &          *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd
5608           if (energy_dec) write (iout,'(a6,2i5,3f8.3)') "edisl",ii,jj,
5609      &    ehpb,fordepth(i),dd
5610            else
5611           if (dhpb1(i).gt.0.0d0) then
5612             ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
5613             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
5614 c            write (iout,*) "beta nmr",
5615 c     &        dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
5616           else
5617             dd=dist(ii,jj)
5618             rdis=dd-dhpb(i)
5619 C Get the force constant corresponding to this distance.
5620             waga=forcon(i)
5621 C Calculate the contribution to energy.
5622             ehpb=ehpb+waga*rdis*rdis
5623 c            write (iout,*) "beta reg",dd,waga*rdis*rdis
5624 C
5625 C Evaluate gradient.
5626 C
5627             fac=waga*rdis/dd
5628           endif
5629           endif
5630           do j=1,3
5631             ggg(j)=fac*(c(j,jj)-c(j,ii))
5632           enddo
5633           do j=1,3
5634             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
5635             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
5636           enddo
5637           do k=1,3
5638             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
5639             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
5640           enddo
5641         else
5642 C Calculate the distance between the two points and its difference from the
5643 C target distance.
5644           dd=dist(ii,jj)
5645           if (constr_dist.eq.11) then
5646             ehpb=ehpb+fordepth(i)**4.0d0
5647      &           *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i))
5648             fac=fordepth(i)**4.0d0
5649      &           *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd
5650           if (energy_dec) write (iout,'(a6,2i5,3f8.3)') "edisl",ii,jj,
5651      &    ehpb,fordepth(i),dd
5652            else
5653           if (dhpb1(i).gt.0.0d0) then
5654             ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
5655             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
5656 c            write (iout,*) "alph nmr",
5657 c     &        dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
5658           else
5659             rdis=dd-dhpb(i)
5660 C Get the force constant corresponding to this distance.
5661             waga=forcon(i)
5662 C Calculate the contribution to energy.
5663             ehpb=ehpb+waga*rdis*rdis
5664 c            write (iout,*) "alpha reg",dd,waga*rdis*rdis
5665 C
5666 C Evaluate gradient.
5667 C
5668             fac=waga*rdis/dd
5669           endif
5670           endif
5671             do j=1,3
5672               ggg(j)=fac*(c(j,jj)-c(j,ii))
5673             enddo
5674 cd      print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
5675 C If this is a SC-SC distance, we need to calculate the contributions to the
5676 C Cartesian gradient in the SC vectors (ghpbx).
5677           if (iii.lt.ii) then
5678           do j=1,3
5679             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
5680             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
5681           enddo
5682           endif
5683 cgrad        do j=iii,jjj-1
5684 cgrad          do k=1,3
5685 cgrad            ghpbc(k,j)=ghpbc(k,j)+ggg(k)
5686 cgrad          enddo
5687 cgrad        enddo
5688           do k=1,3
5689             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
5690             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
5691           enddo
5692         endif
5693       enddo
5694       if (constr_dist.ne.11) ehpb=0.5D0*ehpb
5695       return
5696       end
5697 C--------------------------------------------------------------------------
5698       subroutine ssbond_ene(i,j,eij)
5699 C
5700 C Calculate the distance and angle dependent SS-bond potential energy
5701 C using a free-energy function derived based on RHF/6-31G** ab initio
5702 C calculations of diethyl disulfide.
5703 C
5704 C A. Liwo and U. Kozlowska, 11/24/03
5705 C
5706       implicit real*8 (a-h,o-z)
5707       include 'DIMENSIONS'
5708       include 'COMMON.SBRIDGE'
5709       include 'COMMON.CHAIN'
5710       include 'COMMON.DERIV'
5711       include 'COMMON.LOCAL'
5712       include 'COMMON.INTERACT'
5713       include 'COMMON.VAR'
5714       include 'COMMON.IOUNITS'
5715       double precision erij(3),dcosom1(3),dcosom2(3),gg(3)
5716       itypi=iabs(itype(i))
5717       xi=c(1,nres+i)
5718       yi=c(2,nres+i)
5719       zi=c(3,nres+i)
5720       dxi=dc_norm(1,nres+i)
5721       dyi=dc_norm(2,nres+i)
5722       dzi=dc_norm(3,nres+i)
5723 c      dsci_inv=dsc_inv(itypi)
5724       dsci_inv=vbld_inv(nres+i)
5725       itypj=iabs(itype(j))
5726 c      dscj_inv=dsc_inv(itypj)
5727       dscj_inv=vbld_inv(nres+j)
5728       xj=c(1,nres+j)-xi
5729       yj=c(2,nres+j)-yi
5730       zj=c(3,nres+j)-zi
5731       dxj=dc_norm(1,nres+j)
5732       dyj=dc_norm(2,nres+j)
5733       dzj=dc_norm(3,nres+j)
5734       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
5735       rij=dsqrt(rrij)
5736       erij(1)=xj*rij
5737       erij(2)=yj*rij
5738       erij(3)=zj*rij
5739       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
5740       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
5741       om12=dxi*dxj+dyi*dyj+dzi*dzj
5742       do k=1,3
5743         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
5744         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
5745       enddo
5746       rij=1.0d0/rij
5747       deltad=rij-d0cm
5748       deltat1=1.0d0-om1
5749       deltat2=1.0d0+om2
5750       deltat12=om2-om1+2.0d0
5751       cosphi=om12-om1*om2
5752       eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2)
5753      &  +akct*deltad*deltat12
5754      &  +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi+ebr
5755 c      write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth,
5756 c     &  " akct",akct," deltad",deltad," deltat",deltat1,deltat2,
5757 c     &  " deltat12",deltat12," eij",eij
5758       ed=2*akcm*deltad+akct*deltat12
5759       pom1=akct*deltad
5760       pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
5761       eom1=-2*akth*deltat1-pom1-om2*pom2
5762       eom2= 2*akth*deltat2+pom1-om1*pom2
5763       eom12=pom2
5764       do k=1,3
5765         ggk=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
5766         ghpbx(k,i)=ghpbx(k,i)-ggk
5767      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
5768      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
5769         ghpbx(k,j)=ghpbx(k,j)+ggk
5770      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
5771      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
5772         ghpbc(k,i)=ghpbc(k,i)-ggk
5773         ghpbc(k,j)=ghpbc(k,j)+ggk
5774       enddo
5775 C
5776 C Calculate the components of the gradient in DC and X
5777 C
5778 cgrad      do k=i,j-1
5779 cgrad        do l=1,3
5780 cgrad          ghpbc(l,k)=ghpbc(l,k)+gg(l)
5781 cgrad        enddo
5782 cgrad      enddo
5783       return
5784       end
5785 C--------------------------------------------------------------------------
5786       subroutine ebond(estr)
5787 c
5788 c Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
5789 c
5790       implicit real*8 (a-h,o-z)
5791       include 'DIMENSIONS'
5792       include 'COMMON.LOCAL'
5793       include 'COMMON.GEO'
5794       include 'COMMON.INTERACT'
5795       include 'COMMON.DERIV'
5796       include 'COMMON.VAR'
5797       include 'COMMON.CHAIN'
5798       include 'COMMON.IOUNITS'
5799       include 'COMMON.NAMES'
5800       include 'COMMON.FFIELD'
5801       include 'COMMON.CONTROL'
5802       include 'COMMON.SETUP'
5803       double precision u(3),ud(3)
5804       estr=0.0d0
5805       estr1=0.0d0
5806       do i=ibondp_start,ibondp_end
5807         if (itype(i-1).eq.ntyp1 .and. itype(i).eq.ntyp1) cycle
5808 c          estr1=estr1+gnmr1(vbld(i),-1.0d0,distchainmax)
5809 c          do j=1,3
5810 c          gradb(j,i-1)=gnmr1prim(vbld(i),-1.0d0,distchainmax)
5811 c     &      *dc(j,i-1)/vbld(i)
5812 c          enddo
5813 c          if (energy_dec) write(iout,*)
5814 c     &       "estr1",i,gnmr1(vbld(i),-1.0d0,distchainmax)
5815 c        else
5816 C       Checking if it involves dummy (NH3+ or COO-) group
5817          if (itype(i-1).eq.ntyp1 .or. itype(i).eq.ntyp1) then
5818 C YES   vbldpDUM is the equlibrium length of spring for Dummy atom
5819         diff = vbld(i)-vbldpDUM
5820          else
5821 C NO    vbldp0 is the equlibrium lenght of spring for peptide group
5822         diff = vbld(i)-vbldp0
5823          endif
5824         if (energy_dec)    write (iout,'(a7,i5,4f7.3)')
5825      &     "estr bb",i,vbld(i),vbldp0,diff,AKP*diff*diff
5826         estr=estr+diff*diff
5827         do j=1,3
5828           gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)
5829         enddo
5830 c        write (iout,'(i5,3f10.5)') i,(gradb(j,i-1),j=1,3)
5831 c        endif
5832       enddo
5833       estr=0.5d0*AKP*estr+estr1
5834 c
5835 c 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included
5836 c
5837       do i=ibond_start,ibond_end
5838         iti=iabs(itype(i))
5839         if (iti.ne.10 .and. iti.ne.ntyp1) then
5840           nbi=nbondterm(iti)
5841           if (nbi.eq.1) then
5842             diff=vbld(i+nres)-vbldsc0(1,iti)
5843             if (energy_dec)  write (iout,*)
5844      &      "estr sc",i,iti,vbld(i+nres),vbldsc0(1,iti),diff,
5845      &      AKSC(1,iti),AKSC(1,iti)*diff*diff
5846             estr=estr+0.5d0*AKSC(1,iti)*diff*diff
5847             do j=1,3
5848               gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
5849             enddo
5850           else
5851             do j=1,nbi
5852               diff=vbld(i+nres)-vbldsc0(j,iti)
5853               ud(j)=aksc(j,iti)*diff
5854               u(j)=abond0(j,iti)+0.5d0*ud(j)*diff
5855             enddo
5856             uprod=u(1)
5857             do j=2,nbi
5858               uprod=uprod*u(j)
5859             enddo
5860             usum=0.0d0
5861             usumsqder=0.0d0
5862             do j=1,nbi
5863               uprod1=1.0d0
5864               uprod2=1.0d0
5865               do k=1,nbi
5866                 if (k.ne.j) then
5867                   uprod1=uprod1*u(k)
5868                   uprod2=uprod2*u(k)*u(k)
5869                 endif
5870               enddo
5871               usum=usum+uprod1
5872               usumsqder=usumsqder+ud(j)*uprod2
5873             enddo
5874             estr=estr+uprod/usum
5875             do j=1,3
5876              gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
5877             enddo
5878           endif
5879         endif
5880       enddo
5881       return
5882       end
5883 #ifdef CRYST_THETA
5884 C--------------------------------------------------------------------------
5885       subroutine ebend(etheta,ethetacnstr)
5886 C
5887 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
5888 C angles gamma and its derivatives in consecutive thetas and gammas.
5889 C
5890       implicit real*8 (a-h,o-z)
5891       include 'DIMENSIONS'
5892       include 'COMMON.LOCAL'
5893       include 'COMMON.GEO'
5894       include 'COMMON.INTERACT'
5895       include 'COMMON.DERIV'
5896       include 'COMMON.VAR'
5897       include 'COMMON.CHAIN'
5898       include 'COMMON.IOUNITS'
5899       include 'COMMON.NAMES'
5900       include 'COMMON.FFIELD'
5901       include 'COMMON.CONTROL'
5902       include 'COMMON.TORCNSTR'
5903       common /calcthet/ term1,term2,termm,diffak,ratak,
5904      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
5905      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
5906       double precision y(2),z(2)
5907       delta=0.02d0*pi
5908 c      time11=dexp(-2*time)
5909 c      time12=1.0d0
5910       etheta=0.0D0
5911 c     write (*,'(a,i2)') 'EBEND ICG=',icg
5912       do i=ithet_start,ithet_end
5913         if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
5914      &  .or.itype(i).eq.ntyp1) cycle
5915 C Zero the energy function and its derivative at 0 or pi.
5916         call splinthet(theta(i),0.5d0*delta,ss,ssd)
5917         it=itype(i-1)
5918         ichir1=isign(1,itype(i-2))
5919         ichir2=isign(1,itype(i))
5920          if (itype(i-2).eq.10) ichir1=isign(1,itype(i-1))
5921          if (itype(i).eq.10) ichir2=isign(1,itype(i-1))
5922          if (itype(i-1).eq.10) then
5923           itype1=isign(10,itype(i-2))
5924           ichir11=isign(1,itype(i-2))
5925           ichir12=isign(1,itype(i-2))
5926           itype2=isign(10,itype(i))
5927           ichir21=isign(1,itype(i))
5928           ichir22=isign(1,itype(i))
5929          endif
5930
5931         if (i.gt.3 .and. itype(i-3).ne.ntyp1) then
5932 #ifdef OSF
5933           phii=phi(i)
5934           if (phii.ne.phii) phii=150.0
5935 #else
5936           phii=phi(i)
5937 #endif
5938           y(1)=dcos(phii)
5939           y(2)=dsin(phii)
5940         else
5941           y(1)=0.0D0
5942           y(2)=0.0D0
5943         endif
5944         if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
5945 #ifdef OSF
5946           phii1=phi(i+1)
5947           if (phii1.ne.phii1) phii1=150.0
5948           phii1=pinorm(phii1)
5949           z(1)=cos(phii1)
5950 #else
5951           phii1=phi(i+1)
5952 #endif
5953           z(1)=dcos(phii1)
5954           z(2)=dsin(phii1)
5955         else
5956           z(1)=0.0D0
5957           z(2)=0.0D0
5958         endif
5959 C Calculate the "mean" value of theta from the part of the distribution
5960 C dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2).
5961 C In following comments this theta will be referred to as t_c.
5962         thet_pred_mean=0.0d0
5963         do k=1,2
5964             athetk=athet(k,it,ichir1,ichir2)
5965             bthetk=bthet(k,it,ichir1,ichir2)
5966           if (it.eq.10) then
5967              athetk=athet(k,itype1,ichir11,ichir12)
5968              bthetk=bthet(k,itype2,ichir21,ichir22)
5969           endif
5970          thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k)
5971 c         write(iout,*) 'chuj tu', y(k),z(k)
5972         enddo
5973         dthett=thet_pred_mean*ssd
5974         thet_pred_mean=thet_pred_mean*ss+a0thet(it)
5975 C Derivatives of the "mean" values in gamma1 and gamma2.
5976         dthetg1=(-athet(1,it,ichir1,ichir2)*y(2)
5977      &+athet(2,it,ichir1,ichir2)*y(1))*ss
5978          dthetg2=(-bthet(1,it,ichir1,ichir2)*z(2)
5979      &          +bthet(2,it,ichir1,ichir2)*z(1))*ss
5980          if (it.eq.10) then
5981       dthetg1=(-athet(1,itype1,ichir11,ichir12)*y(2)
5982      &+athet(2,itype1,ichir11,ichir12)*y(1))*ss
5983         dthetg2=(-bthet(1,itype2,ichir21,ichir22)*z(2)
5984      &         +bthet(2,itype2,ichir21,ichir22)*z(1))*ss
5985          endif
5986         if (theta(i).gt.pi-delta) then
5987           call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,
5988      &         E_tc0)
5989           call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0)
5990           call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
5991           call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,
5992      &        E_theta)
5993           call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,
5994      &        E_tc)
5995         else if (theta(i).lt.delta) then
5996           call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0)
5997           call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
5998           call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,
5999      &        E_theta)
6000           call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0)
6001           call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,
6002      &        E_tc)
6003         else
6004           call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,
6005      &        E_theta,E_tc)
6006         endif
6007         etheta=etheta+ethetai
6008         if (energy_dec) write (iout,'(a6,i5,0pf7.3,f7.3,i5)')
6009      &      'ebend',i,ethetai,theta(i),itype(i)
6010         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1
6011         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2
6012         gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)+gloc(nphi+i-2,icg)
6013       enddo
6014       ethetacnstr=0.0d0
6015 C      print *,ithetaconstr_start,ithetaconstr_end,"TU"
6016       do i=ithetaconstr_start,ithetaconstr_end
6017         itheta=itheta_constr(i)
6018         thetiii=theta(itheta)
6019         difi=pinorm(thetiii-theta_constr0(i))
6020         if (difi.gt.theta_drange(i)) then
6021           difi=difi-theta_drange(i)
6022           ethetacnstr=ethetcnstr+0.25d0*for_thet_constr(i)*difi**4
6023           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
6024      &    +for_thet_constr(i)*difi**3
6025         else if (difi.lt.-drange(i)) then
6026           difi=difi+drange(i)
6027           ethetacnstr=ethetcnstr+0.25d0*for_thet_constr(i)*difi**4
6028           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
6029      &    +for_thet_constr(i)*difi**3
6030         else
6031           difi=0.0
6032         endif
6033        if (energy_dec) then
6034         write (iout,'(a6,2i5,4f8.3,2e14.5)') "ethetc",
6035      &    i,itheta,rad2deg*thetiii,
6036      &    rad2deg*theta_constr0(i),  rad2deg*theta_drange(i),
6037      &    rad2deg*difi,0.25d0*for_thet_constr(i)*difi**4,
6038      &    gloc(itheta+nphi-2,icg)
6039         endif
6040       enddo
6041
6042 C Ufff.... We've done all this!!!
6043       return
6044       end
6045 C---------------------------------------------------------------------------
6046       subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,
6047      &     E_tc)
6048       implicit real*8 (a-h,o-z)
6049       include 'DIMENSIONS'
6050       include 'COMMON.LOCAL'
6051       include 'COMMON.IOUNITS'
6052       common /calcthet/ term1,term2,termm,diffak,ratak,
6053      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
6054      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
6055 C Calculate the contributions to both Gaussian lobes.
6056 C 6/6/97 - Deform the Gaussians using the factor of 1/(1+time)
6057 C The "polynomial part" of the "standard deviation" of this part of
6058 C the distributioni.
6059 ccc        write (iout,*) thetai,thet_pred_mean
6060         sig=polthet(3,it)
6061         do j=2,0,-1
6062           sig=sig*thet_pred_mean+polthet(j,it)
6063         enddo
6064 C Derivative of the "interior part" of the "standard deviation of the"
6065 C gamma-dependent Gaussian lobe in t_c.
6066         sigtc=3*polthet(3,it)
6067         do j=2,1,-1
6068           sigtc=sigtc*thet_pred_mean+j*polthet(j,it)
6069         enddo
6070         sigtc=sig*sigtc
6071 C Set the parameters of both Gaussian lobes of the distribution.
6072 C "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc)
6073         fac=sig*sig+sigc0(it)
6074         sigcsq=fac+fac
6075         sigc=1.0D0/sigcsq
6076 C Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c
6077         sigsqtc=-4.0D0*sigcsq*sigtc
6078 c       print *,i,sig,sigtc,sigsqtc
6079 C Following variable (sigtc) is d[sigma(t_c)]/dt_c
6080         sigtc=-sigtc/(fac*fac)
6081 C Following variable is sigma(t_c)**(-2)
6082         sigcsq=sigcsq*sigcsq
6083         sig0i=sig0(it)
6084         sig0inv=1.0D0/sig0i**2
6085         delthec=thetai-thet_pred_mean
6086         delthe0=thetai-theta0i
6087         term1=-0.5D0*sigcsq*delthec*delthec
6088         term2=-0.5D0*sig0inv*delthe0*delthe0
6089 C        write (iout,*)'term1',term1,term2,sigcsq,delthec,sig0inv,delthe0
6090 C Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and
6091 C NaNs in taking the logarithm. We extract the largest exponent which is added
6092 C to the energy (this being the log of the distribution) at the end of energy
6093 C term evaluation for this virtual-bond angle.
6094         if (term1.gt.term2) then
6095           termm=term1
6096           term2=dexp(term2-termm)
6097           term1=1.0d0
6098         else
6099           termm=term2
6100           term1=dexp(term1-termm)
6101           term2=1.0d0
6102         endif
6103 C The ratio between the gamma-independent and gamma-dependent lobes of
6104 C the distribution is a Gaussian function of thet_pred_mean too.
6105         diffak=gthet(2,it)-thet_pred_mean
6106         ratak=diffak/gthet(3,it)**2
6107         ak=dexp(gthet(1,it)-0.5D0*diffak*ratak)
6108 C Let's differentiate it in thet_pred_mean NOW.
6109         aktc=ak*ratak
6110 C Now put together the distribution terms to make complete distribution.
6111         termexp=term1+ak*term2
6112         termpre=sigc+ak*sig0i
6113 C Contribution of the bending energy from this theta is just the -log of
6114 C the sum of the contributions from the two lobes and the pre-exponential
6115 C factor. Simple enough, isn't it?
6116         ethetai=(-dlog(termexp)-termm+dlog(termpre))
6117 C       write (iout,*) 'termexp',termexp,termm,termpre,i
6118 C NOW the derivatives!!!
6119 C 6/6/97 Take into account the deformation.
6120         E_theta=(delthec*sigcsq*term1
6121      &       +ak*delthe0*sig0inv*term2)/termexp
6122         E_tc=((sigtc+aktc*sig0i)/termpre
6123      &      -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+
6124      &       aktc*term2)/termexp)
6125       return
6126       end
6127 c-----------------------------------------------------------------------------
6128       subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)
6129       implicit real*8 (a-h,o-z)
6130       include 'DIMENSIONS'
6131       include 'COMMON.LOCAL'
6132       include 'COMMON.IOUNITS'
6133       common /calcthet/ term1,term2,termm,diffak,ratak,
6134      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
6135      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
6136       delthec=thetai-thet_pred_mean
6137       delthe0=thetai-theta0i
6138 C "Thank you" to MAPLE (probably spared one day of hand-differentiation).
6139       t3 = thetai-thet_pred_mean
6140       t6 = t3**2
6141       t9 = term1
6142       t12 = t3*sigcsq
6143       t14 = t12+t6*sigsqtc
6144       t16 = 1.0d0
6145       t21 = thetai-theta0i
6146       t23 = t21**2
6147       t26 = term2
6148       t27 = t21*t26
6149       t32 = termexp
6150       t40 = t32**2
6151       E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9
6152      & -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40
6153      & *(-t12*t9-ak*sig0inv*t27)
6154       return
6155       end
6156 #else
6157 C--------------------------------------------------------------------------
6158       subroutine ebend(etheta,ethetacnstr)
6159 C
6160 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
6161 C angles gamma and its derivatives in consecutive thetas and gammas.
6162 C ab initio-derived potentials from
6163 c Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203
6164 C
6165       implicit real*8 (a-h,o-z)
6166       include 'DIMENSIONS'
6167       include 'COMMON.LOCAL'
6168       include 'COMMON.GEO'
6169       include 'COMMON.INTERACT'
6170       include 'COMMON.DERIV'
6171       include 'COMMON.VAR'
6172       include 'COMMON.CHAIN'
6173       include 'COMMON.IOUNITS'
6174       include 'COMMON.NAMES'
6175       include 'COMMON.FFIELD'
6176       include 'COMMON.CONTROL'
6177       include 'COMMON.TORCNSTR'
6178       double precision coskt(mmaxtheterm),sinkt(mmaxtheterm),
6179      & cosph1(maxsingle),sinph1(maxsingle),cosph2(maxsingle),
6180      & sinph2(maxsingle),cosph1ph2(maxdouble,maxdouble),
6181      & sinph1ph2(maxdouble,maxdouble)
6182       logical lprn /.false./, lprn1 /.false./
6183       etheta=0.0D0
6184       do i=ithet_start,ithet_end
6185 c        print *,i,itype(i-1),itype(i),itype(i-2)
6186         if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
6187      &  .or.itype(i).eq.ntyp1) cycle
6188 C        print *,i,theta(i)
6189         if (iabs(itype(i+1)).eq.20) iblock=2
6190         if (iabs(itype(i+1)).ne.20) iblock=1
6191         dethetai=0.0d0
6192         dephii=0.0d0
6193         dephii1=0.0d0
6194         theti2=0.5d0*theta(i)
6195         ityp2=ithetyp((itype(i-1)))
6196         do k=1,nntheterm
6197           coskt(k)=dcos(k*theti2)
6198           sinkt(k)=dsin(k*theti2)
6199         enddo
6200 C        print *,ethetai
6201         if (i.gt.3 .and. itype(i-3).ne.ntyp1) then
6202 #ifdef OSF
6203           phii=phi(i)
6204           if (phii.ne.phii) phii=150.0
6205 #else
6206           phii=phi(i)
6207 #endif
6208           ityp1=ithetyp((itype(i-2)))
6209 C propagation of chirality for glycine type
6210           do k=1,nsingle
6211             cosph1(k)=dcos(k*phii)
6212             sinph1(k)=dsin(k*phii)
6213           enddo
6214         else
6215           phii=0.0d0
6216           do k=1,nsingle
6217           ityp1=ithetyp((itype(i-2)))
6218             cosph1(k)=0.0d0
6219             sinph1(k)=0.0d0
6220           enddo
6221         endif
6222         if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
6223 #ifdef OSF
6224           phii1=phi(i+1)
6225           if (phii1.ne.phii1) phii1=150.0
6226           phii1=pinorm(phii1)
6227 #else
6228           phii1=phi(i+1)
6229 #endif
6230           ityp3=ithetyp((itype(i)))
6231           do k=1,nsingle
6232             cosph2(k)=dcos(k*phii1)
6233             sinph2(k)=dsin(k*phii1)
6234           enddo
6235         else
6236           phii1=0.0d0
6237           ityp3=ithetyp((itype(i)))
6238           do k=1,nsingle
6239             cosph2(k)=0.0d0
6240             sinph2(k)=0.0d0
6241           enddo
6242         endif
6243         ethetai=aa0thet(ityp1,ityp2,ityp3,iblock)
6244         do k=1,ndouble
6245           do l=1,k-1
6246             ccl=cosph1(l)*cosph2(k-l)
6247             ssl=sinph1(l)*sinph2(k-l)
6248             scl=sinph1(l)*cosph2(k-l)
6249             csl=cosph1(l)*sinph2(k-l)
6250             cosph1ph2(l,k)=ccl-ssl
6251             cosph1ph2(k,l)=ccl+ssl
6252             sinph1ph2(l,k)=scl+csl
6253             sinph1ph2(k,l)=scl-csl
6254           enddo
6255         enddo
6256         if (lprn) then
6257         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,
6258      &    " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
6259         write (iout,*) "coskt and sinkt"
6260         do k=1,nntheterm
6261           write (iout,*) k,coskt(k),sinkt(k)
6262         enddo
6263         endif
6264         do k=1,ntheterm
6265           ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3,iblock)*sinkt(k)
6266           dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3,iblock)
6267      &      *coskt(k)
6268           if (lprn)
6269      &    write (iout,*) "k",k,"
6270      &     aathet",aathet(k,ityp1,ityp2,ityp3,iblock),
6271      &     " ethetai",ethetai
6272         enddo
6273         if (lprn) then
6274         write (iout,*) "cosph and sinph"
6275         do k=1,nsingle
6276           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
6277         enddo
6278         write (iout,*) "cosph1ph2 and sinph2ph2"
6279         do k=2,ndouble
6280           do l=1,k-1
6281             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),
6282      &         sinph1ph2(l,k),sinph1ph2(k,l)
6283           enddo
6284         enddo
6285         write(iout,*) "ethetai",ethetai
6286         endif
6287 C       print *,ethetai
6288         do m=1,ntheterm2
6289           do k=1,nsingle
6290             aux=bbthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)
6291      &         +ccthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k)
6292      &         +ddthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)
6293      &         +eethet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k)
6294             ethetai=ethetai+sinkt(m)*aux
6295             dethetai=dethetai+0.5d0*m*aux*coskt(m)
6296             dephii=dephii+k*sinkt(m)*(
6297      &          ccthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)-
6298      &          bbthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k))
6299             dephii1=dephii1+k*sinkt(m)*(
6300      &          eethet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)-
6301      &          ddthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k))
6302             if (lprn)
6303      &      write (iout,*) "m",m," k",k," bbthet",
6304      &         bbthet(k,m,ityp1,ityp2,ityp3,iblock)," ccthet",
6305      &         ccthet(k,m,ityp1,ityp2,ityp3,iblock)," ddthet",
6306      &         ddthet(k,m,ityp1,ityp2,ityp3,iblock)," eethet",
6307      &         eethet(k,m,ityp1,ityp2,ityp3,iblock)," ethetai",ethetai
6308 C        print *,"tu",cosph1(k),sinph1(k),cosph2(k),sinph2(k)
6309           enddo
6310         enddo
6311 C        print *,"cosph1", (cosph1(k), k=1,nsingle)
6312 C        print *,"cosph2", (cosph2(k), k=1,nsingle)
6313 C        print *,"sinph1", (sinph1(k), k=1,nsingle)
6314 C        print *,"sinph2", (sinph2(k), k=1,nsingle)
6315         if (lprn)
6316      &  write(iout,*) "ethetai",ethetai
6317 C        print *,"tu",cosph1(k),sinph1(k),cosph2(k),sinph2(k)
6318         do m=1,ntheterm3
6319           do k=2,ndouble
6320             do l=1,k-1
6321               aux=ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
6322      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l)+
6323      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
6324      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)
6325               ethetai=ethetai+sinkt(m)*aux
6326               dethetai=dethetai+0.5d0*m*coskt(m)*aux
6327               dephii=dephii+l*sinkt(m)*(
6328      &           -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)-
6329      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
6330      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
6331      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
6332               dephii1=dephii1+(k-l)*sinkt(m)*(
6333      &           -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
6334      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
6335      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)-
6336      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
6337               if (lprn) then
6338               write (iout,*) "m",m," k",k," l",l," ffthet",
6339      &            ffthet(l,k,m,ityp1,ityp2,ityp3,iblock),
6340      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)," ggthet",
6341      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock),
6342      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock),
6343      &            " ethetai",ethetai
6344               write (iout,*) cosph1ph2(l,k)*sinkt(m),
6345      &            cosph1ph2(k,l)*sinkt(m),
6346      &            sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
6347               endif
6348             enddo
6349           enddo
6350         enddo
6351 10      continue
6352 c        lprn1=.true.
6353 C        print *,ethetai
6354         if (lprn1)
6355      &    write (iout,'(i2,3f8.1,9h ethetai ,f10.5)')
6356      &   i,theta(i)*rad2deg,phii*rad2deg,
6357      &   phii1*rad2deg,ethetai
6358 c        lprn1=.false.
6359         etheta=etheta+ethetai
6360         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
6361         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
6362         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)+wang*dethetai
6363       enddo
6364 C now constrains
6365       ethetacnstr=0.0d0
6366 C      print *,ithetaconstr_start,ithetaconstr_end,"TU"
6367       do i=ithetaconstr_start,ithetaconstr_end
6368         itheta=itheta_constr(i)
6369         thetiii=theta(itheta)
6370         difi=pinorm(thetiii-theta_constr0(i))
6371         if (difi.gt.theta_drange(i)) then
6372           difi=difi-theta_drange(i)
6373           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
6374           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
6375      &    +for_thet_constr(i)*difi**3
6376         else if (difi.lt.-drange(i)) then
6377           difi=difi+drange(i)
6378           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
6379           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
6380      &    +for_thet_constr(i)*difi**3
6381         else
6382           difi=0.0
6383         endif
6384        if (energy_dec) then
6385         write (iout,'(a6,2i5,4f8.3,2e14.5)') "ethetc",
6386      &    i,itheta,rad2deg*thetiii,
6387      &    rad2deg*theta_constr0(i),  rad2deg*theta_drange(i),
6388      &    rad2deg*difi,0.25d0*for_thet_constr(i)*difi**4,
6389      &    gloc(itheta+nphi-2,icg)
6390         endif
6391       enddo
6392
6393       return
6394       end
6395 #endif
6396 #ifdef CRYST_SC
6397 c-----------------------------------------------------------------------------
6398       subroutine esc(escloc)
6399 C Calculate the local energy of a side chain and its derivatives in the
6400 C corresponding virtual-bond valence angles THETA and the spherical angles
6401 C ALPHA and OMEGA.
6402       implicit real*8 (a-h,o-z)
6403       include 'DIMENSIONS'
6404       include 'COMMON.GEO'
6405       include 'COMMON.LOCAL'
6406       include 'COMMON.VAR'
6407       include 'COMMON.INTERACT'
6408       include 'COMMON.DERIV'
6409       include 'COMMON.CHAIN'
6410       include 'COMMON.IOUNITS'
6411       include 'COMMON.NAMES'
6412       include 'COMMON.FFIELD'
6413       include 'COMMON.CONTROL'
6414       double precision x(3),dersc(3),xemp(3),dersc0(3),dersc1(3),
6415      &     ddersc0(3),ddummy(3),xtemp(3),temp(3)
6416       common /sccalc/ time11,time12,time112,theti,it,nlobit
6417       delta=0.02d0*pi
6418       escloc=0.0D0
6419 c     write (iout,'(a)') 'ESC'
6420       do i=loc_start,loc_end
6421         it=itype(i)
6422         if (it.eq.ntyp1) cycle
6423         if (it.eq.10) goto 1
6424         nlobit=nlob(iabs(it))
6425 c       print *,'i=',i,' it=',it,' nlobit=',nlobit
6426 c       write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
6427         theti=theta(i+1)-pipol
6428         x(1)=dtan(theti)
6429         x(2)=alph(i)
6430         x(3)=omeg(i)
6431
6432         if (x(2).gt.pi-delta) then
6433           xtemp(1)=x(1)
6434           xtemp(2)=pi-delta
6435           xtemp(3)=x(3)
6436           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
6437           xtemp(2)=pi
6438           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
6439           call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),
6440      &        escloci,dersc(2))
6441           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
6442      &        ddersc0(1),dersc(1))
6443           call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),
6444      &        ddersc0(3),dersc(3))
6445           xtemp(2)=pi-delta
6446           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
6447           xtemp(2)=pi
6448           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
6449           call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,
6450      &            dersc0(2),esclocbi,dersc02)
6451           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
6452      &            dersc12,dersc01)
6453           call splinthet(x(2),0.5d0*delta,ss,ssd)
6454           dersc0(1)=dersc01
6455           dersc0(2)=dersc02
6456           dersc0(3)=0.0d0
6457           do k=1,3
6458             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
6459           enddo
6460           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
6461 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
6462 c    &             esclocbi,ss,ssd
6463           escloci=ss*escloci+(1.0d0-ss)*esclocbi
6464 c         escloci=esclocbi
6465 c         write (iout,*) escloci
6466         else if (x(2).lt.delta) then
6467           xtemp(1)=x(1)
6468           xtemp(2)=delta
6469           xtemp(3)=x(3)
6470           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
6471           xtemp(2)=0.0d0
6472           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
6473           call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),
6474      &        escloci,dersc(2))
6475           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
6476      &        ddersc0(1),dersc(1))
6477           call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),
6478      &        ddersc0(3),dersc(3))
6479           xtemp(2)=delta
6480           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
6481           xtemp(2)=0.0d0
6482           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
6483           call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,
6484      &            dersc0(2),esclocbi,dersc02)
6485           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
6486      &            dersc12,dersc01)
6487           dersc0(1)=dersc01
6488           dersc0(2)=dersc02
6489           dersc0(3)=0.0d0
6490           call splinthet(x(2),0.5d0*delta,ss,ssd)
6491           do k=1,3
6492             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
6493           enddo
6494           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
6495 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
6496 c    &             esclocbi,ss,ssd
6497           escloci=ss*escloci+(1.0d0-ss)*esclocbi
6498 c         write (iout,*) escloci
6499         else
6500           call enesc(x,escloci,dersc,ddummy,.false.)
6501         endif
6502
6503         escloc=escloc+escloci
6504         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
6505      &     'escloc',i,escloci
6506 c       write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
6507
6508         gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
6509      &   wscloc*dersc(1)
6510         gloc(ialph(i,1),icg)=wscloc*dersc(2)
6511         gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
6512     1   continue
6513       enddo
6514       return
6515       end
6516 C---------------------------------------------------------------------------
6517       subroutine enesc(x,escloci,dersc,ddersc,mixed)
6518       implicit real*8 (a-h,o-z)
6519       include 'DIMENSIONS'
6520       include 'COMMON.GEO'
6521       include 'COMMON.LOCAL'
6522       include 'COMMON.IOUNITS'
6523       common /sccalc/ time11,time12,time112,theti,it,nlobit
6524       double precision x(3),z(3),Ax(3,maxlob,-1:1),dersc(3),ddersc(3)
6525       double precision contr(maxlob,-1:1)
6526       logical mixed
6527 c       write (iout,*) 'it=',it,' nlobit=',nlobit
6528         escloc_i=0.0D0
6529         do j=1,3
6530           dersc(j)=0.0D0
6531           if (mixed) ddersc(j)=0.0d0
6532         enddo
6533         x3=x(3)
6534
6535 C Because of periodicity of the dependence of the SC energy in omega we have
6536 C to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
6537 C To avoid underflows, first compute & store the exponents.
6538
6539         do iii=-1,1
6540
6541           x(3)=x3+iii*dwapi
6542
6543           do j=1,nlobit
6544             do k=1,3
6545               z(k)=x(k)-censc(k,j,it)
6546             enddo
6547             do k=1,3
6548               Axk=0.0D0
6549               do l=1,3
6550                 Axk=Axk+gaussc(l,k,j,it)*z(l)
6551               enddo
6552               Ax(k,j,iii)=Axk
6553             enddo
6554             expfac=0.0D0
6555             do k=1,3
6556               expfac=expfac+Ax(k,j,iii)*z(k)
6557             enddo
6558             contr(j,iii)=expfac
6559           enddo ! j
6560
6561         enddo ! iii
6562
6563         x(3)=x3
6564 C As in the case of ebend, we want to avoid underflows in exponentiation and
6565 C subsequent NaNs and INFs in energy calculation.
6566 C Find the largest exponent
6567         emin=contr(1,-1)
6568         do iii=-1,1
6569           do j=1,nlobit
6570             if (emin.gt.contr(j,iii)) emin=contr(j,iii)
6571           enddo
6572         enddo
6573         emin=0.5D0*emin
6574 cd      print *,'it=',it,' emin=',emin
6575
6576 C Compute the contribution to SC energy and derivatives
6577         do iii=-1,1
6578
6579           do j=1,nlobit
6580 #ifdef OSF
6581             adexp=bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin
6582             if(adexp.ne.adexp) adexp=1.0
6583             expfac=dexp(adexp)
6584 #else
6585             expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin)
6586 #endif
6587 cd          print *,'j=',j,' expfac=',expfac
6588             escloc_i=escloc_i+expfac
6589             do k=1,3
6590               dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
6591             enddo
6592             if (mixed) then
6593               do k=1,3,2
6594                 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii)
6595      &            +gaussc(k,2,j,it))*expfac
6596               enddo
6597             endif
6598           enddo
6599
6600         enddo ! iii
6601
6602         dersc(1)=dersc(1)/cos(theti)**2
6603         ddersc(1)=ddersc(1)/cos(theti)**2
6604         ddersc(3)=ddersc(3)
6605
6606         escloci=-(dlog(escloc_i)-emin)
6607         do j=1,3
6608           dersc(j)=dersc(j)/escloc_i
6609         enddo
6610         if (mixed) then
6611           do j=1,3,2
6612             ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
6613           enddo
6614         endif
6615       return
6616       end
6617 C------------------------------------------------------------------------------
6618       subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
6619       implicit real*8 (a-h,o-z)
6620       include 'DIMENSIONS'
6621       include 'COMMON.GEO'
6622       include 'COMMON.LOCAL'
6623       include 'COMMON.IOUNITS'
6624       common /sccalc/ time11,time12,time112,theti,it,nlobit
6625       double precision x(3),z(3),Ax(3,maxlob),dersc(3)
6626       double precision contr(maxlob)
6627       logical mixed
6628
6629       escloc_i=0.0D0
6630
6631       do j=1,3
6632         dersc(j)=0.0D0
6633       enddo
6634
6635       do j=1,nlobit
6636         do k=1,2
6637           z(k)=x(k)-censc(k,j,it)
6638         enddo
6639         z(3)=dwapi
6640         do k=1,3
6641           Axk=0.0D0
6642           do l=1,3
6643             Axk=Axk+gaussc(l,k,j,it)*z(l)
6644           enddo
6645           Ax(k,j)=Axk
6646         enddo
6647         expfac=0.0D0
6648         do k=1,3
6649           expfac=expfac+Ax(k,j)*z(k)
6650         enddo
6651         contr(j)=expfac
6652       enddo ! j
6653
6654 C As in the case of ebend, we want to avoid underflows in exponentiation and
6655 C subsequent NaNs and INFs in energy calculation.
6656 C Find the largest exponent
6657       emin=contr(1)
6658       do j=1,nlobit
6659         if (emin.gt.contr(j)) emin=contr(j)
6660       enddo
6661       emin=0.5D0*emin
6662
6663 C Compute the contribution to SC energy and derivatives
6664
6665       dersc12=0.0d0
6666       do j=1,nlobit
6667         expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j)+emin)
6668         escloc_i=escloc_i+expfac
6669         do k=1,2
6670           dersc(k)=dersc(k)+Ax(k,j)*expfac
6671         enddo
6672         if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j)
6673      &            +gaussc(1,2,j,it))*expfac
6674         dersc(3)=0.0d0
6675       enddo
6676
6677       dersc(1)=dersc(1)/cos(theti)**2
6678       dersc12=dersc12/cos(theti)**2
6679       escloci=-(dlog(escloc_i)-emin)
6680       do j=1,2
6681         dersc(j)=dersc(j)/escloc_i
6682       enddo
6683       if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
6684       return
6685       end
6686 #else
6687 c----------------------------------------------------------------------------------
6688       subroutine esc(escloc)
6689 C Calculate the local energy of a side chain and its derivatives in the
6690 C corresponding virtual-bond valence angles THETA and the spherical angles
6691 C ALPHA and OMEGA derived from AM1 all-atom calculations.
6692 C added by Urszula Kozlowska. 07/11/2007
6693 C
6694       implicit real*8 (a-h,o-z)
6695       include 'DIMENSIONS'
6696       include 'COMMON.GEO'
6697       include 'COMMON.LOCAL'
6698       include 'COMMON.VAR'
6699       include 'COMMON.SCROT'
6700       include 'COMMON.INTERACT'
6701       include 'COMMON.DERIV'
6702       include 'COMMON.CHAIN'
6703       include 'COMMON.IOUNITS'
6704       include 'COMMON.NAMES'
6705       include 'COMMON.FFIELD'
6706       include 'COMMON.CONTROL'
6707       include 'COMMON.VECTORS'
6708       double precision x_prime(3),y_prime(3),z_prime(3)
6709      &    , sumene,dsc_i,dp2_i,x(65),
6710      &     xx,yy,zz,sumene1,sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6,
6711      &    de_dxx,de_dyy,de_dzz,de_dt
6712       double precision s1_t,s1_6_t,s2_t,s2_6_t
6713       double precision
6714      & dXX_Ci1(3),dYY_Ci1(3),dZZ_Ci1(3),dXX_Ci(3),
6715      & dYY_Ci(3),dZZ_Ci(3),dXX_XYZ(3),dYY_XYZ(3),dZZ_XYZ(3),
6716      & dt_dCi(3),dt_dCi1(3)
6717       common /sccalc/ time11,time12,time112,theti,it,nlobit
6718       delta=0.02d0*pi
6719       escloc=0.0D0
6720       do i=loc_start,loc_end
6721         if (itype(i).eq.ntyp1) cycle
6722         costtab(i+1) =dcos(theta(i+1))
6723         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
6724         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
6725         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
6726         cosfac2=0.5d0/(1.0d0+costtab(i+1))
6727         cosfac=dsqrt(cosfac2)
6728         sinfac2=0.5d0/(1.0d0-costtab(i+1))
6729         sinfac=dsqrt(sinfac2)
6730         it=iabs(itype(i))
6731         if (it.eq.10) goto 1
6732 c
6733 C  Compute the axes of tghe local cartesian coordinates system; store in
6734 c   x_prime, y_prime and z_prime
6735 c
6736         do j=1,3
6737           x_prime(j) = 0.00
6738           y_prime(j) = 0.00
6739           z_prime(j) = 0.00
6740         enddo
6741 C        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
6742 C     &   dc_norm(3,i+nres)
6743         do j = 1,3
6744           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
6745           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
6746         enddo
6747         do j = 1,3
6748           z_prime(j) = -uz(j,i-1)*dsign(1.0d0,dfloat(itype(i)))
6749         enddo
6750 c       write (2,*) "i",i
6751 c       write (2,*) "x_prime",(x_prime(j),j=1,3)
6752 c       write (2,*) "y_prime",(y_prime(j),j=1,3)
6753 c       write (2,*) "z_prime",(z_prime(j),j=1,3)
6754 c       write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
6755 c      & " xy",scalar(x_prime(1),y_prime(1)),
6756 c      & " xz",scalar(x_prime(1),z_prime(1)),
6757 c      & " yy",scalar(y_prime(1),y_prime(1)),
6758 c      & " yz",scalar(y_prime(1),z_prime(1)),
6759 c      & " zz",scalar(z_prime(1),z_prime(1))
6760 c
6761 C Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
6762 C to local coordinate system. Store in xx, yy, zz.
6763 c
6764         xx=0.0d0
6765         yy=0.0d0
6766         zz=0.0d0
6767         do j = 1,3
6768           xx = xx + x_prime(j)*dc_norm(j,i+nres)
6769           yy = yy + y_prime(j)*dc_norm(j,i+nres)
6770           zz = zz + z_prime(j)*dc_norm(j,i+nres)
6771         enddo
6772
6773         xxtab(i)=xx
6774         yytab(i)=yy
6775         zztab(i)=zz
6776 C
6777 C Compute the energy of the ith side cbain
6778 C
6779 c        write (2,*) "xx",xx," yy",yy," zz",zz
6780         it=iabs(itype(i))
6781         do j = 1,65
6782           x(j) = sc_parmin(j,it)
6783         enddo
6784 #ifdef CHECK_COORD
6785 Cc diagnostics - remove later
6786         xx1 = dcos(alph(2))
6787         yy1 = dsin(alph(2))*dcos(omeg(2))
6788         zz1 = -dsign(1.0,dfloat(itype(i)))*dsin(alph(2))*dsin(omeg(2))
6789         write(2,'(3f8.1,3f9.3,1x,3f9.3)')
6790      &    alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,
6791      &    xx1,yy1,zz1
6792 C,"  --- ", xx_w,yy_w,zz_w
6793 c end diagnostics
6794 #endif
6795         sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
6796      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
6797      &   + x(10)*yy*zz
6798         sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
6799      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
6800      & + x(20)*yy*zz
6801         sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
6802      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
6803      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
6804      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
6805      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
6806      &  +x(40)*xx*yy*zz
6807         sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
6808      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
6809      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
6810      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
6811      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
6812      &  +x(60)*xx*yy*zz
6813         dsc_i   = 0.743d0+x(61)
6814         dp2_i   = 1.9d0+x(62)
6815         dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
6816      &          *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
6817         dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
6818      &          *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
6819         s1=(1+x(63))/(0.1d0 + dscp1)
6820         s1_6=(1+x(64))/(0.1d0 + dscp1**6)
6821         s2=(1+x(65))/(0.1d0 + dscp2)
6822         s2_6=(1+x(65))/(0.1d0 + dscp2**6)
6823         sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6)
6824      & + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
6825 c        write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
6826 c     &   sumene4,
6827 c     &   dscp1,dscp2,sumene
6828 c        sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6829         escloc = escloc + sumene
6830 c        write (2,*) "i",i," escloc",sumene,escloc,it,itype(i)
6831 c     & ,zz,xx,yy
6832 c#define DEBUG
6833 #ifdef DEBUG
6834 C
6835 C This section to check the numerical derivatives of the energy of ith side
6836 C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
6837 C #define DEBUG in the code to turn it on.
6838 C
6839         write (2,*) "sumene               =",sumene
6840         aincr=1.0d-7
6841         xxsave=xx
6842         xx=xx+aincr
6843         write (2,*) xx,yy,zz
6844         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6845         de_dxx_num=(sumenep-sumene)/aincr
6846         xx=xxsave
6847         write (2,*) "xx+ sumene from enesc=",sumenep
6848         yysave=yy
6849         yy=yy+aincr
6850         write (2,*) xx,yy,zz
6851         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6852         de_dyy_num=(sumenep-sumene)/aincr
6853         yy=yysave
6854         write (2,*) "yy+ sumene from enesc=",sumenep
6855         zzsave=zz
6856         zz=zz+aincr
6857         write (2,*) xx,yy,zz
6858         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6859         de_dzz_num=(sumenep-sumene)/aincr
6860         zz=zzsave
6861         write (2,*) "zz+ sumene from enesc=",sumenep
6862         costsave=cost2tab(i+1)
6863         sintsave=sint2tab(i+1)
6864         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
6865         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
6866         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6867         de_dt_num=(sumenep-sumene)/aincr
6868         write (2,*) " t+ sumene from enesc=",sumenep
6869         cost2tab(i+1)=costsave
6870         sint2tab(i+1)=sintsave
6871 C End of diagnostics section.
6872 #endif
6873 C
6874 C Compute the gradient of esc
6875 C
6876 c        zz=zz*dsign(1.0,dfloat(itype(i)))
6877         pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
6878         pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
6879         pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
6880         pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
6881         pom_dx=dsc_i*dp2_i*cost2tab(i+1)
6882         pom_dy=dsc_i*dp2_i*sint2tab(i+1)
6883         pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
6884         pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
6885         pom1=(sumene3*sint2tab(i+1)+sumene1)
6886      &     *(pom_s1/dscp1+pom_s16*dscp1**4)
6887         pom2=(sumene4*cost2tab(i+1)+sumene2)
6888      &     *(pom_s2/dscp2+pom_s26*dscp2**4)
6889         sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
6890         sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2
6891      &  +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2)
6892      &  +x(40)*yy*zz
6893         sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
6894         sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2
6895      &  +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2)
6896      &  +x(60)*yy*zz
6897         de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6)
6898      &        +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6)
6899      &        +(pom1+pom2)*pom_dx
6900 #ifdef DEBUG
6901         write(2,*), "de_dxx = ", de_dxx,de_dxx_num,itype(i)
6902 #endif
6903 C
6904         sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
6905         sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2
6906      &  +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2)
6907      &  +x(40)*xx*zz
6908         sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
6909         sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz
6910      &  +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz
6911      &  +x(59)*zz**2 +x(60)*xx*zz
6912         de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6)
6913      &        +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6)
6914      &        +(pom1-pom2)*pom_dy
6915 #ifdef DEBUG
6916         write(2,*), "de_dyy = ", de_dyy,de_dyy_num,itype(i)
6917 #endif
6918 C
6919         de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy
6920      &  +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx
6921      &  +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6)
6922      &  +(x(4) + 2*x(7)*zz+  x(8)*xx + x(10)*yy)*(s1+s1_6)
6923      &  +(x(44)+2*x(47)*zz +x(48)*xx   +x(50)*yy  +3*x(53)*zz**2
6924      &  +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy
6925      &  +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6)
6926      &  + ( x(14) + 2*x(17)*zz+  x(18)*xx + x(20)*yy)*(s2+s2_6)
6927 #ifdef DEBUG
6928         write(2,*), "de_dzz = ", de_dzz,de_dzz_num,itype(i)
6929 #endif
6930 C
6931         de_dt =  0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6)
6932      &  -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6)
6933      &  +pom1*pom_dt1+pom2*pom_dt2
6934 #ifdef DEBUG
6935         write(2,*), "de_dt = ", de_dt,de_dt_num,itype(i)
6936 #endif
6937 c#undef DEBUG
6938 c
6939 C
6940        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
6941        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
6942        cosfac2xx=cosfac2*xx
6943        sinfac2yy=sinfac2*yy
6944        do k = 1,3
6945          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))*
6946      &      vbld_inv(i+1)
6947          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))*
6948      &      vbld_inv(i)
6949          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
6950          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
6951 c         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
6952 c     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
6953 c         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
6954 c     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
6955          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
6956          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
6957          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
6958          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
6959          dZZ_Ci1(k)=0.0d0
6960          dZZ_Ci(k)=0.0d0
6961          do j=1,3
6962            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)
6963      &     *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
6964            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)
6965      &     *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
6966          enddo
6967
6968          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
6969          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
6970          dZZ_XYZ(k)=vbld_inv(i+nres)*
6971      &   (z_prime(k)-zz*dC_norm(k,i+nres))
6972 c
6973          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
6974          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
6975        enddo
6976
6977        do k=1,3
6978          dXX_Ctab(k,i)=dXX_Ci(k)
6979          dXX_C1tab(k,i)=dXX_Ci1(k)
6980          dYY_Ctab(k,i)=dYY_Ci(k)
6981          dYY_C1tab(k,i)=dYY_Ci1(k)
6982          dZZ_Ctab(k,i)=dZZ_Ci(k)
6983          dZZ_C1tab(k,i)=dZZ_Ci1(k)
6984          dXX_XYZtab(k,i)=dXX_XYZ(k)
6985          dYY_XYZtab(k,i)=dYY_XYZ(k)
6986          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
6987        enddo
6988
6989        do k = 1,3
6990 c         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
6991 c     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
6992 c         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
6993 c     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
6994 c         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
6995 c     &    dt_dci(k)
6996 c         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
6997 c     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
6998          gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k)
6999      &    +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
7000          gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k)
7001      &    +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
7002          gsclocx(k,i)=                 de_dxx*dxx_XYZ(k)
7003      &    +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
7004        enddo
7005 c       write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
7006 c     &  (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
7007
7008 C to check gradient call subroutine check_grad
7009
7010     1 continue
7011       enddo
7012       return
7013       end
7014 c------------------------------------------------------------------------------
7015       double precision function enesc(x,xx,yy,zz,cost2,sint2)
7016       implicit none
7017       double precision x(65),xx,yy,zz,cost2,sint2,sumene1,sumene2,
7018      & sumene3,sumene4,sumene,dsc_i,dp2_i,dscp1,dscp2,s1,s1_6,s2,s2_6
7019       sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
7020      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
7021      &   + x(10)*yy*zz
7022       sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
7023      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
7024      & + x(20)*yy*zz
7025       sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
7026      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
7027      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
7028      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
7029      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
7030      &  +x(40)*xx*yy*zz
7031       sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
7032      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
7033      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
7034      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
7035      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
7036      &  +x(60)*xx*yy*zz
7037       dsc_i   = 0.743d0+x(61)
7038       dp2_i   = 1.9d0+x(62)
7039       dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
7040      &          *(xx*cost2+yy*sint2))
7041       dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
7042      &          *(xx*cost2-yy*sint2))
7043       s1=(1+x(63))/(0.1d0 + dscp1)
7044       s1_6=(1+x(64))/(0.1d0 + dscp1**6)
7045       s2=(1+x(65))/(0.1d0 + dscp2)
7046       s2_6=(1+x(65))/(0.1d0 + dscp2**6)
7047       sumene = ( sumene3*sint2 + sumene1)*(s1+s1_6)
7048      & + (sumene4*cost2 +sumene2)*(s2+s2_6)
7049       enesc=sumene
7050       return
7051       end
7052 #endif
7053 c------------------------------------------------------------------------------
7054       subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
7055 C
7056 C This procedure calculates two-body contact function g(rij) and its derivative:
7057 C
7058 C           eps0ij                                     !       x < -1
7059 C g(rij) =  esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5)  ! -1 =< x =< 1
7060 C            0                                         !       x > 1
7061 C
7062 C where x=(rij-r0ij)/delta
7063 C
7064 C rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
7065 C
7066       implicit none
7067       double precision rij,r0ij,eps0ij,fcont,fprimcont
7068       double precision x,x2,x4,delta
7069 c     delta=0.02D0*r0ij
7070 c      delta=0.2D0*r0ij
7071       x=(rij-r0ij)/delta
7072       if (x.lt.-1.0D0) then
7073         fcont=eps0ij
7074         fprimcont=0.0D0
7075       else if (x.le.1.0D0) then
7076         x2=x*x
7077         x4=x2*x2
7078         fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
7079         fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
7080       else
7081         fcont=0.0D0
7082         fprimcont=0.0D0
7083       endif
7084       return
7085       end
7086 c------------------------------------------------------------------------------
7087       subroutine splinthet(theti,delta,ss,ssder)
7088       implicit real*8 (a-h,o-z)
7089       include 'DIMENSIONS'
7090       include 'COMMON.VAR'
7091       include 'COMMON.GEO'
7092       thetup=pi-delta
7093       thetlow=delta
7094       if (theti.gt.pipol) then
7095         call gcont(theti,thetup,1.0d0,delta,ss,ssder)
7096       else
7097         call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
7098         ssder=-ssder
7099       endif
7100       return
7101       end
7102 c------------------------------------------------------------------------------
7103       subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
7104       implicit none
7105       double precision x,x0,delta,f0,f1,fprim0,f,fprim
7106       double precision ksi,ksi2,ksi3,a1,a2,a3
7107       a1=fprim0*delta/(f1-f0)
7108       a2=3.0d0-2.0d0*a1
7109       a3=a1-2.0d0
7110       ksi=(x-x0)/delta
7111       ksi2=ksi*ksi
7112       ksi3=ksi2*ksi
7113       f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
7114       fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
7115       return
7116       end
7117 c------------------------------------------------------------------------------
7118       subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
7119       implicit none
7120       double precision x,x0,delta,f0x,f1x,fprim0x,fx
7121       double precision ksi,ksi2,ksi3,a1,a2,a3
7122       ksi=(x-x0)/delta
7123       ksi2=ksi*ksi
7124       ksi3=ksi2*ksi
7125       a1=fprim0x*delta
7126       a2=3*(f1x-f0x)-2*fprim0x*delta
7127       a3=fprim0x*delta-2*(f1x-f0x)
7128       fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
7129       return
7130       end
7131 C-----------------------------------------------------------------------------
7132 #ifdef CRYST_TOR
7133 C-----------------------------------------------------------------------------
7134       subroutine etor(etors,edihcnstr)
7135       implicit real*8 (a-h,o-z)
7136       include 'DIMENSIONS'
7137       include 'COMMON.VAR'
7138       include 'COMMON.GEO'
7139       include 'COMMON.LOCAL'
7140       include 'COMMON.TORSION'
7141       include 'COMMON.INTERACT'
7142       include 'COMMON.DERIV'
7143       include 'COMMON.CHAIN'
7144       include 'COMMON.NAMES'
7145       include 'COMMON.IOUNITS'
7146       include 'COMMON.FFIELD'
7147       include 'COMMON.TORCNSTR'
7148       include 'COMMON.CONTROL'
7149       logical lprn
7150 C Set lprn=.true. for debugging
7151       lprn=.false.
7152 c      lprn=.true.
7153       etors=0.0D0
7154       do i=iphi_start,iphi_end
7155       etors_ii=0.0D0
7156         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
7157      &      .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
7158         itori=itortyp(itype(i-2))
7159         itori1=itortyp(itype(i-1))
7160         phii=phi(i)
7161         gloci=0.0D0
7162 C Proline-Proline pair is a special case...
7163         if (itori.eq.3 .and. itori1.eq.3) then
7164           if (phii.gt.-dwapi3) then
7165             cosphi=dcos(3*phii)
7166             fac=1.0D0/(1.0D0-cosphi)
7167             etorsi=v1(1,3,3)*fac
7168             etorsi=etorsi+etorsi
7169             etors=etors+etorsi-v1(1,3,3)
7170             if (energy_dec) etors_ii=etors_ii+etorsi-v1(1,3,3)
7171             gloci=gloci-3*fac*etorsi*dsin(3*phii)
7172           endif
7173           do j=1,3
7174             v1ij=v1(j+1,itori,itori1)
7175             v2ij=v2(j+1,itori,itori1)
7176             cosphi=dcos(j*phii)
7177             sinphi=dsin(j*phii)
7178             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7179             if (energy_dec) etors_ii=etors_ii+
7180      &                              v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7181             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7182           enddo
7183         else
7184           do j=1,nterm_old
7185             v1ij=v1(j,itori,itori1)
7186             v2ij=v2(j,itori,itori1)
7187             cosphi=dcos(j*phii)
7188             sinphi=dsin(j*phii)
7189             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7190             if (energy_dec) etors_ii=etors_ii+
7191      &                  v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7192             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7193           enddo
7194         endif
7195         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
7196              'etor',i,etors_ii
7197         if (lprn)
7198      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
7199      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
7200      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
7201         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
7202 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
7203       enddo
7204 ! 6/20/98 - dihedral angle constraints
7205       edihcnstr=0.0d0
7206       do i=1,ndih_constr
7207         itori=idih_constr(i)
7208         phii=phi(itori)
7209         difi=phii-phi0(i)
7210         if (difi.gt.drange(i)) then
7211           difi=difi-drange(i)
7212           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
7213           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
7214         else if (difi.lt.-drange(i)) then
7215           difi=difi+drange(i)
7216           edihcnstr=edihcnstr+0.25d0*ftors(i)**difi**4
7217           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
7218         endif
7219 !        write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii,
7220 !     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
7221       enddo
7222 !      write (iout,*) 'edihcnstr',edihcnstr
7223       return
7224       end
7225 c------------------------------------------------------------------------------
7226       subroutine etor_d(etors_d)
7227       etors_d=0.0d0
7228       return
7229       end
7230 c----------------------------------------------------------------------------
7231 #else
7232       subroutine etor(etors,edihcnstr)
7233       implicit real*8 (a-h,o-z)
7234       include 'DIMENSIONS'
7235       include 'COMMON.VAR'
7236       include 'COMMON.GEO'
7237       include 'COMMON.LOCAL'
7238       include 'COMMON.TORSION'
7239       include 'COMMON.INTERACT'
7240       include 'COMMON.DERIV'
7241       include 'COMMON.CHAIN'
7242       include 'COMMON.NAMES'
7243       include 'COMMON.IOUNITS'
7244       include 'COMMON.FFIELD'
7245       include 'COMMON.TORCNSTR'
7246       include 'COMMON.CONTROL'
7247       logical lprn
7248 C Set lprn=.true. for debugging
7249       lprn=.false.
7250 c     lprn=.true.
7251       etors=0.0D0
7252       do i=iphi_start,iphi_end
7253 C ANY TWO ARE DUMMY ATOMS in row CYCLE
7254 c        if (((itype(i-3).eq.ntyp1).and.(itype(i-2).eq.ntyp1)).or.
7255 c     &      ((itype(i-2).eq.ntyp1).and.(itype(i-1).eq.ntyp1))  .or.
7256 c     &      ((itype(i-1).eq.ntyp1).and.(itype(i).eq.ntyp1))) cycle
7257         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
7258      &      .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
7259 C In current verion the ALL DUMMY ATOM POTENTIALS ARE OFF
7260 C For introducing the NH3+ and COO- group please check the etor_d for reference
7261 C and guidance
7262         etors_ii=0.0D0
7263          if (iabs(itype(i)).eq.20) then
7264          iblock=2
7265          else
7266          iblock=1
7267          endif
7268         itori=itortyp(itype(i-2))
7269         itori1=itortyp(itype(i-1))
7270         phii=phi(i)
7271         gloci=0.0D0
7272 C Regular cosine and sine terms
7273         do j=1,nterm(itori,itori1,iblock)
7274           v1ij=v1(j,itori,itori1,iblock)
7275           v2ij=v2(j,itori,itori1,iblock)
7276           cosphi=dcos(j*phii)
7277           sinphi=dsin(j*phii)
7278           etors=etors+v1ij*cosphi+v2ij*sinphi
7279           if (energy_dec) etors_ii=etors_ii+
7280      &                v1ij*cosphi+v2ij*sinphi
7281           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7282         enddo
7283 C Lorentz terms
7284 C                         v1
7285 C  E = SUM ----------------------------------- - v1
7286 C          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
7287 C
7288         cosphi=dcos(0.5d0*phii)
7289         sinphi=dsin(0.5d0*phii)
7290         do j=1,nlor(itori,itori1,iblock)
7291           vl1ij=vlor1(j,itori,itori1)
7292           vl2ij=vlor2(j,itori,itori1)
7293           vl3ij=vlor3(j,itori,itori1)
7294           pom=vl2ij*cosphi+vl3ij*sinphi
7295           pom1=1.0d0/(pom*pom+1.0d0)
7296           etors=etors+vl1ij*pom1
7297           if (energy_dec) etors_ii=etors_ii+
7298      &                vl1ij*pom1
7299           pom=-pom*pom1*pom1
7300           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
7301         enddo
7302 C Subtract the constant term
7303         etors=etors-v0(itori,itori1,iblock)
7304           if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
7305      &         'etor',i,etors_ii-v0(itori,itori1,iblock)
7306         if (lprn)
7307      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
7308      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
7309      &  (v1(j,itori,itori1,iblock),j=1,6),
7310      &  (v2(j,itori,itori1,iblock),j=1,6)
7311         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
7312 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
7313       enddo
7314 ! 6/20/98 - dihedral angle constraints
7315       edihcnstr=0.0d0
7316 c      do i=1,ndih_constr
7317       do i=idihconstr_start,idihconstr_end
7318         itori=idih_constr(i)
7319         phii=phi(itori)
7320         difi=pinorm(phii-phi0(i))
7321         if (difi.gt.drange(i)) then
7322           difi=difi-drange(i)
7323           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
7324           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
7325         else if (difi.lt.-drange(i)) then
7326           difi=difi+drange(i)
7327           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
7328           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
7329         else
7330           difi=0.0
7331         endif
7332        if (energy_dec) then
7333         write (iout,'(a6,2i5,4f8.3,2e14.5)') "edihc",
7334      &    i,itori,rad2deg*phii,
7335      &    rad2deg*phi0(i),  rad2deg*drange(i),
7336      &    rad2deg*difi,0.25d0*ftors(i)*difi**4,gloc(itori-3,icg)
7337         endif
7338       enddo
7339 cd       write (iout,*) 'edihcnstr',edihcnstr
7340       return
7341       end
7342 c----------------------------------------------------------------------------
7343       subroutine etor_d(etors_d)
7344 C 6/23/01 Compute double torsional energy
7345       implicit real*8 (a-h,o-z)
7346       include 'DIMENSIONS'
7347       include 'COMMON.VAR'
7348       include 'COMMON.GEO'
7349       include 'COMMON.LOCAL'
7350       include 'COMMON.TORSION'
7351       include 'COMMON.INTERACT'
7352       include 'COMMON.DERIV'
7353       include 'COMMON.CHAIN'
7354       include 'COMMON.NAMES'
7355       include 'COMMON.IOUNITS'
7356       include 'COMMON.FFIELD'
7357       include 'COMMON.TORCNSTR'
7358       logical lprn
7359 C Set lprn=.true. for debugging
7360       lprn=.false.
7361 c     lprn=.true.
7362       etors_d=0.0D0
7363 c      write(iout,*) "a tu??"
7364       do i=iphid_start,iphid_end
7365 C ANY TWO ARE DUMMY ATOMS in row CYCLE
7366 C        if (((itype(i-3).eq.ntyp1).and.(itype(i-2).eq.ntyp1)).or.
7367 C     &      ((itype(i-2).eq.ntyp1).and.(itype(i-1).eq.ntyp1)).or.
7368 C     &      ((itype(i-1).eq.ntyp1).and.(itype(i).eq.ntyp1))  .or.
7369 C     &      ((itype(i).eq.ntyp1).and.(itype(i+1).eq.ntyp1))) cycle
7370          if ((itype(i-2).eq.ntyp1).or.itype(i-3).eq.ntyp1.or.
7371      &  (itype(i-1).eq.ntyp1).or.(itype(i).eq.ntyp1).or.
7372      &  (itype(i+1).eq.ntyp1)) cycle
7373 C In current verion the ALL DUMMY ATOM POTENTIALS ARE OFF
7374         itori=itortyp(itype(i-2))
7375         itori1=itortyp(itype(i-1))
7376         itori2=itortyp(itype(i))
7377         phii=phi(i)
7378         phii1=phi(i+1)
7379         gloci1=0.0D0
7380         gloci2=0.0D0
7381         iblock=1
7382         if (iabs(itype(i+1)).eq.20) iblock=2
7383 C Iblock=2 Proline type
7384 C ADASKO: WHEN PARAMETERS FOR THIS TYPE OF BLOCKING GROUP IS READY UNCOMMENT
7385 C CHECK WEATHER THERE IS NECCESITY FOR iblock=3 for COO-
7386 C        if (itype(i+1).eq.ntyp1) iblock=3
7387 C The problem of NH3+ group can be resolved by adding new parameters please note if there
7388 C IS or IS NOT need for this
7389 C IF Yes uncomment below and add to parmread.F appropriate changes and to v1cij and so on
7390 C        is (itype(i-3).eq.ntyp1) ntblock=2
7391 C        ntblock is N-terminal blocking group
7392
7393 C Regular cosine and sine terms
7394         do j=1,ntermd_1(itori,itori1,itori2,iblock)
7395 C Example of changes for NH3+ blocking group
7396 C       do j=1,ntermd_1(itori,itori1,itori2,iblock,ntblock)
7397 C          v1cij=v1c(1,j,itori,itori1,itori2,iblock,ntblock)
7398           v1cij=v1c(1,j,itori,itori1,itori2,iblock)
7399           v1sij=v1s(1,j,itori,itori1,itori2,iblock)
7400           v2cij=v1c(2,j,itori,itori1,itori2,iblock)
7401           v2sij=v1s(2,j,itori,itori1,itori2,iblock)
7402           cosphi1=dcos(j*phii)
7403           sinphi1=dsin(j*phii)
7404           cosphi2=dcos(j*phii1)
7405           sinphi2=dsin(j*phii1)
7406           etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+
7407      &     v2cij*cosphi2+v2sij*sinphi2
7408           gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
7409           gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
7410         enddo
7411         do k=2,ntermd_2(itori,itori1,itori2,iblock)
7412           do l=1,k-1
7413             v1cdij = v2c(k,l,itori,itori1,itori2,iblock)
7414             v2cdij = v2c(l,k,itori,itori1,itori2,iblock)
7415             v1sdij = v2s(k,l,itori,itori1,itori2,iblock)
7416             v2sdij = v2s(l,k,itori,itori1,itori2,iblock)
7417             cosphi1p2=dcos(l*phii+(k-l)*phii1)
7418             cosphi1m2=dcos(l*phii-(k-l)*phii1)
7419             sinphi1p2=dsin(l*phii+(k-l)*phii1)
7420             sinphi1m2=dsin(l*phii-(k-l)*phii1)
7421             etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+
7422      &        v1sdij*sinphi1p2+v2sdij*sinphi1m2
7423             gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2
7424      &        -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
7425             gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2
7426      &        -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
7427           enddo
7428         enddo
7429         gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*gloci1
7430         gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*gloci2
7431       enddo
7432       return
7433       end
7434 #endif
7435 c------------------------------------------------------------------------------
7436       subroutine eback_sc_corr(esccor)
7437 c 7/21/2007 Correlations between the backbone-local and side-chain-local
7438 c        conformational states; temporarily implemented as differences
7439 c        between UNRES torsional potentials (dependent on three types of
7440 c        residues) and the torsional potentials dependent on all 20 types
7441 c        of residues computed from AM1  energy surfaces of terminally-blocked
7442 c        amino-acid residues.
7443       implicit real*8 (a-h,o-z)
7444       include 'DIMENSIONS'
7445       include 'COMMON.VAR'
7446       include 'COMMON.GEO'
7447       include 'COMMON.LOCAL'
7448       include 'COMMON.TORSION'
7449       include 'COMMON.SCCOR'
7450       include 'COMMON.INTERACT'
7451       include 'COMMON.DERIV'
7452       include 'COMMON.CHAIN'
7453       include 'COMMON.NAMES'
7454       include 'COMMON.IOUNITS'
7455       include 'COMMON.FFIELD'
7456       include 'COMMON.CONTROL'
7457       logical lprn
7458 C Set lprn=.true. for debugging
7459       lprn=.false.
7460 c      lprn=.true.
7461 c      write (iout,*) "EBACK_SC_COR",itau_start,itau_end
7462       esccor=0.0D0
7463       do i=itau_start,itau_end
7464         if ((itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)) cycle
7465         esccor_ii=0.0D0
7466         isccori=isccortyp(itype(i-2))
7467         isccori1=isccortyp(itype(i-1))
7468 c      write (iout,*) "EBACK_SC_COR",i,nterm_sccor(isccori,isccori1)
7469         phii=phi(i)
7470         do intertyp=1,3 !intertyp
7471 cc Added 09 May 2012 (Adasko)
7472 cc  Intertyp means interaction type of backbone mainchain correlation:
7473 c   1 = SC...Ca...Ca...Ca
7474 c   2 = Ca...Ca...Ca...SC
7475 c   3 = SC...Ca...Ca...SCi
7476         gloci=0.0D0
7477         if (((intertyp.eq.3).and.((itype(i-2).eq.10).or.
7478      &      (itype(i-1).eq.10).or.(itype(i-2).eq.ntyp1).or.
7479      &      (itype(i-1).eq.ntyp1)))
7480      &    .or. ((intertyp.eq.1).and.((itype(i-2).eq.10)
7481      &     .or.(itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)
7482      &     .or.(itype(i).eq.ntyp1)))
7483      &    .or.((intertyp.eq.2).and.((itype(i-1).eq.10).or.
7484      &      (itype(i-1).eq.ntyp1).or.(itype(i-2).eq.ntyp1).or.
7485      &      (itype(i-3).eq.ntyp1)))) cycle
7486         if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1).eq.ntyp1)) cycle
7487         if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres).eq.ntyp1))
7488      & cycle
7489        do j=1,nterm_sccor(isccori,isccori1)
7490           v1ij=v1sccor(j,intertyp,isccori,isccori1)
7491           v2ij=v2sccor(j,intertyp,isccori,isccori1)
7492           cosphi=dcos(j*tauangle(intertyp,i))
7493           sinphi=dsin(j*tauangle(intertyp,i))
7494           esccor=esccor+v1ij*cosphi+v2ij*sinphi
7495           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7496         enddo
7497 c      write (iout,*) "EBACK_SC_COR",i,v1ij*cosphi+v2ij*sinphi,intertyp
7498         gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci
7499         if (lprn)
7500      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
7501      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,isccori,isccori1,
7502      &  (v1sccor(j,intertyp,isccori,isccori1),j=1,6)
7503      & ,(v2sccor(j,intertyp,isccori,isccori1),j=1,6)
7504         gsccor_loc(i-3)=gsccor_loc(i-3)+gloci
7505        enddo !intertyp
7506       enddo
7507
7508       return
7509       end
7510 c----------------------------------------------------------------------------
7511       subroutine multibody(ecorr)
7512 C This subroutine calculates multi-body contributions to energy following
7513 C the idea of Skolnick et al. If side chains I and J make a contact and
7514 C at the same time side chains I+1 and J+1 make a contact, an extra
7515 C contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
7516       implicit real*8 (a-h,o-z)
7517       include 'DIMENSIONS'
7518       include 'COMMON.IOUNITS'
7519       include 'COMMON.DERIV'
7520       include 'COMMON.INTERACT'
7521       include 'COMMON.CONTACTS'
7522       double precision gx(3),gx1(3)
7523       logical lprn
7524
7525 C Set lprn=.true. for debugging
7526       lprn=.false.
7527
7528       if (lprn) then
7529         write (iout,'(a)') 'Contact function values:'
7530         do i=nnt,nct-2
7531           write (iout,'(i2,20(1x,i2,f10.5))')
7532      &        i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
7533         enddo
7534       endif
7535       ecorr=0.0D0
7536       do i=nnt,nct
7537         do j=1,3
7538           gradcorr(j,i)=0.0D0
7539           gradxorr(j,i)=0.0D0
7540         enddo
7541       enddo
7542       do i=nnt,nct-2
7543
7544         DO ISHIFT = 3,4
7545
7546         i1=i+ishift
7547         num_conti=num_cont(i)
7548         num_conti1=num_cont(i1)
7549         do jj=1,num_conti
7550           j=jcont(jj,i)
7551           do kk=1,num_conti1
7552             j1=jcont(kk,i1)
7553             if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
7554 cd          write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
7555 cd   &                   ' ishift=',ishift
7556 C Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
7557 C The system gains extra energy.
7558               ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
7559             endif   ! j1==j+-ishift
7560           enddo     ! kk
7561         enddo       ! jj
7562
7563         ENDDO ! ISHIFT
7564
7565       enddo         ! i
7566       return
7567       end
7568 c------------------------------------------------------------------------------
7569       double precision function esccorr(i,j,k,l,jj,kk)
7570       implicit real*8 (a-h,o-z)
7571       include 'DIMENSIONS'
7572       include 'COMMON.IOUNITS'
7573       include 'COMMON.DERIV'
7574       include 'COMMON.INTERACT'
7575       include 'COMMON.CONTACTS'
7576       include 'COMMON.SHIELD'
7577       double precision gx(3),gx1(3)
7578       logical lprn
7579       lprn=.false.
7580       eij=facont(jj,i)
7581       ekl=facont(kk,k)
7582 cd    write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
7583 C Calculate the multi-body contribution to energy.
7584 C Calculate multi-body contributions to the gradient.
7585 cd    write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
7586 cd   & k,l,(gacont(m,kk,k),m=1,3)
7587       do m=1,3
7588         gx(m) =ekl*gacont(m,jj,i)
7589         gx1(m)=eij*gacont(m,kk,k)
7590         gradxorr(m,i)=gradxorr(m,i)-gx(m)
7591         gradxorr(m,j)=gradxorr(m,j)+gx(m)
7592         gradxorr(m,k)=gradxorr(m,k)-gx1(m)
7593         gradxorr(m,l)=gradxorr(m,l)+gx1(m)
7594       enddo
7595       do m=i,j-1
7596         do ll=1,3
7597           gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
7598         enddo
7599       enddo
7600       do m=k,l-1
7601         do ll=1,3
7602           gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
7603         enddo
7604       enddo
7605       esccorr=-eij*ekl
7606       return
7607       end
7608 c------------------------------------------------------------------------------
7609       subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
7610 C This subroutine calculates multi-body contributions to hydrogen-bonding
7611       implicit real*8 (a-h,o-z)
7612       include 'DIMENSIONS'
7613       include 'COMMON.IOUNITS'
7614 #ifdef MPI
7615       include "mpif.h"
7616       parameter (max_cont=maxconts)
7617       parameter (max_dim=26)
7618       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
7619       double precision zapas(max_dim,maxconts,max_fg_procs),
7620      &  zapas_recv(max_dim,maxconts,max_fg_procs)
7621       common /przechowalnia/ zapas
7622       integer status(MPI_STATUS_SIZE),req(maxconts*2),
7623      &  status_array(MPI_STATUS_SIZE,maxconts*2)
7624 #endif
7625       include 'COMMON.SETUP'
7626       include 'COMMON.FFIELD'
7627       include 'COMMON.DERIV'
7628       include 'COMMON.INTERACT'
7629       include 'COMMON.CONTACTS'
7630       include 'COMMON.CONTROL'
7631       include 'COMMON.LOCAL'
7632       double precision gx(3),gx1(3),time00
7633       logical lprn,ldone
7634
7635 C Set lprn=.true. for debugging
7636       lprn=.false.
7637 #ifdef MPI
7638       n_corr=0
7639       n_corr1=0
7640       if (nfgtasks.le.1) goto 30
7641       if (lprn) then
7642         write (iout,'(a)') 'Contact function values before RECEIVE:'
7643         do i=nnt,nct-2
7644           write (iout,'(2i3,50(1x,i2,f5.2))')
7645      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
7646      &    j=1,num_cont_hb(i))
7647         enddo
7648       endif
7649       call flush(iout)
7650       do i=1,ntask_cont_from
7651         ncont_recv(i)=0
7652       enddo
7653       do i=1,ntask_cont_to
7654         ncont_sent(i)=0
7655       enddo
7656 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
7657 c     & ntask_cont_to
7658 C Make the list of contacts to send to send to other procesors
7659 c      write (iout,*) "limits",max0(iturn4_end-1,iatel_s),iturn3_end
7660 c      call flush(iout)
7661       do i=iturn3_start,iturn3_end
7662 c        write (iout,*) "make contact list turn3",i," num_cont",
7663 c     &    num_cont_hb(i)
7664         call add_hb_contact(i,i+2,iturn3_sent_local(1,i))
7665       enddo
7666       do i=iturn4_start,iturn4_end
7667 c        write (iout,*) "make contact list turn4",i," num_cont",
7668 c     &   num_cont_hb(i)
7669         call add_hb_contact(i,i+3,iturn4_sent_local(1,i))
7670       enddo
7671       do ii=1,nat_sent
7672         i=iat_sent(ii)
7673 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
7674 c     &    num_cont_hb(i)
7675         do j=1,num_cont_hb(i)
7676         do k=1,4
7677           jjc=jcont_hb(j,i)
7678           iproc=iint_sent_local(k,jjc,ii)
7679 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
7680           if (iproc.gt.0) then
7681             ncont_sent(iproc)=ncont_sent(iproc)+1
7682             nn=ncont_sent(iproc)
7683             zapas(1,nn,iproc)=i
7684             zapas(2,nn,iproc)=jjc
7685             zapas(3,nn,iproc)=facont_hb(j,i)
7686             zapas(4,nn,iproc)=ees0p(j,i)
7687             zapas(5,nn,iproc)=ees0m(j,i)
7688             zapas(6,nn,iproc)=gacont_hbr(1,j,i)
7689             zapas(7,nn,iproc)=gacont_hbr(2,j,i)
7690             zapas(8,nn,iproc)=gacont_hbr(3,j,i)
7691             zapas(9,nn,iproc)=gacontm_hb1(1,j,i)
7692             zapas(10,nn,iproc)=gacontm_hb1(2,j,i)
7693             zapas(11,nn,iproc)=gacontm_hb1(3,j,i)
7694             zapas(12,nn,iproc)=gacontp_hb1(1,j,i)
7695             zapas(13,nn,iproc)=gacontp_hb1(2,j,i)
7696             zapas(14,nn,iproc)=gacontp_hb1(3,j,i)
7697             zapas(15,nn,iproc)=gacontm_hb2(1,j,i)
7698             zapas(16,nn,iproc)=gacontm_hb2(2,j,i)
7699             zapas(17,nn,iproc)=gacontm_hb2(3,j,i)
7700             zapas(18,nn,iproc)=gacontp_hb2(1,j,i)
7701             zapas(19,nn,iproc)=gacontp_hb2(2,j,i)
7702             zapas(20,nn,iproc)=gacontp_hb2(3,j,i)
7703             zapas(21,nn,iproc)=gacontm_hb3(1,j,i)
7704             zapas(22,nn,iproc)=gacontm_hb3(2,j,i)
7705             zapas(23,nn,iproc)=gacontm_hb3(3,j,i)
7706             zapas(24,nn,iproc)=gacontp_hb3(1,j,i)
7707             zapas(25,nn,iproc)=gacontp_hb3(2,j,i)
7708             zapas(26,nn,iproc)=gacontp_hb3(3,j,i)
7709           endif
7710         enddo
7711         enddo
7712       enddo
7713       if (lprn) then
7714       write (iout,*)
7715      &  "Numbers of contacts to be sent to other processors",
7716      &  (ncont_sent(i),i=1,ntask_cont_to)
7717       write (iout,*) "Contacts sent"
7718       do ii=1,ntask_cont_to
7719         nn=ncont_sent(ii)
7720         iproc=itask_cont_to(ii)
7721         write (iout,*) nn," contacts to processor",iproc,
7722      &   " of CONT_TO_COMM group"
7723         do i=1,nn
7724           write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
7725         enddo
7726       enddo
7727       call flush(iout)
7728       endif
7729       CorrelType=477
7730       CorrelID=fg_rank+1
7731       CorrelType1=478
7732       CorrelID1=nfgtasks+fg_rank+1
7733       ireq=0
7734 C Receive the numbers of needed contacts from other processors
7735       do ii=1,ntask_cont_from
7736         iproc=itask_cont_from(ii)
7737         ireq=ireq+1
7738         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
7739      &    FG_COMM,req(ireq),IERR)
7740       enddo
7741 c      write (iout,*) "IRECV ended"
7742 c      call flush(iout)
7743 C Send the number of contacts needed by other processors
7744       do ii=1,ntask_cont_to
7745         iproc=itask_cont_to(ii)
7746         ireq=ireq+1
7747         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
7748      &    FG_COMM,req(ireq),IERR)
7749       enddo
7750 c      write (iout,*) "ISEND ended"
7751 c      write (iout,*) "number of requests (nn)",ireq
7752       call flush(iout)
7753       if (ireq.gt.0)
7754      &  call MPI_Waitall(ireq,req,status_array,ierr)
7755 c      write (iout,*)
7756 c     &  "Numbers of contacts to be received from other processors",
7757 c     &  (ncont_recv(i),i=1,ntask_cont_from)
7758 c      call flush(iout)
7759 C Receive contacts
7760       ireq=0
7761       do ii=1,ntask_cont_from
7762         iproc=itask_cont_from(ii)
7763         nn=ncont_recv(ii)
7764 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
7765 c     &   " of CONT_TO_COMM group"
7766         call flush(iout)
7767         if (nn.gt.0) then
7768           ireq=ireq+1
7769           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
7770      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
7771 c          write (iout,*) "ireq,req",ireq,req(ireq)
7772         endif
7773       enddo
7774 C Send the contacts to processors that need them
7775       do ii=1,ntask_cont_to
7776         iproc=itask_cont_to(ii)
7777         nn=ncont_sent(ii)
7778 c        write (iout,*) nn," contacts to processor",iproc,
7779 c     &   " of CONT_TO_COMM group"
7780         if (nn.gt.0) then
7781           ireq=ireq+1
7782           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
7783      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
7784 c          write (iout,*) "ireq,req",ireq,req(ireq)
7785 c          do i=1,nn
7786 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
7787 c          enddo
7788         endif
7789       enddo
7790 c      write (iout,*) "number of requests (contacts)",ireq
7791 c      write (iout,*) "req",(req(i),i=1,4)
7792 c      call flush(iout)
7793       if (ireq.gt.0)
7794      & call MPI_Waitall(ireq,req,status_array,ierr)
7795       do iii=1,ntask_cont_from
7796         iproc=itask_cont_from(iii)
7797         nn=ncont_recv(iii)
7798         if (lprn) then
7799         write (iout,*) "Received",nn," contacts from processor",iproc,
7800      &   " of CONT_FROM_COMM group"
7801         call flush(iout)
7802         do i=1,nn
7803           write(iout,'(2f5.0,4f10.5)')(zapas_recv(j,i,iii),j=1,5)
7804         enddo
7805         call flush(iout)
7806         endif
7807         do i=1,nn
7808           ii=zapas_recv(1,i,iii)
7809 c Flag the received contacts to prevent double-counting
7810           jj=-zapas_recv(2,i,iii)
7811 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
7812 c          call flush(iout)
7813           nnn=num_cont_hb(ii)+1
7814           num_cont_hb(ii)=nnn
7815           jcont_hb(nnn,ii)=jj
7816           facont_hb(nnn,ii)=zapas_recv(3,i,iii)
7817           ees0p(nnn,ii)=zapas_recv(4,i,iii)
7818           ees0m(nnn,ii)=zapas_recv(5,i,iii)
7819           gacont_hbr(1,nnn,ii)=zapas_recv(6,i,iii)
7820           gacont_hbr(2,nnn,ii)=zapas_recv(7,i,iii)
7821           gacont_hbr(3,nnn,ii)=zapas_recv(8,i,iii)
7822           gacontm_hb1(1,nnn,ii)=zapas_recv(9,i,iii)
7823           gacontm_hb1(2,nnn,ii)=zapas_recv(10,i,iii)
7824           gacontm_hb1(3,nnn,ii)=zapas_recv(11,i,iii)
7825           gacontp_hb1(1,nnn,ii)=zapas_recv(12,i,iii)
7826           gacontp_hb1(2,nnn,ii)=zapas_recv(13,i,iii)
7827           gacontp_hb1(3,nnn,ii)=zapas_recv(14,i,iii)
7828           gacontm_hb2(1,nnn,ii)=zapas_recv(15,i,iii)
7829           gacontm_hb2(2,nnn,ii)=zapas_recv(16,i,iii)
7830           gacontm_hb2(3,nnn,ii)=zapas_recv(17,i,iii)
7831           gacontp_hb2(1,nnn,ii)=zapas_recv(18,i,iii)
7832           gacontp_hb2(2,nnn,ii)=zapas_recv(19,i,iii)
7833           gacontp_hb2(3,nnn,ii)=zapas_recv(20,i,iii)
7834           gacontm_hb3(1,nnn,ii)=zapas_recv(21,i,iii)
7835           gacontm_hb3(2,nnn,ii)=zapas_recv(22,i,iii)
7836           gacontm_hb3(3,nnn,ii)=zapas_recv(23,i,iii)
7837           gacontp_hb3(1,nnn,ii)=zapas_recv(24,i,iii)
7838           gacontp_hb3(2,nnn,ii)=zapas_recv(25,i,iii)
7839           gacontp_hb3(3,nnn,ii)=zapas_recv(26,i,iii)
7840         enddo
7841       enddo
7842       call flush(iout)
7843       if (lprn) then
7844         write (iout,'(a)') 'Contact function values after receive:'
7845         do i=nnt,nct-2
7846           write (iout,'(2i3,50(1x,i3,f5.2))')
7847      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
7848      &    j=1,num_cont_hb(i))
7849         enddo
7850         call flush(iout)
7851       endif
7852    30 continue
7853 #endif
7854       if (lprn) then
7855         write (iout,'(a)') 'Contact function values:'
7856         do i=nnt,nct-2
7857           write (iout,'(2i3,50(1x,i3,f5.2))')
7858      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
7859      &    j=1,num_cont_hb(i))
7860         enddo
7861       endif
7862       ecorr=0.0D0
7863 C Remove the loop below after debugging !!!
7864       do i=nnt,nct
7865         do j=1,3
7866           gradcorr(j,i)=0.0D0
7867           gradxorr(j,i)=0.0D0
7868         enddo
7869       enddo
7870 C Calculate the local-electrostatic correlation terms
7871       do i=min0(iatel_s,iturn4_start),max0(iatel_e,iturn3_end)
7872         i1=i+1
7873         num_conti=num_cont_hb(i)
7874         num_conti1=num_cont_hb(i+1)
7875         do jj=1,num_conti
7876           j=jcont_hb(jj,i)
7877           jp=iabs(j)
7878           do kk=1,num_conti1
7879             j1=jcont_hb(kk,i1)
7880             jp1=iabs(j1)
7881 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
7882 c     &         ' jj=',jj,' kk=',kk
7883             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
7884      &          .or. j.lt.0 .and. j1.gt.0) .and.
7885      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
7886 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
7887 C The system gains extra energy.
7888               ecorr=ecorr+ehbcorr(i,jp,i+1,jp1,jj,kk,0.72D0,0.32D0)
7889               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
7890      &            'ecorrh',i,j,ehbcorr(i,j,i+1,j1,jj,kk,0.72D0,0.32D0)
7891               n_corr=n_corr+1
7892             else if (j1.eq.j) then
7893 C Contacts I-J and I-(J+1) occur simultaneously.
7894 C The system loses extra energy.
7895 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
7896             endif
7897           enddo ! kk
7898           do kk=1,num_conti
7899             j1=jcont_hb(kk,i)
7900 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
7901 c    &         ' jj=',jj,' kk=',kk
7902             if (j1.eq.j+1) then
7903 C Contacts I-J and (I+1)-J occur simultaneously.
7904 C The system loses extra energy.
7905 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
7906             endif ! j1==j+1
7907           enddo ! kk
7908         enddo ! jj
7909       enddo ! i
7910       return
7911       end
7912 c------------------------------------------------------------------------------
7913       subroutine add_hb_contact(ii,jj,itask)
7914       implicit real*8 (a-h,o-z)
7915       include "DIMENSIONS"
7916       include "COMMON.IOUNITS"
7917       integer max_cont
7918       integer max_dim
7919       parameter (max_cont=maxconts)
7920       parameter (max_dim=26)
7921       include "COMMON.CONTACTS"
7922       double precision zapas(max_dim,maxconts,max_fg_procs),
7923      &  zapas_recv(max_dim,maxconts,max_fg_procs)
7924       common /przechowalnia/ zapas
7925       integer i,j,ii,jj,iproc,itask(4),nn
7926 c      write (iout,*) "itask",itask
7927       do i=1,2
7928         iproc=itask(i)
7929         if (iproc.gt.0) then
7930           do j=1,num_cont_hb(ii)
7931             jjc=jcont_hb(j,ii)
7932 c            write (iout,*) "i",ii," j",jj," jjc",jjc
7933             if (jjc.eq.jj) then
7934               ncont_sent(iproc)=ncont_sent(iproc)+1
7935               nn=ncont_sent(iproc)
7936               zapas(1,nn,iproc)=ii
7937               zapas(2,nn,iproc)=jjc
7938               zapas(3,nn,iproc)=facont_hb(j,ii)
7939               zapas(4,nn,iproc)=ees0p(j,ii)
7940               zapas(5,nn,iproc)=ees0m(j,ii)
7941               zapas(6,nn,iproc)=gacont_hbr(1,j,ii)
7942               zapas(7,nn,iproc)=gacont_hbr(2,j,ii)
7943               zapas(8,nn,iproc)=gacont_hbr(3,j,ii)
7944               zapas(9,nn,iproc)=gacontm_hb1(1,j,ii)
7945               zapas(10,nn,iproc)=gacontm_hb1(2,j,ii)
7946               zapas(11,nn,iproc)=gacontm_hb1(3,j,ii)
7947               zapas(12,nn,iproc)=gacontp_hb1(1,j,ii)
7948               zapas(13,nn,iproc)=gacontp_hb1(2,j,ii)
7949               zapas(14,nn,iproc)=gacontp_hb1(3,j,ii)
7950               zapas(15,nn,iproc)=gacontm_hb2(1,j,ii)
7951               zapas(16,nn,iproc)=gacontm_hb2(2,j,ii)
7952               zapas(17,nn,iproc)=gacontm_hb2(3,j,ii)
7953               zapas(18,nn,iproc)=gacontp_hb2(1,j,ii)
7954               zapas(19,nn,iproc)=gacontp_hb2(2,j,ii)
7955               zapas(20,nn,iproc)=gacontp_hb2(3,j,ii)
7956               zapas(21,nn,iproc)=gacontm_hb3(1,j,ii)
7957               zapas(22,nn,iproc)=gacontm_hb3(2,j,ii)
7958               zapas(23,nn,iproc)=gacontm_hb3(3,j,ii)
7959               zapas(24,nn,iproc)=gacontp_hb3(1,j,ii)
7960               zapas(25,nn,iproc)=gacontp_hb3(2,j,ii)
7961               zapas(26,nn,iproc)=gacontp_hb3(3,j,ii)
7962               exit
7963             endif
7964           enddo
7965         endif
7966       enddo
7967       return
7968       end
7969 c------------------------------------------------------------------------------
7970       subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,
7971      &  n_corr1)
7972 C This subroutine calculates multi-body contributions to hydrogen-bonding
7973       implicit real*8 (a-h,o-z)
7974       include 'DIMENSIONS'
7975       include 'COMMON.IOUNITS'
7976 #ifdef MPI
7977       include "mpif.h"
7978       parameter (max_cont=maxconts)
7979       parameter (max_dim=70)
7980       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
7981       double precision zapas(max_dim,maxconts,max_fg_procs),
7982      &  zapas_recv(max_dim,maxconts,max_fg_procs)
7983       common /przechowalnia/ zapas
7984       integer status(MPI_STATUS_SIZE),req(maxconts*2),
7985      &  status_array(MPI_STATUS_SIZE,maxconts*2)
7986 #endif
7987       include 'COMMON.SETUP'
7988       include 'COMMON.FFIELD'
7989       include 'COMMON.DERIV'
7990       include 'COMMON.LOCAL'
7991       include 'COMMON.INTERACT'
7992       include 'COMMON.CONTACTS'
7993       include 'COMMON.CHAIN'
7994       include 'COMMON.CONTROL'
7995       include 'COMMON.SHIELD'
7996       double precision gx(3),gx1(3)
7997       integer num_cont_hb_old(maxres)
7998       logical lprn,ldone
7999       double precision eello4,eello5,eelo6,eello_turn6
8000       external eello4,eello5,eello6,eello_turn6
8001 C Set lprn=.true. for debugging
8002       lprn=.false.
8003       eturn6=0.0d0
8004 #ifdef MPI
8005       do i=1,nres
8006         num_cont_hb_old(i)=num_cont_hb(i)
8007       enddo
8008       n_corr=0
8009       n_corr1=0
8010       if (nfgtasks.le.1) goto 30
8011       if (lprn) then
8012         write (iout,'(a)') 'Contact function values before RECEIVE:'
8013         do i=nnt,nct-2
8014           write (iout,'(2i3,50(1x,i2,f5.2))')
8015      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
8016      &    j=1,num_cont_hb(i))
8017         enddo
8018       endif
8019       call flush(iout)
8020       do i=1,ntask_cont_from
8021         ncont_recv(i)=0
8022       enddo
8023       do i=1,ntask_cont_to
8024         ncont_sent(i)=0
8025       enddo
8026 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
8027 c     & ntask_cont_to
8028 C Make the list of contacts to send to send to other procesors
8029       do i=iturn3_start,iturn3_end
8030 c        write (iout,*) "make contact list turn3",i," num_cont",
8031 c     &    num_cont_hb(i)
8032         call add_hb_contact_eello(i,i+2,iturn3_sent_local(1,i))
8033       enddo
8034       do i=iturn4_start,iturn4_end
8035 c        write (iout,*) "make contact list turn4",i," num_cont",
8036 c     &   num_cont_hb(i)
8037         call add_hb_contact_eello(i,i+3,iturn4_sent_local(1,i))
8038       enddo
8039       do ii=1,nat_sent
8040         i=iat_sent(ii)
8041 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
8042 c     &    num_cont_hb(i)
8043         do j=1,num_cont_hb(i)
8044         do k=1,4
8045           jjc=jcont_hb(j,i)
8046           iproc=iint_sent_local(k,jjc,ii)
8047 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
8048           if (iproc.ne.0) then
8049             ncont_sent(iproc)=ncont_sent(iproc)+1
8050             nn=ncont_sent(iproc)
8051             zapas(1,nn,iproc)=i
8052             zapas(2,nn,iproc)=jjc
8053             zapas(3,nn,iproc)=d_cont(j,i)
8054             ind=3
8055             do kk=1,3
8056               ind=ind+1
8057               zapas(ind,nn,iproc)=grij_hb_cont(kk,j,i)
8058             enddo
8059             do kk=1,2
8060               do ll=1,2
8061                 ind=ind+1
8062                 zapas(ind,nn,iproc)=a_chuj(ll,kk,j,i)
8063               enddo
8064             enddo
8065             do jj=1,5
8066               do kk=1,3
8067                 do ll=1,2
8068                   do mm=1,2
8069                     ind=ind+1
8070                     zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,i)
8071                   enddo
8072                 enddo
8073               enddo
8074             enddo
8075           endif
8076         enddo
8077         enddo
8078       enddo
8079       if (lprn) then
8080       write (iout,*)
8081      &  "Numbers of contacts to be sent to other processors",
8082      &  (ncont_sent(i),i=1,ntask_cont_to)
8083       write (iout,*) "Contacts sent"
8084       do ii=1,ntask_cont_to
8085         nn=ncont_sent(ii)
8086         iproc=itask_cont_to(ii)
8087         write (iout,*) nn," contacts to processor",iproc,
8088      &   " of CONT_TO_COMM group"
8089         do i=1,nn
8090           write(iout,'(2f5.0,10f10.5)')(zapas(j,i,ii),j=1,10)
8091         enddo
8092       enddo
8093       call flush(iout)
8094       endif
8095       CorrelType=477
8096       CorrelID=fg_rank+1
8097       CorrelType1=478
8098       CorrelID1=nfgtasks+fg_rank+1
8099       ireq=0
8100 C Receive the numbers of needed contacts from other processors
8101       do ii=1,ntask_cont_from
8102         iproc=itask_cont_from(ii)
8103         ireq=ireq+1
8104         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
8105      &    FG_COMM,req(ireq),IERR)
8106       enddo
8107 c      write (iout,*) "IRECV ended"
8108 c      call flush(iout)
8109 C Send the number of contacts needed by other processors
8110       do ii=1,ntask_cont_to
8111         iproc=itask_cont_to(ii)
8112         ireq=ireq+1
8113         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
8114      &    FG_COMM,req(ireq),IERR)
8115       enddo
8116 c      write (iout,*) "ISEND ended"
8117 c      write (iout,*) "number of requests (nn)",ireq
8118       call flush(iout)
8119       if (ireq.gt.0)
8120      &  call MPI_Waitall(ireq,req,status_array,ierr)
8121 c      write (iout,*)
8122 c     &  "Numbers of contacts to be received from other processors",
8123 c     &  (ncont_recv(i),i=1,ntask_cont_from)
8124 c      call flush(iout)
8125 C Receive contacts
8126       ireq=0
8127       do ii=1,ntask_cont_from
8128         iproc=itask_cont_from(ii)
8129         nn=ncont_recv(ii)
8130 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
8131 c     &   " of CONT_TO_COMM group"
8132         call flush(iout)
8133         if (nn.gt.0) then
8134           ireq=ireq+1
8135           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
8136      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
8137 c          write (iout,*) "ireq,req",ireq,req(ireq)
8138         endif
8139       enddo
8140 C Send the contacts to processors that need them
8141       do ii=1,ntask_cont_to
8142         iproc=itask_cont_to(ii)
8143         nn=ncont_sent(ii)
8144 c        write (iout,*) nn," contacts to processor",iproc,
8145 c     &   " of CONT_TO_COMM group"
8146         if (nn.gt.0) then
8147           ireq=ireq+1
8148           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
8149      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
8150 c          write (iout,*) "ireq,req",ireq,req(ireq)
8151 c          do i=1,nn
8152 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
8153 c          enddo
8154         endif
8155       enddo
8156 c      write (iout,*) "number of requests (contacts)",ireq
8157 c      write (iout,*) "req",(req(i),i=1,4)
8158 c      call flush(iout)
8159       if (ireq.gt.0)
8160      & call MPI_Waitall(ireq,req,status_array,ierr)
8161       do iii=1,ntask_cont_from
8162         iproc=itask_cont_from(iii)
8163         nn=ncont_recv(iii)
8164         if (lprn) then
8165         write (iout,*) "Received",nn," contacts from processor",iproc,
8166      &   " of CONT_FROM_COMM group"
8167         call flush(iout)
8168         do i=1,nn
8169           write(iout,'(2f5.0,10f10.5)')(zapas_recv(j,i,iii),j=1,10)
8170         enddo
8171         call flush(iout)
8172         endif
8173         do i=1,nn
8174           ii=zapas_recv(1,i,iii)
8175 c Flag the received contacts to prevent double-counting
8176           jj=-zapas_recv(2,i,iii)
8177 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
8178 c          call flush(iout)
8179           nnn=num_cont_hb(ii)+1
8180           num_cont_hb(ii)=nnn
8181           jcont_hb(nnn,ii)=jj
8182           d_cont(nnn,ii)=zapas_recv(3,i,iii)
8183           ind=3
8184           do kk=1,3
8185             ind=ind+1
8186             grij_hb_cont(kk,nnn,ii)=zapas_recv(ind,i,iii)
8187           enddo
8188           do kk=1,2
8189             do ll=1,2
8190               ind=ind+1
8191               a_chuj(ll,kk,nnn,ii)=zapas_recv(ind,i,iii)
8192             enddo
8193           enddo
8194           do jj=1,5
8195             do kk=1,3
8196               do ll=1,2
8197                 do mm=1,2
8198                   ind=ind+1
8199                   a_chuj_der(mm,ll,kk,jj,nnn,ii)=zapas_recv(ind,i,iii)
8200                 enddo
8201               enddo
8202             enddo
8203           enddo
8204         enddo
8205       enddo
8206       call flush(iout)
8207       if (lprn) then
8208         write (iout,'(a)') 'Contact function values after receive:'
8209         do i=nnt,nct-2
8210           write (iout,'(2i3,50(1x,i3,5f6.3))')
8211      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
8212      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
8213         enddo
8214         call flush(iout)
8215       endif
8216    30 continue
8217 #endif
8218       if (lprn) then
8219         write (iout,'(a)') 'Contact function values:'
8220         do i=nnt,nct-2
8221           write (iout,'(2i3,50(1x,i2,5f6.3))')
8222      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
8223      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
8224         enddo
8225       endif
8226       ecorr=0.0D0
8227       ecorr5=0.0d0
8228       ecorr6=0.0d0
8229 C Remove the loop below after debugging !!!
8230       do i=nnt,nct
8231         do j=1,3
8232           gradcorr(j,i)=0.0D0
8233           gradxorr(j,i)=0.0D0
8234         enddo
8235       enddo
8236 C Calculate the dipole-dipole interaction energies
8237       if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
8238       do i=iatel_s,iatel_e+1
8239         num_conti=num_cont_hb(i)
8240         do jj=1,num_conti
8241           j=jcont_hb(jj,i)
8242 #ifdef MOMENT
8243           call dipole(i,j,jj)
8244 #endif
8245         enddo
8246       enddo
8247       endif
8248 C Calculate the local-electrostatic correlation terms
8249 c                write (iout,*) "gradcorr5 in eello5 before loop"
8250 c                do iii=1,nres
8251 c                  write (iout,'(i5,3f10.5)')
8252 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
8253 c                enddo
8254       do i=min0(iatel_s,iturn4_start),max0(iatel_e+1,iturn3_end+1)
8255 c        write (iout,*) "corr loop i",i
8256         i1=i+1
8257         num_conti=num_cont_hb(i)
8258         num_conti1=num_cont_hb(i+1)
8259         do jj=1,num_conti
8260           j=jcont_hb(jj,i)
8261           jp=iabs(j)
8262           do kk=1,num_conti1
8263             j1=jcont_hb(kk,i1)
8264             jp1=iabs(j1)
8265 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
8266 c     &         ' jj=',jj,' kk=',kk
8267 c            if (j1.eq.j+1 .or. j1.eq.j-1) then
8268             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
8269      &          .or. j.lt.0 .and. j1.gt.0) .and.
8270      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
8271 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
8272 C The system gains extra energy.
8273               n_corr=n_corr+1
8274               sqd1=dsqrt(d_cont(jj,i))
8275               sqd2=dsqrt(d_cont(kk,i1))
8276               sred_geom = sqd1*sqd2
8277               IF (sred_geom.lt.cutoff_corr) THEN
8278                 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,
8279      &            ekont,fprimcont)
8280 cd               write (iout,*) 'i=',i,' j=',jp,' i1=',i1,' j1=',jp1,
8281 cd     &         ' jj=',jj,' kk=',kk
8282                 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
8283                 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
8284                 do l=1,3
8285                   g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
8286                   g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
8287                 enddo
8288                 n_corr1=n_corr1+1
8289 cd               write (iout,*) 'sred_geom=',sred_geom,
8290 cd     &          ' ekont=',ekont,' fprim=',fprimcont,
8291 cd     &          ' fac_prim1',fac_prim1,' fac_prim2',fac_prim2
8292 cd               write (iout,*) "g_contij",g_contij
8293 cd               write (iout,*) "grij_hb_cont i",grij_hb_cont(:,jj,i)
8294 cd               write (iout,*) "grij_hb_cont i1",grij_hb_cont(:,jj,i1)
8295                 call calc_eello(i,jp,i+1,jp1,jj,kk)
8296                 if (wcorr4.gt.0.0d0)
8297      &            ecorr=ecorr+eello4(i,jp,i+1,jp1,jj,kk)
8298 CC     &            *fac_shield(i)**2*fac_shield(j)**2
8299                   if (energy_dec.and.wcorr4.gt.0.0d0)
8300      1                 write (iout,'(a6,4i5,0pf7.3)')
8301      2                'ecorr4',i,j,i+1,j1,eello4(i,jp,i+1,jp1,jj,kk)
8302 c                write (iout,*) "gradcorr5 before eello5"
8303 c                do iii=1,nres
8304 c                  write (iout,'(i5,3f10.5)')
8305 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
8306 c                enddo
8307                 if (wcorr5.gt.0.0d0)
8308      &            ecorr5=ecorr5+eello5(i,jp,i+1,jp1,jj,kk)
8309 c                write (iout,*) "gradcorr5 after eello5"
8310 c                do iii=1,nres
8311 c                  write (iout,'(i5,3f10.5)')
8312 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
8313 c                enddo
8314                   if (energy_dec.and.wcorr5.gt.0.0d0)
8315      1                 write (iout,'(a6,4i5,0pf7.3)')
8316      2                'ecorr5',i,j,i+1,j1,eello5(i,jp,i+1,jp1,jj,kk)
8317 cd                write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
8318 cd                write(2,*)'ijkl',i,jp,i+1,jp1
8319                 if (wcorr6.gt.0.0d0 .and. (jp.ne.i+4 .or. jp1.ne.i+3
8320      &               .or. wturn6.eq.0.0d0))then
8321 cd                  write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
8322                   ecorr6=ecorr6+eello6(i,jp,i+1,jp1,jj,kk)
8323                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
8324      1                'ecorr6',i,j,i+1,j1,eello6(i,jp,i+1,jp1,jj,kk)
8325 cd                write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
8326 cd     &            'ecorr6=',ecorr6
8327 cd                write (iout,'(4e15.5)') sred_geom,
8328 cd     &          dabs(eello4(i,jp,i+1,jp1,jj,kk)),
8329 cd     &          dabs(eello5(i,jp,i+1,jp1,jj,kk)),
8330 cd     &          dabs(eello6(i,jp,i+1,jp1,jj,kk))
8331                 else if (wturn6.gt.0.0d0
8332      &            .and. (jp.eq.i+4 .and. jp1.eq.i+3)) then
8333 cd                  write (iout,*) '******eturn6: i,j,i+1,j1',i,jip,i+1,jp1
8334                   eturn6=eturn6+eello_turn6(i,jj,kk)
8335                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
8336      1                 'eturn6',i,j,i+1,j1,eello_turn6(i,jj,kk)
8337 cd                  write (2,*) 'multibody_eello:eturn6',eturn6
8338                 endif
8339               ENDIF
8340 1111          continue
8341             endif
8342           enddo ! kk
8343         enddo ! jj
8344       enddo ! i
8345       do i=1,nres
8346         num_cont_hb(i)=num_cont_hb_old(i)
8347       enddo
8348 c                write (iout,*) "gradcorr5 in eello5"
8349 c                do iii=1,nres
8350 c                  write (iout,'(i5,3f10.5)')
8351 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
8352 c                enddo
8353       return
8354       end
8355 c------------------------------------------------------------------------------
8356       subroutine add_hb_contact_eello(ii,jj,itask)
8357       implicit real*8 (a-h,o-z)
8358       include "DIMENSIONS"
8359       include "COMMON.IOUNITS"
8360       integer max_cont
8361       integer max_dim
8362       parameter (max_cont=maxconts)
8363       parameter (max_dim=70)
8364       include "COMMON.CONTACTS"
8365       double precision zapas(max_dim,maxconts,max_fg_procs),
8366      &  zapas_recv(max_dim,maxconts,max_fg_procs)
8367       common /przechowalnia/ zapas
8368       integer i,j,ii,jj,iproc,itask(4),nn
8369 c      write (iout,*) "itask",itask
8370       do i=1,2
8371         iproc=itask(i)
8372         if (iproc.gt.0) then
8373           do j=1,num_cont_hb(ii)
8374             jjc=jcont_hb(j,ii)
8375 c            write (iout,*) "send turns i",ii," j",jj," jjc",jjc
8376             if (jjc.eq.jj) then
8377               ncont_sent(iproc)=ncont_sent(iproc)+1
8378               nn=ncont_sent(iproc)
8379               zapas(1,nn,iproc)=ii
8380               zapas(2,nn,iproc)=jjc
8381               zapas(3,nn,iproc)=d_cont(j,ii)
8382               ind=3
8383               do kk=1,3
8384                 ind=ind+1
8385                 zapas(ind,nn,iproc)=grij_hb_cont(kk,j,ii)
8386               enddo
8387               do kk=1,2
8388                 do ll=1,2
8389                   ind=ind+1
8390                   zapas(ind,nn,iproc)=a_chuj(ll,kk,j,ii)
8391                 enddo
8392               enddo
8393               do jj=1,5
8394                 do kk=1,3
8395                   do ll=1,2
8396                     do mm=1,2
8397                       ind=ind+1
8398                       zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,ii)
8399                     enddo
8400                   enddo
8401                 enddo
8402               enddo
8403               exit
8404             endif
8405           enddo
8406         endif
8407       enddo
8408       return
8409       end
8410 c------------------------------------------------------------------------------
8411       double precision function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
8412       implicit real*8 (a-h,o-z)
8413       include 'DIMENSIONS'
8414       include 'COMMON.IOUNITS'
8415       include 'COMMON.DERIV'
8416       include 'COMMON.INTERACT'
8417       include 'COMMON.CONTACTS'
8418       include 'COMMON.SHIELD'
8419       include 'COMMON.CONTROL'
8420       double precision gx(3),gx1(3)
8421       logical lprn
8422       lprn=.false.
8423 C      print *,"wchodze",fac_shield(i),shield_mode
8424       eij=facont_hb(jj,i)
8425       ekl=facont_hb(kk,k)
8426       ees0pij=ees0p(jj,i)
8427       ees0pkl=ees0p(kk,k)
8428       ees0mij=ees0m(jj,i)
8429       ees0mkl=ees0m(kk,k)
8430       ekont=eij*ekl
8431       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
8432 C*
8433 C     & fac_shield(i)**2*fac_shield(j)**2
8434 cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
8435 C Following 4 lines for diagnostics.
8436 cd    ees0pkl=0.0D0
8437 cd    ees0pij=1.0D0
8438 cd    ees0mkl=0.0D0
8439 cd    ees0mij=1.0D0
8440 c      write (iout,'(2(a,2i3,a,f10.5,a,2f10.5),a,f10.5,a,$)')
8441 c     & 'Contacts ',i,j,
8442 c     & ' eij',eij,' eesij',ees0pij,ees0mij,' and ',k,l
8443 c     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' energy=',ekont*ees,
8444 c     & 'gradcorr_long'
8445 C Calculate the multi-body contribution to energy.
8446 c      ecorr=ecorr+ekont*ees
8447 C Calculate multi-body contributions to the gradient.
8448       coeffpees0pij=coeffp*ees0pij
8449       coeffmees0mij=coeffm*ees0mij
8450       coeffpees0pkl=coeffp*ees0pkl
8451       coeffmees0mkl=coeffm*ees0mkl
8452       do ll=1,3
8453 cgrad        ghalfi=ees*ekl*gacont_hbr(ll,jj,i)
8454         gradcorr(ll,i)=gradcorr(ll,i)!+0.5d0*ghalfi
8455      &  -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+
8456      &  coeffmees0mkl*gacontm_hb1(ll,jj,i))
8457         gradcorr(ll,j)=gradcorr(ll,j)!+0.5d0*ghalfi
8458      &  -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+
8459      &  coeffmees0mkl*gacontm_hb2(ll,jj,i))
8460 cgrad        ghalfk=ees*eij*gacont_hbr(ll,kk,k)
8461         gradcorr(ll,k)=gradcorr(ll,k)!+0.5d0*ghalfk
8462      &  -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+
8463      &  coeffmees0mij*gacontm_hb1(ll,kk,k))
8464         gradcorr(ll,l)=gradcorr(ll,l)!+0.5d0*ghalfk
8465      &  -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+
8466      &  coeffmees0mij*gacontm_hb2(ll,kk,k))
8467         gradlongij=ees*ekl*gacont_hbr(ll,jj,i)-
8468      &     ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+
8469      &     coeffmees0mkl*gacontm_hb3(ll,jj,i))
8470         gradcorr_long(ll,j)=gradcorr_long(ll,j)+gradlongij
8471         gradcorr_long(ll,i)=gradcorr_long(ll,i)-gradlongij
8472         gradlongkl=ees*eij*gacont_hbr(ll,kk,k)-
8473      &     ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+
8474      &     coeffmees0mij*gacontm_hb3(ll,kk,k))
8475         gradcorr_long(ll,l)=gradcorr_long(ll,l)+gradlongkl
8476         gradcorr_long(ll,k)=gradcorr_long(ll,k)-gradlongkl
8477 c        write (iout,'(2f10.5,2x,$)') gradlongij,gradlongkl
8478       enddo
8479 c      write (iout,*)
8480 cgrad      do m=i+1,j-1
8481 cgrad        do ll=1,3
8482 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
8483 cgrad     &     ees*ekl*gacont_hbr(ll,jj,i)-
8484 cgrad     &     ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
8485 cgrad     &     coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
8486 cgrad        enddo
8487 cgrad      enddo
8488 cgrad      do m=k+1,l-1
8489 cgrad        do ll=1,3
8490 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
8491 cgrad     &     ees*eij*gacont_hbr(ll,kk,k)-
8492 cgrad     &     ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
8493 cgrad     &     coeffm*ees0mij*gacontm_hb3(ll,kk,k))
8494 cgrad        enddo
8495 cgrad      enddo
8496 c      write (iout,*) "ehbcorr",ekont*ees
8497 C      print *,ekont,ees,i,k
8498       ehbcorr=ekont*ees
8499 C now gradient over shielding
8500 C      return
8501       if (shield_mode.gt.0) then
8502        j=ees0plist(jj,i)
8503        l=ees0plist(kk,k)
8504 C        print *,i,j,fac_shield(i),fac_shield(j),
8505 C     &fac_shield(k),fac_shield(l)
8506         if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
8507      &      (fac_shield(k).gt.0).and.(fac_shield(l).gt.0)) then
8508           do ilist=1,ishield_list(i)
8509            iresshield=shield_list(ilist,i)
8510            do m=1,3
8511            rlocshield=grad_shield_side(m,ilist,i)*ehbcorr/fac_shield(i)
8512 C     &      *2.0
8513            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
8514      &              rlocshield
8515      & +grad_shield_loc(m,ilist,i)*ehbcorr/fac_shield(i)
8516             gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
8517      &+rlocshield
8518            enddo
8519           enddo
8520           do ilist=1,ishield_list(j)
8521            iresshield=shield_list(ilist,j)
8522            do m=1,3
8523            rlocshield=grad_shield_side(m,ilist,j)*ehbcorr/fac_shield(j)
8524 C     &     *2.0
8525            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
8526      &              rlocshield
8527      & +grad_shield_loc(m,ilist,j)*ehbcorr/fac_shield(j)
8528            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
8529      &     +rlocshield
8530            enddo
8531           enddo
8532
8533           do ilist=1,ishield_list(k)
8534            iresshield=shield_list(ilist,k)
8535            do m=1,3
8536            rlocshield=grad_shield_side(m,ilist,k)*ehbcorr/fac_shield(k)
8537 C     &     *2.0
8538            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
8539      &              rlocshield
8540      & +grad_shield_loc(m,ilist,k)*ehbcorr/fac_shield(k)
8541            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
8542      &     +rlocshield
8543            enddo
8544           enddo
8545           do ilist=1,ishield_list(l)
8546            iresshield=shield_list(ilist,l)
8547            do m=1,3
8548            rlocshield=grad_shield_side(m,ilist,l)*ehbcorr/fac_shield(l)
8549 C     &     *2.0
8550            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
8551      &              rlocshield
8552      & +grad_shield_loc(m,ilist,l)*ehbcorr/fac_shield(l)
8553            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
8554      &     +rlocshield
8555            enddo
8556           enddo
8557 C          print *,gshieldx(m,iresshield)
8558           do m=1,3
8559             gshieldc_ec(m,i)=gshieldc_ec(m,i)+
8560      &              grad_shield(m,i)*ehbcorr/fac_shield(i)
8561             gshieldc_ec(m,j)=gshieldc_ec(m,j)+
8562      &              grad_shield(m,j)*ehbcorr/fac_shield(j)
8563             gshieldc_ec(m,i-1)=gshieldc_ec(m,i-1)+
8564      &              grad_shield(m,i)*ehbcorr/fac_shield(i)
8565             gshieldc_ec(m,j-1)=gshieldc_ec(m,j-1)+
8566      &              grad_shield(m,j)*ehbcorr/fac_shield(j)
8567
8568             gshieldc_ec(m,k)=gshieldc_ec(m,k)+
8569      &              grad_shield(m,k)*ehbcorr/fac_shield(k)
8570             gshieldc_ec(m,l)=gshieldc_ec(m,l)+
8571      &              grad_shield(m,l)*ehbcorr/fac_shield(l)
8572             gshieldc_ec(m,k-1)=gshieldc_ec(m,k-1)+
8573      &              grad_shield(m,k)*ehbcorr/fac_shield(k)
8574             gshieldc_ec(m,l-1)=gshieldc_ec(m,l-1)+
8575      &              grad_shield(m,l)*ehbcorr/fac_shield(l)
8576
8577            enddo
8578       endif
8579       endif
8580       return
8581       end
8582 #ifdef MOMENT
8583 C---------------------------------------------------------------------------
8584       subroutine dipole(i,j,jj)
8585       implicit real*8 (a-h,o-z)
8586       include 'DIMENSIONS'
8587       include 'COMMON.IOUNITS'
8588       include 'COMMON.CHAIN'
8589       include 'COMMON.FFIELD'
8590       include 'COMMON.DERIV'
8591       include 'COMMON.INTERACT'
8592       include 'COMMON.CONTACTS'
8593       include 'COMMON.TORSION'
8594       include 'COMMON.VAR'
8595       include 'COMMON.GEO'
8596       dimension dipi(2,2),dipj(2,2),dipderi(2),dipderj(2),auxvec(2),
8597      &  auxmat(2,2)
8598       iti1 = itortyp(itype(i+1))
8599       if (j.lt.nres-1) then
8600         itj1 = itortyp(itype(j+1))
8601       else
8602         itj1=ntortyp
8603       endif
8604       do iii=1,2
8605         dipi(iii,1)=Ub2(iii,i)
8606         dipderi(iii)=Ub2der(iii,i)
8607         dipi(iii,2)=b1(iii,i+1)
8608         dipj(iii,1)=Ub2(iii,j)
8609         dipderj(iii)=Ub2der(iii,j)
8610         dipj(iii,2)=b1(iii,j+1)
8611       enddo
8612       kkk=0
8613       do iii=1,2
8614         call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
8615         do jjj=1,2
8616           kkk=kkk+1
8617           dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
8618         enddo
8619       enddo
8620       do kkk=1,5
8621         do lll=1,3
8622           mmm=0
8623           do iii=1,2
8624             call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),
8625      &        auxvec(1))
8626             do jjj=1,2
8627               mmm=mmm+1
8628               dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
8629             enddo
8630           enddo
8631         enddo
8632       enddo
8633       call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
8634       call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
8635       do iii=1,2
8636         dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
8637       enddo
8638       call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
8639       do iii=1,2
8640         dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
8641       enddo
8642       return
8643       end
8644 #endif
8645 C---------------------------------------------------------------------------
8646       subroutine calc_eello(i,j,k,l,jj,kk)
8647 C
8648 C This subroutine computes matrices and vectors needed to calculate
8649 C the fourth-, fifth-, and sixth-order local-electrostatic terms.
8650 C
8651       implicit real*8 (a-h,o-z)
8652       include 'DIMENSIONS'
8653       include 'COMMON.IOUNITS'
8654       include 'COMMON.CHAIN'
8655       include 'COMMON.DERIV'
8656       include 'COMMON.INTERACT'
8657       include 'COMMON.CONTACTS'
8658       include 'COMMON.TORSION'
8659       include 'COMMON.VAR'
8660       include 'COMMON.GEO'
8661       include 'COMMON.FFIELD'
8662       double precision aa1(2,2),aa2(2,2),aa1t(2,2),aa2t(2,2),
8663      &  aa1tder(2,2,3,5),aa2tder(2,2,3,5),auxmat(2,2)
8664       logical lprn
8665       common /kutas/ lprn
8666 cd      write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
8667 cd     & ' jj=',jj,' kk=',kk
8668 cd      if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
8669 cd      write (iout,*) "a_chujij",((a_chuj(iii,jjj,jj,i),iii=1,2),jjj=1,2)
8670 cd      write (iout,*) "a_chujkl",((a_chuj(iii,jjj,kk,k),iii=1,2),jjj=1,2)
8671       do iii=1,2
8672         do jjj=1,2
8673           aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
8674           aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
8675         enddo
8676       enddo
8677       call transpose2(aa1(1,1),aa1t(1,1))
8678       call transpose2(aa2(1,1),aa2t(1,1))
8679       do kkk=1,5
8680         do lll=1,3
8681           call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),
8682      &      aa1tder(1,1,lll,kkk))
8683           call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),
8684      &      aa2tder(1,1,lll,kkk))
8685         enddo
8686       enddo
8687       if (l.eq.j+1) then
8688 C parallel orientation of the two CA-CA-CA frames.
8689         if (i.gt.1) then
8690           iti=itortyp(itype(i))
8691         else
8692           iti=ntortyp
8693         endif
8694         itk1=itortyp(itype(k+1))
8695         itj=itortyp(itype(j))
8696         if (l.lt.nres-1) then
8697           itl1=itortyp(itype(l+1))
8698         else
8699           itl1=ntortyp
8700         endif
8701 C A1 kernel(j+1) A2T
8702 cd        do iii=1,2
8703 cd          write (iout,'(3f10.5,5x,3f10.5)')
8704 cd     &     (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
8705 cd        enddo
8706         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
8707      &   aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),
8708      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
8709 C Following matrices are needed only for 6-th order cumulants
8710         IF (wcorr6.gt.0.0d0) THEN
8711         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
8712      &   aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),
8713      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
8714         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
8715      &   aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),
8716      &   Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
8717      &   ADtEAderx(1,1,1,1,1,1))
8718         lprn=.false.
8719         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
8720      &   aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),
8721      &   DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
8722      &   ADtEA1derx(1,1,1,1,1,1))
8723         ENDIF
8724 C End 6-th order cumulants
8725 cd        lprn=.false.
8726 cd        if (lprn) then
8727 cd        write (2,*) 'In calc_eello6'
8728 cd        do iii=1,2
8729 cd          write (2,*) 'iii=',iii
8730 cd          do kkk=1,5
8731 cd            write (2,*) 'kkk=',kkk
8732 cd            do jjj=1,2
8733 cd              write (2,'(3(2f10.5),5x)')
8734 cd     &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
8735 cd            enddo
8736 cd          enddo
8737 cd        enddo
8738 cd        endif
8739         call transpose2(EUgder(1,1,k),auxmat(1,1))
8740         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
8741         call transpose2(EUg(1,1,k),auxmat(1,1))
8742         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
8743         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
8744         do iii=1,2
8745           do kkk=1,5
8746             do lll=1,3
8747               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
8748      &          EAEAderx(1,1,lll,kkk,iii,1))
8749             enddo
8750           enddo
8751         enddo
8752 C A1T kernel(i+1) A2
8753         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
8754      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),
8755      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
8756 C Following matrices are needed only for 6-th order cumulants
8757         IF (wcorr6.gt.0.0d0) THEN
8758         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
8759      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),
8760      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
8761         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
8762      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),
8763      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
8764      &   ADtEAderx(1,1,1,1,1,2))
8765         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
8766      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),
8767      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
8768      &   ADtEA1derx(1,1,1,1,1,2))
8769         ENDIF
8770 C End 6-th order cumulants
8771         call transpose2(EUgder(1,1,l),auxmat(1,1))
8772         call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
8773         call transpose2(EUg(1,1,l),auxmat(1,1))
8774         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
8775         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
8776         do iii=1,2
8777           do kkk=1,5
8778             do lll=1,3
8779               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
8780      &          EAEAderx(1,1,lll,kkk,iii,2))
8781             enddo
8782           enddo
8783         enddo
8784 C AEAb1 and AEAb2
8785 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
8786 C They are needed only when the fifth- or the sixth-order cumulants are
8787 C indluded.
8788         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
8789         call transpose2(AEA(1,1,1),auxmat(1,1))
8790         call matvec2(auxmat(1,1),b1(1,i),AEAb1(1,1,1))
8791         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
8792         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
8793         call transpose2(AEAderg(1,1,1),auxmat(1,1))
8794         call matvec2(auxmat(1,1),b1(1,i),AEAb1derg(1,1,1))
8795         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
8796         call matvec2(AEA(1,1,1),b1(1,k+1),AEAb1(1,2,1))
8797         call matvec2(AEAderg(1,1,1),b1(1,k+1),AEAb1derg(1,2,1))
8798         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
8799         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
8800         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
8801         call transpose2(AEA(1,1,2),auxmat(1,1))
8802         call matvec2(auxmat(1,1),b1(1,j),AEAb1(1,1,2))
8803         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
8804         call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
8805         call transpose2(AEAderg(1,1,2),auxmat(1,1))
8806         call matvec2(auxmat(1,1),b1(1,j),AEAb1derg(1,1,2))
8807         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
8808         call matvec2(AEA(1,1,2),b1(1,l+1),AEAb1(1,2,2))
8809         call matvec2(AEAderg(1,1,2),b1(1,l+1),AEAb1derg(1,2,2))
8810         call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
8811         call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
8812         call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
8813 C Calculate the Cartesian derivatives of the vectors.
8814         do iii=1,2
8815           do kkk=1,5
8816             do lll=1,3
8817               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
8818               call matvec2(auxmat(1,1),b1(1,i),
8819      &          AEAb1derx(1,lll,kkk,iii,1,1))
8820               call matvec2(auxmat(1,1),Ub2(1,i),
8821      &          AEAb2derx(1,lll,kkk,iii,1,1))
8822               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
8823      &          AEAb1derx(1,lll,kkk,iii,2,1))
8824               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
8825      &          AEAb2derx(1,lll,kkk,iii,2,1))
8826               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
8827               call matvec2(auxmat(1,1),b1(1,j),
8828      &          AEAb1derx(1,lll,kkk,iii,1,2))
8829               call matvec2(auxmat(1,1),Ub2(1,j),
8830      &          AEAb2derx(1,lll,kkk,iii,1,2))
8831               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,l+1),
8832      &          AEAb1derx(1,lll,kkk,iii,2,2))
8833               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),
8834      &          AEAb2derx(1,lll,kkk,iii,2,2))
8835             enddo
8836           enddo
8837         enddo
8838         ENDIF
8839 C End vectors
8840       else
8841 C Antiparallel orientation of the two CA-CA-CA frames.
8842         if (i.gt.1) then
8843           iti=itortyp(itype(i))
8844         else
8845           iti=ntortyp
8846         endif
8847         itk1=itortyp(itype(k+1))
8848         itl=itortyp(itype(l))
8849         itj=itortyp(itype(j))
8850         if (j.lt.nres-1) then
8851           itj1=itortyp(itype(j+1))
8852         else
8853           itj1=ntortyp
8854         endif
8855 C A2 kernel(j-1)T A1T
8856         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
8857      &   aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),
8858      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
8859 C Following matrices are needed only for 6-th order cumulants
8860         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
8861      &     j.eq.i+4 .and. l.eq.i+3)) THEN
8862         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
8863      &   aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),
8864      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
8865         call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
8866      &   aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),
8867      &   Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
8868      &   ADtEAderx(1,1,1,1,1,1))
8869         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
8870      &   aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),
8871      &   DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
8872      &   ADtEA1derx(1,1,1,1,1,1))
8873         ENDIF
8874 C End 6-th order cumulants
8875         call transpose2(EUgder(1,1,k),auxmat(1,1))
8876         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
8877         call transpose2(EUg(1,1,k),auxmat(1,1))
8878         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
8879         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
8880         do iii=1,2
8881           do kkk=1,5
8882             do lll=1,3
8883               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
8884      &          EAEAderx(1,1,lll,kkk,iii,1))
8885             enddo
8886           enddo
8887         enddo
8888 C A2T kernel(i+1)T A1
8889         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
8890      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),
8891      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
8892 C Following matrices are needed only for 6-th order cumulants
8893         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
8894      &     j.eq.i+4 .and. l.eq.i+3)) THEN
8895         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
8896      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),
8897      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
8898         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
8899      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),
8900      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
8901      &   ADtEAderx(1,1,1,1,1,2))
8902         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
8903      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),
8904      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
8905      &   ADtEA1derx(1,1,1,1,1,2))
8906         ENDIF
8907 C End 6-th order cumulants
8908         call transpose2(EUgder(1,1,j),auxmat(1,1))
8909         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
8910         call transpose2(EUg(1,1,j),auxmat(1,1))
8911         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
8912         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
8913         do iii=1,2
8914           do kkk=1,5
8915             do lll=1,3
8916               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
8917      &          EAEAderx(1,1,lll,kkk,iii,2))
8918             enddo
8919           enddo
8920         enddo
8921 C AEAb1 and AEAb2
8922 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
8923 C They are needed only when the fifth- or the sixth-order cumulants are
8924 C indluded.
8925         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or.
8926      &    (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
8927         call transpose2(AEA(1,1,1),auxmat(1,1))
8928         call matvec2(auxmat(1,1),b1(1,i),AEAb1(1,1,1))
8929         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
8930         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
8931         call transpose2(AEAderg(1,1,1),auxmat(1,1))
8932         call matvec2(auxmat(1,1),b1(1,i),AEAb1derg(1,1,1))
8933         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
8934         call matvec2(AEA(1,1,1),b1(1,k+1),AEAb1(1,2,1))
8935         call matvec2(AEAderg(1,1,1),b1(1,k+1),AEAb1derg(1,2,1))
8936         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
8937         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
8938         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
8939         call transpose2(AEA(1,1,2),auxmat(1,1))
8940         call matvec2(auxmat(1,1),b1(1,j+1),AEAb1(1,1,2))
8941         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
8942         call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
8943         call transpose2(AEAderg(1,1,2),auxmat(1,1))
8944         call matvec2(auxmat(1,1),b1(1,l),AEAb1(1,1,2))
8945         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
8946         call matvec2(AEA(1,1,2),b1(1,j+1),AEAb1(1,2,2))
8947         call matvec2(AEAderg(1,1,2),b1(1,j+1),AEAb1derg(1,2,2))
8948         call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
8949         call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
8950         call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
8951 C Calculate the Cartesian derivatives of the vectors.
8952         do iii=1,2
8953           do kkk=1,5
8954             do lll=1,3
8955               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
8956               call matvec2(auxmat(1,1),b1(1,i),
8957      &          AEAb1derx(1,lll,kkk,iii,1,1))
8958               call matvec2(auxmat(1,1),Ub2(1,i),
8959      &          AEAb2derx(1,lll,kkk,iii,1,1))
8960               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
8961      &          AEAb1derx(1,lll,kkk,iii,2,1))
8962               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
8963      &          AEAb2derx(1,lll,kkk,iii,2,1))
8964               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
8965               call matvec2(auxmat(1,1),b1(1,l),
8966      &          AEAb1derx(1,lll,kkk,iii,1,2))
8967               call matvec2(auxmat(1,1),Ub2(1,l),
8968      &          AEAb2derx(1,lll,kkk,iii,1,2))
8969               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,j+1),
8970      &          AEAb1derx(1,lll,kkk,iii,2,2))
8971               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),
8972      &          AEAb2derx(1,lll,kkk,iii,2,2))
8973             enddo
8974           enddo
8975         enddo
8976         ENDIF
8977 C End vectors
8978       endif
8979       return
8980       end
8981 C---------------------------------------------------------------------------
8982       subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,
8983      &  KK,KKderg,AKA,AKAderg,AKAderx)
8984       implicit none
8985       integer nderg
8986       logical transp
8987       double precision aa1(2,2),aa2t(2,2),aa1derx(2,2,3,5),
8988      &  aa2tderx(2,2,3,5),KK(2,2),KKderg(2,2,nderg),AKA(2,2),
8989      &  AKAderg(2,2,nderg),AKAderx(2,2,3,5,2)
8990       integer iii,kkk,lll
8991       integer jjj,mmm
8992       logical lprn
8993       common /kutas/ lprn
8994       call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
8995       do iii=1,nderg
8996         call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,
8997      &    AKAderg(1,1,iii))
8998       enddo
8999 cd      if (lprn) write (2,*) 'In kernel'
9000       do kkk=1,5
9001 cd        if (lprn) write (2,*) 'kkk=',kkk
9002         do lll=1,3
9003           call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),
9004      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
9005 cd          if (lprn) then
9006 cd            write (2,*) 'lll=',lll
9007 cd            write (2,*) 'iii=1'
9008 cd            do jjj=1,2
9009 cd              write (2,'(3(2f10.5),5x)')
9010 cd     &        (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
9011 cd            enddo
9012 cd          endif
9013           call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),
9014      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
9015 cd          if (lprn) then
9016 cd            write (2,*) 'lll=',lll
9017 cd            write (2,*) 'iii=2'
9018 cd            do jjj=1,2
9019 cd              write (2,'(3(2f10.5),5x)')
9020 cd     &        (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
9021 cd            enddo
9022 cd          endif
9023         enddo
9024       enddo
9025       return
9026       end
9027 C---------------------------------------------------------------------------
9028       double precision function eello4(i,j,k,l,jj,kk)
9029       implicit real*8 (a-h,o-z)
9030       include 'DIMENSIONS'
9031       include 'COMMON.IOUNITS'
9032       include 'COMMON.CHAIN'
9033       include 'COMMON.DERIV'
9034       include 'COMMON.INTERACT'
9035       include 'COMMON.CONTACTS'
9036       include 'COMMON.TORSION'
9037       include 'COMMON.VAR'
9038       include 'COMMON.GEO'
9039       double precision pizda(2,2),ggg1(3),ggg2(3)
9040 cd      if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
9041 cd        eello4=0.0d0
9042 cd        return
9043 cd      endif
9044 cd      print *,'eello4:',i,j,k,l,jj,kk
9045 cd      write (2,*) 'i',i,' j',j,' k',k,' l',l
9046 cd      call checkint4(i,j,k,l,jj,kk,eel4_num)
9047 cold      eij=facont_hb(jj,i)
9048 cold      ekl=facont_hb(kk,k)
9049 cold      ekont=eij*ekl
9050       eel4=-EAEA(1,1,1)-EAEA(2,2,1)
9051 cd      eel41=-EAEA(1,1,2)-EAEA(2,2,2)
9052       gcorr_loc(k-1)=gcorr_loc(k-1)
9053      &   -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
9054       if (l.eq.j+1) then
9055         gcorr_loc(l-1)=gcorr_loc(l-1)
9056      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
9057       else
9058         gcorr_loc(j-1)=gcorr_loc(j-1)
9059      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
9060       endif
9061       do iii=1,2
9062         do kkk=1,5
9063           do lll=1,3
9064             derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1)
9065      &                        -EAEAderx(2,2,lll,kkk,iii,1)
9066 cd            derx(lll,kkk,iii)=0.0d0
9067           enddo
9068         enddo
9069       enddo
9070 cd      gcorr_loc(l-1)=0.0d0
9071 cd      gcorr_loc(j-1)=0.0d0
9072 cd      gcorr_loc(k-1)=0.0d0
9073 cd      eel4=1.0d0
9074 cd      write (iout,*)'Contacts have occurred for peptide groups',
9075 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l,
9076 cd     &  ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
9077       if (j.lt.nres-1) then
9078         j1=j+1
9079         j2=j-1
9080       else
9081         j1=j-1
9082         j2=j-2
9083       endif
9084       if (l.lt.nres-1) then
9085         l1=l+1
9086         l2=l-1
9087       else
9088         l1=l-1
9089         l2=l-2
9090       endif
9091       do ll=1,3
9092 cgrad        ggg1(ll)=eel4*g_contij(ll,1)
9093 cgrad        ggg2(ll)=eel4*g_contij(ll,2)
9094         glongij=eel4*g_contij(ll,1)+ekont*derx(ll,1,1)
9095         glongkl=eel4*g_contij(ll,2)+ekont*derx(ll,1,2)
9096 cgrad        ghalf=0.5d0*ggg1(ll)
9097         gradcorr(ll,i)=gradcorr(ll,i)+ekont*derx(ll,2,1)
9098         gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
9099         gradcorr(ll,j)=gradcorr(ll,j)+ekont*derx(ll,4,1)
9100         gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
9101         gradcorr_long(ll,j)=gradcorr_long(ll,j)+glongij
9102         gradcorr_long(ll,i)=gradcorr_long(ll,i)-glongij
9103 cgrad        ghalf=0.5d0*ggg2(ll)
9104         gradcorr(ll,k)=gradcorr(ll,k)+ekont*derx(ll,2,2)
9105         gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
9106         gradcorr(ll,l)=gradcorr(ll,l)+ekont*derx(ll,4,2)
9107         gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
9108         gradcorr_long(ll,l)=gradcorr_long(ll,l)+glongkl
9109         gradcorr_long(ll,k)=gradcorr_long(ll,k)-glongkl
9110       enddo
9111 cgrad      do m=i+1,j-1
9112 cgrad        do ll=1,3
9113 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
9114 cgrad        enddo
9115 cgrad      enddo
9116 cgrad      do m=k+1,l-1
9117 cgrad        do ll=1,3
9118 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
9119 cgrad        enddo
9120 cgrad      enddo
9121 cgrad      do m=i+2,j2
9122 cgrad        do ll=1,3
9123 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
9124 cgrad        enddo
9125 cgrad      enddo
9126 cgrad      do m=k+2,l2
9127 cgrad        do ll=1,3
9128 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
9129 cgrad        enddo
9130 cgrad      enddo
9131 cd      do iii=1,nres-3
9132 cd        write (2,*) iii,gcorr_loc(iii)
9133 cd      enddo
9134       eello4=ekont*eel4
9135 cd      write (2,*) 'ekont',ekont
9136 cd      write (iout,*) 'eello4',ekont*eel4
9137       return
9138       end
9139 C---------------------------------------------------------------------------
9140       double precision function eello5(i,j,k,l,jj,kk)
9141       implicit real*8 (a-h,o-z)
9142       include 'DIMENSIONS'
9143       include 'COMMON.IOUNITS'
9144       include 'COMMON.CHAIN'
9145       include 'COMMON.DERIV'
9146       include 'COMMON.INTERACT'
9147       include 'COMMON.CONTACTS'
9148       include 'COMMON.TORSION'
9149       include 'COMMON.VAR'
9150       include 'COMMON.GEO'
9151       double precision pizda(2,2),auxmat(2,2),auxmat1(2,2),vv(2)
9152       double precision ggg1(3),ggg2(3)
9153 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9154 C                                                                              C
9155 C                            Parallel chains                                   C
9156 C                                                                              C
9157 C          o             o                   o             o                   C
9158 C         /l\           / \             \   / \           / \   /              C
9159 C        /   \         /   \             \ /   \         /   \ /               C
9160 C       j| o |l1       | o |              o| o |         | o |o                C
9161 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
9162 C      \i/   \         /   \ /             /   \         /   \                 C
9163 C       o    k1             o                                                  C
9164 C         (I)          (II)                (III)          (IV)                 C
9165 C                                                                              C
9166 C      eello5_1        eello5_2            eello5_3       eello5_4             C
9167 C                                                                              C
9168 C                            Antiparallel chains                               C
9169 C                                                                              C
9170 C          o             o                   o             o                   C
9171 C         /j\           / \             \   / \           / \   /              C
9172 C        /   \         /   \             \ /   \         /   \ /               C
9173 C      j1| o |l        | o |              o| o |         | o |o                C
9174 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
9175 C      \i/   \         /   \ /             /   \         /   \                 C
9176 C       o     k1            o                                                  C
9177 C         (I)          (II)                (III)          (IV)                 C
9178 C                                                                              C
9179 C      eello5_1        eello5_2            eello5_3       eello5_4             C
9180 C                                                                              C
9181 C o denotes a local interaction, vertical lines an electrostatic interaction.  C
9182 C                                                                              C
9183 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9184 cd      if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
9185 cd        eello5=0.0d0
9186 cd        return
9187 cd      endif
9188 cd      write (iout,*)
9189 cd     &   'EELLO5: Contacts have occurred for peptide groups',i,j,
9190 cd     &   ' and',k,l
9191       itk=itortyp(itype(k))
9192       itl=itortyp(itype(l))
9193       itj=itortyp(itype(j))
9194       eello5_1=0.0d0
9195       eello5_2=0.0d0
9196       eello5_3=0.0d0
9197       eello5_4=0.0d0
9198 cd      call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
9199 cd     &   eel5_3_num,eel5_4_num)
9200       do iii=1,2
9201         do kkk=1,5
9202           do lll=1,3
9203             derx(lll,kkk,iii)=0.0d0
9204           enddo
9205         enddo
9206       enddo
9207 cd      eij=facont_hb(jj,i)
9208 cd      ekl=facont_hb(kk,k)
9209 cd      ekont=eij*ekl
9210 cd      write (iout,*)'Contacts have occurred for peptide groups',
9211 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l
9212 cd      goto 1111
9213 C Contribution from the graph I.
9214 cd      write (2,*) 'AEA  ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
9215 cd      write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
9216       call transpose2(EUg(1,1,k),auxmat(1,1))
9217       call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
9218       vv(1)=pizda(1,1)-pizda(2,2)
9219       vv(2)=pizda(1,2)+pizda(2,1)
9220       eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k))
9221      & +0.5d0*scalar2(vv(1),Dtobr2(1,i))
9222 C Explicit gradient in virtual-dihedral angles.
9223       if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1)
9224      & +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k))
9225      & +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
9226       call transpose2(EUgder(1,1,k),auxmat1(1,1))
9227       call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
9228       vv(1)=pizda(1,1)-pizda(2,2)
9229       vv(2)=pizda(1,2)+pizda(2,1)
9230       g_corr5_loc(k-1)=g_corr5_loc(k-1)
9231      & +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k))
9232      & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
9233       call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
9234       vv(1)=pizda(1,1)-pizda(2,2)
9235       vv(2)=pizda(1,2)+pizda(2,1)
9236       if (l.eq.j+1) then
9237         if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1)
9238      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
9239      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
9240       else
9241         if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1)
9242      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
9243      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
9244       endif
9245 C Cartesian gradient
9246       do iii=1,2
9247         do kkk=1,5
9248           do lll=1,3
9249             call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),
9250      &        pizda(1,1))
9251             vv(1)=pizda(1,1)-pizda(2,2)
9252             vv(2)=pizda(1,2)+pizda(2,1)
9253             derx(lll,kkk,iii)=derx(lll,kkk,iii)
9254      &       +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k))
9255      &       +0.5d0*scalar2(vv(1),Dtobr2(1,i))
9256           enddo
9257         enddo
9258       enddo
9259 c      goto 1112
9260 c1111  continue
9261 C Contribution from graph II
9262       call transpose2(EE(1,1,itk),auxmat(1,1))
9263       call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
9264       vv(1)=pizda(1,1)+pizda(2,2)
9265       vv(2)=pizda(2,1)-pizda(1,2)
9266       eello5_2=scalar2(AEAb1(1,2,1),b1(1,k))
9267      & -0.5d0*scalar2(vv(1),Ctobr(1,k))
9268 C Explicit gradient in virtual-dihedral angles.
9269       g_corr5_loc(k-1)=g_corr5_loc(k-1)
9270      & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
9271       call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
9272       vv(1)=pizda(1,1)+pizda(2,2)
9273       vv(2)=pizda(2,1)-pizda(1,2)
9274       if (l.eq.j+1) then
9275         g_corr5_loc(l-1)=g_corr5_loc(l-1)
9276      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,k))
9277      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
9278       else
9279         g_corr5_loc(j-1)=g_corr5_loc(j-1)
9280      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,k))
9281      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
9282       endif
9283 C Cartesian gradient
9284       do iii=1,2
9285         do kkk=1,5
9286           do lll=1,3
9287             call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
9288      &        pizda(1,1))
9289             vv(1)=pizda(1,1)+pizda(2,2)
9290             vv(2)=pizda(2,1)-pizda(1,2)
9291             derx(lll,kkk,iii)=derx(lll,kkk,iii)
9292      &       +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,k))
9293      &       -0.5d0*scalar2(vv(1),Ctobr(1,k))
9294           enddo
9295         enddo
9296       enddo
9297 cd      goto 1112
9298 cd1111  continue
9299       if (l.eq.j+1) then
9300 cd        goto 1110
9301 C Parallel orientation
9302 C Contribution from graph III
9303         call transpose2(EUg(1,1,l),auxmat(1,1))
9304         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
9305         vv(1)=pizda(1,1)-pizda(2,2)
9306         vv(2)=pizda(1,2)+pizda(2,1)
9307         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l))
9308      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j))
9309 C Explicit gradient in virtual-dihedral angles.
9310         g_corr5_loc(j-1)=g_corr5_loc(j-1)
9311      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l))
9312      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
9313         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
9314         vv(1)=pizda(1,1)-pizda(2,2)
9315         vv(2)=pizda(1,2)+pizda(2,1)
9316         g_corr5_loc(k-1)=g_corr5_loc(k-1)
9317      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l))
9318      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
9319         call transpose2(EUgder(1,1,l),auxmat1(1,1))
9320         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
9321         vv(1)=pizda(1,1)-pizda(2,2)
9322         vv(2)=pizda(1,2)+pizda(2,1)
9323         g_corr5_loc(l-1)=g_corr5_loc(l-1)
9324      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l))
9325      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
9326 C Cartesian gradient
9327         do iii=1,2
9328           do kkk=1,5
9329             do lll=1,3
9330               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
9331      &          pizda(1,1))
9332               vv(1)=pizda(1,1)-pizda(2,2)
9333               vv(2)=pizda(1,2)+pizda(2,1)
9334               derx(lll,kkk,iii)=derx(lll,kkk,iii)
9335      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l))
9336      &         +0.5d0*scalar2(vv(1),Dtobr2(1,j))
9337             enddo
9338           enddo
9339         enddo
9340 cd        goto 1112
9341 C Contribution from graph IV
9342 cd1110    continue
9343         call transpose2(EE(1,1,itl),auxmat(1,1))
9344         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
9345         vv(1)=pizda(1,1)+pizda(2,2)
9346         vv(2)=pizda(2,1)-pizda(1,2)
9347         eello5_4=scalar2(AEAb1(1,2,2),b1(1,l))
9348      &   -0.5d0*scalar2(vv(1),Ctobr(1,l))
9349 C Explicit gradient in virtual-dihedral angles.
9350         g_corr5_loc(l-1)=g_corr5_loc(l-1)
9351      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
9352         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
9353         vv(1)=pizda(1,1)+pizda(2,2)
9354         vv(2)=pizda(2,1)-pizda(1,2)
9355         g_corr5_loc(k-1)=g_corr5_loc(k-1)
9356      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,l))
9357      &   -0.5d0*scalar2(vv(1),Ctobr(1,l)))
9358 C Cartesian gradient
9359         do iii=1,2
9360           do kkk=1,5
9361             do lll=1,3
9362               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
9363      &          pizda(1,1))
9364               vv(1)=pizda(1,1)+pizda(2,2)
9365               vv(2)=pizda(2,1)-pizda(1,2)
9366               derx(lll,kkk,iii)=derx(lll,kkk,iii)
9367      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,l))
9368      &         -0.5d0*scalar2(vv(1),Ctobr(1,l))
9369             enddo
9370           enddo
9371         enddo
9372       else
9373 C Antiparallel orientation
9374 C Contribution from graph III
9375 c        goto 1110
9376         call transpose2(EUg(1,1,j),auxmat(1,1))
9377         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
9378         vv(1)=pizda(1,1)-pizda(2,2)
9379         vv(2)=pizda(1,2)+pizda(2,1)
9380         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j))
9381      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l))
9382 C Explicit gradient in virtual-dihedral angles.
9383         g_corr5_loc(l-1)=g_corr5_loc(l-1)
9384      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j))
9385      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
9386         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
9387         vv(1)=pizda(1,1)-pizda(2,2)
9388         vv(2)=pizda(1,2)+pizda(2,1)
9389         g_corr5_loc(k-1)=g_corr5_loc(k-1)
9390      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j))
9391      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
9392         call transpose2(EUgder(1,1,j),auxmat1(1,1))
9393         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
9394         vv(1)=pizda(1,1)-pizda(2,2)
9395         vv(2)=pizda(1,2)+pizda(2,1)
9396         g_corr5_loc(j-1)=g_corr5_loc(j-1)
9397      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j))
9398      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
9399 C Cartesian gradient
9400         do iii=1,2
9401           do kkk=1,5
9402             do lll=1,3
9403               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
9404      &          pizda(1,1))
9405               vv(1)=pizda(1,1)-pizda(2,2)
9406               vv(2)=pizda(1,2)+pizda(2,1)
9407               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
9408      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j))
9409      &         +0.5d0*scalar2(vv(1),Dtobr2(1,l))
9410             enddo
9411           enddo
9412         enddo
9413 cd        goto 1112
9414 C Contribution from graph IV
9415 1110    continue
9416         call transpose2(EE(1,1,itj),auxmat(1,1))
9417         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
9418         vv(1)=pizda(1,1)+pizda(2,2)
9419         vv(2)=pizda(2,1)-pizda(1,2)
9420         eello5_4=scalar2(AEAb1(1,2,2),b1(1,j))
9421      &   -0.5d0*scalar2(vv(1),Ctobr(1,j))
9422 C Explicit gradient in virtual-dihedral angles.
9423         g_corr5_loc(j-1)=g_corr5_loc(j-1)
9424      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
9425         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
9426         vv(1)=pizda(1,1)+pizda(2,2)
9427         vv(2)=pizda(2,1)-pizda(1,2)
9428         g_corr5_loc(k-1)=g_corr5_loc(k-1)
9429      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,j))
9430      &   -0.5d0*scalar2(vv(1),Ctobr(1,j)))
9431 C Cartesian gradient
9432         do iii=1,2
9433           do kkk=1,5
9434             do lll=1,3
9435               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
9436      &          pizda(1,1))
9437               vv(1)=pizda(1,1)+pizda(2,2)
9438               vv(2)=pizda(2,1)-pizda(1,2)
9439               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
9440      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,j))
9441      &         -0.5d0*scalar2(vv(1),Ctobr(1,j))
9442             enddo
9443           enddo
9444         enddo
9445       endif
9446 1112  continue
9447       eel5=eello5_1+eello5_2+eello5_3+eello5_4
9448 cd      if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
9449 cd        write (2,*) 'ijkl',i,j,k,l
9450 cd        write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
9451 cd     &     ' eello5_3',eello5_3,' eello5_4',eello5_4
9452 cd      endif
9453 cd      write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
9454 cd      write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
9455 cd      write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
9456 cd      write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
9457       if (j.lt.nres-1) then
9458         j1=j+1
9459         j2=j-1
9460       else
9461         j1=j-1
9462         j2=j-2
9463       endif
9464       if (l.lt.nres-1) then
9465         l1=l+1
9466         l2=l-1
9467       else
9468         l1=l-1
9469         l2=l-2
9470       endif
9471 cd      eij=1.0d0
9472 cd      ekl=1.0d0
9473 cd      ekont=1.0d0
9474 cd      write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
9475 C 2/11/08 AL Gradients over DC's connecting interacting sites will be
9476 C        summed up outside the subrouine as for the other subroutines
9477 C        handling long-range interactions. The old code is commented out
9478 C        with "cgrad" to keep track of changes.
9479       do ll=1,3
9480 cgrad        ggg1(ll)=eel5*g_contij(ll,1)
9481 cgrad        ggg2(ll)=eel5*g_contij(ll,2)
9482         gradcorr5ij=eel5*g_contij(ll,1)+ekont*derx(ll,1,1)
9483         gradcorr5kl=eel5*g_contij(ll,2)+ekont*derx(ll,1,2)
9484 c        write (iout,'(a,3i3,a,5f8.3,2i3,a,5f8.3,a,f8.3)')
9485 c     &   "ecorr5",ll,i,j," derx",derx(ll,2,1),derx(ll,3,1),derx(ll,4,1),
9486 c     &   derx(ll,5,1),k,l," derx",derx(ll,2,2),derx(ll,3,2),
9487 c     &   derx(ll,4,2),derx(ll,5,2)," ekont",ekont
9488 c        write (iout,'(a,3i3,a,3f8.3,2i3,a,3f8.3)')
9489 c     &   "ecorr5",ll,i,j," gradcorr5",g_contij(ll,1),derx(ll,1,1),
9490 c     &   gradcorr5ij,
9491 c     &   k,l," gradcorr5",g_contij(ll,2),derx(ll,1,2),gradcorr5kl
9492 cold        ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
9493 cgrad        ghalf=0.5d0*ggg1(ll)
9494 cd        ghalf=0.0d0
9495         gradcorr5(ll,i)=gradcorr5(ll,i)+ekont*derx(ll,2,1)
9496         gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
9497         gradcorr5(ll,j)=gradcorr5(ll,j)+ekont*derx(ll,4,1)
9498         gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
9499         gradcorr5_long(ll,j)=gradcorr5_long(ll,j)+gradcorr5ij
9500         gradcorr5_long(ll,i)=gradcorr5_long(ll,i)-gradcorr5ij
9501 cold        ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
9502 cgrad        ghalf=0.5d0*ggg2(ll)
9503 cd        ghalf=0.0d0
9504         gradcorr5(ll,k)=gradcorr5(ll,k)+ekont*derx(ll,2,2)
9505         gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
9506         gradcorr5(ll,l)=gradcorr5(ll,l)+ekont*derx(ll,4,2)
9507         gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
9508         gradcorr5_long(ll,l)=gradcorr5_long(ll,l)+gradcorr5kl
9509         gradcorr5_long(ll,k)=gradcorr5_long(ll,k)-gradcorr5kl
9510       enddo
9511 cd      goto 1112
9512 cgrad      do m=i+1,j-1
9513 cgrad        do ll=1,3
9514 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
9515 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
9516 cgrad        enddo
9517 cgrad      enddo
9518 cgrad      do m=k+1,l-1
9519 cgrad        do ll=1,3
9520 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
9521 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
9522 cgrad        enddo
9523 cgrad      enddo
9524 c1112  continue
9525 cgrad      do m=i+2,j2
9526 cgrad        do ll=1,3
9527 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
9528 cgrad        enddo
9529 cgrad      enddo
9530 cgrad      do m=k+2,l2
9531 cgrad        do ll=1,3
9532 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
9533 cgrad        enddo
9534 cgrad      enddo
9535 cd      do iii=1,nres-3
9536 cd        write (2,*) iii,g_corr5_loc(iii)
9537 cd      enddo
9538       eello5=ekont*eel5
9539 cd      write (2,*) 'ekont',ekont
9540 cd      write (iout,*) 'eello5',ekont*eel5
9541       return
9542       end
9543 c--------------------------------------------------------------------------
9544       double precision function eello6(i,j,k,l,jj,kk)
9545       implicit real*8 (a-h,o-z)
9546       include 'DIMENSIONS'
9547       include 'COMMON.IOUNITS'
9548       include 'COMMON.CHAIN'
9549       include 'COMMON.DERIV'
9550       include 'COMMON.INTERACT'
9551       include 'COMMON.CONTACTS'
9552       include 'COMMON.TORSION'
9553       include 'COMMON.VAR'
9554       include 'COMMON.GEO'
9555       include 'COMMON.FFIELD'
9556       double precision ggg1(3),ggg2(3)
9557 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
9558 cd        eello6=0.0d0
9559 cd        return
9560 cd      endif
9561 cd      write (iout,*)
9562 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
9563 cd     &   ' and',k,l
9564       eello6_1=0.0d0
9565       eello6_2=0.0d0
9566       eello6_3=0.0d0
9567       eello6_4=0.0d0
9568       eello6_5=0.0d0
9569       eello6_6=0.0d0
9570 cd      call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
9571 cd     &   eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
9572       do iii=1,2
9573         do kkk=1,5
9574           do lll=1,3
9575             derx(lll,kkk,iii)=0.0d0
9576           enddo
9577         enddo
9578       enddo
9579 cd      eij=facont_hb(jj,i)
9580 cd      ekl=facont_hb(kk,k)
9581 cd      ekont=eij*ekl
9582 cd      eij=1.0d0
9583 cd      ekl=1.0d0
9584 cd      ekont=1.0d0
9585       if (l.eq.j+1) then
9586         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
9587         eello6_2=eello6_graph1(j,i,l,k,2,.false.)
9588         eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
9589         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
9590         eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
9591         eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
9592       else
9593         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
9594         eello6_2=eello6_graph1(l,k,j,i,2,.true.)
9595         eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
9596         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
9597         if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
9598           eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
9599         else
9600           eello6_5=0.0d0
9601         endif
9602         eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
9603       endif
9604 C If turn contributions are considered, they will be handled separately.
9605       eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
9606 cd      write(iout,*) 'eello6_1',eello6_1!,' eel6_1_num',16*eel6_1_num
9607 cd      write(iout,*) 'eello6_2',eello6_2!,' eel6_2_num',16*eel6_2_num
9608 cd      write(iout,*) 'eello6_3',eello6_3!,' eel6_3_num',16*eel6_3_num
9609 cd      write(iout,*) 'eello6_4',eello6_4!,' eel6_4_num',16*eel6_4_num
9610 cd      write(iout,*) 'eello6_5',eello6_5!,' eel6_5_num',16*eel6_5_num
9611 cd      write(iout,*) 'eello6_6',eello6_6!,' eel6_6_num',16*eel6_6_num
9612 cd      goto 1112
9613       if (j.lt.nres-1) then
9614         j1=j+1
9615         j2=j-1
9616       else
9617         j1=j-1
9618         j2=j-2
9619       endif
9620       if (l.lt.nres-1) then
9621         l1=l+1
9622         l2=l-1
9623       else
9624         l1=l-1
9625         l2=l-2
9626       endif
9627       do ll=1,3
9628 cgrad        ggg1(ll)=eel6*g_contij(ll,1)
9629 cgrad        ggg2(ll)=eel6*g_contij(ll,2)
9630 cold        ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
9631 cgrad        ghalf=0.5d0*ggg1(ll)
9632 cd        ghalf=0.0d0
9633         gradcorr6ij=eel6*g_contij(ll,1)+ekont*derx(ll,1,1)
9634         gradcorr6kl=eel6*g_contij(ll,2)+ekont*derx(ll,1,2)
9635         gradcorr6(ll,i)=gradcorr6(ll,i)+ekont*derx(ll,2,1)
9636         gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
9637         gradcorr6(ll,j)=gradcorr6(ll,j)+ekont*derx(ll,4,1)
9638         gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
9639         gradcorr6_long(ll,j)=gradcorr6_long(ll,j)+gradcorr6ij
9640         gradcorr6_long(ll,i)=gradcorr6_long(ll,i)-gradcorr6ij
9641 cgrad        ghalf=0.5d0*ggg2(ll)
9642 cold        ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
9643 cd        ghalf=0.0d0
9644         gradcorr6(ll,k)=gradcorr6(ll,k)+ekont*derx(ll,2,2)
9645         gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
9646         gradcorr6(ll,l)=gradcorr6(ll,l)+ekont*derx(ll,4,2)
9647         gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
9648         gradcorr6_long(ll,l)=gradcorr6_long(ll,l)+gradcorr6kl
9649         gradcorr6_long(ll,k)=gradcorr6_long(ll,k)-gradcorr6kl
9650       enddo
9651 cd      goto 1112
9652 cgrad      do m=i+1,j-1
9653 cgrad        do ll=1,3
9654 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
9655 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
9656 cgrad        enddo
9657 cgrad      enddo
9658 cgrad      do m=k+1,l-1
9659 cgrad        do ll=1,3
9660 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
9661 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
9662 cgrad        enddo
9663 cgrad      enddo
9664 cgrad1112  continue
9665 cgrad      do m=i+2,j2
9666 cgrad        do ll=1,3
9667 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
9668 cgrad        enddo
9669 cgrad      enddo
9670 cgrad      do m=k+2,l2
9671 cgrad        do ll=1,3
9672 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
9673 cgrad        enddo
9674 cgrad      enddo
9675 cd      do iii=1,nres-3
9676 cd        write (2,*) iii,g_corr6_loc(iii)
9677 cd      enddo
9678       eello6=ekont*eel6
9679 cd      write (2,*) 'ekont',ekont
9680 cd      write (iout,*) 'eello6',ekont*eel6
9681       return
9682       end
9683 c--------------------------------------------------------------------------
9684       double precision function eello6_graph1(i,j,k,l,imat,swap)
9685       implicit real*8 (a-h,o-z)
9686       include 'DIMENSIONS'
9687       include 'COMMON.IOUNITS'
9688       include 'COMMON.CHAIN'
9689       include 'COMMON.DERIV'
9690       include 'COMMON.INTERACT'
9691       include 'COMMON.CONTACTS'
9692       include 'COMMON.TORSION'
9693       include 'COMMON.VAR'
9694       include 'COMMON.GEO'
9695       double precision vv(2),vv1(2),pizda(2,2),auxmat(2,2),pizda1(2,2)
9696       logical swap
9697       logical lprn
9698       common /kutas/ lprn
9699 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9700 C                                                                              C
9701 C      Parallel       Antiparallel                                             C
9702 C                                                                              C
9703 C          o             o                                                     C
9704 C         /l\           /j\                                                    C
9705 C        /   \         /   \                                                   C
9706 C       /| o |         | o |\                                                  C
9707 C     \ j|/k\|  /   \  |/k\|l /                                                C
9708 C      \ /   \ /     \ /   \ /                                                 C
9709 C       o     o       o     o                                                  C
9710 C       i             i                                                        C
9711 C                                                                              C
9712 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9713       itk=itortyp(itype(k))
9714       s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
9715       s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
9716       s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
9717       call transpose2(EUgC(1,1,k),auxmat(1,1))
9718       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
9719       vv1(1)=pizda1(1,1)-pizda1(2,2)
9720       vv1(2)=pizda1(1,2)+pizda1(2,1)
9721       s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
9722       vv(1)=AEAb1(1,2,imat)*b1(1,k)-AEAb1(2,2,imat)*b1(2,k)
9723       vv(2)=AEAb1(1,2,imat)*b1(2,k)+AEAb1(2,2,imat)*b1(1,k)
9724       s5=scalar2(vv(1),Dtobr2(1,i))
9725 cd      write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
9726       eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
9727       if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1)
9728      & -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i))
9729      & -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k))
9730      & +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k))
9731      & +0.5d0*scalar2(vv1(1),Dtobr2der(1,i))
9732      & +scalar2(vv(1),Dtobr2der(1,i)))
9733       call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
9734       vv1(1)=pizda1(1,1)-pizda1(2,2)
9735       vv1(2)=pizda1(1,2)+pizda1(2,1)
9736       vv(1)=AEAb1derg(1,2,imat)*b1(1,k)-AEAb1derg(2,2,imat)*b1(2,k)
9737       vv(2)=AEAb1derg(1,2,imat)*b1(2,k)+AEAb1derg(2,2,imat)*b1(1,k)
9738       if (l.eq.j+1) then
9739         g_corr6_loc(l-1)=g_corr6_loc(l-1)
9740      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
9741      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
9742      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
9743      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
9744       else
9745         g_corr6_loc(j-1)=g_corr6_loc(j-1)
9746      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
9747      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
9748      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
9749      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
9750       endif
9751       call transpose2(EUgCder(1,1,k),auxmat(1,1))
9752       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
9753       vv1(1)=pizda1(1,1)-pizda1(2,2)
9754       vv1(2)=pizda1(1,2)+pizda1(2,1)
9755       if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1)
9756      & +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k))
9757      & +scalar2(AEAb2(1,1,imat),CUgb2der(1,k))
9758      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
9759       do iii=1,2
9760         if (swap) then
9761           ind=3-iii
9762         else
9763           ind=iii
9764         endif
9765         do kkk=1,5
9766           do lll=1,3
9767             s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
9768             s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
9769             s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
9770             call transpose2(EUgC(1,1,k),auxmat(1,1))
9771             call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
9772      &        pizda1(1,1))
9773             vv1(1)=pizda1(1,1)-pizda1(2,2)
9774             vv1(2)=pizda1(1,2)+pizda1(2,1)
9775             s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
9776             vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,k)
9777      &       -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,k)
9778             vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,k)
9779      &       +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,k)
9780             s5=scalar2(vv(1),Dtobr2(1,i))
9781             derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
9782           enddo
9783         enddo
9784       enddo
9785       return
9786       end
9787 c----------------------------------------------------------------------------
9788       double precision function eello6_graph2(i,j,k,l,jj,kk,swap)
9789       implicit real*8 (a-h,o-z)
9790       include 'DIMENSIONS'
9791       include 'COMMON.IOUNITS'
9792       include 'COMMON.CHAIN'
9793       include 'COMMON.DERIV'
9794       include 'COMMON.INTERACT'
9795       include 'COMMON.CONTACTS'
9796       include 'COMMON.TORSION'
9797       include 'COMMON.VAR'
9798       include 'COMMON.GEO'
9799       logical swap
9800       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
9801      & auxvec1(2),auxvec2(2),auxmat1(2,2)
9802       logical lprn
9803       common /kutas/ lprn
9804 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9805 C                                                                              C
9806 C      Parallel       Antiparallel                                             C
9807 C                                                                              C
9808 C          o             o                                                     C
9809 C     \   /l\           /j\   /                                                C
9810 C      \ /   \         /   \ /                                                 C
9811 C       o| o |         | o |o                                                  C
9812 C     \ j|/k\|      \  |/k\|l                                                  C
9813 C      \ /   \       \ /   \                                                   C
9814 C       o             o                                                        C
9815 C       i             i                                                        C
9816 C                                                                              C
9817 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9818 cd      write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
9819 C AL 7/4/01 s1 would occur in the sixth-order moment,
9820 C           but not in a cluster cumulant
9821 #ifdef MOMENT
9822       s1=dip(1,jj,i)*dip(1,kk,k)
9823 #endif
9824       call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
9825       s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
9826       call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
9827       s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
9828       call transpose2(EUg(1,1,k),auxmat(1,1))
9829       call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
9830       vv(1)=pizda(1,1)-pizda(2,2)
9831       vv(2)=pizda(1,2)+pizda(2,1)
9832       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
9833 cd      write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
9834 #ifdef MOMENT
9835       eello6_graph2=-(s1+s2+s3+s4)
9836 #else
9837       eello6_graph2=-(s2+s3+s4)
9838 #endif
9839 c      eello6_graph2=-s3
9840 C Derivatives in gamma(i-1)
9841       if (i.gt.1) then
9842 #ifdef MOMENT
9843         s1=dipderg(1,jj,i)*dip(1,kk,k)
9844 #endif
9845         s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
9846         call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
9847         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
9848         s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
9849 #ifdef MOMENT
9850         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
9851 #else
9852         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
9853 #endif
9854 c        g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
9855       endif
9856 C Derivatives in gamma(k-1)
9857 #ifdef MOMENT
9858       s1=dip(1,jj,i)*dipderg(1,kk,k)
9859 #endif
9860       call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
9861       s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
9862       call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
9863       s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
9864       call transpose2(EUgder(1,1,k),auxmat1(1,1))
9865       call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
9866       vv(1)=pizda(1,1)-pizda(2,2)
9867       vv(2)=pizda(1,2)+pizda(2,1)
9868       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
9869 #ifdef MOMENT
9870       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
9871 #else
9872       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
9873 #endif
9874 c      g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
9875 C Derivatives in gamma(j-1) or gamma(l-1)
9876       if (j.gt.1) then
9877 #ifdef MOMENT
9878         s1=dipderg(3,jj,i)*dip(1,kk,k)
9879 #endif
9880         call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
9881         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
9882         s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
9883         call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
9884         vv(1)=pizda(1,1)-pizda(2,2)
9885         vv(2)=pizda(1,2)+pizda(2,1)
9886         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
9887 #ifdef MOMENT
9888         if (swap) then
9889           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
9890         else
9891           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
9892         endif
9893 #endif
9894         g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
9895 c        g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
9896       endif
9897 C Derivatives in gamma(l-1) or gamma(j-1)
9898       if (l.gt.1) then
9899 #ifdef MOMENT
9900         s1=dip(1,jj,i)*dipderg(3,kk,k)
9901 #endif
9902         call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
9903         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
9904         call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
9905         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
9906         call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
9907         vv(1)=pizda(1,1)-pizda(2,2)
9908         vv(2)=pizda(1,2)+pizda(2,1)
9909         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
9910 #ifdef MOMENT
9911         if (swap) then
9912           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
9913         else
9914           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
9915         endif
9916 #endif
9917         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
9918 c        g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
9919       endif
9920 C Cartesian derivatives.
9921       if (lprn) then
9922         write (2,*) 'In eello6_graph2'
9923         do iii=1,2
9924           write (2,*) 'iii=',iii
9925           do kkk=1,5
9926             write (2,*) 'kkk=',kkk
9927             do jjj=1,2
9928               write (2,'(3(2f10.5),5x)')
9929      &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
9930             enddo
9931           enddo
9932         enddo
9933       endif
9934       do iii=1,2
9935         do kkk=1,5
9936           do lll=1,3
9937 #ifdef MOMENT
9938             if (iii.eq.1) then
9939               s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
9940             else
9941               s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
9942             endif
9943 #endif
9944             call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),
9945      &        auxvec(1))
9946             s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
9947             call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),
9948      &        auxvec(1))
9949             s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
9950             call transpose2(EUg(1,1,k),auxmat(1,1))
9951             call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),
9952      &        pizda(1,1))
9953             vv(1)=pizda(1,1)-pizda(2,2)
9954             vv(2)=pizda(1,2)+pizda(2,1)
9955             s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
9956 cd            write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
9957 #ifdef MOMENT
9958             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
9959 #else
9960             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
9961 #endif
9962             if (swap) then
9963               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
9964             else
9965               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
9966             endif
9967           enddo
9968         enddo
9969       enddo
9970       return
9971       end
9972 c----------------------------------------------------------------------------
9973       double precision function eello6_graph3(i,j,k,l,jj,kk,swap)
9974       implicit real*8 (a-h,o-z)
9975       include 'DIMENSIONS'
9976       include 'COMMON.IOUNITS'
9977       include 'COMMON.CHAIN'
9978       include 'COMMON.DERIV'
9979       include 'COMMON.INTERACT'
9980       include 'COMMON.CONTACTS'
9981       include 'COMMON.TORSION'
9982       include 'COMMON.VAR'
9983       include 'COMMON.GEO'
9984       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2)
9985       logical swap
9986 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9987 C                                                                              C
9988 C      Parallel       Antiparallel                                             C
9989 C                                                                              C
9990 C          o             o                                                     C
9991 C         /l\   /   \   /j\                                                    C
9992 C        /   \ /     \ /   \                                                   C
9993 C       /| o |o       o| o |\                                                  C
9994 C       j|/k\|  /      |/k\|l /                                                C
9995 C        /   \ /       /   \ /                                                 C
9996 C       /     o       /     o                                                  C
9997 C       i             i                                                        C
9998 C                                                                              C
9999 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10000 C
10001 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
10002 C           energy moment and not to the cluster cumulant.
10003       iti=itortyp(itype(i))
10004       if (j.lt.nres-1) then
10005         itj1=itortyp(itype(j+1))
10006       else
10007         itj1=ntortyp
10008       endif
10009       itk=itortyp(itype(k))
10010       itk1=itortyp(itype(k+1))
10011       if (l.lt.nres-1) then
10012         itl1=itortyp(itype(l+1))
10013       else
10014         itl1=ntortyp
10015       endif
10016 #ifdef MOMENT
10017       s1=dip(4,jj,i)*dip(4,kk,k)
10018 #endif
10019       call matvec2(AECA(1,1,1),b1(1,k+1),auxvec(1))
10020       s2=0.5d0*scalar2(b1(1,k),auxvec(1))
10021       call matvec2(AECA(1,1,2),b1(1,l+1),auxvec(1))
10022       s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
10023       call transpose2(EE(1,1,itk),auxmat(1,1))
10024       call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
10025       vv(1)=pizda(1,1)+pizda(2,2)
10026       vv(2)=pizda(2,1)-pizda(1,2)
10027       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
10028 cd      write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4,
10029 cd     & "sum",-(s2+s3+s4)
10030 #ifdef MOMENT
10031       eello6_graph3=-(s1+s2+s3+s4)
10032 #else
10033       eello6_graph3=-(s2+s3+s4)
10034 #endif
10035 c      eello6_graph3=-s4
10036 C Derivatives in gamma(k-1)
10037       call matvec2(AECAderg(1,1,2),b1(1,l+1),auxvec(1))
10038       s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
10039       s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
10040       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
10041 C Derivatives in gamma(l-1)
10042       call matvec2(AECAderg(1,1,1),b1(1,k+1),auxvec(1))
10043       s2=0.5d0*scalar2(b1(1,k),auxvec(1))
10044       call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
10045       vv(1)=pizda(1,1)+pizda(2,2)
10046       vv(2)=pizda(2,1)-pizda(1,2)
10047       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
10048       g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
10049 C Cartesian derivatives.
10050       do iii=1,2
10051         do kkk=1,5
10052           do lll=1,3
10053 #ifdef MOMENT
10054             if (iii.eq.1) then
10055               s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
10056             else
10057               s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
10058             endif
10059 #endif
10060             call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
10061      &        auxvec(1))
10062             s2=0.5d0*scalar2(b1(1,k),auxvec(1))
10063             call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,l+1),
10064      &        auxvec(1))
10065             s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
10066             call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),
10067      &        pizda(1,1))
10068             vv(1)=pizda(1,1)+pizda(2,2)
10069             vv(2)=pizda(2,1)-pizda(1,2)
10070             s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
10071 #ifdef MOMENT
10072             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
10073 #else
10074             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
10075 #endif
10076             if (swap) then
10077               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
10078             else
10079               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
10080             endif
10081 c            derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
10082           enddo
10083         enddo
10084       enddo
10085       return
10086       end
10087 c----------------------------------------------------------------------------
10088       double precision function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
10089       implicit real*8 (a-h,o-z)
10090       include 'DIMENSIONS'
10091       include 'COMMON.IOUNITS'
10092       include 'COMMON.CHAIN'
10093       include 'COMMON.DERIV'
10094       include 'COMMON.INTERACT'
10095       include 'COMMON.CONTACTS'
10096       include 'COMMON.TORSION'
10097       include 'COMMON.VAR'
10098       include 'COMMON.GEO'
10099       include 'COMMON.FFIELD'
10100       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
10101      & auxvec1(2),auxmat1(2,2)
10102       logical swap
10103 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10104 C                                                                              C
10105 C      Parallel       Antiparallel                                             C
10106 C                                                                              C
10107 C          o             o                                                     C
10108 C         /l\   /   \   /j\                                                    C
10109 C        /   \ /     \ /   \                                                   C
10110 C       /| o |o       o| o |\                                                  C
10111 C     \ j|/k\|      \  |/k\|l                                                  C
10112 C      \ /   \       \ /   \                                                   C
10113 C       o     \       o     \                                                  C
10114 C       i             i                                                        C
10115 C                                                                              C
10116 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10117 C
10118 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
10119 C           energy moment and not to the cluster cumulant.
10120 cd      write (2,*) 'eello_graph4: wturn6',wturn6
10121       iti=itortyp(itype(i))
10122       itj=itortyp(itype(j))
10123       if (j.lt.nres-1) then
10124         itj1=itortyp(itype(j+1))
10125       else
10126         itj1=ntortyp
10127       endif
10128       itk=itortyp(itype(k))
10129       if (k.lt.nres-1) then
10130         itk1=itortyp(itype(k+1))
10131       else
10132         itk1=ntortyp
10133       endif
10134       itl=itortyp(itype(l))
10135       if (l.lt.nres-1) then
10136         itl1=itortyp(itype(l+1))
10137       else
10138         itl1=ntortyp
10139       endif
10140 cd      write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
10141 cd      write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
10142 cd     & ' itl',itl,' itl1',itl1
10143 #ifdef MOMENT
10144       if (imat.eq.1) then
10145         s1=dip(3,jj,i)*dip(3,kk,k)
10146       else
10147         s1=dip(2,jj,j)*dip(2,kk,l)
10148       endif
10149 #endif
10150       call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
10151       s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
10152       if (j.eq.l+1) then
10153         call matvec2(ADtEA1(1,1,3-imat),b1(1,j+1),auxvec1(1))
10154         s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
10155       else
10156         call matvec2(ADtEA1(1,1,3-imat),b1(1,l+1),auxvec1(1))
10157         s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
10158       endif
10159       call transpose2(EUg(1,1,k),auxmat(1,1))
10160       call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
10161       vv(1)=pizda(1,1)-pizda(2,2)
10162       vv(2)=pizda(2,1)+pizda(1,2)
10163       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
10164 cd      write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
10165 #ifdef MOMENT
10166       eello6_graph4=-(s1+s2+s3+s4)
10167 #else
10168       eello6_graph4=-(s2+s3+s4)
10169 #endif
10170 C Derivatives in gamma(i-1)
10171       if (i.gt.1) then
10172 #ifdef MOMENT
10173         if (imat.eq.1) then
10174           s1=dipderg(2,jj,i)*dip(3,kk,k)
10175         else
10176           s1=dipderg(4,jj,j)*dip(2,kk,l)
10177         endif
10178 #endif
10179         s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
10180         if (j.eq.l+1) then
10181           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,j+1),auxvec1(1))
10182           s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
10183         else
10184           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,l+1),auxvec1(1))
10185           s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
10186         endif
10187         s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
10188         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
10189 cd          write (2,*) 'turn6 derivatives'
10190 #ifdef MOMENT
10191           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
10192 #else
10193           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
10194 #endif
10195         else
10196 #ifdef MOMENT
10197           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
10198 #else
10199           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
10200 #endif
10201         endif
10202       endif
10203 C Derivatives in gamma(k-1)
10204 #ifdef MOMENT
10205       if (imat.eq.1) then
10206         s1=dip(3,jj,i)*dipderg(2,kk,k)
10207       else
10208         s1=dip(2,jj,j)*dipderg(4,kk,l)
10209       endif
10210 #endif
10211       call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
10212       s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
10213       if (j.eq.l+1) then
10214         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,j+1),auxvec1(1))
10215         s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
10216       else
10217         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,l+1),auxvec1(1))
10218         s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
10219       endif
10220       call transpose2(EUgder(1,1,k),auxmat1(1,1))
10221       call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
10222       vv(1)=pizda(1,1)-pizda(2,2)
10223       vv(2)=pizda(2,1)+pizda(1,2)
10224       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
10225       if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
10226 #ifdef MOMENT
10227         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
10228 #else
10229         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
10230 #endif
10231       else
10232 #ifdef MOMENT
10233         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
10234 #else
10235         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
10236 #endif
10237       endif
10238 C Derivatives in gamma(j-1) or gamma(l-1)
10239       if (l.eq.j+1 .and. l.gt.1) then
10240         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
10241         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
10242         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
10243         vv(1)=pizda(1,1)-pizda(2,2)
10244         vv(2)=pizda(2,1)+pizda(1,2)
10245         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
10246         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
10247       else if (j.gt.1) then
10248         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
10249         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
10250         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
10251         vv(1)=pizda(1,1)-pizda(2,2)
10252         vv(2)=pizda(2,1)+pizda(1,2)
10253         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
10254         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
10255           gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
10256         else
10257           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
10258         endif
10259       endif
10260 C Cartesian derivatives.
10261       do iii=1,2
10262         do kkk=1,5
10263           do lll=1,3
10264 #ifdef MOMENT
10265             if (iii.eq.1) then
10266               if (imat.eq.1) then
10267                 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
10268               else
10269                 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
10270               endif
10271             else
10272               if (imat.eq.1) then
10273                 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
10274               else
10275                 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
10276               endif
10277             endif
10278 #endif
10279             call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),
10280      &        auxvec(1))
10281             s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
10282             if (j.eq.l+1) then
10283               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
10284      &          b1(1,j+1),auxvec(1))
10285               s3=-0.5d0*scalar2(b1(1,j),auxvec(1))
10286             else
10287               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
10288      &          b1(1,l+1),auxvec(1))
10289               s3=-0.5d0*scalar2(b1(1,l),auxvec(1))
10290             endif
10291             call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
10292      &        pizda(1,1))
10293             vv(1)=pizda(1,1)-pizda(2,2)
10294             vv(2)=pizda(2,1)+pizda(1,2)
10295             s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
10296             if (swap) then
10297               if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
10298 #ifdef MOMENT
10299                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
10300      &             -(s1+s2+s4)
10301 #else
10302                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
10303      &             -(s2+s4)
10304 #endif
10305                 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
10306               else
10307 #ifdef MOMENT
10308                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
10309 #else
10310                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
10311 #endif
10312                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
10313               endif
10314             else
10315 #ifdef MOMENT
10316               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
10317 #else
10318               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
10319 #endif
10320               if (l.eq.j+1) then
10321                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
10322               else
10323                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
10324               endif
10325             endif
10326           enddo
10327         enddo
10328       enddo
10329       return
10330       end
10331 c----------------------------------------------------------------------------
10332       double precision function eello_turn6(i,jj,kk)
10333       implicit real*8 (a-h,o-z)
10334       include 'DIMENSIONS'
10335       include 'COMMON.IOUNITS'
10336       include 'COMMON.CHAIN'
10337       include 'COMMON.DERIV'
10338       include 'COMMON.INTERACT'
10339       include 'COMMON.CONTACTS'
10340       include 'COMMON.TORSION'
10341       include 'COMMON.VAR'
10342       include 'COMMON.GEO'
10343       double precision vtemp1(2),vtemp2(2),vtemp3(2),vtemp4(2),
10344      &  atemp(2,2),auxmat(2,2),achuj_temp(2,2),gtemp(2,2),gvec(2),
10345      &  ggg1(3),ggg2(3)
10346       double precision vtemp1d(2),vtemp2d(2),vtemp3d(2),vtemp4d(2),
10347      &  atempd(2,2),auxmatd(2,2),achuj_tempd(2,2),gtempd(2,2),gvecd(2)
10348 C 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
10349 C           the respective energy moment and not to the cluster cumulant.
10350       s1=0.0d0
10351       s8=0.0d0
10352       s13=0.0d0
10353 c
10354       eello_turn6=0.0d0
10355       j=i+4
10356       k=i+1
10357       l=i+3
10358       iti=itortyp(itype(i))
10359       itk=itortyp(itype(k))
10360       itk1=itortyp(itype(k+1))
10361       itl=itortyp(itype(l))
10362       itj=itortyp(itype(j))
10363 cd      write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
10364 cd      write (2,*) 'i',i,' k',k,' j',j,' l',l
10365 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
10366 cd        eello6=0.0d0
10367 cd        return
10368 cd      endif
10369 cd      write (iout,*)
10370 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
10371 cd     &   ' and',k,l
10372 cd      call checkint_turn6(i,jj,kk,eel_turn6_num)
10373       do iii=1,2
10374         do kkk=1,5
10375           do lll=1,3
10376             derx_turn(lll,kkk,iii)=0.0d0
10377           enddo
10378         enddo
10379       enddo
10380 cd      eij=1.0d0
10381 cd      ekl=1.0d0
10382 cd      ekont=1.0d0
10383       eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
10384 cd      eello6_5=0.0d0
10385 cd      write (2,*) 'eello6_5',eello6_5
10386 #ifdef MOMENT
10387       call transpose2(AEA(1,1,1),auxmat(1,1))
10388       call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
10389       ss1=scalar2(Ub2(1,i+2),b1(1,l))
10390       s1 = (auxmat(1,1)+auxmat(2,2))*ss1
10391 #endif
10392       call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1(1))
10393       call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
10394       s2 = scalar2(b1(1,k),vtemp1(1))
10395 #ifdef MOMENT
10396       call transpose2(AEA(1,1,2),atemp(1,1))
10397       call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
10398       call matvec2(Ug2(1,1,i+2),dd(1,1,itk1),vtemp2(1))
10399       s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
10400 #endif
10401       call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
10402       call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
10403       s12 = scalar2(Ub2(1,i+2),vtemp3(1))
10404 #ifdef MOMENT
10405       call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
10406       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
10407       call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
10408       call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
10409       ss13 = scalar2(b1(1,k),vtemp4(1))
10410       s13 = (gtemp(1,1)+gtemp(2,2))*ss13
10411 #endif
10412 c      write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
10413 c      s1=0.0d0
10414 c      s2=0.0d0
10415 c      s8=0.0d0
10416 c      s12=0.0d0
10417 c      s13=0.0d0
10418       eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
10419 C Derivatives in gamma(i+2)
10420       s1d =0.0d0
10421       s8d =0.0d0
10422 #ifdef MOMENT
10423       call transpose2(AEA(1,1,1),auxmatd(1,1))
10424       call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
10425       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
10426       call transpose2(AEAderg(1,1,2),atempd(1,1))
10427       call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
10428       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
10429 #endif
10430       call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
10431       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
10432       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
10433 c      s1d=0.0d0
10434 c      s2d=0.0d0
10435 c      s8d=0.0d0
10436 c      s12d=0.0d0
10437 c      s13d=0.0d0
10438       gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
10439 C Derivatives in gamma(i+3)
10440 #ifdef MOMENT
10441       call transpose2(AEA(1,1,1),auxmatd(1,1))
10442       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
10443       ss1d=scalar2(Ub2der(1,i+2),b1(1,l))
10444       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
10445 #endif
10446       call matvec2(EUgder(1,1,i+2),b1(1,l),vtemp1d(1))
10447       call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
10448       s2d = scalar2(b1(1,k),vtemp1d(1))
10449 #ifdef MOMENT
10450       call matvec2(Ug2der(1,1,i+2),dd(1,1,itk1),vtemp2d(1))
10451       s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2d(1))
10452 #endif
10453       s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
10454 #ifdef MOMENT
10455       call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
10456       call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
10457       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
10458 #endif
10459 c      s1d=0.0d0
10460 c      s2d=0.0d0
10461 c      s8d=0.0d0
10462 c      s12d=0.0d0
10463 c      s13d=0.0d0
10464 #ifdef MOMENT
10465       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
10466      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
10467 #else
10468       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
10469      &               -0.5d0*ekont*(s2d+s12d)
10470 #endif
10471 C Derivatives in gamma(i+4)
10472       call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
10473       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
10474       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
10475 #ifdef MOMENT
10476       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
10477       call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
10478       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
10479 #endif
10480 c      s1d=0.0d0
10481 c      s2d=0.0d0
10482 c      s8d=0.0d0
10483 C      s12d=0.0d0
10484 c      s13d=0.0d0
10485 #ifdef MOMENT
10486       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
10487 #else
10488       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
10489 #endif
10490 C Derivatives in gamma(i+5)
10491 #ifdef MOMENT
10492       call transpose2(AEAderg(1,1,1),auxmatd(1,1))
10493       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
10494       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
10495 #endif
10496       call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1d(1))
10497       call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
10498       s2d = scalar2(b1(1,k),vtemp1d(1))
10499 #ifdef MOMENT
10500       call transpose2(AEA(1,1,2),atempd(1,1))
10501       call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
10502       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
10503 #endif
10504       call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
10505       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
10506 #ifdef MOMENT
10507       call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
10508       ss13d = scalar2(b1(1,k),vtemp4d(1))
10509       s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
10510 #endif
10511 c      s1d=0.0d0
10512 c      s2d=0.0d0
10513 c      s8d=0.0d0
10514 c      s12d=0.0d0
10515 c      s13d=0.0d0
10516 #ifdef MOMENT
10517       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
10518      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
10519 #else
10520       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
10521      &               -0.5d0*ekont*(s2d+s12d)
10522 #endif
10523 C Cartesian derivatives
10524       do iii=1,2
10525         do kkk=1,5
10526           do lll=1,3
10527 #ifdef MOMENT
10528             call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
10529             call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
10530             s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
10531 #endif
10532             call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1(1))
10533             call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),
10534      &          vtemp1d(1))
10535             s2d = scalar2(b1(1,k),vtemp1d(1))
10536 #ifdef MOMENT
10537             call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
10538             call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
10539             s8d = -(atempd(1,1)+atempd(2,2))*
10540      &           scalar2(cc(1,1,itl),vtemp2(1))
10541 #endif
10542             call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),
10543      &           auxmatd(1,1))
10544             call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
10545             s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
10546 c      s1d=0.0d0
10547 c      s2d=0.0d0
10548 c      s8d=0.0d0
10549 c      s12d=0.0d0
10550 c      s13d=0.0d0
10551 #ifdef MOMENT
10552             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
10553      &        - 0.5d0*(s1d+s2d)
10554 #else
10555             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
10556      &        - 0.5d0*s2d
10557 #endif
10558 #ifdef MOMENT
10559             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
10560      &        - 0.5d0*(s8d+s12d)
10561 #else
10562             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
10563      &        - 0.5d0*s12d
10564 #endif
10565           enddo
10566         enddo
10567       enddo
10568 #ifdef MOMENT
10569       do kkk=1,5
10570         do lll=1,3
10571           call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),
10572      &      achuj_tempd(1,1))
10573           call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
10574           call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
10575           s13d=(gtempd(1,1)+gtempd(2,2))*ss13
10576           derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
10577           call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),
10578      &      vtemp4d(1))
10579           ss13d = scalar2(b1(1,k),vtemp4d(1))
10580           s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
10581           derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
10582         enddo
10583       enddo
10584 #endif
10585 cd      write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
10586 cd     &  16*eel_turn6_num
10587 cd      goto 1112
10588       if (j.lt.nres-1) then
10589         j1=j+1
10590         j2=j-1
10591       else
10592         j1=j-1
10593         j2=j-2
10594       endif
10595       if (l.lt.nres-1) then
10596         l1=l+1
10597         l2=l-1
10598       else
10599         l1=l-1
10600         l2=l-2
10601       endif
10602       do ll=1,3
10603 cgrad        ggg1(ll)=eel_turn6*g_contij(ll,1)
10604 cgrad        ggg2(ll)=eel_turn6*g_contij(ll,2)
10605 cgrad        ghalf=0.5d0*ggg1(ll)
10606 cd        ghalf=0.0d0
10607         gturn6ij=eel_turn6*g_contij(ll,1)+ekont*derx_turn(ll,1,1)
10608         gturn6kl=eel_turn6*g_contij(ll,2)+ekont*derx_turn(ll,1,2)
10609         gcorr6_turn(ll,i)=gcorr6_turn(ll,i)!+ghalf
10610      &    +ekont*derx_turn(ll,2,1)
10611         gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
10612         gcorr6_turn(ll,j)=gcorr6_turn(ll,j)!+ghalf
10613      &    +ekont*derx_turn(ll,4,1)
10614         gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
10615         gcorr6_turn_long(ll,j)=gcorr6_turn_long(ll,j)+gturn6ij
10616         gcorr6_turn_long(ll,i)=gcorr6_turn_long(ll,i)-gturn6ij
10617 cgrad        ghalf=0.5d0*ggg2(ll)
10618 cd        ghalf=0.0d0
10619         gcorr6_turn(ll,k)=gcorr6_turn(ll,k)!+ghalf
10620      &    +ekont*derx_turn(ll,2,2)
10621         gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
10622         gcorr6_turn(ll,l)=gcorr6_turn(ll,l)!+ghalf
10623      &    +ekont*derx_turn(ll,4,2)
10624         gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
10625         gcorr6_turn_long(ll,l)=gcorr6_turn_long(ll,l)+gturn6kl
10626         gcorr6_turn_long(ll,k)=gcorr6_turn_long(ll,k)-gturn6kl
10627       enddo
10628 cd      goto 1112
10629 cgrad      do m=i+1,j-1
10630 cgrad        do ll=1,3
10631 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
10632 cgrad        enddo
10633 cgrad      enddo
10634 cgrad      do m=k+1,l-1
10635 cgrad        do ll=1,3
10636 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
10637 cgrad        enddo
10638 cgrad      enddo
10639 cgrad1112  continue
10640 cgrad      do m=i+2,j2
10641 cgrad        do ll=1,3
10642 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
10643 cgrad        enddo
10644 cgrad      enddo
10645 cgrad      do m=k+2,l2
10646 cgrad        do ll=1,3
10647 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
10648 cgrad        enddo
10649 cgrad      enddo
10650 cd      do iii=1,nres-3
10651 cd        write (2,*) iii,g_corr6_loc(iii)
10652 cd      enddo
10653       eello_turn6=ekont*eel_turn6
10654 cd      write (2,*) 'ekont',ekont
10655 cd      write (2,*) 'eel_turn6',ekont*eel_turn6
10656       return
10657       end
10658
10659 C-----------------------------------------------------------------------------
10660       double precision function scalar(u,v)
10661 !DIR$ INLINEALWAYS scalar
10662 #ifndef OSF
10663 cDEC$ ATTRIBUTES FORCEINLINE::scalar
10664 #endif
10665       implicit none
10666       double precision u(3),v(3)
10667 cd      double precision sc
10668 cd      integer i
10669 cd      sc=0.0d0
10670 cd      do i=1,3
10671 cd        sc=sc+u(i)*v(i)
10672 cd      enddo
10673 cd      scalar=sc
10674
10675       scalar=u(1)*v(1)+u(2)*v(2)+u(3)*v(3)
10676       return
10677       end
10678 crc-------------------------------------------------
10679       SUBROUTINE MATVEC2(A1,V1,V2)
10680 !DIR$ INLINEALWAYS MATVEC2
10681 #ifndef OSF
10682 cDEC$ ATTRIBUTES FORCEINLINE::MATVEC2
10683 #endif
10684       implicit real*8 (a-h,o-z)
10685       include 'DIMENSIONS'
10686       DIMENSION A1(2,2),V1(2),V2(2)
10687 c      DO 1 I=1,2
10688 c        VI=0.0
10689 c        DO 3 K=1,2
10690 c    3     VI=VI+A1(I,K)*V1(K)
10691 c        Vaux(I)=VI
10692 c    1 CONTINUE
10693
10694       vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
10695       vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
10696
10697       v2(1)=vaux1
10698       v2(2)=vaux2
10699       END
10700 C---------------------------------------
10701       SUBROUTINE MATMAT2(A1,A2,A3)
10702 #ifndef OSF
10703 cDEC$ ATTRIBUTES FORCEINLINE::MATMAT2
10704 #endif
10705       implicit real*8 (a-h,o-z)
10706       include 'DIMENSIONS'
10707       DIMENSION A1(2,2),A2(2,2),A3(2,2)
10708 c      DIMENSION AI3(2,2)
10709 c        DO  J=1,2
10710 c          A3IJ=0.0
10711 c          DO K=1,2
10712 c           A3IJ=A3IJ+A1(I,K)*A2(K,J)
10713 c          enddo
10714 c          A3(I,J)=A3IJ
10715 c       enddo
10716 c      enddo
10717
10718       ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
10719       ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
10720       ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
10721       ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
10722
10723       A3(1,1)=AI3_11
10724       A3(2,1)=AI3_21
10725       A3(1,2)=AI3_12
10726       A3(2,2)=AI3_22
10727       END
10728
10729 c-------------------------------------------------------------------------
10730       double precision function scalar2(u,v)
10731 !DIR$ INLINEALWAYS scalar2
10732       implicit none
10733       double precision u(2),v(2)
10734       double precision sc
10735       integer i
10736       scalar2=u(1)*v(1)+u(2)*v(2)
10737       return
10738       end
10739
10740 C-----------------------------------------------------------------------------
10741
10742       subroutine transpose2(a,at)
10743 !DIR$ INLINEALWAYS transpose2
10744 #ifndef OSF
10745 cDEC$ ATTRIBUTES FORCEINLINE::transpose2
10746 #endif
10747       implicit none
10748       double precision a(2,2),at(2,2)
10749       at(1,1)=a(1,1)
10750       at(1,2)=a(2,1)
10751       at(2,1)=a(1,2)
10752       at(2,2)=a(2,2)
10753       return
10754       end
10755 c--------------------------------------------------------------------------
10756       subroutine transpose(n,a,at)
10757       implicit none
10758       integer n,i,j
10759       double precision a(n,n),at(n,n)
10760       do i=1,n
10761         do j=1,n
10762           at(j,i)=a(i,j)
10763         enddo
10764       enddo
10765       return
10766       end
10767 C---------------------------------------------------------------------------
10768       subroutine prodmat3(a1,a2,kk,transp,prod)
10769 !DIR$ INLINEALWAYS prodmat3
10770 #ifndef OSF
10771 cDEC$ ATTRIBUTES FORCEINLINE::prodmat3
10772 #endif
10773       implicit none
10774       integer i,j
10775       double precision a1(2,2),a2(2,2),a2t(2,2),kk(2,2),prod(2,2)
10776       logical transp
10777 crc      double precision auxmat(2,2),prod_(2,2)
10778
10779       if (transp) then
10780 crc        call transpose2(kk(1,1),auxmat(1,1))
10781 crc        call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
10782 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
10783
10784            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1)
10785      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
10786            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2)
10787      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
10788            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1)
10789      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
10790            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2)
10791      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
10792
10793       else
10794 crc        call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
10795 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
10796
10797            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1)
10798      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
10799            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2)
10800      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
10801            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1)
10802      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
10803            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2)
10804      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
10805
10806       endif
10807 c      call transpose2(a2(1,1),a2t(1,1))
10808
10809 crc      print *,transp
10810 crc      print *,((prod_(i,j),i=1,2),j=1,2)
10811 crc      print *,((prod(i,j),i=1,2),j=1,2)
10812
10813       return
10814       end
10815 CCC----------------------------------------------
10816       subroutine Eliptransfer(eliptran)
10817       implicit real*8 (a-h,o-z)
10818       include 'DIMENSIONS'
10819       include 'COMMON.GEO'
10820       include 'COMMON.VAR'
10821       include 'COMMON.LOCAL'
10822       include 'COMMON.CHAIN'
10823       include 'COMMON.DERIV'
10824       include 'COMMON.NAMES'
10825       include 'COMMON.INTERACT'
10826       include 'COMMON.IOUNITS'
10827       include 'COMMON.CALC'
10828       include 'COMMON.CONTROL'
10829       include 'COMMON.SPLITELE'
10830       include 'COMMON.SBRIDGE'
10831 C this is done by Adasko
10832 C      print *,"wchodze"
10833 C structure of box:
10834 C      water
10835 C--bordliptop-- buffore starts
10836 C--bufliptop--- here true lipid starts
10837 C      lipid
10838 C--buflipbot--- lipid ends buffore starts
10839 C--bordlipbot--buffore ends
10840       eliptran=0.0
10841       do i=ilip_start,ilip_end
10842 C       do i=1,1
10843         if (itype(i).eq.ntyp1) cycle
10844
10845         positi=(mod(((c(3,i)+c(3,i+1))/2.0d0),boxzsize))
10846         if (positi.le.0) positi=positi+boxzsize
10847 C        print *,i
10848 C first for peptide groups
10849 c for each residue check if it is in lipid or lipid water border area
10850        if ((positi.gt.bordlipbot)
10851      &.and.(positi.lt.bordliptop)) then
10852 C the energy transfer exist
10853         if (positi.lt.buflipbot) then
10854 C what fraction I am in
10855          fracinbuf=1.0d0-
10856      &        ((positi-bordlipbot)/lipbufthick)
10857 C lipbufthick is thickenes of lipid buffore
10858          sslip=sscalelip(fracinbuf)
10859          ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
10860          eliptran=eliptran+sslip*pepliptran
10861          gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
10862          gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
10863 C         gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
10864
10865 C        print *,"doing sccale for lower part"
10866 C         print *,i,sslip,fracinbuf,ssgradlip
10867         elseif (positi.gt.bufliptop) then
10868          fracinbuf=1.0d0-((bordliptop-positi)/lipbufthick)
10869          sslip=sscalelip(fracinbuf)
10870          ssgradlip=sscagradlip(fracinbuf)/lipbufthick
10871          eliptran=eliptran+sslip*pepliptran
10872          gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
10873          gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
10874 C         gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
10875 C          print *, "doing sscalefor top part"
10876 C         print *,i,sslip,fracinbuf,ssgradlip
10877         else
10878          eliptran=eliptran+pepliptran
10879 C         print *,"I am in true lipid"
10880         endif
10881 C       else
10882 C       eliptran=elpitran+0.0 ! I am in water
10883        endif
10884        enddo
10885 C       print *, "nic nie bylo w lipidzie?"
10886 C now multiply all by the peptide group transfer factor
10887 C       eliptran=eliptran*pepliptran
10888 C now the same for side chains
10889 CV       do i=1,1
10890        do i=ilip_start,ilip_end
10891         if (itype(i).eq.ntyp1) cycle
10892         positi=(mod(c(3,i+nres),boxzsize))
10893         if (positi.le.0) positi=positi+boxzsize
10894 C       print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop
10895 c for each residue check if it is in lipid or lipid water border area
10896 C       respos=mod(c(3,i+nres),boxzsize)
10897 C       print *,positi,bordlipbot,buflipbot
10898        if ((positi.gt.bordlipbot)
10899      & .and.(positi.lt.bordliptop)) then
10900 C the energy transfer exist
10901         if (positi.lt.buflipbot) then
10902          fracinbuf=1.0d0-
10903      &     ((positi-bordlipbot)/lipbufthick)
10904 C lipbufthick is thickenes of lipid buffore
10905          sslip=sscalelip(fracinbuf)
10906          ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
10907          eliptran=eliptran+sslip*liptranene(itype(i))
10908          gliptranx(3,i)=gliptranx(3,i)
10909      &+ssgradlip*liptranene(itype(i))
10910          gliptranc(3,i-1)= gliptranc(3,i-1)
10911      &+ssgradlip*liptranene(itype(i))
10912 C         print *,"doing sccale for lower part"
10913         elseif (positi.gt.bufliptop) then
10914          fracinbuf=1.0d0-
10915      &((bordliptop-positi)/lipbufthick)
10916          sslip=sscalelip(fracinbuf)
10917          ssgradlip=sscagradlip(fracinbuf)/lipbufthick
10918          eliptran=eliptran+sslip*liptranene(itype(i))
10919          gliptranx(3,i)=gliptranx(3,i)
10920      &+ssgradlip*liptranene(itype(i))
10921          gliptranc(3,i-1)= gliptranc(3,i-1)
10922      &+ssgradlip*liptranene(itype(i))
10923 C          print *, "doing sscalefor top part",sslip,fracinbuf
10924         else
10925          eliptran=eliptran+liptranene(itype(i))
10926 C         print *,"I am in true lipid"
10927         endif
10928         endif ! if in lipid or buffor
10929 C       else
10930 C       eliptran=elpitran+0.0 ! I am in water
10931        enddo
10932        return
10933        end
10934 C---------------------------------------------------------
10935 C AFM soubroutine for constant force
10936        subroutine AFMforce(Eafmforce)
10937        implicit real*8 (a-h,o-z)
10938       include 'DIMENSIONS'
10939       include 'COMMON.GEO'
10940       include 'COMMON.VAR'
10941       include 'COMMON.LOCAL'
10942       include 'COMMON.CHAIN'
10943       include 'COMMON.DERIV'
10944       include 'COMMON.NAMES'
10945       include 'COMMON.INTERACT'
10946       include 'COMMON.IOUNITS'
10947       include 'COMMON.CALC'
10948       include 'COMMON.CONTROL'
10949       include 'COMMON.SPLITELE'
10950       include 'COMMON.SBRIDGE'
10951       real*8 diffafm(3)
10952       dist=0.0d0
10953       Eafmforce=0.0d0
10954       do i=1,3
10955       diffafm(i)=c(i,afmend)-c(i,afmbeg)
10956       dist=dist+diffafm(i)**2
10957       enddo
10958       dist=dsqrt(dist)
10959       Eafmforce=-forceAFMconst*(dist-distafminit)
10960       do i=1,3
10961       gradafm(i,afmend-1)=-forceAFMconst*diffafm(i)/dist
10962       gradafm(i,afmbeg-1)=forceAFMconst*diffafm(i)/dist
10963       enddo
10964 C      print *,'AFM',Eafmforce
10965       return
10966       end
10967 C---------------------------------------------------------
10968 C AFM subroutine with pseudoconstant velocity
10969        subroutine AFMvel(Eafmforce)
10970        implicit real*8 (a-h,o-z)
10971       include 'DIMENSIONS'
10972       include 'COMMON.GEO'
10973       include 'COMMON.VAR'
10974       include 'COMMON.LOCAL'
10975       include 'COMMON.CHAIN'
10976       include 'COMMON.DERIV'
10977       include 'COMMON.NAMES'
10978       include 'COMMON.INTERACT'
10979       include 'COMMON.IOUNITS'
10980       include 'COMMON.CALC'
10981       include 'COMMON.CONTROL'
10982       include 'COMMON.SPLITELE'
10983       include 'COMMON.SBRIDGE'
10984       real*8 diffafm(3)
10985 C Only for check grad COMMENT if not used for checkgrad
10986 C      totT=3.0d0
10987 C--------------------------------------------------------
10988 C      print *,"wchodze"
10989       dist=0.0d0
10990       Eafmforce=0.0d0
10991       do i=1,3
10992       diffafm(i)=c(i,afmend)-c(i,afmbeg)
10993       dist=dist+diffafm(i)**2
10994       enddo
10995       dist=dsqrt(dist)
10996       Eafmforce=0.5d0*forceAFMconst
10997      & *(distafminit+totTafm*velAFMconst-dist)**2
10998 C      Eafmforce=-forceAFMconst*(dist-distafminit)
10999       do i=1,3
11000       gradafm(i,afmend-1)=-forceAFMconst*
11001      &(distafminit+totTafm*velAFMconst-dist)
11002      &*diffafm(i)/dist
11003       gradafm(i,afmbeg-1)=forceAFMconst*
11004      &(distafminit+totTafm*velAFMconst-dist)
11005      &*diffafm(i)/dist
11006       enddo
11007 C      print *,'AFM',Eafmforce,totTafm*velAFMconst,dist
11008       return
11009       end
11010 C-----------------------------------------------------------
11011 C first for shielding is setting of function of side-chains
11012        subroutine set_shield_fac
11013       implicit real*8 (a-h,o-z)
11014       include 'DIMENSIONS'
11015       include 'COMMON.CHAIN'
11016       include 'COMMON.DERIV'
11017       include 'COMMON.IOUNITS'
11018       include 'COMMON.SHIELD'
11019       include 'COMMON.INTERACT'
11020 C this is the squar root 77 devided by 81 the epislion in lipid (in protein)
11021       double precision div77_81/0.974996043d0/,
11022      &div4_81/0.2222222222d0/,sh_frac_dist_grad(3)
11023
11024 C the vector between center of side_chain and peptide group
11025        double precision pep_side(3),long,side_calf(3),
11026      &pept_group(3),costhet_grad(3),cosphi_grad_long(3),
11027      &cosphi_grad_loc(3),pep_side_norm(3),side_calf_norm(3)
11028 C the line belowe needs to be changed for FGPROC>1
11029       do i=1,nres-1
11030       if ((itype(i).eq.ntyp1).and.itype(i+1).eq.ntyp1) cycle
11031       ishield_list(i)=0
11032 Cif there two consequtive dummy atoms there is no peptide group between them
11033 C the line below has to be changed for FGPROC>1
11034       VolumeTotal=0.0
11035       do k=1,nres
11036        if ((itype(k).eq.ntyp1).or.(itype(k).eq.10)) cycle
11037        dist_pep_side=0.0
11038        dist_side_calf=0.0
11039        do j=1,3
11040 C first lets set vector conecting the ithe side-chain with kth side-chain
11041       pep_side(j)=c(j,k+nres)-(c(j,i)+c(j,i+1))/2.0d0
11042 C      pep_side(j)=2.0d0
11043 C and vector conecting the side-chain with its proper calfa
11044       side_calf(j)=c(j,k+nres)-c(j,k)
11045 C      side_calf(j)=2.0d0
11046       pept_group(j)=c(j,i)-c(j,i+1)
11047 C lets have their lenght
11048       dist_pep_side=pep_side(j)**2+dist_pep_side
11049       dist_side_calf=dist_side_calf+side_calf(j)**2
11050       dist_pept_group=dist_pept_group+pept_group(j)**2
11051       enddo
11052        dist_pep_side=dsqrt(dist_pep_side)
11053        dist_pept_group=dsqrt(dist_pept_group)
11054        dist_side_calf=dsqrt(dist_side_calf)
11055       do j=1,3
11056         pep_side_norm(j)=pep_side(j)/dist_pep_side
11057         side_calf_norm(j)=dist_side_calf
11058       enddo
11059 C now sscale fraction
11060        sh_frac_dist=-(dist_pep_side-rpp(1,1)-buff_shield)/buff_shield
11061 C       print *,buff_shield,"buff"
11062 C now sscale
11063         if (sh_frac_dist.le.0.0) cycle
11064 C If we reach here it means that this side chain reaches the shielding sphere
11065 C Lets add him to the list for gradient
11066         ishield_list(i)=ishield_list(i)+1
11067 C ishield_list is a list of non 0 side-chain that contribute to factor gradient
11068 C this list is essential otherwise problem would be O3
11069         shield_list(ishield_list(i),i)=k
11070 C Lets have the sscale value
11071         if (sh_frac_dist.gt.1.0) then
11072          scale_fac_dist=1.0d0
11073          do j=1,3
11074          sh_frac_dist_grad(j)=0.0d0
11075          enddo
11076         else
11077          scale_fac_dist=-sh_frac_dist*sh_frac_dist
11078      &                   *(2.0*sh_frac_dist-3.0d0)
11079          fac_help_scale=6.0*(sh_frac_dist-sh_frac_dist**2)
11080      &                  /dist_pep_side/buff_shield*0.5
11081 C remember for the final gradient multiply sh_frac_dist_grad(j)
11082 C for side_chain by factor -2 !
11083          do j=1,3
11084          sh_frac_dist_grad(j)=fac_help_scale*pep_side(j)
11085 C         print *,"jestem",scale_fac_dist,fac_help_scale,
11086 C     &                    sh_frac_dist_grad(j)
11087          enddo
11088         endif
11089 C        if ((i.eq.3).and.(k.eq.2)) then
11090 C        print *,i,sh_frac_dist,dist_pep,fac_help_scale,scale_fac_dist
11091 C     & ,"TU"
11092 C        endif
11093
11094 C this is what is now we have the distance scaling now volume...
11095       short=short_r_sidechain(itype(k))
11096       long=long_r_sidechain(itype(k))
11097       costhet=1.0d0/dsqrt(1.0+short**2/dist_pep_side**2)
11098 C now costhet_grad
11099 C       costhet=0.0d0
11100        costhet_fac=costhet**3*short**2*(-0.5)/dist_pep_side**4
11101 C       costhet_fac=0.0d0
11102        do j=1,3
11103          costhet_grad(j)=costhet_fac*pep_side(j)
11104        enddo
11105 C remember for the final gradient multiply costhet_grad(j)
11106 C for side_chain by factor -2 !
11107 C fac alfa is angle between CB_k,CA_k, CA_i,CA_i+1
11108 C pep_side0pept_group is vector multiplication
11109       pep_side0pept_group=0.0
11110       do j=1,3
11111       pep_side0pept_group=pep_side0pept_group+pep_side(j)*side_calf(j)
11112       enddo
11113       cosalfa=(pep_side0pept_group/
11114      & (dist_pep_side*dist_side_calf))
11115       fac_alfa_sin=1.0-cosalfa**2
11116       fac_alfa_sin=dsqrt(fac_alfa_sin)
11117       rkprim=fac_alfa_sin*(long-short)+short
11118 C now costhet_grad
11119        cosphi=1.0d0/dsqrt(1.0+rkprim**2/dist_pep_side**2)
11120        cosphi_fac=cosphi**3*rkprim**2*(-0.5)/dist_pep_side**4
11121
11122        do j=1,3
11123          cosphi_grad_long(j)=cosphi_fac*pep_side(j)
11124      &+cosphi**3*0.5/dist_pep_side**2*(-rkprim)
11125      &*(long-short)/fac_alfa_sin*cosalfa/
11126      &((dist_pep_side*dist_side_calf))*
11127      &((side_calf(j))-cosalfa*
11128      &((pep_side(j)/dist_pep_side)*dist_side_calf))
11129
11130         cosphi_grad_loc(j)=cosphi**3*0.5/dist_pep_side**2*(-rkprim)
11131      &*(long-short)/fac_alfa_sin*cosalfa
11132      &/((dist_pep_side*dist_side_calf))*
11133      &(pep_side(j)-
11134      &cosalfa*side_calf(j)/dist_side_calf*dist_pep_side)
11135        enddo
11136
11137       VofOverlap=VSolvSphere/2.0d0*(1.0-costhet)*(1.0-cosphi)
11138      &                    /VSolvSphere_div
11139 C now the gradient...
11140 C grad_shield is gradient of Calfa for peptide groups
11141 C      write(iout,*) "shield_compon",i,k,VSolvSphere,scale_fac_dist,
11142 C     &               costhet,cosphi
11143 C       write(iout,*) "cosphi_compon",i,k,pep_side0pept_group,
11144 C     & dist_pep_side,dist_side_calf,c(1,k+nres),c(1,k),itype(k)
11145       do j=1,3
11146       grad_shield(j,i)=grad_shield(j,i)
11147 C gradient po skalowaniu
11148      &                +(sh_frac_dist_grad(j)
11149 C  gradient po costhet
11150      &-scale_fac_dist*costhet_grad(j)/(1.0-costhet)
11151      &-scale_fac_dist*(cosphi_grad_long(j))
11152      &/(1.0-cosphi) )*div77_81
11153      &*VofOverlap
11154 C grad_shield_side is Cbeta sidechain gradient
11155       grad_shield_side(j,ishield_list(i),i)=
11156      &        (sh_frac_dist_grad(j)*-2.0d0
11157      &       +scale_fac_dist*costhet_grad(j)*2.0d0/(1.0-costhet)
11158      &       +scale_fac_dist*(cosphi_grad_long(j))
11159      &        *2.0d0/(1.0-cosphi))
11160      &        *div77_81*VofOverlap
11161
11162        grad_shield_loc(j,ishield_list(i),i)=
11163      &   scale_fac_dist*cosphi_grad_loc(j)
11164      &        *2.0d0/(1.0-cosphi)
11165      &        *div77_81*VofOverlap
11166       enddo
11167       VolumeTotal=VolumeTotal+VofOverlap*scale_fac_dist
11168       enddo
11169       fac_shield(i)=VolumeTotal*div77_81+div4_81
11170 C      write(2,*) "TOTAL VOLUME",i,VolumeTotal,fac_shield(i)
11171       enddo
11172       return
11173       end
11174