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        if ((tor_mode.eq.0).or.(tor_mode.eq.2)) then
 205         call ebend(ebe,ethetacnstr)
 206         endif
 207 C ebend kcc is Kubo cumulant clustered rigorous attemp to derive the
 208 C energy function
 209        if ((tor_mode.eq.1).or.(tor_mode.eq.2)) then
 210          call ebend_kcc(ebe,ethetacnstr)
 211         endif
 212       else
 213         ebe=0
 214         ethetacnstr=0
 215       endif
 216 c      print *,"Processor",myrank," computed UB"
 217 C
 218 C Calculate the SC local energy.
 219 C
 220 C      print *,"TU DOCHODZE?"
 221       call esc(escloc)
 222 c      print *,"Processor",myrank," computed USC"
 223 C
 224 C Calculate the virtual-bond torsional energy.
 225 C
 226 cd    print *,'nterm=',nterm
 227       if (wtor.gt.0) then
 228        if ((tor_mode.eq.0).or.(tor_mode.eq.2)) then
 229        call etor(etors,edihcnstr)
 230        endif
 231 C etor kcc is Kubo cumulant clustered rigorous attemp to derive the
 232 C energy function
 233        if ((tor_mode.eq.1).or.(tor_mode.eq.2)) then
 234        call etor(etors,edihcnstr)
 235        endif
 236       else
 237        etors=0
 238        edihcnstr=0
 239       endif
 240 c      print *,"Processor",myrank," computed Utor"
 241 C
 242 C 6/23/01 Calculate double-torsional energy
 243 C
 244       if ((wtor_d.gt.0).and.((tor_mode.eq.0).or.(tor_mode.eq.2))) then
 245        call etor_d(etors_d)
 246       else
 247        etors_d=0
 248       endif
 249 c      print *,"Processor",myrank," computed Utord"
 250 C
 251 C 21/5/07 Calculate local sicdechain correlation energy
 252 C
 253       if (wsccor.gt.0.0d0) then
 254         call eback_sc_corr(esccor)
 255       else
 256         esccor=0.0d0
 257       endif
 258 C      print *,"PRZED MULIt"
 259 c      print *,"Processor",myrank," computed Usccorr"
 260 C
 261 C 12/1/95 Multi-body terms
 262 C
 263       n_corr=0
 264       n_corr1=0
 265       if ((wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0
 266      &    .or. wturn6.gt.0.0d0) .and. ipot.lt.6) then
 267          call multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1)
 268 cd         write(2,*)'multibody_eello n_corr=',n_corr,' n_corr1=',n_corr1,
 269 cd     &" ecorr",ecorr," ecorr5",ecorr5," ecorr6",ecorr6," eturn6",eturn6
 270       else
 271          ecorr=0.0d0
 272          ecorr5=0.0d0
 273          ecorr6=0.0d0
 274          eturn6=0.0d0
 275       endif
 276       if ((wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) .and. ipot.lt.6) then
 277          call multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
 278 cd         write (iout,*) "multibody_hb ecorr",ecorr
 279       endif
 280 c      print *,"Processor",myrank," computed Ucorr"
 281 C
 282 C If performing constraint dynamics, call the constraint energy
 283 C  after the equilibration time
 284       if(usampl.and.totT.gt.eq_time) then
 285          call EconstrQ
 286          call Econstr_back
 287       else
 288          Uconst=0.0d0
 289          Uconst_back=0.0d0
 290       endif
 291 C 01/27/2015 added by adasko
 292 C the energy component below is energy transfer into lipid environment
 293 C based on partition function
 294 C      print *,"przed lipidami"
 295       if (wliptran.gt.0) then
 296         call Eliptransfer(eliptran)
 297       endif
 298 C      print *,"za lipidami"
 299       if (AFMlog.gt.0) then
 300         call AFMforce(Eafmforce)
 301       else if (selfguide.gt.0) then
 302         call AFMvel(Eafmforce)
 303       endif
 304 #ifdef TIMING
 305       time_enecalc=time_enecalc+MPI_Wtime()-time00
 306 #endif
 307 c      print *,"Processor",myrank," computed Uconstr"
 308 #ifdef TIMING
 309       time00=MPI_Wtime()
 310 #endif
 311 c
 312 C Sum the energies
 313 C
 314       energia(1)=evdw
 315 #ifdef SCP14
 316       energia(2)=evdw2-evdw2_14
 317       energia(18)=evdw2_14
 318 #else
 319       energia(2)=evdw2
 320       energia(18)=0.0d0
 321 #endif
 322 #ifdef SPLITELE
 323       energia(3)=ees
 324       energia(16)=evdw1
 325 #else
 326       energia(3)=ees+evdw1
 327       energia(16)=0.0d0
 328 #endif
 329       energia(4)=ecorr
 330       energia(5)=ecorr5
 331       energia(6)=ecorr6
 332       energia(7)=eel_loc
 333       energia(8)=eello_turn3
 334       energia(9)=eello_turn4
 335       energia(10)=eturn6
 336       energia(11)=ebe
 337       energia(12)=escloc
 338       energia(13)=etors
 339       energia(14)=etors_d
 340       energia(15)=ehpb
 341       energia(19)=edihcnstr
 342       energia(17)=estr
 343       energia(20)=Uconst+Uconst_back
 344       energia(21)=esccor
 345       energia(22)=eliptran
 346       energia(23)=Eafmforce
 347       energia(24)=ethetacnstr
 348 c    Here are the energies showed per procesor if the are more processors
 349 c    per molecule then we sum it up in sum_energy subroutine
 350 c      print *," Processor",myrank," calls SUM_ENERGY"
 351       call sum_energy(energia,.true.)
 352       if (dyn_ss) call dyn_set_nss
 353 c      print *," Processor",myrank," left SUM_ENERGY"
 354 #ifdef TIMING
 355       time_sumene=time_sumene+MPI_Wtime()-time00
 356 #endif
 357       return
 358       end
 359 c-------------------------------------------------------------------------------
 360       subroutine sum_energy(energia,reduce)
 361       implicit real*8 (a-h,o-z)
 362       include 'DIMENSIONS'
 363 #ifndef ISNAN
 364       external proc_proc
 365 #ifdef WINPGI
 366 cMS$ATTRIBUTES C ::  proc_proc
 367 #endif
 368 #endif
 369 #ifdef MPI
 370       include "mpif.h"
 371 #endif
 372       include 'COMMON.SETUP'
 373       include 'COMMON.IOUNITS'
 374       double precision energia(0:n_ene),enebuff(0:n_ene+1)
 375       include 'COMMON.FFIELD'
 376       include 'COMMON.DERIV'
 377       include 'COMMON.INTERACT'
 378       include 'COMMON.SBRIDGE'
 379       include 'COMMON.CHAIN'
 380       include 'COMMON.VAR'
 381       include 'COMMON.CONTROL'
 382       include 'COMMON.TIME1'
 383       logical reduce
 384 #ifdef MPI
 385       if (nfgtasks.gt.1 .and. reduce) then
 386 #ifdef DEBUG
 387         write (iout,*) "energies before REDUCE"
 388         call enerprint(energia)
 389         call flush(iout)
 390 #endif
 391         do i=0,n_ene
 392           enebuff(i)=energia(i)
 393         enddo
 394         time00=MPI_Wtime()
 395         call MPI_Barrier(FG_COMM,IERR)
 396         time_barrier_e=time_barrier_e+MPI_Wtime()-time00
 397         time00=MPI_Wtime()
 398         call MPI_Reduce(enebuff(0),energia(0),n_ene+1,
 399      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 400 #ifdef DEBUG
 401         write (iout,*) "energies after REDUCE"
 402         call enerprint(energia)
 403         call flush(iout)
 404 #endif
 405         time_Reduce=time_Reduce+MPI_Wtime()-time00
 406       endif
 407       if (fg_rank.eq.0) then
 408 #endif
 409       evdw=energia(1)
 410 #ifdef SCP14
 411       evdw2=energia(2)+energia(18)
 412       evdw2_14=energia(18)
 413 #else
 414       evdw2=energia(2)
 415 #endif
 416 #ifdef SPLITELE
 417       ees=energia(3)
 418       evdw1=energia(16)
 419 #else
 420       ees=energia(3)
 421       evdw1=0.0d0
 422 #endif
 423       ecorr=energia(4)
 424       ecorr5=energia(5)
 425       ecorr6=energia(6)
 426       eel_loc=energia(7)
 427       eello_turn3=energia(8)
 428       eello_turn4=energia(9)
 429       eturn6=energia(10)
 430       ebe=energia(11)
 431       escloc=energia(12)
 432       etors=energia(13)
 433       etors_d=energia(14)
 434       ehpb=energia(15)
 435       edihcnstr=energia(19)
 436       estr=energia(17)
 437       Uconst=energia(20)
 438       esccor=energia(21)
 439       eliptran=energia(22)
 440       Eafmforce=energia(23)
 441       ethetacnstr=energia(24)
 442 #ifdef SPLITELE
 443       etot=wsc*evdw+wscp*evdw2+welec*ees+wvdwpp*evdw1
 444      & +wang*ebe+wtor*etors+wscloc*escloc
 445      & +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5
 446      & +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3
 447      & +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d
 448      & +wbond*estr+Uconst+wsccor*esccor+wliptran*eliptran+Eafmforce
 449      & +ethetacnstr
 450 #else
 451       etot=wsc*evdw+wscp*evdw2+welec*(ees+evdw1)
 452      & +wang*ebe+wtor*etors+wscloc*escloc
 453      & +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5
 454      & +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3
 455      & +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d
 456      & +wbond*estr+Uconst+wsccor*esccor+wliptran*eliptran
 457      & +Eafmforce
 458      & +ethetacnstr
 459 #endif
 460       energia(0)=etot
 461 c detecting NaNQ
 462 #ifdef ISNAN
 463 #ifdef AIX
 464       if (isnan(etot).ne.0) energia(0)=1.0d+99
 465 #else
 466       if (isnan(etot)) energia(0)=1.0d+99
 467 #endif
 468 #else
 469       i=0
 470 #ifdef WINPGI
 471       idumm=proc_proc(etot,i)
 472 #else
 473       call proc_proc(etot,i)
 474 #endif
 475       if(i.eq.1)energia(0)=1.0d+99
 476 #endif
 477 #ifdef MPI
 478       endif
 479 #endif
 480       return
 481       end
 482 c-------------------------------------------------------------------------------
 483       subroutine sum_gradient
 484       implicit real*8 (a-h,o-z)
 485       include 'DIMENSIONS'
 486 #ifndef ISNAN
 487       external proc_proc
 488 #ifdef WINPGI
 489 cMS$ATTRIBUTES C ::  proc_proc
 490 #endif
 491 #endif
 492 #ifdef MPI
 493       include 'mpif.h'
 494 #endif
 495       double precision gradbufc(3,-1:maxres),gradbufx(3,-1:maxres),
 496      & glocbuf(4*maxres),gradbufc_sum(3,-1:maxres)
 497      & ,gloc_scbuf(3,-1:maxres)
 498       include 'COMMON.SETUP'
 499       include 'COMMON.IOUNITS'
 500       include 'COMMON.FFIELD'
 501       include 'COMMON.DERIV'
 502       include 'COMMON.INTERACT'
 503       include 'COMMON.SBRIDGE'
 504       include 'COMMON.CHAIN'
 505       include 'COMMON.VAR'
 506       include 'COMMON.CONTROL'
 507       include 'COMMON.TIME1'
 508       include 'COMMON.MAXGRAD'
 509       include 'COMMON.SCCOR'
 510 #ifdef TIMING
 511       time01=MPI_Wtime()
 512 #endif
 513 #ifdef DEBUG
 514       write (iout,*) "sum_gradient gvdwc, gvdwx"
 515       do i=1,nres
 516         write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)')
 517      &   i,(gvdwx(j,i),j=1,3),(gvdwc(j,i),j=1,3)
 518       enddo
 519       call flush(iout)
 520 #endif
 521 #ifdef MPI
 522 C FG slaves call the following matching MPI_Bcast in ERGASTULUM
 523         if (nfgtasks.gt.1 .and. fg_rank.eq.0)
 524      &    call MPI_Bcast(1,1,MPI_INTEGER,king,FG_COMM,IERROR)
 525 #endif
 526 C
 527 C 9/29/08 AL Transform parts of gradients in site coordinates to the gradient
 528 C            in virtual-bond-vector coordinates
 529 C
 530 #ifdef DEBUG
 531 c      write (iout,*) "gel_loc gel_loc_long and gel_loc_loc"
 532 c      do i=1,nres-1
 533 c        write (iout,'(i5,3f10.5,2x,3f10.5,2x,f10.5)')
 534 c     &   i,(gel_loc(j,i),j=1,3),(gel_loc_long(j,i),j=1,3),gel_loc_loc(i)
 535 c      enddo
 536 c      write (iout,*) "gel_loc_tur3 gel_loc_turn4"
 537 c      do i=1,nres-1
 538 c        write (iout,'(i5,3f10.5,2x,f10.5)')
 539 c     &  i,(gcorr4_turn(j,i),j=1,3),gel_loc_turn4(i)
 540 c      enddo
 541       write (iout,*) "gradcorr5 gradcorr5_long gradcorr5_loc"
 542       do i=1,nres
 543         write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)')
 544      &   i,(gradcorr5(j,i),j=1,3),(gradcorr5_long(j,i),j=1,3),
 545      &   g_corr5_loc(i)
 546       enddo
 547       call flush(iout)
 548 #endif
 549 #ifdef SPLITELE
 550       do i=0,nct
 551         do j=1,3
 552           gradbufc(j,i)=wsc*gvdwc(j,i)+
 553      &                wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+
 554      &                welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+
 555      &                wel_loc*gel_loc_long(j,i)+
 556      &                wcorr*gradcorr_long(j,i)+
 557      &                wcorr5*gradcorr5_long(j,i)+
 558      &                wcorr6*gradcorr6_long(j,i)+
 559      &                wturn6*gcorr6_turn_long(j,i)+
 560      &                wstrain*ghpbc(j,i)
 561      &                +wliptran*gliptranc(j,i)
 562      &                +gradafm(j,i)
 563      &                 +welec*gshieldc(j,i)
 564      &                 +wcorr*gshieldc_ec(j,i)
 565      &                 +wturn3*gshieldc_t3(j,i)
 566      &                 +wturn4*gshieldc_t4(j,i)
 567      &                 +wel_loc*gshieldc_ll(j,i)
 568
 569
 570         enddo
 571       enddo
 572 #else
 573       do i=0,nct
 574         do j=1,3
 575           gradbufc(j,i)=wsc*gvdwc(j,i)+
 576      &                wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+
 577      &                welec*gelc_long(j,i)+
 578      &                wbond*gradb(j,i)+
 579      &                wel_loc*gel_loc_long(j,i)+
 580      &                wcorr*gradcorr_long(j,i)+
 581      &                wcorr5*gradcorr5_long(j,i)+
 582      &                wcorr6*gradcorr6_long(j,i)+
 583      &                wturn6*gcorr6_turn_long(j,i)+
 584      &                wstrain*ghpbc(j,i)
 585      &                +wliptran*gliptranc(j,i)
 586      &                +gradafm(j,i)
 587      &                 +welec*gshieldc(j,i)
 588      &                 +wcorr*gshieldc_ec(j,i)
 589      &                 +wturn4*gshieldc_t4(j,i)
 590      &                 +wel_loc*gshieldc_ll(j,i)
 591
 592
 593         enddo
 594       enddo
 595 #endif
 596 #ifdef MPI
 597       if (nfgtasks.gt.1) then
 598       time00=MPI_Wtime()
 599 #ifdef DEBUG
 600       write (iout,*) "gradbufc before allreduce"
 601       do i=1,nres
 602         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 603       enddo
 604       call flush(iout)
 605 #endif
 606       do i=0,nres
 607         do j=1,3
 608           gradbufc_sum(j,i)=gradbufc(j,i)
 609         enddo
 610       enddo
 611 c      call MPI_AllReduce(gradbufc(1,1),gradbufc_sum(1,1),3*nres,
 612 c     &    MPI_DOUBLE_PRECISION,MPI_SUM,FG_COMM,IERR)
 613 c      time_reduce=time_reduce+MPI_Wtime()-time00
 614 #ifdef DEBUG
 615 c      write (iout,*) "gradbufc_sum after allreduce"
 616 c      do i=1,nres
 617 c        write (iout,'(i3,3f10.5)') i,(gradbufc_sum(j,i),j=1,3)
 618 c      enddo
 619 c      call flush(iout)
 620 #endif
 621 #ifdef TIMING
 622 c      time_allreduce=time_allreduce+MPI_Wtime()-time00
 623 #endif
 624       do i=nnt,nres
 625         do k=1,3
 626           gradbufc(k,i)=0.0d0
 627         enddo
 628       enddo
 629 #ifdef DEBUG
 630       write (iout,*) "igrad_start",igrad_start," igrad_end",igrad_end
 631       write (iout,*) (i," jgrad_start",jgrad_start(i),
 632      &                  " jgrad_end  ",jgrad_end(i),
 633      &                  i=igrad_start,igrad_end)
 634 #endif
 635 c
 636 c Obsolete and inefficient code; we can make the effort O(n) and, therefore,
 637 c do not parallelize this part.
 638 c
 639 c      do i=igrad_start,igrad_end
 640 c        do j=jgrad_start(i),jgrad_end(i)
 641 c          do k=1,3
 642 c            gradbufc(k,i)=gradbufc(k,i)+gradbufc_sum(k,j)
 643 c          enddo
 644 c        enddo
 645 c      enddo
 646       do j=1,3
 647         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
 648       enddo
 649       do i=nres-2,-1,-1
 650         do j=1,3
 651           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
 652         enddo
 653       enddo
 654 #ifdef DEBUG
 655       write (iout,*) "gradbufc after summing"
 656       do i=1,nres
 657         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 658       enddo
 659       call flush(iout)
 660 #endif
 661       else
 662 #endif
 663 #ifdef DEBUG
 664       write (iout,*) "gradbufc"
 665       do i=1,nres
 666         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 667       enddo
 668       call flush(iout)
 669 #endif
 670       do i=-1,nres
 671         do j=1,3
 672           gradbufc_sum(j,i)=gradbufc(j,i)
 673           gradbufc(j,i)=0.0d0
 674         enddo
 675       enddo
 676       do j=1,3
 677         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
 678       enddo
 679       do i=nres-2,-1,-1
 680         do j=1,3
 681           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
 682         enddo
 683       enddo
 684 c      do i=nnt,nres-1
 685 c        do k=1,3
 686 c          gradbufc(k,i)=0.0d0
 687 c        enddo
 688 c        do j=i+1,nres
 689 c          do k=1,3
 690 c            gradbufc(k,i)=gradbufc(k,i)+gradbufc(k,j)
 691 c          enddo
 692 c        enddo
 693 c      enddo
 694 #ifdef DEBUG
 695       write (iout,*) "gradbufc after summing"
 696       do i=1,nres
 697         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 698       enddo
 699       call flush(iout)
 700 #endif
 701 #ifdef MPI
 702       endif
 703 #endif
 704       do k=1,3
 705         gradbufc(k,nres)=0.0d0
 706       enddo
 707       do i=-1,nct
 708         do j=1,3
 709 #ifdef SPLITELE
 710 C          print *,gradbufc(1,13)
 711 C          print *,welec*gelc(1,13)
 712 C          print *,wel_loc*gel_loc(1,13)
 713 C          print *,0.5d0*(wscp*gvdwc_scpp(1,13))
 714 C          print *,welec*gelc_long(1,13)+wvdwpp*gvdwpp(1,13)
 715 C          print *,wel_loc*gel_loc_long(1,13)
 716 C          print *,gradafm(1,13),"AFM"
 717           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+
 718      &                wel_loc*gel_loc(j,i)+
 719      &                0.5d0*(wscp*gvdwc_scpp(j,i)+
 720      &                welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+
 721      &                wel_loc*gel_loc_long(j,i)+
 722      &                wcorr*gradcorr_long(j,i)+
 723      &                wcorr5*gradcorr5_long(j,i)+
 724      &                wcorr6*gradcorr6_long(j,i)+
 725      &                wturn6*gcorr6_turn_long(j,i))+
 726      &                wbond*gradb(j,i)+
 727      &                wcorr*gradcorr(j,i)+
 728      &                wturn3*gcorr3_turn(j,i)+
 729      &                wturn4*gcorr4_turn(j,i)+
 730      &                wcorr5*gradcorr5(j,i)+
 731      &                wcorr6*gradcorr6(j,i)+
 732      &                wturn6*gcorr6_turn(j,i)+
 733      &                wsccor*gsccorc(j,i)
 734      &               +wscloc*gscloc(j,i)
 735      &               +wliptran*gliptranc(j,i)
 736      &                +gradafm(j,i)
 737      &                 +welec*gshieldc(j,i)
 738      &                 +welec*gshieldc_loc(j,i)
 739      &                 +wcorr*gshieldc_ec(j,i)
 740      &                 +wcorr*gshieldc_loc_ec(j,i)
 741      &                 +wturn3*gshieldc_t3(j,i)
 742      &                 +wturn3*gshieldc_loc_t3(j,i)
 743      &                 +wturn4*gshieldc_t4(j,i)
 744      &                 +wturn4*gshieldc_loc_t4(j,i)
 745      &                 +wel_loc*gshieldc_ll(j,i)
 746      &                 +wel_loc*gshieldc_loc_ll(j,i)
 747
 748
 749
 750
 751
 752
 753 #else
 754           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+
 755      &                wel_loc*gel_loc(j,i)+
 756      &                0.5d0*(wscp*gvdwc_scpp(j,i)+
 757      &                welec*gelc_long(j,i)+
 758      &                wel_loc*gel_loc_long(j,i)+
 759      &                wcorr*gcorr_long(j,i)+
 760      &                wcorr5*gradcorr5_long(j,i)+
 761      &                wcorr6*gradcorr6_long(j,i)+
 762      &                wturn6*gcorr6_turn_long(j,i))+
 763      &                wbond*gradb(j,i)+
 764      &                wcorr*gradcorr(j,i)+
 765      &                wturn3*gcorr3_turn(j,i)+
 766      &                wturn4*gcorr4_turn(j,i)+
 767      &                wcorr5*gradcorr5(j,i)+
 768      &                wcorr6*gradcorr6(j,i)+
 769      &                wturn6*gcorr6_turn(j,i)+
 770      &                wsccor*gsccorc(j,i)
 771      &               +wscloc*gscloc(j,i)
 772      &               +wliptran*gliptranc(j,i)
 773      &                +gradafm(j,i)
 774      &                 +welec*gshieldc(j,i)
 775      &                 +welec*gshieldc_loc(j,i)
 776      &                 +wcorr*gshieldc_ec(j,i)
 777      &                 +wcorr*gshieldc_loc_ec(j,i)
 778      &                 +wturn3*gshieldc_t3(j,i)
 779      &                 +wturn3*gshieldc_loc_t3(j,i)
 780      &                 +wturn4*gshieldc_t4(j,i)
 781      &                 +wturn4*gshieldc_loc_t4(j,i)
 782      &                 +wel_loc*gshieldc_ll(j,i)
 783      &                 +wel_loc*gshieldc_loc_ll(j,i)
 784
 785
 786
 787
 788
 789 #endif
 790           gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+
 791      &                  wbond*gradbx(j,i)+
 792      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
 793      &                  wsccor*gsccorx(j,i)
 794      &                 +wscloc*gsclocx(j,i)
 795      &                 +wliptran*gliptranx(j,i)
 796      &                 +welec*gshieldx(j,i)
 797      &                 +wcorr*gshieldx_ec(j,i)
 798      &                 +wturn3*gshieldx_t3(j,i)
 799      &                 +wturn4*gshieldx_t4(j,i)
 800      &                 +wel_loc*gshieldx_ll(j,i)
 801
 802
 803
 804         enddo
 805       enddo
 806 #ifdef DEBUG
 807       write (iout,*) "gloc before adding corr"
 808       do i=1,4*nres
 809         write (iout,*) i,gloc(i,icg)
 810       enddo
 811 #endif
 812       do i=1,nres-3
 813         gloc(i,icg)=gloc(i,icg)+wcorr*gcorr_loc(i)
 814      &   +wcorr5*g_corr5_loc(i)
 815      &   +wcorr6*g_corr6_loc(i)
 816      &   +wturn4*gel_loc_turn4(i)
 817      &   +wturn3*gel_loc_turn3(i)
 818      &   +wturn6*gel_loc_turn6(i)
 819      &   +wel_loc*gel_loc_loc(i)
 820       enddo
 821 #ifdef DEBUG
 822       write (iout,*) "gloc after adding corr"
 823       do i=1,4*nres
 824         write (iout,*) i,gloc(i,icg)
 825       enddo
 826 #endif
 827 #ifdef MPI
 828       if (nfgtasks.gt.1) then
 829         do j=1,3
 830           do i=1,nres
 831             gradbufc(j,i)=gradc(j,i,icg)
 832             gradbufx(j,i)=gradx(j,i,icg)
 833           enddo
 834         enddo
 835         do i=1,4*nres
 836           glocbuf(i)=gloc(i,icg)
 837         enddo
 838 c#define DEBUG
 839 #ifdef DEBUG
 840       write (iout,*) "gloc_sc before reduce"
 841       do i=1,nres
 842        do j=1,1
 843         write (iout,*) i,j,gloc_sc(j,i,icg)
 844        enddo
 845       enddo
 846 #endif
 847 c#undef DEBUG
 848         do i=1,nres
 849          do j=1,3
 850           gloc_scbuf(j,i)=gloc_sc(j,i,icg)
 851          enddo
 852         enddo
 853         time00=MPI_Wtime()
 854         call MPI_Barrier(FG_COMM,IERR)
 855         time_barrier_g=time_barrier_g+MPI_Wtime()-time00
 856         time00=MPI_Wtime()
 857         call MPI_Reduce(gradbufc(1,1),gradc(1,1,icg),3*nres,
 858      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 859         call MPI_Reduce(gradbufx(1,1),gradx(1,1,icg),3*nres,
 860      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 861         call MPI_Reduce(glocbuf(1),gloc(1,icg),4*nres,
 862      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 863         time_reduce=time_reduce+MPI_Wtime()-time00
 864         call MPI_Reduce(gloc_scbuf(1,1),gloc_sc(1,1,icg),3*nres,
 865      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 866         time_reduce=time_reduce+MPI_Wtime()-time00
 867 c#define DEBUG
 868 #ifdef DEBUG
 869       write (iout,*) "gloc_sc after reduce"
 870       do i=1,nres
 871        do j=1,1
 872         write (iout,*) i,j,gloc_sc(j,i,icg)
 873        enddo
 874       enddo
 875 #endif
 876 c#undef DEBUG
 877 #ifdef DEBUG
 878       write (iout,*) "gloc after reduce"
 879       do i=1,4*nres
 880         write (iout,*) i,gloc(i,icg)
 881       enddo
 882 #endif
 883       endif
 884 #endif
 885       if (gnorm_check) then
 886 c
 887 c Compute the maximum elements of the gradient
 888 c
 889       gvdwc_max=0.0d0
 890       gvdwc_scp_max=0.0d0
 891       gelc_max=0.0d0
 892       gvdwpp_max=0.0d0
 893       gradb_max=0.0d0
 894       ghpbc_max=0.0d0
 895       gradcorr_max=0.0d0
 896       gel_loc_max=0.0d0
 897       gcorr3_turn_max=0.0d0
 898       gcorr4_turn_max=0.0d0
 899       gradcorr5_max=0.0d0
 900       gradcorr6_max=0.0d0
 901       gcorr6_turn_max=0.0d0
 902       gsccorc_max=0.0d0
 903       gscloc_max=0.0d0
 904       gvdwx_max=0.0d0
 905       gradx_scp_max=0.0d0
 906       ghpbx_max=0.0d0
 907       gradxorr_max=0.0d0
 908       gsccorx_max=0.0d0
 909       gsclocx_max=0.0d0
 910       do i=1,nct
 911         gvdwc_norm=dsqrt(scalar(gvdwc(1,i),gvdwc(1,i)))
 912         if (gvdwc_norm.gt.gvdwc_max) gvdwc_max=gvdwc_norm
 913         gvdwc_scp_norm=dsqrt(scalar(gvdwc_scp(1,i),gvdwc_scp(1,i)))
 914         if (gvdwc_scp_norm.gt.gvdwc_scp_max)
 915      &   gvdwc_scp_max=gvdwc_scp_norm
 916         gelc_norm=dsqrt(scalar(gelc(1,i),gelc(1,i)))
 917         if (gelc_norm.gt.gelc_max) gelc_max=gelc_norm
 918         gvdwpp_norm=dsqrt(scalar(gvdwpp(1,i),gvdwpp(1,i)))
 919         if (gvdwpp_norm.gt.gvdwpp_max) gvdwpp_max=gvdwpp_norm
 920         gradb_norm=dsqrt(scalar(gradb(1,i),gradb(1,i)))
 921         if (gradb_norm.gt.gradb_max) gradb_max=gradb_norm
 922         ghpbc_norm=dsqrt(scalar(ghpbc(1,i),ghpbc(1,i)))
 923         if (ghpbc_norm.gt.ghpbc_max) ghpbc_max=ghpbc_norm
 924         gradcorr_norm=dsqrt(scalar(gradcorr(1,i),gradcorr(1,i)))
 925         if (gradcorr_norm.gt.gradcorr_max) gradcorr_max=gradcorr_norm
 926         gel_loc_norm=dsqrt(scalar(gel_loc(1,i),gel_loc(1,i)))
 927         if (gel_loc_norm.gt.gel_loc_max) gel_loc_max=gel_loc_norm
 928         gcorr3_turn_norm=dsqrt(scalar(gcorr3_turn(1,i),
 929      &    gcorr3_turn(1,i)))
 930         if (gcorr3_turn_norm.gt.gcorr3_turn_max)
 931      &    gcorr3_turn_max=gcorr3_turn_norm
 932         gcorr4_turn_norm=dsqrt(scalar(gcorr4_turn(1,i),
 933      &    gcorr4_turn(1,i)))
 934         if (gcorr4_turn_norm.gt.gcorr4_turn_max)
 935      &    gcorr4_turn_max=gcorr4_turn_norm
 936         gradcorr5_norm=dsqrt(scalar(gradcorr5(1,i),gradcorr5(1,i)))
 937         if (gradcorr5_norm.gt.gradcorr5_max)
 938      &    gradcorr5_max=gradcorr5_norm
 939         gradcorr6_norm=dsqrt(scalar(gradcorr6(1,i),gradcorr6(1,i)))
 940         if (gradcorr6_norm.gt.gradcorr6_max) gcorr6_max=gradcorr6_norm
 941         gcorr6_turn_norm=dsqrt(scalar(gcorr6_turn(1,i),
 942      &    gcorr6_turn(1,i)))
 943         if (gcorr6_turn_norm.gt.gcorr6_turn_max)
 944      &    gcorr6_turn_max=gcorr6_turn_norm
 945         gsccorr_norm=dsqrt(scalar(gsccorc(1,i),gsccorc(1,i)))
 946         if (gsccorr_norm.gt.gsccorr_max) gsccorr_max=gsccorr_norm
 947         gscloc_norm=dsqrt(scalar(gscloc(1,i),gscloc(1,i)))
 948         if (gscloc_norm.gt.gscloc_max) gscloc_max=gscloc_norm
 949         gvdwx_norm=dsqrt(scalar(gvdwx(1,i),gvdwx(1,i)))
 950         if (gvdwx_norm.gt.gvdwx_max) gvdwx_max=gvdwx_norm
 951         gradx_scp_norm=dsqrt(scalar(gradx_scp(1,i),gradx_scp(1,i)))
 952         if (gradx_scp_norm.gt.gradx_scp_max)
 953      &    gradx_scp_max=gradx_scp_norm
 954         ghpbx_norm=dsqrt(scalar(ghpbx(1,i),ghpbx(1,i)))
 955         if (ghpbx_norm.gt.ghpbx_max) ghpbx_max=ghpbx_norm
 956         gradxorr_norm=dsqrt(scalar(gradxorr(1,i),gradxorr(1,i)))
 957         if (gradxorr_norm.gt.gradxorr_max) gradxorr_max=gradxorr_norm
 958         gsccorrx_norm=dsqrt(scalar(gsccorx(1,i),gsccorx(1,i)))
 959         if (gsccorrx_norm.gt.gsccorrx_max) gsccorrx_max=gsccorrx_norm
 960         gsclocx_norm=dsqrt(scalar(gsclocx(1,i),gsclocx(1,i)))
 961         if (gsclocx_norm.gt.gsclocx_max) gsclocx_max=gsclocx_norm
 962       enddo
 963       if (gradout) then
 964 #ifdef AIX
 965         open(istat,file=statname,position="append")
 966 #else
 967         open(istat,file=statname,access="append")
 968 #endif
 969         write (istat,'(1h#,21f10.2)') gvdwc_max,gvdwc_scp_max,
 970      &     gelc_max,gvdwpp_max,gradb_max,ghpbc_max,
 971      &     gradcorr_max,gel_loc_max,gcorr3_turn_max,gcorr4_turn_max,
 972      &     gradcorr5_max,gradcorr6_max,gcorr6_turn_max,gsccorc_max,
 973      &     gscloc_max,gvdwx_max,gradx_scp_max,ghpbx_max,gradxorr_max,
 974      &     gsccorx_max,gsclocx_max
 975         close(istat)
 976         if (gvdwc_max.gt.1.0d4) then
 977           write (iout,*) "gvdwc gvdwx gradb gradbx"
 978           do i=nnt,nct
 979             write(iout,'(i5,4(3f10.2,5x))') i,(gvdwc(j,i),gvdwx(j,i),
 980      &        gradb(j,i),gradbx(j,i),j=1,3)
 981           enddo
 982           call pdbout(0.0d0,'cipiszcze',iout)
 983           call flush(iout)
 984         endif
 985       endif
 986       endif
 987 #ifdef DEBUG
 988       write (iout,*) "gradc gradx gloc"
 989       do i=1,nres
 990         write (iout,'(i5,3f10.5,5x,3f10.5,5x,f10.5)')
 991      &   i,(gradc(j,i,icg),j=1,3),(gradx(j,i,icg),j=1,3),gloc(i,icg)
 992       enddo
 993 #endif
 994 #ifdef TIMING
 995       time_sumgradient=time_sumgradient+MPI_Wtime()-time01
 996 #endif
 997       return
 998       end
 999 c-------------------------------------------------------------------------------
1000       subroutine rescale_weights(t_bath)
1001       implicit real*8 (a-h,o-z)
1002       include 'DIMENSIONS'
1003       include 'COMMON.IOUNITS'
1004       include 'COMMON.FFIELD'
1005       include 'COMMON.SBRIDGE'
1006       double precision kfac /2.4d0/
1007       double precision x,x2,x3,x4,x5,licznik /1.12692801104297249644/
1008 c      facT=temp0/t_bath
1009 c      facT=2*temp0/(t_bath+temp0)
1010       if (rescale_mode.eq.0) then
1011         facT=1.0d0
1012         facT2=1.0d0
1013         facT3=1.0d0
1014         facT4=1.0d0
1015         facT5=1.0d0
1016       else if (rescale_mode.eq.1) then
1017         facT=kfac/(kfac-1.0d0+t_bath/temp0)
1018         facT2=kfac**2/(kfac**2-1.0d0+(t_bath/temp0)**2)
1019         facT3=kfac**3/(kfac**3-1.0d0+(t_bath/temp0)**3)
1020         facT4=kfac**4/(kfac**4-1.0d0+(t_bath/temp0)**4)
1021         facT5=kfac**5/(kfac**5-1.0d0+(t_bath/temp0)**5)
1022       else if (rescale_mode.eq.2) then
1023         x=t_bath/temp0
1024         x2=x*x
1025         x3=x2*x
1026         x4=x3*x
1027         x5=x4*x
1028         facT=licznik/dlog(dexp(x)+dexp(-x))
1029         facT2=licznik/dlog(dexp(x2)+dexp(-x2))
1030         facT3=licznik/dlog(dexp(x3)+dexp(-x3))
1031         facT4=licznik/dlog(dexp(x4)+dexp(-x4))
1032         facT5=licznik/dlog(dexp(x5)+dexp(-x5))
1033       else
1034         write (iout,*) "Wrong RESCALE_MODE",rescale_mode
1035         write (*,*) "Wrong RESCALE_MODE",rescale_mode
1036 #ifdef MPI
1037        call MPI_Finalize(MPI_COMM_WORLD,IERROR)
1038 #endif
1039        stop 555
1040       endif
1041       welec=weights(3)*fact
1042       wcorr=weights(4)*fact3
1043       wcorr5=weights(5)*fact4
1044       wcorr6=weights(6)*fact5
1045       wel_loc=weights(7)*fact2
1046       wturn3=weights(8)*fact2
1047       wturn4=weights(9)*fact3
1048       wturn6=weights(10)*fact5
1049       wtor=weights(13)*fact
1050       wtor_d=weights(14)*fact2
1051       wsccor=weights(21)*fact
1052
1053       return
1054       end
1055 C------------------------------------------------------------------------
1056       subroutine enerprint(energia)
1057       implicit real*8 (a-h,o-z)
1058       include 'DIMENSIONS'
1059       include 'COMMON.IOUNITS'
1060       include 'COMMON.FFIELD'
1061       include 'COMMON.SBRIDGE'
1062       include 'COMMON.MD'
1063       double precision energia(0:n_ene)
1064       etot=energia(0)
1065       evdw=energia(1)
1066       evdw2=energia(2)
1067 #ifdef SCP14
1068       evdw2=energia(2)+energia(18)
1069 #else
1070       evdw2=energia(2)
1071 #endif
1072       ees=energia(3)
1073 #ifdef SPLITELE
1074       evdw1=energia(16)
1075 #endif
1076       ecorr=energia(4)
1077       ecorr5=energia(5)
1078       ecorr6=energia(6)
1079       eel_loc=energia(7)
1080       eello_turn3=energia(8)
1081       eello_turn4=energia(9)
1082       eello_turn6=energia(10)
1083       ebe=energia(11)
1084       escloc=energia(12)
1085       etors=energia(13)
1086       etors_d=energia(14)
1087       ehpb=energia(15)
1088       edihcnstr=energia(19)
1089       estr=energia(17)
1090       Uconst=energia(20)
1091       esccor=energia(21)
1092       eliptran=energia(22)
1093       Eafmforce=energia(23)
1094       ethetacnstr=energia(24)
1095 #ifdef SPLITELE
1096       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,evdw1,wvdwpp,
1097      &  estr,wbond,ebe,wang,
1098      &  escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,
1099      &  ecorr,wcorr,
1100      &  ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,
1101      &  eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccro,edihcnstr,
1102      &  ethetacnstr,ebr*nss,Uconst,eliptran,wliptran,Eafmforc,
1103      &  etot
1104    10 format (/'Virtual-chain energies:'//
1105      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
1106      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
1107      & 'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/
1108      & 'EVDWPP=',1pE16.6,' WEIGHT=',1pD16.6,' (p-p VDW)'/
1109      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
1110      & 'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
1111      & 'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
1112      & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
1113      & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
1114      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6,
1115      & ' (SS bridges & dist. cnstr.)'/
1116      & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1117      & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1118      & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1119      & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
1120      & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
1121      & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
1122      & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
1123      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
1124      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
1125      & 'ETHETC= ',1pE16.6,' (valence angle constraints)'/
1126      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
1127      & 'UCONST= ',1pE16.6,' (Constraint energy)'/
1128      & 'ELT=',1pE16.6, ' WEIGHT=',1pD16.6,' (Lipid transfer energy)'/
1129      & 'EAFM=  ',1pE16.6,' (atomic-force microscopy)'/
1130      & 'ETOT=  ',1pE16.6,' (total)')
1131
1132 #else
1133       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,
1134      &  estr,wbond,ebe,wang,
1135      &  escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,
1136      &  ecorr,wcorr,
1137      &  ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,
1138      &  eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccro,edihcnstr,
1139      &  ethetacnstr,ebr*nss,Uconst,eliptran,wliptran,Eafmforc,
1140      &  etot
1141    10 format (/'Virtual-chain energies:'//
1142      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
1143      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
1144      & 'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/
1145      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
1146      & 'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
1147      & 'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
1148      & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
1149      & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
1150      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6,
1151      & ' (SS bridges & dist. cnstr.)'/
1152      & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1153      & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1154      & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1155      & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
1156      & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
1157      & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
1158      & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
1159      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
1160      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
1161      & 'ETHETC= ',1pE16.6,' (valence angle constraints)'/
1162      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
1163      & 'UCONST=',1pE16.6,' (Constraint energy)'/
1164      & 'ELT=',1pE16.6, ' WEIGHT=',1pD16.6,' (Lipid transfer energy)'/
1165      & 'EAFM=  ',1pE16.6,' (atomic-force microscopy)'/
1166      & 'ETOT=  ',1pE16.6,' (total)')
1167 #endif
1168       return
1169       end
1170 C-----------------------------------------------------------------------
1171       subroutine elj(evdw)
1172 C
1173 C This subroutine calculates the interaction energy of nonbonded side chains
1174 C assuming the LJ potential of interaction.
1175 C
1176       implicit real*8 (a-h,o-z)
1177       include 'DIMENSIONS'
1178       parameter (accur=1.0d-10)
1179       include 'COMMON.GEO'
1180       include 'COMMON.VAR'
1181       include 'COMMON.LOCAL'
1182       include 'COMMON.CHAIN'
1183       include 'COMMON.DERIV'
1184       include 'COMMON.INTERACT'
1185       include 'COMMON.TORSION'
1186       include 'COMMON.SBRIDGE'
1187       include 'COMMON.NAMES'
1188       include 'COMMON.IOUNITS'
1189       include 'COMMON.CONTACTS'
1190       dimension gg(3)
1191 c      write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
1192       evdw=0.0D0
1193       do i=iatsc_s,iatsc_e
1194         itypi=iabs(itype(i))
1195         if (itypi.eq.ntyp1) cycle
1196         itypi1=iabs(itype(i+1))
1197         xi=c(1,nres+i)
1198         yi=c(2,nres+i)
1199         zi=c(3,nres+i)
1200 C Change 12/1/95
1201         num_conti=0
1202 C
1203 C Calculate SC interaction energy.
1204 C
1205         do iint=1,nint_gr(i)
1206 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
1207 cd   &                  'iend=',iend(i,iint)
1208           do j=istart(i,iint),iend(i,iint)
1209             itypj=iabs(itype(j))
1210             if (itypj.eq.ntyp1) cycle
1211             xj=c(1,nres+j)-xi
1212             yj=c(2,nres+j)-yi
1213             zj=c(3,nres+j)-zi
1214 C Change 12/1/95 to calculate four-body interactions
1215             rij=xj*xj+yj*yj+zj*zj
1216             rrij=1.0D0/rij
1217 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
1218             eps0ij=eps(itypi,itypj)
1219             fac=rrij**expon2
1220 C have you changed here?
1221             e1=fac*fac*aa
1222             e2=fac*bb
1223             evdwij=e1+e2
1224 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1225 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1226 cd          write (iout,'(2(a3,i3,2x),6(1pd12.4)/2(3(1pd12.4),5x)/)')
1227 cd   &        restyp(itypi),i,restyp(itypj),j,a(itypi,itypj),
1228 cd   &        bb(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,epsi,sigm,
1229 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1230             evdw=evdw+evdwij
1231 C
1232 C Calculate the components of the gradient in DC and X
1233 C
1234             fac=-rrij*(e1+evdwij)
1235             gg(1)=xj*fac
1236             gg(2)=yj*fac
1237             gg(3)=zj*fac
1238             do k=1,3
1239               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1240               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1241               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1242               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1243             enddo
1244 cgrad            do k=i,j-1
1245 cgrad              do l=1,3
1246 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1247 cgrad              enddo
1248 cgrad            enddo
1249 C
1250 C 12/1/95, revised on 5/20/97
1251 C
1252 C Calculate the contact function. The ith column of the array JCONT will
1253 C contain the numbers of atoms that make contacts with the atom I (of numbers
1254 C greater than I). The arrays FACONT and GACONT will contain the values of
1255 C the contact function and its derivative.
1256 C
1257 C Uncomment next line, if the correlation interactions include EVDW explicitly.
1258 c           if (j.gt.i+1 .and. evdwij.le.0.0D0) then
1259 C Uncomment next line, if the correlation interactions are contact function only
1260             if (j.gt.i+1.and. eps0ij.gt.0.0D0) then
1261               rij=dsqrt(rij)
1262               sigij=sigma(itypi,itypj)
1263               r0ij=rs0(itypi,itypj)
1264 C
1265 C Check whether the SC's are not too far to make a contact.
1266 C
1267               rcut=1.5d0*r0ij
1268               call gcont(rij,rcut,1.0d0,0.2d0*rcut,fcont,fprimcont)
1269 C Add a new contact, if the SC's are close enough, but not too close (r<sigma).
1270 C
1271               if (fcont.gt.0.0D0) then
1272 C If the SC-SC distance if close to sigma, apply spline.
1273 cAdam           call gcont(-rij,-1.03d0*sigij,2.0d0*sigij,1.0d0,
1274 cAdam &             fcont1,fprimcont1)
1275 cAdam           fcont1=1.0d0-fcont1
1276 cAdam           if (fcont1.gt.0.0d0) then
1277 cAdam             fprimcont=fprimcont*fcont1+fcont*fprimcont1
1278 cAdam             fcont=fcont*fcont1
1279 cAdam           endif
1280 C Uncomment following 4 lines to have the geometric average of the epsilon0's
1281 cga             eps0ij=1.0d0/dsqrt(eps0ij)
1282 cga             do k=1,3
1283 cga               gg(k)=gg(k)*eps0ij
1284 cga             enddo
1285 cga             eps0ij=-evdwij*eps0ij
1286 C Uncomment for AL's type of SC correlation interactions.
1287 cadam           eps0ij=-evdwij
1288                 num_conti=num_conti+1
1289                 jcont(num_conti,i)=j
1290                 facont(num_conti,i)=fcont*eps0ij
1291                 fprimcont=eps0ij*fprimcont/rij
1292                 fcont=expon*fcont
1293 cAdam           gacont(1,num_conti,i)=-fprimcont*xj+fcont*gg(1)
1294 cAdam           gacont(2,num_conti,i)=-fprimcont*yj+fcont*gg(2)
1295 cAdam           gacont(3,num_conti,i)=-fprimcont*zj+fcont*gg(3)
1296 C Uncomment following 3 lines for Skolnick's type of SC correlation.
1297                 gacont(1,num_conti,i)=-fprimcont*xj
1298                 gacont(2,num_conti,i)=-fprimcont*yj
1299                 gacont(3,num_conti,i)=-fprimcont*zj
1300 cd              write (iout,'(2i5,2f10.5)') i,j,rij,facont(num_conti,i)
1301 cd              write (iout,'(2i3,3f10.5)')
1302 cd   &           i,j,(gacont(kk,num_conti,i),kk=1,3)
1303               endif
1304             endif
1305           enddo      ! j
1306         enddo        ! iint
1307 C Change 12/1/95
1308         num_cont(i)=num_conti
1309       enddo          ! i
1310       do i=1,nct
1311         do j=1,3
1312           gvdwc(j,i)=expon*gvdwc(j,i)
1313           gvdwx(j,i)=expon*gvdwx(j,i)
1314         enddo
1315       enddo
1316 C******************************************************************************
1317 C
1318 C                              N O T E !!!
1319 C
1320 C To save time, the factor of EXPON has been extracted from ALL components
1321 C of GVDWC and GRADX. Remember to multiply them by this factor before further
1322 C use!
1323 C
1324 C******************************************************************************
1325       return
1326       end
1327 C-----------------------------------------------------------------------------
1328       subroutine eljk(evdw)
1329 C
1330 C This subroutine calculates the interaction energy of nonbonded side chains
1331 C assuming the LJK potential of interaction.
1332 C
1333       implicit real*8 (a-h,o-z)
1334       include 'DIMENSIONS'
1335       include 'COMMON.GEO'
1336       include 'COMMON.VAR'
1337       include 'COMMON.LOCAL'
1338       include 'COMMON.CHAIN'
1339       include 'COMMON.DERIV'
1340       include 'COMMON.INTERACT'
1341       include 'COMMON.IOUNITS'
1342       include 'COMMON.NAMES'
1343       dimension gg(3)
1344       logical scheck
1345 c     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
1346       evdw=0.0D0
1347       do i=iatsc_s,iatsc_e
1348         itypi=iabs(itype(i))
1349         if (itypi.eq.ntyp1) cycle
1350         itypi1=iabs(itype(i+1))
1351         xi=c(1,nres+i)
1352         yi=c(2,nres+i)
1353         zi=c(3,nres+i)
1354 C
1355 C Calculate SC interaction energy.
1356 C
1357         do iint=1,nint_gr(i)
1358           do j=istart(i,iint),iend(i,iint)
1359             itypj=iabs(itype(j))
1360             if (itypj.eq.ntyp1) cycle
1361             xj=c(1,nres+j)-xi
1362             yj=c(2,nres+j)-yi
1363             zj=c(3,nres+j)-zi
1364             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1365             fac_augm=rrij**expon
1366             e_augm=augm(itypi,itypj)*fac_augm
1367             r_inv_ij=dsqrt(rrij)
1368             rij=1.0D0/r_inv_ij
1369             r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
1370             fac=r_shift_inv**expon
1371 C have you changed here?
1372             e1=fac*fac*aa
1373             e2=fac*bb
1374             evdwij=e_augm+e1+e2
1375 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1376 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1377 cd          write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
1378 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
1379 cd   &        bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
1380 cd   &        sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
1381 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1382             evdw=evdw+evdwij
1383 C
1384 C Calculate the components of the gradient in DC and X
1385 C
1386             fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
1387             gg(1)=xj*fac
1388             gg(2)=yj*fac
1389             gg(3)=zj*fac
1390             do k=1,3
1391               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1392               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1393               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1394               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1395             enddo
1396 cgrad            do k=i,j-1
1397 cgrad              do l=1,3
1398 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1399 cgrad              enddo
1400 cgrad            enddo
1401           enddo      ! j
1402         enddo        ! iint
1403       enddo          ! i
1404       do i=1,nct
1405         do j=1,3
1406           gvdwc(j,i)=expon*gvdwc(j,i)
1407           gvdwx(j,i)=expon*gvdwx(j,i)
1408         enddo
1409       enddo
1410       return
1411       end
1412 C-----------------------------------------------------------------------------
1413       subroutine ebp(evdw)
1414 C
1415 C This subroutine calculates the interaction energy of nonbonded side chains
1416 C assuming the Berne-Pechukas potential of interaction.
1417 C
1418       implicit real*8 (a-h,o-z)
1419       include 'DIMENSIONS'
1420       include 'COMMON.GEO'
1421       include 'COMMON.VAR'
1422       include 'COMMON.LOCAL'
1423       include 'COMMON.CHAIN'
1424       include 'COMMON.DERIV'
1425       include 'COMMON.NAMES'
1426       include 'COMMON.INTERACT'
1427       include 'COMMON.IOUNITS'
1428       include 'COMMON.CALC'
1429       common /srutu/ icall
1430 c     double precision rrsave(maxdim)
1431       logical lprn
1432       evdw=0.0D0
1433 c     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
1434       evdw=0.0D0
1435 c     if (icall.eq.0) then
1436 c       lprn=.true.
1437 c     else
1438         lprn=.false.
1439 c     endif
1440       ind=0
1441       do i=iatsc_s,iatsc_e
1442         itypi=iabs(itype(i))
1443         if (itypi.eq.ntyp1) cycle
1444         itypi1=iabs(itype(i+1))
1445         xi=c(1,nres+i)
1446         yi=c(2,nres+i)
1447         zi=c(3,nres+i)
1448         dxi=dc_norm(1,nres+i)
1449         dyi=dc_norm(2,nres+i)
1450         dzi=dc_norm(3,nres+i)
1451 c        dsci_inv=dsc_inv(itypi)
1452         dsci_inv=vbld_inv(i+nres)
1453 C
1454 C Calculate SC interaction energy.
1455 C
1456         do iint=1,nint_gr(i)
1457           do j=istart(i,iint),iend(i,iint)
1458             ind=ind+1
1459             itypj=iabs(itype(j))
1460             if (itypj.eq.ntyp1) cycle
1461 c            dscj_inv=dsc_inv(itypj)
1462             dscj_inv=vbld_inv(j+nres)
1463             chi1=chi(itypi,itypj)
1464             chi2=chi(itypj,itypi)
1465             chi12=chi1*chi2
1466             chip1=chip(itypi)
1467             chip2=chip(itypj)
1468             chip12=chip1*chip2
1469             alf1=alp(itypi)
1470             alf2=alp(itypj)
1471             alf12=0.5D0*(alf1+alf2)
1472 C For diagnostics only!!!
1473 c           chi1=0.0D0
1474 c           chi2=0.0D0
1475 c           chi12=0.0D0
1476 c           chip1=0.0D0
1477 c           chip2=0.0D0
1478 c           chip12=0.0D0
1479 c           alf1=0.0D0
1480 c           alf2=0.0D0
1481 c           alf12=0.0D0
1482             xj=c(1,nres+j)-xi
1483             yj=c(2,nres+j)-yi
1484             zj=c(3,nres+j)-zi
1485             dxj=dc_norm(1,nres+j)
1486             dyj=dc_norm(2,nres+j)
1487             dzj=dc_norm(3,nres+j)
1488             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1489 cd          if (icall.eq.0) then
1490 cd            rrsave(ind)=rrij
1491 cd          else
1492 cd            rrij=rrsave(ind)
1493 cd          endif
1494             rij=dsqrt(rrij)
1495 C Calculate the angle-dependent terms of energy & contributions to derivatives.
1496             call sc_angular
1497 C Calculate whole angle-dependent part of epsilon and contributions
1498 C to its derivatives
1499 C have you changed here?
1500             fac=(rrij*sigsq)**expon2
1501             e1=fac*fac*aa
1502             e2=fac*bb
1503             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1504             eps2der=evdwij*eps3rt
1505             eps3der=evdwij*eps2rt
1506             evdwij=evdwij*eps2rt*eps3rt
1507             evdw=evdw+evdwij
1508             if (lprn) then
1509             sigm=dabs(aa/bb)**(1.0D0/6.0D0)
1510             epsi=bb**2/aa
1511 cd            write (iout,'(2(a3,i3,2x),15(0pf7.3))')
1512 cd     &        restyp(itypi),i,restyp(itypj),j,
1513 cd     &        epsi,sigm,chi1,chi2,chip1,chip2,
1514 cd     &        eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
1515 cd     &        om1,om2,om12,1.0D0/dsqrt(rrij),
1516 cd     &        evdwij
1517             endif
1518 C Calculate gradient components.
1519             e1=e1*eps1*eps2rt**2*eps3rt**2
1520             fac=-expon*(e1+evdwij)
1521             sigder=fac/sigsq
1522             fac=rrij*fac
1523 C Calculate radial part of the gradient
1524             gg(1)=xj*fac
1525             gg(2)=yj*fac
1526             gg(3)=zj*fac
1527 C Calculate the angular part of the gradient and sum add the contributions
1528 C to the appropriate components of the Cartesian gradient.
1529             call sc_grad
1530           enddo      ! j
1531         enddo        ! iint
1532       enddo          ! i
1533 c     stop
1534       return
1535       end
1536 C-----------------------------------------------------------------------------
1537       subroutine egb(evdw)
1538 C
1539 C This subroutine calculates the interaction energy of nonbonded side chains
1540 C assuming the Gay-Berne potential of interaction.
1541 C
1542       implicit real*8 (a-h,o-z)
1543       include 'DIMENSIONS'
1544       include 'COMMON.GEO'
1545       include 'COMMON.VAR'
1546       include 'COMMON.LOCAL'
1547       include 'COMMON.CHAIN'
1548       include 'COMMON.DERIV'
1549       include 'COMMON.NAMES'
1550       include 'COMMON.INTERACT'
1551       include 'COMMON.IOUNITS'
1552       include 'COMMON.CALC'
1553       include 'COMMON.CONTROL'
1554       include 'COMMON.SPLITELE'
1555       include 'COMMON.SBRIDGE'
1556       logical lprn
1557       integer xshift,yshift,zshift
1558
1559       evdw=0.0D0
1560 ccccc      energy_dec=.false.
1561 C      print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1562       evdw=0.0D0
1563       lprn=.false.
1564 c     if (icall.eq.0) lprn=.false.
1565       ind=0
1566 C the loop over all 27 posible neigbours (for xshift=0,yshift=0,zshift=0
1567 C we have the original box)
1568 C      do xshift=-1,1
1569 C      do yshift=-1,1
1570 C      do zshift=-1,1
1571       do i=iatsc_s,iatsc_e
1572         itypi=iabs(itype(i))
1573         if (itypi.eq.ntyp1) cycle
1574         itypi1=iabs(itype(i+1))
1575         xi=c(1,nres+i)
1576         yi=c(2,nres+i)
1577         zi=c(3,nres+i)
1578 C Return atom into box, boxxsize is size of box in x dimension
1579 c  134   continue
1580 c        if (xi.gt.((xshift+0.5d0)*boxxsize)) xi=xi-boxxsize
1581 c        if (xi.lt.((xshift-0.5d0)*boxxsize)) xi=xi+boxxsize
1582 C Condition for being inside the proper box
1583 c        if ((xi.gt.((xshift+0.5d0)*boxxsize)).or.
1584 c     &       (xi.lt.((xshift-0.5d0)*boxxsize))) then
1585 c        go to 134
1586 c        endif
1587 c  135   continue
1588 c        if (yi.gt.((yshift+0.5d0)*boxysize)) yi=yi-boxysize
1589 c        if (yi.lt.((yshift-0.5d0)*boxysize)) yi=yi+boxysize
1590 C Condition for being inside the proper box
1591 c        if ((yi.gt.((yshift+0.5d0)*boxysize)).or.
1592 c     &       (yi.lt.((yshift-0.5d0)*boxysize))) then
1593 c        go to 135
1594 c        endif
1595 c  136   continue
1596 c        if (zi.gt.((zshift+0.5d0)*boxzsize)) zi=zi-boxzsize
1597 c        if (zi.lt.((zshift-0.5d0)*boxzsize)) zi=zi+boxzsize
1598 C Condition for being inside the proper box
1599 c        if ((zi.gt.((zshift+0.5d0)*boxzsize)).or.
1600 c     &       (zi.lt.((zshift-0.5d0)*boxzsize))) then
1601 c        go to 136
1602 c        endif
1603           xi=mod(xi,boxxsize)
1604           if (xi.lt.0) xi=xi+boxxsize
1605           yi=mod(yi,boxysize)
1606           if (yi.lt.0) yi=yi+boxysize
1607           zi=mod(zi,boxzsize)
1608           if (zi.lt.0) zi=zi+boxzsize
1609 C define scaling factor for lipids
1610
1611 C        if (positi.le.0) positi=positi+boxzsize
1612 C        print *,i
1613 C first for peptide groups
1614 c for each residue check if it is in lipid or lipid water border area
1615        if ((zi.gt.bordlipbot)
1616      &.and.(zi.lt.bordliptop)) then
1617 C the energy transfer exist
1618         if (zi.lt.buflipbot) then
1619 C what fraction I am in
1620          fracinbuf=1.0d0-
1621      &        ((zi-bordlipbot)/lipbufthick)
1622 C lipbufthick is thickenes of lipid buffore
1623          sslipi=sscalelip(fracinbuf)
1624          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
1625         elseif (zi.gt.bufliptop) then
1626          fracinbuf=1.0d0-((bordliptop-zi)/lipbufthick)
1627          sslipi=sscalelip(fracinbuf)
1628          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
1629         else
1630          sslipi=1.0d0
1631          ssgradlipi=0.0
1632         endif
1633        else
1634          sslipi=0.0d0
1635          ssgradlipi=0.0
1636        endif
1637
1638 C          xi=xi+xshift*boxxsize
1639 C          yi=yi+yshift*boxysize
1640 C          zi=zi+zshift*boxzsize
1641
1642         dxi=dc_norm(1,nres+i)
1643         dyi=dc_norm(2,nres+i)
1644         dzi=dc_norm(3,nres+i)
1645 c        dsci_inv=dsc_inv(itypi)
1646         dsci_inv=vbld_inv(i+nres)
1647 c        write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)
1648 c        write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi
1649 C
1650 C Calculate SC interaction energy.
1651 C
1652         do iint=1,nint_gr(i)
1653           do j=istart(i,iint),iend(i,iint)
1654             IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN
1655
1656 c              write(iout,*) "PRZED ZWYKLE", evdwij
1657               call dyn_ssbond_ene(i,j,evdwij)
1658 c              write(iout,*) "PO ZWYKLE", evdwij
1659
1660               evdw=evdw+evdwij
1661               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)')
1662      &                        'evdw',i,j,evdwij,' ss'
1663 C triple bond artifac removal
1664              do k=j+1,iend(i,iint)
1665 C search over all next residues
1666               if (dyn_ss_mask(k)) then
1667 C check if they are cysteins
1668 C              write(iout,*) 'k=',k
1669
1670 c              write(iout,*) "PRZED TRI", evdwij
1671                evdwij_przed_tri=evdwij
1672               call triple_ssbond_ene(i,j,k,evdwij)
1673 c               if(evdwij_przed_tri.ne.evdwij) then
1674 c                 write (iout,*) "TRI:", evdwij, evdwij_przed_tri
1675 c               endif
1676
1677 c              write(iout,*) "PO TRI", evdwij
1678 C call the energy function that removes the artifical triple disulfide
1679 C bond the soubroutine is located in ssMD.F
1680               evdw=evdw+evdwij
1681               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)')
1682      &                        'evdw',i,j,evdwij,'tss'
1683               endif!dyn_ss_mask(k)
1684              enddo! k
1685             ELSE
1686             ind=ind+1
1687             itypj=iabs(itype(j))
1688             if (itypj.eq.ntyp1) cycle
1689 c            dscj_inv=dsc_inv(itypj)
1690             dscj_inv=vbld_inv(j+nres)
1691 c            write (iout,*) "j",j,dsc_inv(itypj),dscj_inv,
1692 c     &       1.0d0/vbld(j+nres)
1693 c            write (iout,*) "i",i," j", j," itype",itype(i),itype(j)
1694             sig0ij=sigma(itypi,itypj)
1695             chi1=chi(itypi,itypj)
1696             chi2=chi(itypj,itypi)
1697             chi12=chi1*chi2
1698             chip1=chip(itypi)
1699             chip2=chip(itypj)
1700             chip12=chip1*chip2
1701             alf1=alp(itypi)
1702             alf2=alp(itypj)
1703             alf12=0.5D0*(alf1+alf2)
1704 C For diagnostics only!!!
1705 c           chi1=0.0D0
1706 c           chi2=0.0D0
1707 c           chi12=0.0D0
1708 c           chip1=0.0D0
1709 c           chip2=0.0D0
1710 c           chip12=0.0D0
1711 c           alf1=0.0D0
1712 c           alf2=0.0D0
1713 c           alf12=0.0D0
1714             xj=c(1,nres+j)
1715             yj=c(2,nres+j)
1716             zj=c(3,nres+j)
1717 C Return atom J into box the original box
1718 c  137   continue
1719 c        if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
1720 c        if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
1721 C Condition for being inside the proper box
1722 c        if ((xj.gt.((0.5d0)*boxxsize)).or.
1723 c     &       (xj.lt.((-0.5d0)*boxxsize))) then
1724 c        go to 137
1725 c        endif
1726 c  138   continue
1727 c        if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
1728 c        if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
1729 C Condition for being inside the proper box
1730 c        if ((yj.gt.((0.5d0)*boxysize)).or.
1731 c     &       (yj.lt.((-0.5d0)*boxysize))) then
1732 c        go to 138
1733 c        endif
1734 c  139   continue
1735 c        if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
1736 c        if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
1737 C Condition for being inside the proper box
1738 c        if ((zj.gt.((0.5d0)*boxzsize)).or.
1739 c     &       (zj.lt.((-0.5d0)*boxzsize))) then
1740 c        go to 139
1741 c        endif
1742           xj=mod(xj,boxxsize)
1743           if (xj.lt.0) xj=xj+boxxsize
1744           yj=mod(yj,boxysize)
1745           if (yj.lt.0) yj=yj+boxysize
1746           zj=mod(zj,boxzsize)
1747           if (zj.lt.0) zj=zj+boxzsize
1748        if ((zj.gt.bordlipbot)
1749      &.and.(zj.lt.bordliptop)) then
1750 C the energy transfer exist
1751         if (zj.lt.buflipbot) then
1752 C what fraction I am in
1753          fracinbuf=1.0d0-
1754      &        ((zj-bordlipbot)/lipbufthick)
1755 C lipbufthick is thickenes of lipid buffore
1756          sslipj=sscalelip(fracinbuf)
1757          ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
1758         elseif (zj.gt.bufliptop) then
1759          fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
1760          sslipj=sscalelip(fracinbuf)
1761          ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
1762         else
1763          sslipj=1.0d0
1764          ssgradlipj=0.0
1765         endif
1766        else
1767          sslipj=0.0d0
1768          ssgradlipj=0.0
1769        endif
1770       aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
1771      &  +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1772       bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
1773      &  +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1774 C      if (aa.ne.aa_aq(itypi,itypj)) write(63,'(2e10.5)')
1775 C     &(aa-aa_aq(itypi,itypj)),(bb-bb_aq(itypi,itypj))
1776 C      if (ssgradlipj.gt.0.0d0) print *,"??WTF??"
1777 C      print *,sslipi,sslipj,bordlipbot,zi,zj
1778       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
1779       xj_safe=xj
1780       yj_safe=yj
1781       zj_safe=zj
1782       subchap=0
1783       do xshift=-1,1
1784       do yshift=-1,1
1785       do zshift=-1,1
1786           xj=xj_safe+xshift*boxxsize
1787           yj=yj_safe+yshift*boxysize
1788           zj=zj_safe+zshift*boxzsize
1789           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
1790           if(dist_temp.lt.dist_init) then
1791             dist_init=dist_temp
1792             xj_temp=xj
1793             yj_temp=yj
1794             zj_temp=zj
1795             subchap=1
1796           endif
1797        enddo
1798        enddo
1799        enddo
1800        if (subchap.eq.1) then
1801           xj=xj_temp-xi
1802           yj=yj_temp-yi
1803           zj=zj_temp-zi
1804        else
1805           xj=xj_safe-xi
1806           yj=yj_safe-yi
1807           zj=zj_safe-zi
1808        endif
1809             dxj=dc_norm(1,nres+j)
1810             dyj=dc_norm(2,nres+j)
1811             dzj=dc_norm(3,nres+j)
1812 C            xj=xj-xi
1813 C            yj=yj-yi
1814 C            zj=zj-zi
1815 c            write (iout,*) "dcnorj",dxi*dxi+dyi*dyi+dzi*dzi
1816 c            write (iout,*) "j",j," dc_norm",
1817 c     &       dc_norm(1,nres+j),dc_norm(2,nres+j),dc_norm(3,nres+j)
1818             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1819             rij=dsqrt(rrij)
1820             sss=sscale((1.0d0/rij)/sigma(itypi,itypj))
1821             sssgrad=sscagrad((1.0d0/rij)/sigma(itypi,itypj))
1822
1823 c            write (iout,'(a7,4f8.3)')
1824 c    &      "ssscale",sss,((1.0d0/rij)/sigma(itypi,itypj)),r_cut,rlamb
1825             if (sss.gt.0.0d0) then
1826 C Calculate angle-dependent terms of energy and contributions to their
1827 C derivatives.
1828             call sc_angular
1829             sigsq=1.0D0/sigsq
1830             sig=sig0ij*dsqrt(sigsq)
1831             rij_shift=1.0D0/rij-sig+sig0ij
1832 c for diagnostics; uncomment
1833 c            rij_shift=1.2*sig0ij
1834 C I hate to put IF's in the loops, but here don't have another choice!!!!
1835             if (rij_shift.le.0.0D0) then
1836               evdw=1.0D20
1837 cd              write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1838 cd     &        restyp(itypi),i,restyp(itypj),j,
1839 cd     &        rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq)
1840               return
1841             endif
1842             sigder=-sig*sigsq
1843 c---------------------------------------------------------------
1844             rij_shift=1.0D0/rij_shift
1845             fac=rij_shift**expon
1846 C here to start with
1847 C            if (c(i,3).gt.
1848             faclip=fac
1849             e1=fac*fac*aa
1850             e2=fac*bb
1851             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1852             eps2der=evdwij*eps3rt
1853             eps3der=evdwij*eps2rt
1854 C       write(63,'(2i3,2e10.3,2f10.5)') i,j,aa,bb, evdwij,
1855 C     &((sslipi+sslipj)/2.0d0+
1856 C     &(2.0d0-sslipi-sslipj)/2.0d0)
1857 c            write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt,
1858 c     &        " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2
1859             evdwij=evdwij*eps2rt*eps3rt
1860             evdw=evdw+evdwij*sss
1861             if (lprn) then
1862             sigm=dabs(aa/bb)**(1.0D0/6.0D0)
1863             epsi=bb**2/aa
1864             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1865      &        restyp(itypi),i,restyp(itypj),j,
1866      &        epsi,sigm,chi1,chi2,chip1,chip2,
1867      &        eps1,eps2rt**2,eps3rt**2,sig,sig0ij,
1868      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1869      &        evdwij
1870             endif
1871
1872             if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
1873      &                        'evdw',i,j,evdwij
1874
1875 C Calculate gradient components.
1876             e1=e1*eps1*eps2rt**2*eps3rt**2
1877             fac=-expon*(e1+evdwij)*rij_shift
1878             sigder=fac*sigder
1879             fac=rij*fac
1880 c            print '(2i4,6f8.4)',i,j,sss,sssgrad*
1881 c     &      evdwij,fac,sigma(itypi,itypj),expon
1882             fac=fac+evdwij/sss*sssgrad/sigma(itypi,itypj)*rij
1883 c            fac=0.0d0
1884 C Calculate the radial part of the gradient
1885             gg_lipi(3)=eps1*(eps2rt*eps2rt)
1886      &*(eps3rt*eps3rt)*sss/2.0d0*(faclip*faclip*
1887      & (aa_lip(itypi,itypj)-aa_aq(itypi,itypj))
1888      &+faclip*(bb_lip(itypi,itypj)-bb_aq(itypi,itypj)))
1889             gg_lipj(3)=ssgradlipj*gg_lipi(3)
1890             gg_lipi(3)=gg_lipi(3)*ssgradlipi
1891 C            gg_lipi(3)=0.0d0
1892 C            gg_lipj(3)=0.0d0
1893             gg(1)=xj*fac
1894             gg(2)=yj*fac
1895             gg(3)=zj*fac
1896 C Calculate angular part of the gradient.
1897             call sc_grad
1898             endif
1899             ENDIF    ! dyn_ss
1900           enddo      ! j
1901         enddo        ! iint
1902       enddo          ! i
1903 C      enddo          ! zshift
1904 C      enddo          ! yshift
1905 C      enddo          ! xshift
1906 c      write (iout,*) "Number of loop steps in EGB:",ind
1907 cccc      energy_dec=.false.
1908       return
1909       end
1910 C-----------------------------------------------------------------------------
1911       subroutine egbv(evdw)
1912 C
1913 C This subroutine calculates the interaction energy of nonbonded side chains
1914 C assuming the Gay-Berne-Vorobjev potential of interaction.
1915 C
1916       implicit real*8 (a-h,o-z)
1917       include 'DIMENSIONS'
1918       include 'COMMON.GEO'
1919       include 'COMMON.VAR'
1920       include 'COMMON.LOCAL'
1921       include 'COMMON.CHAIN'
1922       include 'COMMON.DERIV'
1923       include 'COMMON.NAMES'
1924       include 'COMMON.INTERACT'
1925       include 'COMMON.IOUNITS'
1926       include 'COMMON.CALC'
1927       common /srutu/ icall
1928       logical lprn
1929       evdw=0.0D0
1930 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1931       evdw=0.0D0
1932       lprn=.false.
1933 c     if (icall.eq.0) lprn=.true.
1934       ind=0
1935       do i=iatsc_s,iatsc_e
1936         itypi=iabs(itype(i))
1937         if (itypi.eq.ntyp1) cycle
1938         itypi1=iabs(itype(i+1))
1939         xi=c(1,nres+i)
1940         yi=c(2,nres+i)
1941         zi=c(3,nres+i)
1942           xi=mod(xi,boxxsize)
1943           if (xi.lt.0) xi=xi+boxxsize
1944           yi=mod(yi,boxysize)
1945           if (yi.lt.0) yi=yi+boxysize
1946           zi=mod(zi,boxzsize)
1947           if (zi.lt.0) zi=zi+boxzsize
1948 C define scaling factor for lipids
1949
1950 C        if (positi.le.0) positi=positi+boxzsize
1951 C        print *,i
1952 C first for peptide groups
1953 c for each residue check if it is in lipid or lipid water border area
1954        if ((zi.gt.bordlipbot)
1955      &.and.(zi.lt.bordliptop)) then
1956 C the energy transfer exist
1957         if (zi.lt.buflipbot) then
1958 C what fraction I am in
1959          fracinbuf=1.0d0-
1960      &        ((zi-bordlipbot)/lipbufthick)
1961 C lipbufthick is thickenes of lipid buffore
1962          sslipi=sscalelip(fracinbuf)
1963          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
1964         elseif (zi.gt.bufliptop) then
1965          fracinbuf=1.0d0-((bordliptop-zi)/lipbufthick)
1966          sslipi=sscalelip(fracinbuf)
1967          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
1968         else
1969          sslipi=1.0d0
1970          ssgradlipi=0.0
1971         endif
1972        else
1973          sslipi=0.0d0
1974          ssgradlipi=0.0
1975        endif
1976
1977         dxi=dc_norm(1,nres+i)
1978         dyi=dc_norm(2,nres+i)
1979         dzi=dc_norm(3,nres+i)
1980 c        dsci_inv=dsc_inv(itypi)
1981         dsci_inv=vbld_inv(i+nres)
1982 C
1983 C Calculate SC interaction energy.
1984 C
1985         do iint=1,nint_gr(i)
1986           do j=istart(i,iint),iend(i,iint)
1987             ind=ind+1
1988             itypj=iabs(itype(j))
1989             if (itypj.eq.ntyp1) cycle
1990 c            dscj_inv=dsc_inv(itypj)
1991             dscj_inv=vbld_inv(j+nres)
1992             sig0ij=sigma(itypi,itypj)
1993             r0ij=r0(itypi,itypj)
1994             chi1=chi(itypi,itypj)
1995             chi2=chi(itypj,itypi)
1996             chi12=chi1*chi2
1997             chip1=chip(itypi)
1998             chip2=chip(itypj)
1999             chip12=chip1*chip2
2000             alf1=alp(itypi)
2001             alf2=alp(itypj)
2002             alf12=0.5D0*(alf1+alf2)
2003 C For diagnostics only!!!
2004 c           chi1=0.0D0
2005 c           chi2=0.0D0
2006 c           chi12=0.0D0
2007 c           chip1=0.0D0
2008 c           chip2=0.0D0
2009 c           chip12=0.0D0
2010 c           alf1=0.0D0
2011 c           alf2=0.0D0
2012 c           alf12=0.0D0
2013 C            xj=c(1,nres+j)-xi
2014 C            yj=c(2,nres+j)-yi
2015 C            zj=c(3,nres+j)-zi
2016           xj=mod(xj,boxxsize)
2017           if (xj.lt.0) xj=xj+boxxsize
2018           yj=mod(yj,boxysize)
2019           if (yj.lt.0) yj=yj+boxysize
2020           zj=mod(zj,boxzsize)
2021           if (zj.lt.0) zj=zj+boxzsize
2022        if ((zj.gt.bordlipbot)
2023      &.and.(zj.lt.bordliptop)) then
2024 C the energy transfer exist
2025         if (zj.lt.buflipbot) then
2026 C what fraction I am in
2027          fracinbuf=1.0d0-
2028      &        ((zj-bordlipbot)/lipbufthick)
2029 C lipbufthick is thickenes of lipid buffore
2030          sslipj=sscalelip(fracinbuf)
2031          ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
2032         elseif (zj.gt.bufliptop) then
2033          fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
2034          sslipj=sscalelip(fracinbuf)
2035          ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
2036         else
2037          sslipj=1.0d0
2038          ssgradlipj=0.0
2039         endif
2040        else
2041          sslipj=0.0d0
2042          ssgradlipj=0.0
2043        endif
2044       aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
2045      &  +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
2046       bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
2047      &  +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
2048 C      if (aa.ne.aa_aq(itypi,itypj)) write(63,'2e10.5')
2049 C     &(aa-aa_aq(itypi,itypj)),(bb-bb_aq(itypi,itypj))
2050       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
2051       xj_safe=xj
2052       yj_safe=yj
2053       zj_safe=zj
2054       subchap=0
2055       do xshift=-1,1
2056       do yshift=-1,1
2057       do zshift=-1,1
2058           xj=xj_safe+xshift*boxxsize
2059           yj=yj_safe+yshift*boxysize
2060           zj=zj_safe+zshift*boxzsize
2061           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
2062           if(dist_temp.lt.dist_init) then
2063             dist_init=dist_temp
2064             xj_temp=xj
2065             yj_temp=yj
2066             zj_temp=zj
2067             subchap=1
2068           endif
2069        enddo
2070        enddo
2071        enddo
2072        if (subchap.eq.1) then
2073           xj=xj_temp-xi
2074           yj=yj_temp-yi
2075           zj=zj_temp-zi
2076        else
2077           xj=xj_safe-xi
2078           yj=yj_safe-yi
2079           zj=zj_safe-zi
2080        endif
2081             dxj=dc_norm(1,nres+j)
2082             dyj=dc_norm(2,nres+j)
2083             dzj=dc_norm(3,nres+j)
2084             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
2085             rij=dsqrt(rrij)
2086 C Calculate angle-dependent terms of energy and contributions to their
2087 C derivatives.
2088             call sc_angular
2089             sigsq=1.0D0/sigsq
2090             sig=sig0ij*dsqrt(sigsq)
2091             rij_shift=1.0D0/rij-sig+r0ij
2092 C I hate to put IF's in the loops, but here don't have another choice!!!!
2093             if (rij_shift.le.0.0D0) then
2094               evdw=1.0D20
2095               return
2096             endif
2097             sigder=-sig*sigsq
2098 c---------------------------------------------------------------
2099             rij_shift=1.0D0/rij_shift
2100             fac=rij_shift**expon
2101             e1=fac*fac*aa
2102             e2=fac*bb
2103             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
2104             eps2der=evdwij*eps3rt
2105             eps3der=evdwij*eps2rt
2106             fac_augm=rrij**expon
2107             e_augm=augm(itypi,itypj)*fac_augm
2108             evdwij=evdwij*eps2rt*eps3rt
2109             evdw=evdw+evdwij+e_augm
2110             if (lprn) then
2111             sigm=dabs(aa/bb)**(1.0D0/6.0D0)
2112             epsi=bb**2/aa
2113             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
2114      &        restyp(itypi),i,restyp(itypj),j,
2115      &        epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),
2116      &        chi1,chi2,chip1,chip2,
2117      &        eps1,eps2rt**2,eps3rt**2,
2118      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
2119      &        evdwij+e_augm
2120             endif
2121 C Calculate gradient components.
2122             e1=e1*eps1*eps2rt**2*eps3rt**2
2123             fac=-expon*(e1+evdwij)*rij_shift
2124             sigder=fac*sigder
2125             fac=rij*fac-2*expon*rrij*e_augm
2126             fac=fac+evdwij/sss*sssgrad/sigma(itypi,itypj)*rij
2127 C Calculate the radial part of the gradient
2128             gg(1)=xj*fac
2129             gg(2)=yj*fac
2130             gg(3)=zj*fac
2131 C Calculate angular part of the gradient.
2132             call sc_grad
2133           enddo      ! j
2134         enddo        ! iint
2135       enddo          ! i
2136       end
2137 C-----------------------------------------------------------------------------
2138       subroutine sc_angular
2139 C Calculate eps1,eps2,eps3,sigma, and parts of their derivatives in om1,om2,
2140 C om12. Called by ebp, egb, and egbv.
2141       implicit none
2142       include 'COMMON.CALC'
2143       include 'COMMON.IOUNITS'
2144       erij(1)=xj*rij
2145       erij(2)=yj*rij
2146       erij(3)=zj*rij
2147       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
2148       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
2149       om12=dxi*dxj+dyi*dyj+dzi*dzj
2150       chiom12=chi12*om12
2151 C Calculate eps1(om12) and its derivative in om12
2152       faceps1=1.0D0-om12*chiom12
2153       faceps1_inv=1.0D0/faceps1
2154       eps1=dsqrt(faceps1_inv)
2155 C Following variable is eps1*deps1/dom12
2156       eps1_om12=faceps1_inv*chiom12
2157 c diagnostics only
2158 c      faceps1_inv=om12
2159 c      eps1=om12
2160 c      eps1_om12=1.0d0
2161 c      write (iout,*) "om12",om12," eps1",eps1
2162 C Calculate sigma(om1,om2,om12) and the derivatives of sigma**2 in om1,om2,
2163 C and om12.
2164       om1om2=om1*om2
2165       chiom1=chi1*om1
2166       chiom2=chi2*om2
2167       facsig=om1*chiom1+om2*chiom2-2.0D0*om1om2*chiom12
2168       sigsq=1.0D0-facsig*faceps1_inv
2169       sigsq_om1=(chiom1-chiom12*om2)*faceps1_inv
2170       sigsq_om2=(chiom2-chiom12*om1)*faceps1_inv
2171       sigsq_om12=-chi12*(om1om2*faceps1-om12*facsig)*faceps1_inv**2
2172 c diagnostics only
2173 c      sigsq=1.0d0
2174 c      sigsq_om1=0.0d0
2175 c      sigsq_om2=0.0d0
2176 c      sigsq_om12=0.0d0
2177 c      write (iout,*) "chiom1",chiom1," chiom2",chiom2," chiom12",chiom12
2178 c      write (iout,*) "faceps1",faceps1," faceps1_inv",faceps1_inv,
2179 c     &    " eps1",eps1
2180 C Calculate eps2 and its derivatives in om1, om2, and om12.
2181       chipom1=chip1*om1
2182       chipom2=chip2*om2
2183       chipom12=chip12*om12
2184       facp=1.0D0-om12*chipom12
2185       facp_inv=1.0D0/facp
2186       facp1=om1*chipom1+om2*chipom2-2.0D0*om1om2*chipom12
2187 c      write (iout,*) "chipom1",chipom1," chipom2",chipom2,
2188 c     &  " chipom12",chipom12," facp",facp," facp_inv",facp_inv
2189 C Following variable is the square root of eps2
2190       eps2rt=1.0D0-facp1*facp_inv
2191 C Following three variables are the derivatives of the square root of eps
2192 C in om1, om2, and om12.
2193       eps2rt_om1=-4.0D0*(chipom1-chipom12*om2)*facp_inv
2194       eps2rt_om2=-4.0D0*(chipom2-chipom12*om1)*facp_inv
2195       eps2rt_om12=4.0D0*chip12*(om1om2*facp-om12*facp1)*facp_inv**2
2196 C Evaluate the "asymmetric" factor in the VDW constant, eps3
2197       eps3rt=1.0D0-alf1*om1+alf2*om2-alf12*om12
2198 c      write (iout,*) "eps2rt",eps2rt," eps3rt",eps3rt
2199 c      write (iout,*) "eps2rt_om1",eps2rt_om1," eps2rt_om2",eps2rt_om2,
2200 c     &  " eps2rt_om12",eps2rt_om12
2201 C Calculate whole angle-dependent part of epsilon and contributions
2202 C to its derivatives
2203       return
2204       end
2205 C----------------------------------------------------------------------------
2206       subroutine sc_grad
2207       implicit real*8 (a-h,o-z)
2208       include 'DIMENSIONS'
2209       include 'COMMON.CHAIN'
2210       include 'COMMON.DERIV'
2211       include 'COMMON.CALC'
2212       include 'COMMON.IOUNITS'
2213       double precision dcosom1(3),dcosom2(3)
2214 cc      print *,'sss=',sss
2215       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
2216       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
2217       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12
2218      &     -2.0D0*alf12*eps3der+sigder*sigsq_om12
2219 c diagnostics only
2220 c      eom1=0.0d0
2221 c      eom2=0.0d0
2222 c      eom12=evdwij*eps1_om12
2223 c end diagnostics
2224 c      write (iout,*) "eps2der",eps2der," eps3der",eps3der,
2225 c     &  " sigder",sigder
2226 c      write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12
2227 c      write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12
2228       do k=1,3
2229         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
2230         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
2231       enddo
2232       do k=1,3
2233         gg(k)=(gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k))*sss
2234       enddo
2235 c      write (iout,*) "gg",(gg(k),k=1,3)
2236       do k=1,3
2237         gvdwx(k,i)=gvdwx(k,i)-gg(k)+gg_lipi(k)
2238      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
2239      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv*sss
2240         gvdwx(k,j)=gvdwx(k,j)+gg(k)+gg_lipj(k)
2241      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
2242      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv*sss
2243 c        write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
2244 c     &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
2245 c        write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
2246 c     &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
2247       enddo
2248 C
2249 C Calculate the components of the gradient in DC and X
2250 C
2251 cgrad      do k=i,j-1
2252 cgrad        do l=1,3
2253 cgrad          gvdwc(l,k)=gvdwc(l,k)+gg(l)
2254 cgrad        enddo
2255 cgrad      enddo
2256       do l=1,3
2257         gvdwc(l,i)=gvdwc(l,i)-gg(l)+gg_lipi(l)
2258         gvdwc(l,j)=gvdwc(l,j)+gg(l)+gg_lipj(l)
2259       enddo
2260       return
2261       end
2262 C-----------------------------------------------------------------------
2263       subroutine e_softsphere(evdw)
2264 C
2265 C This subroutine calculates the interaction energy of nonbonded side chains
2266 C assuming the LJ potential of interaction.
2267 C
2268       implicit real*8 (a-h,o-z)
2269       include 'DIMENSIONS'
2270       parameter (accur=1.0d-10)
2271       include 'COMMON.GEO'
2272       include 'COMMON.VAR'
2273       include 'COMMON.LOCAL'
2274       include 'COMMON.CHAIN'
2275       include 'COMMON.DERIV'
2276       include 'COMMON.INTERACT'
2277       include 'COMMON.TORSION'
2278       include 'COMMON.SBRIDGE'
2279       include 'COMMON.NAMES'
2280       include 'COMMON.IOUNITS'
2281       include 'COMMON.CONTACTS'
2282       dimension gg(3)
2283 cd    print *,'Entering Esoft_sphere nnt=',nnt,' nct=',nct
2284       evdw=0.0D0
2285       do i=iatsc_s,iatsc_e
2286         itypi=iabs(itype(i))
2287         if (itypi.eq.ntyp1) cycle
2288         itypi1=iabs(itype(i+1))
2289         xi=c(1,nres+i)
2290         yi=c(2,nres+i)
2291         zi=c(3,nres+i)
2292 C
2293 C Calculate SC interaction energy.
2294 C
2295         do iint=1,nint_gr(i)
2296 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
2297 cd   &                  'iend=',iend(i,iint)
2298           do j=istart(i,iint),iend(i,iint)
2299             itypj=iabs(itype(j))
2300             if (itypj.eq.ntyp1) cycle
2301             xj=c(1,nres+j)-xi
2302             yj=c(2,nres+j)-yi
2303             zj=c(3,nres+j)-zi
2304             rij=xj*xj+yj*yj+zj*zj
2305 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
2306             r0ij=r0(itypi,itypj)
2307             r0ijsq=r0ij*r0ij
2308 c            print *,i,j,r0ij,dsqrt(rij)
2309             if (rij.lt.r0ijsq) then
2310               evdwij=0.25d0*(rij-r0ijsq)**2
2311               fac=rij-r0ijsq
2312             else
2313               evdwij=0.0d0
2314               fac=0.0d0
2315             endif
2316             evdw=evdw+evdwij
2317 C
2318 C Calculate the components of the gradient in DC and X
2319 C
2320             gg(1)=xj*fac
2321             gg(2)=yj*fac
2322             gg(3)=zj*fac
2323             do k=1,3
2324               gvdwx(k,i)=gvdwx(k,i)-gg(k)
2325               gvdwx(k,j)=gvdwx(k,j)+gg(k)
2326               gvdwc(k,i)=gvdwc(k,i)-gg(k)
2327               gvdwc(k,j)=gvdwc(k,j)+gg(k)
2328             enddo
2329 cgrad            do k=i,j-1
2330 cgrad              do l=1,3
2331 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
2332 cgrad              enddo
2333 cgrad            enddo
2334           enddo ! j
2335         enddo ! iint
2336       enddo ! i
2337       return
2338       end
2339 C--------------------------------------------------------------------------
2340       subroutine eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,
2341      &              eello_turn4)
2342 C
2343 C Soft-sphere potential of p-p interaction
2344 C
2345       implicit real*8 (a-h,o-z)
2346       include 'DIMENSIONS'
2347       include 'COMMON.CONTROL'
2348       include 'COMMON.IOUNITS'
2349       include 'COMMON.GEO'
2350       include 'COMMON.VAR'
2351       include 'COMMON.LOCAL'
2352       include 'COMMON.CHAIN'
2353       include 'COMMON.DERIV'
2354       include 'COMMON.INTERACT'
2355       include 'COMMON.CONTACTS'
2356       include 'COMMON.TORSION'
2357       include 'COMMON.VECTORS'
2358       include 'COMMON.FFIELD'
2359       dimension ggg(3)
2360 C      write(iout,*) 'In EELEC_soft_sphere'
2361       ees=0.0D0
2362       evdw1=0.0D0
2363       eel_loc=0.0d0
2364       eello_turn3=0.0d0
2365       eello_turn4=0.0d0
2366       ind=0
2367       do i=iatel_s,iatel_e
2368         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
2369         dxi=dc(1,i)
2370         dyi=dc(2,i)
2371         dzi=dc(3,i)
2372         xmedi=c(1,i)+0.5d0*dxi
2373         ymedi=c(2,i)+0.5d0*dyi
2374         zmedi=c(3,i)+0.5d0*dzi
2375           xmedi=mod(xmedi,boxxsize)
2376           if (xmedi.lt.0) xmedi=xmedi+boxxsize
2377           ymedi=mod(ymedi,boxysize)
2378           if (ymedi.lt.0) ymedi=ymedi+boxysize
2379           zmedi=mod(zmedi,boxzsize)
2380           if (zmedi.lt.0) zmedi=zmedi+boxzsize
2381         num_conti=0
2382 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
2383         do j=ielstart(i),ielend(i)
2384           if (itype(j).eq.ntyp1 .or. itype(j+1).eq.ntyp1) cycle
2385           ind=ind+1
2386           iteli=itel(i)
2387           itelj=itel(j)
2388           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
2389           r0ij=rpp(iteli,itelj)
2390           r0ijsq=r0ij*r0ij
2391           dxj=dc(1,j)
2392           dyj=dc(2,j)
2393           dzj=dc(3,j)
2394           xj=c(1,j)+0.5D0*dxj
2395           yj=c(2,j)+0.5D0*dyj
2396           zj=c(3,j)+0.5D0*dzj
2397           xj=mod(xj,boxxsize)
2398           if (xj.lt.0) xj=xj+boxxsize
2399           yj=mod(yj,boxysize)
2400           if (yj.lt.0) yj=yj+boxysize
2401           zj=mod(zj,boxzsize)
2402           if (zj.lt.0) zj=zj+boxzsize
2403       dist_init=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
2404       xj_safe=xj
2405       yj_safe=yj
2406       zj_safe=zj
2407       isubchap=0
2408       do xshift=-1,1
2409       do yshift=-1,1
2410       do zshift=-1,1
2411           xj=xj_safe+xshift*boxxsize
2412           yj=yj_safe+yshift*boxysize
2413           zj=zj_safe+zshift*boxzsize
2414           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
2415           if(dist_temp.lt.dist_init) then
2416             dist_init=dist_temp
2417             xj_temp=xj
2418             yj_temp=yj
2419             zj_temp=zj
2420             isubchap=1
2421           endif
2422        enddo
2423        enddo
2424        enddo
2425        if (isubchap.eq.1) then
2426           xj=xj_temp-xmedi
2427           yj=yj_temp-ymedi
2428           zj=zj_temp-zmedi
2429        else
2430           xj=xj_safe-xmedi
2431           yj=yj_safe-ymedi
2432           zj=zj_safe-zmedi
2433        endif
2434           rij=xj*xj+yj*yj+zj*zj
2435             sss=sscale(sqrt(rij))
2436             sssgrad=sscagrad(sqrt(rij))
2437           if (rij.lt.r0ijsq) then
2438             evdw1ij=0.25d0*(rij-r0ijsq)**2
2439             fac=rij-r0ijsq
2440           else
2441             evdw1ij=0.0d0
2442             fac=0.0d0
2443           endif
2444           evdw1=evdw1+evdw1ij*sss
2445 C
2446 C Calculate contributions to the Cartesian gradient.
2447 C
2448           ggg(1)=fac*xj*sssgrad
2449           ggg(2)=fac*yj*sssgrad
2450           ggg(3)=fac*zj*sssgrad
2451           do k=1,3
2452             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
2453             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
2454           enddo
2455 *
2456 * Loop over residues i+1 thru j-1.
2457 *
2458 cgrad          do k=i+1,j-1
2459 cgrad            do l=1,3
2460 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
2461 cgrad            enddo
2462 cgrad          enddo
2463         enddo ! j
2464       enddo   ! i
2465 cgrad      do i=nnt,nct-1
2466 cgrad        do k=1,3
2467 cgrad          gelc(k,i)=gelc(k,i)+0.5d0*gelc(k,i)
2468 cgrad        enddo
2469 cgrad        do j=i+1,nct-1
2470 cgrad          do k=1,3
2471 cgrad            gelc(k,i)=gelc(k,i)+gelc(k,j)
2472 cgrad          enddo
2473 cgrad        enddo
2474 cgrad      enddo
2475       return
2476       end
2477 c------------------------------------------------------------------------------
2478       subroutine vec_and_deriv
2479       implicit real*8 (a-h,o-z)
2480       include 'DIMENSIONS'
2481 #ifdef MPI
2482       include 'mpif.h'
2483 #endif
2484       include 'COMMON.IOUNITS'
2485       include 'COMMON.GEO'
2486       include 'COMMON.VAR'
2487       include 'COMMON.LOCAL'
2488       include 'COMMON.CHAIN'
2489       include 'COMMON.VECTORS'
2490       include 'COMMON.SETUP'
2491       include 'COMMON.TIME1'
2492       dimension uyder(3,3,2),uzder(3,3,2),vbld_inv_temp(2)
2493 C Compute the local reference systems. For reference system (i), the
2494 C X-axis points from CA(i) to CA(i+1), the Y axis is in the
2495 C CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
2496 #ifdef PARVEC
2497       do i=ivec_start,ivec_end
2498 #else
2499       do i=1,nres-1
2500 #endif
2501           if (i.eq.nres-1) then
2502 C Case of the last full residue
2503 C Compute the Z-axis
2504             call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
2505             costh=dcos(pi-theta(nres))
2506             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2507             do k=1,3
2508               uz(k,i)=fac*uz(k,i)
2509             enddo
2510 C Compute the derivatives of uz
2511             uzder(1,1,1)= 0.0d0
2512             uzder(2,1,1)=-dc_norm(3,i-1)
2513             uzder(3,1,1)= dc_norm(2,i-1)
2514             uzder(1,2,1)= dc_norm(3,i-1)
2515             uzder(2,2,1)= 0.0d0
2516             uzder(3,2,1)=-dc_norm(1,i-1)
2517             uzder(1,3,1)=-dc_norm(2,i-1)
2518             uzder(2,3,1)= dc_norm(1,i-1)
2519             uzder(3,3,1)= 0.0d0
2520             uzder(1,1,2)= 0.0d0
2521             uzder(2,1,2)= dc_norm(3,i)
2522             uzder(3,1,2)=-dc_norm(2,i)
2523             uzder(1,2,2)=-dc_norm(3,i)
2524             uzder(2,2,2)= 0.0d0
2525             uzder(3,2,2)= dc_norm(1,i)
2526             uzder(1,3,2)= dc_norm(2,i)
2527             uzder(2,3,2)=-dc_norm(1,i)
2528             uzder(3,3,2)= 0.0d0
2529 C Compute the Y-axis
2530             facy=fac
2531             do k=1,3
2532               uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
2533             enddo
2534 C Compute the derivatives of uy
2535             do j=1,3
2536               do k=1,3
2537                 uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i)
2538      &                        -dc_norm(k,i)*dc_norm(j,i-1)
2539                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2540               enddo
2541               uyder(j,j,1)=uyder(j,j,1)-costh
2542               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2543             enddo
2544             do j=1,2
2545               do k=1,3
2546                 do l=1,3
2547                   uygrad(l,k,j,i)=uyder(l,k,j)
2548                   uzgrad(l,k,j,i)=uzder(l,k,j)
2549                 enddo
2550               enddo
2551             enddo
2552             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2553             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2554             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2555             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2556           else
2557 C Other residues
2558 C Compute the Z-axis
2559             call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
2560             costh=dcos(pi-theta(i+2))
2561             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2562             do k=1,3
2563               uz(k,i)=fac*uz(k,i)
2564             enddo
2565 C Compute the derivatives of uz
2566             uzder(1,1,1)= 0.0d0
2567             uzder(2,1,1)=-dc_norm(3,i+1)
2568             uzder(3,1,1)= dc_norm(2,i+1)
2569             uzder(1,2,1)= dc_norm(3,i+1)
2570             uzder(2,2,1)= 0.0d0
2571             uzder(3,2,1)=-dc_norm(1,i+1)
2572             uzder(1,3,1)=-dc_norm(2,i+1)
2573             uzder(2,3,1)= dc_norm(1,i+1)
2574             uzder(3,3,1)= 0.0d0
2575             uzder(1,1,2)= 0.0d0
2576             uzder(2,1,2)= dc_norm(3,i)
2577             uzder(3,1,2)=-dc_norm(2,i)
2578             uzder(1,2,2)=-dc_norm(3,i)
2579             uzder(2,2,2)= 0.0d0
2580             uzder(3,2,2)= dc_norm(1,i)
2581             uzder(1,3,2)= dc_norm(2,i)
2582             uzder(2,3,2)=-dc_norm(1,i)
2583             uzder(3,3,2)= 0.0d0
2584 C Compute the Y-axis
2585             facy=fac
2586             do k=1,3
2587               uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
2588             enddo
2589 C Compute the derivatives of uy
2590             do j=1,3
2591               do k=1,3
2592                 uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i)
2593      &                        -dc_norm(k,i)*dc_norm(j,i+1)
2594                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2595               enddo
2596               uyder(j,j,1)=uyder(j,j,1)-costh
2597               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2598             enddo
2599             do j=1,2
2600               do k=1,3
2601                 do l=1,3
2602                   uygrad(l,k,j,i)=uyder(l,k,j)
2603                   uzgrad(l,k,j,i)=uzder(l,k,j)
2604                 enddo
2605               enddo
2606             enddo
2607             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2608             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2609             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2610             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2611           endif
2612       enddo
2613       do i=1,nres-1
2614         vbld_inv_temp(1)=vbld_inv(i+1)
2615         if (i.lt.nres-1) then
2616           vbld_inv_temp(2)=vbld_inv(i+2)
2617           else
2618           vbld_inv_temp(2)=vbld_inv(i)
2619           endif
2620         do j=1,2
2621           do k=1,3
2622             do l=1,3
2623               uygrad(l,k,j,i)=vbld_inv_temp(j)*uygrad(l,k,j,i)
2624               uzgrad(l,k,j,i)=vbld_inv_temp(j)*uzgrad(l,k,j,i)
2625             enddo
2626           enddo
2627         enddo
2628       enddo
2629 #if defined(PARVEC) && defined(MPI)
2630       if (nfgtasks1.gt.1) then
2631         time00=MPI_Wtime()
2632 c        print *,"Processor",fg_rank1,kolor1," ivec_start",ivec_start,
2633 c     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks1-1),
2634 c     &   " ivec_count",(ivec_count(i),i=0,nfgtasks1-1)
2635         call MPI_Allgatherv(uy(1,ivec_start),ivec_count(fg_rank1),
2636      &   MPI_UYZ,uy(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
2637      &   FG_COMM1,IERR)
2638         call MPI_Allgatherv(uz(1,ivec_start),ivec_count(fg_rank1),
2639      &   MPI_UYZ,uz(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
2640      &   FG_COMM1,IERR)
2641         call MPI_Allgatherv(uygrad(1,1,1,ivec_start),
2642      &   ivec_count(fg_rank1),MPI_UYZGRAD,uygrad(1,1,1,1),ivec_count(0),
2643      &   ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2644         call MPI_Allgatherv(uzgrad(1,1,1,ivec_start),
2645      &   ivec_count(fg_rank1),MPI_UYZGRAD,uzgrad(1,1,1,1),ivec_count(0),
2646      &   ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2647         time_gather=time_gather+MPI_Wtime()-time00
2648       endif
2649 c      if (fg_rank.eq.0) then
2650 c        write (iout,*) "Arrays UY and UZ"
2651 c        do i=1,nres-1
2652 c          write (iout,'(i5,3f10.5,5x,3f10.5)') i,(uy(k,i),k=1,3),
2653 c     &     (uz(k,i),k=1,3)
2654 c        enddo
2655 c      endif
2656 #endif
2657       return
2658       end
2659 C-----------------------------------------------------------------------------
2660       subroutine check_vecgrad
2661       implicit real*8 (a-h,o-z)
2662       include 'DIMENSIONS'
2663       include 'COMMON.IOUNITS'
2664       include 'COMMON.GEO'
2665       include 'COMMON.VAR'
2666       include 'COMMON.LOCAL'
2667       include 'COMMON.CHAIN'
2668       include 'COMMON.VECTORS'
2669       dimension uygradt(3,3,2,maxres),uzgradt(3,3,2,maxres)
2670       dimension uyt(3,maxres),uzt(3,maxres)
2671       dimension uygradn(3,3,2),uzgradn(3,3,2),erij(3)
2672       double precision delta /1.0d-7/
2673       call vec_and_deriv
2674 cd      do i=1,nres
2675 crc          write(iout,'(2i5,2(3f10.5,5x))') i,1,dc_norm(:,i)
2676 crc          write(iout,'(2i5,2(3f10.5,5x))') i,2,uy(:,i)
2677 crc          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,uz(:,i)
2678 cd          write(iout,'(2i5,2(3f10.5,5x))') i,1,
2679 cd     &     (dc_norm(if90,i),if90=1,3)
2680 cd          write(iout,'(2i5,2(3f10.5,5x))') i,2,(uy(if90,i),if90=1,3)
2681 cd          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,(uz(if90,i),if90=1,3)
2682 cd          write(iout,'(a)')
2683 cd      enddo
2684       do i=1,nres
2685         do j=1,2
2686           do k=1,3
2687             do l=1,3
2688               uygradt(l,k,j,i)=uygrad(l,k,j,i)
2689               uzgradt(l,k,j,i)=uzgrad(l,k,j,i)
2690             enddo
2691           enddo
2692         enddo
2693       enddo
2694       call vec_and_deriv
2695       do i=1,nres
2696         do j=1,3
2697           uyt(j,i)=uy(j,i)
2698           uzt(j,i)=uz(j,i)
2699         enddo
2700       enddo
2701       do i=1,nres
2702 cd        write (iout,*) 'i=',i
2703         do k=1,3
2704           erij(k)=dc_norm(k,i)
2705         enddo
2706         do j=1,3
2707           do k=1,3
2708             dc_norm(k,i)=erij(k)
2709           enddo
2710           dc_norm(j,i)=dc_norm(j,i)+delta
2711 c          fac=dsqrt(scalar(dc_norm(1,i),dc_norm(1,i)))
2712 c          do k=1,3
2713 c            dc_norm(k,i)=dc_norm(k,i)/fac
2714 c          enddo
2715 c          write (iout,*) (dc_norm(k,i),k=1,3)
2716 c          write (iout,*) (erij(k),k=1,3)
2717           call vec_and_deriv
2718           do k=1,3
2719             uygradn(k,j,1)=(uy(k,i)-uyt(k,i))/delta
2720             uygradn(k,j,2)=(uy(k,i-1)-uyt(k,i-1))/delta
2721             uzgradn(k,j,1)=(uz(k,i)-uzt(k,i))/delta
2722             uzgradn(k,j,2)=(uz(k,i-1)-uzt(k,i-1))/delta
2723           enddo
2724 c          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2725 c     &      j,(uzgradt(k,j,1,i),k=1,3),(uzgradn(k,j,1),k=1,3),
2726 c     &      (uzgradt(k,j,2,i-1),k=1,3),(uzgradn(k,j,2),k=1,3)
2727         enddo
2728         do k=1,3
2729           dc_norm(k,i)=erij(k)
2730         enddo
2731 cd        do k=1,3
2732 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2733 cd     &      k,(uygradt(k,l,1,i),l=1,3),(uygradn(k,l,1),l=1,3),
2734 cd     &      (uygradt(k,l,2,i-1),l=1,3),(uygradn(k,l,2),l=1,3)
2735 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2736 cd     &      k,(uzgradt(k,l,1,i),l=1,3),(uzgradn(k,l,1),l=1,3),
2737 cd     &      (uzgradt(k,l,2,i-1),l=1,3),(uzgradn(k,l,2),l=1,3)
2738 cd          write (iout,'(a)')
2739 cd        enddo
2740       enddo
2741       return
2742       end
2743 C--------------------------------------------------------------------------
2744       subroutine set_matrices
2745       implicit real*8 (a-h,o-z)
2746       include 'DIMENSIONS'
2747 #ifdef MPI
2748       include "mpif.h"
2749       include "COMMON.SETUP"
2750       integer IERR
2751       integer status(MPI_STATUS_SIZE)
2752 #endif
2753       include 'COMMON.IOUNITS'
2754       include 'COMMON.GEO'
2755       include 'COMMON.VAR'
2756       include 'COMMON.LOCAL'
2757       include 'COMMON.CHAIN'
2758       include 'COMMON.DERIV'
2759       include 'COMMON.INTERACT'
2760       include 'COMMON.CONTACTS'
2761       include 'COMMON.TORSION'
2762       include 'COMMON.VECTORS'
2763       include 'COMMON.FFIELD'
2764       double precision auxvec(2),auxmat(2,2)
2765 C
2766 C Compute the virtual-bond-torsional-angle dependent quantities needed
2767 C to calculate the el-loc multibody terms of various order.
2768 C
2769 c      write(iout,*) 'nphi=',nphi,nres
2770 #ifdef PARMAT
2771       do i=ivec_start+2,ivec_end+2
2772 #else
2773       do i=3,nres+1
2774 #endif
2775 #ifdef NEWCORR
2776         if (i.gt. nnt+2 .and. i.lt.nct+2) then
2777           iti = itortyp(itype(i-2))
2778         else
2779           iti=ntortyp+1
2780         endif
2781 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2782         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2783           iti1 = itortyp(itype(i-1))
2784         else
2785           iti1=ntortyp+1
2786         endif
2787 c        write(iout,*),i
2788         b1(1,i-2)=bnew1(1,1,iti)*dsin(theta(i-1)/2.0)
2789      &           +bnew1(2,1,iti)*dsin(theta(i-1))
2790      &           +bnew1(3,1,iti)*dcos(theta(i-1)/2.0)
2791         gtb1(1,i-2)=bnew1(1,1,iti)*dcos(theta(i-1)/2.0d0)/2.0d0
2792      &             +bnew1(2,1,iti)*dcos(theta(i-1))
2793      &             -bnew1(3,1,iti)*dsin(theta(i-1)/2.0d0)/2.0d0
2794 c     &           +bnew1(3,1,iti)*sin(alpha(i))*cos(beta(i))
2795 c     &*(cos(theta(i)/2.0)
2796         b2(1,i-2)=bnew2(1,1,iti)*dsin(theta(i-1)/2.0)
2797      &           +bnew2(2,1,iti)*dsin(theta(i-1))
2798      &           +bnew2(3,1,iti)*dcos(theta(i-1)/2.0)
2799 c     &           +bnew2(3,1,iti)*sin(alpha(i))*cos(beta(i))
2800 c     &*(cos(theta(i)/2.0)
2801         gtb2(1,i-2)=bnew2(1,1,iti)*dcos(theta(i-1)/2.0d0)/2.0d0
2802      &             +bnew2(2,1,iti)*dcos(theta(i-1))
2803      &             -bnew2(3,1,iti)*dsin(theta(i-1)/2.0d0)/2.0d0
2804 c        if (ggb1(1,i).eq.0.0d0) then
2805 c        write(iout,*) 'i=',i,ggb1(1,i),
2806 c     &bnew1(1,1,iti)*cos(theta(i)/2.0)/2.0,
2807 c     &bnew1(2,1,iti)*cos(theta(i)),
2808 c     &bnew1(3,1,iti)*sin(theta(i)/2.0)/2.0
2809 c        endif
2810         b1(2,i-2)=bnew1(1,2,iti)
2811         gtb1(2,i-2)=0.0
2812         b2(2,i-2)=bnew2(1,2,iti)
2813         gtb2(2,i-2)=0.0
2814         EE(1,1,i-2)=eenew(1,iti)*dcos(theta(i-1))
2815         EE(1,2,i-2)=eeold(1,2,iti)
2816         EE(2,1,i-2)=eeold(2,1,iti)
2817         EE(2,2,i-2)=eeold(2,2,iti)
2818         gtEE(1,1,i-2)=-eenew(1,iti)*dsin(theta(i-1))
2819         gtEE(1,2,i-2)=0.0d0
2820         gtEE(2,2,i-2)=0.0d0
2821         gtEE(2,1,i-2)=0.0d0
2822 c        EE(2,2,iti)=0.0d0
2823 c        EE(1,2,iti)=0.5d0*eenew(1,iti)
2824 c        EE(2,1,iti)=0.5d0*eenew(1,iti)
2825 c        b1(2,iti)=bnew1(1,2,iti)*sin(alpha(i))*sin(beta(i))
2826 c        b2(2,iti)=bnew2(1,2,iti)*sin(alpha(i))*sin(beta(i))
2827        b1tilde(1,i-2)=b1(1,i-2)
2828        b1tilde(2,i-2)=-b1(2,i-2)
2829        b2tilde(1,i-2)=b2(1,i-2)
2830        b2tilde(2,i-2)=-b2(2,i-2)
2831 c       write (iout,*) 'i=',i-2,gtb1(2,i-2),gtb1(1,i-2)
2832 c       write(iout,*)  'b1=',b1(1,i-2)
2833 c       write (iout,*) 'theta=', theta(i-1)
2834        enddo
2835 #else
2836         if (i.gt. nnt+2 .and. i.lt.nct+2) then
2837           iti = itortyp(itype(i-2))
2838         else
2839           iti=ntortyp+1
2840         endif
2841 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2842         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2843           iti1 = itortyp(itype(i-1))
2844         else
2845           iti1=ntortyp+1
2846         endif
2847         b1(1,i-2)=b(3,iti)
2848         b1(2,i-2)=b(5,iti)
2849         b2(1,i-2)=b(2,iti)
2850         b2(2,i-2)=b(4,iti)
2851        b1tilde(1,i-2)=b1(1,i-2)
2852        b1tilde(2,i-2)=-b1(2,i-2)
2853        b2tilde(1,i-2)=b2(1,i-2)
2854        b2tilde(2,i-2)=-b2(2,i-2)
2855         EE(1,2,i-2)=eeold(1,2,iti)
2856         EE(2,1,i-2)=eeold(2,1,iti)
2857         EE(2,2,i-2)=eeold(2,2,iti)
2858         EE(1,1,i-2)=eeold(1,1,iti)
2859       enddo
2860 #endif
2861 #ifdef PARMAT
2862       do i=ivec_start+2,ivec_end+2
2863 #else
2864       do i=3,nres+1
2865 #endif
2866         if (i .lt. nres+1) then
2867           sin1=dsin(phi(i))
2868           cos1=dcos(phi(i))
2869           sintab(i-2)=sin1
2870           costab(i-2)=cos1
2871           obrot(1,i-2)=cos1
2872           obrot(2,i-2)=sin1
2873           sin2=dsin(2*phi(i))
2874           cos2=dcos(2*phi(i))
2875           sintab2(i-2)=sin2
2876           costab2(i-2)=cos2
2877           obrot2(1,i-2)=cos2
2878           obrot2(2,i-2)=sin2
2879           Ug(1,1,i-2)=-cos1
2880           Ug(1,2,i-2)=-sin1
2881           Ug(2,1,i-2)=-sin1
2882           Ug(2,2,i-2)= cos1
2883           Ug2(1,1,i-2)=-cos2
2884           Ug2(1,2,i-2)=-sin2
2885           Ug2(2,1,i-2)=-sin2
2886           Ug2(2,2,i-2)= cos2
2887         else
2888           costab(i-2)=1.0d0
2889           sintab(i-2)=0.0d0
2890           obrot(1,i-2)=1.0d0
2891           obrot(2,i-2)=0.0d0
2892           obrot2(1,i-2)=0.0d0
2893           obrot2(2,i-2)=0.0d0
2894           Ug(1,1,i-2)=1.0d0
2895           Ug(1,2,i-2)=0.0d0
2896           Ug(2,1,i-2)=0.0d0
2897           Ug(2,2,i-2)=1.0d0
2898           Ug2(1,1,i-2)=0.0d0
2899           Ug2(1,2,i-2)=0.0d0
2900           Ug2(2,1,i-2)=0.0d0
2901           Ug2(2,2,i-2)=0.0d0
2902         endif
2903         if (i .gt. 3 .and. i .lt. nres+1) then
2904           obrot_der(1,i-2)=-sin1
2905           obrot_der(2,i-2)= cos1
2906           Ugder(1,1,i-2)= sin1
2907           Ugder(1,2,i-2)=-cos1
2908           Ugder(2,1,i-2)=-cos1
2909           Ugder(2,2,i-2)=-sin1
2910           dwacos2=cos2+cos2
2911           dwasin2=sin2+sin2
2912           obrot2_der(1,i-2)=-dwasin2
2913           obrot2_der(2,i-2)= dwacos2
2914           Ug2der(1,1,i-2)= dwasin2
2915           Ug2der(1,2,i-2)=-dwacos2
2916           Ug2der(2,1,i-2)=-dwacos2
2917           Ug2der(2,2,i-2)=-dwasin2
2918         else
2919           obrot_der(1,i-2)=0.0d0
2920           obrot_der(2,i-2)=0.0d0
2921           Ugder(1,1,i-2)=0.0d0
2922           Ugder(1,2,i-2)=0.0d0
2923           Ugder(2,1,i-2)=0.0d0
2924           Ugder(2,2,i-2)=0.0d0
2925           obrot2_der(1,i-2)=0.0d0
2926           obrot2_der(2,i-2)=0.0d0
2927           Ug2der(1,1,i-2)=0.0d0
2928           Ug2der(1,2,i-2)=0.0d0
2929           Ug2der(2,1,i-2)=0.0d0
2930           Ug2der(2,2,i-2)=0.0d0
2931         endif
2932 c        if (i.gt. iatel_s+2 .and. i.lt.iatel_e+5) then
2933         if (i.gt. nnt+2 .and. i.lt.nct+2) then
2934           iti = itortyp(itype(i-2))
2935         else
2936           iti=ntortyp
2937         endif
2938 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2939         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2940           iti1 = itortyp(itype(i-1))
2941         else
2942           iti1=ntortyp
2943         endif
2944 cd        write (iout,*) '*******i',i,' iti1',iti
2945 cd        write (iout,*) 'b1',b1(:,iti)
2946 cd        write (iout,*) 'b2',b2(:,iti)
2947 cd        write (iout,*) 'Ug',Ug(:,:,i-2)
2948 c        if (i .gt. iatel_s+2) then
2949         if (i .gt. nnt+2) then
2950           call matvec2(Ug(1,1,i-2),b2(1,i-2),Ub2(1,i-2))
2951 #ifdef NEWCORR
2952           call matvec2(Ug(1,1,i-2),gtb2(1,i-2),gUb2(1,i-2))
2953 c          write (iout,*) Ug(1,1,i-2),gtb2(1,i-2),gUb2(1,i-2),"chuj"
2954 #endif
2955 c          write(iout,*) "co jest kurwa", iti, EE(1,1,iti),EE(2,1,iti),
2956 c     &    EE(1,2,iti),EE(2,2,iti)
2957           call matmat2(EE(1,1,i-2),Ug(1,1,i-2),EUg(1,1,i-2))
2958           call matmat2(gtEE(1,1,i-2),Ug(1,1,i-2),gtEUg(1,1,i-2))
2959 c          write(iout,*) "Macierz EUG",
2960 c     &    eug(1,1,i-2),eug(1,2,i-2),eug(2,1,i-2),
2961 c     &    eug(2,2,i-2)
2962           if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2963      &    then
2964           call matmat2(CC(1,1,iti),Ug(1,1,i-2),CUg(1,1,i-2))
2965           call matmat2(DD(1,1,iti),Ug(1,1,i-2),DUg(1,1,i-2))
2966           call matmat2(Dtilde(1,1,iti),Ug2(1,1,i-2),DtUg2(1,1,i-2))
2967           call matvec2(Ctilde(1,1,iti1),obrot(1,i-2),Ctobr(1,i-2))
2968           call matvec2(Dtilde(1,1,iti),obrot2(1,i-2),Dtobr2(1,i-2))
2969           endif
2970         else
2971           do k=1,2
2972             Ub2(k,i-2)=0.0d0
2973             Ctobr(k,i-2)=0.0d0
2974             Dtobr2(k,i-2)=0.0d0
2975             do l=1,2
2976               EUg(l,k,i-2)=0.0d0
2977               CUg(l,k,i-2)=0.0d0
2978               DUg(l,k,i-2)=0.0d0
2979               DtUg2(l,k,i-2)=0.0d0
2980             enddo
2981           enddo
2982         endif
2983         call matvec2(Ugder(1,1,i-2),b2(1,i-2),Ub2der(1,i-2))
2984         call matmat2(EE(1,1,i-2),Ugder(1,1,i-2),EUgder(1,1,i-2))
2985         do k=1,2
2986           muder(k,i-2)=Ub2der(k,i-2)
2987         enddo
2988 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2989         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2990           if (itype(i-1).le.ntyp) then
2991             iti1 = itortyp(itype(i-1))
2992           else
2993             iti1=ntortyp
2994           endif
2995         else
2996           iti1=ntortyp
2997         endif
2998         do k=1,2
2999           mu(k,i-2)=Ub2(k,i-2)+b1(k,i-1)
3000         enddo
3001 C        write (iout,*) 'mumu',i,b1(1,i-1),Ub2(1,i-2)
3002 c        write (iout,*) 'mu ',mu(:,i-2),i-2
3003 cd        write (iout,*) 'mu1',mu1(:,i-2)
3004 cd        write (iout,*) 'mu2',mu2(:,i-2)
3005         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
3006      &  then
3007         call matmat2(CC(1,1,iti1),Ugder(1,1,i-2),CUgder(1,1,i-2))
3008         call matmat2(DD(1,1,iti),Ugder(1,1,i-2),DUgder(1,1,i-2))
3009         call matmat2(Dtilde(1,1,iti),Ug2der(1,1,i-2),DtUg2der(1,1,i-2))
3010         call matvec2(Ctilde(1,1,iti1),obrot_der(1,i-2),Ctobrder(1,i-2))
3011         call matvec2(Dtilde(1,1,iti),obrot2_der(1,i-2),Dtobr2der(1,i-2))
3012 C Vectors and matrices dependent on a single virtual-bond dihedral.
3013         call matvec2(DD(1,1,iti),b1tilde(1,i-1),auxvec(1))
3014         call matvec2(Ug2(1,1,i-2),auxvec(1),Ug2Db1t(1,i-2))
3015         call matvec2(Ug2der(1,1,i-2),auxvec(1),Ug2Db1tder(1,i-2))
3016         call matvec2(CC(1,1,iti1),Ub2(1,i-2),CUgb2(1,i-2))
3017         call matvec2(CC(1,1,iti1),Ub2der(1,i-2),CUgb2der(1,i-2))
3018         call matmat2(EUg(1,1,i-2),CC(1,1,iti1),EUgC(1,1,i-2))
3019         call matmat2(EUgder(1,1,i-2),CC(1,1,iti1),EUgCder(1,1,i-2))
3020         call matmat2(EUg(1,1,i-2),DD(1,1,iti1),EUgD(1,1,i-2))
3021         call matmat2(EUgder(1,1,i-2),DD(1,1,iti1),EUgDder(1,1,i-2))
3022         endif
3023       enddo
3024 C Matrices dependent on two consecutive virtual-bond dihedrals.
3025 C The order of matrices is from left to right.
3026       if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
3027      &then
3028 c      do i=max0(ivec_start,2),ivec_end
3029       do i=2,nres-1
3030         call matmat2(DtUg2(1,1,i-1),EUg(1,1,i),DtUg2EUg(1,1,i))
3031         call matmat2(DtUg2der(1,1,i-1),EUg(1,1,i),DtUg2EUgder(1,1,1,i))
3032         call matmat2(DtUg2(1,1,i-1),EUgder(1,1,i),DtUg2EUgder(1,1,2,i))
3033         call transpose2(DtUg2(1,1,i-1),auxmat(1,1))
3034         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUg(1,1,i))
3035         call matmat2(auxmat(1,1),EUgder(1,1,i),Ug2DtEUgder(1,1,2,i))
3036         call transpose2(DtUg2der(1,1,i-1),auxmat(1,1))
3037         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUgder(1,1,1,i))
3038       enddo
3039       endif
3040 #if defined(MPI) && defined(PARMAT)
3041 #ifdef DEBUG
3042 c      if (fg_rank.eq.0) then
3043         write (iout,*) "Arrays UG and UGDER before GATHER"
3044         do i=1,nres-1
3045           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3046      &     ((ug(l,k,i),l=1,2),k=1,2),
3047      &     ((ugder(l,k,i),l=1,2),k=1,2)
3048         enddo
3049         write (iout,*) "Arrays UG2 and UG2DER"
3050         do i=1,nres-1
3051           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3052      &     ((ug2(l,k,i),l=1,2),k=1,2),
3053      &     ((ug2der(l,k,i),l=1,2),k=1,2)
3054         enddo
3055         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
3056         do i=1,nres-1
3057           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3058      &     (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
3059      &     (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
3060         enddo
3061         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
3062         do i=1,nres-1
3063           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3064      &     costab(i),sintab(i),costab2(i),sintab2(i)
3065         enddo
3066         write (iout,*) "Array MUDER"
3067         do i=1,nres-1
3068           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
3069         enddo
3070 c      endif
3071 #endif
3072       if (nfgtasks.gt.1) then
3073         time00=MPI_Wtime()
3074 c        write(iout,*)"Processor",fg_rank,kolor," ivec_start",ivec_start,
3075 c     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks-1),
3076 c     &   " ivec_count",(ivec_count(i),i=0,nfgtasks-1)
3077 #ifdef MATGATHER
3078         call MPI_Allgatherv(Ub2(1,ivec_start),ivec_count(fg_rank1),
3079      &   MPI_MU,Ub2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3080      &   FG_COMM1,IERR)
3081         call MPI_Allgatherv(Ub2der(1,ivec_start),ivec_count(fg_rank1),
3082      &   MPI_MU,Ub2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3083      &   FG_COMM1,IERR)
3084         call MPI_Allgatherv(mu(1,ivec_start),ivec_count(fg_rank1),
3085      &   MPI_MU,mu(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3086      &   FG_COMM1,IERR)
3087         call MPI_Allgatherv(muder(1,ivec_start),ivec_count(fg_rank1),
3088      &   MPI_MU,muder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3089      &   FG_COMM1,IERR)
3090         call MPI_Allgatherv(Eug(1,1,ivec_start),ivec_count(fg_rank1),
3091      &   MPI_MAT1,Eug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3092      &   FG_COMM1,IERR)
3093         call MPI_Allgatherv(Eugder(1,1,ivec_start),ivec_count(fg_rank1),
3094      &   MPI_MAT1,Eugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3095      &   FG_COMM1,IERR)
3096         call MPI_Allgatherv(costab(ivec_start),ivec_count(fg_rank1),
3097      &   MPI_DOUBLE_PRECISION,costab(1),ivec_count(0),ivec_displ(0),
3098      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3099         call MPI_Allgatherv(sintab(ivec_start),ivec_count(fg_rank1),
3100      &   MPI_DOUBLE_PRECISION,sintab(1),ivec_count(0),ivec_displ(0),
3101      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3102         call MPI_Allgatherv(costab2(ivec_start),ivec_count(fg_rank1),
3103      &   MPI_DOUBLE_PRECISION,costab2(1),ivec_count(0),ivec_displ(0),
3104      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3105         call MPI_Allgatherv(sintab2(ivec_start),ivec_count(fg_rank1),
3106      &   MPI_DOUBLE_PRECISION,sintab2(1),ivec_count(0),ivec_displ(0),
3107      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3108         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
3109      &  then
3110         call MPI_Allgatherv(Ctobr(1,ivec_start),ivec_count(fg_rank1),
3111      &   MPI_MU,Ctobr(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3112      &   FG_COMM1,IERR)
3113         call MPI_Allgatherv(Ctobrder(1,ivec_start),ivec_count(fg_rank1),
3114      &   MPI_MU,Ctobrder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3115      &   FG_COMM1,IERR)
3116         call MPI_Allgatherv(Dtobr2(1,ivec_start),ivec_count(fg_rank1),
3117      &   MPI_MU,Dtobr2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3118      &   FG_COMM1,IERR)
3119        call MPI_Allgatherv(Dtobr2der(1,ivec_start),ivec_count(fg_rank1),
3120      &   MPI_MU,Dtobr2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3121      &   FG_COMM1,IERR)
3122         call MPI_Allgatherv(Ug2Db1t(1,ivec_start),ivec_count(fg_rank1),
3123      &   MPI_MU,Ug2Db1t(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3124      &   FG_COMM1,IERR)
3125         call MPI_Allgatherv(Ug2Db1tder(1,ivec_start),
3126      &   ivec_count(fg_rank1),
3127      &   MPI_MU,Ug2Db1tder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3128      &   FG_COMM1,IERR)
3129         call MPI_Allgatherv(CUgb2(1,ivec_start),ivec_count(fg_rank1),
3130      &   MPI_MU,CUgb2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3131      &   FG_COMM1,IERR)
3132         call MPI_Allgatherv(CUgb2der(1,ivec_start),ivec_count(fg_rank1),
3133      &   MPI_MU,CUgb2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3134      &   FG_COMM1,IERR)
3135         call MPI_Allgatherv(Cug(1,1,ivec_start),ivec_count(fg_rank1),
3136      &   MPI_MAT1,Cug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3137      &   FG_COMM1,IERR)
3138         call MPI_Allgatherv(Cugder(1,1,ivec_start),ivec_count(fg_rank1),
3139      &   MPI_MAT1,Cugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3140      &   FG_COMM1,IERR)
3141         call MPI_Allgatherv(Dug(1,1,ivec_start),ivec_count(fg_rank1),
3142      &   MPI_MAT1,Dug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3143      &   FG_COMM1,IERR)
3144         call MPI_Allgatherv(Dugder(1,1,ivec_start),ivec_count(fg_rank1),
3145      &   MPI_MAT1,Dugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3146      &   FG_COMM1,IERR)
3147         call MPI_Allgatherv(Dtug2(1,1,ivec_start),ivec_count(fg_rank1),
3148      &   MPI_MAT1,Dtug2(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3149      &   FG_COMM1,IERR)
3150         call MPI_Allgatherv(Dtug2der(1,1,ivec_start),
3151      &   ivec_count(fg_rank1),
3152      &   MPI_MAT1,Dtug2der(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3153      &   FG_COMM1,IERR)
3154         call MPI_Allgatherv(EugC(1,1,ivec_start),ivec_count(fg_rank1),
3155      &   MPI_MAT1,EugC(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3156      &   FG_COMM1,IERR)
3157        call MPI_Allgatherv(EugCder(1,1,ivec_start),ivec_count(fg_rank1),
3158      &   MPI_MAT1,EugCder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3159      &   FG_COMM1,IERR)
3160         call MPI_Allgatherv(EugD(1,1,ivec_start),ivec_count(fg_rank1),
3161      &   MPI_MAT1,EugD(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3162      &   FG_COMM1,IERR)
3163        call MPI_Allgatherv(EugDder(1,1,ivec_start),ivec_count(fg_rank1),
3164      &   MPI_MAT1,EugDder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3165      &   FG_COMM1,IERR)
3166         call MPI_Allgatherv(DtUg2EUg(1,1,ivec_start),
3167      &   ivec_count(fg_rank1),
3168      &   MPI_MAT1,DtUg2EUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3169      &   FG_COMM1,IERR)
3170         call MPI_Allgatherv(Ug2DtEUg(1,1,ivec_start),
3171      &   ivec_count(fg_rank1),
3172      &   MPI_MAT1,Ug2DtEUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3173      &   FG_COMM1,IERR)
3174         call MPI_Allgatherv(DtUg2EUgder(1,1,1,ivec_start),
3175      &   ivec_count(fg_rank1),
3176      &   MPI_MAT2,DtUg2EUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
3177      &   MPI_MAT2,FG_COMM1,IERR)
3178         call MPI_Allgatherv(Ug2DtEUgder(1,1,1,ivec_start),
3179      &   ivec_count(fg_rank1),
3180      &   MPI_MAT2,Ug2DtEUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
3181      &   MPI_MAT2,FG_COMM1,IERR)
3182         endif
3183 #else
3184 c Passes matrix info through the ring
3185       isend=fg_rank1
3186       irecv=fg_rank1-1
3187       if (irecv.lt.0) irecv=nfgtasks1-1
3188       iprev=irecv
3189       inext=fg_rank1+1
3190       if (inext.ge.nfgtasks1) inext=0
3191       do i=1,nfgtasks1-1
3192 c        write (iout,*) "isend",isend," irecv",irecv
3193 c        call flush(iout)
3194         lensend=lentyp(isend)
3195         lenrecv=lentyp(irecv)
3196 c        write (iout,*) "lensend",lensend," lenrecv",lenrecv
3197 c        call MPI_SENDRECV(ug(1,1,ivec_displ(isend)+1),1,
3198 c     &   MPI_ROTAT1(lensend),inext,2200+isend,
3199 c     &   ug(1,1,ivec_displ(irecv)+1),1,MPI_ROTAT1(lenrecv),
3200 c     &   iprev,2200+irecv,FG_COMM,status,IERR)
3201 c        write (iout,*) "Gather ROTAT1"
3202 c        call flush(iout)
3203 c        call MPI_SENDRECV(obrot(1,ivec_displ(isend)+1),1,
3204 c     &   MPI_ROTAT2(lensend),inext,3300+isend,
3205 c     &   obrot(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
3206 c     &   iprev,3300+irecv,FG_COMM,status,IERR)
3207 c        write (iout,*) "Gather ROTAT2"
3208 c        call flush(iout)
3209         call MPI_SENDRECV(costab(ivec_displ(isend)+1),1,
3210      &   MPI_ROTAT_OLD(lensend),inext,4400+isend,
3211      &   costab(ivec_displ(irecv)+1),1,MPI_ROTAT_OLD(lenrecv),
3212      &   iprev,4400+irecv,FG_COMM,status,IERR)
3213 c        write (iout,*) "Gather ROTAT_OLD"
3214 c        call flush(iout)
3215         call MPI_SENDRECV(mu(1,ivec_displ(isend)+1),1,
3216      &   MPI_PRECOMP11(lensend),inext,5500+isend,
3217      &   mu(1,ivec_displ(irecv)+1),1,MPI_PRECOMP11(lenrecv),
3218      &   iprev,5500+irecv,FG_COMM,status,IERR)
3219 c        write (iout,*) "Gather PRECOMP11"
3220 c        call flush(iout)
3221         call MPI_SENDRECV(Eug(1,1,ivec_displ(isend)+1),1,
3222      &   MPI_PRECOMP12(lensend),inext,6600+isend,
3223      &   Eug(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP12(lenrecv),
3224      &   iprev,6600+irecv,FG_COMM,status,IERR)
3225 c        write (iout,*) "Gather PRECOMP12"
3226 c        call flush(iout)
3227         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
3228      &  then
3229         call MPI_SENDRECV(ug2db1t(1,ivec_displ(isend)+1),1,
3230      &   MPI_ROTAT2(lensend),inext,7700+isend,
3231      &   ug2db1t(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
3232      &   iprev,7700+irecv,FG_COMM,status,IERR)
3233 c        write (iout,*) "Gather PRECOMP21"
3234 c        call flush(iout)
3235         call MPI_SENDRECV(EUgC(1,1,ivec_displ(isend)+1),1,
3236      &   MPI_PRECOMP22(lensend),inext,8800+isend,
3237      &   EUgC(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP22(lenrecv),
3238      &   iprev,8800+irecv,FG_COMM,status,IERR)
3239 c        write (iout,*) "Gather PRECOMP22"
3240 c        call flush(iout)
3241         call MPI_SENDRECV(Ug2DtEUgder(1,1,1,ivec_displ(isend)+1),1,
3242      &   MPI_PRECOMP23(lensend),inext,9900+isend,
3243      &   Ug2DtEUgder(1,1,1,ivec_displ(irecv)+1),1,
3244      &   MPI_PRECOMP23(lenrecv),
3245      &   iprev,9900+irecv,FG_COMM,status,IERR)
3246 c        write (iout,*) "Gather PRECOMP23"
3247 c        call flush(iout)
3248         endif
3249         isend=irecv
3250         irecv=irecv-1
3251         if (irecv.lt.0) irecv=nfgtasks1-1
3252       enddo
3253 #endif
3254         time_gather=time_gather+MPI_Wtime()-time00
3255       endif
3256 #ifdef DEBUG
3257 c      if (fg_rank.eq.0) then
3258         write (iout,*) "Arrays UG and UGDER"
3259         do i=1,nres-1
3260           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3261      &     ((ug(l,k,i),l=1,2),k=1,2),
3262      &     ((ugder(l,k,i),l=1,2),k=1,2)
3263         enddo
3264         write (iout,*) "Arrays UG2 and UG2DER"
3265         do i=1,nres-1
3266           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3267      &     ((ug2(l,k,i),l=1,2),k=1,2),
3268      &     ((ug2der(l,k,i),l=1,2),k=1,2)
3269         enddo
3270         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
3271         do i=1,nres-1
3272           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3273      &     (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
3274      &     (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
3275         enddo
3276         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
3277         do i=1,nres-1
3278           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3279      &     costab(i),sintab(i),costab2(i),sintab2(i)
3280         enddo
3281         write (iout,*) "Array MUDER"
3282         do i=1,nres-1
3283           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
3284         enddo
3285 c      endif
3286 #endif
3287 #endif
3288 cd      do i=1,nres
3289 cd        iti = itortyp(itype(i))
3290 cd        write (iout,*) i
3291 cd        do j=1,2
3292 cd        write (iout,'(2f10.5,5x,2f10.5,5x,2f10.5)')
3293 cd     &  (EE(j,k,iti),k=1,2),(Ug(j,k,i),k=1,2),(EUg(j,k,i),k=1,2)
3294 cd        enddo
3295 cd      enddo
3296       return
3297       end
3298 C--------------------------------------------------------------------------
3299       subroutine eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
3300 C
3301 C This subroutine calculates the average interaction energy and its gradient
3302 C in the virtual-bond vectors between non-adjacent peptide groups, based on
3303 C the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
3304 C The potential depends both on the distance of peptide-group centers and on
3305 C the orientation of the CA-CA virtual bonds.
3306 C
3307       implicit real*8 (a-h,o-z)
3308 #ifdef MPI
3309       include 'mpif.h'
3310 #endif
3311       include 'DIMENSIONS'
3312       include 'COMMON.CONTROL'
3313       include 'COMMON.SETUP'
3314       include 'COMMON.IOUNITS'
3315       include 'COMMON.GEO'
3316       include 'COMMON.VAR'
3317       include 'COMMON.LOCAL'
3318       include 'COMMON.CHAIN'
3319       include 'COMMON.DERIV'
3320       include 'COMMON.INTERACT'
3321       include 'COMMON.CONTACTS'
3322       include 'COMMON.TORSION'
3323       include 'COMMON.VECTORS'
3324       include 'COMMON.FFIELD'
3325       include 'COMMON.TIME1'
3326       include 'COMMON.SPLITELE'
3327       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
3328      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
3329       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
3330      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4),gmuij(4)
3331       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3332      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3333      &    num_conti,j1,j2
3334 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
3335 #ifdef MOMENT
3336       double precision scal_el /1.0d0/
3337 #else
3338       double precision scal_el /0.5d0/
3339 #endif
3340 C 12/13/98
3341 C 13-go grudnia roku pamietnego...
3342       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
3343      &                   0.0d0,1.0d0,0.0d0,
3344      &                   0.0d0,0.0d0,1.0d0/
3345 cd      write(iout,*) 'In EELEC'
3346 cd      do i=1,nloctyp
3347 cd        write(iout,*) 'Type',i
3348 cd        write(iout,*) 'B1',B1(:,i)
3349 cd        write(iout,*) 'B2',B2(:,i)
3350 cd        write(iout,*) 'CC',CC(:,:,i)
3351 cd        write(iout,*) 'DD',DD(:,:,i)
3352 cd        write(iout,*) 'EE',EE(:,:,i)
3353 cd      enddo
3354 cd      call check_vecgrad
3355 cd      stop
3356       if (icheckgrad.eq.1) then
3357         do i=1,nres-1
3358           fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
3359           do k=1,3
3360             dc_norm(k,i)=dc(k,i)*fac
3361           enddo
3362 c          write (iout,*) 'i',i,' fac',fac
3363         enddo
3364       endif
3365       if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
3366      &    .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or.
3367      &    wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
3368 c        call vec_and_deriv
3369 #ifdef TIMING
3370         time01=MPI_Wtime()
3371 #endif
3372         call set_matrices
3373 #ifdef TIMING
3374         time_mat=time_mat+MPI_Wtime()-time01
3375 #endif
3376       endif
3377 cd      do i=1,nres-1
3378 cd        write (iout,*) 'i=',i
3379 cd        do k=1,3
3380 cd        write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
3381 cd        enddo
3382 cd        do k=1,3
3383 cd          write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
3384 cd     &     uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
3385 cd        enddo
3386 cd      enddo
3387       t_eelecij=0.0d0
3388       ees=0.0D0
3389       evdw1=0.0D0
3390       eel_loc=0.0d0
3391       eello_turn3=0.0d0
3392       eello_turn4=0.0d0
3393       ind=0
3394       do i=1,nres
3395         num_cont_hb(i)=0
3396       enddo
3397 cd      print '(a)','Enter EELEC'
3398 cd      write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
3399       do i=1,nres
3400         gel_loc_loc(i)=0.0d0
3401         gcorr_loc(i)=0.0d0
3402       enddo
3403 c
3404 c
3405 c 9/27/08 AL Split the interaction loop to ensure load balancing of turn terms
3406 C
3407 C Loop over i,i+2 and i,i+3 pairs of the peptide groups
3408 C
3409 C 14/01/2014 TURN3,TUNR4 does no go under periodic boundry condition
3410       do i=iturn3_start,iturn3_end
3411         if (i.le.1) cycle
3412 C        write(iout,*) "tu jest i",i
3413         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
3414 C changes suggested by Ana to avoid out of bounds
3415      & .or.((i+4).gt.nres)
3416      & .or.((i-1).le.0)
3417 C end of changes by Ana
3418      &  .or. itype(i+2).eq.ntyp1
3419      &  .or. itype(i+3).eq.ntyp1) cycle
3420         if(i.gt.1)then
3421           if(itype(i-1).eq.ntyp1)cycle
3422         end if
3423         if(i.LT.nres-3)then
3424           if (itype(i+4).eq.ntyp1) cycle
3425         end if
3426         dxi=dc(1,i)
3427         dyi=dc(2,i)
3428         dzi=dc(3,i)
3429         dx_normi=dc_norm(1,i)
3430         dy_normi=dc_norm(2,i)
3431         dz_normi=dc_norm(3,i)
3432         xmedi=c(1,i)+0.5d0*dxi
3433         ymedi=c(2,i)+0.5d0*dyi
3434         zmedi=c(3,i)+0.5d0*dzi
3435           xmedi=mod(xmedi,boxxsize)
3436           if (xmedi.lt.0) xmedi=xmedi+boxxsize
3437           ymedi=mod(ymedi,boxysize)
3438           if (ymedi.lt.0) ymedi=ymedi+boxysize
3439           zmedi=mod(zmedi,boxzsize)
3440           if (zmedi.lt.0) zmedi=zmedi+boxzsize
3441         num_conti=0
3442         call eelecij(i,i+2,ees,evdw1,eel_loc)
3443         if (wturn3.gt.0.0d0) call eturn3(i,eello_turn3)
3444         num_cont_hb(i)=num_conti
3445       enddo
3446       do i=iturn4_start,iturn4_end
3447         if (i.le.1) cycle
3448         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
3449 C changes suggested by Ana to avoid out of bounds
3450      & .or.((i+5).gt.nres)
3451      & .or.((i-1).le.0)
3452 C end of changes suggested by Ana
3453      &    .or. itype(i+3).eq.ntyp1
3454      &    .or. itype(i+4).eq.ntyp1
3455      &    .or. itype(i+5).eq.ntyp1
3456      &    .or. itype(i).eq.ntyp1
3457      &    .or. itype(i-1).eq.ntyp1
3458      &                             ) cycle
3459         dxi=dc(1,i)
3460         dyi=dc(2,i)
3461         dzi=dc(3,i)
3462         dx_normi=dc_norm(1,i)
3463         dy_normi=dc_norm(2,i)
3464         dz_normi=dc_norm(3,i)
3465         xmedi=c(1,i)+0.5d0*dxi
3466         ymedi=c(2,i)+0.5d0*dyi
3467         zmedi=c(3,i)+0.5d0*dzi
3468 C Return atom into box, boxxsize is size of box in x dimension
3469 c  194   continue
3470 c        if (xmedi.gt.((0.5d0)*boxxsize)) xmedi=xmedi-boxxsize
3471 c        if (xmedi.lt.((-0.5d0)*boxxsize)) xmedi=xmedi+boxxsize
3472 C Condition for being inside the proper box
3473 c        if ((xmedi.gt.((0.5d0)*boxxsize)).or.
3474 c     &       (xmedi.lt.((-0.5d0)*boxxsize))) then
3475 c        go to 194
3476 c        endif
3477 c  195   continue
3478 c        if (ymedi.gt.((0.5d0)*boxysize)) ymedi=ymedi-boxysize
3479 c        if (ymedi.lt.((-0.5d0)*boxysize)) ymedi=ymedi+boxysize
3480 C Condition for being inside the proper box
3481 c        if ((ymedi.gt.((0.5d0)*boxysize)).or.
3482 c     &       (ymedi.lt.((-0.5d0)*boxysize))) then
3483 c        go to 195
3484 c        endif
3485 c  196   continue
3486 c        if (zmedi.gt.((0.5d0)*boxzsize)) zmedi=zmedi-boxzsize
3487 c        if (zmedi.lt.((-0.5d0)*boxzsize)) zmedi=zmedi+boxzsize
3488 C Condition for being inside the proper box
3489 c        if ((zmedi.gt.((0.5d0)*boxzsize)).or.
3490 c     &       (zmedi.lt.((-0.5d0)*boxzsize))) then
3491 c        go to 196
3492 c        endif
3493           xmedi=mod(xmedi,boxxsize)
3494           if (xmedi.lt.0) xmedi=xmedi+boxxsize
3495           ymedi=mod(ymedi,boxysize)
3496           if (ymedi.lt.0) ymedi=ymedi+boxysize
3497           zmedi=mod(zmedi,boxzsize)
3498           if (zmedi.lt.0) zmedi=zmedi+boxzsize
3499
3500         num_conti=num_cont_hb(i)
3501 c        write(iout,*) "JESTEM W PETLI"
3502         call eelecij(i,i+3,ees,evdw1,eel_loc)
3503         if (wturn4.gt.0.0d0 .and. itype(i+2).ne.ntyp1)
3504      &   call eturn4(i,eello_turn4)
3505         num_cont_hb(i)=num_conti
3506       enddo   ! i
3507 C Loop over all neighbouring boxes
3508 C      do xshift=-1,1
3509 C      do yshift=-1,1
3510 C      do zshift=-1,1
3511 c
3512 c Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
3513 c
3514 CTU KURWA
3515       do i=iatel_s,iatel_e
3516 C        do i=75,75
3517         if (i.le.1) cycle
3518         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
3519 C changes suggested by Ana to avoid out of bounds
3520      & .or.((i+2).gt.nres)
3521      & .or.((i-1).le.0)
3522 C end of changes by Ana
3523      &  .or. itype(i+2).eq.ntyp1
3524      &  .or. itype(i-1).eq.ntyp1
3525      &                ) cycle
3526         dxi=dc(1,i)
3527         dyi=dc(2,i)
3528         dzi=dc(3,i)
3529         dx_normi=dc_norm(1,i)
3530         dy_normi=dc_norm(2,i)
3531         dz_normi=dc_norm(3,i)
3532         xmedi=c(1,i)+0.5d0*dxi
3533         ymedi=c(2,i)+0.5d0*dyi
3534         zmedi=c(3,i)+0.5d0*dzi
3535           xmedi=mod(xmedi,boxxsize)
3536           if (xmedi.lt.0) xmedi=xmedi+boxxsize
3537           ymedi=mod(ymedi,boxysize)
3538           if (ymedi.lt.0) ymedi=ymedi+boxysize
3539           zmedi=mod(zmedi,boxzsize)
3540           if (zmedi.lt.0) zmedi=zmedi+boxzsize
3541 C          xmedi=xmedi+xshift*boxxsize
3542 C          ymedi=ymedi+yshift*boxysize
3543 C          zmedi=zmedi+zshift*boxzsize
3544
3545 C Return tom into box, boxxsize is size of box in x dimension
3546 c  164   continue
3547 c        if (xmedi.gt.((xshift+0.5d0)*boxxsize)) xmedi=xmedi-boxxsize
3548 c        if (xmedi.lt.((xshift-0.5d0)*boxxsize)) xmedi=xmedi+boxxsize
3549 C Condition for being inside the proper box
3550 c        if ((xmedi.gt.((xshift+0.5d0)*boxxsize)).or.
3551 c     &       (xmedi.lt.((xshift-0.5d0)*boxxsize))) then
3552 c        go to 164
3553 c        endif
3554 c  165   continue
3555 c        if (ymedi.gt.((yshift+0.5d0)*boxysize)) ymedi=ymedi-boxysize
3556 c        if (ymedi.lt.((yshift-0.5d0)*boxysize)) ymedi=ymedi+boxysize
3557 C Condition for being inside the proper box
3558 c        if ((ymedi.gt.((yshift+0.5d0)*boxysize)).or.
3559 c     &       (ymedi.lt.((yshift-0.5d0)*boxysize))) then
3560 c        go to 165
3561 c        endif
3562 c  166   continue
3563 c        if (zmedi.gt.((zshift+0.5d0)*boxzsize)) zmedi=zmedi-boxzsize
3564 c        if (zmedi.lt.((zshift-0.5d0)*boxzsize)) zmedi=zmedi+boxzsize
3565 cC Condition for being inside the proper box
3566 c        if ((zmedi.gt.((zshift+0.5d0)*boxzsize)).or.
3567 c     &       (zmedi.lt.((zshift-0.5d0)*boxzsize))) then
3568 c        go to 166
3569 c        endif
3570
3571 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
3572         num_conti=num_cont_hb(i)
3573 C I TU KURWA
3574         do j=ielstart(i),ielend(i)
3575 C          do j=16,17
3576 C          write (iout,*) i,j
3577          if (j.le.1) cycle
3578           if (itype(j).eq.ntyp1.or. itype(j+1).eq.ntyp1
3579 C changes suggested by Ana to avoid out of bounds
3580      & .or.((j+2).gt.nres)
3581      & .or.((j-1).le.0)
3582 C end of changes by Ana
3583      & .or.itype(j+2).eq.ntyp1
3584      & .or.itype(j-1).eq.ntyp1
3585      &) cycle
3586           call eelecij(i,j,ees,evdw1,eel_loc)
3587         enddo ! j
3588         num_cont_hb(i)=num_conti
3589       enddo   ! i
3590 C     enddo   ! zshift
3591 C      enddo   ! yshift
3592 C      enddo   ! xshift
3593
3594 c      write (iout,*) "Number of loop steps in EELEC:",ind
3595 cd      do i=1,nres
3596 cd        write (iout,'(i3,3f10.5,5x,3f10.5)')
3597 cd     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
3598 cd      enddo
3599 c 12/7/99 Adam eello_turn3 will be considered as a separate energy term
3600 ccc      eel_loc=eel_loc+eello_turn3
3601 cd      print *,"Processor",fg_rank," t_eelecij",t_eelecij
3602       return
3603       end
3604 C-------------------------------------------------------------------------------
3605       subroutine eelecij(i,j,ees,evdw1,eel_loc)
3606       implicit real*8 (a-h,o-z)
3607       include 'DIMENSIONS'
3608 #ifdef MPI
3609       include "mpif.h"
3610 #endif
3611       include 'COMMON.CONTROL'
3612       include 'COMMON.IOUNITS'
3613       include 'COMMON.GEO'
3614       include 'COMMON.VAR'
3615       include 'COMMON.LOCAL'
3616       include 'COMMON.CHAIN'
3617       include 'COMMON.DERIV'
3618       include 'COMMON.INTERACT'
3619       include 'COMMON.CONTACTS'
3620       include 'COMMON.TORSION'
3621       include 'COMMON.VECTORS'
3622       include 'COMMON.FFIELD'
3623       include 'COMMON.TIME1'
3624       include 'COMMON.SPLITELE'
3625       include 'COMMON.SHIELD'
3626       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
3627      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
3628       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
3629      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4),gmuij1(4),gmuji1(4),
3630      &    gmuij2(4),gmuji2(4)
3631       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3632      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3633      &    num_conti,j1,j2
3634 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
3635 #ifdef MOMENT
3636       double precision scal_el /1.0d0/
3637 #else
3638       double precision scal_el /0.5d0/
3639 #endif
3640 C 12/13/98
3641 C 13-go grudnia roku pamietnego...
3642       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
3643      &                   0.0d0,1.0d0,0.0d0,
3644      &                   0.0d0,0.0d0,1.0d0/
3645 c          time00=MPI_Wtime()
3646 cd      write (iout,*) "eelecij",i,j
3647 c          ind=ind+1
3648           iteli=itel(i)
3649           itelj=itel(j)
3650           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
3651           aaa=app(iteli,itelj)
3652           bbb=bpp(iteli,itelj)
3653           ael6i=ael6(iteli,itelj)
3654           ael3i=ael3(iteli,itelj)
3655           dxj=dc(1,j)
3656           dyj=dc(2,j)
3657           dzj=dc(3,j)
3658           dx_normj=dc_norm(1,j)
3659           dy_normj=dc_norm(2,j)
3660           dz_normj=dc_norm(3,j)
3661 C          xj=c(1,j)+0.5D0*dxj-xmedi
3662 C          yj=c(2,j)+0.5D0*dyj-ymedi
3663 C          zj=c(3,j)+0.5D0*dzj-zmedi
3664           xj=c(1,j)+0.5D0*dxj
3665           yj=c(2,j)+0.5D0*dyj
3666           zj=c(3,j)+0.5D0*dzj
3667           xj=mod(xj,boxxsize)
3668           if (xj.lt.0) xj=xj+boxxsize
3669           yj=mod(yj,boxysize)
3670           if (yj.lt.0) yj=yj+boxysize
3671           zj=mod(zj,boxzsize)
3672           if (zj.lt.0) zj=zj+boxzsize
3673           if ((zj.lt.0).or.(xj.lt.0).or.(yj.lt.0)) write (*,*) "CHUJ"
3674       dist_init=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
3675       xj_safe=xj
3676       yj_safe=yj
3677       zj_safe=zj
3678       isubchap=0
3679       do xshift=-1,1
3680       do yshift=-1,1
3681       do zshift=-1,1
3682           xj=xj_safe+xshift*boxxsize
3683           yj=yj_safe+yshift*boxysize
3684           zj=zj_safe+zshift*boxzsize
3685           dist_temp=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
3686           if(dist_temp.lt.dist_init) then
3687             dist_init=dist_temp
3688             xj_temp=xj
3689             yj_temp=yj
3690             zj_temp=zj
3691             isubchap=1
3692           endif
3693        enddo
3694        enddo
3695        enddo
3696        if (isubchap.eq.1) then
3697           xj=xj_temp-xmedi
3698           yj=yj_temp-ymedi
3699           zj=zj_temp-zmedi
3700        else
3701           xj=xj_safe-xmedi
3702           yj=yj_safe-ymedi
3703           zj=zj_safe-zmedi
3704        endif
3705 C        if ((i+3).lt.j) then !this condition keeps for turn3 and turn4 not subject to PBC
3706 c  174   continue
3707 c        if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
3708 c        if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
3709 C Condition for being inside the proper box
3710 c        if ((xj.gt.((0.5d0)*boxxsize)).or.
3711 c     &       (xj.lt.((-0.5d0)*boxxsize))) then
3712 c        go to 174
3713 c        endif
3714 c  175   continue
3715 c        if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
3716 c        if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
3717 C Condition for being inside the proper box
3718 c        if ((yj.gt.((0.5d0)*boxysize)).or.
3719 c     &       (yj.lt.((-0.5d0)*boxysize))) then
3720 c        go to 175
3721 c        endif
3722 c  176   continue
3723 c        if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
3724 c        if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
3725 C Condition for being inside the proper box
3726 c        if ((zj.gt.((0.5d0)*boxzsize)).or.
3727 c     &       (zj.lt.((-0.5d0)*boxzsize))) then
3728 c        go to 176
3729 c        endif
3730 C        endif !endPBC condintion
3731 C        xj=xj-xmedi
3732 C        yj=yj-ymedi
3733 C        zj=zj-zmedi
3734           rij=xj*xj+yj*yj+zj*zj
3735
3736             sss=sscale(sqrt(rij))
3737             sssgrad=sscagrad(sqrt(rij))
3738 c            if (sss.gt.0.0d0) then
3739           rrmij=1.0D0/rij
3740           rij=dsqrt(rij)
3741           rmij=1.0D0/rij
3742           r3ij=rrmij*rmij
3743           r6ij=r3ij*r3ij
3744           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
3745           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
3746           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
3747           fac=cosa-3.0D0*cosb*cosg
3748           ev1=aaa*r6ij*r6ij
3749 c 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
3750           if (j.eq.i+2) ev1=scal_el*ev1
3751           ev2=bbb*r6ij
3752           fac3=ael6i*r6ij
3753           fac4=ael3i*r3ij
3754           evdwij=(ev1+ev2)
3755           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
3756           el2=fac4*fac
3757 C MARYSIA
3758 C          eesij=(el1+el2)
3759 C 12/26/95 - for the evaluation of multi-body H-bonding interactions
3760           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
3761           if (shield_mode.gt.0) then
3762 C          fac_shield(i)=0.4
3763 C          fac_shield(j)=0.6
3764           el1=el1*fac_shield(i)**2*fac_shield(j)**2
3765           el2=el2*fac_shield(i)**2*fac_shield(j)**2
3766           eesij=(el1+el2)
3767           ees=ees+eesij
3768           else
3769           fac_shield(i)=1.0
3770           fac_shield(j)=1.0
3771           eesij=(el1+el2)
3772           ees=ees+eesij
3773           endif
3774           evdw1=evdw1+evdwij*sss
3775 cd          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
3776 cd     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
3777 cd     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
3778 cd     &      xmedi,ymedi,zmedi,xj,yj,zj
3779
3780           if (energy_dec) then
3781               write (iout,'(a6,2i5,0pf7.3,2i5,2e11.3)')
3782      &'evdw1',i,j,evdwij
3783      &,iteli,itelj,aaa,evdw1
3784               write (iout,'(a6,2i5,0pf7.3,2f8.3)') 'ees',i,j,eesij,
3785      &fac_shield(i),fac_shield(j)
3786           endif
3787
3788 C
3789 C Calculate contributions to the Cartesian gradient.
3790 C
3791 #ifdef SPLITELE
3792           facvdw=-6*rrmij*(ev1+evdwij)*sss
3793           facel=-3*rrmij*(el1+eesij)
3794           fac1=fac
3795           erij(1)=xj*rmij
3796           erij(2)=yj*rmij
3797           erij(3)=zj*rmij
3798
3799 *
3800 * Radial derivatives. First process both termini of the fragment (i,j)
3801 *
3802           ggg(1)=facel*xj
3803           ggg(2)=facel*yj
3804           ggg(3)=facel*zj
3805           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
3806      &  (shield_mode.gt.0)) then
3807 C          print *,i,j
3808           do ilist=1,ishield_list(i)
3809            iresshield=shield_list(ilist,i)
3810            do k=1,3
3811            rlocshield=grad_shield_side(k,ilist,i)*eesij/fac_shield(i)
3812      &      *2.0
3813            gshieldx(k,iresshield)=gshieldx(k,iresshield)+
3814      &              rlocshield
3815      & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)*2.0
3816             gshieldc(k,iresshield-1)=gshieldc(k,iresshield-1)+rlocshield
3817 C           gshieldc_loc(k,iresshield)=gshieldc_loc(k,iresshield)
3818 C     & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)
3819 C             if (iresshield.gt.i) then
3820 C               do ishi=i+1,iresshield-1
3821 C                gshieldc(k,ishi)=gshieldc(k,ishi)+rlocshield
3822 C     & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)
3823 C
3824 C              enddo
3825 C             else
3826 C               do ishi=iresshield,i
3827 C                gshieldc(k,ishi)=gshieldc(k,ishi)-rlocshield
3828 C     & -grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)
3829 C
3830 C               enddo
3831 C              endif
3832            enddo
3833           enddo
3834           do ilist=1,ishield_list(j)
3835            iresshield=shield_list(ilist,j)
3836            do k=1,3
3837            rlocshield=grad_shield_side(k,ilist,j)*eesij/fac_shield(j)
3838      &     *2.0
3839            gshieldx(k,iresshield)=gshieldx(k,iresshield)+
3840      &              rlocshield
3841      & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)*2.0
3842            gshieldc(k,iresshield-1)=gshieldc(k,iresshield-1)+rlocshield
3843
3844 C     & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
3845 C           gshieldc_loc(k,iresshield)=gshieldc_loc(k,iresshield)
3846 C     & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
3847 C             if (iresshield.gt.j) then
3848 C               do ishi=j+1,iresshield-1
3849 C                gshieldc(k,ishi)=gshieldc(k,ishi)+rlocshield
3850 C     & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
3851 C
3852 C               enddo
3853 C            else
3854 C               do ishi=iresshield,j
3855 C                gshieldc(k,ishi)=gshieldc(k,ishi)-rlocshield
3856 C     & -grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
3857 C               enddo
3858 C              endif
3859            enddo
3860           enddo
3861
3862           do k=1,3
3863             gshieldc(k,i)=gshieldc(k,i)+
3864      &              grad_shield(k,i)*eesij/fac_shield(i)*2.0
3865             gshieldc(k,j)=gshieldc(k,j)+
3866      &              grad_shield(k,j)*eesij/fac_shield(j)*2.0
3867             gshieldc(k,i-1)=gshieldc(k,i-1)+
3868      &              grad_shield(k,i)*eesij/fac_shield(i)*2.0
3869             gshieldc(k,j-1)=gshieldc(k,j-1)+
3870      &              grad_shield(k,j)*eesij/fac_shield(j)*2.0
3871
3872            enddo
3873            endif
3874 c          do k=1,3
3875 c            ghalf=0.5D0*ggg(k)
3876 c            gelc(k,i)=gelc(k,i)+ghalf
3877 c            gelc(k,j)=gelc(k,j)+ghalf
3878 c          enddo
3879 c 9/28/08 AL Gradient compotents will be summed only at the end
3880 C           print *,"before", gelc_long(1,i), gelc_long(1,j)
3881           do k=1,3
3882             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
3883 C     &                    +grad_shield(k,j)*eesij/fac_shield(j)
3884             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
3885 C     &                    +grad_shield(k,i)*eesij/fac_shield(i)
3886 C            gelc_long(k,i-1)=gelc_long(k,i-1)
3887 C     &                    +grad_shield(k,i)*eesij/fac_shield(i)
3888 C            gelc_long(k,j-1)=gelc_long(k,j-1)
3889 C     &                    +grad_shield(k,j)*eesij/fac_shield(j)
3890           enddo
3891 C           print *,"bafter", gelc_long(1,i), gelc_long(1,j)
3892
3893 *
3894 * Loop over residues i+1 thru j-1.
3895 *
3896 cgrad          do k=i+1,j-1
3897 cgrad            do l=1,3
3898 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3899 cgrad            enddo
3900 cgrad          enddo
3901           if (sss.gt.0.0) then
3902           ggg(1)=facvdw*xj+sssgrad*rmij*evdwij*xj
3903           ggg(2)=facvdw*yj+sssgrad*rmij*evdwij*yj
3904           ggg(3)=facvdw*zj+sssgrad*rmij*evdwij*zj
3905           else
3906           ggg(1)=0.0
3907           ggg(2)=0.0
3908           ggg(3)=0.0
3909           endif
3910 c          do k=1,3
3911 c            ghalf=0.5D0*ggg(k)
3912 c            gvdwpp(k,i)=gvdwpp(k,i)+ghalf
3913 c            gvdwpp(k,j)=gvdwpp(k,j)+ghalf
3914 c          enddo
3915 c 9/28/08 AL Gradient compotents will be summed only at the end
3916           do k=1,3
3917             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
3918             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
3919           enddo
3920 *
3921 * Loop over residues i+1 thru j-1.
3922 *
3923 cgrad          do k=i+1,j-1
3924 cgrad            do l=1,3
3925 cgrad              gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
3926 cgrad            enddo
3927 cgrad          enddo
3928 #else
3929 C MARYSIA
3930           facvdw=(ev1+evdwij)*sss
3931           facel=(el1+eesij)
3932           fac1=fac
3933           fac=-3*rrmij*(facvdw+facvdw+facel)
3934           erij(1)=xj*rmij
3935           erij(2)=yj*rmij
3936           erij(3)=zj*rmij
3937 *
3938 * Radial derivatives. First process both termini of the fragment (i,j)
3939 *
3940           ggg(1)=fac*xj
3941 C+eesij*grad_shield(1,i)+eesij*grad_shield(1,j)
3942           ggg(2)=fac*yj
3943 C+eesij*grad_shield(2,i)+eesij*grad_shield(2,j)
3944           ggg(3)=fac*zj
3945 C+eesij*grad_shield(3,i)+eesij*grad_shield(3,j)
3946 c          do k=1,3
3947 c            ghalf=0.5D0*ggg(k)
3948 c            gelc(k,i)=gelc(k,i)+ghalf
3949 c            gelc(k,j)=gelc(k,j)+ghalf
3950 c          enddo
3951 c 9/28/08 AL Gradient compotents will be summed only at the end
3952           do k=1,3
3953             gelc_long(k,j)=gelc(k,j)+ggg(k)
3954             gelc_long(k,i)=gelc(k,i)-ggg(k)
3955           enddo
3956 *
3957 * Loop over residues i+1 thru j-1.
3958 *
3959 cgrad          do k=i+1,j-1
3960 cgrad            do l=1,3
3961 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3962 cgrad            enddo
3963 cgrad          enddo
3964 c 9/28/08 AL Gradient compotents will be summed only at the end
3965           ggg(1)=facvdw*xj+sssgrad*rmij*evdwij*xj
3966           ggg(2)=facvdw*yj+sssgrad*rmij*evdwij*yj
3967           ggg(3)=facvdw*zj+sssgrad*rmij*evdwij*zj
3968           do k=1,3
3969             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
3970             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
3971           enddo
3972 #endif
3973 *
3974 * Angular part
3975 *
3976           ecosa=2.0D0*fac3*fac1+fac4
3977           fac4=-3.0D0*fac4
3978           fac3=-6.0D0*fac3
3979           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
3980           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
3981           do k=1,3
3982             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
3983             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
3984           enddo
3985 cd        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
3986 cd   &          (dcosg(k),k=1,3)
3987           do k=1,3
3988             ggg(k)=(ecosb*dcosb(k)+ecosg*dcosg(k))*
3989      &      fac_shield(i)**2*fac_shield(j)**2
3990           enddo
3991 c          do k=1,3
3992 c            ghalf=0.5D0*ggg(k)
3993 c            gelc(k,i)=gelc(k,i)+ghalf
3994 c     &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
3995 c     &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3996 c            gelc(k,j)=gelc(k,j)+ghalf
3997 c     &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
3998 c     &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3999 c          enddo
4000 cgrad          do k=i+1,j-1
4001 cgrad            do l=1,3
4002 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
4003 cgrad            enddo
4004 cgrad          enddo
4005 C                     print *,"before22", gelc_long(1,i), gelc_long(1,j)
4006           do k=1,3
4007             gelc(k,i)=gelc(k,i)
4008      &           +((ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
4009      &           + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1))
4010      &           *fac_shield(i)**2*fac_shield(j)**2
4011             gelc(k,j)=gelc(k,j)
4012      &           +((ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
4013      &           + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1))
4014      &           *fac_shield(i)**2*fac_shield(j)**2
4015             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
4016             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
4017           enddo
4018 C           print *,"before33", gelc_long(1,i), gelc_long(1,j)
4019
4020 C MARYSIA
4021 c          endif !sscale
4022           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
4023      &        .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0
4024      &        .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
4025 C
4026 C 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
4027 C   energy of a peptide unit is assumed in the form of a second-order
4028 C   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
4029 C   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
4030 C   are computed for EVERY pair of non-contiguous peptide groups.
4031 C
4032
4033           if (j.lt.nres-1) then
4034             j1=j+1
4035             j2=j-1
4036           else
4037             j1=j-1
4038             j2=j-2
4039           endif
4040           kkk=0
4041           lll=0
4042           do k=1,2
4043             do l=1,2
4044               kkk=kkk+1
4045               muij(kkk)=mu(k,i)*mu(l,j)
4046 c              write(iout,*) 'mumu=', mu(k,i),mu(l,j),i,j,k,l
4047 #ifdef NEWCORR
4048              gmuij1(kkk)=gtb1(k,i+1)*mu(l,j)
4049 c             write(iout,*) 'k=',k,i,gtb1(k,i+1),gtb1(k,i+1)*mu(l,j)
4050              gmuij2(kkk)=gUb2(k,i)*mu(l,j)
4051              gmuji1(kkk)=mu(k,i)*gtb1(l,j+1)
4052 c             write(iout,*) 'l=',l,j,gtb1(l,j+1),gtb1(l,j+1)*mu(k,i)
4053              gmuji2(kkk)=mu(k,i)*gUb2(l,j)
4054 #endif
4055             enddo
4056           enddo
4057 cd         write (iout,*) 'EELEC: i',i,' j',j
4058 cd          write (iout,*) 'j',j,' j1',j1,' j2',j2
4059 cd          write(iout,*) 'muij',muij
4060           ury=scalar(uy(1,i),erij)
4061           urz=scalar(uz(1,i),erij)
4062           vry=scalar(uy(1,j),erij)
4063           vrz=scalar(uz(1,j),erij)
4064           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
4065           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
4066           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
4067           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
4068           fac=dsqrt(-ael6i)*r3ij
4069           a22=a22*fac
4070           a23=a23*fac
4071           a32=a32*fac
4072           a33=a33*fac
4073 cd          write (iout,'(4i5,4f10.5)')
4074 cd     &     i,itortyp(itype(i)),j,itortyp(itype(j)),a22,a23,a32,a33
4075 cd          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
4076 cd          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') uy(:,i),uz(:,i),
4077 cd     &      uy(:,j),uz(:,j)
4078 cd          write (iout,'(4f10.5)')
4079 cd     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
4080 cd     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
4081 cd          write (iout,'(4f10.5)') ury,urz,vry,vrz
4082 cd           write (iout,'(9f10.5/)')
4083 cd     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
4084 C Derivatives of the elements of A in virtual-bond vectors
4085           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
4086           do k=1,3
4087             uryg(k,1)=scalar(erder(1,k),uy(1,i))
4088             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
4089             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
4090             urzg(k,1)=scalar(erder(1,k),uz(1,i))
4091             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
4092             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
4093             vryg(k,1)=scalar(erder(1,k),uy(1,j))
4094             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
4095             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
4096             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
4097             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
4098             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
4099           enddo
4100 C Compute radial contributions to the gradient
4101           facr=-3.0d0*rrmij
4102           a22der=a22*facr
4103           a23der=a23*facr
4104           a32der=a32*facr
4105           a33der=a33*facr
4106           agg(1,1)=a22der*xj
4107           agg(2,1)=a22der*yj
4108           agg(3,1)=a22der*zj
4109           agg(1,2)=a23der*xj
4110           agg(2,2)=a23der*yj
4111           agg(3,2)=a23der*zj
4112           agg(1,3)=a32der*xj
4113           agg(2,3)=a32der*yj
4114           agg(3,3)=a32der*zj
4115           agg(1,4)=a33der*xj
4116           agg(2,4)=a33der*yj
4117           agg(3,4)=a33der*zj
4118 C Add the contributions coming from er
4119           fac3=-3.0d0*fac
4120           do k=1,3
4121             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
4122             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
4123             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
4124             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
4125           enddo
4126           do k=1,3
4127 C Derivatives in DC(i)
4128 cgrad            ghalf1=0.5d0*agg(k,1)
4129 cgrad            ghalf2=0.5d0*agg(k,2)
4130 cgrad            ghalf3=0.5d0*agg(k,3)
4131 cgrad            ghalf4=0.5d0*agg(k,4)
4132             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j))
4133      &      -3.0d0*uryg(k,2)*vry)!+ghalf1
4134             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j))
4135      &      -3.0d0*uryg(k,2)*vrz)!+ghalf2
4136             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j))
4137      &      -3.0d0*urzg(k,2)*vry)!+ghalf3
4138             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j))
4139      &      -3.0d0*urzg(k,2)*vrz)!+ghalf4
4140 C Derivatives in DC(i+1)
4141             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j))
4142      &      -3.0d0*uryg(k,3)*vry)!+agg(k,1)
4143             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j))
4144      &      -3.0d0*uryg(k,3)*vrz)!+agg(k,2)
4145             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j))
4146      &      -3.0d0*urzg(k,3)*vry)!+agg(k,3)
4147             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j))
4148      &      -3.0d0*urzg(k,3)*vrz)!+agg(k,4)
4149 C Derivatives in DC(j)
4150             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i))
4151      &      -3.0d0*vryg(k,2)*ury)!+ghalf1
4152             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i))
4153      &      -3.0d0*vrzg(k,2)*ury)!+ghalf2
4154             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i))
4155      &      -3.0d0*vryg(k,2)*urz)!+ghalf3
4156             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i))
4157      &      -3.0d0*vrzg(k,2)*urz)!+ghalf4
4158 C Derivatives in DC(j+1) or DC(nres-1)
4159             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i))
4160      &      -3.0d0*vryg(k,3)*ury)
4161             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i))
4162      &      -3.0d0*vrzg(k,3)*ury)
4163             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i))
4164      &      -3.0d0*vryg(k,3)*urz)
4165             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i))
4166      &      -3.0d0*vrzg(k,3)*urz)
4167 cgrad            if (j.eq.nres-1 .and. i.lt.j-2) then
4168 cgrad              do l=1,4
4169 cgrad                aggj1(k,l)=aggj1(k,l)+agg(k,l)
4170 cgrad              enddo
4171 cgrad            endif
4172           enddo
4173           acipa(1,1)=a22
4174           acipa(1,2)=a23
4175           acipa(2,1)=a32
4176           acipa(2,2)=a33
4177           a22=-a22
4178           a23=-a23
4179           do l=1,2
4180             do k=1,3
4181               agg(k,l)=-agg(k,l)
4182               aggi(k,l)=-aggi(k,l)
4183               aggi1(k,l)=-aggi1(k,l)
4184               aggj(k,l)=-aggj(k,l)
4185               aggj1(k,l)=-aggj1(k,l)
4186             enddo
4187           enddo
4188           if (j.lt.nres-1) then
4189             a22=-a22
4190             a32=-a32
4191             do l=1,3,2
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           else
4201             a22=-a22
4202             a23=-a23
4203             a32=-a32
4204             a33=-a33
4205             do l=1,4
4206               do k=1,3
4207                 agg(k,l)=-agg(k,l)
4208                 aggi(k,l)=-aggi(k,l)
4209                 aggi1(k,l)=-aggi1(k,l)
4210                 aggj(k,l)=-aggj(k,l)
4211                 aggj1(k,l)=-aggj1(k,l)
4212               enddo
4213             enddo
4214           endif
4215           ENDIF ! WCORR
4216           IF (wel_loc.gt.0.0d0) THEN
4217 C Contribution to the local-electrostatic energy coming from the i-j pair
4218           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3)
4219      &     +a33*muij(4)
4220           if (shield_mode.eq.0) then
4221            fac_shield(i)=1.0
4222            fac_shield(j)=1.0
4223 C          else
4224 C           fac_shield(i)=0.4
4225 C           fac_shield(j)=0.6
4226           endif
4227           eel_loc_ij=eel_loc_ij
4228      &    *fac_shield(i)*fac_shield(j)
4229 C Now derivative over eel_loc
4230           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
4231      &  (shield_mode.gt.0)) then
4232 C          print *,i,j
4233
4234           do ilist=1,ishield_list(i)
4235            iresshield=shield_list(ilist,i)
4236            do k=1,3
4237            rlocshield=grad_shield_side(k,ilist,i)*eel_loc_ij
4238      &                                          /fac_shield(i)
4239 C     &      *2.0
4240            gshieldx_ll(k,iresshield)=gshieldx_ll(k,iresshield)+
4241      &              rlocshield
4242      & +grad_shield_loc(k,ilist,i)*eel_loc_ij/fac_shield(i)
4243             gshieldc_ll(k,iresshield-1)=gshieldc_ll(k,iresshield-1)
4244      &      +rlocshield
4245            enddo
4246           enddo
4247           do ilist=1,ishield_list(j)
4248            iresshield=shield_list(ilist,j)
4249            do k=1,3
4250            rlocshield=grad_shield_side(k,ilist,j)*eel_loc_ij
4251      &                                       /fac_shield(j)
4252 C     &     *2.0
4253            gshieldx_ll(k,iresshield)=gshieldx_ll(k,iresshield)+
4254      &              rlocshield
4255      & +grad_shield_loc(k,ilist,j)*eel_loc_ij/fac_shield(j)
4256            gshieldc_ll(k,iresshield-1)=gshieldc_ll(k,iresshield-1)
4257      &             +rlocshield
4258
4259            enddo
4260           enddo
4261
4262           do k=1,3
4263             gshieldc_ll(k,i)=gshieldc_ll(k,i)+
4264      &              grad_shield(k,i)*eel_loc_ij/fac_shield(i)
4265             gshieldc_ll(k,j)=gshieldc_ll(k,j)+
4266      &              grad_shield(k,j)*eel_loc_ij/fac_shield(j)
4267             gshieldc_ll(k,i-1)=gshieldc_ll(k,i-1)+
4268      &              grad_shield(k,i)*eel_loc_ij/fac_shield(i)
4269             gshieldc_ll(k,j-1)=gshieldc_ll(k,j-1)+
4270      &              grad_shield(k,j)*eel_loc_ij/fac_shield(j)
4271            enddo
4272            endif
4273
4274
4275 c          write (iout,*) 'i',i,' j',j,itype(i),itype(j),
4276 c     &                     ' eel_loc_ij',eel_loc_ij
4277 C          write(iout,*) 'muije=',i,j,muij(1),muij(2),muij(3),muij(4)
4278 C Calculate patrial derivative for theta angle
4279 #ifdef NEWCORR
4280          geel_loc_ij=(a22*gmuij1(1)
4281      &     +a23*gmuij1(2)
4282      &     +a32*gmuij1(3)
4283      &     +a33*gmuij1(4))
4284      &    *fac_shield(i)*fac_shield(j)
4285 c         write(iout,*) "derivative over thatai"
4286 c         write(iout,*) a22*gmuij1(1), a23*gmuij1(2) ,a32*gmuij1(3),
4287 c     &   a33*gmuij1(4)
4288          gloc(nphi+i,icg)=gloc(nphi+i,icg)+
4289      &      geel_loc_ij*wel_loc
4290 c         write(iout,*) "derivative over thatai-1"
4291 c         write(iout,*) a22*gmuij2(1), a23*gmuij2(2) ,a32*gmuij2(3),
4292 c     &   a33*gmuij2(4)
4293          geel_loc_ij=
4294      &     a22*gmuij2(1)
4295      &     +a23*gmuij2(2)
4296      &     +a32*gmuij2(3)
4297      &     +a33*gmuij2(4)
4298          gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
4299      &      geel_loc_ij*wel_loc
4300      &    *fac_shield(i)*fac_shield(j)
4301
4302 c  Derivative over j residue
4303          geel_loc_ji=a22*gmuji1(1)
4304      &     +a23*gmuji1(2)
4305      &     +a32*gmuji1(3)
4306      &     +a33*gmuji1(4)
4307 c         write(iout,*) "derivative over thataj"
4308 c         write(iout,*) a22*gmuji1(1), a23*gmuji1(2) ,a32*gmuji1(3),
4309 c     &   a33*gmuji1(4)
4310
4311         gloc(nphi+j,icg)=gloc(nphi+j,icg)+
4312      &      geel_loc_ji*wel_loc
4313      &    *fac_shield(i)*fac_shield(j)
4314
4315          geel_loc_ji=
4316      &     +a22*gmuji2(1)
4317      &     +a23*gmuji2(2)
4318      &     +a32*gmuji2(3)
4319      &     +a33*gmuji2(4)
4320 c         write(iout,*) "derivative over thataj-1"
4321 c         write(iout,*) a22*gmuji2(1), a23*gmuji2(2) ,a32*gmuji2(3),
4322 c     &   a33*gmuji2(4)
4323          gloc(nphi+j-1,icg)=gloc(nphi+j-1,icg)+
4324      &      geel_loc_ji*wel_loc
4325      &    *fac_shield(i)*fac_shield(j)
4326 #endif
4327 cd          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
4328
4329           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
4330      &            'eelloc',i,j,eel_loc_ij
4331 c           if (eel_loc_ij.ne.0)
4332 c     &      write (iout,'(a4,2i4,8f9.5)')'chuj',
4333 c     &     i,j,a22,muij(1),a23,muij(2),a32,muij(3),a33,muij(4)
4334
4335           eel_loc=eel_loc+eel_loc_ij
4336 C Partial derivatives in virtual-bond dihedral angles gamma
4337           if (i.gt.1)
4338      &    gel_loc_loc(i-1)=gel_loc_loc(i-1)+
4339      &            (a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j)
4340      &           +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j))
4341      &    *fac_shield(i)*fac_shield(j)
4342
4343           gel_loc_loc(j-1)=gel_loc_loc(j-1)+
4344      &           (a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j)
4345      &           +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j))
4346      &    *fac_shield(i)*fac_shield(j)
4347 C Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
4348           do l=1,3
4349             ggg(l)=(agg(l,1)*muij(1)+
4350      &          agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4))
4351      &    *fac_shield(i)*fac_shield(j)
4352             gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l)
4353             gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l)
4354 cgrad            ghalf=0.5d0*ggg(l)
4355 cgrad            gel_loc(l,i)=gel_loc(l,i)+ghalf
4356 cgrad            gel_loc(l,j)=gel_loc(l,j)+ghalf
4357           enddo
4358 cgrad          do k=i+1,j2
4359 cgrad            do l=1,3
4360 cgrad              gel_loc(l,k)=gel_loc(l,k)+ggg(l)
4361 cgrad            enddo
4362 cgrad          enddo
4363 C Remaining derivatives of eello
4364           do l=1,3
4365             gel_loc(l,i)=gel_loc(l,i)+(aggi(l,1)*muij(1)+
4366      &        aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4))
4367      &    *fac_shield(i)*fac_shield(j)
4368
4369             gel_loc(l,i+1)=gel_loc(l,i+1)+(aggi1(l,1)*muij(1)+
4370      &     aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4))
4371      &    *fac_shield(i)*fac_shield(j)
4372
4373             gel_loc(l,j)=gel_loc(l,j)+(aggj(l,1)*muij(1)+
4374      &       aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4))
4375      &    *fac_shield(i)*fac_shield(j)
4376
4377             gel_loc(l,j1)=gel_loc(l,j1)+(aggj1(l,1)*muij(1)+
4378      &     aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4))
4379      &    *fac_shield(i)*fac_shield(j)
4380
4381           enddo
4382           ENDIF
4383 C Change 12/26/95 to calculate four-body contributions to H-bonding energy
4384 c          if (j.gt.i+1 .and. num_conti.le.maxconts) then
4385           if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0
4386      &       .and. num_conti.le.maxconts) then
4387 c            write (iout,*) i,j," entered corr"
4388 C
4389 C Calculate the contact function. The ith column of the array JCONT will
4390 C contain the numbers of atoms that make contacts with the atom I (of numbers
4391 C greater than I). The arrays FACONT and GACONT will contain the values of
4392 C the contact function and its derivative.
4393 c           r0ij=1.02D0*rpp(iteli,itelj)
4394 c           r0ij=1.11D0*rpp(iteli,itelj)
4395             r0ij=2.20D0*rpp(iteli,itelj)
4396 c           r0ij=1.55D0*rpp(iteli,itelj)
4397             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
4398             if (fcont.gt.0.0D0) then
4399               num_conti=num_conti+1
4400               if (num_conti.gt.maxconts) then
4401                 write (iout,*) 'WARNING - max. # of contacts exceeded;',
4402      &                         ' will skip next contacts for this conf.'
4403               else
4404                 jcont_hb(num_conti,i)=j
4405 cd                write (iout,*) "i",i," j",j," num_conti",num_conti,
4406 cd     &           " jcont_hb",jcont_hb(num_conti,i)
4407                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.
4408      &          wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
4409 C 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
4410 C  terms.
4411                 d_cont(num_conti,i)=rij
4412 cd                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
4413 C     --- Electrostatic-interaction matrix ---
4414                 a_chuj(1,1,num_conti,i)=a22
4415                 a_chuj(1,2,num_conti,i)=a23
4416                 a_chuj(2,1,num_conti,i)=a32
4417                 a_chuj(2,2,num_conti,i)=a33
4418 C     --- Gradient of rij
4419                 do kkk=1,3
4420                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
4421                 enddo
4422                 kkll=0
4423                 do k=1,2
4424                   do l=1,2
4425                     kkll=kkll+1
4426                     do m=1,3
4427                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
4428                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
4429                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
4430                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
4431                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
4432                     enddo
4433                   enddo
4434                 enddo
4435                 ENDIF
4436                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
4437 C Calculate contact energies
4438                 cosa4=4.0D0*cosa
4439                 wij=cosa-3.0D0*cosb*cosg
4440                 cosbg1=cosb+cosg
4441                 cosbg2=cosb-cosg
4442 c               fac3=dsqrt(-ael6i)/r0ij**3
4443                 fac3=dsqrt(-ael6i)*r3ij
4444 c                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
4445                 ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
4446                 if (ees0tmp.gt.0) then
4447                   ees0pij=dsqrt(ees0tmp)
4448                 else
4449                   ees0pij=0
4450                 endif
4451 c                ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
4452                 ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
4453                 if (ees0tmp.gt.0) then
4454                   ees0mij=dsqrt(ees0tmp)
4455                 else
4456                   ees0mij=0
4457                 endif
4458 c               ees0mij=0.0D0
4459                 if (shield_mode.eq.0) then
4460                 fac_shield(i)=1.0d0
4461                 fac_shield(j)=1.0d0
4462                 else
4463                 ees0plist(num_conti,i)=j
4464 C                fac_shield(i)=0.4d0
4465 C                fac_shield(j)=0.6d0
4466                 endif
4467                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij)
4468      &          *fac_shield(i)*fac_shield(j)
4469                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij)
4470      &          *fac_shield(i)*fac_shield(j)
4471 C Diagnostics. Comment out or remove after debugging!
4472 c               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
4473 c               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
4474 c               ees0m(num_conti,i)=0.0D0
4475 C End diagnostics.
4476 c               write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
4477 c    & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
4478 C Angular derivatives of the contact function
4479                 ees0pij1=fac3/ees0pij
4480                 ees0mij1=fac3/ees0mij
4481                 fac3p=-3.0D0*fac3*rrmij
4482                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
4483                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
4484 c               ees0mij1=0.0D0
4485                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
4486                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
4487                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
4488                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
4489                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
4490                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
4491                 ecosap=ecosa1+ecosa2
4492                 ecosbp=ecosb1+ecosb2
4493                 ecosgp=ecosg1+ecosg2
4494                 ecosam=ecosa1-ecosa2
4495                 ecosbm=ecosb1-ecosb2
4496                 ecosgm=ecosg1-ecosg2
4497 C Diagnostics
4498 c               ecosap=ecosa1
4499 c               ecosbp=ecosb1
4500 c               ecosgp=ecosg1
4501 c               ecosam=0.0D0
4502 c               ecosbm=0.0D0
4503 c               ecosgm=0.0D0
4504 C End diagnostics
4505                 facont_hb(num_conti,i)=fcont
4506                 fprimcont=fprimcont/rij
4507 cd              facont_hb(num_conti,i)=1.0D0
4508 C Following line is for diagnostics.
4509 cd              fprimcont=0.0D0
4510                 do k=1,3
4511                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
4512                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
4513                 enddo
4514                 do k=1,3
4515                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
4516                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
4517                 enddo
4518                 gggp(1)=gggp(1)+ees0pijp*xj
4519                 gggp(2)=gggp(2)+ees0pijp*yj
4520                 gggp(3)=gggp(3)+ees0pijp*zj
4521                 gggm(1)=gggm(1)+ees0mijp*xj
4522                 gggm(2)=gggm(2)+ees0mijp*yj
4523                 gggm(3)=gggm(3)+ees0mijp*zj
4524 C Derivatives due to the contact function
4525                 gacont_hbr(1,num_conti,i)=fprimcont*xj
4526                 gacont_hbr(2,num_conti,i)=fprimcont*yj
4527                 gacont_hbr(3,num_conti,i)=fprimcont*zj
4528                 do k=1,3
4529 c
4530 c 10/24/08 cgrad and ! comments indicate the parts of the code removed
4531 c          following the change of gradient-summation algorithm.
4532 c
4533 cgrad                  ghalfp=0.5D0*gggp(k)
4534 cgrad                  ghalfm=0.5D0*gggm(k)
4535                   gacontp_hb1(k,num_conti,i)=!ghalfp
4536      &              +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i))
4537      &              + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
4538      &          *fac_shield(i)*fac_shield(j)
4539
4540                   gacontp_hb2(k,num_conti,i)=!ghalfp
4541      &              +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j))
4542      &              + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
4543      &          *fac_shield(i)*fac_shield(j)
4544
4545                   gacontp_hb3(k,num_conti,i)=gggp(k)
4546      &          *fac_shield(i)*fac_shield(j)
4547
4548                   gacontm_hb1(k,num_conti,i)=!ghalfm
4549      &              +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i))
4550      &              + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
4551      &          *fac_shield(i)*fac_shield(j)
4552
4553                   gacontm_hb2(k,num_conti,i)=!ghalfm
4554      &              +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j))
4555      &              + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
4556      &          *fac_shield(i)*fac_shield(j)
4557
4558                   gacontm_hb3(k,num_conti,i)=gggm(k)
4559      &          *fac_shield(i)*fac_shield(j)
4560
4561                 enddo
4562 C Diagnostics. Comment out or remove after debugging!
4563 cdiag           do k=1,3
4564 cdiag             gacontp_hb1(k,num_conti,i)=0.0D0
4565 cdiag             gacontp_hb2(k,num_conti,i)=0.0D0
4566 cdiag             gacontp_hb3(k,num_conti,i)=0.0D0
4567 cdiag             gacontm_hb1(k,num_conti,i)=0.0D0
4568 cdiag             gacontm_hb2(k,num_conti,i)=0.0D0
4569 cdiag             gacontm_hb3(k,num_conti,i)=0.0D0
4570 cdiag           enddo
4571               ENDIF ! wcorr
4572               endif  ! num_conti.le.maxconts
4573             endif  ! fcont.gt.0
4574           endif    ! j.gt.i+1
4575           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
4576             do k=1,4
4577               do l=1,3
4578                 ghalf=0.5d0*agg(l,k)
4579                 aggi(l,k)=aggi(l,k)+ghalf
4580                 aggi1(l,k)=aggi1(l,k)+agg(l,k)
4581                 aggj(l,k)=aggj(l,k)+ghalf
4582               enddo
4583             enddo
4584             if (j.eq.nres-1 .and. i.lt.j-2) then
4585               do k=1,4
4586                 do l=1,3
4587                   aggj1(l,k)=aggj1(l,k)+agg(l,k)
4588                 enddo
4589               enddo
4590             endif
4591           endif
4592 c          t_eelecij=t_eelecij+MPI_Wtime()-time00
4593       return
4594       end
4595 C-----------------------------------------------------------------------------
4596       subroutine eturn3(i,eello_turn3)
4597 C Third- and fourth-order contributions from turns
4598       implicit real*8 (a-h,o-z)
4599       include 'DIMENSIONS'
4600       include 'COMMON.IOUNITS'
4601       include 'COMMON.GEO'
4602       include 'COMMON.VAR'
4603       include 'COMMON.LOCAL'
4604       include 'COMMON.CHAIN'
4605       include 'COMMON.DERIV'
4606       include 'COMMON.INTERACT'
4607       include 'COMMON.CONTACTS'
4608       include 'COMMON.TORSION'
4609       include 'COMMON.VECTORS'
4610       include 'COMMON.FFIELD'
4611       include 'COMMON.CONTROL'
4612       include 'COMMON.SHIELD'
4613       dimension ggg(3)
4614       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
4615      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
4616      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2),gpizda1(2,2),
4617      &  gpizda2(2,2),auxgmat1(2,2),auxgmatt1(2,2),
4618      &  auxgmat2(2,2),auxgmatt2(2,2)
4619       double precision agg(3,4),aggi(3,4),aggi1(3,4),
4620      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
4621       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
4622      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
4623      &    num_conti,j1,j2
4624       j=i+2
4625 c      write (iout,*) "eturn3",i,j,j1,j2
4626       a_temp(1,1)=a22
4627       a_temp(1,2)=a23
4628       a_temp(2,1)=a32
4629       a_temp(2,2)=a33
4630 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4631 C
4632 C               Third-order contributions
4633 C
4634 C                 (i+2)o----(i+3)
4635 C                      | |
4636 C                      | |
4637 C                 (i+1)o----i
4638 C
4639 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4640 cd        call checkint_turn3(i,a_temp,eello_turn3_num)
4641         call matmat2(EUg(1,1,i+1),EUg(1,1,i+2),auxmat(1,1))
4642 c auxalary matices for theta gradient
4643 c auxalary matrix for i+1 and constant i+2
4644         call matmat2(gtEUg(1,1,i+1),EUg(1,1,i+2),auxgmat1(1,1))
4645 c auxalary matrix for i+2 and constant i+1
4646         call matmat2(EUg(1,1,i+1),gtEUg(1,1,i+2),auxgmat2(1,1))
4647         call transpose2(auxmat(1,1),auxmat1(1,1))
4648         call transpose2(auxgmat1(1,1),auxgmatt1(1,1))
4649         call transpose2(auxgmat2(1,1),auxgmatt2(1,1))
4650         call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4651         call matmat2(a_temp(1,1),auxgmatt1(1,1),gpizda1(1,1))
4652         call matmat2(a_temp(1,1),auxgmatt2(1,1),gpizda2(1,1))
4653         if (shield_mode.eq.0) then
4654         fac_shield(i)=1.0
4655         fac_shield(j)=1.0
4656 C        else
4657 C        fac_shield(i)=0.4
4658 C        fac_shield(j)=0.6
4659         endif
4660         eello_turn3=eello_turn3+0.5d0*(pizda(1,1)+pizda(2,2))
4661      &  *fac_shield(i)*fac_shield(j)
4662         eello_t3=0.5d0*(pizda(1,1)+pizda(2,2))
4663      &  *fac_shield(i)*fac_shield(j)
4664 C Derivatives in theta
4665         gloc(nphi+i,icg)=gloc(nphi+i,icg)
4666      &  +0.5d0*(gpizda1(1,1)+gpizda1(2,2))*wturn3
4667      &   *fac_shield(i)*fac_shield(j)
4668         gloc(nphi+i+1,icg)=gloc(nphi+i+1,icg)
4669      &  +0.5d0*(gpizda2(1,1)+gpizda2(2,2))*wturn3
4670      &   *fac_shield(i)*fac_shield(j)
4671
4672
4673 C        if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
4674 C Derivatives in shield mode
4675           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
4676      &  (shield_mode.gt.0)) then
4677 C          print *,i,j
4678
4679           do ilist=1,ishield_list(i)
4680            iresshield=shield_list(ilist,i)
4681            do k=1,3
4682            rlocshield=grad_shield_side(k,ilist,i)*eello_t3/fac_shield(i)
4683 C     &      *2.0
4684            gshieldx_t3(k,iresshield)=gshieldx_t3(k,iresshield)+
4685      &              rlocshield
4686      & +grad_shield_loc(k,ilist,i)*eello_t3/fac_shield(i)
4687             gshieldc_t3(k,iresshield-1)=gshieldc_t3(k,iresshield-1)
4688      &      +rlocshield
4689            enddo
4690           enddo
4691           do ilist=1,ishield_list(j)
4692            iresshield=shield_list(ilist,j)
4693            do k=1,3
4694            rlocshield=grad_shield_side(k,ilist,j)*eello_t3/fac_shield(j)
4695 C     &     *2.0
4696            gshieldx_t3(k,iresshield)=gshieldx_t3(k,iresshield)+
4697      &              rlocshield
4698      & +grad_shield_loc(k,ilist,j)*eello_t3/fac_shield(j)
4699            gshieldc_t3(k,iresshield-1)=gshieldc_t3(k,iresshield-1)
4700      &             +rlocshield
4701
4702            enddo
4703           enddo
4704
4705           do k=1,3
4706             gshieldc_t3(k,i)=gshieldc_t3(k,i)+
4707      &              grad_shield(k,i)*eello_t3/fac_shield(i)
4708             gshieldc_t3(k,j)=gshieldc_t3(k,j)+
4709      &              grad_shield(k,j)*eello_t3/fac_shield(j)
4710             gshieldc_t3(k,i-1)=gshieldc_t3(k,i-1)+
4711      &              grad_shield(k,i)*eello_t3/fac_shield(i)
4712             gshieldc_t3(k,j-1)=gshieldc_t3(k,j-1)+
4713      &              grad_shield(k,j)*eello_t3/fac_shield(j)
4714            enddo
4715            endif
4716
4717 C        if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
4718 cd        write (2,*) 'i,',i,' j',j,'eello_turn3',
4719 cd     &    0.5d0*(pizda(1,1)+pizda(2,2)),
4720 cd     &    ' eello_turn3_num',4*eello_turn3_num
4721 C Derivatives in gamma(i)
4722         call matmat2(EUgder(1,1,i+1),EUg(1,1,i+2),auxmat2(1,1))
4723         call transpose2(auxmat2(1,1),auxmat3(1,1))
4724         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
4725         gel_loc_turn3(i)=gel_loc_turn3(i)+0.5d0*(pizda(1,1)+pizda(2,2))
4726      &   *fac_shield(i)*fac_shield(j)
4727 C Derivatives in gamma(i+1)
4728         call matmat2(EUg(1,1,i+1),EUgder(1,1,i+2),auxmat2(1,1))
4729         call transpose2(auxmat2(1,1),auxmat3(1,1))
4730         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
4731         gel_loc_turn3(i+1)=gel_loc_turn3(i+1)
4732      &    +0.5d0*(pizda(1,1)+pizda(2,2))
4733      &   *fac_shield(i)*fac_shield(j)
4734 C Cartesian derivatives
4735         do l=1,3
4736 c            ghalf1=0.5d0*agg(l,1)
4737 c            ghalf2=0.5d0*agg(l,2)
4738 c            ghalf3=0.5d0*agg(l,3)
4739 c            ghalf4=0.5d0*agg(l,4)
4740           a_temp(1,1)=aggi(l,1)!+ghalf1
4741           a_temp(1,2)=aggi(l,2)!+ghalf2
4742           a_temp(2,1)=aggi(l,3)!+ghalf3
4743           a_temp(2,2)=aggi(l,4)!+ghalf4
4744           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4745           gcorr3_turn(l,i)=gcorr3_turn(l,i)
4746      &      +0.5d0*(pizda(1,1)+pizda(2,2))
4747      &   *fac_shield(i)*fac_shield(j)
4748
4749           a_temp(1,1)=aggi1(l,1)!+agg(l,1)
4750           a_temp(1,2)=aggi1(l,2)!+agg(l,2)
4751           a_temp(2,1)=aggi1(l,3)!+agg(l,3)
4752           a_temp(2,2)=aggi1(l,4)!+agg(l,4)
4753           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4754           gcorr3_turn(l,i+1)=gcorr3_turn(l,i+1)
4755      &      +0.5d0*(pizda(1,1)+pizda(2,2))
4756      &   *fac_shield(i)*fac_shield(j)
4757           a_temp(1,1)=aggj(l,1)!+ghalf1
4758           a_temp(1,2)=aggj(l,2)!+ghalf2
4759           a_temp(2,1)=aggj(l,3)!+ghalf3
4760           a_temp(2,2)=aggj(l,4)!+ghalf4
4761           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4762           gcorr3_turn(l,j)=gcorr3_turn(l,j)
4763      &      +0.5d0*(pizda(1,1)+pizda(2,2))
4764      &   *fac_shield(i)*fac_shield(j)
4765           a_temp(1,1)=aggj1(l,1)
4766           a_temp(1,2)=aggj1(l,2)
4767           a_temp(2,1)=aggj1(l,3)
4768           a_temp(2,2)=aggj1(l,4)
4769           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4770           gcorr3_turn(l,j1)=gcorr3_turn(l,j1)
4771      &      +0.5d0*(pizda(1,1)+pizda(2,2))
4772      &   *fac_shield(i)*fac_shield(j)
4773         enddo
4774       return
4775       end
4776 C-------------------------------------------------------------------------------
4777       subroutine eturn4(i,eello_turn4)
4778 C Third- and fourth-order contributions from turns
4779       implicit real*8 (a-h,o-z)
4780       include 'DIMENSIONS'
4781       include 'COMMON.IOUNITS'
4782       include 'COMMON.GEO'
4783       include 'COMMON.VAR'
4784       include 'COMMON.LOCAL'
4785       include 'COMMON.CHAIN'
4786       include 'COMMON.DERIV'
4787       include 'COMMON.INTERACT'
4788       include 'COMMON.CONTACTS'
4789       include 'COMMON.TORSION'
4790       include 'COMMON.VECTORS'
4791       include 'COMMON.FFIELD'
4792       include 'COMMON.CONTROL'
4793       include 'COMMON.SHIELD'
4794       dimension ggg(3)
4795       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
4796      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
4797      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2),auxgvec(2),
4798      &  auxgEvec1(2),auxgEvec2(2),auxgEvec3(2),
4799      &  gte1t(2,2),gte2t(2,2),gte3t(2,2),
4800      &  gte1a(2,2),gtae3(2,2),gtae3e2(2,2), ae3gte2(2,2),
4801      &  gtEpizda1(2,2),gtEpizda2(2,2),gtEpizda3(2,2)
4802       double precision agg(3,4),aggi(3,4),aggi1(3,4),
4803      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
4804       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
4805      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
4806      &    num_conti,j1,j2
4807       j=i+3
4808 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4809 C
4810 C               Fourth-order contributions
4811 C
4812 C                 (i+3)o----(i+4)
4813 C                     /  |
4814 C               (i+2)o   |
4815 C                     \  |
4816 C                 (i+1)o----i
4817 C
4818 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4819 cd        call checkint_turn4(i,a_temp,eello_turn4_num)
4820 c        write (iout,*) "eturn4 i",i," j",j," j1",j1," j2",j2
4821 c        write(iout,*)"WCHODZE W PROGRAM"
4822         a_temp(1,1)=a22
4823         a_temp(1,2)=a23
4824         a_temp(2,1)=a32
4825         a_temp(2,2)=a33
4826         iti1=itortyp(itype(i+1))
4827         iti2=itortyp(itype(i+2))
4828         iti3=itortyp(itype(i+3))
4829 c        write(iout,*) "iti1",iti1," iti2",iti2," iti3",iti3
4830         call transpose2(EUg(1,1,i+1),e1t(1,1))
4831         call transpose2(Eug(1,1,i+2),e2t(1,1))
4832         call transpose2(Eug(1,1,i+3),e3t(1,1))
4833 C Ematrix derivative in theta
4834         call transpose2(gtEUg(1,1,i+1),gte1t(1,1))
4835         call transpose2(gtEug(1,1,i+2),gte2t(1,1))
4836         call transpose2(gtEug(1,1,i+3),gte3t(1,1))
4837         call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4838 c       eta1 in derivative theta
4839         call matmat2(gte1t(1,1),a_temp(1,1),gte1a(1,1))
4840         call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4841 c       auxgvec is derivative of Ub2 so i+3 theta
4842         call matvec2(e1a(1,1),gUb2(1,i+3),auxgvec(1))
4843 c       auxalary matrix of E i+1
4844         call matvec2(gte1a(1,1),Ub2(1,i+3),auxgEvec1(1))
4845 c        s1=0.0
4846 c        gs1=0.0
4847         s1=scalar2(b1(1,i+2),auxvec(1))
4848 c derivative of theta i+2 with constant i+3
4849         gs23=scalar2(gtb1(1,i+2),auxvec(1))
4850 c derivative of theta i+2 with constant i+2
4851         gs32=scalar2(b1(1,i+2),auxgvec(1))
4852 c derivative of E matix in theta of i+1
4853         gsE13=scalar2(b1(1,i+2),auxgEvec1(1))
4854
4855         call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4856 c       ea31 in derivative theta
4857         call matmat2(a_temp(1,1),gte3t(1,1),gtae3(1,1))
4858         call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4859 c auxilary matrix auxgvec of Ub2 with constant E matirx
4860         call matvec2(ae3(1,1),gUb2(1,i+2),auxgvec(1))
4861 c auxilary matrix auxgEvec1 of E matix with Ub2 constant
4862         call matvec2(gtae3(1,1),Ub2(1,i+2),auxgEvec3(1))
4863
4864 c        s2=0.0
4865 c        gs2=0.0
4866         s2=scalar2(b1(1,i+1),auxvec(1))
4867 c derivative of theta i+1 with constant i+3
4868         gs13=scalar2(gtb1(1,i+1),auxvec(1))
4869 c derivative of theta i+2 with constant i+1
4870         gs21=scalar2(b1(1,i+1),auxgvec(1))
4871 c derivative of theta i+3 with constant i+1
4872         gsE31=scalar2(b1(1,i+1),auxgEvec3(1))
4873 c        write(iout,*) gs1,gs2,'i=',i,auxgvec(1),gUb2(1,i+2),gtb1(1,i+2),
4874 c     &  gtb1(1,i+1)
4875         call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4876 c two derivatives over diffetent matrices
4877 c gtae3e2 is derivative over i+3
4878         call matmat2(gtae3(1,1),e2t(1,1),gtae3e2(1,1))
4879 c ae3gte2 is derivative over i+2
4880         call matmat2(ae3(1,1),gte2t(1,1),ae3gte2(1,1))
4881         call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4882 c three possible derivative over theta E matices
4883 c i+1
4884         call matmat2(ae3e2(1,1),gte1t(1,1),gtEpizda1(1,1))
4885 c i+2
4886         call matmat2(ae3gte2(1,1),e1t(1,1),gtEpizda2(1,1))
4887 c i+3
4888         call matmat2(gtae3e2(1,1),e1t(1,1),gtEpizda3(1,1))
4889         s3=0.5d0*(pizda(1,1)+pizda(2,2))
4890
4891         gsEE1=0.5d0*(gtEpizda1(1,1)+gtEpizda1(2,2))
4892         gsEE2=0.5d0*(gtEpizda2(1,1)+gtEpizda2(2,2))
4893         gsEE3=0.5d0*(gtEpizda3(1,1)+gtEpizda3(2,2))
4894         if (shield_mode.eq.0) then
4895         fac_shield(i)=1.0
4896         fac_shield(j)=1.0
4897 C        else
4898 C        fac_shield(i)=0.6
4899 C        fac_shield(j)=0.4
4900         endif
4901         eello_turn4=eello_turn4-(s1+s2+s3)
4902      &  *fac_shield(i)*fac_shield(j)
4903         eello_t4=-(s1+s2+s3)
4904      &  *fac_shield(i)*fac_shield(j)
4905 c             write(iout,*)'chujOWO', auxvec(1),b1(1,iti2)
4906         if (energy_dec) write (iout,'(a6,2i5,0pf7.3,3f7.3)')
4907      &      'eturn4',i,j,-(s1+s2+s3),s1,s2,s3
4908 C Now derivative over shield:
4909           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
4910      &  (shield_mode.gt.0)) then
4911 C          print *,i,j
4912
4913           do ilist=1,ishield_list(i)
4914            iresshield=shield_list(ilist,i)
4915            do k=1,3
4916            rlocshield=grad_shield_side(k,ilist,i)*eello_t4/fac_shield(i)
4917 C     &      *2.0
4918            gshieldx_t4(k,iresshield)=gshieldx_t4(k,iresshield)+
4919      &              rlocshield
4920      & +grad_shield_loc(k,ilist,i)*eello_t4/fac_shield(i)
4921             gshieldc_t4(k,iresshield-1)=gshieldc_t4(k,iresshield-1)
4922      &      +rlocshield
4923            enddo
4924           enddo
4925           do ilist=1,ishield_list(j)
4926            iresshield=shield_list(ilist,j)
4927            do k=1,3
4928            rlocshield=grad_shield_side(k,ilist,j)*eello_t4/fac_shield(j)
4929 C     &     *2.0
4930            gshieldx_t4(k,iresshield)=gshieldx_t4(k,iresshield)+
4931      &              rlocshield
4932      & +grad_shield_loc(k,ilist,j)*eello_t4/fac_shield(j)
4933            gshieldc_t4(k,iresshield-1)=gshieldc_t4(k,iresshield-1)
4934      &             +rlocshield
4935
4936            enddo
4937           enddo
4938
4939           do k=1,3
4940             gshieldc_t4(k,i)=gshieldc_t4(k,i)+
4941      &              grad_shield(k,i)*eello_t4/fac_shield(i)
4942             gshieldc_t4(k,j)=gshieldc_t4(k,j)+
4943      &              grad_shield(k,j)*eello_t4/fac_shield(j)
4944             gshieldc_t4(k,i-1)=gshieldc_t4(k,i-1)+
4945      &              grad_shield(k,i)*eello_t4/fac_shield(i)
4946             gshieldc_t4(k,j-1)=gshieldc_t4(k,j-1)+
4947      &              grad_shield(k,j)*eello_t4/fac_shield(j)
4948            enddo
4949            endif
4950
4951
4952
4953
4954
4955
4956 cd        write (2,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
4957 cd     &    ' eello_turn4_num',8*eello_turn4_num
4958 #ifdef NEWCORR
4959         gloc(nphi+i,icg)=gloc(nphi+i,icg)
4960      &                  -(gs13+gsE13+gsEE1)*wturn4
4961      &  *fac_shield(i)*fac_shield(j)
4962         gloc(nphi+i+1,icg)= gloc(nphi+i+1,icg)
4963      &                    -(gs23+gs21+gsEE2)*wturn4
4964      &  *fac_shield(i)*fac_shield(j)
4965
4966         gloc(nphi+i+2,icg)= gloc(nphi+i+2,icg)
4967      &                    -(gs32+gsE31+gsEE3)*wturn4
4968      &  *fac_shield(i)*fac_shield(j)
4969
4970 c         gloc(nphi+i+1,icg)=gloc(nphi+i+1,icg)-
4971 c     &   gs2
4972 #endif
4973         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
4974      &      'eturn4',i,j,-(s1+s2+s3)
4975 c        write (iout,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
4976 c     &    ' eello_turn4_num',8*eello_turn4_num
4977 C Derivatives in gamma(i)
4978         call transpose2(EUgder(1,1,i+1),e1tder(1,1))
4979         call matmat2(e1tder(1,1),a_temp(1,1),auxmat(1,1))
4980         call matvec2(auxmat(1,1),Ub2(1,i+3),auxvec(1))
4981         s1=scalar2(b1(1,i+2),auxvec(1))
4982         call matmat2(ae3e2(1,1),e1tder(1,1),pizda(1,1))
4983         s3=0.5d0*(pizda(1,1)+pizda(2,2))
4984         gel_loc_turn4(i)=gel_loc_turn4(i)-(s1+s3)
4985      &  *fac_shield(i)*fac_shield(j)
4986 C Derivatives in gamma(i+1)
4987         call transpose2(EUgder(1,1,i+2),e2tder(1,1))
4988         call matvec2(ae3(1,1),Ub2der(1,i+2),auxvec(1))
4989         s2=scalar2(b1(1,i+1),auxvec(1))
4990         call matmat2(ae3(1,1),e2tder(1,1),auxmat(1,1))
4991         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
4992         s3=0.5d0*(pizda(1,1)+pizda(2,2))
4993         gel_loc_turn4(i+1)=gel_loc_turn4(i+1)-(s2+s3)
4994      &  *fac_shield(i)*fac_shield(j)
4995 C Derivatives in gamma(i+2)
4996         call transpose2(EUgder(1,1,i+3),e3tder(1,1))
4997         call matvec2(e1a(1,1),Ub2der(1,i+3),auxvec(1))
4998         s1=scalar2(b1(1,i+2),auxvec(1))
4999         call matmat2(a_temp(1,1),e3tder(1,1),auxmat(1,1))
5000         call matvec2(auxmat(1,1),Ub2(1,i+2),auxvec(1))
5001         s2=scalar2(b1(1,i+1),auxvec(1))
5002         call matmat2(auxmat(1,1),e2t(1,1),auxmat3(1,1))
5003         call matmat2(auxmat3(1,1),e1t(1,1),pizda(1,1))
5004         s3=0.5d0*(pizda(1,1)+pizda(2,2))
5005         gel_loc_turn4(i+2)=gel_loc_turn4(i+2)-(s1+s2+s3)
5006      &  *fac_shield(i)*fac_shield(j)
5007 C Cartesian derivatives
5008 C Derivatives of this turn contributions in DC(i+2)
5009         if (j.lt.nres-1) then
5010           do l=1,3
5011             a_temp(1,1)=agg(l,1)
5012             a_temp(1,2)=agg(l,2)
5013             a_temp(2,1)=agg(l,3)
5014             a_temp(2,2)=agg(l,4)
5015             call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5016             call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5017             s1=scalar2(b1(1,i+2),auxvec(1))
5018             call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5019             call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5020             s2=scalar2(b1(1,i+1),auxvec(1))
5021             call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5022             call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5023             s3=0.5d0*(pizda(1,1)+pizda(2,2))
5024             ggg(l)=-(s1+s2+s3)
5025             gcorr4_turn(l,i+2)=gcorr4_turn(l,i+2)-(s1+s2+s3)
5026      &  *fac_shield(i)*fac_shield(j)
5027           enddo
5028         endif
5029 C Remaining derivatives of this turn contribution
5030         do l=1,3
5031           a_temp(1,1)=aggi(l,1)
5032           a_temp(1,2)=aggi(l,2)
5033           a_temp(2,1)=aggi(l,3)
5034           a_temp(2,2)=aggi(l,4)
5035           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5036           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5037           s1=scalar2(b1(1,i+2),auxvec(1))
5038           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5039           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5040           s2=scalar2(b1(1,i+1),auxvec(1))
5041           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5042           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5043           s3=0.5d0*(pizda(1,1)+pizda(2,2))
5044           gcorr4_turn(l,i)=gcorr4_turn(l,i)-(s1+s2+s3)
5045      &  *fac_shield(i)*fac_shield(j)
5046           a_temp(1,1)=aggi1(l,1)
5047           a_temp(1,2)=aggi1(l,2)
5048           a_temp(2,1)=aggi1(l,3)
5049           a_temp(2,2)=aggi1(l,4)
5050           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5051           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5052           s1=scalar2(b1(1,i+2),auxvec(1))
5053           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5054           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5055           s2=scalar2(b1(1,i+1),auxvec(1))
5056           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5057           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5058           s3=0.5d0*(pizda(1,1)+pizda(2,2))
5059           gcorr4_turn(l,i+1)=gcorr4_turn(l,i+1)-(s1+s2+s3)
5060      &  *fac_shield(i)*fac_shield(j)
5061           a_temp(1,1)=aggj(l,1)
5062           a_temp(1,2)=aggj(l,2)
5063           a_temp(2,1)=aggj(l,3)
5064           a_temp(2,2)=aggj(l,4)
5065           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5066           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5067           s1=scalar2(b1(1,i+2),auxvec(1))
5068           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5069           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5070           s2=scalar2(b1(1,i+1),auxvec(1))
5071           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5072           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5073           s3=0.5d0*(pizda(1,1)+pizda(2,2))
5074           gcorr4_turn(l,j)=gcorr4_turn(l,j)-(s1+s2+s3)
5075      &  *fac_shield(i)*fac_shield(j)
5076           a_temp(1,1)=aggj1(l,1)
5077           a_temp(1,2)=aggj1(l,2)
5078           a_temp(2,1)=aggj1(l,3)
5079           a_temp(2,2)=aggj1(l,4)
5080           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5081           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5082           s1=scalar2(b1(1,i+2),auxvec(1))
5083           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5084           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5085           s2=scalar2(b1(1,i+1),auxvec(1))
5086           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5087           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5088           s3=0.5d0*(pizda(1,1)+pizda(2,2))
5089 c          write (iout,*) "s1",s1," s2",s2," s3",s3," s1+s2+s3",s1+s2+s3
5090           gcorr4_turn(l,j1)=gcorr4_turn(l,j1)-(s1+s2+s3)
5091      &  *fac_shield(i)*fac_shield(j)
5092         enddo
5093       return
5094       end
5095 C-----------------------------------------------------------------------------
5096       subroutine vecpr(u,v,w)
5097       implicit real*8(a-h,o-z)
5098       dimension u(3),v(3),w(3)
5099       w(1)=u(2)*v(3)-u(3)*v(2)
5100       w(2)=-u(1)*v(3)+u(3)*v(1)
5101       w(3)=u(1)*v(2)-u(2)*v(1)
5102       return
5103       end
5104 C-----------------------------------------------------------------------------
5105       subroutine unormderiv(u,ugrad,unorm,ungrad)
5106 C This subroutine computes the derivatives of a normalized vector u, given
5107 C the derivatives computed without normalization conditions, ugrad. Returns
5108 C ungrad.
5109       implicit none
5110       double precision u(3),ugrad(3,3),unorm,ungrad(3,3)
5111       double precision vec(3)
5112       double precision scalar
5113       integer i,j
5114 c      write (2,*) 'ugrad',ugrad
5115 c      write (2,*) 'u',u
5116       do i=1,3
5117         vec(i)=scalar(ugrad(1,i),u(1))
5118       enddo
5119 c      write (2,*) 'vec',vec
5120       do i=1,3
5121         do j=1,3
5122           ungrad(j,i)=(ugrad(j,i)-u(j)*vec(i))*unorm
5123         enddo
5124       enddo
5125 c      write (2,*) 'ungrad',ungrad
5126       return
5127       end
5128 C-----------------------------------------------------------------------------
5129       subroutine escp_soft_sphere(evdw2,evdw2_14)
5130 C
5131 C This subroutine calculates the excluded-volume interaction energy between
5132 C peptide-group centers and side chains and its gradient in virtual-bond and
5133 C side-chain vectors.
5134 C
5135       implicit real*8 (a-h,o-z)
5136       include 'DIMENSIONS'
5137       include 'COMMON.GEO'
5138       include 'COMMON.VAR'
5139       include 'COMMON.LOCAL'
5140       include 'COMMON.CHAIN'
5141       include 'COMMON.DERIV'
5142       include 'COMMON.INTERACT'
5143       include 'COMMON.FFIELD'
5144       include 'COMMON.IOUNITS'
5145       include 'COMMON.CONTROL'
5146       dimension ggg(3)
5147       evdw2=0.0D0
5148       evdw2_14=0.0d0
5149       r0_scp=4.5d0
5150 cd    print '(a)','Enter ESCP'
5151 cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
5152 C      do xshift=-1,1
5153 C      do yshift=-1,1
5154 C      do zshift=-1,1
5155       do i=iatscp_s,iatscp_e
5156         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
5157         iteli=itel(i)
5158         xi=0.5D0*(c(1,i)+c(1,i+1))
5159         yi=0.5D0*(c(2,i)+c(2,i+1))
5160         zi=0.5D0*(c(3,i)+c(3,i+1))
5161 C Return atom into box, boxxsize is size of box in x dimension
5162 c  134   continue
5163 c        if (xi.gt.((xshift+0.5d0)*boxxsize)) xi=xi-boxxsize
5164 c        if (xi.lt.((xshift-0.5d0)*boxxsize)) xi=xi+boxxsize
5165 C Condition for being inside the proper box
5166 c        if ((xi.gt.((xshift+0.5d0)*boxxsize)).or.
5167 c     &       (xi.lt.((xshift-0.5d0)*boxxsize))) then
5168 c        go to 134
5169 c        endif
5170 c  135   continue
5171 c        if (yi.gt.((yshift+0.5d0)*boxysize)) yi=yi-boxysize
5172 c        if (yi.lt.((yshift-0.5d0)*boxysize)) yi=yi+boxysize
5173 C Condition for being inside the proper box
5174 c        if ((yi.gt.((yshift+0.5d0)*boxysize)).or.
5175 c     &       (yi.lt.((yshift-0.5d0)*boxysize))) then
5176 c        go to 135
5177 c c       endif
5178 c  136   continue
5179 c        if (zi.gt.((zshift+0.5d0)*boxzsize)) zi=zi-boxzsize
5180 c        if (zi.lt.((zshift-0.5d0)*boxzsize)) zi=zi+boxzsize
5181 cC Condition for being inside the proper box
5182 c        if ((zi.gt.((zshift+0.5d0)*boxzsize)).or.
5183 c     &       (zi.lt.((zshift-0.5d0)*boxzsize))) then
5184 c        go to 136
5185 c        endif
5186           xi=mod(xi,boxxsize)
5187           if (xi.lt.0) xi=xi+boxxsize
5188           yi=mod(yi,boxysize)
5189           if (yi.lt.0) yi=yi+boxysize
5190           zi=mod(zi,boxzsize)
5191           if (zi.lt.0) zi=zi+boxzsize
5192 C          xi=xi+xshift*boxxsize
5193 C          yi=yi+yshift*boxysize
5194 C          zi=zi+zshift*boxzsize
5195         do iint=1,nscp_gr(i)
5196
5197         do j=iscpstart(i,iint),iscpend(i,iint)
5198           if (itype(j).eq.ntyp1) cycle
5199           itypj=iabs(itype(j))
5200 C Uncomment following three lines for SC-p interactions
5201 c         xj=c(1,nres+j)-xi
5202 c         yj=c(2,nres+j)-yi
5203 c         zj=c(3,nres+j)-zi
5204 C Uncomment following three lines for Ca-p interactions
5205           xj=c(1,j)
5206           yj=c(2,j)
5207           zj=c(3,j)
5208 c  174   continue
5209 c        if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
5210 c        if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
5211 C Condition for being inside the proper box
5212 c        if ((xj.gt.((0.5d0)*boxxsize)).or.
5213 c     &       (xj.lt.((-0.5d0)*boxxsize))) then
5214 c        go to 174
5215 c        endif
5216 c  175   continue
5217 c        if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
5218 c        if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
5219 cC Condition for being inside the proper box
5220 c        if ((yj.gt.((0.5d0)*boxysize)).or.
5221 c     &       (yj.lt.((-0.5d0)*boxysize))) then
5222 c        go to 175
5223 c        endif
5224 c  176   continue
5225 c        if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
5226 c        if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
5227 C Condition for being inside the proper box
5228 c        if ((zj.gt.((0.5d0)*boxzsize)).or.
5229 c     &       (zj.lt.((-0.5d0)*boxzsize))) then
5230 c        go to 176
5231           xj=mod(xj,boxxsize)
5232           if (xj.lt.0) xj=xj+boxxsize
5233           yj=mod(yj,boxysize)
5234           if (yj.lt.0) yj=yj+boxysize
5235           zj=mod(zj,boxzsize)
5236           if (zj.lt.0) zj=zj+boxzsize
5237       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
5238       xj_safe=xj
5239       yj_safe=yj
5240       zj_safe=zj
5241       subchap=0
5242       do xshift=-1,1
5243       do yshift=-1,1
5244       do zshift=-1,1
5245           xj=xj_safe+xshift*boxxsize
5246           yj=yj_safe+yshift*boxysize
5247           zj=zj_safe+zshift*boxzsize
5248           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
5249           if(dist_temp.lt.dist_init) then
5250             dist_init=dist_temp
5251             xj_temp=xj
5252             yj_temp=yj
5253             zj_temp=zj
5254             subchap=1
5255           endif
5256        enddo
5257        enddo
5258        enddo
5259        if (subchap.eq.1) then
5260           xj=xj_temp-xi
5261           yj=yj_temp-yi
5262           zj=zj_temp-zi
5263        else
5264           xj=xj_safe-xi
5265           yj=yj_safe-yi
5266           zj=zj_safe-zi
5267        endif
5268 c c       endif
5269 C          xj=xj-xi
5270 C          yj=yj-yi
5271 C          zj=zj-zi
5272           rij=xj*xj+yj*yj+zj*zj
5273
5274           r0ij=r0_scp
5275           r0ijsq=r0ij*r0ij
5276           if (rij.lt.r0ijsq) then
5277             evdwij=0.25d0*(rij-r0ijsq)**2
5278             fac=rij-r0ijsq
5279           else
5280             evdwij=0.0d0
5281             fac=0.0d0
5282           endif
5283           evdw2=evdw2+evdwij
5284 C
5285 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
5286 C
5287           ggg(1)=xj*fac
5288           ggg(2)=yj*fac
5289           ggg(3)=zj*fac
5290 cgrad          if (j.lt.i) then
5291 cd          write (iout,*) 'j<i'
5292 C Uncomment following three lines for SC-p interactions
5293 c           do k=1,3
5294 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
5295 c           enddo
5296 cgrad          else
5297 cd          write (iout,*) 'j>i'
5298 cgrad            do k=1,3
5299 cgrad              ggg(k)=-ggg(k)
5300 C Uncomment following line for SC-p interactions
5301 c             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
5302 cgrad            enddo
5303 cgrad          endif
5304 cgrad          do k=1,3
5305 cgrad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
5306 cgrad          enddo
5307 cgrad          kstart=min0(i+1,j)
5308 cgrad          kend=max0(i-1,j-1)
5309 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
5310 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
5311 cgrad          do k=kstart,kend
5312 cgrad            do l=1,3
5313 cgrad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
5314 cgrad            enddo
5315 cgrad          enddo
5316           do k=1,3
5317             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
5318             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
5319           enddo
5320         enddo
5321
5322         enddo ! iint
5323       enddo ! i
5324 C      enddo !zshift
5325 C      enddo !yshift
5326 C      enddo !xshift
5327       return
5328       end
5329 C-----------------------------------------------------------------------------
5330       subroutine escp(evdw2,evdw2_14)
5331 C
5332 C This subroutine calculates the excluded-volume interaction energy between
5333 C peptide-group centers and side chains and its gradient in virtual-bond and
5334 C side-chain vectors.
5335 C
5336       implicit real*8 (a-h,o-z)
5337       include 'DIMENSIONS'
5338       include 'COMMON.GEO'
5339       include 'COMMON.VAR'
5340       include 'COMMON.LOCAL'
5341       include 'COMMON.CHAIN'
5342       include 'COMMON.DERIV'
5343       include 'COMMON.INTERACT'
5344       include 'COMMON.FFIELD'
5345       include 'COMMON.IOUNITS'
5346       include 'COMMON.CONTROL'
5347       include 'COMMON.SPLITELE'
5348       dimension ggg(3)
5349       evdw2=0.0D0
5350       evdw2_14=0.0d0
5351 c        print *,boxxsize,boxysize,boxzsize,'wymiary pudla'
5352 cd    print '(a)','Enter ESCP'
5353 cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
5354 C      do xshift=-1,1
5355 C      do yshift=-1,1
5356 C      do zshift=-1,1
5357       do i=iatscp_s,iatscp_e
5358         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
5359         iteli=itel(i)
5360         xi=0.5D0*(c(1,i)+c(1,i+1))
5361         yi=0.5D0*(c(2,i)+c(2,i+1))
5362         zi=0.5D0*(c(3,i)+c(3,i+1))
5363           xi=mod(xi,boxxsize)
5364           if (xi.lt.0) xi=xi+boxxsize
5365           yi=mod(yi,boxysize)
5366           if (yi.lt.0) yi=yi+boxysize
5367           zi=mod(zi,boxzsize)
5368           if (zi.lt.0) zi=zi+boxzsize
5369 c          xi=xi+xshift*boxxsize
5370 c          yi=yi+yshift*boxysize
5371 c          zi=zi+zshift*boxzsize
5372 c        print *,xi,yi,zi,'polozenie i'
5373 C Return atom into box, boxxsize is size of box in x dimension
5374 c  134   continue
5375 c        if (xi.gt.((xshift+0.5d0)*boxxsize)) xi=xi-boxxsize
5376 c        if (xi.lt.((xshift-0.5d0)*boxxsize)) xi=xi+boxxsize
5377 C Condition for being inside the proper box
5378 c        if ((xi.gt.((xshift+0.5d0)*boxxsize)).or.
5379 c     &       (xi.lt.((xshift-0.5d0)*boxxsize))) then
5380 c        go to 134
5381 c        endif
5382 c  135   continue
5383 c          print *,xi,boxxsize,"pierwszy"
5384
5385 c        if (yi.gt.((yshift+0.5d0)*boxysize)) yi=yi-boxysize
5386 c        if (yi.lt.((yshift-0.5d0)*boxysize)) yi=yi+boxysize
5387 C Condition for being inside the proper box
5388 c        if ((yi.gt.((yshift+0.5d0)*boxysize)).or.
5389 c     &       (yi.lt.((yshift-0.5d0)*boxysize))) then
5390 c        go to 135
5391 c        endif
5392 c  136   continue
5393 c        if (zi.gt.((zshift+0.5d0)*boxzsize)) zi=zi-boxzsize
5394 c        if (zi.lt.((zshift-0.5d0)*boxzsize)) zi=zi+boxzsize
5395 C Condition for being inside the proper box
5396 c        if ((zi.gt.((zshift+0.5d0)*boxzsize)).or.
5397 c     &       (zi.lt.((zshift-0.5d0)*boxzsize))) then
5398 c        go to 136
5399 c        endif
5400         do iint=1,nscp_gr(i)
5401
5402         do j=iscpstart(i,iint),iscpend(i,iint)
5403           itypj=iabs(itype(j))
5404           if (itypj.eq.ntyp1) cycle
5405 C Uncomment following three lines for SC-p interactions
5406 c         xj=c(1,nres+j)-xi
5407 c         yj=c(2,nres+j)-yi
5408 c         zj=c(3,nres+j)-zi
5409 C Uncomment following three lines for Ca-p interactions
5410           xj=c(1,j)
5411           yj=c(2,j)
5412           zj=c(3,j)
5413           xj=mod(xj,boxxsize)
5414           if (xj.lt.0) xj=xj+boxxsize
5415           yj=mod(yj,boxysize)
5416           if (yj.lt.0) yj=yj+boxysize
5417           zj=mod(zj,boxzsize)
5418           if (zj.lt.0) zj=zj+boxzsize
5419 c  174   continue
5420 c        if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
5421 c        if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
5422 C Condition for being inside the proper box
5423 c        if ((xj.gt.((0.5d0)*boxxsize)).or.
5424 c     &       (xj.lt.((-0.5d0)*boxxsize))) then
5425 c        go to 174
5426 c        endif
5427 c  175   continue
5428 c        if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
5429 c        if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
5430 cC Condition for being inside the proper box
5431 c        if ((yj.gt.((0.5d0)*boxysize)).or.
5432 c     &       (yj.lt.((-0.5d0)*boxysize))) then
5433 c        go to 175
5434 c        endif
5435 c  176   continue
5436 c        if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
5437 c        if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
5438 C Condition for being inside the proper box
5439 c        if ((zj.gt.((0.5d0)*boxzsize)).or.
5440 c     &       (zj.lt.((-0.5d0)*boxzsize))) then
5441 c        go to 176
5442 c        endif
5443 CHERE IS THE CALCULATION WHICH MIRROR IMAGE IS THE CLOSEST ONE
5444       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
5445       xj_safe=xj
5446       yj_safe=yj
5447       zj_safe=zj
5448       subchap=0
5449       do xshift=-1,1
5450       do yshift=-1,1
5451       do zshift=-1,1
5452           xj=xj_safe+xshift*boxxsize
5453           yj=yj_safe+yshift*boxysize
5454           zj=zj_safe+zshift*boxzsize
5455           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
5456           if(dist_temp.lt.dist_init) then
5457             dist_init=dist_temp
5458             xj_temp=xj
5459             yj_temp=yj
5460             zj_temp=zj
5461             subchap=1
5462           endif
5463        enddo
5464        enddo
5465        enddo
5466        if (subchap.eq.1) then
5467           xj=xj_temp-xi
5468           yj=yj_temp-yi
5469           zj=zj_temp-zi
5470        else
5471           xj=xj_safe-xi
5472           yj=yj_safe-yi
5473           zj=zj_safe-zi
5474        endif
5475 c          print *,xj,yj,zj,'polozenie j'
5476           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
5477 c          print *,rrij
5478           sss=sscale(1.0d0/(dsqrt(rrij)))
5479 c          print *,r_cut,1.0d0/dsqrt(rrij),sss,'tu patrz'
5480 c          if (sss.eq.0) print *,'czasem jest OK'
5481           if (sss.le.0.0d0) cycle
5482           sssgrad=sscagrad(1.0d0/(dsqrt(rrij)))
5483           fac=rrij**expon2
5484           e1=fac*fac*aad(itypj,iteli)
5485           e2=fac*bad(itypj,iteli)
5486           if (iabs(j-i) .le. 2) then
5487             e1=scal14*e1
5488             e2=scal14*e2
5489             evdw2_14=evdw2_14+(e1+e2)*sss
5490           endif
5491           evdwij=e1+e2
5492           evdw2=evdw2+evdwij*sss
5493           if (energy_dec) write (iout,'(a6,2i5,0pf7.3,2i3,3e11.3)')
5494      &        'evdw2',i,j,evdwij,iteli,itypj,fac,aad(itypj,iteli),
5495      &       bad(itypj,iteli)
5496 C
5497 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
5498 C
5499           fac=-(evdwij+e1)*rrij*sss
5500           fac=fac+(evdwij)*sssgrad*dsqrt(rrij)/expon
5501           ggg(1)=xj*fac
5502           ggg(2)=yj*fac
5503           ggg(3)=zj*fac
5504 cgrad          if (j.lt.i) then
5505 cd          write (iout,*) 'j<i'
5506 C Uncomment following three lines for SC-p interactions
5507 c           do k=1,3
5508 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
5509 c           enddo
5510 cgrad          else
5511 cd          write (iout,*) 'j>i'
5512 cgrad            do k=1,3
5513 cgrad              ggg(k)=-ggg(k)
5514 C Uncomment following line for SC-p interactions
5515 ccgrad             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
5516 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
5517 cgrad            enddo
5518 cgrad          endif
5519 cgrad          do k=1,3
5520 cgrad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
5521 cgrad          enddo
5522 cgrad          kstart=min0(i+1,j)
5523 cgrad          kend=max0(i-1,j-1)
5524 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
5525 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
5526 cgrad          do k=kstart,kend
5527 cgrad            do l=1,3
5528 cgrad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
5529 cgrad            enddo
5530 cgrad          enddo
5531           do k=1,3
5532             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
5533             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
5534           enddo
5535 c        endif !endif for sscale cutoff
5536         enddo ! j
5537
5538         enddo ! iint
5539       enddo ! i
5540 c      enddo !zshift
5541 c      enddo !yshift
5542 c      enddo !xshift
5543       do i=1,nct
5544         do j=1,3
5545           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
5546           gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
5547           gradx_scp(j,i)=expon*gradx_scp(j,i)
5548         enddo
5549       enddo
5550 C******************************************************************************
5551 C
5552 C                              N O T E !!!
5553 C
5554 C To save time the factor EXPON has been extracted from ALL components
5555 C of GVDWC and GRADX. Remember to multiply them by this factor before further
5556 C use!
5557 C
5558 C******************************************************************************
5559       return
5560       end
5561 C--------------------------------------------------------------------------
5562       subroutine edis(ehpb)
5563 C
5564 C Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors.
5565 C
5566       implicit real*8 (a-h,o-z)
5567       include 'DIMENSIONS'
5568       include 'COMMON.SBRIDGE'
5569       include 'COMMON.CHAIN'
5570       include 'COMMON.DERIV'
5571       include 'COMMON.VAR'
5572       include 'COMMON.INTERACT'
5573       include 'COMMON.IOUNITS'
5574       include 'COMMON.CONTROL'
5575       dimension ggg(3)
5576       ehpb=0.0D0
5577       do i=1,3
5578        ggg(i)=0.0d0
5579       enddo
5580 C      write (iout,*) ,"link_end",link_end,constr_dist
5581 cd      write(iout,*)'edis: nhpb=',nhpb,' fbr=',fbr
5582 cd      write(iout,*)'link_start=',link_start,' link_end=',link_end
5583       if (link_end.eq.0) return
5584       do i=link_start,link_end
5585 C If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a
5586 C CA-CA distance used in regularization of structure.
5587         ii=ihpb(i)
5588         jj=jhpb(i)
5589 C iii and jjj point to the residues for which the distance is assigned.
5590         if (ii.gt.nres) then
5591           iii=ii-nres
5592           jjj=jj-nres
5593         else
5594           iii=ii
5595           jjj=jj
5596         endif
5597 c        write (iout,*) "i",i," ii",ii," iii",iii," jj",jj," jjj",jjj,
5598 c     &    dhpb(i),dhpb1(i),forcon(i)
5599 C 24/11/03 AL: SS bridges handled separately because of introducing a specific
5600 C    distance and angle dependent SS bond potential.
5601 C        if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and.
5602 C     & iabs(itype(jjj)).eq.1) then
5603 cmc        if (ii.gt.nres .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then
5604 C 18/07/06 MC: Use the convention that the first nss pairs are SS bonds
5605         if (.not.dyn_ss .and. i.le.nss) then
5606 C 15/02/13 CC dynamic SSbond - additional check
5607          if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and.
5608      & iabs(itype(jjj)).eq.1) then
5609           call ssbond_ene(iii,jjj,eij)
5610           ehpb=ehpb+2*eij
5611          endif
5612 cd          write (iout,*) "eij",eij
5613 cd   &   ' waga=',waga,' fac=',fac
5614         else if (ii.gt.nres .and. jj.gt.nres) then
5615 c Restraints from contact prediction
5616           dd=dist(ii,jj)
5617           if (constr_dist.eq.11) then
5618             ehpb=ehpb+fordepth(i)**4.0d0
5619      &          *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i))
5620             fac=fordepth(i)**4.0d0
5621      &          *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd
5622           if (energy_dec) write (iout,'(a6,2i5,3f8.3)') "edisl",ii,jj,
5623      &    ehpb,fordepth(i),dd
5624            else
5625           if (dhpb1(i).gt.0.0d0) then
5626             ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
5627             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
5628 c            write (iout,*) "beta nmr",
5629 c     &        dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
5630           else
5631             dd=dist(ii,jj)
5632             rdis=dd-dhpb(i)
5633 C Get the force constant corresponding to this distance.
5634             waga=forcon(i)
5635 C Calculate the contribution to energy.
5636             ehpb=ehpb+waga*rdis*rdis
5637 c            write (iout,*) "beta reg",dd,waga*rdis*rdis
5638 C
5639 C Evaluate gradient.
5640 C
5641             fac=waga*rdis/dd
5642           endif
5643           endif
5644           do j=1,3
5645             ggg(j)=fac*(c(j,jj)-c(j,ii))
5646           enddo
5647           do j=1,3
5648             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
5649             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
5650           enddo
5651           do k=1,3
5652             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
5653             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
5654           enddo
5655         else
5656 C Calculate the distance between the two points and its difference from the
5657 C target distance.
5658           dd=dist(ii,jj)
5659           if (constr_dist.eq.11) then
5660             ehpb=ehpb+fordepth(i)**4.0d0
5661      &           *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i))
5662             fac=fordepth(i)**4.0d0
5663      &           *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd
5664           if (energy_dec) write (iout,'(a6,2i5,3f8.3)') "edisl",ii,jj,
5665      &    ehpb,fordepth(i),dd
5666            else
5667           if (dhpb1(i).gt.0.0d0) then
5668             ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
5669             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
5670 c            write (iout,*) "alph nmr",
5671 c     &        dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
5672           else
5673             rdis=dd-dhpb(i)
5674 C Get the force constant corresponding to this distance.
5675             waga=forcon(i)
5676 C Calculate the contribution to energy.
5677             ehpb=ehpb+waga*rdis*rdis
5678 c            write (iout,*) "alpha reg",dd,waga*rdis*rdis
5679 C
5680 C Evaluate gradient.
5681 C
5682             fac=waga*rdis/dd
5683           endif
5684           endif
5685             do j=1,3
5686               ggg(j)=fac*(c(j,jj)-c(j,ii))
5687             enddo
5688 cd      print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
5689 C If this is a SC-SC distance, we need to calculate the contributions to the
5690 C Cartesian gradient in the SC vectors (ghpbx).
5691           if (iii.lt.ii) then
5692           do j=1,3
5693             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
5694             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
5695           enddo
5696           endif
5697 cgrad        do j=iii,jjj-1
5698 cgrad          do k=1,3
5699 cgrad            ghpbc(k,j)=ghpbc(k,j)+ggg(k)
5700 cgrad          enddo
5701 cgrad        enddo
5702           do k=1,3
5703             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
5704             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
5705           enddo
5706         endif
5707       enddo
5708       if (constr_dist.ne.11) ehpb=0.5D0*ehpb
5709       return
5710       end
5711 C--------------------------------------------------------------------------
5712       subroutine ssbond_ene(i,j,eij)
5713 C
5714 C Calculate the distance and angle dependent SS-bond potential energy
5715 C using a free-energy function derived based on RHF/6-31G** ab initio
5716 C calculations of diethyl disulfide.
5717 C
5718 C A. Liwo and U. Kozlowska, 11/24/03
5719 C
5720       implicit real*8 (a-h,o-z)
5721       include 'DIMENSIONS'
5722       include 'COMMON.SBRIDGE'
5723       include 'COMMON.CHAIN'
5724       include 'COMMON.DERIV'
5725       include 'COMMON.LOCAL'
5726       include 'COMMON.INTERACT'
5727       include 'COMMON.VAR'
5728       include 'COMMON.IOUNITS'
5729       double precision erij(3),dcosom1(3),dcosom2(3),gg(3)
5730       itypi=iabs(itype(i))
5731       xi=c(1,nres+i)
5732       yi=c(2,nres+i)
5733       zi=c(3,nres+i)
5734       dxi=dc_norm(1,nres+i)
5735       dyi=dc_norm(2,nres+i)
5736       dzi=dc_norm(3,nres+i)
5737 c      dsci_inv=dsc_inv(itypi)
5738       dsci_inv=vbld_inv(nres+i)
5739       itypj=iabs(itype(j))
5740 c      dscj_inv=dsc_inv(itypj)
5741       dscj_inv=vbld_inv(nres+j)
5742       xj=c(1,nres+j)-xi
5743       yj=c(2,nres+j)-yi
5744       zj=c(3,nres+j)-zi
5745       dxj=dc_norm(1,nres+j)
5746       dyj=dc_norm(2,nres+j)
5747       dzj=dc_norm(3,nres+j)
5748       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
5749       rij=dsqrt(rrij)
5750       erij(1)=xj*rij
5751       erij(2)=yj*rij
5752       erij(3)=zj*rij
5753       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
5754       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
5755       om12=dxi*dxj+dyi*dyj+dzi*dzj
5756       do k=1,3
5757         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
5758         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
5759       enddo
5760       rij=1.0d0/rij
5761       deltad=rij-d0cm
5762       deltat1=1.0d0-om1
5763       deltat2=1.0d0+om2
5764       deltat12=om2-om1+2.0d0
5765       cosphi=om12-om1*om2
5766       eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2)
5767      &  +akct*deltad*deltat12
5768      &  +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi+ebr
5769 c      write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth,
5770 c     &  " akct",akct," deltad",deltad," deltat",deltat1,deltat2,
5771 c     &  " deltat12",deltat12," eij",eij
5772       ed=2*akcm*deltad+akct*deltat12
5773       pom1=akct*deltad
5774       pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
5775       eom1=-2*akth*deltat1-pom1-om2*pom2
5776       eom2= 2*akth*deltat2+pom1-om1*pom2
5777       eom12=pom2
5778       do k=1,3
5779         ggk=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
5780         ghpbx(k,i)=ghpbx(k,i)-ggk
5781      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
5782      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
5783         ghpbx(k,j)=ghpbx(k,j)+ggk
5784      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
5785      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
5786         ghpbc(k,i)=ghpbc(k,i)-ggk
5787         ghpbc(k,j)=ghpbc(k,j)+ggk
5788       enddo
5789 C
5790 C Calculate the components of the gradient in DC and X
5791 C
5792 cgrad      do k=i,j-1
5793 cgrad        do l=1,3
5794 cgrad          ghpbc(l,k)=ghpbc(l,k)+gg(l)
5795 cgrad        enddo
5796 cgrad      enddo
5797       return
5798       end
5799 C--------------------------------------------------------------------------
5800       subroutine ebond(estr)
5801 c
5802 c Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
5803 c
5804       implicit real*8 (a-h,o-z)
5805       include 'DIMENSIONS'
5806       include 'COMMON.LOCAL'
5807       include 'COMMON.GEO'
5808       include 'COMMON.INTERACT'
5809       include 'COMMON.DERIV'
5810       include 'COMMON.VAR'
5811       include 'COMMON.CHAIN'
5812       include 'COMMON.IOUNITS'
5813       include 'COMMON.NAMES'
5814       include 'COMMON.FFIELD'
5815       include 'COMMON.CONTROL'
5816       include 'COMMON.SETUP'
5817       double precision u(3),ud(3)
5818       estr=0.0d0
5819       estr1=0.0d0
5820       do i=ibondp_start,ibondp_end
5821         if (itype(i-1).eq.ntyp1 .and. itype(i).eq.ntyp1) cycle
5822 c          estr1=estr1+gnmr1(vbld(i),-1.0d0,distchainmax)
5823 c          do j=1,3
5824 c          gradb(j,i-1)=gnmr1prim(vbld(i),-1.0d0,distchainmax)
5825 c     &      *dc(j,i-1)/vbld(i)
5826 c          enddo
5827 c          if (energy_dec) write(iout,*)
5828 c     &       "estr1",i,gnmr1(vbld(i),-1.0d0,distchainmax)
5829 c        else
5830 C       Checking if it involves dummy (NH3+ or COO-) group
5831          if (itype(i-1).eq.ntyp1 .or. itype(i).eq.ntyp1) then
5832 C YES   vbldpDUM is the equlibrium length of spring for Dummy atom
5833         diff = vbld(i)-vbldpDUM
5834          else
5835 C NO    vbldp0 is the equlibrium lenght of spring for peptide group
5836         diff = vbld(i)-vbldp0
5837          endif
5838         if (energy_dec)    write (iout,'(a7,i5,4f7.3)')
5839      &     "estr bb",i,vbld(i),vbldp0,diff,AKP*diff*diff
5840         estr=estr+diff*diff
5841         do j=1,3
5842           gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)
5843         enddo
5844 c        write (iout,'(i5,3f10.5)') i,(gradb(j,i-1),j=1,3)
5845 c        endif
5846       enddo
5847       estr=0.5d0*AKP*estr+estr1
5848 c
5849 c 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included
5850 c
5851       do i=ibond_start,ibond_end
5852         iti=iabs(itype(i))
5853         if (iti.ne.10 .and. iti.ne.ntyp1) then
5854           nbi=nbondterm(iti)
5855           if (nbi.eq.1) then
5856             diff=vbld(i+nres)-vbldsc0(1,iti)
5857             if (energy_dec)  write (iout,*)
5858      &      "estr sc",i,iti,vbld(i+nres),vbldsc0(1,iti),diff,
5859      &      AKSC(1,iti),AKSC(1,iti)*diff*diff
5860             estr=estr+0.5d0*AKSC(1,iti)*diff*diff
5861             do j=1,3
5862               gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
5863             enddo
5864           else
5865             do j=1,nbi
5866               diff=vbld(i+nres)-vbldsc0(j,iti)
5867               ud(j)=aksc(j,iti)*diff
5868               u(j)=abond0(j,iti)+0.5d0*ud(j)*diff
5869             enddo
5870             uprod=u(1)
5871             do j=2,nbi
5872               uprod=uprod*u(j)
5873             enddo
5874             usum=0.0d0
5875             usumsqder=0.0d0
5876             do j=1,nbi
5877               uprod1=1.0d0
5878               uprod2=1.0d0
5879               do k=1,nbi
5880                 if (k.ne.j) then
5881                   uprod1=uprod1*u(k)
5882                   uprod2=uprod2*u(k)*u(k)
5883                 endif
5884               enddo
5885               usum=usum+uprod1
5886               usumsqder=usumsqder+ud(j)*uprod2
5887             enddo
5888             estr=estr+uprod/usum
5889             do j=1,3
5890              gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
5891             enddo
5892           endif
5893         endif
5894       enddo
5895       return
5896       end
5897 #ifdef CRYST_THETA
5898 C--------------------------------------------------------------------------
5899       subroutine ebend(etheta,ethetacnstr)
5900 C
5901 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
5902 C angles gamma and its derivatives in consecutive thetas and gammas.
5903 C
5904       implicit real*8 (a-h,o-z)
5905       include 'DIMENSIONS'
5906       include 'COMMON.LOCAL'
5907       include 'COMMON.GEO'
5908       include 'COMMON.INTERACT'
5909       include 'COMMON.DERIV'
5910       include 'COMMON.VAR'
5911       include 'COMMON.CHAIN'
5912       include 'COMMON.IOUNITS'
5913       include 'COMMON.NAMES'
5914       include 'COMMON.FFIELD'
5915       include 'COMMON.CONTROL'
5916       include 'COMMON.TORCNSTR'
5917       common /calcthet/ term1,term2,termm,diffak,ratak,
5918      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
5919      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
5920       double precision y(2),z(2)
5921       delta=0.02d0*pi
5922 c      time11=dexp(-2*time)
5923 c      time12=1.0d0
5924       etheta=0.0D0
5925 c     write (*,'(a,i2)') 'EBEND ICG=',icg
5926       do i=ithet_start,ithet_end
5927         if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
5928      &  .or.itype(i).eq.ntyp1) cycle
5929 C Zero the energy function and its derivative at 0 or pi.
5930         call splinthet(theta(i),0.5d0*delta,ss,ssd)
5931         it=itype(i-1)
5932         ichir1=isign(1,itype(i-2))
5933         ichir2=isign(1,itype(i))
5934          if (itype(i-2).eq.10) ichir1=isign(1,itype(i-1))
5935          if (itype(i).eq.10) ichir2=isign(1,itype(i-1))
5936          if (itype(i-1).eq.10) then
5937           itype1=isign(10,itype(i-2))
5938           ichir11=isign(1,itype(i-2))
5939           ichir12=isign(1,itype(i-2))
5940           itype2=isign(10,itype(i))
5941           ichir21=isign(1,itype(i))
5942           ichir22=isign(1,itype(i))
5943          endif
5944
5945         if (i.gt.3 .and. itype(i-3).ne.ntyp1) then
5946 #ifdef OSF
5947           phii=phi(i)
5948           if (phii.ne.phii) phii=150.0
5949 #else
5950           phii=phi(i)
5951 #endif
5952           y(1)=dcos(phii)
5953           y(2)=dsin(phii)
5954         else
5955           y(1)=0.0D0
5956           y(2)=0.0D0
5957         endif
5958         if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
5959 #ifdef OSF
5960           phii1=phi(i+1)
5961           if (phii1.ne.phii1) phii1=150.0
5962           phii1=pinorm(phii1)
5963           z(1)=cos(phii1)
5964 #else
5965           phii1=phi(i+1)
5966 #endif
5967           z(1)=dcos(phii1)
5968           z(2)=dsin(phii1)
5969         else
5970           z(1)=0.0D0
5971           z(2)=0.0D0
5972         endif
5973 C Calculate the "mean" value of theta from the part of the distribution
5974 C dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2).
5975 C In following comments this theta will be referred to as t_c.
5976         thet_pred_mean=0.0d0
5977         do k=1,2
5978             athetk=athet(k,it,ichir1,ichir2)
5979             bthetk=bthet(k,it,ichir1,ichir2)
5980           if (it.eq.10) then
5981              athetk=athet(k,itype1,ichir11,ichir12)
5982              bthetk=bthet(k,itype2,ichir21,ichir22)
5983           endif
5984          thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k)
5985 c         write(iout,*) 'chuj tu', y(k),z(k)
5986         enddo
5987         dthett=thet_pred_mean*ssd
5988         thet_pred_mean=thet_pred_mean*ss+a0thet(it)
5989 C Derivatives of the "mean" values in gamma1 and gamma2.
5990         dthetg1=(-athet(1,it,ichir1,ichir2)*y(2)
5991      &+athet(2,it,ichir1,ichir2)*y(1))*ss
5992          dthetg2=(-bthet(1,it,ichir1,ichir2)*z(2)
5993      &          +bthet(2,it,ichir1,ichir2)*z(1))*ss
5994          if (it.eq.10) then
5995       dthetg1=(-athet(1,itype1,ichir11,ichir12)*y(2)
5996      &+athet(2,itype1,ichir11,ichir12)*y(1))*ss
5997         dthetg2=(-bthet(1,itype2,ichir21,ichir22)*z(2)
5998      &         +bthet(2,itype2,ichir21,ichir22)*z(1))*ss
5999          endif
6000         if (theta(i).gt.pi-delta) then
6001           call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,
6002      &         E_tc0)
6003           call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0)
6004           call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
6005           call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,
6006      &        E_theta)
6007           call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,
6008      &        E_tc)
6009         else if (theta(i).lt.delta) then
6010           call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0)
6011           call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
6012           call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,
6013      &        E_theta)
6014           call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0)
6015           call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,
6016      &        E_tc)
6017         else
6018           call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,
6019      &        E_theta,E_tc)
6020         endif
6021         etheta=etheta+ethetai
6022         if (energy_dec) write (iout,'(a6,i5,0pf7.3,f7.3,i5)')
6023      &      'ebend',i,ethetai,theta(i),itype(i)
6024         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1
6025         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2
6026         gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)+gloc(nphi+i-2,icg)
6027       enddo
6028       ethetacnstr=0.0d0
6029 C      print *,ithetaconstr_start,ithetaconstr_end,"TU"
6030       do i=ithetaconstr_start,ithetaconstr_end
6031         itheta=itheta_constr(i)
6032         thetiii=theta(itheta)
6033         difi=pinorm(thetiii-theta_constr0(i))
6034         if (difi.gt.theta_drange(i)) then
6035           difi=difi-theta_drange(i)
6036           ethetacnstr=ethetcnstr+0.25d0*for_thet_constr(i)*difi**4
6037           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
6038      &    +for_thet_constr(i)*difi**3
6039         else if (difi.lt.-drange(i)) then
6040           difi=difi+drange(i)
6041           ethetacnstr=ethetcnstr+0.25d0*for_thet_constr(i)*difi**4
6042           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
6043      &    +for_thet_constr(i)*difi**3
6044         else
6045           difi=0.0
6046         endif
6047        if (energy_dec) then
6048         write (iout,'(a6,2i5,4f8.3,2e14.5)') "ethetc",
6049      &    i,itheta,rad2deg*thetiii,
6050      &    rad2deg*theta_constr0(i),  rad2deg*theta_drange(i),
6051      &    rad2deg*difi,0.25d0*for_thet_constr(i)*difi**4,
6052      &    gloc(itheta+nphi-2,icg)
6053         endif
6054       enddo
6055
6056 C Ufff.... We've done all this!!!
6057       return
6058       end
6059 C---------------------------------------------------------------------------
6060       subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,
6061      &     E_tc)
6062       implicit real*8 (a-h,o-z)
6063       include 'DIMENSIONS'
6064       include 'COMMON.LOCAL'
6065       include 'COMMON.IOUNITS'
6066       common /calcthet/ term1,term2,termm,diffak,ratak,
6067      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
6068      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
6069 C Calculate the contributions to both Gaussian lobes.
6070 C 6/6/97 - Deform the Gaussians using the factor of 1/(1+time)
6071 C The "polynomial part" of the "standard deviation" of this part of
6072 C the distributioni.
6073 ccc        write (iout,*) thetai,thet_pred_mean
6074         sig=polthet(3,it)
6075         do j=2,0,-1
6076           sig=sig*thet_pred_mean+polthet(j,it)
6077         enddo
6078 C Derivative of the "interior part" of the "standard deviation of the"
6079 C gamma-dependent Gaussian lobe in t_c.
6080         sigtc=3*polthet(3,it)
6081         do j=2,1,-1
6082           sigtc=sigtc*thet_pred_mean+j*polthet(j,it)
6083         enddo
6084         sigtc=sig*sigtc
6085 C Set the parameters of both Gaussian lobes of the distribution.
6086 C "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc)
6087         fac=sig*sig+sigc0(it)
6088         sigcsq=fac+fac
6089         sigc=1.0D0/sigcsq
6090 C Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c
6091         sigsqtc=-4.0D0*sigcsq*sigtc
6092 c       print *,i,sig,sigtc,sigsqtc
6093 C Following variable (sigtc) is d[sigma(t_c)]/dt_c
6094         sigtc=-sigtc/(fac*fac)
6095 C Following variable is sigma(t_c)**(-2)
6096         sigcsq=sigcsq*sigcsq
6097         sig0i=sig0(it)
6098         sig0inv=1.0D0/sig0i**2
6099         delthec=thetai-thet_pred_mean
6100         delthe0=thetai-theta0i
6101         term1=-0.5D0*sigcsq*delthec*delthec
6102         term2=-0.5D0*sig0inv*delthe0*delthe0
6103 C        write (iout,*)'term1',term1,term2,sigcsq,delthec,sig0inv,delthe0
6104 C Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and
6105 C NaNs in taking the logarithm. We extract the largest exponent which is added
6106 C to the energy (this being the log of the distribution) at the end of energy
6107 C term evaluation for this virtual-bond angle.
6108         if (term1.gt.term2) then
6109           termm=term1
6110           term2=dexp(term2-termm)
6111           term1=1.0d0
6112         else
6113           termm=term2
6114           term1=dexp(term1-termm)
6115           term2=1.0d0
6116         endif
6117 C The ratio between the gamma-independent and gamma-dependent lobes of
6118 C the distribution is a Gaussian function of thet_pred_mean too.
6119         diffak=gthet(2,it)-thet_pred_mean
6120         ratak=diffak/gthet(3,it)**2
6121         ak=dexp(gthet(1,it)-0.5D0*diffak*ratak)
6122 C Let's differentiate it in thet_pred_mean NOW.
6123         aktc=ak*ratak
6124 C Now put together the distribution terms to make complete distribution.
6125         termexp=term1+ak*term2
6126         termpre=sigc+ak*sig0i
6127 C Contribution of the bending energy from this theta is just the -log of
6128 C the sum of the contributions from the two lobes and the pre-exponential
6129 C factor. Simple enough, isn't it?
6130         ethetai=(-dlog(termexp)-termm+dlog(termpre))
6131 C       write (iout,*) 'termexp',termexp,termm,termpre,i
6132 C NOW the derivatives!!!
6133 C 6/6/97 Take into account the deformation.
6134         E_theta=(delthec*sigcsq*term1
6135      &       +ak*delthe0*sig0inv*term2)/termexp
6136         E_tc=((sigtc+aktc*sig0i)/termpre
6137      &      -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+
6138      &       aktc*term2)/termexp)
6139       return
6140       end
6141 c-----------------------------------------------------------------------------
6142       subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)
6143       implicit real*8 (a-h,o-z)
6144       include 'DIMENSIONS'
6145       include 'COMMON.LOCAL'
6146       include 'COMMON.IOUNITS'
6147       common /calcthet/ term1,term2,termm,diffak,ratak,
6148      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
6149      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
6150       delthec=thetai-thet_pred_mean
6151       delthe0=thetai-theta0i
6152 C "Thank you" to MAPLE (probably spared one day of hand-differentiation).
6153       t3 = thetai-thet_pred_mean
6154       t6 = t3**2
6155       t9 = term1
6156       t12 = t3*sigcsq
6157       t14 = t12+t6*sigsqtc
6158       t16 = 1.0d0
6159       t21 = thetai-theta0i
6160       t23 = t21**2
6161       t26 = term2
6162       t27 = t21*t26
6163       t32 = termexp
6164       t40 = t32**2
6165       E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9
6166      & -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40
6167      & *(-t12*t9-ak*sig0inv*t27)
6168       return
6169       end
6170 #else
6171 C--------------------------------------------------------------------------
6172       subroutine ebend(etheta,ethetacnstr)
6173 C
6174 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
6175 C angles gamma and its derivatives in consecutive thetas and gammas.
6176 C ab initio-derived potentials from
6177 c Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203
6178 C
6179       implicit real*8 (a-h,o-z)
6180       include 'DIMENSIONS'
6181       include 'COMMON.LOCAL'
6182       include 'COMMON.GEO'
6183       include 'COMMON.INTERACT'
6184       include 'COMMON.DERIV'
6185       include 'COMMON.VAR'
6186       include 'COMMON.CHAIN'
6187       include 'COMMON.IOUNITS'
6188       include 'COMMON.NAMES'
6189       include 'COMMON.FFIELD'
6190       include 'COMMON.CONTROL'
6191       include 'COMMON.TORCNSTR'
6192       double precision coskt(mmaxtheterm),sinkt(mmaxtheterm),
6193      & cosph1(maxsingle),sinph1(maxsingle),cosph2(maxsingle),
6194      & sinph2(maxsingle),cosph1ph2(maxdouble,maxdouble),
6195      & sinph1ph2(maxdouble,maxdouble)
6196       logical lprn /.false./, lprn1 /.false./
6197       etheta=0.0D0
6198       do i=ithet_start,ithet_end
6199 c        print *,i,itype(i-1),itype(i),itype(i-2)
6200         if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
6201      &  .or.itype(i).eq.ntyp1) cycle
6202 C        print *,i,theta(i)
6203         if (iabs(itype(i+1)).eq.20) iblock=2
6204         if (iabs(itype(i+1)).ne.20) iblock=1
6205         dethetai=0.0d0
6206         dephii=0.0d0
6207         dephii1=0.0d0
6208         theti2=0.5d0*theta(i)
6209         ityp2=ithetyp((itype(i-1)))
6210         do k=1,nntheterm
6211           coskt(k)=dcos(k*theti2)
6212           sinkt(k)=dsin(k*theti2)
6213         enddo
6214 C        print *,ethetai
6215         if (i.gt.3 .and. itype(i-3).ne.ntyp1) then
6216 #ifdef OSF
6217           phii=phi(i)
6218           if (phii.ne.phii) phii=150.0
6219 #else
6220           phii=phi(i)
6221 #endif
6222           ityp1=ithetyp((itype(i-2)))
6223 C propagation of chirality for glycine type
6224           do k=1,nsingle
6225             cosph1(k)=dcos(k*phii)
6226             sinph1(k)=dsin(k*phii)
6227           enddo
6228         else
6229           phii=0.0d0
6230           do k=1,nsingle
6231           ityp1=ithetyp((itype(i-2)))
6232             cosph1(k)=0.0d0
6233             sinph1(k)=0.0d0
6234           enddo
6235         endif
6236         if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
6237 #ifdef OSF
6238           phii1=phi(i+1)
6239           if (phii1.ne.phii1) phii1=150.0
6240           phii1=pinorm(phii1)
6241 #else
6242           phii1=phi(i+1)
6243 #endif
6244           ityp3=ithetyp((itype(i)))
6245           do k=1,nsingle
6246             cosph2(k)=dcos(k*phii1)
6247             sinph2(k)=dsin(k*phii1)
6248           enddo
6249         else
6250           phii1=0.0d0
6251           ityp3=ithetyp((itype(i)))
6252           do k=1,nsingle
6253             cosph2(k)=0.0d0
6254             sinph2(k)=0.0d0
6255           enddo
6256         endif
6257         ethetai=aa0thet(ityp1,ityp2,ityp3,iblock)
6258         do k=1,ndouble
6259           do l=1,k-1
6260             ccl=cosph1(l)*cosph2(k-l)
6261             ssl=sinph1(l)*sinph2(k-l)
6262             scl=sinph1(l)*cosph2(k-l)
6263             csl=cosph1(l)*sinph2(k-l)
6264             cosph1ph2(l,k)=ccl-ssl
6265             cosph1ph2(k,l)=ccl+ssl
6266             sinph1ph2(l,k)=scl+csl
6267             sinph1ph2(k,l)=scl-csl
6268           enddo
6269         enddo
6270         if (lprn) then
6271         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,
6272      &    " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
6273         write (iout,*) "coskt and sinkt"
6274         do k=1,nntheterm
6275           write (iout,*) k,coskt(k),sinkt(k)
6276         enddo
6277         endif
6278         do k=1,ntheterm
6279           ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3,iblock)*sinkt(k)
6280           dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3,iblock)
6281      &      *coskt(k)
6282           if (lprn)
6283      &    write (iout,*) "k",k,"
6284      &     aathet",aathet(k,ityp1,ityp2,ityp3,iblock),
6285      &     " ethetai",ethetai
6286         enddo
6287         if (lprn) then
6288         write (iout,*) "cosph and sinph"
6289         do k=1,nsingle
6290           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
6291         enddo
6292         write (iout,*) "cosph1ph2 and sinph2ph2"
6293         do k=2,ndouble
6294           do l=1,k-1
6295             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),
6296      &         sinph1ph2(l,k),sinph1ph2(k,l)
6297           enddo
6298         enddo
6299         write(iout,*) "ethetai",ethetai
6300         endif
6301 C       print *,ethetai
6302         do m=1,ntheterm2
6303           do k=1,nsingle
6304             aux=bbthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)
6305      &         +ccthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k)
6306      &         +ddthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)
6307      &         +eethet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k)
6308             ethetai=ethetai+sinkt(m)*aux
6309             dethetai=dethetai+0.5d0*m*aux*coskt(m)
6310             dephii=dephii+k*sinkt(m)*(
6311      &          ccthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)-
6312      &          bbthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k))
6313             dephii1=dephii1+k*sinkt(m)*(
6314      &          eethet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)-
6315      &          ddthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k))
6316             if (lprn)
6317      &      write (iout,*) "m",m," k",k," bbthet",
6318      &         bbthet(k,m,ityp1,ityp2,ityp3,iblock)," ccthet",
6319      &         ccthet(k,m,ityp1,ityp2,ityp3,iblock)," ddthet",
6320      &         ddthet(k,m,ityp1,ityp2,ityp3,iblock)," eethet",
6321      &         eethet(k,m,ityp1,ityp2,ityp3,iblock)," ethetai",ethetai
6322 C        print *,"tu",cosph1(k),sinph1(k),cosph2(k),sinph2(k)
6323           enddo
6324         enddo
6325 C        print *,"cosph1", (cosph1(k), k=1,nsingle)
6326 C        print *,"cosph2", (cosph2(k), k=1,nsingle)
6327 C        print *,"sinph1", (sinph1(k), k=1,nsingle)
6328 C        print *,"sinph2", (sinph2(k), k=1,nsingle)
6329         if (lprn)
6330      &  write(iout,*) "ethetai",ethetai
6331 C        print *,"tu",cosph1(k),sinph1(k),cosph2(k),sinph2(k)
6332         do m=1,ntheterm3
6333           do k=2,ndouble
6334             do l=1,k-1
6335               aux=ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
6336      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l)+
6337      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
6338      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)
6339               ethetai=ethetai+sinkt(m)*aux
6340               dethetai=dethetai+0.5d0*m*coskt(m)*aux
6341               dephii=dephii+l*sinkt(m)*(
6342      &           -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)-
6343      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
6344      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
6345      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
6346               dephii1=dephii1+(k-l)*sinkt(m)*(
6347      &           -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
6348      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
6349      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)-
6350      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
6351               if (lprn) then
6352               write (iout,*) "m",m," k",k," l",l," ffthet",
6353      &            ffthet(l,k,m,ityp1,ityp2,ityp3,iblock),
6354      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)," ggthet",
6355      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock),
6356      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock),
6357      &            " ethetai",ethetai
6358               write (iout,*) cosph1ph2(l,k)*sinkt(m),
6359      &            cosph1ph2(k,l)*sinkt(m),
6360      &            sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
6361               endif
6362             enddo
6363           enddo
6364         enddo
6365 10      continue
6366 c        lprn1=.true.
6367 C        print *,ethetai
6368         if (lprn1)
6369      &    write (iout,'(i2,3f8.1,9h ethetai ,f10.5)')
6370      &   i,theta(i)*rad2deg,phii*rad2deg,
6371      &   phii1*rad2deg,ethetai
6372 c        lprn1=.false.
6373         etheta=etheta+ethetai
6374         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
6375         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
6376         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)+wang*dethetai
6377       enddo
6378 C now constrains
6379       ethetacnstr=0.0d0
6380 C      print *,ithetaconstr_start,ithetaconstr_end,"TU"
6381       do i=ithetaconstr_start,ithetaconstr_end
6382         itheta=itheta_constr(i)
6383         thetiii=theta(itheta)
6384         difi=pinorm(thetiii-theta_constr0(i))
6385         if (difi.gt.theta_drange(i)) then
6386           difi=difi-theta_drange(i)
6387           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
6388           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
6389      &    +for_thet_constr(i)*difi**3
6390         else if (difi.lt.-drange(i)) then
6391           difi=difi+drange(i)
6392           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
6393           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
6394      &    +for_thet_constr(i)*difi**3
6395         else
6396           difi=0.0
6397         endif
6398        if (energy_dec) then
6399         write (iout,'(a6,2i5,4f8.3,2e14.5)') "ethetc",
6400      &    i,itheta,rad2deg*thetiii,
6401      &    rad2deg*theta_constr0(i),  rad2deg*theta_drange(i),
6402      &    rad2deg*difi,0.25d0*for_thet_constr(i)*difi**4,
6403      &    gloc(itheta+nphi-2,icg)
6404         endif
6405       enddo
6406
6407       return
6408       end
6409 #endif
6410 #ifdef CRYST_SC
6411 c-----------------------------------------------------------------------------
6412       subroutine esc(escloc)
6413 C Calculate the local energy of a side chain and its derivatives in the
6414 C corresponding virtual-bond valence angles THETA and the spherical angles
6415 C ALPHA and OMEGA.
6416       implicit real*8 (a-h,o-z)
6417       include 'DIMENSIONS'
6418       include 'COMMON.GEO'
6419       include 'COMMON.LOCAL'
6420       include 'COMMON.VAR'
6421       include 'COMMON.INTERACT'
6422       include 'COMMON.DERIV'
6423       include 'COMMON.CHAIN'
6424       include 'COMMON.IOUNITS'
6425       include 'COMMON.NAMES'
6426       include 'COMMON.FFIELD'
6427       include 'COMMON.CONTROL'
6428       double precision x(3),dersc(3),xemp(3),dersc0(3),dersc1(3),
6429      &     ddersc0(3),ddummy(3),xtemp(3),temp(3)
6430       common /sccalc/ time11,time12,time112,theti,it,nlobit
6431       delta=0.02d0*pi
6432       escloc=0.0D0
6433 c     write (iout,'(a)') 'ESC'
6434       do i=loc_start,loc_end
6435         it=itype(i)
6436         if (it.eq.ntyp1) cycle
6437         if (it.eq.10) goto 1
6438         nlobit=nlob(iabs(it))
6439 c       print *,'i=',i,' it=',it,' nlobit=',nlobit
6440 c       write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
6441         theti=theta(i+1)-pipol
6442         x(1)=dtan(theti)
6443         x(2)=alph(i)
6444         x(3)=omeg(i)
6445
6446         if (x(2).gt.pi-delta) then
6447           xtemp(1)=x(1)
6448           xtemp(2)=pi-delta
6449           xtemp(3)=x(3)
6450           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
6451           xtemp(2)=pi
6452           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
6453           call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),
6454      &        escloci,dersc(2))
6455           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
6456      &        ddersc0(1),dersc(1))
6457           call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),
6458      &        ddersc0(3),dersc(3))
6459           xtemp(2)=pi-delta
6460           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
6461           xtemp(2)=pi
6462           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
6463           call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,
6464      &            dersc0(2),esclocbi,dersc02)
6465           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
6466      &            dersc12,dersc01)
6467           call splinthet(x(2),0.5d0*delta,ss,ssd)
6468           dersc0(1)=dersc01
6469           dersc0(2)=dersc02
6470           dersc0(3)=0.0d0
6471           do k=1,3
6472             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
6473           enddo
6474           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
6475 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
6476 c    &             esclocbi,ss,ssd
6477           escloci=ss*escloci+(1.0d0-ss)*esclocbi
6478 c         escloci=esclocbi
6479 c         write (iout,*) escloci
6480         else if (x(2).lt.delta) then
6481           xtemp(1)=x(1)
6482           xtemp(2)=delta
6483           xtemp(3)=x(3)
6484           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
6485           xtemp(2)=0.0d0
6486           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
6487           call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),
6488      &        escloci,dersc(2))
6489           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
6490      &        ddersc0(1),dersc(1))
6491           call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),
6492      &        ddersc0(3),dersc(3))
6493           xtemp(2)=delta
6494           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
6495           xtemp(2)=0.0d0
6496           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
6497           call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,
6498      &            dersc0(2),esclocbi,dersc02)
6499           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
6500      &            dersc12,dersc01)
6501           dersc0(1)=dersc01
6502           dersc0(2)=dersc02
6503           dersc0(3)=0.0d0
6504           call splinthet(x(2),0.5d0*delta,ss,ssd)
6505           do k=1,3
6506             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
6507           enddo
6508           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
6509 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
6510 c    &             esclocbi,ss,ssd
6511           escloci=ss*escloci+(1.0d0-ss)*esclocbi
6512 c         write (iout,*) escloci
6513         else
6514           call enesc(x,escloci,dersc,ddummy,.false.)
6515         endif
6516
6517         escloc=escloc+escloci
6518         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
6519      &     'escloc',i,escloci
6520 c       write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
6521
6522         gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
6523      &   wscloc*dersc(1)
6524         gloc(ialph(i,1),icg)=wscloc*dersc(2)
6525         gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
6526     1   continue
6527       enddo
6528       return
6529       end
6530 C---------------------------------------------------------------------------
6531       subroutine enesc(x,escloci,dersc,ddersc,mixed)
6532       implicit real*8 (a-h,o-z)
6533       include 'DIMENSIONS'
6534       include 'COMMON.GEO'
6535       include 'COMMON.LOCAL'
6536       include 'COMMON.IOUNITS'
6537       common /sccalc/ time11,time12,time112,theti,it,nlobit
6538       double precision x(3),z(3),Ax(3,maxlob,-1:1),dersc(3),ddersc(3)
6539       double precision contr(maxlob,-1:1)
6540       logical mixed
6541 c       write (iout,*) 'it=',it,' nlobit=',nlobit
6542         escloc_i=0.0D0
6543         do j=1,3
6544           dersc(j)=0.0D0
6545           if (mixed) ddersc(j)=0.0d0
6546         enddo
6547         x3=x(3)
6548
6549 C Because of periodicity of the dependence of the SC energy in omega we have
6550 C to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
6551 C To avoid underflows, first compute & store the exponents.
6552
6553         do iii=-1,1
6554
6555           x(3)=x3+iii*dwapi
6556
6557           do j=1,nlobit
6558             do k=1,3
6559               z(k)=x(k)-censc(k,j,it)
6560             enddo
6561             do k=1,3
6562               Axk=0.0D0
6563               do l=1,3
6564                 Axk=Axk+gaussc(l,k,j,it)*z(l)
6565               enddo
6566               Ax(k,j,iii)=Axk
6567             enddo
6568             expfac=0.0D0
6569             do k=1,3
6570               expfac=expfac+Ax(k,j,iii)*z(k)
6571             enddo
6572             contr(j,iii)=expfac
6573           enddo ! j
6574
6575         enddo ! iii
6576
6577         x(3)=x3
6578 C As in the case of ebend, we want to avoid underflows in exponentiation and
6579 C subsequent NaNs and INFs in energy calculation.
6580 C Find the largest exponent
6581         emin=contr(1,-1)
6582         do iii=-1,1
6583           do j=1,nlobit
6584             if (emin.gt.contr(j,iii)) emin=contr(j,iii)
6585           enddo
6586         enddo
6587         emin=0.5D0*emin
6588 cd      print *,'it=',it,' emin=',emin
6589
6590 C Compute the contribution to SC energy and derivatives
6591         do iii=-1,1
6592
6593           do j=1,nlobit
6594 #ifdef OSF
6595             adexp=bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin
6596             if(adexp.ne.adexp) adexp=1.0
6597             expfac=dexp(adexp)
6598 #else
6599             expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin)
6600 #endif
6601 cd          print *,'j=',j,' expfac=',expfac
6602             escloc_i=escloc_i+expfac
6603             do k=1,3
6604               dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
6605             enddo
6606             if (mixed) then
6607               do k=1,3,2
6608                 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii)
6609      &            +gaussc(k,2,j,it))*expfac
6610               enddo
6611             endif
6612           enddo
6613
6614         enddo ! iii
6615
6616         dersc(1)=dersc(1)/cos(theti)**2
6617         ddersc(1)=ddersc(1)/cos(theti)**2
6618         ddersc(3)=ddersc(3)
6619
6620         escloci=-(dlog(escloc_i)-emin)
6621         do j=1,3
6622           dersc(j)=dersc(j)/escloc_i
6623         enddo
6624         if (mixed) then
6625           do j=1,3,2
6626             ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
6627           enddo
6628         endif
6629       return
6630       end
6631 C------------------------------------------------------------------------------
6632       subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
6633       implicit real*8 (a-h,o-z)
6634       include 'DIMENSIONS'
6635       include 'COMMON.GEO'
6636       include 'COMMON.LOCAL'
6637       include 'COMMON.IOUNITS'
6638       common /sccalc/ time11,time12,time112,theti,it,nlobit
6639       double precision x(3),z(3),Ax(3,maxlob),dersc(3)
6640       double precision contr(maxlob)
6641       logical mixed
6642
6643       escloc_i=0.0D0
6644
6645       do j=1,3
6646         dersc(j)=0.0D0
6647       enddo
6648
6649       do j=1,nlobit
6650         do k=1,2
6651           z(k)=x(k)-censc(k,j,it)
6652         enddo
6653         z(3)=dwapi
6654         do k=1,3
6655           Axk=0.0D0
6656           do l=1,3
6657             Axk=Axk+gaussc(l,k,j,it)*z(l)
6658           enddo
6659           Ax(k,j)=Axk
6660         enddo
6661         expfac=0.0D0
6662         do k=1,3
6663           expfac=expfac+Ax(k,j)*z(k)
6664         enddo
6665         contr(j)=expfac
6666       enddo ! j
6667
6668 C As in the case of ebend, we want to avoid underflows in exponentiation and
6669 C subsequent NaNs and INFs in energy calculation.
6670 C Find the largest exponent
6671       emin=contr(1)
6672       do j=1,nlobit
6673         if (emin.gt.contr(j)) emin=contr(j)
6674       enddo
6675       emin=0.5D0*emin
6676
6677 C Compute the contribution to SC energy and derivatives
6678
6679       dersc12=0.0d0
6680       do j=1,nlobit
6681         expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j)+emin)
6682         escloc_i=escloc_i+expfac
6683         do k=1,2
6684           dersc(k)=dersc(k)+Ax(k,j)*expfac
6685         enddo
6686         if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j)
6687      &            +gaussc(1,2,j,it))*expfac
6688         dersc(3)=0.0d0
6689       enddo
6690
6691       dersc(1)=dersc(1)/cos(theti)**2
6692       dersc12=dersc12/cos(theti)**2
6693       escloci=-(dlog(escloc_i)-emin)
6694       do j=1,2
6695         dersc(j)=dersc(j)/escloc_i
6696       enddo
6697       if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
6698       return
6699       end
6700 #else
6701 c----------------------------------------------------------------------------------
6702       subroutine esc(escloc)
6703 C Calculate the local energy of a side chain and its derivatives in the
6704 C corresponding virtual-bond valence angles THETA and the spherical angles
6705 C ALPHA and OMEGA derived from AM1 all-atom calculations.
6706 C added by Urszula Kozlowska. 07/11/2007
6707 C
6708       implicit real*8 (a-h,o-z)
6709       include 'DIMENSIONS'
6710       include 'COMMON.GEO'
6711       include 'COMMON.LOCAL'
6712       include 'COMMON.VAR'
6713       include 'COMMON.SCROT'
6714       include 'COMMON.INTERACT'
6715       include 'COMMON.DERIV'
6716       include 'COMMON.CHAIN'
6717       include 'COMMON.IOUNITS'
6718       include 'COMMON.NAMES'
6719       include 'COMMON.FFIELD'
6720       include 'COMMON.CONTROL'
6721       include 'COMMON.VECTORS'
6722       double precision x_prime(3),y_prime(3),z_prime(3)
6723      &    , sumene,dsc_i,dp2_i,x(65),
6724      &     xx,yy,zz,sumene1,sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6,
6725      &    de_dxx,de_dyy,de_dzz,de_dt
6726       double precision s1_t,s1_6_t,s2_t,s2_6_t
6727       double precision
6728      & dXX_Ci1(3),dYY_Ci1(3),dZZ_Ci1(3),dXX_Ci(3),
6729      & dYY_Ci(3),dZZ_Ci(3),dXX_XYZ(3),dYY_XYZ(3),dZZ_XYZ(3),
6730      & dt_dCi(3),dt_dCi1(3)
6731       common /sccalc/ time11,time12,time112,theti,it,nlobit
6732       delta=0.02d0*pi
6733       escloc=0.0D0
6734       do i=loc_start,loc_end
6735         if (itype(i).eq.ntyp1) cycle
6736         costtab(i+1) =dcos(theta(i+1))
6737         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
6738         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
6739         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
6740         cosfac2=0.5d0/(1.0d0+costtab(i+1))
6741         cosfac=dsqrt(cosfac2)
6742         sinfac2=0.5d0/(1.0d0-costtab(i+1))
6743         sinfac=dsqrt(sinfac2)
6744         it=iabs(itype(i))
6745         if (it.eq.10) goto 1
6746 c
6747 C  Compute the axes of tghe local cartesian coordinates system; store in
6748 c   x_prime, y_prime and z_prime
6749 c
6750         do j=1,3
6751           x_prime(j) = 0.00
6752           y_prime(j) = 0.00
6753           z_prime(j) = 0.00
6754         enddo
6755 C        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
6756 C     &   dc_norm(3,i+nres)
6757         do j = 1,3
6758           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
6759           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
6760         enddo
6761         do j = 1,3
6762           z_prime(j) = -uz(j,i-1)*dsign(1.0d0,dfloat(itype(i)))
6763         enddo
6764 c       write (2,*) "i",i
6765 c       write (2,*) "x_prime",(x_prime(j),j=1,3)
6766 c       write (2,*) "y_prime",(y_prime(j),j=1,3)
6767 c       write (2,*) "z_prime",(z_prime(j),j=1,3)
6768 c       write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
6769 c      & " xy",scalar(x_prime(1),y_prime(1)),
6770 c      & " xz",scalar(x_prime(1),z_prime(1)),
6771 c      & " yy",scalar(y_prime(1),y_prime(1)),
6772 c      & " yz",scalar(y_prime(1),z_prime(1)),
6773 c      & " zz",scalar(z_prime(1),z_prime(1))
6774 c
6775 C Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
6776 C to local coordinate system. Store in xx, yy, zz.
6777 c
6778         xx=0.0d0
6779         yy=0.0d0
6780         zz=0.0d0
6781         do j = 1,3
6782           xx = xx + x_prime(j)*dc_norm(j,i+nres)
6783           yy = yy + y_prime(j)*dc_norm(j,i+nres)
6784           zz = zz + z_prime(j)*dc_norm(j,i+nres)
6785         enddo
6786
6787         xxtab(i)=xx
6788         yytab(i)=yy
6789         zztab(i)=zz
6790 C
6791 C Compute the energy of the ith side cbain
6792 C
6793 c        write (2,*) "xx",xx," yy",yy," zz",zz
6794         it=iabs(itype(i))
6795         do j = 1,65
6796           x(j) = sc_parmin(j,it)
6797         enddo
6798 #ifdef CHECK_COORD
6799 Cc diagnostics - remove later
6800         xx1 = dcos(alph(2))
6801         yy1 = dsin(alph(2))*dcos(omeg(2))
6802         zz1 = -dsign(1.0,dfloat(itype(i)))*dsin(alph(2))*dsin(omeg(2))
6803         write(2,'(3f8.1,3f9.3,1x,3f9.3)')
6804      &    alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,
6805      &    xx1,yy1,zz1
6806 C,"  --- ", xx_w,yy_w,zz_w
6807 c end diagnostics
6808 #endif
6809         sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
6810      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
6811      &   + x(10)*yy*zz
6812         sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
6813      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
6814      & + x(20)*yy*zz
6815         sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
6816      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
6817      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
6818      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
6819      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
6820      &  +x(40)*xx*yy*zz
6821         sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
6822      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
6823      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
6824      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
6825      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
6826      &  +x(60)*xx*yy*zz
6827         dsc_i   = 0.743d0+x(61)
6828         dp2_i   = 1.9d0+x(62)
6829         dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
6830      &          *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
6831         dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
6832      &          *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
6833         s1=(1+x(63))/(0.1d0 + dscp1)
6834         s1_6=(1+x(64))/(0.1d0 + dscp1**6)
6835         s2=(1+x(65))/(0.1d0 + dscp2)
6836         s2_6=(1+x(65))/(0.1d0 + dscp2**6)
6837         sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6)
6838      & + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
6839 c        write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
6840 c     &   sumene4,
6841 c     &   dscp1,dscp2,sumene
6842 c        sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6843         escloc = escloc + sumene
6844 c        write (2,*) "i",i," escloc",sumene,escloc,it,itype(i)
6845 c     & ,zz,xx,yy
6846 c#define DEBUG
6847 #ifdef DEBUG
6848 C
6849 C This section to check the numerical derivatives of the energy of ith side
6850 C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
6851 C #define DEBUG in the code to turn it on.
6852 C
6853         write (2,*) "sumene               =",sumene
6854         aincr=1.0d-7
6855         xxsave=xx
6856         xx=xx+aincr
6857         write (2,*) xx,yy,zz
6858         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6859         de_dxx_num=(sumenep-sumene)/aincr
6860         xx=xxsave
6861         write (2,*) "xx+ sumene from enesc=",sumenep
6862         yysave=yy
6863         yy=yy+aincr
6864         write (2,*) xx,yy,zz
6865         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6866         de_dyy_num=(sumenep-sumene)/aincr
6867         yy=yysave
6868         write (2,*) "yy+ sumene from enesc=",sumenep
6869         zzsave=zz
6870         zz=zz+aincr
6871         write (2,*) xx,yy,zz
6872         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6873         de_dzz_num=(sumenep-sumene)/aincr
6874         zz=zzsave
6875         write (2,*) "zz+ sumene from enesc=",sumenep
6876         costsave=cost2tab(i+1)
6877         sintsave=sint2tab(i+1)
6878         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
6879         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
6880         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6881         de_dt_num=(sumenep-sumene)/aincr
6882         write (2,*) " t+ sumene from enesc=",sumenep
6883         cost2tab(i+1)=costsave
6884         sint2tab(i+1)=sintsave
6885 C End of diagnostics section.
6886 #endif
6887 C
6888 C Compute the gradient of esc
6889 C
6890 c        zz=zz*dsign(1.0,dfloat(itype(i)))
6891         pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
6892         pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
6893         pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
6894         pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
6895         pom_dx=dsc_i*dp2_i*cost2tab(i+1)
6896         pom_dy=dsc_i*dp2_i*sint2tab(i+1)
6897         pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
6898         pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
6899         pom1=(sumene3*sint2tab(i+1)+sumene1)
6900      &     *(pom_s1/dscp1+pom_s16*dscp1**4)
6901         pom2=(sumene4*cost2tab(i+1)+sumene2)
6902      &     *(pom_s2/dscp2+pom_s26*dscp2**4)
6903         sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
6904         sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2
6905      &  +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2)
6906      &  +x(40)*yy*zz
6907         sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
6908         sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2
6909      &  +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2)
6910      &  +x(60)*yy*zz
6911         de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6)
6912      &        +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6)
6913      &        +(pom1+pom2)*pom_dx
6914 #ifdef DEBUG
6915         write(2,*), "de_dxx = ", de_dxx,de_dxx_num,itype(i)
6916 #endif
6917 C
6918         sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
6919         sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2
6920      &  +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2)
6921      &  +x(40)*xx*zz
6922         sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
6923         sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz
6924      &  +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz
6925      &  +x(59)*zz**2 +x(60)*xx*zz
6926         de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6)
6927      &        +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6)
6928      &        +(pom1-pom2)*pom_dy
6929 #ifdef DEBUG
6930         write(2,*), "de_dyy = ", de_dyy,de_dyy_num,itype(i)
6931 #endif
6932 C
6933         de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy
6934      &  +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx
6935      &  +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6)
6936      &  +(x(4) + 2*x(7)*zz+  x(8)*xx + x(10)*yy)*(s1+s1_6)
6937      &  +(x(44)+2*x(47)*zz +x(48)*xx   +x(50)*yy  +3*x(53)*zz**2
6938      &  +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy
6939      &  +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6)
6940      &  + ( x(14) + 2*x(17)*zz+  x(18)*xx + x(20)*yy)*(s2+s2_6)
6941 #ifdef DEBUG
6942         write(2,*), "de_dzz = ", de_dzz,de_dzz_num,itype(i)
6943 #endif
6944 C
6945         de_dt =  0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6)
6946      &  -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6)
6947      &  +pom1*pom_dt1+pom2*pom_dt2
6948 #ifdef DEBUG
6949         write(2,*), "de_dt = ", de_dt,de_dt_num,itype(i)
6950 #endif
6951 c#undef DEBUG
6952 c
6953 C
6954        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
6955        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
6956        cosfac2xx=cosfac2*xx
6957        sinfac2yy=sinfac2*yy
6958        do k = 1,3
6959          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))*
6960      &      vbld_inv(i+1)
6961          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))*
6962      &      vbld_inv(i)
6963          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
6964          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
6965 c         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
6966 c     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
6967 c         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
6968 c     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
6969          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
6970          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
6971          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
6972          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
6973          dZZ_Ci1(k)=0.0d0
6974          dZZ_Ci(k)=0.0d0
6975          do j=1,3
6976            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)
6977      &     *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
6978            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)
6979      &     *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
6980          enddo
6981
6982          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
6983          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
6984          dZZ_XYZ(k)=vbld_inv(i+nres)*
6985      &   (z_prime(k)-zz*dC_norm(k,i+nres))
6986 c
6987          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
6988          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
6989        enddo
6990
6991        do k=1,3
6992          dXX_Ctab(k,i)=dXX_Ci(k)
6993          dXX_C1tab(k,i)=dXX_Ci1(k)
6994          dYY_Ctab(k,i)=dYY_Ci(k)
6995          dYY_C1tab(k,i)=dYY_Ci1(k)
6996          dZZ_Ctab(k,i)=dZZ_Ci(k)
6997          dZZ_C1tab(k,i)=dZZ_Ci1(k)
6998          dXX_XYZtab(k,i)=dXX_XYZ(k)
6999          dYY_XYZtab(k,i)=dYY_XYZ(k)
7000          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
7001        enddo
7002
7003        do k = 1,3
7004 c         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
7005 c     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
7006 c         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
7007 c     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
7008 c         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
7009 c     &    dt_dci(k)
7010 c         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
7011 c     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
7012          gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k)
7013      &    +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
7014          gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k)
7015      &    +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
7016          gsclocx(k,i)=                 de_dxx*dxx_XYZ(k)
7017      &    +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
7018        enddo
7019 c       write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
7020 c     &  (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
7021
7022 C to check gradient call subroutine check_grad
7023
7024     1 continue
7025       enddo
7026       return
7027       end
7028 c------------------------------------------------------------------------------
7029       double precision function enesc(x,xx,yy,zz,cost2,sint2)
7030       implicit none
7031       double precision x(65),xx,yy,zz,cost2,sint2,sumene1,sumene2,
7032      & sumene3,sumene4,sumene,dsc_i,dp2_i,dscp1,dscp2,s1,s1_6,s2,s2_6
7033       sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
7034      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
7035      &   + x(10)*yy*zz
7036       sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
7037      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
7038      & + x(20)*yy*zz
7039       sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
7040      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
7041      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
7042      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
7043      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
7044      &  +x(40)*xx*yy*zz
7045       sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
7046      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
7047      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
7048      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
7049      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
7050      &  +x(60)*xx*yy*zz
7051       dsc_i   = 0.743d0+x(61)
7052       dp2_i   = 1.9d0+x(62)
7053       dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
7054      &          *(xx*cost2+yy*sint2))
7055       dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
7056      &          *(xx*cost2-yy*sint2))
7057       s1=(1+x(63))/(0.1d0 + dscp1)
7058       s1_6=(1+x(64))/(0.1d0 + dscp1**6)
7059       s2=(1+x(65))/(0.1d0 + dscp2)
7060       s2_6=(1+x(65))/(0.1d0 + dscp2**6)
7061       sumene = ( sumene3*sint2 + sumene1)*(s1+s1_6)
7062      & + (sumene4*cost2 +sumene2)*(s2+s2_6)
7063       enesc=sumene
7064       return
7065       end
7066 #endif
7067 c------------------------------------------------------------------------------
7068       subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
7069 C
7070 C This procedure calculates two-body contact function g(rij) and its derivative:
7071 C
7072 C           eps0ij                                     !       x < -1
7073 C g(rij) =  esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5)  ! -1 =< x =< 1
7074 C            0                                         !       x > 1
7075 C
7076 C where x=(rij-r0ij)/delta
7077 C
7078 C rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
7079 C
7080       implicit none
7081       double precision rij,r0ij,eps0ij,fcont,fprimcont
7082       double precision x,x2,x4,delta
7083 c     delta=0.02D0*r0ij
7084 c      delta=0.2D0*r0ij
7085       x=(rij-r0ij)/delta
7086       if (x.lt.-1.0D0) then
7087         fcont=eps0ij
7088         fprimcont=0.0D0
7089       else if (x.le.1.0D0) then
7090         x2=x*x
7091         x4=x2*x2
7092         fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
7093         fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
7094       else
7095         fcont=0.0D0
7096         fprimcont=0.0D0
7097       endif
7098       return
7099       end
7100 c------------------------------------------------------------------------------
7101       subroutine splinthet(theti,delta,ss,ssder)
7102       implicit real*8 (a-h,o-z)
7103       include 'DIMENSIONS'
7104       include 'COMMON.VAR'
7105       include 'COMMON.GEO'
7106       thetup=pi-delta
7107       thetlow=delta
7108       if (theti.gt.pipol) then
7109         call gcont(theti,thetup,1.0d0,delta,ss,ssder)
7110       else
7111         call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
7112         ssder=-ssder
7113       endif
7114       return
7115       end
7116 c------------------------------------------------------------------------------
7117       subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
7118       implicit none
7119       double precision x,x0,delta,f0,f1,fprim0,f,fprim
7120       double precision ksi,ksi2,ksi3,a1,a2,a3
7121       a1=fprim0*delta/(f1-f0)
7122       a2=3.0d0-2.0d0*a1
7123       a3=a1-2.0d0
7124       ksi=(x-x0)/delta
7125       ksi2=ksi*ksi
7126       ksi3=ksi2*ksi
7127       f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
7128       fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
7129       return
7130       end
7131 c------------------------------------------------------------------------------
7132       subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
7133       implicit none
7134       double precision x,x0,delta,f0x,f1x,fprim0x,fx
7135       double precision ksi,ksi2,ksi3,a1,a2,a3
7136       ksi=(x-x0)/delta
7137       ksi2=ksi*ksi
7138       ksi3=ksi2*ksi
7139       a1=fprim0x*delta
7140       a2=3*(f1x-f0x)-2*fprim0x*delta
7141       a3=fprim0x*delta-2*(f1x-f0x)
7142       fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
7143       return
7144       end
7145 C-----------------------------------------------------------------------------
7146 #ifdef CRYST_TOR
7147 C-----------------------------------------------------------------------------
7148       subroutine etor(etors,edihcnstr)
7149       implicit real*8 (a-h,o-z)
7150       include 'DIMENSIONS'
7151       include 'COMMON.VAR'
7152       include 'COMMON.GEO'
7153       include 'COMMON.LOCAL'
7154       include 'COMMON.TORSION'
7155       include 'COMMON.INTERACT'
7156       include 'COMMON.DERIV'
7157       include 'COMMON.CHAIN'
7158       include 'COMMON.NAMES'
7159       include 'COMMON.IOUNITS'
7160       include 'COMMON.FFIELD'
7161       include 'COMMON.TORCNSTR'
7162       include 'COMMON.CONTROL'
7163       logical lprn
7164 C Set lprn=.true. for debugging
7165       lprn=.false.
7166 c      lprn=.true.
7167       etors=0.0D0
7168       do i=iphi_start,iphi_end
7169       etors_ii=0.0D0
7170         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
7171      &      .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
7172         itori=itortyp(itype(i-2))
7173         itori1=itortyp(itype(i-1))
7174         phii=phi(i)
7175         gloci=0.0D0
7176 C Proline-Proline pair is a special case...
7177         if (itori.eq.3 .and. itori1.eq.3) then
7178           if (phii.gt.-dwapi3) then
7179             cosphi=dcos(3*phii)
7180             fac=1.0D0/(1.0D0-cosphi)
7181             etorsi=v1(1,3,3)*fac
7182             etorsi=etorsi+etorsi
7183             etors=etors+etorsi-v1(1,3,3)
7184             if (energy_dec) etors_ii=etors_ii+etorsi-v1(1,3,3)
7185             gloci=gloci-3*fac*etorsi*dsin(3*phii)
7186           endif
7187           do j=1,3
7188             v1ij=v1(j+1,itori,itori1)
7189             v2ij=v2(j+1,itori,itori1)
7190             cosphi=dcos(j*phii)
7191             sinphi=dsin(j*phii)
7192             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7193             if (energy_dec) etors_ii=etors_ii+
7194      &                              v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7195             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7196           enddo
7197         else
7198           do j=1,nterm_old
7199             v1ij=v1(j,itori,itori1)
7200             v2ij=v2(j,itori,itori1)
7201             cosphi=dcos(j*phii)
7202             sinphi=dsin(j*phii)
7203             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7204             if (energy_dec) etors_ii=etors_ii+
7205      &                  v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7206             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7207           enddo
7208         endif
7209         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
7210              'etor',i,etors_ii
7211         if (lprn)
7212      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
7213      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
7214      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
7215         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
7216 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
7217       enddo
7218 ! 6/20/98 - dihedral angle constraints
7219       edihcnstr=0.0d0
7220       do i=1,ndih_constr
7221         itori=idih_constr(i)
7222         phii=phi(itori)
7223         difi=phii-phi0(i)
7224         if (difi.gt.drange(i)) then
7225           difi=difi-drange(i)
7226           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
7227           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
7228         else if (difi.lt.-drange(i)) then
7229           difi=difi+drange(i)
7230           edihcnstr=edihcnstr+0.25d0*ftors(i)**difi**4
7231           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
7232         endif
7233 !        write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii,
7234 !     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
7235       enddo
7236 !      write (iout,*) 'edihcnstr',edihcnstr
7237       return
7238       end
7239 c------------------------------------------------------------------------------
7240       subroutine etor_d(etors_d)
7241       etors_d=0.0d0
7242       return
7243       end
7244 c----------------------------------------------------------------------------
7245 #else
7246       subroutine etor(etors,edihcnstr)
7247       implicit real*8 (a-h,o-z)
7248       include 'DIMENSIONS'
7249       include 'COMMON.VAR'
7250       include 'COMMON.GEO'
7251       include 'COMMON.LOCAL'
7252       include 'COMMON.TORSION'
7253       include 'COMMON.INTERACT'
7254       include 'COMMON.DERIV'
7255       include 'COMMON.CHAIN'
7256       include 'COMMON.NAMES'
7257       include 'COMMON.IOUNITS'
7258       include 'COMMON.FFIELD'
7259       include 'COMMON.TORCNSTR'
7260       include 'COMMON.CONTROL'
7261       logical lprn
7262 C Set lprn=.true. for debugging
7263       lprn=.false.
7264 c     lprn=.true.
7265       etors=0.0D0
7266       do i=iphi_start,iphi_end
7267 C ANY TWO ARE DUMMY ATOMS in row CYCLE
7268 c        if (((itype(i-3).eq.ntyp1).and.(itype(i-2).eq.ntyp1)).or.
7269 c     &      ((itype(i-2).eq.ntyp1).and.(itype(i-1).eq.ntyp1))  .or.
7270 c     &      ((itype(i-1).eq.ntyp1).and.(itype(i).eq.ntyp1))) cycle
7271         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
7272      &      .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
7273 C In current verion the ALL DUMMY ATOM POTENTIALS ARE OFF
7274 C For introducing the NH3+ and COO- group please check the etor_d for reference
7275 C and guidance
7276         etors_ii=0.0D0
7277          if (iabs(itype(i)).eq.20) then
7278          iblock=2
7279          else
7280          iblock=1
7281          endif
7282         itori=itortyp(itype(i-2))
7283         itori1=itortyp(itype(i-1))
7284         phii=phi(i)
7285         gloci=0.0D0
7286 C Regular cosine and sine terms
7287         do j=1,nterm(itori,itori1,iblock)
7288           v1ij=v1(j,itori,itori1,iblock)
7289           v2ij=v2(j,itori,itori1,iblock)
7290           cosphi=dcos(j*phii)
7291           sinphi=dsin(j*phii)
7292           etors=etors+v1ij*cosphi+v2ij*sinphi
7293           if (energy_dec) etors_ii=etors_ii+
7294      &                v1ij*cosphi+v2ij*sinphi
7295           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7296         enddo
7297 C Lorentz terms
7298 C                         v1
7299 C  E = SUM ----------------------------------- - v1
7300 C          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
7301 C
7302         cosphi=dcos(0.5d0*phii)
7303         sinphi=dsin(0.5d0*phii)
7304         do j=1,nlor(itori,itori1,iblock)
7305           vl1ij=vlor1(j,itori,itori1)
7306           vl2ij=vlor2(j,itori,itori1)
7307           vl3ij=vlor3(j,itori,itori1)
7308           pom=vl2ij*cosphi+vl3ij*sinphi
7309           pom1=1.0d0/(pom*pom+1.0d0)
7310           etors=etors+vl1ij*pom1
7311           if (energy_dec) etors_ii=etors_ii+
7312      &                vl1ij*pom1
7313           pom=-pom*pom1*pom1
7314           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
7315         enddo
7316 C Subtract the constant term
7317         etors=etors-v0(itori,itori1,iblock)
7318           if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
7319      &         'etor',i,etors_ii-v0(itori,itori1,iblock)
7320         if (lprn)
7321      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
7322      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
7323      &  (v1(j,itori,itori1,iblock),j=1,6),
7324      &  (v2(j,itori,itori1,iblock),j=1,6)
7325         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
7326 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
7327       enddo
7328 ! 6/20/98 - dihedral angle constraints
7329       edihcnstr=0.0d0
7330 c      do i=1,ndih_constr
7331       do i=idihconstr_start,idihconstr_end
7332         itori=idih_constr(i)
7333         phii=phi(itori)
7334         difi=pinorm(phii-phi0(i))
7335         if (difi.gt.drange(i)) then
7336           difi=difi-drange(i)
7337           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
7338           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
7339         else if (difi.lt.-drange(i)) then
7340           difi=difi+drange(i)
7341           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
7342           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
7343         else
7344           difi=0.0
7345         endif
7346        if (energy_dec) then
7347         write (iout,'(a6,2i5,4f8.3,2e14.5)') "edihc",
7348      &    i,itori,rad2deg*phii,
7349      &    rad2deg*phi0(i),  rad2deg*drange(i),
7350      &    rad2deg*difi,0.25d0*ftors(i)*difi**4,gloc(itori-3,icg)
7351         endif
7352       enddo
7353 cd       write (iout,*) 'edihcnstr',edihcnstr
7354       return
7355       end
7356 c----------------------------------------------------------------------------
7357       subroutine etor_d(etors_d)
7358 C 6/23/01 Compute double torsional energy
7359       implicit real*8 (a-h,o-z)
7360       include 'DIMENSIONS'
7361       include 'COMMON.VAR'
7362       include 'COMMON.GEO'
7363       include 'COMMON.LOCAL'
7364       include 'COMMON.TORSION'
7365       include 'COMMON.INTERACT'
7366       include 'COMMON.DERIV'
7367       include 'COMMON.CHAIN'
7368       include 'COMMON.NAMES'
7369       include 'COMMON.IOUNITS'
7370       include 'COMMON.FFIELD'
7371       include 'COMMON.TORCNSTR'
7372       logical lprn
7373 C Set lprn=.true. for debugging
7374       lprn=.false.
7375 c     lprn=.true.
7376       etors_d=0.0D0
7377 c      write(iout,*) "a tu??"
7378       do i=iphid_start,iphid_end
7379 C ANY TWO ARE DUMMY ATOMS in row CYCLE
7380 C        if (((itype(i-3).eq.ntyp1).and.(itype(i-2).eq.ntyp1)).or.
7381 C     &      ((itype(i-2).eq.ntyp1).and.(itype(i-1).eq.ntyp1)).or.
7382 C     &      ((itype(i-1).eq.ntyp1).and.(itype(i).eq.ntyp1))  .or.
7383 C     &      ((itype(i).eq.ntyp1).and.(itype(i+1).eq.ntyp1))) cycle
7384          if ((itype(i-2).eq.ntyp1).or.itype(i-3).eq.ntyp1.or.
7385      &  (itype(i-1).eq.ntyp1).or.(itype(i).eq.ntyp1).or.
7386      &  (itype(i+1).eq.ntyp1)) cycle
7387 C In current verion the ALL DUMMY ATOM POTENTIALS ARE OFF
7388         itori=itortyp(itype(i-2))
7389         itori1=itortyp(itype(i-1))
7390         itori2=itortyp(itype(i))
7391         phii=phi(i)
7392         phii1=phi(i+1)
7393         gloci1=0.0D0
7394         gloci2=0.0D0
7395         iblock=1
7396         if (iabs(itype(i+1)).eq.20) iblock=2
7397 C Iblock=2 Proline type
7398 C ADASKO: WHEN PARAMETERS FOR THIS TYPE OF BLOCKING GROUP IS READY UNCOMMENT
7399 C CHECK WEATHER THERE IS NECCESITY FOR iblock=3 for COO-
7400 C        if (itype(i+1).eq.ntyp1) iblock=3
7401 C The problem of NH3+ group can be resolved by adding new parameters please note if there
7402 C IS or IS NOT need for this
7403 C IF Yes uncomment below and add to parmread.F appropriate changes and to v1cij and so on
7404 C        is (itype(i-3).eq.ntyp1) ntblock=2
7405 C        ntblock is N-terminal blocking group
7406
7407 C Regular cosine and sine terms
7408         do j=1,ntermd_1(itori,itori1,itori2,iblock)
7409 C Example of changes for NH3+ blocking group
7410 C       do j=1,ntermd_1(itori,itori1,itori2,iblock,ntblock)
7411 C          v1cij=v1c(1,j,itori,itori1,itori2,iblock,ntblock)
7412           v1cij=v1c(1,j,itori,itori1,itori2,iblock)
7413           v1sij=v1s(1,j,itori,itori1,itori2,iblock)
7414           v2cij=v1c(2,j,itori,itori1,itori2,iblock)
7415           v2sij=v1s(2,j,itori,itori1,itori2,iblock)
7416           cosphi1=dcos(j*phii)
7417           sinphi1=dsin(j*phii)
7418           cosphi2=dcos(j*phii1)
7419           sinphi2=dsin(j*phii1)
7420           etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+
7421      &     v2cij*cosphi2+v2sij*sinphi2
7422           gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
7423           gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
7424         enddo
7425         do k=2,ntermd_2(itori,itori1,itori2,iblock)
7426           do l=1,k-1
7427             v1cdij = v2c(k,l,itori,itori1,itori2,iblock)
7428             v2cdij = v2c(l,k,itori,itori1,itori2,iblock)
7429             v1sdij = v2s(k,l,itori,itori1,itori2,iblock)
7430             v2sdij = v2s(l,k,itori,itori1,itori2,iblock)
7431             cosphi1p2=dcos(l*phii+(k-l)*phii1)
7432             cosphi1m2=dcos(l*phii-(k-l)*phii1)
7433             sinphi1p2=dsin(l*phii+(k-l)*phii1)
7434             sinphi1m2=dsin(l*phii-(k-l)*phii1)
7435             etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+
7436      &        v1sdij*sinphi1p2+v2sdij*sinphi1m2
7437             gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2
7438      &        -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
7439             gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2
7440      &        -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
7441           enddo
7442         enddo
7443         gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*gloci1
7444         gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*gloci2
7445       enddo
7446       return
7447       end
7448 #endif
7449 C----------------------------------------------------------------------------------
7450 C The rigorous attempt to derive energy function
7451       subroutine etor_kcc(etors,edihcnstr)
7452       implicit real*8 (a-h,o-z)
7453       include 'DIMENSIONS'
7454       include 'COMMON.VAR'
7455       include 'COMMON.GEO'
7456       include 'COMMON.LOCAL'
7457       include 'COMMON.TORSION'
7458       include 'COMMON.INTERACT'
7459       include 'COMMON.DERIV'
7460       include 'COMMON.CHAIN'
7461       include 'COMMON.NAMES'
7462       include 'COMMON.IOUNITS'
7463       include 'COMMON.FFIELD'
7464       include 'COMMON.TORCNSTR'
7465       include 'COMMON.CONTROL'
7466       logical lprn
7467       double precision thybt1(maxtermkcc),thybt2(maxtermkcc)
7468 C Set lprn=.true. for debugging
7469       lprn=.false.
7470 c     lprn=.true.
7471       etors=0.0D0
7472       do i=iphi_start,iphi_end
7473 C ANY TWO ARE DUMMY ATOMS in row CYCLE
7474 c        if (((itype(i-3).eq.ntyp1).and.(itype(i-2).eq.ntyp1)).or.
7475 c     &      ((itype(i-2).eq.ntyp1).and.(itype(i-1).eq.ntyp1))  .or.
7476 c     &      ((itype(i-1).eq.ntyp1).and.(itype(i).eq.ntyp1))) cycle
7477         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
7478      &      .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
7479         itori=itortyp_kcc(itype(i-2))
7480         itori1=itortyp_kcc(itype(i-1))
7481         phii=phi(i)
7482         glocig=0.0D0
7483         glocit1=0.0d0
7484         glocit2=0.0d0
7485         sumnonchebyshev=0.0d0
7486         sumchebyshev=0.0d0
7487 C to avoid multiple devision by 2
7488         theti22=0.5d0*theta(i)
7489 C theta 12 is the theta_1 /2
7490 C theta 22 is theta_2 /2
7491         theti12=0.5d0*theta(i-1)
7492 C and appropriate sinus function
7493         sinthet2=dsin(theta(i))
7494         sinthet1=dsin(theta(i-1))
7495         costhet1=dcos(theta(i-1))
7496         costhet2=dcos(theta(i))
7497 C to speed up lets store its mutliplication
7498          sint1t2=sinthet2*sinthet1
7499 C \sum_{i=1}^n (sin(theta_1) * sin(theta_2))^n * (c_n* cos(n*gamma)
7500 C +d_n*sin(n*gamma)) *
7501 C \sum_{i=1}^m (1+a_m*Tb_m(cos(theta_1 /2))+b_m*Tb_m(cos(theta_2 /2)))
7502 C we have two sum 1) Non-Chebyshev which is with n and gamma
7503         do j=1,nterm_kcc(itori,itori1)
7504
7505           v1ij=v1_kcc(j,itori,itori1)
7506           v2ij=v2_kcc(j,itori,itori1)
7507 C v1ij is c_n and d_n in euation above
7508           cosphi=dcos(j*phii)
7509           sinphi=dsin(j*phii)
7510           sint1t2n=sint1t2**j
7511           sumnonchebyshev=sumnonchebyshev+
7512      &                    sint1t2n*(v1ij*cosphi+v2ij*sinphi)
7513           actval=sint1t2n*(v1ij*cosphi+v2ij*sinphi)
7514 C          etors=etors+sint1t2n*(v1ij*cosphi+v2ij*sinphi)
7515 C          if (energy_dec) etors_ii=etors_ii+
7516 C     &                v1ij*cosphi+v2ij*sinphi
7517 C glocig is the gradient local i site in gamma
7518           glocig=glocig+j*(v2ij*cosphi-v1ij*sinphi)*sint1t2n
7519 C now gradient over theta_1
7520           glocit1=glocit1+actval/sinthet1*j*costhet1
7521           glocit2=glocit2+actval/sinthet2*j*costhet2
7522         enddo
7523
7524 C now the Czebyshev polinominal sum
7525         do j=1,nterm_kcc_Tb(itori,itori1)
7526          thybt1(j)=v1_chyb(j,itori,itori1)
7527          thybt2(j)=v2_chyb(j,itori,itori1)
7528         enddo
7529         sumth1thyb=tschebyshev
7530      &         (1,nterm_kcc_Tb(itori,itori1),thybt1(1),dcos(theta12))
7531         gradthybt1=gradtschebyshev
7532      &         (0,nterm_kcc_Tb(itori,itori1)-1,thybt1(1),dcos(theta12))
7533      & *(nterm_kcc_Tb(itori,itori1))*0.5*dsin(theta12)
7534         sumth2thyb=tschebyshev
7535      &         (1,nterm_kcc_Tb(itori,itori1),thybt2(1),dcos(theta22))
7536         gradthybt2=gradtschebyshev
7537      &         (0,nterm_kcc_Tb(itori,itori1)-1,thybt2(1),dcos(theta22))
7538      & *(nterm_kcc_Tb(itori,itori1))*0.5*dsin(theta22)
7539
7540 C now overal sumation
7541          etors=etors+(1.0d0+sumth1thyb+sumth2thyb)*sumnonchebyshev
7542 C derivative over gamma
7543          gloc(i-3,icg)=gloc(i-3,icg)+wtor*glocig
7544      &   *(1.0d0+sumth1thyb+sumth2thyb)
7545 C derivative over theta1
7546         gloc(nphi+i-3,icg)=gloc(nphi+i-3,icg)+wang*
7547      &  (glocit1*(1.0d0+sumth1thyb+sumth2thyb)+
7548      &   sumnonchebyshev*gradthybt1)
7549 C now derivative over theta2
7550         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)+wang*
7551      &  (glocit2*(1.0d0+sumth1thyb+sumth2thyb)+
7552      &   sumnonchebyshev*gradthybt2)
7553        enddo
7554
7555
7556 C        gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
7557 ! 6/20/98 - dihedral angle constraints
7558       if (tor_mode.ne.2) then
7559       edihcnstr=0.0d0
7560 c      do i=1,ndih_constr
7561       do i=idihconstr_start,idihconstr_end
7562         itori=idih_constr(i)
7563         phii=phi(itori)
7564         difi=pinorm(phii-phi0(i))
7565         if (difi.gt.drange(i)) then
7566           difi=difi-drange(i)
7567           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
7568           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
7569         else if (difi.lt.-drange(i)) then
7570           difi=difi+drange(i)
7571           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
7572           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
7573         else
7574           difi=0.0
7575         endif
7576        enddo
7577        endif
7578       return
7579       end
7580
7581
7582
7583 c------------------------------------------------------------------------------
7584       subroutine eback_sc_corr(esccor)
7585 c 7/21/2007 Correlations between the backbone-local and side-chain-local
7586 c        conformational states; temporarily implemented as differences
7587 c        between UNRES torsional potentials (dependent on three types of
7588 c        residues) and the torsional potentials dependent on all 20 types
7589 c        of residues computed from AM1  energy surfaces of terminally-blocked
7590 c        amino-acid residues.
7591       implicit real*8 (a-h,o-z)
7592       include 'DIMENSIONS'
7593       include 'COMMON.VAR'
7594       include 'COMMON.GEO'
7595       include 'COMMON.LOCAL'
7596       include 'COMMON.TORSION'
7597       include 'COMMON.SCCOR'
7598       include 'COMMON.INTERACT'
7599       include 'COMMON.DERIV'
7600       include 'COMMON.CHAIN'
7601       include 'COMMON.NAMES'
7602       include 'COMMON.IOUNITS'
7603       include 'COMMON.FFIELD'
7604       include 'COMMON.CONTROL'
7605       logical lprn
7606 C Set lprn=.true. for debugging
7607       lprn=.false.
7608 c      lprn=.true.
7609 c      write (iout,*) "EBACK_SC_COR",itau_start,itau_end
7610       esccor=0.0D0
7611       do i=itau_start,itau_end
7612         if ((itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)) cycle
7613         esccor_ii=0.0D0
7614         isccori=isccortyp(itype(i-2))
7615         isccori1=isccortyp(itype(i-1))
7616 c      write (iout,*) "EBACK_SC_COR",i,nterm_sccor(isccori,isccori1)
7617         phii=phi(i)
7618         do intertyp=1,3 !intertyp
7619 cc Added 09 May 2012 (Adasko)
7620 cc  Intertyp means interaction type of backbone mainchain correlation:
7621 c   1 = SC...Ca...Ca...Ca
7622 c   2 = Ca...Ca...Ca...SC
7623 c   3 = SC...Ca...Ca...SCi
7624         gloci=0.0D0
7625         if (((intertyp.eq.3).and.((itype(i-2).eq.10).or.
7626      &      (itype(i-1).eq.10).or.(itype(i-2).eq.ntyp1).or.
7627      &      (itype(i-1).eq.ntyp1)))
7628      &    .or. ((intertyp.eq.1).and.((itype(i-2).eq.10)
7629      &     .or.(itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)
7630      &     .or.(itype(i).eq.ntyp1)))
7631      &    .or.((intertyp.eq.2).and.((itype(i-1).eq.10).or.
7632      &      (itype(i-1).eq.ntyp1).or.(itype(i-2).eq.ntyp1).or.
7633      &      (itype(i-3).eq.ntyp1)))) cycle
7634         if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1).eq.ntyp1)) cycle
7635         if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres).eq.ntyp1))
7636      & cycle
7637        do j=1,nterm_sccor(isccori,isccori1)
7638           v1ij=v1sccor(j,intertyp,isccori,isccori1)
7639           v2ij=v2sccor(j,intertyp,isccori,isccori1)
7640           cosphi=dcos(j*tauangle(intertyp,i))
7641           sinphi=dsin(j*tauangle(intertyp,i))
7642           esccor=esccor+v1ij*cosphi+v2ij*sinphi
7643           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7644         enddo
7645 c      write (iout,*) "EBACK_SC_COR",i,v1ij*cosphi+v2ij*sinphi,intertyp
7646         gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci
7647         if (lprn)
7648      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
7649      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,isccori,isccori1,
7650      &  (v1sccor(j,intertyp,isccori,isccori1),j=1,6)
7651      & ,(v2sccor(j,intertyp,isccori,isccori1),j=1,6)
7652         gsccor_loc(i-3)=gsccor_loc(i-3)+gloci
7653        enddo !intertyp
7654       enddo
7655
7656       return
7657       end
7658 c----------------------------------------------------------------------------
7659       subroutine multibody(ecorr)
7660 C This subroutine calculates multi-body contributions to energy following
7661 C the idea of Skolnick et al. If side chains I and J make a contact and
7662 C at the same time side chains I+1 and J+1 make a contact, an extra
7663 C contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
7664       implicit real*8 (a-h,o-z)
7665       include 'DIMENSIONS'
7666       include 'COMMON.IOUNITS'
7667       include 'COMMON.DERIV'
7668       include 'COMMON.INTERACT'
7669       include 'COMMON.CONTACTS'
7670       double precision gx(3),gx1(3)
7671       logical lprn
7672
7673 C Set lprn=.true. for debugging
7674       lprn=.false.
7675
7676       if (lprn) then
7677         write (iout,'(a)') 'Contact function values:'
7678         do i=nnt,nct-2
7679           write (iout,'(i2,20(1x,i2,f10.5))')
7680      &        i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
7681         enddo
7682       endif
7683       ecorr=0.0D0
7684       do i=nnt,nct
7685         do j=1,3
7686           gradcorr(j,i)=0.0D0
7687           gradxorr(j,i)=0.0D0
7688         enddo
7689       enddo
7690       do i=nnt,nct-2
7691
7692         DO ISHIFT = 3,4
7693
7694         i1=i+ishift
7695         num_conti=num_cont(i)
7696         num_conti1=num_cont(i1)
7697         do jj=1,num_conti
7698           j=jcont(jj,i)
7699           do kk=1,num_conti1
7700             j1=jcont(kk,i1)
7701             if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
7702 cd          write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
7703 cd   &                   ' ishift=',ishift
7704 C Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
7705 C The system gains extra energy.
7706               ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
7707             endif   ! j1==j+-ishift
7708           enddo     ! kk
7709         enddo       ! jj
7710
7711         ENDDO ! ISHIFT
7712
7713       enddo         ! i
7714       return
7715       end
7716 c------------------------------------------------------------------------------
7717       double precision function esccorr(i,j,k,l,jj,kk)
7718       implicit real*8 (a-h,o-z)
7719       include 'DIMENSIONS'
7720       include 'COMMON.IOUNITS'
7721       include 'COMMON.DERIV'
7722       include 'COMMON.INTERACT'
7723       include 'COMMON.CONTACTS'
7724       include 'COMMON.SHIELD'
7725       double precision gx(3),gx1(3)
7726       logical lprn
7727       lprn=.false.
7728       eij=facont(jj,i)
7729       ekl=facont(kk,k)
7730 cd    write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
7731 C Calculate the multi-body contribution to energy.
7732 C Calculate multi-body contributions to the gradient.
7733 cd    write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
7734 cd   & k,l,(gacont(m,kk,k),m=1,3)
7735       do m=1,3
7736         gx(m) =ekl*gacont(m,jj,i)
7737         gx1(m)=eij*gacont(m,kk,k)
7738         gradxorr(m,i)=gradxorr(m,i)-gx(m)
7739         gradxorr(m,j)=gradxorr(m,j)+gx(m)
7740         gradxorr(m,k)=gradxorr(m,k)-gx1(m)
7741         gradxorr(m,l)=gradxorr(m,l)+gx1(m)
7742       enddo
7743       do m=i,j-1
7744         do ll=1,3
7745           gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
7746         enddo
7747       enddo
7748       do m=k,l-1
7749         do ll=1,3
7750           gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
7751         enddo
7752       enddo
7753       esccorr=-eij*ekl
7754       return
7755       end
7756 c------------------------------------------------------------------------------
7757       subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
7758 C This subroutine calculates multi-body contributions to hydrogen-bonding
7759       implicit real*8 (a-h,o-z)
7760       include 'DIMENSIONS'
7761       include 'COMMON.IOUNITS'
7762 #ifdef MPI
7763       include "mpif.h"
7764       parameter (max_cont=maxconts)
7765       parameter (max_dim=26)
7766       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
7767       double precision zapas(max_dim,maxconts,max_fg_procs),
7768      &  zapas_recv(max_dim,maxconts,max_fg_procs)
7769       common /przechowalnia/ zapas
7770       integer status(MPI_STATUS_SIZE),req(maxconts*2),
7771      &  status_array(MPI_STATUS_SIZE,maxconts*2)
7772 #endif
7773       include 'COMMON.SETUP'
7774       include 'COMMON.FFIELD'
7775       include 'COMMON.DERIV'
7776       include 'COMMON.INTERACT'
7777       include 'COMMON.CONTACTS'
7778       include 'COMMON.CONTROL'
7779       include 'COMMON.LOCAL'
7780       double precision gx(3),gx1(3),time00
7781       logical lprn,ldone
7782
7783 C Set lprn=.true. for debugging
7784       lprn=.false.
7785 #ifdef MPI
7786       n_corr=0
7787       n_corr1=0
7788       if (nfgtasks.le.1) goto 30
7789       if (lprn) then
7790         write (iout,'(a)') 'Contact function values before RECEIVE:'
7791         do i=nnt,nct-2
7792           write (iout,'(2i3,50(1x,i2,f5.2))')
7793      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
7794      &    j=1,num_cont_hb(i))
7795         enddo
7796       endif
7797       call flush(iout)
7798       do i=1,ntask_cont_from
7799         ncont_recv(i)=0
7800       enddo
7801       do i=1,ntask_cont_to
7802         ncont_sent(i)=0
7803       enddo
7804 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
7805 c     & ntask_cont_to
7806 C Make the list of contacts to send to send to other procesors
7807 c      write (iout,*) "limits",max0(iturn4_end-1,iatel_s),iturn3_end
7808 c      call flush(iout)
7809       do i=iturn3_start,iturn3_end
7810 c        write (iout,*) "make contact list turn3",i," num_cont",
7811 c     &    num_cont_hb(i)
7812         call add_hb_contact(i,i+2,iturn3_sent_local(1,i))
7813       enddo
7814       do i=iturn4_start,iturn4_end
7815 c        write (iout,*) "make contact list turn4",i," num_cont",
7816 c     &   num_cont_hb(i)
7817         call add_hb_contact(i,i+3,iturn4_sent_local(1,i))
7818       enddo
7819       do ii=1,nat_sent
7820         i=iat_sent(ii)
7821 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
7822 c     &    num_cont_hb(i)
7823         do j=1,num_cont_hb(i)
7824         do k=1,4
7825           jjc=jcont_hb(j,i)
7826           iproc=iint_sent_local(k,jjc,ii)
7827 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
7828           if (iproc.gt.0) then
7829             ncont_sent(iproc)=ncont_sent(iproc)+1
7830             nn=ncont_sent(iproc)
7831             zapas(1,nn,iproc)=i
7832             zapas(2,nn,iproc)=jjc
7833             zapas(3,nn,iproc)=facont_hb(j,i)
7834             zapas(4,nn,iproc)=ees0p(j,i)
7835             zapas(5,nn,iproc)=ees0m(j,i)
7836             zapas(6,nn,iproc)=gacont_hbr(1,j,i)
7837             zapas(7,nn,iproc)=gacont_hbr(2,j,i)
7838             zapas(8,nn,iproc)=gacont_hbr(3,j,i)
7839             zapas(9,nn,iproc)=gacontm_hb1(1,j,i)
7840             zapas(10,nn,iproc)=gacontm_hb1(2,j,i)
7841             zapas(11,nn,iproc)=gacontm_hb1(3,j,i)
7842             zapas(12,nn,iproc)=gacontp_hb1(1,j,i)
7843             zapas(13,nn,iproc)=gacontp_hb1(2,j,i)
7844             zapas(14,nn,iproc)=gacontp_hb1(3,j,i)
7845             zapas(15,nn,iproc)=gacontm_hb2(1,j,i)
7846             zapas(16,nn,iproc)=gacontm_hb2(2,j,i)
7847             zapas(17,nn,iproc)=gacontm_hb2(3,j,i)
7848             zapas(18,nn,iproc)=gacontp_hb2(1,j,i)
7849             zapas(19,nn,iproc)=gacontp_hb2(2,j,i)
7850             zapas(20,nn,iproc)=gacontp_hb2(3,j,i)
7851             zapas(21,nn,iproc)=gacontm_hb3(1,j,i)
7852             zapas(22,nn,iproc)=gacontm_hb3(2,j,i)
7853             zapas(23,nn,iproc)=gacontm_hb3(3,j,i)
7854             zapas(24,nn,iproc)=gacontp_hb3(1,j,i)
7855             zapas(25,nn,iproc)=gacontp_hb3(2,j,i)
7856             zapas(26,nn,iproc)=gacontp_hb3(3,j,i)
7857           endif
7858         enddo
7859         enddo
7860       enddo
7861       if (lprn) then
7862       write (iout,*)
7863      &  "Numbers of contacts to be sent to other processors",
7864      &  (ncont_sent(i),i=1,ntask_cont_to)
7865       write (iout,*) "Contacts sent"
7866       do ii=1,ntask_cont_to
7867         nn=ncont_sent(ii)
7868         iproc=itask_cont_to(ii)
7869         write (iout,*) nn," contacts to processor",iproc,
7870      &   " of CONT_TO_COMM group"
7871         do i=1,nn
7872           write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
7873         enddo
7874       enddo
7875       call flush(iout)
7876       endif
7877       CorrelType=477
7878       CorrelID=fg_rank+1
7879       CorrelType1=478
7880       CorrelID1=nfgtasks+fg_rank+1
7881       ireq=0
7882 C Receive the numbers of needed contacts from other processors
7883       do ii=1,ntask_cont_from
7884         iproc=itask_cont_from(ii)
7885         ireq=ireq+1
7886         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
7887      &    FG_COMM,req(ireq),IERR)
7888       enddo
7889 c      write (iout,*) "IRECV ended"
7890 c      call flush(iout)
7891 C Send the number of contacts needed by other processors
7892       do ii=1,ntask_cont_to
7893         iproc=itask_cont_to(ii)
7894         ireq=ireq+1
7895         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
7896      &    FG_COMM,req(ireq),IERR)
7897       enddo
7898 c      write (iout,*) "ISEND ended"
7899 c      write (iout,*) "number of requests (nn)",ireq
7900       call flush(iout)
7901       if (ireq.gt.0)
7902      &  call MPI_Waitall(ireq,req,status_array,ierr)
7903 c      write (iout,*)
7904 c     &  "Numbers of contacts to be received from other processors",
7905 c     &  (ncont_recv(i),i=1,ntask_cont_from)
7906 c      call flush(iout)
7907 C Receive contacts
7908       ireq=0
7909       do ii=1,ntask_cont_from
7910         iproc=itask_cont_from(ii)
7911         nn=ncont_recv(ii)
7912 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
7913 c     &   " of CONT_TO_COMM group"
7914         call flush(iout)
7915         if (nn.gt.0) then
7916           ireq=ireq+1
7917           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
7918      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
7919 c          write (iout,*) "ireq,req",ireq,req(ireq)
7920         endif
7921       enddo
7922 C Send the contacts to processors that need them
7923       do ii=1,ntask_cont_to
7924         iproc=itask_cont_to(ii)
7925         nn=ncont_sent(ii)
7926 c        write (iout,*) nn," contacts to processor",iproc,
7927 c     &   " of CONT_TO_COMM group"
7928         if (nn.gt.0) then
7929           ireq=ireq+1
7930           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
7931      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
7932 c          write (iout,*) "ireq,req",ireq,req(ireq)
7933 c          do i=1,nn
7934 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
7935 c          enddo
7936         endif
7937       enddo
7938 c      write (iout,*) "number of requests (contacts)",ireq
7939 c      write (iout,*) "req",(req(i),i=1,4)
7940 c      call flush(iout)
7941       if (ireq.gt.0)
7942      & call MPI_Waitall(ireq,req,status_array,ierr)
7943       do iii=1,ntask_cont_from
7944         iproc=itask_cont_from(iii)
7945         nn=ncont_recv(iii)
7946         if (lprn) then
7947         write (iout,*) "Received",nn," contacts from processor",iproc,
7948      &   " of CONT_FROM_COMM group"
7949         call flush(iout)
7950         do i=1,nn
7951           write(iout,'(2f5.0,4f10.5)')(zapas_recv(j,i,iii),j=1,5)
7952         enddo
7953         call flush(iout)
7954         endif
7955         do i=1,nn
7956           ii=zapas_recv(1,i,iii)
7957 c Flag the received contacts to prevent double-counting
7958           jj=-zapas_recv(2,i,iii)
7959 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
7960 c          call flush(iout)
7961           nnn=num_cont_hb(ii)+1
7962           num_cont_hb(ii)=nnn
7963           jcont_hb(nnn,ii)=jj
7964           facont_hb(nnn,ii)=zapas_recv(3,i,iii)
7965           ees0p(nnn,ii)=zapas_recv(4,i,iii)
7966           ees0m(nnn,ii)=zapas_recv(5,i,iii)
7967           gacont_hbr(1,nnn,ii)=zapas_recv(6,i,iii)
7968           gacont_hbr(2,nnn,ii)=zapas_recv(7,i,iii)
7969           gacont_hbr(3,nnn,ii)=zapas_recv(8,i,iii)
7970           gacontm_hb1(1,nnn,ii)=zapas_recv(9,i,iii)
7971           gacontm_hb1(2,nnn,ii)=zapas_recv(10,i,iii)
7972           gacontm_hb1(3,nnn,ii)=zapas_recv(11,i,iii)
7973           gacontp_hb1(1,nnn,ii)=zapas_recv(12,i,iii)
7974           gacontp_hb1(2,nnn,ii)=zapas_recv(13,i,iii)
7975           gacontp_hb1(3,nnn,ii)=zapas_recv(14,i,iii)
7976           gacontm_hb2(1,nnn,ii)=zapas_recv(15,i,iii)
7977           gacontm_hb2(2,nnn,ii)=zapas_recv(16,i,iii)
7978           gacontm_hb2(3,nnn,ii)=zapas_recv(17,i,iii)
7979           gacontp_hb2(1,nnn,ii)=zapas_recv(18,i,iii)
7980           gacontp_hb2(2,nnn,ii)=zapas_recv(19,i,iii)
7981           gacontp_hb2(3,nnn,ii)=zapas_recv(20,i,iii)
7982           gacontm_hb3(1,nnn,ii)=zapas_recv(21,i,iii)
7983           gacontm_hb3(2,nnn,ii)=zapas_recv(22,i,iii)
7984           gacontm_hb3(3,nnn,ii)=zapas_recv(23,i,iii)
7985           gacontp_hb3(1,nnn,ii)=zapas_recv(24,i,iii)
7986           gacontp_hb3(2,nnn,ii)=zapas_recv(25,i,iii)
7987           gacontp_hb3(3,nnn,ii)=zapas_recv(26,i,iii)
7988         enddo
7989       enddo
7990       call flush(iout)
7991       if (lprn) then
7992         write (iout,'(a)') 'Contact function values after receive:'
7993         do i=nnt,nct-2
7994           write (iout,'(2i3,50(1x,i3,f5.2))')
7995      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
7996      &    j=1,num_cont_hb(i))
7997         enddo
7998         call flush(iout)
7999       endif
8000    30 continue
8001 #endif
8002       if (lprn) then
8003         write (iout,'(a)') 'Contact function values:'
8004         do i=nnt,nct-2
8005           write (iout,'(2i3,50(1x,i3,f5.2))')
8006      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
8007      &    j=1,num_cont_hb(i))
8008         enddo
8009       endif
8010       ecorr=0.0D0
8011 C Remove the loop below after debugging !!!
8012       do i=nnt,nct
8013         do j=1,3
8014           gradcorr(j,i)=0.0D0
8015           gradxorr(j,i)=0.0D0
8016         enddo
8017       enddo
8018 C Calculate the local-electrostatic correlation terms
8019       do i=min0(iatel_s,iturn4_start),max0(iatel_e,iturn3_end)
8020         i1=i+1
8021         num_conti=num_cont_hb(i)
8022         num_conti1=num_cont_hb(i+1)
8023         do jj=1,num_conti
8024           j=jcont_hb(jj,i)
8025           jp=iabs(j)
8026           do kk=1,num_conti1
8027             j1=jcont_hb(kk,i1)
8028             jp1=iabs(j1)
8029 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
8030 c     &         ' jj=',jj,' kk=',kk
8031             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
8032      &          .or. j.lt.0 .and. j1.gt.0) .and.
8033      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
8034 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
8035 C The system gains extra energy.
8036               ecorr=ecorr+ehbcorr(i,jp,i+1,jp1,jj,kk,0.72D0,0.32D0)
8037               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
8038      &            'ecorrh',i,j,ehbcorr(i,j,i+1,j1,jj,kk,0.72D0,0.32D0)
8039               n_corr=n_corr+1
8040             else if (j1.eq.j) then
8041 C Contacts I-J and I-(J+1) occur simultaneously.
8042 C The system loses extra energy.
8043 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
8044             endif
8045           enddo ! kk
8046           do kk=1,num_conti
8047             j1=jcont_hb(kk,i)
8048 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
8049 c    &         ' jj=',jj,' kk=',kk
8050             if (j1.eq.j+1) then
8051 C Contacts I-J and (I+1)-J occur simultaneously.
8052 C The system loses extra energy.
8053 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
8054             endif ! j1==j+1
8055           enddo ! kk
8056         enddo ! jj
8057       enddo ! i
8058       return
8059       end
8060 c------------------------------------------------------------------------------
8061       subroutine add_hb_contact(ii,jj,itask)
8062       implicit real*8 (a-h,o-z)
8063       include "DIMENSIONS"
8064       include "COMMON.IOUNITS"
8065       integer max_cont
8066       integer max_dim
8067       parameter (max_cont=maxconts)
8068       parameter (max_dim=26)
8069       include "COMMON.CONTACTS"
8070       double precision zapas(max_dim,maxconts,max_fg_procs),
8071      &  zapas_recv(max_dim,maxconts,max_fg_procs)
8072       common /przechowalnia/ zapas
8073       integer i,j,ii,jj,iproc,itask(4),nn
8074 c      write (iout,*) "itask",itask
8075       do i=1,2
8076         iproc=itask(i)
8077         if (iproc.gt.0) then
8078           do j=1,num_cont_hb(ii)
8079             jjc=jcont_hb(j,ii)
8080 c            write (iout,*) "i",ii," j",jj," jjc",jjc
8081             if (jjc.eq.jj) then
8082               ncont_sent(iproc)=ncont_sent(iproc)+1
8083               nn=ncont_sent(iproc)
8084               zapas(1,nn,iproc)=ii
8085               zapas(2,nn,iproc)=jjc
8086               zapas(3,nn,iproc)=facont_hb(j,ii)
8087               zapas(4,nn,iproc)=ees0p(j,ii)
8088               zapas(5,nn,iproc)=ees0m(j,ii)
8089               zapas(6,nn,iproc)=gacont_hbr(1,j,ii)
8090               zapas(7,nn,iproc)=gacont_hbr(2,j,ii)
8091               zapas(8,nn,iproc)=gacont_hbr(3,j,ii)
8092               zapas(9,nn,iproc)=gacontm_hb1(1,j,ii)
8093               zapas(10,nn,iproc)=gacontm_hb1(2,j,ii)
8094               zapas(11,nn,iproc)=gacontm_hb1(3,j,ii)
8095               zapas(12,nn,iproc)=gacontp_hb1(1,j,ii)
8096               zapas(13,nn,iproc)=gacontp_hb1(2,j,ii)
8097               zapas(14,nn,iproc)=gacontp_hb1(3,j,ii)
8098               zapas(15,nn,iproc)=gacontm_hb2(1,j,ii)
8099               zapas(16,nn,iproc)=gacontm_hb2(2,j,ii)
8100               zapas(17,nn,iproc)=gacontm_hb2(3,j,ii)
8101               zapas(18,nn,iproc)=gacontp_hb2(1,j,ii)
8102               zapas(19,nn,iproc)=gacontp_hb2(2,j,ii)
8103               zapas(20,nn,iproc)=gacontp_hb2(3,j,ii)
8104               zapas(21,nn,iproc)=gacontm_hb3(1,j,ii)
8105               zapas(22,nn,iproc)=gacontm_hb3(2,j,ii)
8106               zapas(23,nn,iproc)=gacontm_hb3(3,j,ii)
8107               zapas(24,nn,iproc)=gacontp_hb3(1,j,ii)
8108               zapas(25,nn,iproc)=gacontp_hb3(2,j,ii)
8109               zapas(26,nn,iproc)=gacontp_hb3(3,j,ii)
8110               exit
8111             endif
8112           enddo
8113         endif
8114       enddo
8115       return
8116       end
8117 c------------------------------------------------------------------------------
8118       subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,
8119      &  n_corr1)
8120 C This subroutine calculates multi-body contributions to hydrogen-bonding
8121       implicit real*8 (a-h,o-z)
8122       include 'DIMENSIONS'
8123       include 'COMMON.IOUNITS'
8124 #ifdef MPI
8125       include "mpif.h"
8126       parameter (max_cont=maxconts)
8127       parameter (max_dim=70)
8128       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
8129       double precision zapas(max_dim,maxconts,max_fg_procs),
8130      &  zapas_recv(max_dim,maxconts,max_fg_procs)
8131       common /przechowalnia/ zapas
8132       integer status(MPI_STATUS_SIZE),req(maxconts*2),
8133      &  status_array(MPI_STATUS_SIZE,maxconts*2)
8134 #endif
8135       include 'COMMON.SETUP'
8136       include 'COMMON.FFIELD'
8137       include 'COMMON.DERIV'
8138       include 'COMMON.LOCAL'
8139       include 'COMMON.INTERACT'
8140       include 'COMMON.CONTACTS'
8141       include 'COMMON.CHAIN'
8142       include 'COMMON.CONTROL'
8143       include 'COMMON.SHIELD'
8144       double precision gx(3),gx1(3)
8145       integer num_cont_hb_old(maxres)
8146       logical lprn,ldone
8147       double precision eello4,eello5,eelo6,eello_turn6
8148       external eello4,eello5,eello6,eello_turn6
8149 C Set lprn=.true. for debugging
8150       lprn=.false.
8151       eturn6=0.0d0
8152 #ifdef MPI
8153       do i=1,nres
8154         num_cont_hb_old(i)=num_cont_hb(i)
8155       enddo
8156       n_corr=0
8157       n_corr1=0
8158       if (nfgtasks.le.1) goto 30
8159       if (lprn) then
8160         write (iout,'(a)') 'Contact function values before RECEIVE:'
8161         do i=nnt,nct-2
8162           write (iout,'(2i3,50(1x,i2,f5.2))')
8163      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
8164      &    j=1,num_cont_hb(i))
8165         enddo
8166       endif
8167       call flush(iout)
8168       do i=1,ntask_cont_from
8169         ncont_recv(i)=0
8170       enddo
8171       do i=1,ntask_cont_to
8172         ncont_sent(i)=0
8173       enddo
8174 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
8175 c     & ntask_cont_to
8176 C Make the list of contacts to send to send to other procesors
8177       do i=iturn3_start,iturn3_end
8178 c        write (iout,*) "make contact list turn3",i," num_cont",
8179 c     &    num_cont_hb(i)
8180         call add_hb_contact_eello(i,i+2,iturn3_sent_local(1,i))
8181       enddo
8182       do i=iturn4_start,iturn4_end
8183 c        write (iout,*) "make contact list turn4",i," num_cont",
8184 c     &   num_cont_hb(i)
8185         call add_hb_contact_eello(i,i+3,iturn4_sent_local(1,i))
8186       enddo
8187       do ii=1,nat_sent
8188         i=iat_sent(ii)
8189 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
8190 c     &    num_cont_hb(i)
8191         do j=1,num_cont_hb(i)
8192         do k=1,4
8193           jjc=jcont_hb(j,i)
8194           iproc=iint_sent_local(k,jjc,ii)
8195 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
8196           if (iproc.ne.0) then
8197             ncont_sent(iproc)=ncont_sent(iproc)+1
8198             nn=ncont_sent(iproc)
8199             zapas(1,nn,iproc)=i
8200             zapas(2,nn,iproc)=jjc
8201             zapas(3,nn,iproc)=d_cont(j,i)
8202             ind=3
8203             do kk=1,3
8204               ind=ind+1
8205               zapas(ind,nn,iproc)=grij_hb_cont(kk,j,i)
8206             enddo
8207             do kk=1,2
8208               do ll=1,2
8209                 ind=ind+1
8210                 zapas(ind,nn,iproc)=a_chuj(ll,kk,j,i)
8211               enddo
8212             enddo
8213             do jj=1,5
8214               do kk=1,3
8215                 do ll=1,2
8216                   do mm=1,2
8217                     ind=ind+1
8218                     zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,i)
8219                   enddo
8220                 enddo
8221               enddo
8222             enddo
8223           endif
8224         enddo
8225         enddo
8226       enddo
8227       if (lprn) then
8228       write (iout,*)
8229      &  "Numbers of contacts to be sent to other processors",
8230      &  (ncont_sent(i),i=1,ntask_cont_to)
8231       write (iout,*) "Contacts sent"
8232       do ii=1,ntask_cont_to
8233         nn=ncont_sent(ii)
8234         iproc=itask_cont_to(ii)
8235         write (iout,*) nn," contacts to processor",iproc,
8236      &   " of CONT_TO_COMM group"
8237         do i=1,nn
8238           write(iout,'(2f5.0,10f10.5)')(zapas(j,i,ii),j=1,10)
8239         enddo
8240       enddo
8241       call flush(iout)
8242       endif
8243       CorrelType=477
8244       CorrelID=fg_rank+1
8245       CorrelType1=478
8246       CorrelID1=nfgtasks+fg_rank+1
8247       ireq=0
8248 C Receive the numbers of needed contacts from other processors
8249       do ii=1,ntask_cont_from
8250         iproc=itask_cont_from(ii)
8251         ireq=ireq+1
8252         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
8253      &    FG_COMM,req(ireq),IERR)
8254       enddo
8255 c      write (iout,*) "IRECV ended"
8256 c      call flush(iout)
8257 C Send the number of contacts needed by other processors
8258       do ii=1,ntask_cont_to
8259         iproc=itask_cont_to(ii)
8260         ireq=ireq+1
8261         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
8262      &    FG_COMM,req(ireq),IERR)
8263       enddo
8264 c      write (iout,*) "ISEND ended"
8265 c      write (iout,*) "number of requests (nn)",ireq
8266       call flush(iout)
8267       if (ireq.gt.0)
8268      &  call MPI_Waitall(ireq,req,status_array,ierr)
8269 c      write (iout,*)
8270 c     &  "Numbers of contacts to be received from other processors",
8271 c     &  (ncont_recv(i),i=1,ntask_cont_from)
8272 c      call flush(iout)
8273 C Receive contacts
8274       ireq=0
8275       do ii=1,ntask_cont_from
8276         iproc=itask_cont_from(ii)
8277         nn=ncont_recv(ii)
8278 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
8279 c     &   " of CONT_TO_COMM group"
8280         call flush(iout)
8281         if (nn.gt.0) then
8282           ireq=ireq+1
8283           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
8284      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
8285 c          write (iout,*) "ireq,req",ireq,req(ireq)
8286         endif
8287       enddo
8288 C Send the contacts to processors that need them
8289       do ii=1,ntask_cont_to
8290         iproc=itask_cont_to(ii)
8291         nn=ncont_sent(ii)
8292 c        write (iout,*) nn," contacts to processor",iproc,
8293 c     &   " of CONT_TO_COMM group"
8294         if (nn.gt.0) then
8295           ireq=ireq+1
8296           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
8297      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
8298 c          write (iout,*) "ireq,req",ireq,req(ireq)
8299 c          do i=1,nn
8300 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
8301 c          enddo
8302         endif
8303       enddo
8304 c      write (iout,*) "number of requests (contacts)",ireq
8305 c      write (iout,*) "req",(req(i),i=1,4)
8306 c      call flush(iout)
8307       if (ireq.gt.0)
8308      & call MPI_Waitall(ireq,req,status_array,ierr)
8309       do iii=1,ntask_cont_from
8310         iproc=itask_cont_from(iii)
8311         nn=ncont_recv(iii)
8312         if (lprn) then
8313         write (iout,*) "Received",nn," contacts from processor",iproc,
8314      &   " of CONT_FROM_COMM group"
8315         call flush(iout)
8316         do i=1,nn
8317           write(iout,'(2f5.0,10f10.5)')(zapas_recv(j,i,iii),j=1,10)
8318         enddo
8319         call flush(iout)
8320         endif
8321         do i=1,nn
8322           ii=zapas_recv(1,i,iii)
8323 c Flag the received contacts to prevent double-counting
8324           jj=-zapas_recv(2,i,iii)
8325 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
8326 c          call flush(iout)
8327           nnn=num_cont_hb(ii)+1
8328           num_cont_hb(ii)=nnn
8329           jcont_hb(nnn,ii)=jj
8330           d_cont(nnn,ii)=zapas_recv(3,i,iii)
8331           ind=3
8332           do kk=1,3
8333             ind=ind+1
8334             grij_hb_cont(kk,nnn,ii)=zapas_recv(ind,i,iii)
8335           enddo
8336           do kk=1,2
8337             do ll=1,2
8338               ind=ind+1
8339               a_chuj(ll,kk,nnn,ii)=zapas_recv(ind,i,iii)
8340             enddo
8341           enddo
8342           do jj=1,5
8343             do kk=1,3
8344               do ll=1,2
8345                 do mm=1,2
8346                   ind=ind+1
8347                   a_chuj_der(mm,ll,kk,jj,nnn,ii)=zapas_recv(ind,i,iii)
8348                 enddo
8349               enddo
8350             enddo
8351           enddo
8352         enddo
8353       enddo
8354       call flush(iout)
8355       if (lprn) then
8356         write (iout,'(a)') 'Contact function values after receive:'
8357         do i=nnt,nct-2
8358           write (iout,'(2i3,50(1x,i3,5f6.3))')
8359      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
8360      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
8361         enddo
8362         call flush(iout)
8363       endif
8364    30 continue
8365 #endif
8366       if (lprn) then
8367         write (iout,'(a)') 'Contact function values:'
8368         do i=nnt,nct-2
8369           write (iout,'(2i3,50(1x,i2,5f6.3))')
8370      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
8371      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
8372         enddo
8373       endif
8374       ecorr=0.0D0
8375       ecorr5=0.0d0
8376       ecorr6=0.0d0
8377 C Remove the loop below after debugging !!!
8378       do i=nnt,nct
8379         do j=1,3
8380           gradcorr(j,i)=0.0D0
8381           gradxorr(j,i)=0.0D0
8382         enddo
8383       enddo
8384 C Calculate the dipole-dipole interaction energies
8385       if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
8386       do i=iatel_s,iatel_e+1
8387         num_conti=num_cont_hb(i)
8388         do jj=1,num_conti
8389           j=jcont_hb(jj,i)
8390 #ifdef MOMENT
8391           call dipole(i,j,jj)
8392 #endif
8393         enddo
8394       enddo
8395       endif
8396 C Calculate the local-electrostatic correlation terms
8397 c                write (iout,*) "gradcorr5 in eello5 before loop"
8398 c                do iii=1,nres
8399 c                  write (iout,'(i5,3f10.5)')
8400 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
8401 c                enddo
8402       do i=min0(iatel_s,iturn4_start),max0(iatel_e+1,iturn3_end+1)
8403 c        write (iout,*) "corr loop i",i
8404         i1=i+1
8405         num_conti=num_cont_hb(i)
8406         num_conti1=num_cont_hb(i+1)
8407         do jj=1,num_conti
8408           j=jcont_hb(jj,i)
8409           jp=iabs(j)
8410           do kk=1,num_conti1
8411             j1=jcont_hb(kk,i1)
8412             jp1=iabs(j1)
8413 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
8414 c     &         ' jj=',jj,' kk=',kk
8415 c            if (j1.eq.j+1 .or. j1.eq.j-1) then
8416             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
8417      &          .or. j.lt.0 .and. j1.gt.0) .and.
8418      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
8419 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
8420 C The system gains extra energy.
8421               n_corr=n_corr+1
8422               sqd1=dsqrt(d_cont(jj,i))
8423               sqd2=dsqrt(d_cont(kk,i1))
8424               sred_geom = sqd1*sqd2
8425               IF (sred_geom.lt.cutoff_corr) THEN
8426                 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,
8427      &            ekont,fprimcont)
8428 cd               write (iout,*) 'i=',i,' j=',jp,' i1=',i1,' j1=',jp1,
8429 cd     &         ' jj=',jj,' kk=',kk
8430                 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
8431                 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
8432                 do l=1,3
8433                   g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
8434                   g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
8435                 enddo
8436                 n_corr1=n_corr1+1
8437 cd               write (iout,*) 'sred_geom=',sred_geom,
8438 cd     &          ' ekont=',ekont,' fprim=',fprimcont,
8439 cd     &          ' fac_prim1',fac_prim1,' fac_prim2',fac_prim2
8440 cd               write (iout,*) "g_contij",g_contij
8441 cd               write (iout,*) "grij_hb_cont i",grij_hb_cont(:,jj,i)
8442 cd               write (iout,*) "grij_hb_cont i1",grij_hb_cont(:,jj,i1)
8443                 call calc_eello(i,jp,i+1,jp1,jj,kk)
8444                 if (wcorr4.gt.0.0d0)
8445      &            ecorr=ecorr+eello4(i,jp,i+1,jp1,jj,kk)
8446 CC     &            *fac_shield(i)**2*fac_shield(j)**2
8447                   if (energy_dec.and.wcorr4.gt.0.0d0)
8448      1                 write (iout,'(a6,4i5,0pf7.3)')
8449      2                'ecorr4',i,j,i+1,j1,eello4(i,jp,i+1,jp1,jj,kk)
8450 c                write (iout,*) "gradcorr5 before eello5"
8451 c                do iii=1,nres
8452 c                  write (iout,'(i5,3f10.5)')
8453 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
8454 c                enddo
8455                 if (wcorr5.gt.0.0d0)
8456      &            ecorr5=ecorr5+eello5(i,jp,i+1,jp1,jj,kk)
8457 c                write (iout,*) "gradcorr5 after eello5"
8458 c                do iii=1,nres
8459 c                  write (iout,'(i5,3f10.5)')
8460 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
8461 c                enddo
8462                   if (energy_dec.and.wcorr5.gt.0.0d0)
8463      1                 write (iout,'(a6,4i5,0pf7.3)')
8464      2                'ecorr5',i,j,i+1,j1,eello5(i,jp,i+1,jp1,jj,kk)
8465 cd                write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
8466 cd                write(2,*)'ijkl',i,jp,i+1,jp1
8467                 if (wcorr6.gt.0.0d0 .and. (jp.ne.i+4 .or. jp1.ne.i+3
8468      &               .or. wturn6.eq.0.0d0))then
8469 cd                  write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
8470                   ecorr6=ecorr6+eello6(i,jp,i+1,jp1,jj,kk)
8471                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
8472      1                'ecorr6',i,j,i+1,j1,eello6(i,jp,i+1,jp1,jj,kk)
8473 cd                write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
8474 cd     &            'ecorr6=',ecorr6
8475 cd                write (iout,'(4e15.5)') sred_geom,
8476 cd     &          dabs(eello4(i,jp,i+1,jp1,jj,kk)),
8477 cd     &          dabs(eello5(i,jp,i+1,jp1,jj,kk)),
8478 cd     &          dabs(eello6(i,jp,i+1,jp1,jj,kk))
8479                 else if (wturn6.gt.0.0d0
8480      &            .and. (jp.eq.i+4 .and. jp1.eq.i+3)) then
8481 cd                  write (iout,*) '******eturn6: i,j,i+1,j1',i,jip,i+1,jp1
8482                   eturn6=eturn6+eello_turn6(i,jj,kk)
8483                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
8484      1                 'eturn6',i,j,i+1,j1,eello_turn6(i,jj,kk)
8485 cd                  write (2,*) 'multibody_eello:eturn6',eturn6
8486                 endif
8487               ENDIF
8488 1111          continue
8489             endif
8490           enddo ! kk
8491         enddo ! jj
8492       enddo ! i
8493       do i=1,nres
8494         num_cont_hb(i)=num_cont_hb_old(i)
8495       enddo
8496 c                write (iout,*) "gradcorr5 in eello5"
8497 c                do iii=1,nres
8498 c                  write (iout,'(i5,3f10.5)')
8499 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
8500 c                enddo
8501       return
8502       end
8503 c------------------------------------------------------------------------------
8504       subroutine add_hb_contact_eello(ii,jj,itask)
8505       implicit real*8 (a-h,o-z)
8506       include "DIMENSIONS"
8507       include "COMMON.IOUNITS"
8508       integer max_cont
8509       integer max_dim
8510       parameter (max_cont=maxconts)
8511       parameter (max_dim=70)
8512       include "COMMON.CONTACTS"
8513       double precision zapas(max_dim,maxconts,max_fg_procs),
8514      &  zapas_recv(max_dim,maxconts,max_fg_procs)
8515       common /przechowalnia/ zapas
8516       integer i,j,ii,jj,iproc,itask(4),nn
8517 c      write (iout,*) "itask",itask
8518       do i=1,2
8519         iproc=itask(i)
8520         if (iproc.gt.0) then
8521           do j=1,num_cont_hb(ii)
8522             jjc=jcont_hb(j,ii)
8523 c            write (iout,*) "send turns i",ii," j",jj," jjc",jjc
8524             if (jjc.eq.jj) then
8525               ncont_sent(iproc)=ncont_sent(iproc)+1
8526               nn=ncont_sent(iproc)
8527               zapas(1,nn,iproc)=ii
8528               zapas(2,nn,iproc)=jjc
8529               zapas(3,nn,iproc)=d_cont(j,ii)
8530               ind=3
8531               do kk=1,3
8532                 ind=ind+1
8533                 zapas(ind,nn,iproc)=grij_hb_cont(kk,j,ii)
8534               enddo
8535               do kk=1,2
8536                 do ll=1,2
8537                   ind=ind+1
8538                   zapas(ind,nn,iproc)=a_chuj(ll,kk,j,ii)
8539                 enddo
8540               enddo
8541               do jj=1,5
8542                 do kk=1,3
8543                   do ll=1,2
8544                     do mm=1,2
8545                       ind=ind+1
8546                       zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,ii)
8547                     enddo
8548                   enddo
8549                 enddo
8550               enddo
8551               exit
8552             endif
8553           enddo
8554         endif
8555       enddo
8556       return
8557       end
8558 c------------------------------------------------------------------------------
8559       double precision function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
8560       implicit real*8 (a-h,o-z)
8561       include 'DIMENSIONS'
8562       include 'COMMON.IOUNITS'
8563       include 'COMMON.DERIV'
8564       include 'COMMON.INTERACT'
8565       include 'COMMON.CONTACTS'
8566       include 'COMMON.SHIELD'
8567       include 'COMMON.CONTROL'
8568       double precision gx(3),gx1(3)
8569       logical lprn
8570       lprn=.false.
8571 C      print *,"wchodze",fac_shield(i),shield_mode
8572       eij=facont_hb(jj,i)
8573       ekl=facont_hb(kk,k)
8574       ees0pij=ees0p(jj,i)
8575       ees0pkl=ees0p(kk,k)
8576       ees0mij=ees0m(jj,i)
8577       ees0mkl=ees0m(kk,k)
8578       ekont=eij*ekl
8579       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
8580 C*
8581 C     & fac_shield(i)**2*fac_shield(j)**2
8582 cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
8583 C Following 4 lines for diagnostics.
8584 cd    ees0pkl=0.0D0
8585 cd    ees0pij=1.0D0
8586 cd    ees0mkl=0.0D0
8587 cd    ees0mij=1.0D0
8588 c      write (iout,'(2(a,2i3,a,f10.5,a,2f10.5),a,f10.5,a,$)')
8589 c     & 'Contacts ',i,j,
8590 c     & ' eij',eij,' eesij',ees0pij,ees0mij,' and ',k,l
8591 c     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' energy=',ekont*ees,
8592 c     & 'gradcorr_long'
8593 C Calculate the multi-body contribution to energy.
8594 c      ecorr=ecorr+ekont*ees
8595 C Calculate multi-body contributions to the gradient.
8596       coeffpees0pij=coeffp*ees0pij
8597       coeffmees0mij=coeffm*ees0mij
8598       coeffpees0pkl=coeffp*ees0pkl
8599       coeffmees0mkl=coeffm*ees0mkl
8600       do ll=1,3
8601 cgrad        ghalfi=ees*ekl*gacont_hbr(ll,jj,i)
8602         gradcorr(ll,i)=gradcorr(ll,i)!+0.5d0*ghalfi
8603      &  -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+
8604      &  coeffmees0mkl*gacontm_hb1(ll,jj,i))
8605         gradcorr(ll,j)=gradcorr(ll,j)!+0.5d0*ghalfi
8606      &  -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+
8607      &  coeffmees0mkl*gacontm_hb2(ll,jj,i))
8608 cgrad        ghalfk=ees*eij*gacont_hbr(ll,kk,k)
8609         gradcorr(ll,k)=gradcorr(ll,k)!+0.5d0*ghalfk
8610      &  -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+
8611      &  coeffmees0mij*gacontm_hb1(ll,kk,k))
8612         gradcorr(ll,l)=gradcorr(ll,l)!+0.5d0*ghalfk
8613      &  -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+
8614      &  coeffmees0mij*gacontm_hb2(ll,kk,k))
8615         gradlongij=ees*ekl*gacont_hbr(ll,jj,i)-
8616      &     ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+
8617      &     coeffmees0mkl*gacontm_hb3(ll,jj,i))
8618         gradcorr_long(ll,j)=gradcorr_long(ll,j)+gradlongij
8619         gradcorr_long(ll,i)=gradcorr_long(ll,i)-gradlongij
8620         gradlongkl=ees*eij*gacont_hbr(ll,kk,k)-
8621      &     ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+
8622      &     coeffmees0mij*gacontm_hb3(ll,kk,k))
8623         gradcorr_long(ll,l)=gradcorr_long(ll,l)+gradlongkl
8624         gradcorr_long(ll,k)=gradcorr_long(ll,k)-gradlongkl
8625 c        write (iout,'(2f10.5,2x,$)') gradlongij,gradlongkl
8626       enddo
8627 c      write (iout,*)
8628 cgrad      do m=i+1,j-1
8629 cgrad        do ll=1,3
8630 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
8631 cgrad     &     ees*ekl*gacont_hbr(ll,jj,i)-
8632 cgrad     &     ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
8633 cgrad     &     coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
8634 cgrad        enddo
8635 cgrad      enddo
8636 cgrad      do m=k+1,l-1
8637 cgrad        do ll=1,3
8638 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
8639 cgrad     &     ees*eij*gacont_hbr(ll,kk,k)-
8640 cgrad     &     ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
8641 cgrad     &     coeffm*ees0mij*gacontm_hb3(ll,kk,k))
8642 cgrad        enddo
8643 cgrad      enddo
8644 c      write (iout,*) "ehbcorr",ekont*ees
8645 C      print *,ekont,ees,i,k
8646       ehbcorr=ekont*ees
8647 C now gradient over shielding
8648 C      return
8649       if (shield_mode.gt.0) then
8650        j=ees0plist(jj,i)
8651        l=ees0plist(kk,k)
8652 C        print *,i,j,fac_shield(i),fac_shield(j),
8653 C     &fac_shield(k),fac_shield(l)
8654         if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
8655      &      (fac_shield(k).gt.0).and.(fac_shield(l).gt.0)) then
8656           do ilist=1,ishield_list(i)
8657            iresshield=shield_list(ilist,i)
8658            do m=1,3
8659            rlocshield=grad_shield_side(m,ilist,i)*ehbcorr/fac_shield(i)
8660 C     &      *2.0
8661            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
8662      &              rlocshield
8663      & +grad_shield_loc(m,ilist,i)*ehbcorr/fac_shield(i)
8664             gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
8665      &+rlocshield
8666            enddo
8667           enddo
8668           do ilist=1,ishield_list(j)
8669            iresshield=shield_list(ilist,j)
8670            do m=1,3
8671            rlocshield=grad_shield_side(m,ilist,j)*ehbcorr/fac_shield(j)
8672 C     &     *2.0
8673            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
8674      &              rlocshield
8675      & +grad_shield_loc(m,ilist,j)*ehbcorr/fac_shield(j)
8676            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
8677      &     +rlocshield
8678            enddo
8679           enddo
8680
8681           do ilist=1,ishield_list(k)
8682            iresshield=shield_list(ilist,k)
8683            do m=1,3
8684            rlocshield=grad_shield_side(m,ilist,k)*ehbcorr/fac_shield(k)
8685 C     &     *2.0
8686            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
8687      &              rlocshield
8688      & +grad_shield_loc(m,ilist,k)*ehbcorr/fac_shield(k)
8689            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
8690      &     +rlocshield
8691            enddo
8692           enddo
8693           do ilist=1,ishield_list(l)
8694            iresshield=shield_list(ilist,l)
8695            do m=1,3
8696            rlocshield=grad_shield_side(m,ilist,l)*ehbcorr/fac_shield(l)
8697 C     &     *2.0
8698            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
8699      &              rlocshield
8700      & +grad_shield_loc(m,ilist,l)*ehbcorr/fac_shield(l)
8701            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
8702      &     +rlocshield
8703            enddo
8704           enddo
8705 C          print *,gshieldx(m,iresshield)
8706           do m=1,3
8707             gshieldc_ec(m,i)=gshieldc_ec(m,i)+
8708      &              grad_shield(m,i)*ehbcorr/fac_shield(i)
8709             gshieldc_ec(m,j)=gshieldc_ec(m,j)+
8710      &              grad_shield(m,j)*ehbcorr/fac_shield(j)
8711             gshieldc_ec(m,i-1)=gshieldc_ec(m,i-1)+
8712      &              grad_shield(m,i)*ehbcorr/fac_shield(i)
8713             gshieldc_ec(m,j-1)=gshieldc_ec(m,j-1)+
8714      &              grad_shield(m,j)*ehbcorr/fac_shield(j)
8715
8716             gshieldc_ec(m,k)=gshieldc_ec(m,k)+
8717      &              grad_shield(m,k)*ehbcorr/fac_shield(k)
8718             gshieldc_ec(m,l)=gshieldc_ec(m,l)+
8719      &              grad_shield(m,l)*ehbcorr/fac_shield(l)
8720             gshieldc_ec(m,k-1)=gshieldc_ec(m,k-1)+
8721      &              grad_shield(m,k)*ehbcorr/fac_shield(k)
8722             gshieldc_ec(m,l-1)=gshieldc_ec(m,l-1)+
8723      &              grad_shield(m,l)*ehbcorr/fac_shield(l)
8724
8725            enddo
8726       endif
8727       endif
8728       return
8729       end
8730 #ifdef MOMENT
8731 C---------------------------------------------------------------------------
8732       subroutine dipole(i,j,jj)
8733       implicit real*8 (a-h,o-z)
8734       include 'DIMENSIONS'
8735       include 'COMMON.IOUNITS'
8736       include 'COMMON.CHAIN'
8737       include 'COMMON.FFIELD'
8738       include 'COMMON.DERIV'
8739       include 'COMMON.INTERACT'
8740       include 'COMMON.CONTACTS'
8741       include 'COMMON.TORSION'
8742       include 'COMMON.VAR'
8743       include 'COMMON.GEO'
8744       dimension dipi(2,2),dipj(2,2),dipderi(2),dipderj(2),auxvec(2),
8745      &  auxmat(2,2)
8746       iti1 = itortyp(itype(i+1))
8747       if (j.lt.nres-1) then
8748         itj1 = itortyp(itype(j+1))
8749       else
8750         itj1=ntortyp
8751       endif
8752       do iii=1,2
8753         dipi(iii,1)=Ub2(iii,i)
8754         dipderi(iii)=Ub2der(iii,i)
8755         dipi(iii,2)=b1(iii,i+1)
8756         dipj(iii,1)=Ub2(iii,j)
8757         dipderj(iii)=Ub2der(iii,j)
8758         dipj(iii,2)=b1(iii,j+1)
8759       enddo
8760       kkk=0
8761       do iii=1,2
8762         call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
8763         do jjj=1,2
8764           kkk=kkk+1
8765           dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
8766         enddo
8767       enddo
8768       do kkk=1,5
8769         do lll=1,3
8770           mmm=0
8771           do iii=1,2
8772             call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),
8773      &        auxvec(1))
8774             do jjj=1,2
8775               mmm=mmm+1
8776               dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
8777             enddo
8778           enddo
8779         enddo
8780       enddo
8781       call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
8782       call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
8783       do iii=1,2
8784         dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
8785       enddo
8786       call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
8787       do iii=1,2
8788         dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
8789       enddo
8790       return
8791       end
8792 #endif
8793 C---------------------------------------------------------------------------
8794       subroutine calc_eello(i,j,k,l,jj,kk)
8795 C
8796 C This subroutine computes matrices and vectors needed to calculate
8797 C the fourth-, fifth-, and sixth-order local-electrostatic terms.
8798 C
8799       implicit real*8 (a-h,o-z)
8800       include 'DIMENSIONS'
8801       include 'COMMON.IOUNITS'
8802       include 'COMMON.CHAIN'
8803       include 'COMMON.DERIV'
8804       include 'COMMON.INTERACT'
8805       include 'COMMON.CONTACTS'
8806       include 'COMMON.TORSION'
8807       include 'COMMON.VAR'
8808       include 'COMMON.GEO'
8809       include 'COMMON.FFIELD'
8810       double precision aa1(2,2),aa2(2,2),aa1t(2,2),aa2t(2,2),
8811      &  aa1tder(2,2,3,5),aa2tder(2,2,3,5),auxmat(2,2)
8812       logical lprn
8813       common /kutas/ lprn
8814 cd      write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
8815 cd     & ' jj=',jj,' kk=',kk
8816 cd      if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
8817 cd      write (iout,*) "a_chujij",((a_chuj(iii,jjj,jj,i),iii=1,2),jjj=1,2)
8818 cd      write (iout,*) "a_chujkl",((a_chuj(iii,jjj,kk,k),iii=1,2),jjj=1,2)
8819       do iii=1,2
8820         do jjj=1,2
8821           aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
8822           aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
8823         enddo
8824       enddo
8825       call transpose2(aa1(1,1),aa1t(1,1))
8826       call transpose2(aa2(1,1),aa2t(1,1))
8827       do kkk=1,5
8828         do lll=1,3
8829           call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),
8830      &      aa1tder(1,1,lll,kkk))
8831           call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),
8832      &      aa2tder(1,1,lll,kkk))
8833         enddo
8834       enddo
8835       if (l.eq.j+1) then
8836 C parallel orientation of the two CA-CA-CA frames.
8837         if (i.gt.1) then
8838           iti=itortyp(itype(i))
8839         else
8840           iti=ntortyp
8841         endif
8842         itk1=itortyp(itype(k+1))
8843         itj=itortyp(itype(j))
8844         if (l.lt.nres-1) then
8845           itl1=itortyp(itype(l+1))
8846         else
8847           itl1=ntortyp
8848         endif
8849 C A1 kernel(j+1) A2T
8850 cd        do iii=1,2
8851 cd          write (iout,'(3f10.5,5x,3f10.5)')
8852 cd     &     (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
8853 cd        enddo
8854         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
8855      &   aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),
8856      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
8857 C Following matrices are needed only for 6-th order cumulants
8858         IF (wcorr6.gt.0.0d0) THEN
8859         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
8860      &   aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),
8861      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
8862         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
8863      &   aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),
8864      &   Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
8865      &   ADtEAderx(1,1,1,1,1,1))
8866         lprn=.false.
8867         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
8868      &   aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),
8869      &   DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
8870      &   ADtEA1derx(1,1,1,1,1,1))
8871         ENDIF
8872 C End 6-th order cumulants
8873 cd        lprn=.false.
8874 cd        if (lprn) then
8875 cd        write (2,*) 'In calc_eello6'
8876 cd        do iii=1,2
8877 cd          write (2,*) 'iii=',iii
8878 cd          do kkk=1,5
8879 cd            write (2,*) 'kkk=',kkk
8880 cd            do jjj=1,2
8881 cd              write (2,'(3(2f10.5),5x)')
8882 cd     &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
8883 cd            enddo
8884 cd          enddo
8885 cd        enddo
8886 cd        endif
8887         call transpose2(EUgder(1,1,k),auxmat(1,1))
8888         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
8889         call transpose2(EUg(1,1,k),auxmat(1,1))
8890         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
8891         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
8892         do iii=1,2
8893           do kkk=1,5
8894             do lll=1,3
8895               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
8896      &          EAEAderx(1,1,lll,kkk,iii,1))
8897             enddo
8898           enddo
8899         enddo
8900 C A1T kernel(i+1) A2
8901         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
8902      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),
8903      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
8904 C Following matrices are needed only for 6-th order cumulants
8905         IF (wcorr6.gt.0.0d0) THEN
8906         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
8907      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),
8908      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
8909         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
8910      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),
8911      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
8912      &   ADtEAderx(1,1,1,1,1,2))
8913         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
8914      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),
8915      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
8916      &   ADtEA1derx(1,1,1,1,1,2))
8917         ENDIF
8918 C End 6-th order cumulants
8919         call transpose2(EUgder(1,1,l),auxmat(1,1))
8920         call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
8921         call transpose2(EUg(1,1,l),auxmat(1,1))
8922         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
8923         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
8924         do iii=1,2
8925           do kkk=1,5
8926             do lll=1,3
8927               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
8928      &          EAEAderx(1,1,lll,kkk,iii,2))
8929             enddo
8930           enddo
8931         enddo
8932 C AEAb1 and AEAb2
8933 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
8934 C They are needed only when the fifth- or the sixth-order cumulants are
8935 C indluded.
8936         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
8937         call transpose2(AEA(1,1,1),auxmat(1,1))
8938         call matvec2(auxmat(1,1),b1(1,i),AEAb1(1,1,1))
8939         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
8940         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
8941         call transpose2(AEAderg(1,1,1),auxmat(1,1))
8942         call matvec2(auxmat(1,1),b1(1,i),AEAb1derg(1,1,1))
8943         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
8944         call matvec2(AEA(1,1,1),b1(1,k+1),AEAb1(1,2,1))
8945         call matvec2(AEAderg(1,1,1),b1(1,k+1),AEAb1derg(1,2,1))
8946         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
8947         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
8948         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
8949         call transpose2(AEA(1,1,2),auxmat(1,1))
8950         call matvec2(auxmat(1,1),b1(1,j),AEAb1(1,1,2))
8951         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
8952         call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
8953         call transpose2(AEAderg(1,1,2),auxmat(1,1))
8954         call matvec2(auxmat(1,1),b1(1,j),AEAb1derg(1,1,2))
8955         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
8956         call matvec2(AEA(1,1,2),b1(1,l+1),AEAb1(1,2,2))
8957         call matvec2(AEAderg(1,1,2),b1(1,l+1),AEAb1derg(1,2,2))
8958         call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
8959         call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
8960         call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
8961 C Calculate the Cartesian derivatives of the vectors.
8962         do iii=1,2
8963           do kkk=1,5
8964             do lll=1,3
8965               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
8966               call matvec2(auxmat(1,1),b1(1,i),
8967      &          AEAb1derx(1,lll,kkk,iii,1,1))
8968               call matvec2(auxmat(1,1),Ub2(1,i),
8969      &          AEAb2derx(1,lll,kkk,iii,1,1))
8970               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
8971      &          AEAb1derx(1,lll,kkk,iii,2,1))
8972               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
8973      &          AEAb2derx(1,lll,kkk,iii,2,1))
8974               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
8975               call matvec2(auxmat(1,1),b1(1,j),
8976      &          AEAb1derx(1,lll,kkk,iii,1,2))
8977               call matvec2(auxmat(1,1),Ub2(1,j),
8978      &          AEAb2derx(1,lll,kkk,iii,1,2))
8979               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,l+1),
8980      &          AEAb1derx(1,lll,kkk,iii,2,2))
8981               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),
8982      &          AEAb2derx(1,lll,kkk,iii,2,2))
8983             enddo
8984           enddo
8985         enddo
8986         ENDIF
8987 C End vectors
8988       else
8989 C Antiparallel orientation of the two CA-CA-CA frames.
8990         if (i.gt.1) then
8991           iti=itortyp(itype(i))
8992         else
8993           iti=ntortyp
8994         endif
8995         itk1=itortyp(itype(k+1))
8996         itl=itortyp(itype(l))
8997         itj=itortyp(itype(j))
8998         if (j.lt.nres-1) then
8999           itj1=itortyp(itype(j+1))
9000         else
9001           itj1=ntortyp
9002         endif
9003 C A2 kernel(j-1)T A1T
9004         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9005      &   aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),
9006      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
9007 C Following matrices are needed only for 6-th order cumulants
9008         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
9009      &     j.eq.i+4 .and. l.eq.i+3)) THEN
9010         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9011      &   aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),
9012      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
9013         call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9014      &   aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),
9015      &   Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
9016      &   ADtEAderx(1,1,1,1,1,1))
9017         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9018      &   aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),
9019      &   DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
9020      &   ADtEA1derx(1,1,1,1,1,1))
9021         ENDIF
9022 C End 6-th order cumulants
9023         call transpose2(EUgder(1,1,k),auxmat(1,1))
9024         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
9025         call transpose2(EUg(1,1,k),auxmat(1,1))
9026         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
9027         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
9028         do iii=1,2
9029           do kkk=1,5
9030             do lll=1,3
9031               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
9032      &          EAEAderx(1,1,lll,kkk,iii,1))
9033             enddo
9034           enddo
9035         enddo
9036 C A2T kernel(i+1)T A1
9037         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
9038      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),
9039      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
9040 C Following matrices are needed only for 6-th order cumulants
9041         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
9042      &     j.eq.i+4 .and. l.eq.i+3)) THEN
9043         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
9044      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),
9045      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
9046         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
9047      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),
9048      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
9049      &   ADtEAderx(1,1,1,1,1,2))
9050         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
9051      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),
9052      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
9053      &   ADtEA1derx(1,1,1,1,1,2))
9054         ENDIF
9055 C End 6-th order cumulants
9056         call transpose2(EUgder(1,1,j),auxmat(1,1))
9057         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
9058         call transpose2(EUg(1,1,j),auxmat(1,1))
9059         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
9060         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
9061         do iii=1,2
9062           do kkk=1,5
9063             do lll=1,3
9064               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
9065      &          EAEAderx(1,1,lll,kkk,iii,2))
9066             enddo
9067           enddo
9068         enddo
9069 C AEAb1 and AEAb2
9070 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
9071 C They are needed only when the fifth- or the sixth-order cumulants are
9072 C indluded.
9073         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or.
9074      &    (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
9075         call transpose2(AEA(1,1,1),auxmat(1,1))
9076         call matvec2(auxmat(1,1),b1(1,i),AEAb1(1,1,1))
9077         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
9078         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
9079         call transpose2(AEAderg(1,1,1),auxmat(1,1))
9080         call matvec2(auxmat(1,1),b1(1,i),AEAb1derg(1,1,1))
9081         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
9082         call matvec2(AEA(1,1,1),b1(1,k+1),AEAb1(1,2,1))
9083         call matvec2(AEAderg(1,1,1),b1(1,k+1),AEAb1derg(1,2,1))
9084         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
9085         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
9086         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
9087         call transpose2(AEA(1,1,2),auxmat(1,1))
9088         call matvec2(auxmat(1,1),b1(1,j+1),AEAb1(1,1,2))
9089         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
9090         call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
9091         call transpose2(AEAderg(1,1,2),auxmat(1,1))
9092         call matvec2(auxmat(1,1),b1(1,l),AEAb1(1,1,2))
9093         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
9094         call matvec2(AEA(1,1,2),b1(1,j+1),AEAb1(1,2,2))
9095         call matvec2(AEAderg(1,1,2),b1(1,j+1),AEAb1derg(1,2,2))
9096         call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
9097         call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
9098         call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
9099 C Calculate the Cartesian derivatives of the vectors.
9100         do iii=1,2
9101           do kkk=1,5
9102             do lll=1,3
9103               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
9104               call matvec2(auxmat(1,1),b1(1,i),
9105      &          AEAb1derx(1,lll,kkk,iii,1,1))
9106               call matvec2(auxmat(1,1),Ub2(1,i),
9107      &          AEAb2derx(1,lll,kkk,iii,1,1))
9108               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
9109      &          AEAb1derx(1,lll,kkk,iii,2,1))
9110               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
9111      &          AEAb2derx(1,lll,kkk,iii,2,1))
9112               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
9113               call matvec2(auxmat(1,1),b1(1,l),
9114      &          AEAb1derx(1,lll,kkk,iii,1,2))
9115               call matvec2(auxmat(1,1),Ub2(1,l),
9116      &          AEAb2derx(1,lll,kkk,iii,1,2))
9117               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,j+1),
9118      &          AEAb1derx(1,lll,kkk,iii,2,2))
9119               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),
9120      &          AEAb2derx(1,lll,kkk,iii,2,2))
9121             enddo
9122           enddo
9123         enddo
9124         ENDIF
9125 C End vectors
9126       endif
9127       return
9128       end
9129 C---------------------------------------------------------------------------
9130       subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,
9131      &  KK,KKderg,AKA,AKAderg,AKAderx)
9132       implicit none
9133       integer nderg
9134       logical transp
9135       double precision aa1(2,2),aa2t(2,2),aa1derx(2,2,3,5),
9136      &  aa2tderx(2,2,3,5),KK(2,2),KKderg(2,2,nderg),AKA(2,2),
9137      &  AKAderg(2,2,nderg),AKAderx(2,2,3,5,2)
9138       integer iii,kkk,lll
9139       integer jjj,mmm
9140       logical lprn
9141       common /kutas/ lprn
9142       call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
9143       do iii=1,nderg
9144         call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,
9145      &    AKAderg(1,1,iii))
9146       enddo
9147 cd      if (lprn) write (2,*) 'In kernel'
9148       do kkk=1,5
9149 cd        if (lprn) write (2,*) 'kkk=',kkk
9150         do lll=1,3
9151           call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),
9152      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
9153 cd          if (lprn) then
9154 cd            write (2,*) 'lll=',lll
9155 cd            write (2,*) 'iii=1'
9156 cd            do jjj=1,2
9157 cd              write (2,'(3(2f10.5),5x)')
9158 cd     &        (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
9159 cd            enddo
9160 cd          endif
9161           call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),
9162      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
9163 cd          if (lprn) then
9164 cd            write (2,*) 'lll=',lll
9165 cd            write (2,*) 'iii=2'
9166 cd            do jjj=1,2
9167 cd              write (2,'(3(2f10.5),5x)')
9168 cd     &        (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
9169 cd            enddo
9170 cd          endif
9171         enddo
9172       enddo
9173       return
9174       end
9175 C---------------------------------------------------------------------------
9176       double precision function eello4(i,j,k,l,jj,kk)
9177       implicit real*8 (a-h,o-z)
9178       include 'DIMENSIONS'
9179       include 'COMMON.IOUNITS'
9180       include 'COMMON.CHAIN'
9181       include 'COMMON.DERIV'
9182       include 'COMMON.INTERACT'
9183       include 'COMMON.CONTACTS'
9184       include 'COMMON.TORSION'
9185       include 'COMMON.VAR'
9186       include 'COMMON.GEO'
9187       double precision pizda(2,2),ggg1(3),ggg2(3)
9188 cd      if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
9189 cd        eello4=0.0d0
9190 cd        return
9191 cd      endif
9192 cd      print *,'eello4:',i,j,k,l,jj,kk
9193 cd      write (2,*) 'i',i,' j',j,' k',k,' l',l
9194 cd      call checkint4(i,j,k,l,jj,kk,eel4_num)
9195 cold      eij=facont_hb(jj,i)
9196 cold      ekl=facont_hb(kk,k)
9197 cold      ekont=eij*ekl
9198       eel4=-EAEA(1,1,1)-EAEA(2,2,1)
9199 cd      eel41=-EAEA(1,1,2)-EAEA(2,2,2)
9200       gcorr_loc(k-1)=gcorr_loc(k-1)
9201      &   -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
9202       if (l.eq.j+1) then
9203         gcorr_loc(l-1)=gcorr_loc(l-1)
9204      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
9205       else
9206         gcorr_loc(j-1)=gcorr_loc(j-1)
9207      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
9208       endif
9209       do iii=1,2
9210         do kkk=1,5
9211           do lll=1,3
9212             derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1)
9213      &                        -EAEAderx(2,2,lll,kkk,iii,1)
9214 cd            derx(lll,kkk,iii)=0.0d0
9215           enddo
9216         enddo
9217       enddo
9218 cd      gcorr_loc(l-1)=0.0d0
9219 cd      gcorr_loc(j-1)=0.0d0
9220 cd      gcorr_loc(k-1)=0.0d0
9221 cd      eel4=1.0d0
9222 cd      write (iout,*)'Contacts have occurred for peptide groups',
9223 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l,
9224 cd     &  ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
9225       if (j.lt.nres-1) then
9226         j1=j+1
9227         j2=j-1
9228       else
9229         j1=j-1
9230         j2=j-2
9231       endif
9232       if (l.lt.nres-1) then
9233         l1=l+1
9234         l2=l-1
9235       else
9236         l1=l-1
9237         l2=l-2
9238       endif
9239       do ll=1,3
9240 cgrad        ggg1(ll)=eel4*g_contij(ll,1)
9241 cgrad        ggg2(ll)=eel4*g_contij(ll,2)
9242         glongij=eel4*g_contij(ll,1)+ekont*derx(ll,1,1)
9243         glongkl=eel4*g_contij(ll,2)+ekont*derx(ll,1,2)
9244 cgrad        ghalf=0.5d0*ggg1(ll)
9245         gradcorr(ll,i)=gradcorr(ll,i)+ekont*derx(ll,2,1)
9246         gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
9247         gradcorr(ll,j)=gradcorr(ll,j)+ekont*derx(ll,4,1)
9248         gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
9249         gradcorr_long(ll,j)=gradcorr_long(ll,j)+glongij
9250         gradcorr_long(ll,i)=gradcorr_long(ll,i)-glongij
9251 cgrad        ghalf=0.5d0*ggg2(ll)
9252         gradcorr(ll,k)=gradcorr(ll,k)+ekont*derx(ll,2,2)
9253         gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
9254         gradcorr(ll,l)=gradcorr(ll,l)+ekont*derx(ll,4,2)
9255         gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
9256         gradcorr_long(ll,l)=gradcorr_long(ll,l)+glongkl
9257         gradcorr_long(ll,k)=gradcorr_long(ll,k)-glongkl
9258       enddo
9259 cgrad      do m=i+1,j-1
9260 cgrad        do ll=1,3
9261 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
9262 cgrad        enddo
9263 cgrad      enddo
9264 cgrad      do m=k+1,l-1
9265 cgrad        do ll=1,3
9266 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
9267 cgrad        enddo
9268 cgrad      enddo
9269 cgrad      do m=i+2,j2
9270 cgrad        do ll=1,3
9271 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
9272 cgrad        enddo
9273 cgrad      enddo
9274 cgrad      do m=k+2,l2
9275 cgrad        do ll=1,3
9276 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
9277 cgrad        enddo
9278 cgrad      enddo
9279 cd      do iii=1,nres-3
9280 cd        write (2,*) iii,gcorr_loc(iii)
9281 cd      enddo
9282       eello4=ekont*eel4
9283 cd      write (2,*) 'ekont',ekont
9284 cd      write (iout,*) 'eello4',ekont*eel4
9285       return
9286       end
9287 C---------------------------------------------------------------------------
9288       double precision function eello5(i,j,k,l,jj,kk)
9289       implicit real*8 (a-h,o-z)
9290       include 'DIMENSIONS'
9291       include 'COMMON.IOUNITS'
9292       include 'COMMON.CHAIN'
9293       include 'COMMON.DERIV'
9294       include 'COMMON.INTERACT'
9295       include 'COMMON.CONTACTS'
9296       include 'COMMON.TORSION'
9297       include 'COMMON.VAR'
9298       include 'COMMON.GEO'
9299       double precision pizda(2,2),auxmat(2,2),auxmat1(2,2),vv(2)
9300       double precision ggg1(3),ggg2(3)
9301 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9302 C                                                                              C
9303 C                            Parallel chains                                   C
9304 C                                                                              C
9305 C          o             o                   o             o                   C
9306 C         /l\           / \             \   / \           / \   /              C
9307 C        /   \         /   \             \ /   \         /   \ /               C
9308 C       j| o |l1       | o |              o| o |         | o |o                C
9309 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
9310 C      \i/   \         /   \ /             /   \         /   \                 C
9311 C       o    k1             o                                                  C
9312 C         (I)          (II)                (III)          (IV)                 C
9313 C                                                                              C
9314 C      eello5_1        eello5_2            eello5_3       eello5_4             C
9315 C                                                                              C
9316 C                            Antiparallel chains                               C
9317 C                                                                              C
9318 C          o             o                   o             o                   C
9319 C         /j\           / \             \   / \           / \   /              C
9320 C        /   \         /   \             \ /   \         /   \ /               C
9321 C      j1| o |l        | o |              o| o |         | o |o                C
9322 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
9323 C      \i/   \         /   \ /             /   \         /   \                 C
9324 C       o     k1            o                                                  C
9325 C         (I)          (II)                (III)          (IV)                 C
9326 C                                                                              C
9327 C      eello5_1        eello5_2            eello5_3       eello5_4             C
9328 C                                                                              C
9329 C o denotes a local interaction, vertical lines an electrostatic interaction.  C
9330 C                                                                              C
9331 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9332 cd      if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
9333 cd        eello5=0.0d0
9334 cd        return
9335 cd      endif
9336 cd      write (iout,*)
9337 cd     &   'EELLO5: Contacts have occurred for peptide groups',i,j,
9338 cd     &   ' and',k,l
9339       itk=itortyp(itype(k))
9340       itl=itortyp(itype(l))
9341       itj=itortyp(itype(j))
9342       eello5_1=0.0d0
9343       eello5_2=0.0d0
9344       eello5_3=0.0d0
9345       eello5_4=0.0d0
9346 cd      call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
9347 cd     &   eel5_3_num,eel5_4_num)
9348       do iii=1,2
9349         do kkk=1,5
9350           do lll=1,3
9351             derx(lll,kkk,iii)=0.0d0
9352           enddo
9353         enddo
9354       enddo
9355 cd      eij=facont_hb(jj,i)
9356 cd      ekl=facont_hb(kk,k)
9357 cd      ekont=eij*ekl
9358 cd      write (iout,*)'Contacts have occurred for peptide groups',
9359 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l
9360 cd      goto 1111
9361 C Contribution from the graph I.
9362 cd      write (2,*) 'AEA  ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
9363 cd      write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
9364       call transpose2(EUg(1,1,k),auxmat(1,1))
9365       call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
9366       vv(1)=pizda(1,1)-pizda(2,2)
9367       vv(2)=pizda(1,2)+pizda(2,1)
9368       eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k))
9369      & +0.5d0*scalar2(vv(1),Dtobr2(1,i))
9370 C Explicit gradient in virtual-dihedral angles.
9371       if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1)
9372      & +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k))
9373      & +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
9374       call transpose2(EUgder(1,1,k),auxmat1(1,1))
9375       call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
9376       vv(1)=pizda(1,1)-pizda(2,2)
9377       vv(2)=pizda(1,2)+pizda(2,1)
9378       g_corr5_loc(k-1)=g_corr5_loc(k-1)
9379      & +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k))
9380      & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
9381       call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
9382       vv(1)=pizda(1,1)-pizda(2,2)
9383       vv(2)=pizda(1,2)+pizda(2,1)
9384       if (l.eq.j+1) then
9385         if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1)
9386      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
9387      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
9388       else
9389         if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1)
9390      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
9391      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
9392       endif
9393 C Cartesian gradient
9394       do iii=1,2
9395         do kkk=1,5
9396           do lll=1,3
9397             call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),
9398      &        pizda(1,1))
9399             vv(1)=pizda(1,1)-pizda(2,2)
9400             vv(2)=pizda(1,2)+pizda(2,1)
9401             derx(lll,kkk,iii)=derx(lll,kkk,iii)
9402      &       +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k))
9403      &       +0.5d0*scalar2(vv(1),Dtobr2(1,i))
9404           enddo
9405         enddo
9406       enddo
9407 c      goto 1112
9408 c1111  continue
9409 C Contribution from graph II
9410       call transpose2(EE(1,1,itk),auxmat(1,1))
9411       call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
9412       vv(1)=pizda(1,1)+pizda(2,2)
9413       vv(2)=pizda(2,1)-pizda(1,2)
9414       eello5_2=scalar2(AEAb1(1,2,1),b1(1,k))
9415      & -0.5d0*scalar2(vv(1),Ctobr(1,k))
9416 C Explicit gradient in virtual-dihedral angles.
9417       g_corr5_loc(k-1)=g_corr5_loc(k-1)
9418      & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
9419       call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
9420       vv(1)=pizda(1,1)+pizda(2,2)
9421       vv(2)=pizda(2,1)-pizda(1,2)
9422       if (l.eq.j+1) then
9423         g_corr5_loc(l-1)=g_corr5_loc(l-1)
9424      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,k))
9425      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
9426       else
9427         g_corr5_loc(j-1)=g_corr5_loc(j-1)
9428      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,k))
9429      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
9430       endif
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,1),
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,iii)=derx(lll,kkk,iii)
9440      &       +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,k))
9441      &       -0.5d0*scalar2(vv(1),Ctobr(1,k))
9442           enddo
9443         enddo
9444       enddo
9445 cd      goto 1112
9446 cd1111  continue
9447       if (l.eq.j+1) then
9448 cd        goto 1110
9449 C Parallel orientation
9450 C Contribution from graph III
9451         call transpose2(EUg(1,1,l),auxmat(1,1))
9452         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
9453         vv(1)=pizda(1,1)-pizda(2,2)
9454         vv(2)=pizda(1,2)+pizda(2,1)
9455         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l))
9456      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j))
9457 C Explicit gradient in virtual-dihedral angles.
9458         g_corr5_loc(j-1)=g_corr5_loc(j-1)
9459      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l))
9460      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
9461         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
9462         vv(1)=pizda(1,1)-pizda(2,2)
9463         vv(2)=pizda(1,2)+pizda(2,1)
9464         g_corr5_loc(k-1)=g_corr5_loc(k-1)
9465      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l))
9466      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
9467         call transpose2(EUgder(1,1,l),auxmat1(1,1))
9468         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
9469         vv(1)=pizda(1,1)-pizda(2,2)
9470         vv(2)=pizda(1,2)+pizda(2,1)
9471         g_corr5_loc(l-1)=g_corr5_loc(l-1)
9472      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l))
9473      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
9474 C Cartesian gradient
9475         do iii=1,2
9476           do kkk=1,5
9477             do lll=1,3
9478               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
9479      &          pizda(1,1))
9480               vv(1)=pizda(1,1)-pizda(2,2)
9481               vv(2)=pizda(1,2)+pizda(2,1)
9482               derx(lll,kkk,iii)=derx(lll,kkk,iii)
9483      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l))
9484      &         +0.5d0*scalar2(vv(1),Dtobr2(1,j))
9485             enddo
9486           enddo
9487         enddo
9488 cd        goto 1112
9489 C Contribution from graph IV
9490 cd1110    continue
9491         call transpose2(EE(1,1,itl),auxmat(1,1))
9492         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
9493         vv(1)=pizda(1,1)+pizda(2,2)
9494         vv(2)=pizda(2,1)-pizda(1,2)
9495         eello5_4=scalar2(AEAb1(1,2,2),b1(1,l))
9496      &   -0.5d0*scalar2(vv(1),Ctobr(1,l))
9497 C Explicit gradient in virtual-dihedral angles.
9498         g_corr5_loc(l-1)=g_corr5_loc(l-1)
9499      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
9500         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
9501         vv(1)=pizda(1,1)+pizda(2,2)
9502         vv(2)=pizda(2,1)-pizda(1,2)
9503         g_corr5_loc(k-1)=g_corr5_loc(k-1)
9504      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,l))
9505      &   -0.5d0*scalar2(vv(1),Ctobr(1,l)))
9506 C Cartesian gradient
9507         do iii=1,2
9508           do kkk=1,5
9509             do lll=1,3
9510               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
9511      &          pizda(1,1))
9512               vv(1)=pizda(1,1)+pizda(2,2)
9513               vv(2)=pizda(2,1)-pizda(1,2)
9514               derx(lll,kkk,iii)=derx(lll,kkk,iii)
9515      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,l))
9516      &         -0.5d0*scalar2(vv(1),Ctobr(1,l))
9517             enddo
9518           enddo
9519         enddo
9520       else
9521 C Antiparallel orientation
9522 C Contribution from graph III
9523 c        goto 1110
9524         call transpose2(EUg(1,1,j),auxmat(1,1))
9525         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
9526         vv(1)=pizda(1,1)-pizda(2,2)
9527         vv(2)=pizda(1,2)+pizda(2,1)
9528         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j))
9529      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l))
9530 C Explicit gradient in virtual-dihedral angles.
9531         g_corr5_loc(l-1)=g_corr5_loc(l-1)
9532      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j))
9533      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
9534         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
9535         vv(1)=pizda(1,1)-pizda(2,2)
9536         vv(2)=pizda(1,2)+pizda(2,1)
9537         g_corr5_loc(k-1)=g_corr5_loc(k-1)
9538      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j))
9539      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
9540         call transpose2(EUgder(1,1,j),auxmat1(1,1))
9541         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
9542         vv(1)=pizda(1,1)-pizda(2,2)
9543         vv(2)=pizda(1,2)+pizda(2,1)
9544         g_corr5_loc(j-1)=g_corr5_loc(j-1)
9545      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j))
9546      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
9547 C Cartesian gradient
9548         do iii=1,2
9549           do kkk=1,5
9550             do lll=1,3
9551               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
9552      &          pizda(1,1))
9553               vv(1)=pizda(1,1)-pizda(2,2)
9554               vv(2)=pizda(1,2)+pizda(2,1)
9555               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
9556      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j))
9557      &         +0.5d0*scalar2(vv(1),Dtobr2(1,l))
9558             enddo
9559           enddo
9560         enddo
9561 cd        goto 1112
9562 C Contribution from graph IV
9563 1110    continue
9564         call transpose2(EE(1,1,itj),auxmat(1,1))
9565         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
9566         vv(1)=pizda(1,1)+pizda(2,2)
9567         vv(2)=pizda(2,1)-pizda(1,2)
9568         eello5_4=scalar2(AEAb1(1,2,2),b1(1,j))
9569      &   -0.5d0*scalar2(vv(1),Ctobr(1,j))
9570 C Explicit gradient in virtual-dihedral angles.
9571         g_corr5_loc(j-1)=g_corr5_loc(j-1)
9572      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
9573         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
9574         vv(1)=pizda(1,1)+pizda(2,2)
9575         vv(2)=pizda(2,1)-pizda(1,2)
9576         g_corr5_loc(k-1)=g_corr5_loc(k-1)
9577      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,j))
9578      &   -0.5d0*scalar2(vv(1),Ctobr(1,j)))
9579 C Cartesian gradient
9580         do iii=1,2
9581           do kkk=1,5
9582             do lll=1,3
9583               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
9584      &          pizda(1,1))
9585               vv(1)=pizda(1,1)+pizda(2,2)
9586               vv(2)=pizda(2,1)-pizda(1,2)
9587               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
9588      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,j))
9589      &         -0.5d0*scalar2(vv(1),Ctobr(1,j))
9590             enddo
9591           enddo
9592         enddo
9593       endif
9594 1112  continue
9595       eel5=eello5_1+eello5_2+eello5_3+eello5_4
9596 cd      if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
9597 cd        write (2,*) 'ijkl',i,j,k,l
9598 cd        write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
9599 cd     &     ' eello5_3',eello5_3,' eello5_4',eello5_4
9600 cd      endif
9601 cd      write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
9602 cd      write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
9603 cd      write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
9604 cd      write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
9605       if (j.lt.nres-1) then
9606         j1=j+1
9607         j2=j-1
9608       else
9609         j1=j-1
9610         j2=j-2
9611       endif
9612       if (l.lt.nres-1) then
9613         l1=l+1
9614         l2=l-1
9615       else
9616         l1=l-1
9617         l2=l-2
9618       endif
9619 cd      eij=1.0d0
9620 cd      ekl=1.0d0
9621 cd      ekont=1.0d0
9622 cd      write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
9623 C 2/11/08 AL Gradients over DC's connecting interacting sites will be
9624 C        summed up outside the subrouine as for the other subroutines
9625 C        handling long-range interactions. The old code is commented out
9626 C        with "cgrad" to keep track of changes.
9627       do ll=1,3
9628 cgrad        ggg1(ll)=eel5*g_contij(ll,1)
9629 cgrad        ggg2(ll)=eel5*g_contij(ll,2)
9630         gradcorr5ij=eel5*g_contij(ll,1)+ekont*derx(ll,1,1)
9631         gradcorr5kl=eel5*g_contij(ll,2)+ekont*derx(ll,1,2)
9632 c        write (iout,'(a,3i3,a,5f8.3,2i3,a,5f8.3,a,f8.3)')
9633 c     &   "ecorr5",ll,i,j," derx",derx(ll,2,1),derx(ll,3,1),derx(ll,4,1),
9634 c     &   derx(ll,5,1),k,l," derx",derx(ll,2,2),derx(ll,3,2),
9635 c     &   derx(ll,4,2),derx(ll,5,2)," ekont",ekont
9636 c        write (iout,'(a,3i3,a,3f8.3,2i3,a,3f8.3)')
9637 c     &   "ecorr5",ll,i,j," gradcorr5",g_contij(ll,1),derx(ll,1,1),
9638 c     &   gradcorr5ij,
9639 c     &   k,l," gradcorr5",g_contij(ll,2),derx(ll,1,2),gradcorr5kl
9640 cold        ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
9641 cgrad        ghalf=0.5d0*ggg1(ll)
9642 cd        ghalf=0.0d0
9643         gradcorr5(ll,i)=gradcorr5(ll,i)+ekont*derx(ll,2,1)
9644         gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
9645         gradcorr5(ll,j)=gradcorr5(ll,j)+ekont*derx(ll,4,1)
9646         gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
9647         gradcorr5_long(ll,j)=gradcorr5_long(ll,j)+gradcorr5ij
9648         gradcorr5_long(ll,i)=gradcorr5_long(ll,i)-gradcorr5ij
9649 cold        ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
9650 cgrad        ghalf=0.5d0*ggg2(ll)
9651 cd        ghalf=0.0d0
9652         gradcorr5(ll,k)=gradcorr5(ll,k)+ekont*derx(ll,2,2)
9653         gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
9654         gradcorr5(ll,l)=gradcorr5(ll,l)+ekont*derx(ll,4,2)
9655         gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
9656         gradcorr5_long(ll,l)=gradcorr5_long(ll,l)+gradcorr5kl
9657         gradcorr5_long(ll,k)=gradcorr5_long(ll,k)-gradcorr5kl
9658       enddo
9659 cd      goto 1112
9660 cgrad      do m=i+1,j-1
9661 cgrad        do ll=1,3
9662 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
9663 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
9664 cgrad        enddo
9665 cgrad      enddo
9666 cgrad      do m=k+1,l-1
9667 cgrad        do ll=1,3
9668 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
9669 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
9670 cgrad        enddo
9671 cgrad      enddo
9672 c1112  continue
9673 cgrad      do m=i+2,j2
9674 cgrad        do ll=1,3
9675 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
9676 cgrad        enddo
9677 cgrad      enddo
9678 cgrad      do m=k+2,l2
9679 cgrad        do ll=1,3
9680 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
9681 cgrad        enddo
9682 cgrad      enddo
9683 cd      do iii=1,nres-3
9684 cd        write (2,*) iii,g_corr5_loc(iii)
9685 cd      enddo
9686       eello5=ekont*eel5
9687 cd      write (2,*) 'ekont',ekont
9688 cd      write (iout,*) 'eello5',ekont*eel5
9689       return
9690       end
9691 c--------------------------------------------------------------------------
9692       double precision function eello6(i,j,k,l,jj,kk)
9693       implicit real*8 (a-h,o-z)
9694       include 'DIMENSIONS'
9695       include 'COMMON.IOUNITS'
9696       include 'COMMON.CHAIN'
9697       include 'COMMON.DERIV'
9698       include 'COMMON.INTERACT'
9699       include 'COMMON.CONTACTS'
9700       include 'COMMON.TORSION'
9701       include 'COMMON.VAR'
9702       include 'COMMON.GEO'
9703       include 'COMMON.FFIELD'
9704       double precision ggg1(3),ggg2(3)
9705 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
9706 cd        eello6=0.0d0
9707 cd        return
9708 cd      endif
9709 cd      write (iout,*)
9710 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
9711 cd     &   ' and',k,l
9712       eello6_1=0.0d0
9713       eello6_2=0.0d0
9714       eello6_3=0.0d0
9715       eello6_4=0.0d0
9716       eello6_5=0.0d0
9717       eello6_6=0.0d0
9718 cd      call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
9719 cd     &   eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
9720       do iii=1,2
9721         do kkk=1,5
9722           do lll=1,3
9723             derx(lll,kkk,iii)=0.0d0
9724           enddo
9725         enddo
9726       enddo
9727 cd      eij=facont_hb(jj,i)
9728 cd      ekl=facont_hb(kk,k)
9729 cd      ekont=eij*ekl
9730 cd      eij=1.0d0
9731 cd      ekl=1.0d0
9732 cd      ekont=1.0d0
9733       if (l.eq.j+1) then
9734         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
9735         eello6_2=eello6_graph1(j,i,l,k,2,.false.)
9736         eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
9737         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
9738         eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
9739         eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
9740       else
9741         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
9742         eello6_2=eello6_graph1(l,k,j,i,2,.true.)
9743         eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
9744         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
9745         if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
9746           eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
9747         else
9748           eello6_5=0.0d0
9749         endif
9750         eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
9751       endif
9752 C If turn contributions are considered, they will be handled separately.
9753       eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
9754 cd      write(iout,*) 'eello6_1',eello6_1!,' eel6_1_num',16*eel6_1_num
9755 cd      write(iout,*) 'eello6_2',eello6_2!,' eel6_2_num',16*eel6_2_num
9756 cd      write(iout,*) 'eello6_3',eello6_3!,' eel6_3_num',16*eel6_3_num
9757 cd      write(iout,*) 'eello6_4',eello6_4!,' eel6_4_num',16*eel6_4_num
9758 cd      write(iout,*) 'eello6_5',eello6_5!,' eel6_5_num',16*eel6_5_num
9759 cd      write(iout,*) 'eello6_6',eello6_6!,' eel6_6_num',16*eel6_6_num
9760 cd      goto 1112
9761       if (j.lt.nres-1) then
9762         j1=j+1
9763         j2=j-1
9764       else
9765         j1=j-1
9766         j2=j-2
9767       endif
9768       if (l.lt.nres-1) then
9769         l1=l+1
9770         l2=l-1
9771       else
9772         l1=l-1
9773         l2=l-2
9774       endif
9775       do ll=1,3
9776 cgrad        ggg1(ll)=eel6*g_contij(ll,1)
9777 cgrad        ggg2(ll)=eel6*g_contij(ll,2)
9778 cold        ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
9779 cgrad        ghalf=0.5d0*ggg1(ll)
9780 cd        ghalf=0.0d0
9781         gradcorr6ij=eel6*g_contij(ll,1)+ekont*derx(ll,1,1)
9782         gradcorr6kl=eel6*g_contij(ll,2)+ekont*derx(ll,1,2)
9783         gradcorr6(ll,i)=gradcorr6(ll,i)+ekont*derx(ll,2,1)
9784         gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
9785         gradcorr6(ll,j)=gradcorr6(ll,j)+ekont*derx(ll,4,1)
9786         gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
9787         gradcorr6_long(ll,j)=gradcorr6_long(ll,j)+gradcorr6ij
9788         gradcorr6_long(ll,i)=gradcorr6_long(ll,i)-gradcorr6ij
9789 cgrad        ghalf=0.5d0*ggg2(ll)
9790 cold        ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
9791 cd        ghalf=0.0d0
9792         gradcorr6(ll,k)=gradcorr6(ll,k)+ekont*derx(ll,2,2)
9793         gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
9794         gradcorr6(ll,l)=gradcorr6(ll,l)+ekont*derx(ll,4,2)
9795         gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
9796         gradcorr6_long(ll,l)=gradcorr6_long(ll,l)+gradcorr6kl
9797         gradcorr6_long(ll,k)=gradcorr6_long(ll,k)-gradcorr6kl
9798       enddo
9799 cd      goto 1112
9800 cgrad      do m=i+1,j-1
9801 cgrad        do ll=1,3
9802 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
9803 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
9804 cgrad        enddo
9805 cgrad      enddo
9806 cgrad      do m=k+1,l-1
9807 cgrad        do ll=1,3
9808 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
9809 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
9810 cgrad        enddo
9811 cgrad      enddo
9812 cgrad1112  continue
9813 cgrad      do m=i+2,j2
9814 cgrad        do ll=1,3
9815 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
9816 cgrad        enddo
9817 cgrad      enddo
9818 cgrad      do m=k+2,l2
9819 cgrad        do ll=1,3
9820 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
9821 cgrad        enddo
9822 cgrad      enddo
9823 cd      do iii=1,nres-3
9824 cd        write (2,*) iii,g_corr6_loc(iii)
9825 cd      enddo
9826       eello6=ekont*eel6
9827 cd      write (2,*) 'ekont',ekont
9828 cd      write (iout,*) 'eello6',ekont*eel6
9829       return
9830       end
9831 c--------------------------------------------------------------------------
9832       double precision function eello6_graph1(i,j,k,l,imat,swap)
9833       implicit real*8 (a-h,o-z)
9834       include 'DIMENSIONS'
9835       include 'COMMON.IOUNITS'
9836       include 'COMMON.CHAIN'
9837       include 'COMMON.DERIV'
9838       include 'COMMON.INTERACT'
9839       include 'COMMON.CONTACTS'
9840       include 'COMMON.TORSION'
9841       include 'COMMON.VAR'
9842       include 'COMMON.GEO'
9843       double precision vv(2),vv1(2),pizda(2,2),auxmat(2,2),pizda1(2,2)
9844       logical swap
9845       logical lprn
9846       common /kutas/ lprn
9847 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9848 C                                                                              C
9849 C      Parallel       Antiparallel                                             C
9850 C                                                                              C
9851 C          o             o                                                     C
9852 C         /l\           /j\                                                    C
9853 C        /   \         /   \                                                   C
9854 C       /| o |         | o |\                                                  C
9855 C     \ j|/k\|  /   \  |/k\|l /                                                C
9856 C      \ /   \ /     \ /   \ /                                                 C
9857 C       o     o       o     o                                                  C
9858 C       i             i                                                        C
9859 C                                                                              C
9860 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9861       itk=itortyp(itype(k))
9862       s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
9863       s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
9864       s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
9865       call transpose2(EUgC(1,1,k),auxmat(1,1))
9866       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
9867       vv1(1)=pizda1(1,1)-pizda1(2,2)
9868       vv1(2)=pizda1(1,2)+pizda1(2,1)
9869       s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
9870       vv(1)=AEAb1(1,2,imat)*b1(1,k)-AEAb1(2,2,imat)*b1(2,k)
9871       vv(2)=AEAb1(1,2,imat)*b1(2,k)+AEAb1(2,2,imat)*b1(1,k)
9872       s5=scalar2(vv(1),Dtobr2(1,i))
9873 cd      write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
9874       eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
9875       if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1)
9876      & -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i))
9877      & -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k))
9878      & +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k))
9879      & +0.5d0*scalar2(vv1(1),Dtobr2der(1,i))
9880      & +scalar2(vv(1),Dtobr2der(1,i)))
9881       call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
9882       vv1(1)=pizda1(1,1)-pizda1(2,2)
9883       vv1(2)=pizda1(1,2)+pizda1(2,1)
9884       vv(1)=AEAb1derg(1,2,imat)*b1(1,k)-AEAb1derg(2,2,imat)*b1(2,k)
9885       vv(2)=AEAb1derg(1,2,imat)*b1(2,k)+AEAb1derg(2,2,imat)*b1(1,k)
9886       if (l.eq.j+1) then
9887         g_corr6_loc(l-1)=g_corr6_loc(l-1)
9888      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
9889      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
9890      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
9891      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
9892       else
9893         g_corr6_loc(j-1)=g_corr6_loc(j-1)
9894      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
9895      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
9896      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
9897      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
9898       endif
9899       call transpose2(EUgCder(1,1,k),auxmat(1,1))
9900       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
9901       vv1(1)=pizda1(1,1)-pizda1(2,2)
9902       vv1(2)=pizda1(1,2)+pizda1(2,1)
9903       if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1)
9904      & +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k))
9905      & +scalar2(AEAb2(1,1,imat),CUgb2der(1,k))
9906      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
9907       do iii=1,2
9908         if (swap) then
9909           ind=3-iii
9910         else
9911           ind=iii
9912         endif
9913         do kkk=1,5
9914           do lll=1,3
9915             s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
9916             s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
9917             s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
9918             call transpose2(EUgC(1,1,k),auxmat(1,1))
9919             call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
9920      &        pizda1(1,1))
9921             vv1(1)=pizda1(1,1)-pizda1(2,2)
9922             vv1(2)=pizda1(1,2)+pizda1(2,1)
9923             s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
9924             vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,k)
9925      &       -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,k)
9926             vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,k)
9927      &       +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,k)
9928             s5=scalar2(vv(1),Dtobr2(1,i))
9929             derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
9930           enddo
9931         enddo
9932       enddo
9933       return
9934       end
9935 c----------------------------------------------------------------------------
9936       double precision function eello6_graph2(i,j,k,l,jj,kk,swap)
9937       implicit real*8 (a-h,o-z)
9938       include 'DIMENSIONS'
9939       include 'COMMON.IOUNITS'
9940       include 'COMMON.CHAIN'
9941       include 'COMMON.DERIV'
9942       include 'COMMON.INTERACT'
9943       include 'COMMON.CONTACTS'
9944       include 'COMMON.TORSION'
9945       include 'COMMON.VAR'
9946       include 'COMMON.GEO'
9947       logical swap
9948       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
9949      & auxvec1(2),auxvec2(2),auxmat1(2,2)
9950       logical lprn
9951       common /kutas/ lprn
9952 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9953 C                                                                              C
9954 C      Parallel       Antiparallel                                             C
9955 C                                                                              C
9956 C          o             o                                                     C
9957 C     \   /l\           /j\   /                                                C
9958 C      \ /   \         /   \ /                                                 C
9959 C       o| o |         | o |o                                                  C
9960 C     \ j|/k\|      \  |/k\|l                                                  C
9961 C      \ /   \       \ /   \                                                   C
9962 C       o             o                                                        C
9963 C       i             i                                                        C
9964 C                                                                              C
9965 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9966 cd      write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
9967 C AL 7/4/01 s1 would occur in the sixth-order moment,
9968 C           but not in a cluster cumulant
9969 #ifdef MOMENT
9970       s1=dip(1,jj,i)*dip(1,kk,k)
9971 #endif
9972       call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
9973       s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
9974       call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
9975       s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
9976       call transpose2(EUg(1,1,k),auxmat(1,1))
9977       call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
9978       vv(1)=pizda(1,1)-pizda(2,2)
9979       vv(2)=pizda(1,2)+pizda(2,1)
9980       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
9981 cd      write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
9982 #ifdef MOMENT
9983       eello6_graph2=-(s1+s2+s3+s4)
9984 #else
9985       eello6_graph2=-(s2+s3+s4)
9986 #endif
9987 c      eello6_graph2=-s3
9988 C Derivatives in gamma(i-1)
9989       if (i.gt.1) then
9990 #ifdef MOMENT
9991         s1=dipderg(1,jj,i)*dip(1,kk,k)
9992 #endif
9993         s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
9994         call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
9995         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
9996         s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
9997 #ifdef MOMENT
9998         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
9999 #else
10000         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
10001 #endif
10002 c        g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
10003       endif
10004 C Derivatives in gamma(k-1)
10005 #ifdef MOMENT
10006       s1=dip(1,jj,i)*dipderg(1,kk,k)
10007 #endif
10008       call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
10009       s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
10010       call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
10011       s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
10012       call transpose2(EUgder(1,1,k),auxmat1(1,1))
10013       call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
10014       vv(1)=pizda(1,1)-pizda(2,2)
10015       vv(2)=pizda(1,2)+pizda(2,1)
10016       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
10017 #ifdef MOMENT
10018       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
10019 #else
10020       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
10021 #endif
10022 c      g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
10023 C Derivatives in gamma(j-1) or gamma(l-1)
10024       if (j.gt.1) then
10025 #ifdef MOMENT
10026         s1=dipderg(3,jj,i)*dip(1,kk,k)
10027 #endif
10028         call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
10029         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
10030         s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
10031         call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
10032         vv(1)=pizda(1,1)-pizda(2,2)
10033         vv(2)=pizda(1,2)+pizda(2,1)
10034         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
10035 #ifdef MOMENT
10036         if (swap) then
10037           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
10038         else
10039           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
10040         endif
10041 #endif
10042         g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
10043 c        g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
10044       endif
10045 C Derivatives in gamma(l-1) or gamma(j-1)
10046       if (l.gt.1) then
10047 #ifdef MOMENT
10048         s1=dip(1,jj,i)*dipderg(3,kk,k)
10049 #endif
10050         call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
10051         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
10052         call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
10053         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
10054         call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
10055         vv(1)=pizda(1,1)-pizda(2,2)
10056         vv(2)=pizda(1,2)+pizda(2,1)
10057         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
10058 #ifdef MOMENT
10059         if (swap) then
10060           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
10061         else
10062           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
10063         endif
10064 #endif
10065         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
10066 c        g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
10067       endif
10068 C Cartesian derivatives.
10069       if (lprn) then
10070         write (2,*) 'In eello6_graph2'
10071         do iii=1,2
10072           write (2,*) 'iii=',iii
10073           do kkk=1,5
10074             write (2,*) 'kkk=',kkk
10075             do jjj=1,2
10076               write (2,'(3(2f10.5),5x)')
10077      &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
10078             enddo
10079           enddo
10080         enddo
10081       endif
10082       do iii=1,2
10083         do kkk=1,5
10084           do lll=1,3
10085 #ifdef MOMENT
10086             if (iii.eq.1) then
10087               s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
10088             else
10089               s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
10090             endif
10091 #endif
10092             call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),
10093      &        auxvec(1))
10094             s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
10095             call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),
10096      &        auxvec(1))
10097             s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
10098             call transpose2(EUg(1,1,k),auxmat(1,1))
10099             call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),
10100      &        pizda(1,1))
10101             vv(1)=pizda(1,1)-pizda(2,2)
10102             vv(2)=pizda(1,2)+pizda(2,1)
10103             s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
10104 cd            write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
10105 #ifdef MOMENT
10106             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
10107 #else
10108             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
10109 #endif
10110             if (swap) then
10111               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
10112             else
10113               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
10114             endif
10115           enddo
10116         enddo
10117       enddo
10118       return
10119       end
10120 c----------------------------------------------------------------------------
10121       double precision function eello6_graph3(i,j,k,l,jj,kk,swap)
10122       implicit real*8 (a-h,o-z)
10123       include 'DIMENSIONS'
10124       include 'COMMON.IOUNITS'
10125       include 'COMMON.CHAIN'
10126       include 'COMMON.DERIV'
10127       include 'COMMON.INTERACT'
10128       include 'COMMON.CONTACTS'
10129       include 'COMMON.TORSION'
10130       include 'COMMON.VAR'
10131       include 'COMMON.GEO'
10132       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2)
10133       logical swap
10134 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10135 C                                                                              C
10136 C      Parallel       Antiparallel                                             C
10137 C                                                                              C
10138 C          o             o                                                     C
10139 C         /l\   /   \   /j\                                                    C
10140 C        /   \ /     \ /   \                                                   C
10141 C       /| o |o       o| o |\                                                  C
10142 C       j|/k\|  /      |/k\|l /                                                C
10143 C        /   \ /       /   \ /                                                 C
10144 C       /     o       /     o                                                  C
10145 C       i             i                                                        C
10146 C                                                                              C
10147 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10148 C
10149 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
10150 C           energy moment and not to the cluster cumulant.
10151       iti=itortyp(itype(i))
10152       if (j.lt.nres-1) then
10153         itj1=itortyp(itype(j+1))
10154       else
10155         itj1=ntortyp
10156       endif
10157       itk=itortyp(itype(k))
10158       itk1=itortyp(itype(k+1))
10159       if (l.lt.nres-1) then
10160         itl1=itortyp(itype(l+1))
10161       else
10162         itl1=ntortyp
10163       endif
10164 #ifdef MOMENT
10165       s1=dip(4,jj,i)*dip(4,kk,k)
10166 #endif
10167       call matvec2(AECA(1,1,1),b1(1,k+1),auxvec(1))
10168       s2=0.5d0*scalar2(b1(1,k),auxvec(1))
10169       call matvec2(AECA(1,1,2),b1(1,l+1),auxvec(1))
10170       s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
10171       call transpose2(EE(1,1,itk),auxmat(1,1))
10172       call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
10173       vv(1)=pizda(1,1)+pizda(2,2)
10174       vv(2)=pizda(2,1)-pizda(1,2)
10175       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
10176 cd      write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4,
10177 cd     & "sum",-(s2+s3+s4)
10178 #ifdef MOMENT
10179       eello6_graph3=-(s1+s2+s3+s4)
10180 #else
10181       eello6_graph3=-(s2+s3+s4)
10182 #endif
10183 c      eello6_graph3=-s4
10184 C Derivatives in gamma(k-1)
10185       call matvec2(AECAderg(1,1,2),b1(1,l+1),auxvec(1))
10186       s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
10187       s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
10188       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
10189 C Derivatives in gamma(l-1)
10190       call matvec2(AECAderg(1,1,1),b1(1,k+1),auxvec(1))
10191       s2=0.5d0*scalar2(b1(1,k),auxvec(1))
10192       call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
10193       vv(1)=pizda(1,1)+pizda(2,2)
10194       vv(2)=pizda(2,1)-pizda(1,2)
10195       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
10196       g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
10197 C Cartesian derivatives.
10198       do iii=1,2
10199         do kkk=1,5
10200           do lll=1,3
10201 #ifdef MOMENT
10202             if (iii.eq.1) then
10203               s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
10204             else
10205               s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
10206             endif
10207 #endif
10208             call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
10209      &        auxvec(1))
10210             s2=0.5d0*scalar2(b1(1,k),auxvec(1))
10211             call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,l+1),
10212      &        auxvec(1))
10213             s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
10214             call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),
10215      &        pizda(1,1))
10216             vv(1)=pizda(1,1)+pizda(2,2)
10217             vv(2)=pizda(2,1)-pizda(1,2)
10218             s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
10219 #ifdef MOMENT
10220             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
10221 #else
10222             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
10223 #endif
10224             if (swap) then
10225               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
10226             else
10227               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
10228             endif
10229 c            derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
10230           enddo
10231         enddo
10232       enddo
10233       return
10234       end
10235 c----------------------------------------------------------------------------
10236       double precision function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
10237       implicit real*8 (a-h,o-z)
10238       include 'DIMENSIONS'
10239       include 'COMMON.IOUNITS'
10240       include 'COMMON.CHAIN'
10241       include 'COMMON.DERIV'
10242       include 'COMMON.INTERACT'
10243       include 'COMMON.CONTACTS'
10244       include 'COMMON.TORSION'
10245       include 'COMMON.VAR'
10246       include 'COMMON.GEO'
10247       include 'COMMON.FFIELD'
10248       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
10249      & auxvec1(2),auxmat1(2,2)
10250       logical swap
10251 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10252 C                                                                              C
10253 C      Parallel       Antiparallel                                             C
10254 C                                                                              C
10255 C          o             o                                                     C
10256 C         /l\   /   \   /j\                                                    C
10257 C        /   \ /     \ /   \                                                   C
10258 C       /| o |o       o| o |\                                                  C
10259 C     \ j|/k\|      \  |/k\|l                                                  C
10260 C      \ /   \       \ /   \                                                   C
10261 C       o     \       o     \                                                  C
10262 C       i             i                                                        C
10263 C                                                                              C
10264 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10265 C
10266 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
10267 C           energy moment and not to the cluster cumulant.
10268 cd      write (2,*) 'eello_graph4: wturn6',wturn6
10269       iti=itortyp(itype(i))
10270       itj=itortyp(itype(j))
10271       if (j.lt.nres-1) then
10272         itj1=itortyp(itype(j+1))
10273       else
10274         itj1=ntortyp
10275       endif
10276       itk=itortyp(itype(k))
10277       if (k.lt.nres-1) then
10278         itk1=itortyp(itype(k+1))
10279       else
10280         itk1=ntortyp
10281       endif
10282       itl=itortyp(itype(l))
10283       if (l.lt.nres-1) then
10284         itl1=itortyp(itype(l+1))
10285       else
10286         itl1=ntortyp
10287       endif
10288 cd      write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
10289 cd      write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
10290 cd     & ' itl',itl,' itl1',itl1
10291 #ifdef MOMENT
10292       if (imat.eq.1) then
10293         s1=dip(3,jj,i)*dip(3,kk,k)
10294       else
10295         s1=dip(2,jj,j)*dip(2,kk,l)
10296       endif
10297 #endif
10298       call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
10299       s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
10300       if (j.eq.l+1) then
10301         call matvec2(ADtEA1(1,1,3-imat),b1(1,j+1),auxvec1(1))
10302         s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
10303       else
10304         call matvec2(ADtEA1(1,1,3-imat),b1(1,l+1),auxvec1(1))
10305         s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
10306       endif
10307       call transpose2(EUg(1,1,k),auxmat(1,1))
10308       call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
10309       vv(1)=pizda(1,1)-pizda(2,2)
10310       vv(2)=pizda(2,1)+pizda(1,2)
10311       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
10312 cd      write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
10313 #ifdef MOMENT
10314       eello6_graph4=-(s1+s2+s3+s4)
10315 #else
10316       eello6_graph4=-(s2+s3+s4)
10317 #endif
10318 C Derivatives in gamma(i-1)
10319       if (i.gt.1) then
10320 #ifdef MOMENT
10321         if (imat.eq.1) then
10322           s1=dipderg(2,jj,i)*dip(3,kk,k)
10323         else
10324           s1=dipderg(4,jj,j)*dip(2,kk,l)
10325         endif
10326 #endif
10327         s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
10328         if (j.eq.l+1) then
10329           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,j+1),auxvec1(1))
10330           s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
10331         else
10332           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,l+1),auxvec1(1))
10333           s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
10334         endif
10335         s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
10336         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
10337 cd          write (2,*) 'turn6 derivatives'
10338 #ifdef MOMENT
10339           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
10340 #else
10341           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
10342 #endif
10343         else
10344 #ifdef MOMENT
10345           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
10346 #else
10347           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
10348 #endif
10349         endif
10350       endif
10351 C Derivatives in gamma(k-1)
10352 #ifdef MOMENT
10353       if (imat.eq.1) then
10354         s1=dip(3,jj,i)*dipderg(2,kk,k)
10355       else
10356         s1=dip(2,jj,j)*dipderg(4,kk,l)
10357       endif
10358 #endif
10359       call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
10360       s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
10361       if (j.eq.l+1) then
10362         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,j+1),auxvec1(1))
10363         s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
10364       else
10365         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,l+1),auxvec1(1))
10366         s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
10367       endif
10368       call transpose2(EUgder(1,1,k),auxmat1(1,1))
10369       call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
10370       vv(1)=pizda(1,1)-pizda(2,2)
10371       vv(2)=pizda(2,1)+pizda(1,2)
10372       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
10373       if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
10374 #ifdef MOMENT
10375         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
10376 #else
10377         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
10378 #endif
10379       else
10380 #ifdef MOMENT
10381         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
10382 #else
10383         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
10384 #endif
10385       endif
10386 C Derivatives in gamma(j-1) or gamma(l-1)
10387       if (l.eq.j+1 .and. l.gt.1) then
10388         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
10389         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
10390         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
10391         vv(1)=pizda(1,1)-pizda(2,2)
10392         vv(2)=pizda(2,1)+pizda(1,2)
10393         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
10394         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
10395       else if (j.gt.1) then
10396         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
10397         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
10398         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
10399         vv(1)=pizda(1,1)-pizda(2,2)
10400         vv(2)=pizda(2,1)+pizda(1,2)
10401         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
10402         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
10403           gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
10404         else
10405           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
10406         endif
10407       endif
10408 C Cartesian derivatives.
10409       do iii=1,2
10410         do kkk=1,5
10411           do lll=1,3
10412 #ifdef MOMENT
10413             if (iii.eq.1) then
10414               if (imat.eq.1) then
10415                 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
10416               else
10417                 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
10418               endif
10419             else
10420               if (imat.eq.1) then
10421                 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
10422               else
10423                 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
10424               endif
10425             endif
10426 #endif
10427             call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),
10428      &        auxvec(1))
10429             s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
10430             if (j.eq.l+1) then
10431               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
10432      &          b1(1,j+1),auxvec(1))
10433               s3=-0.5d0*scalar2(b1(1,j),auxvec(1))
10434             else
10435               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
10436      &          b1(1,l+1),auxvec(1))
10437               s3=-0.5d0*scalar2(b1(1,l),auxvec(1))
10438             endif
10439             call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
10440      &        pizda(1,1))
10441             vv(1)=pizda(1,1)-pizda(2,2)
10442             vv(2)=pizda(2,1)+pizda(1,2)
10443             s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
10444             if (swap) then
10445               if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
10446 #ifdef MOMENT
10447                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
10448      &             -(s1+s2+s4)
10449 #else
10450                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
10451      &             -(s2+s4)
10452 #endif
10453                 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
10454               else
10455 #ifdef MOMENT
10456                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
10457 #else
10458                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
10459 #endif
10460                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
10461               endif
10462             else
10463 #ifdef MOMENT
10464               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
10465 #else
10466               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
10467 #endif
10468               if (l.eq.j+1) then
10469                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
10470               else
10471                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
10472               endif
10473             endif
10474           enddo
10475         enddo
10476       enddo
10477       return
10478       end
10479 c----------------------------------------------------------------------------
10480       double precision function eello_turn6(i,jj,kk)
10481       implicit real*8 (a-h,o-z)
10482       include 'DIMENSIONS'
10483       include 'COMMON.IOUNITS'
10484       include 'COMMON.CHAIN'
10485       include 'COMMON.DERIV'
10486       include 'COMMON.INTERACT'
10487       include 'COMMON.CONTACTS'
10488       include 'COMMON.TORSION'
10489       include 'COMMON.VAR'
10490       include 'COMMON.GEO'
10491       double precision vtemp1(2),vtemp2(2),vtemp3(2),vtemp4(2),
10492      &  atemp(2,2),auxmat(2,2),achuj_temp(2,2),gtemp(2,2),gvec(2),
10493      &  ggg1(3),ggg2(3)
10494       double precision vtemp1d(2),vtemp2d(2),vtemp3d(2),vtemp4d(2),
10495      &  atempd(2,2),auxmatd(2,2),achuj_tempd(2,2),gtempd(2,2),gvecd(2)
10496 C 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
10497 C           the respective energy moment and not to the cluster cumulant.
10498       s1=0.0d0
10499       s8=0.0d0
10500       s13=0.0d0
10501 c
10502       eello_turn6=0.0d0
10503       j=i+4
10504       k=i+1
10505       l=i+3
10506       iti=itortyp(itype(i))
10507       itk=itortyp(itype(k))
10508       itk1=itortyp(itype(k+1))
10509       itl=itortyp(itype(l))
10510       itj=itortyp(itype(j))
10511 cd      write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
10512 cd      write (2,*) 'i',i,' k',k,' j',j,' l',l
10513 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
10514 cd        eello6=0.0d0
10515 cd        return
10516 cd      endif
10517 cd      write (iout,*)
10518 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
10519 cd     &   ' and',k,l
10520 cd      call checkint_turn6(i,jj,kk,eel_turn6_num)
10521       do iii=1,2
10522         do kkk=1,5
10523           do lll=1,3
10524             derx_turn(lll,kkk,iii)=0.0d0
10525           enddo
10526         enddo
10527       enddo
10528 cd      eij=1.0d0
10529 cd      ekl=1.0d0
10530 cd      ekont=1.0d0
10531       eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
10532 cd      eello6_5=0.0d0
10533 cd      write (2,*) 'eello6_5',eello6_5
10534 #ifdef MOMENT
10535       call transpose2(AEA(1,1,1),auxmat(1,1))
10536       call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
10537       ss1=scalar2(Ub2(1,i+2),b1(1,l))
10538       s1 = (auxmat(1,1)+auxmat(2,2))*ss1
10539 #endif
10540       call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1(1))
10541       call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
10542       s2 = scalar2(b1(1,k),vtemp1(1))
10543 #ifdef MOMENT
10544       call transpose2(AEA(1,1,2),atemp(1,1))
10545       call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
10546       call matvec2(Ug2(1,1,i+2),dd(1,1,itk1),vtemp2(1))
10547       s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
10548 #endif
10549       call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
10550       call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
10551       s12 = scalar2(Ub2(1,i+2),vtemp3(1))
10552 #ifdef MOMENT
10553       call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
10554       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
10555       call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
10556       call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
10557       ss13 = scalar2(b1(1,k),vtemp4(1))
10558       s13 = (gtemp(1,1)+gtemp(2,2))*ss13
10559 #endif
10560 c      write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
10561 c      s1=0.0d0
10562 c      s2=0.0d0
10563 c      s8=0.0d0
10564 c      s12=0.0d0
10565 c      s13=0.0d0
10566       eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
10567 C Derivatives in gamma(i+2)
10568       s1d =0.0d0
10569       s8d =0.0d0
10570 #ifdef MOMENT
10571       call transpose2(AEA(1,1,1),auxmatd(1,1))
10572       call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
10573       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
10574       call transpose2(AEAderg(1,1,2),atempd(1,1))
10575       call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
10576       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
10577 #endif
10578       call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
10579       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
10580       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
10581 c      s1d=0.0d0
10582 c      s2d=0.0d0
10583 c      s8d=0.0d0
10584 c      s12d=0.0d0
10585 c      s13d=0.0d0
10586       gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
10587 C Derivatives in gamma(i+3)
10588 #ifdef MOMENT
10589       call transpose2(AEA(1,1,1),auxmatd(1,1))
10590       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
10591       ss1d=scalar2(Ub2der(1,i+2),b1(1,l))
10592       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
10593 #endif
10594       call matvec2(EUgder(1,1,i+2),b1(1,l),vtemp1d(1))
10595       call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
10596       s2d = scalar2(b1(1,k),vtemp1d(1))
10597 #ifdef MOMENT
10598       call matvec2(Ug2der(1,1,i+2),dd(1,1,itk1),vtemp2d(1))
10599       s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2d(1))
10600 #endif
10601       s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
10602 #ifdef MOMENT
10603       call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
10604       call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
10605       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
10606 #endif
10607 c      s1d=0.0d0
10608 c      s2d=0.0d0
10609 c      s8d=0.0d0
10610 c      s12d=0.0d0
10611 c      s13d=0.0d0
10612 #ifdef MOMENT
10613       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
10614      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
10615 #else
10616       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
10617      &               -0.5d0*ekont*(s2d+s12d)
10618 #endif
10619 C Derivatives in gamma(i+4)
10620       call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
10621       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
10622       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
10623 #ifdef MOMENT
10624       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
10625       call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
10626       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
10627 #endif
10628 c      s1d=0.0d0
10629 c      s2d=0.0d0
10630 c      s8d=0.0d0
10631 C      s12d=0.0d0
10632 c      s13d=0.0d0
10633 #ifdef MOMENT
10634       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
10635 #else
10636       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
10637 #endif
10638 C Derivatives in gamma(i+5)
10639 #ifdef MOMENT
10640       call transpose2(AEAderg(1,1,1),auxmatd(1,1))
10641       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
10642       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
10643 #endif
10644       call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1d(1))
10645       call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
10646       s2d = scalar2(b1(1,k),vtemp1d(1))
10647 #ifdef MOMENT
10648       call transpose2(AEA(1,1,2),atempd(1,1))
10649       call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
10650       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
10651 #endif
10652       call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
10653       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
10654 #ifdef MOMENT
10655       call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
10656       ss13d = scalar2(b1(1,k),vtemp4d(1))
10657       s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
10658 #endif
10659 c      s1d=0.0d0
10660 c      s2d=0.0d0
10661 c      s8d=0.0d0
10662 c      s12d=0.0d0
10663 c      s13d=0.0d0
10664 #ifdef MOMENT
10665       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
10666      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
10667 #else
10668       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
10669      &               -0.5d0*ekont*(s2d+s12d)
10670 #endif
10671 C Cartesian derivatives
10672       do iii=1,2
10673         do kkk=1,5
10674           do lll=1,3
10675 #ifdef MOMENT
10676             call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
10677             call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
10678             s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
10679 #endif
10680             call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1(1))
10681             call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),
10682      &          vtemp1d(1))
10683             s2d = scalar2(b1(1,k),vtemp1d(1))
10684 #ifdef MOMENT
10685             call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
10686             call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
10687             s8d = -(atempd(1,1)+atempd(2,2))*
10688      &           scalar2(cc(1,1,itl),vtemp2(1))
10689 #endif
10690             call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),
10691      &           auxmatd(1,1))
10692             call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
10693             s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
10694 c      s1d=0.0d0
10695 c      s2d=0.0d0
10696 c      s8d=0.0d0
10697 c      s12d=0.0d0
10698 c      s13d=0.0d0
10699 #ifdef MOMENT
10700             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
10701      &        - 0.5d0*(s1d+s2d)
10702 #else
10703             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
10704      &        - 0.5d0*s2d
10705 #endif
10706 #ifdef MOMENT
10707             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
10708      &        - 0.5d0*(s8d+s12d)
10709 #else
10710             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
10711      &        - 0.5d0*s12d
10712 #endif
10713           enddo
10714         enddo
10715       enddo
10716 #ifdef MOMENT
10717       do kkk=1,5
10718         do lll=1,3
10719           call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),
10720      &      achuj_tempd(1,1))
10721           call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
10722           call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
10723           s13d=(gtempd(1,1)+gtempd(2,2))*ss13
10724           derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
10725           call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),
10726      &      vtemp4d(1))
10727           ss13d = scalar2(b1(1,k),vtemp4d(1))
10728           s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
10729           derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
10730         enddo
10731       enddo
10732 #endif
10733 cd      write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
10734 cd     &  16*eel_turn6_num
10735 cd      goto 1112
10736       if (j.lt.nres-1) then
10737         j1=j+1
10738         j2=j-1
10739       else
10740         j1=j-1
10741         j2=j-2
10742       endif
10743       if (l.lt.nres-1) then
10744         l1=l+1
10745         l2=l-1
10746       else
10747         l1=l-1
10748         l2=l-2
10749       endif
10750       do ll=1,3
10751 cgrad        ggg1(ll)=eel_turn6*g_contij(ll,1)
10752 cgrad        ggg2(ll)=eel_turn6*g_contij(ll,2)
10753 cgrad        ghalf=0.5d0*ggg1(ll)
10754 cd        ghalf=0.0d0
10755         gturn6ij=eel_turn6*g_contij(ll,1)+ekont*derx_turn(ll,1,1)
10756         gturn6kl=eel_turn6*g_contij(ll,2)+ekont*derx_turn(ll,1,2)
10757         gcorr6_turn(ll,i)=gcorr6_turn(ll,i)!+ghalf
10758      &    +ekont*derx_turn(ll,2,1)
10759         gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
10760         gcorr6_turn(ll,j)=gcorr6_turn(ll,j)!+ghalf
10761      &    +ekont*derx_turn(ll,4,1)
10762         gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
10763         gcorr6_turn_long(ll,j)=gcorr6_turn_long(ll,j)+gturn6ij
10764         gcorr6_turn_long(ll,i)=gcorr6_turn_long(ll,i)-gturn6ij
10765 cgrad        ghalf=0.5d0*ggg2(ll)
10766 cd        ghalf=0.0d0
10767         gcorr6_turn(ll,k)=gcorr6_turn(ll,k)!+ghalf
10768      &    +ekont*derx_turn(ll,2,2)
10769         gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
10770         gcorr6_turn(ll,l)=gcorr6_turn(ll,l)!+ghalf
10771      &    +ekont*derx_turn(ll,4,2)
10772         gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
10773         gcorr6_turn_long(ll,l)=gcorr6_turn_long(ll,l)+gturn6kl
10774         gcorr6_turn_long(ll,k)=gcorr6_turn_long(ll,k)-gturn6kl
10775       enddo
10776 cd      goto 1112
10777 cgrad      do m=i+1,j-1
10778 cgrad        do ll=1,3
10779 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
10780 cgrad        enddo
10781 cgrad      enddo
10782 cgrad      do m=k+1,l-1
10783 cgrad        do ll=1,3
10784 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
10785 cgrad        enddo
10786 cgrad      enddo
10787 cgrad1112  continue
10788 cgrad      do m=i+2,j2
10789 cgrad        do ll=1,3
10790 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
10791 cgrad        enddo
10792 cgrad      enddo
10793 cgrad      do m=k+2,l2
10794 cgrad        do ll=1,3
10795 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
10796 cgrad        enddo
10797 cgrad      enddo
10798 cd      do iii=1,nres-3
10799 cd        write (2,*) iii,g_corr6_loc(iii)
10800 cd      enddo
10801       eello_turn6=ekont*eel_turn6
10802 cd      write (2,*) 'ekont',ekont
10803 cd      write (2,*) 'eel_turn6',ekont*eel_turn6
10804       return
10805       end
10806
10807 C-----------------------------------------------------------------------------
10808       double precision function scalar(u,v)
10809 !DIR$ INLINEALWAYS scalar
10810 #ifndef OSF
10811 cDEC$ ATTRIBUTES FORCEINLINE::scalar
10812 #endif
10813       implicit none
10814       double precision u(3),v(3)
10815 cd      double precision sc
10816 cd      integer i
10817 cd      sc=0.0d0
10818 cd      do i=1,3
10819 cd        sc=sc+u(i)*v(i)
10820 cd      enddo
10821 cd      scalar=sc
10822
10823       scalar=u(1)*v(1)+u(2)*v(2)+u(3)*v(3)
10824       return
10825       end
10826 crc-------------------------------------------------
10827       SUBROUTINE MATVEC2(A1,V1,V2)
10828 !DIR$ INLINEALWAYS MATVEC2
10829 #ifndef OSF
10830 cDEC$ ATTRIBUTES FORCEINLINE::MATVEC2
10831 #endif
10832       implicit real*8 (a-h,o-z)
10833       include 'DIMENSIONS'
10834       DIMENSION A1(2,2),V1(2),V2(2)
10835 c      DO 1 I=1,2
10836 c        VI=0.0
10837 c        DO 3 K=1,2
10838 c    3     VI=VI+A1(I,K)*V1(K)
10839 c        Vaux(I)=VI
10840 c    1 CONTINUE
10841
10842       vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
10843       vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
10844
10845       v2(1)=vaux1
10846       v2(2)=vaux2
10847       END
10848 C---------------------------------------
10849       SUBROUTINE MATMAT2(A1,A2,A3)
10850 #ifndef OSF
10851 cDEC$ ATTRIBUTES FORCEINLINE::MATMAT2
10852 #endif
10853       implicit real*8 (a-h,o-z)
10854       include 'DIMENSIONS'
10855       DIMENSION A1(2,2),A2(2,2),A3(2,2)
10856 c      DIMENSION AI3(2,2)
10857 c        DO  J=1,2
10858 c          A3IJ=0.0
10859 c          DO K=1,2
10860 c           A3IJ=A3IJ+A1(I,K)*A2(K,J)
10861 c          enddo
10862 c          A3(I,J)=A3IJ
10863 c       enddo
10864 c      enddo
10865
10866       ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
10867       ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
10868       ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
10869       ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
10870
10871       A3(1,1)=AI3_11
10872       A3(2,1)=AI3_21
10873       A3(1,2)=AI3_12
10874       A3(2,2)=AI3_22
10875       END
10876
10877 c-------------------------------------------------------------------------
10878       double precision function scalar2(u,v)
10879 !DIR$ INLINEALWAYS scalar2
10880       implicit none
10881       double precision u(2),v(2)
10882       double precision sc
10883       integer i
10884       scalar2=u(1)*v(1)+u(2)*v(2)
10885       return
10886       end
10887
10888 C-----------------------------------------------------------------------------
10889
10890       subroutine transpose2(a,at)
10891 !DIR$ INLINEALWAYS transpose2
10892 #ifndef OSF
10893 cDEC$ ATTRIBUTES FORCEINLINE::transpose2
10894 #endif
10895       implicit none
10896       double precision a(2,2),at(2,2)
10897       at(1,1)=a(1,1)
10898       at(1,2)=a(2,1)
10899       at(2,1)=a(1,2)
10900       at(2,2)=a(2,2)
10901       return
10902       end
10903 c--------------------------------------------------------------------------
10904       subroutine transpose(n,a,at)
10905       implicit none
10906       integer n,i,j
10907       double precision a(n,n),at(n,n)
10908       do i=1,n
10909         do j=1,n
10910           at(j,i)=a(i,j)
10911         enddo
10912       enddo
10913       return
10914       end
10915 C---------------------------------------------------------------------------
10916       subroutine prodmat3(a1,a2,kk,transp,prod)
10917 !DIR$ INLINEALWAYS prodmat3
10918 #ifndef OSF
10919 cDEC$ ATTRIBUTES FORCEINLINE::prodmat3
10920 #endif
10921       implicit none
10922       integer i,j
10923       double precision a1(2,2),a2(2,2),a2t(2,2),kk(2,2),prod(2,2)
10924       logical transp
10925 crc      double precision auxmat(2,2),prod_(2,2)
10926
10927       if (transp) then
10928 crc        call transpose2(kk(1,1),auxmat(1,1))
10929 crc        call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
10930 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
10931
10932            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1)
10933      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
10934            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2)
10935      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
10936            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1)
10937      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
10938            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2)
10939      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
10940
10941       else
10942 crc        call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
10943 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
10944
10945            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1)
10946      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
10947            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2)
10948      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
10949            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1)
10950      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
10951            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2)
10952      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
10953
10954       endif
10955 c      call transpose2(a2(1,1),a2t(1,1))
10956
10957 crc      print *,transp
10958 crc      print *,((prod_(i,j),i=1,2),j=1,2)
10959 crc      print *,((prod(i,j),i=1,2),j=1,2)
10960
10961       return
10962       end
10963 CCC----------------------------------------------
10964       subroutine Eliptransfer(eliptran)
10965       implicit real*8 (a-h,o-z)
10966       include 'DIMENSIONS'
10967       include 'COMMON.GEO'
10968       include 'COMMON.VAR'
10969       include 'COMMON.LOCAL'
10970       include 'COMMON.CHAIN'
10971       include 'COMMON.DERIV'
10972       include 'COMMON.NAMES'
10973       include 'COMMON.INTERACT'
10974       include 'COMMON.IOUNITS'
10975       include 'COMMON.CALC'
10976       include 'COMMON.CONTROL'
10977       include 'COMMON.SPLITELE'
10978       include 'COMMON.SBRIDGE'
10979 C this is done by Adasko
10980 C      print *,"wchodze"
10981 C structure of box:
10982 C      water
10983 C--bordliptop-- buffore starts
10984 C--bufliptop--- here true lipid starts
10985 C      lipid
10986 C--buflipbot--- lipid ends buffore starts
10987 C--bordlipbot--buffore ends
10988       eliptran=0.0
10989       do i=ilip_start,ilip_end
10990 C       do i=1,1
10991         if (itype(i).eq.ntyp1) cycle
10992
10993         positi=(mod(((c(3,i)+c(3,i+1))/2.0d0),boxzsize))
10994         if (positi.le.0) positi=positi+boxzsize
10995 C        print *,i
10996 C first for peptide groups
10997 c for each residue check if it is in lipid or lipid water border area
10998        if ((positi.gt.bordlipbot)
10999      &.and.(positi.lt.bordliptop)) then
11000 C the energy transfer exist
11001         if (positi.lt.buflipbot) then
11002 C what fraction I am in
11003          fracinbuf=1.0d0-
11004      &        ((positi-bordlipbot)/lipbufthick)
11005 C lipbufthick is thickenes of lipid buffore
11006          sslip=sscalelip(fracinbuf)
11007          ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
11008          eliptran=eliptran+sslip*pepliptran
11009          gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
11010          gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
11011 C         gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
11012
11013 C        print *,"doing sccale for lower part"
11014 C         print *,i,sslip,fracinbuf,ssgradlip
11015         elseif (positi.gt.bufliptop) then
11016          fracinbuf=1.0d0-((bordliptop-positi)/lipbufthick)
11017          sslip=sscalelip(fracinbuf)
11018          ssgradlip=sscagradlip(fracinbuf)/lipbufthick
11019          eliptran=eliptran+sslip*pepliptran
11020          gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
11021          gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
11022 C         gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
11023 C          print *, "doing sscalefor top part"
11024 C         print *,i,sslip,fracinbuf,ssgradlip
11025         else
11026          eliptran=eliptran+pepliptran
11027 C         print *,"I am in true lipid"
11028         endif
11029 C       else
11030 C       eliptran=elpitran+0.0 ! I am in water
11031        endif
11032        enddo
11033 C       print *, "nic nie bylo w lipidzie?"
11034 C now multiply all by the peptide group transfer factor
11035 C       eliptran=eliptran*pepliptran
11036 C now the same for side chains
11037 CV       do i=1,1
11038        do i=ilip_start,ilip_end
11039         if (itype(i).eq.ntyp1) cycle
11040         positi=(mod(c(3,i+nres),boxzsize))
11041         if (positi.le.0) positi=positi+boxzsize
11042 C       print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop
11043 c for each residue check if it is in lipid or lipid water border area
11044 C       respos=mod(c(3,i+nres),boxzsize)
11045 C       print *,positi,bordlipbot,buflipbot
11046        if ((positi.gt.bordlipbot)
11047      & .and.(positi.lt.bordliptop)) then
11048 C the energy transfer exist
11049         if (positi.lt.buflipbot) then
11050          fracinbuf=1.0d0-
11051      &     ((positi-bordlipbot)/lipbufthick)
11052 C lipbufthick is thickenes of lipid buffore
11053          sslip=sscalelip(fracinbuf)
11054          ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
11055          eliptran=eliptran+sslip*liptranene(itype(i))
11056          gliptranx(3,i)=gliptranx(3,i)
11057      &+ssgradlip*liptranene(itype(i))
11058          gliptranc(3,i-1)= gliptranc(3,i-1)
11059      &+ssgradlip*liptranene(itype(i))
11060 C         print *,"doing sccale for lower part"
11061         elseif (positi.gt.bufliptop) then
11062          fracinbuf=1.0d0-
11063      &((bordliptop-positi)/lipbufthick)
11064          sslip=sscalelip(fracinbuf)
11065          ssgradlip=sscagradlip(fracinbuf)/lipbufthick
11066          eliptran=eliptran+sslip*liptranene(itype(i))
11067          gliptranx(3,i)=gliptranx(3,i)
11068      &+ssgradlip*liptranene(itype(i))
11069          gliptranc(3,i-1)= gliptranc(3,i-1)
11070      &+ssgradlip*liptranene(itype(i))
11071 C          print *, "doing sscalefor top part",sslip,fracinbuf
11072         else
11073          eliptran=eliptran+liptranene(itype(i))
11074 C         print *,"I am in true lipid"
11075         endif
11076         endif ! if in lipid or buffor
11077 C       else
11078 C       eliptran=elpitran+0.0 ! I am in water
11079        enddo
11080        return
11081        end
11082 C---------------------------------------------------------
11083 C AFM soubroutine for constant force
11084        subroutine AFMforce(Eafmforce)
11085        implicit real*8 (a-h,o-z)
11086       include 'DIMENSIONS'
11087       include 'COMMON.GEO'
11088       include 'COMMON.VAR'
11089       include 'COMMON.LOCAL'
11090       include 'COMMON.CHAIN'
11091       include 'COMMON.DERIV'
11092       include 'COMMON.NAMES'
11093       include 'COMMON.INTERACT'
11094       include 'COMMON.IOUNITS'
11095       include 'COMMON.CALC'
11096       include 'COMMON.CONTROL'
11097       include 'COMMON.SPLITELE'
11098       include 'COMMON.SBRIDGE'
11099       real*8 diffafm(3)
11100       dist=0.0d0
11101       Eafmforce=0.0d0
11102       do i=1,3
11103       diffafm(i)=c(i,afmend)-c(i,afmbeg)
11104       dist=dist+diffafm(i)**2
11105       enddo
11106       dist=dsqrt(dist)
11107       Eafmforce=-forceAFMconst*(dist-distafminit)
11108       do i=1,3
11109       gradafm(i,afmend-1)=-forceAFMconst*diffafm(i)/dist
11110       gradafm(i,afmbeg-1)=forceAFMconst*diffafm(i)/dist
11111       enddo
11112 C      print *,'AFM',Eafmforce
11113       return
11114       end
11115 C---------------------------------------------------------
11116 C AFM subroutine with pseudoconstant velocity
11117        subroutine AFMvel(Eafmforce)
11118        implicit real*8 (a-h,o-z)
11119       include 'DIMENSIONS'
11120       include 'COMMON.GEO'
11121       include 'COMMON.VAR'
11122       include 'COMMON.LOCAL'
11123       include 'COMMON.CHAIN'
11124       include 'COMMON.DERIV'
11125       include 'COMMON.NAMES'
11126       include 'COMMON.INTERACT'
11127       include 'COMMON.IOUNITS'
11128       include 'COMMON.CALC'
11129       include 'COMMON.CONTROL'
11130       include 'COMMON.SPLITELE'
11131       include 'COMMON.SBRIDGE'
11132       real*8 diffafm(3)
11133 C Only for check grad COMMENT if not used for checkgrad
11134 C      totT=3.0d0
11135 C--------------------------------------------------------
11136 C      print *,"wchodze"
11137       dist=0.0d0
11138       Eafmforce=0.0d0
11139       do i=1,3
11140       diffafm(i)=c(i,afmend)-c(i,afmbeg)
11141       dist=dist+diffafm(i)**2
11142       enddo
11143       dist=dsqrt(dist)
11144       Eafmforce=0.5d0*forceAFMconst
11145      & *(distafminit+totTafm*velAFMconst-dist)**2
11146 C      Eafmforce=-forceAFMconst*(dist-distafminit)
11147       do i=1,3
11148       gradafm(i,afmend-1)=-forceAFMconst*
11149      &(distafminit+totTafm*velAFMconst-dist)
11150      &*diffafm(i)/dist
11151       gradafm(i,afmbeg-1)=forceAFMconst*
11152      &(distafminit+totTafm*velAFMconst-dist)
11153      &*diffafm(i)/dist
11154       enddo
11155 C      print *,'AFM',Eafmforce,totTafm*velAFMconst,dist
11156       return
11157       end
11158 C-----------------------------------------------------------
11159 C first for shielding is setting of function of side-chains
11160        subroutine set_shield_fac
11161       implicit real*8 (a-h,o-z)
11162       include 'DIMENSIONS'
11163       include 'COMMON.CHAIN'
11164       include 'COMMON.DERIV'
11165       include 'COMMON.IOUNITS'
11166       include 'COMMON.SHIELD'
11167       include 'COMMON.INTERACT'
11168 C this is the squar root 77 devided by 81 the epislion in lipid (in protein)
11169       double precision div77_81/0.974996043d0/,
11170      &div4_81/0.2222222222d0/,sh_frac_dist_grad(3)
11171
11172 C the vector between center of side_chain and peptide group
11173        double precision pep_side(3),long,side_calf(3),
11174      &pept_group(3),costhet_grad(3),cosphi_grad_long(3),
11175      &cosphi_grad_loc(3),pep_side_norm(3),side_calf_norm(3)
11176 C the line belowe needs to be changed for FGPROC>1
11177       do i=1,nres-1
11178       if ((itype(i).eq.ntyp1).and.itype(i+1).eq.ntyp1) cycle
11179       ishield_list(i)=0
11180 Cif there two consequtive dummy atoms there is no peptide group between them
11181 C the line below has to be changed for FGPROC>1
11182       VolumeTotal=0.0
11183       do k=1,nres
11184        if ((itype(k).eq.ntyp1).or.(itype(k).eq.10)) cycle
11185        dist_pep_side=0.0
11186        dist_side_calf=0.0
11187        do j=1,3
11188 C first lets set vector conecting the ithe side-chain with kth side-chain
11189       pep_side(j)=c(j,k+nres)-(c(j,i)+c(j,i+1))/2.0d0
11190 C      pep_side(j)=2.0d0
11191 C and vector conecting the side-chain with its proper calfa
11192       side_calf(j)=c(j,k+nres)-c(j,k)
11193 C      side_calf(j)=2.0d0
11194       pept_group(j)=c(j,i)-c(j,i+1)
11195 C lets have their lenght
11196       dist_pep_side=pep_side(j)**2+dist_pep_side
11197       dist_side_calf=dist_side_calf+side_calf(j)**2
11198       dist_pept_group=dist_pept_group+pept_group(j)**2
11199       enddo
11200        dist_pep_side=dsqrt(dist_pep_side)
11201        dist_pept_group=dsqrt(dist_pept_group)
11202        dist_side_calf=dsqrt(dist_side_calf)
11203       do j=1,3
11204         pep_side_norm(j)=pep_side(j)/dist_pep_side
11205         side_calf_norm(j)=dist_side_calf
11206       enddo
11207 C now sscale fraction
11208        sh_frac_dist=-(dist_pep_side-rpp(1,1)-buff_shield)/buff_shield
11209 C       print *,buff_shield,"buff"
11210 C now sscale
11211         if (sh_frac_dist.le.0.0) cycle
11212 C If we reach here it means that this side chain reaches the shielding sphere
11213 C Lets add him to the list for gradient
11214         ishield_list(i)=ishield_list(i)+1
11215 C ishield_list is a list of non 0 side-chain that contribute to factor gradient
11216 C this list is essential otherwise problem would be O3
11217         shield_list(ishield_list(i),i)=k
11218 C Lets have the sscale value
11219         if (sh_frac_dist.gt.1.0) then
11220          scale_fac_dist=1.0d0
11221          do j=1,3
11222          sh_frac_dist_grad(j)=0.0d0
11223          enddo
11224         else
11225          scale_fac_dist=-sh_frac_dist*sh_frac_dist
11226      &                   *(2.0*sh_frac_dist-3.0d0)
11227          fac_help_scale=6.0*(sh_frac_dist-sh_frac_dist**2)
11228      &                  /dist_pep_side/buff_shield*0.5
11229 C remember for the final gradient multiply sh_frac_dist_grad(j)
11230 C for side_chain by factor -2 !
11231          do j=1,3
11232          sh_frac_dist_grad(j)=fac_help_scale*pep_side(j)
11233 C         print *,"jestem",scale_fac_dist,fac_help_scale,
11234 C     &                    sh_frac_dist_grad(j)
11235          enddo
11236         endif
11237 C        if ((i.eq.3).and.(k.eq.2)) then
11238 C        print *,i,sh_frac_dist,dist_pep,fac_help_scale,scale_fac_dist
11239 C     & ,"TU"
11240 C        endif
11241
11242 C this is what is now we have the distance scaling now volume...
11243       short=short_r_sidechain(itype(k))
11244       long=long_r_sidechain(itype(k))
11245       costhet=1.0d0/dsqrt(1.0+short**2/dist_pep_side**2)
11246 C now costhet_grad
11247 C       costhet=0.0d0
11248        costhet_fac=costhet**3*short**2*(-0.5)/dist_pep_side**4
11249 C       costhet_fac=0.0d0
11250        do j=1,3
11251          costhet_grad(j)=costhet_fac*pep_side(j)
11252        enddo
11253 C remember for the final gradient multiply costhet_grad(j)
11254 C for side_chain by factor -2 !
11255 C fac alfa is angle between CB_k,CA_k, CA_i,CA_i+1
11256 C pep_side0pept_group is vector multiplication
11257       pep_side0pept_group=0.0
11258       do j=1,3
11259       pep_side0pept_group=pep_side0pept_group+pep_side(j)*side_calf(j)
11260       enddo
11261       cosalfa=(pep_side0pept_group/
11262      & (dist_pep_side*dist_side_calf))
11263       fac_alfa_sin=1.0-cosalfa**2
11264       fac_alfa_sin=dsqrt(fac_alfa_sin)
11265       rkprim=fac_alfa_sin*(long-short)+short
11266 C now costhet_grad
11267        cosphi=1.0d0/dsqrt(1.0+rkprim**2/dist_pep_side**2)
11268        cosphi_fac=cosphi**3*rkprim**2*(-0.5)/dist_pep_side**4
11269
11270        do j=1,3
11271          cosphi_grad_long(j)=cosphi_fac*pep_side(j)
11272      &+cosphi**3*0.5/dist_pep_side**2*(-rkprim)
11273      &*(long-short)/fac_alfa_sin*cosalfa/
11274      &((dist_pep_side*dist_side_calf))*
11275      &((side_calf(j))-cosalfa*
11276      &((pep_side(j)/dist_pep_side)*dist_side_calf))
11277
11278         cosphi_grad_loc(j)=cosphi**3*0.5/dist_pep_side**2*(-rkprim)
11279      &*(long-short)/fac_alfa_sin*cosalfa
11280      &/((dist_pep_side*dist_side_calf))*
11281      &(pep_side(j)-
11282      &cosalfa*side_calf(j)/dist_side_calf*dist_pep_side)
11283        enddo
11284
11285       VofOverlap=VSolvSphere/2.0d0*(1.0-costhet)*(1.0-cosphi)
11286      &                    /VSolvSphere_div
11287 C now the gradient...
11288 C grad_shield is gradient of Calfa for peptide groups
11289 C      write(iout,*) "shield_compon",i,k,VSolvSphere,scale_fac_dist,
11290 C     &               costhet,cosphi
11291 C       write(iout,*) "cosphi_compon",i,k,pep_side0pept_group,
11292 C     & dist_pep_side,dist_side_calf,c(1,k+nres),c(1,k),itype(k)
11293       do j=1,3
11294       grad_shield(j,i)=grad_shield(j,i)
11295 C gradient po skalowaniu
11296      &                +(sh_frac_dist_grad(j)
11297 C  gradient po costhet
11298      &-scale_fac_dist*costhet_grad(j)/(1.0-costhet)
11299      &-scale_fac_dist*(cosphi_grad_long(j))
11300      &/(1.0-cosphi) )*div77_81
11301      &*VofOverlap
11302 C grad_shield_side is Cbeta sidechain gradient
11303       grad_shield_side(j,ishield_list(i),i)=
11304      &        (sh_frac_dist_grad(j)*-2.0d0
11305      &       +scale_fac_dist*costhet_grad(j)*2.0d0/(1.0-costhet)
11306      &       +scale_fac_dist*(cosphi_grad_long(j))
11307      &        *2.0d0/(1.0-cosphi))
11308      &        *div77_81*VofOverlap
11309
11310        grad_shield_loc(j,ishield_list(i),i)=
11311      &   scale_fac_dist*cosphi_grad_loc(j)
11312      &        *2.0d0/(1.0-cosphi)
11313      &        *div77_81*VofOverlap
11314       enddo
11315       VolumeTotal=VolumeTotal+VofOverlap*scale_fac_dist
11316       enddo
11317       fac_shield(i)=VolumeTotal*div77_81+div4_81
11318 C      write(2,*) "TOTAL VOLUME",i,VolumeTotal,fac_shield(i)
11319       enddo
11320       return
11321       end
11322 C--------------------------------------------------------------------------
11323       double precision function tschebyshev(m,n,x,y)
11324       implicit none
11325       include "DIMENSIONS"
11326       integer i,m,n
11327       double precision x(n),y,yy(0:maxvar),aux
11328 c Tschebyshev polynomial. Note that the first term is omitted
11329 c m=0: the constant term is included
11330 c m=1: the constant term is not included
11331       yy(0)=1.0d0
11332       yy(1)=y
11333       do i=2,n
11334         yy(i)=2*yy(1)*yy(i-1)-yy(i-2)
11335       enddo
11336       aux=0.0d0
11337       do i=m,n
11338         aux=aux+x(i)*yy(i)
11339       enddo
11340       tschebyshev=aux
11341       return
11342       end
11343 C--------------------------------------------------------------------------
11344       double precision function gradtschebyshev(m,n,x,y)
11345       implicit none
11346       include "DIMENSIONS"
11347       integer i,m,n
11348       double precision x(n),y,yy(0:maxvar),aux
11349 c Tschebyshev polynomial. Note that the first term is omitted
11350 c m=0: the constant term is included
11351 c m=1: the constant term is not included
11352       yy(0)=1.0d0
11353       yy(1)=2.0d0*y
11354       do i=2,n
11355         yy(i)=2*yy(1)*yy(i-1)-yy(i-2)
11356       enddo
11357       aux=0.0d0
11358       do i=m,n
11359         aux=aux+x(i)*yy(i)
11360       enddo
11361       gradtschebyshev=aux
11362       return
11363       end
11364