source/unres/src_MD-M/energy_p_new_barrier.F

   1       subroutine etotal(energia)
   2       implicit real*8 (a-h,o-z)
   3       include 'DIMENSIONS'
   4 #ifndef ISNAN
   5       external proc_proc
   6 #ifdef WINPGI
   7 cMS$ATTRIBUTES C ::  proc_proc
   8 #endif
   9 #endif
  10 #ifdef MPI
  11       include "mpif.h"
  12       double precision weights_(n_ene)
  13 #endif
  14       include 'COMMON.SETUP'
  15       include 'COMMON.IOUNITS'
  16       double precision energia(0:n_ene)
  17       include 'COMMON.LOCAL'
  18       include 'COMMON.FFIELD'
  19       include 'COMMON.DERIV'
  20       include 'COMMON.INTERACT'
  21       include 'COMMON.SBRIDGE'
  22       include 'COMMON.CHAIN'
  23       include 'COMMON.VAR'
  24       include 'COMMON.MD'
  25       include 'COMMON.CONTROL'
  26       include 'COMMON.TIME1'
  27       include 'COMMON.SPLITELE'
  28 #ifdef MPI
  29 c      print*,"ETOTAL Processor",fg_rank," absolute rank",myrank,
  30 c     & " nfgtasks",nfgtasks
  31       if (nfgtasks.gt.1) then
  32         time00=MPI_Wtime()
  33 C FG slaves call the following matching MPI_Bcast in ERGASTULUM
  34         if (fg_rank.eq.0) then
  35           call MPI_Bcast(0,1,MPI_INTEGER,king,FG_COMM,IERROR)
  36 c          print *,"Processor",myrank," BROADCAST iorder"
  37 C FG master sets up the WEIGHTS_ array which will be broadcast to the
  38 C FG slaves as WEIGHTS array.
  39           weights_(1)=wsc
  40           weights_(2)=wscp
  41           weights_(3)=welec
  42           weights_(4)=wcorr
  43           weights_(5)=wcorr5
  44           weights_(6)=wcorr6
  45           weights_(7)=wel_loc
  46           weights_(8)=wturn3
  47           weights_(9)=wturn4
  48           weights_(10)=wturn6
  49           weights_(11)=wang
  50           weights_(12)=wscloc
  51           weights_(13)=wtor
  52           weights_(14)=wtor_d
  53           weights_(15)=wstrain
  54           weights_(16)=wvdwpp
  55           weights_(17)=wbond
  56           weights_(18)=scal14
  57           weights_(21)=wsccor
  58 C FG Master broadcasts the WEIGHTS_ array
  59           call MPI_Bcast(weights_(1),n_ene,
  60      &        MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
  61         else
  62 C FG slaves receive the WEIGHTS array
  63           call MPI_Bcast(weights(1),n_ene,
  64      &        MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
  65           wsc=weights(1)
  66           wscp=weights(2)
  67           welec=weights(3)
  68           wcorr=weights(4)
  69           wcorr5=weights(5)
  70           wcorr6=weights(6)
  71           wel_loc=weights(7)
  72           wturn3=weights(8)
  73           wturn4=weights(9)
  74           wturn6=weights(10)
  75           wang=weights(11)
  76           wscloc=weights(12)
  77           wtor=weights(13)
  78           wtor_d=weights(14)
  79           wstrain=weights(15)
  80           wvdwpp=weights(16)
  81           wbond=weights(17)
  82           scal14=weights(18)
  83           wsccor=weights(21)
  84         endif
  85         time_Bcast=time_Bcast+MPI_Wtime()-time00
  86         time_Bcastw=time_Bcastw+MPI_Wtime()-time00
  87 c        call chainbuild_cart
  88       endif
  89 c      print *,'Processor',myrank,' calling etotal ipot=',ipot
  90 c      print *,'Processor',myrank,' nnt=',nnt,' nct=',nct
  91 #else
  92 c      if (modecalc.eq.12.or.modecalc.eq.14) then
  93 c        call int_from_cart1(.false.)
  94 c      endif
  95 #endif
  96 #ifdef TIMING
  97       time00=MPI_Wtime()
  98 #endif
  99 C
 100 C Compute the side-chain and electrostatic interaction energy
 101 C
 102 C      print *,ipot
 103       goto (101,102,103,104,105,106) ipot
 104 C Lennard-Jones potential.
 105   101 call elj(evdw)
 106 cd    print '(a)','Exit ELJ'
 107       goto 107
 108 C Lennard-Jones-Kihara potential (shifted).
 109   102 call eljk(evdw)
 110       goto 107
 111 C Berne-Pechukas potential (dilated LJ, angular dependence).
 112   103 call ebp(evdw)
 113       goto 107
 114 C Gay-Berne potential (shifted LJ, angular dependence).
 115   104 call egb(evdw)
 116 C      print *,"bylem w egb"
 117       goto 107
 118 C Gay-Berne-Vorobjev potential (shifted LJ, angular dependence).
 119   105 call egbv(evdw)
 120       goto 107
 121 C Soft-sphere potential
 122   106 call e_softsphere(evdw)
 123 C
 124 C Calculate electrostatic (H-bonding) energy of the main chain.
 125 C
 126   107 continue
 127 cmc
 128 cmc Sep-06: egb takes care of dynamic ss bonds too
 129 cmc
 130 c      if (dyn_ss) call dyn_set_nss
 131
 132 c      print *,"Processor",myrank," computed USCSC"
 133 #ifdef TIMING
 134       time01=MPI_Wtime()
 135 #endif
 136       call vec_and_deriv
 137 #ifdef TIMING
 138       time_vec=time_vec+MPI_Wtime()-time01
 139 #endif
 140 C Introduction of shielding effect first for each peptide group
 141 C the shielding factor is set this factor is describing how each
 142 C peptide group is shielded by side-chains
 143 C the matrix - shield_fac(i) the i index describe the ith between i and i+1
 144 C      write (iout,*) "shield_mode",shield_mode
 145       if (shield_mode.gt.0) then
 146        call set_shield_fac
 147       endif
 148 c      print *,"Processor",myrank," left VEC_AND_DERIV"
 149       if (ipot.lt.6) then
 150 #ifdef SPLITELE
 151          if (welec.gt.0d0.or.wvdwpp.gt.0d0.or.wel_loc.gt.0d0.or.
 152      &       wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0
 153      &       .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0
 154      &       .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
 155 #else
 156          if (welec.gt.0d0.or.wel_loc.gt.0d0.or.
 157      &       wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0
 158      &       .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0
 159      &       .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
 160 #endif
 161             call eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
 162          else
 163             ees=0.0d0
 164             evdw1=0.0d0
 165             eel_loc=0.0d0
 166             eello_turn3=0.0d0
 167             eello_turn4=0.0d0
 168          endif
 169       else
 170         write (iout,*) "Soft-spheer ELEC potential"
 171 c        call eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,
 172 c     &   eello_turn4)
 173       endif
 174 c      print *,"Processor",myrank," computed UELEC"
 175 C
 176 C Calculate excluded-volume interaction energy between peptide groups
 177 C and side chains.
 178 C
 179       if (ipot.lt.6) then
 180        if(wscp.gt.0d0) then
 181         call escp(evdw2,evdw2_14)
 182        else
 183         evdw2=0
 184         evdw2_14=0
 185        endif
 186       else
 187 c        write (iout,*) "Soft-sphere SCP potential"
 188         call escp_soft_sphere(evdw2,evdw2_14)
 189       endif
 190 c
 191 c Calculate the bond-stretching energy
 192 c
 193       call ebond(estr)
 194 C
 195 C Calculate the disulfide-bridge and other energy and the contributions
 196 C from other distance constraints.
 197 cd    print *,'Calling EHPB'
 198       call edis(ehpb)
 199 cd    print *,'EHPB exitted succesfully.'
 200 C
 201 C Calculate the virtual-bond-angle energy.
 202 C
 203       if (wang.gt.0d0) then
 204         call ebend(ebe,ethetacnstr)
 205       else
 206         ebe=0
 207         ethetacnstr=0
 208       endif
 209 c      print *,"Processor",myrank," computed UB"
 210 C
 211 C Calculate the SC local energy.
 212 C
 213 C      print *,"TU DOCHODZE?"
 214       call esc(escloc)
 215 c      print *,"Processor",myrank," computed USC"
 216 C
 217 C Calculate the virtual-bond torsional energy.
 218 C
 219 cd    print *,'nterm=',nterm
 220       if (wtor.gt.0) then
 221        call etor(etors,edihcnstr)
 222       else
 223        etors=0
 224        edihcnstr=0
 225       endif
 226 c      print *,"Processor",myrank," computed Utor"
 227 C
 228 C 6/23/01 Calculate double-torsional energy
 229 C
 230       if (wtor_d.gt.0) then
 231        call etor_d(etors_d)
 232       else
 233        etors_d=0
 234       endif
 235 c      print *,"Processor",myrank," computed Utord"
 236 C
 237 C 21/5/07 Calculate local sicdechain correlation energy
 238 C
 239       if (wsccor.gt.0.0d0) then
 240         call eback_sc_corr(esccor)
 241       else
 242         esccor=0.0d0
 243       endif
 244 C      print *,"PRZED MULIt"
 245 c      print *,"Processor",myrank," computed Usccorr"
 246 C
 247 C 12/1/95 Multi-body terms
 248 C
 249       n_corr=0
 250       n_corr1=0
 251       if ((wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0
 252      &    .or. wturn6.gt.0.0d0) .and. ipot.lt.6) then
 253          call multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1)
 254 cd         write(2,*)'multibody_eello n_corr=',n_corr,' n_corr1=',n_corr1,
 255 cd     &" ecorr",ecorr," ecorr5",ecorr5," ecorr6",ecorr6," eturn6",eturn6
 256       else
 257          ecorr=0.0d0
 258          ecorr5=0.0d0
 259          ecorr6=0.0d0
 260          eturn6=0.0d0
 261       endif
 262       if ((wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) .and. ipot.lt.6) then
 263          call multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
 264 cd         write (iout,*) "multibody_hb ecorr",ecorr
 265       endif
 266 c      print *,"Processor",myrank," computed Ucorr"
 267 C
 268 C If performing constraint dynamics, call the constraint energy
 269 C  after the equilibration time
 270       if(usampl.and.totT.gt.eq_time) then
 271          call EconstrQ
 272          call Econstr_back
 273       else
 274          Uconst=0.0d0
 275          Uconst_back=0.0d0
 276       endif
 277 C 01/27/2015 added by adasko
 278 C the energy component below is energy transfer into lipid environment
 279 C based on partition function
 280 C      print *,"przed lipidami"
 281       if (wliptran.gt.0) then
 282         call Eliptransfer(eliptran)
 283       endif
 284 C      print *,"za lipidami"
 285       if (AFMlog.gt.0) then
 286         call AFMforce(Eafmforce)
 287       else if (selfguide.gt.0) then
 288         call AFMvel(Eafmforce)
 289       endif
 290 #ifdef TIMING
 291       time_enecalc=time_enecalc+MPI_Wtime()-time00
 292 #endif
 293 c      print *,"Processor",myrank," computed Uconstr"
 294 #ifdef TIMING
 295       time00=MPI_Wtime()
 296 #endif
 297 c
 298 C Sum the energies
 299 C
 300       energia(1)=evdw
 301 #ifdef SCP14
 302       energia(2)=evdw2-evdw2_14
 303       energia(18)=evdw2_14
 304 #else
 305       energia(2)=evdw2
 306       energia(18)=0.0d0
 307 #endif
 308 #ifdef SPLITELE
 309       energia(3)=ees
 310       energia(16)=evdw1
 311 #else
 312       energia(3)=ees+evdw1
 313       energia(16)=0.0d0
 314 #endif
 315       energia(4)=ecorr
 316       energia(5)=ecorr5
 317       energia(6)=ecorr6
 318       energia(7)=eel_loc
 319       energia(8)=eello_turn3
 320       energia(9)=eello_turn4
 321       energia(10)=eturn6
 322       energia(11)=ebe
 323       energia(12)=escloc
 324       energia(13)=etors
 325       energia(14)=etors_d
 326       energia(15)=ehpb
 327       energia(19)=edihcnstr
 328       energia(17)=estr
 329       energia(20)=Uconst+Uconst_back
 330       energia(21)=esccor
 331       energia(22)=eliptran
 332       energia(23)=Eafmforce
 333       energia(24)=ethetacnstr
 334 c    Here are the energies showed per procesor if the are more processors
 335 c    per molecule then we sum it up in sum_energy subroutine
 336 c      print *," Processor",myrank," calls SUM_ENERGY"
 337       call sum_energy(energia,.true.)
 338       if (dyn_ss) call dyn_set_nss
 339 c      print *," Processor",myrank," left SUM_ENERGY"
 340 #ifdef TIMING
 341       time_sumene=time_sumene+MPI_Wtime()-time00
 342 #endif
 343       return
 344       end
 345 c-------------------------------------------------------------------------------
 346       subroutine sum_energy(energia,reduce)
 347       implicit real*8 (a-h,o-z)
 348       include 'DIMENSIONS'
 349 #ifndef ISNAN
 350       external proc_proc
 351 #ifdef WINPGI
 352 cMS$ATTRIBUTES C ::  proc_proc
 353 #endif
 354 #endif
 355 #ifdef MPI
 356       include "mpif.h"
 357 #endif
 358       include 'COMMON.SETUP'
 359       include 'COMMON.IOUNITS'
 360       double precision energia(0:n_ene),enebuff(0:n_ene+1)
 361       include 'COMMON.FFIELD'
 362       include 'COMMON.DERIV'
 363       include 'COMMON.INTERACT'
 364       include 'COMMON.SBRIDGE'
 365       include 'COMMON.CHAIN'
 366       include 'COMMON.VAR'
 367       include 'COMMON.CONTROL'
 368       include 'COMMON.TIME1'
 369       logical reduce
 370 #ifdef MPI
 371       if (nfgtasks.gt.1 .and. reduce) then
 372 #ifdef DEBUG
 373         write (iout,*) "energies before REDUCE"
 374         call enerprint(energia)
 375         call flush(iout)
 376 #endif
 377         do i=0,n_ene
 378           enebuff(i)=energia(i)
 379         enddo
 380         time00=MPI_Wtime()
 381         call MPI_Barrier(FG_COMM,IERR)
 382         time_barrier_e=time_barrier_e+MPI_Wtime()-time00
 383         time00=MPI_Wtime()
 384         call MPI_Reduce(enebuff(0),energia(0),n_ene+1,
 385      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 386 #ifdef DEBUG
 387         write (iout,*) "energies after REDUCE"
 388         call enerprint(energia)
 389         call flush(iout)
 390 #endif
 391         time_Reduce=time_Reduce+MPI_Wtime()-time00
 392       endif
 393       if (fg_rank.eq.0) then
 394 #endif
 395       evdw=energia(1)
 396 #ifdef SCP14
 397       evdw2=energia(2)+energia(18)
 398       evdw2_14=energia(18)
 399 #else
 400       evdw2=energia(2)
 401 #endif
 402 #ifdef SPLITELE
 403       ees=energia(3)
 404       evdw1=energia(16)
 405 #else
 406       ees=energia(3)
 407       evdw1=0.0d0
 408 #endif
 409       ecorr=energia(4)
 410       ecorr5=energia(5)
 411       ecorr6=energia(6)
 412       eel_loc=energia(7)
 413       eello_turn3=energia(8)
 414       eello_turn4=energia(9)
 415       eturn6=energia(10)
 416       ebe=energia(11)
 417       escloc=energia(12)
 418       etors=energia(13)
 419       etors_d=energia(14)
 420       ehpb=energia(15)
 421       edihcnstr=energia(19)
 422       estr=energia(17)
 423       Uconst=energia(20)
 424       esccor=energia(21)
 425       eliptran=energia(22)
 426       Eafmforce=energia(23)
 427       ethetacnstr=energia(24)
 428 #ifdef SPLITELE
 429       etot=wsc*evdw+wscp*evdw2+welec*ees+wvdwpp*evdw1
 430      & +wang*ebe+wtor*etors+wscloc*escloc
 431      & +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5
 432      & +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3
 433      & +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d
 434      & +wbond*estr+Uconst+wsccor*esccor+wliptran*eliptran+Eafmforce
 435      & +ethetacnstr
 436 #else
 437       etot=wsc*evdw+wscp*evdw2+welec*(ees+evdw1)
 438      & +wang*ebe+wtor*etors+wscloc*escloc
 439      & +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5
 440      & +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3
 441      & +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d
 442      & +wbond*estr+Uconst+wsccor*esccor+wliptran*eliptran
 443      & +Eafmforce
 444      & +ethetacnstr
 445 #endif
 446       energia(0)=etot
 447 c detecting NaNQ
 448 #ifdef ISNAN
 449 #ifdef AIX
 450       if (isnan(etot).ne.0) energia(0)=1.0d+99
 451 #else
 452       if (isnan(etot)) energia(0)=1.0d+99
 453 #endif
 454 #else
 455       i=0
 456 #ifdef WINPGI
 457       idumm=proc_proc(etot,i)
 458 #else
 459       call proc_proc(etot,i)
 460 #endif
 461       if(i.eq.1)energia(0)=1.0d+99
 462 #endif
 463 #ifdef MPI
 464       endif
 465 #endif
 466       return
 467       end
 468 c-------------------------------------------------------------------------------
 469       subroutine sum_gradient
 470       implicit real*8 (a-h,o-z)
 471       include 'DIMENSIONS'
 472 #ifndef ISNAN
 473       external proc_proc
 474 #ifdef WINPGI
 475 cMS$ATTRIBUTES C ::  proc_proc
 476 #endif
 477 #endif
 478 #ifdef MPI
 479       include 'mpif.h'
 480 #endif
 481       double precision gradbufc(3,-1:maxres),gradbufx(3,-1:maxres),
 482      & glocbuf(4*maxres),gradbufc_sum(3,-1:maxres)
 483      & ,gloc_scbuf(3,-1:maxres)
 484       include 'COMMON.SETUP'
 485       include 'COMMON.IOUNITS'
 486       include 'COMMON.FFIELD'
 487       include 'COMMON.DERIV'
 488       include 'COMMON.INTERACT'
 489       include 'COMMON.SBRIDGE'
 490       include 'COMMON.CHAIN'
 491       include 'COMMON.VAR'
 492       include 'COMMON.CONTROL'
 493       include 'COMMON.TIME1'
 494       include 'COMMON.MAXGRAD'
 495       include 'COMMON.SCCOR'
 496 #ifdef TIMING
 497       time01=MPI_Wtime()
 498 #endif
 499 #ifdef DEBUG
 500       write (iout,*) "sum_gradient gvdwc, gvdwx"
 501       do i=1,nres
 502         write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)')
 503      &   i,(gvdwx(j,i),j=1,3),(gvdwc(j,i),j=1,3)
 504       enddo
 505       call flush(iout)
 506 #endif
 507 #ifdef MPI
 508 C FG slaves call the following matching MPI_Bcast in ERGASTULUM
 509         if (nfgtasks.gt.1 .and. fg_rank.eq.0)
 510      &    call MPI_Bcast(1,1,MPI_INTEGER,king,FG_COMM,IERROR)
 511 #endif
 512 C
 513 C 9/29/08 AL Transform parts of gradients in site coordinates to the gradient
 514 C            in virtual-bond-vector coordinates
 515 C
 516 #ifdef DEBUG
 517 c      write (iout,*) "gel_loc gel_loc_long and gel_loc_loc"
 518 c      do i=1,nres-1
 519 c        write (iout,'(i5,3f10.5,2x,3f10.5,2x,f10.5)')
 520 c     &   i,(gel_loc(j,i),j=1,3),(gel_loc_long(j,i),j=1,3),gel_loc_loc(i)
 521 c      enddo
 522 c      write (iout,*) "gel_loc_tur3 gel_loc_turn4"
 523 c      do i=1,nres-1
 524 c        write (iout,'(i5,3f10.5,2x,f10.5)')
 525 c     &  i,(gcorr4_turn(j,i),j=1,3),gel_loc_turn4(i)
 526 c      enddo
 527       write (iout,*) "gradcorr5 gradcorr5_long gradcorr5_loc"
 528       do i=1,nres
 529         write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)')
 530      &   i,(gradcorr5(j,i),j=1,3),(gradcorr5_long(j,i),j=1,3),
 531      &   g_corr5_loc(i)
 532       enddo
 533       call flush(iout)
 534 #endif
 535 #ifdef SPLITELE
 536       do i=0,nct
 537         do j=1,3
 538           gradbufc(j,i)=wsc*gvdwc(j,i)+
 539      &                wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+
 540      &                welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+
 541      &                wel_loc*gel_loc_long(j,i)+
 542      &                wcorr*gradcorr_long(j,i)+
 543      &                wcorr5*gradcorr5_long(j,i)+
 544      &                wcorr6*gradcorr6_long(j,i)+
 545      &                wturn6*gcorr6_turn_long(j,i)+
 546      &                wstrain*ghpbc(j,i)
 547      &                +wliptran*gliptranc(j,i)
 548      &                +gradafm(j,i)
 549      &                 +welec*gshieldc(j,i)
 550
 551         enddo
 552       enddo
 553 #else
 554       do i=0,nct
 555         do j=1,3
 556           gradbufc(j,i)=wsc*gvdwc(j,i)+
 557      &                wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+
 558      &                welec*gelc_long(j,i)+
 559      &                wbond*gradb(j,i)+
 560      &                wel_loc*gel_loc_long(j,i)+
 561      &                wcorr*gradcorr_long(j,i)+
 562      &                wcorr5*gradcorr5_long(j,i)+
 563      &                wcorr6*gradcorr6_long(j,i)+
 564      &                wturn6*gcorr6_turn_long(j,i)+
 565      &                wstrain*ghpbc(j,i)
 566      &                +wliptran*gliptranc(j,i)
 567      &                +gradafm(j,i)
 568      &                 +welec*gshieldc(j,i)
 569
 570         enddo
 571       enddo
 572 #endif
 573 #ifdef MPI
 574       if (nfgtasks.gt.1) then
 575       time00=MPI_Wtime()
 576 #ifdef DEBUG
 577       write (iout,*) "gradbufc before allreduce"
 578       do i=1,nres
 579         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 580       enddo
 581       call flush(iout)
 582 #endif
 583       do i=0,nres
 584         do j=1,3
 585           gradbufc_sum(j,i)=gradbufc(j,i)
 586         enddo
 587       enddo
 588 c      call MPI_AllReduce(gradbufc(1,1),gradbufc_sum(1,1),3*nres,
 589 c     &    MPI_DOUBLE_PRECISION,MPI_SUM,FG_COMM,IERR)
 590 c      time_reduce=time_reduce+MPI_Wtime()-time00
 591 #ifdef DEBUG
 592 c      write (iout,*) "gradbufc_sum after allreduce"
 593 c      do i=1,nres
 594 c        write (iout,'(i3,3f10.5)') i,(gradbufc_sum(j,i),j=1,3)
 595 c      enddo
 596 c      call flush(iout)
 597 #endif
 598 #ifdef TIMING
 599 c      time_allreduce=time_allreduce+MPI_Wtime()-time00
 600 #endif
 601       do i=nnt,nres
 602         do k=1,3
 603           gradbufc(k,i)=0.0d0
 604         enddo
 605       enddo
 606 #ifdef DEBUG
 607       write (iout,*) "igrad_start",igrad_start," igrad_end",igrad_end
 608       write (iout,*) (i," jgrad_start",jgrad_start(i),
 609      &                  " jgrad_end  ",jgrad_end(i),
 610      &                  i=igrad_start,igrad_end)
 611 #endif
 612 c
 613 c Obsolete and inefficient code; we can make the effort O(n) and, therefore,
 614 c do not parallelize this part.
 615 c
 616 c      do i=igrad_start,igrad_end
 617 c        do j=jgrad_start(i),jgrad_end(i)
 618 c          do k=1,3
 619 c            gradbufc(k,i)=gradbufc(k,i)+gradbufc_sum(k,j)
 620 c          enddo
 621 c        enddo
 622 c      enddo
 623       do j=1,3
 624         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
 625       enddo
 626       do i=nres-2,-1,-1
 627         do j=1,3
 628           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
 629         enddo
 630       enddo
 631 #ifdef DEBUG
 632       write (iout,*) "gradbufc after summing"
 633       do i=1,nres
 634         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 635       enddo
 636       call flush(iout)
 637 #endif
 638       else
 639 #endif
 640 #ifdef DEBUG
 641       write (iout,*) "gradbufc"
 642       do i=1,nres
 643         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 644       enddo
 645       call flush(iout)
 646 #endif
 647       do i=-1,nres
 648         do j=1,3
 649           gradbufc_sum(j,i)=gradbufc(j,i)
 650           gradbufc(j,i)=0.0d0
 651         enddo
 652       enddo
 653       do j=1,3
 654         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
 655       enddo
 656       do i=nres-2,-1,-1
 657         do j=1,3
 658           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
 659         enddo
 660       enddo
 661 c      do i=nnt,nres-1
 662 c        do k=1,3
 663 c          gradbufc(k,i)=0.0d0
 664 c        enddo
 665 c        do j=i+1,nres
 666 c          do k=1,3
 667 c            gradbufc(k,i)=gradbufc(k,i)+gradbufc(k,j)
 668 c          enddo
 669 c        enddo
 670 c      enddo
 671 #ifdef DEBUG
 672       write (iout,*) "gradbufc after summing"
 673       do i=1,nres
 674         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 675       enddo
 676       call flush(iout)
 677 #endif
 678 #ifdef MPI
 679       endif
 680 #endif
 681       do k=1,3
 682         gradbufc(k,nres)=0.0d0
 683       enddo
 684       do i=-1,nct
 685         do j=1,3
 686 #ifdef SPLITELE
 687 C          print *,gradbufc(1,13)
 688 C          print *,welec*gelc(1,13)
 689 C          print *,wel_loc*gel_loc(1,13)
 690 C          print *,0.5d0*(wscp*gvdwc_scpp(1,13))
 691 C          print *,welec*gelc_long(1,13)+wvdwpp*gvdwpp(1,13)
 692 C          print *,wel_loc*gel_loc_long(1,13)
 693 C          print *,gradafm(1,13),"AFM"
 694           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+
 695      &                wel_loc*gel_loc(j,i)+
 696      &                0.5d0*(wscp*gvdwc_scpp(j,i)+
 697      &                welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+
 698      &                wel_loc*gel_loc_long(j,i)+
 699      &                wcorr*gradcorr_long(j,i)+
 700      &                wcorr5*gradcorr5_long(j,i)+
 701      &                wcorr6*gradcorr6_long(j,i)+
 702      &                wturn6*gcorr6_turn_long(j,i))+
 703      &                wbond*gradb(j,i)+
 704      &                wcorr*gradcorr(j,i)+
 705      &                wturn3*gcorr3_turn(j,i)+
 706      &                wturn4*gcorr4_turn(j,i)+
 707      &                wcorr5*gradcorr5(j,i)+
 708      &                wcorr6*gradcorr6(j,i)+
 709      &                wturn6*gcorr6_turn(j,i)+
 710      &                wsccor*gsccorc(j,i)
 711      &               +wscloc*gscloc(j,i)
 712      &               +wliptran*gliptranc(j,i)
 713      &                +gradafm(j,i)
 714      &                 +welec*gshieldc(j,i)
 715      &                 +welec*gshieldc_loc(j,i)
 716
 717
 718 #else
 719           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+
 720      &                wel_loc*gel_loc(j,i)+
 721      &                0.5d0*(wscp*gvdwc_scpp(j,i)+
 722      &                welec*gelc_long(j,i)
 723      &                wel_loc*gel_loc_long(j,i)+
 724      &                wcorr*gcorr_long(j,i)+
 725      &                wcorr5*gradcorr5_long(j,i)+
 726      &                wcorr6*gradcorr6_long(j,i)+
 727      &                wturn6*gcorr6_turn_long(j,i))+
 728      &                wbond*gradb(j,i)+
 729      &                wcorr*gradcorr(j,i)+
 730      &                wturn3*gcorr3_turn(j,i)+
 731      &                wturn4*gcorr4_turn(j,i)+
 732      &                wcorr5*gradcorr5(j,i)+
 733      &                wcorr6*gradcorr6(j,i)+
 734      &                wturn6*gcorr6_turn(j,i)+
 735      &                wsccor*gsccorc(j,i)
 736      &               +wscloc*gscloc(j,i)
 737      &               +wliptran*gliptranc(j,i)
 738      &                +gradafm(j,i)
 739      &                 +welec*gshieldc(j,i)
 740      &                 +welec*gshieldc_loc(j,i)
 741
 742
 743 #endif
 744           gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+
 745      &                  wbond*gradbx(j,i)+
 746      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
 747      &                  wsccor*gsccorx(j,i)
 748      &                 +wscloc*gsclocx(j,i)
 749      &                 +wliptran*gliptranx(j,i)
 750      &                 +welec*gshieldx(j,i)
 751         enddo
 752       enddo
 753 #ifdef DEBUG
 754       write (iout,*) "gloc before adding corr"
 755       do i=1,4*nres
 756         write (iout,*) i,gloc(i,icg)
 757       enddo
 758 #endif
 759       do i=1,nres-3
 760         gloc(i,icg)=gloc(i,icg)+wcorr*gcorr_loc(i)
 761      &   +wcorr5*g_corr5_loc(i)
 762      &   +wcorr6*g_corr6_loc(i)
 763      &   +wturn4*gel_loc_turn4(i)
 764      &   +wturn3*gel_loc_turn3(i)
 765      &   +wturn6*gel_loc_turn6(i)
 766      &   +wel_loc*gel_loc_loc(i)
 767       enddo
 768 #ifdef DEBUG
 769       write (iout,*) "gloc after adding corr"
 770       do i=1,4*nres
 771         write (iout,*) i,gloc(i,icg)
 772       enddo
 773 #endif
 774 #ifdef MPI
 775       if (nfgtasks.gt.1) then
 776         do j=1,3
 777           do i=1,nres
 778             gradbufc(j,i)=gradc(j,i,icg)
 779             gradbufx(j,i)=gradx(j,i,icg)
 780           enddo
 781         enddo
 782         do i=1,4*nres
 783           glocbuf(i)=gloc(i,icg)
 784         enddo
 785 c#define DEBUG
 786 #ifdef DEBUG
 787       write (iout,*) "gloc_sc before reduce"
 788       do i=1,nres
 789        do j=1,1
 790         write (iout,*) i,j,gloc_sc(j,i,icg)
 791        enddo
 792       enddo
 793 #endif
 794 c#undef DEBUG
 795         do i=1,nres
 796          do j=1,3
 797           gloc_scbuf(j,i)=gloc_sc(j,i,icg)
 798          enddo
 799         enddo
 800         time00=MPI_Wtime()
 801         call MPI_Barrier(FG_COMM,IERR)
 802         time_barrier_g=time_barrier_g+MPI_Wtime()-time00
 803         time00=MPI_Wtime()
 804         call MPI_Reduce(gradbufc(1,1),gradc(1,1,icg),3*nres,
 805      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 806         call MPI_Reduce(gradbufx(1,1),gradx(1,1,icg),3*nres,
 807      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 808         call MPI_Reduce(glocbuf(1),gloc(1,icg),4*nres,
 809      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 810         time_reduce=time_reduce+MPI_Wtime()-time00
 811         call MPI_Reduce(gloc_scbuf(1,1),gloc_sc(1,1,icg),3*nres,
 812      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 813         time_reduce=time_reduce+MPI_Wtime()-time00
 814 c#define DEBUG
 815 #ifdef DEBUG
 816       write (iout,*) "gloc_sc after reduce"
 817       do i=1,nres
 818        do j=1,1
 819         write (iout,*) i,j,gloc_sc(j,i,icg)
 820        enddo
 821       enddo
 822 #endif
 823 c#undef DEBUG
 824 #ifdef DEBUG
 825       write (iout,*) "gloc after reduce"
 826       do i=1,4*nres
 827         write (iout,*) i,gloc(i,icg)
 828       enddo
 829 #endif
 830       endif
 831 #endif
 832       if (gnorm_check) then
 833 c
 834 c Compute the maximum elements of the gradient
 835 c
 836       gvdwc_max=0.0d0
 837       gvdwc_scp_max=0.0d0
 838       gelc_max=0.0d0
 839       gvdwpp_max=0.0d0
 840       gradb_max=0.0d0
 841       ghpbc_max=0.0d0
 842       gradcorr_max=0.0d0
 843       gel_loc_max=0.0d0
 844       gcorr3_turn_max=0.0d0
 845       gcorr4_turn_max=0.0d0
 846       gradcorr5_max=0.0d0
 847       gradcorr6_max=0.0d0
 848       gcorr6_turn_max=0.0d0
 849       gsccorc_max=0.0d0
 850       gscloc_max=0.0d0
 851       gvdwx_max=0.0d0
 852       gradx_scp_max=0.0d0
 853       ghpbx_max=0.0d0
 854       gradxorr_max=0.0d0
 855       gsccorx_max=0.0d0
 856       gsclocx_max=0.0d0
 857       do i=1,nct
 858         gvdwc_norm=dsqrt(scalar(gvdwc(1,i),gvdwc(1,i)))
 859         if (gvdwc_norm.gt.gvdwc_max) gvdwc_max=gvdwc_norm
 860         gvdwc_scp_norm=dsqrt(scalar(gvdwc_scp(1,i),gvdwc_scp(1,i)))
 861         if (gvdwc_scp_norm.gt.gvdwc_scp_max)
 862      &   gvdwc_scp_max=gvdwc_scp_norm
 863         gelc_norm=dsqrt(scalar(gelc(1,i),gelc(1,i)))
 864         if (gelc_norm.gt.gelc_max) gelc_max=gelc_norm
 865         gvdwpp_norm=dsqrt(scalar(gvdwpp(1,i),gvdwpp(1,i)))
 866         if (gvdwpp_norm.gt.gvdwpp_max) gvdwpp_max=gvdwpp_norm
 867         gradb_norm=dsqrt(scalar(gradb(1,i),gradb(1,i)))
 868         if (gradb_norm.gt.gradb_max) gradb_max=gradb_norm
 869         ghpbc_norm=dsqrt(scalar(ghpbc(1,i),ghpbc(1,i)))
 870         if (ghpbc_norm.gt.ghpbc_max) ghpbc_max=ghpbc_norm
 871         gradcorr_norm=dsqrt(scalar(gradcorr(1,i),gradcorr(1,i)))
 872         if (gradcorr_norm.gt.gradcorr_max) gradcorr_max=gradcorr_norm
 873         gel_loc_norm=dsqrt(scalar(gel_loc(1,i),gel_loc(1,i)))
 874         if (gel_loc_norm.gt.gel_loc_max) gel_loc_max=gel_loc_norm
 875         gcorr3_turn_norm=dsqrt(scalar(gcorr3_turn(1,i),
 876      &    gcorr3_turn(1,i)))
 877         if (gcorr3_turn_norm.gt.gcorr3_turn_max)
 878      &    gcorr3_turn_max=gcorr3_turn_norm
 879         gcorr4_turn_norm=dsqrt(scalar(gcorr4_turn(1,i),
 880      &    gcorr4_turn(1,i)))
 881         if (gcorr4_turn_norm.gt.gcorr4_turn_max)
 882      &    gcorr4_turn_max=gcorr4_turn_norm
 883         gradcorr5_norm=dsqrt(scalar(gradcorr5(1,i),gradcorr5(1,i)))
 884         if (gradcorr5_norm.gt.gradcorr5_max)
 885      &    gradcorr5_max=gradcorr5_norm
 886         gradcorr6_norm=dsqrt(scalar(gradcorr6(1,i),gradcorr6(1,i)))
 887         if (gradcorr6_norm.gt.gradcorr6_max) gcorr6_max=gradcorr6_norm
 888         gcorr6_turn_norm=dsqrt(scalar(gcorr6_turn(1,i),
 889      &    gcorr6_turn(1,i)))
 890         if (gcorr6_turn_norm.gt.gcorr6_turn_max)
 891      &    gcorr6_turn_max=gcorr6_turn_norm
 892         gsccorr_norm=dsqrt(scalar(gsccorc(1,i),gsccorc(1,i)))
 893         if (gsccorr_norm.gt.gsccorr_max) gsccorr_max=gsccorr_norm
 894         gscloc_norm=dsqrt(scalar(gscloc(1,i),gscloc(1,i)))
 895         if (gscloc_norm.gt.gscloc_max) gscloc_max=gscloc_norm
 896         gvdwx_norm=dsqrt(scalar(gvdwx(1,i),gvdwx(1,i)))
 897         if (gvdwx_norm.gt.gvdwx_max) gvdwx_max=gvdwx_norm
 898         gradx_scp_norm=dsqrt(scalar(gradx_scp(1,i),gradx_scp(1,i)))
 899         if (gradx_scp_norm.gt.gradx_scp_max)
 900      &    gradx_scp_max=gradx_scp_norm
 901         ghpbx_norm=dsqrt(scalar(ghpbx(1,i),ghpbx(1,i)))
 902         if (ghpbx_norm.gt.ghpbx_max) ghpbx_max=ghpbx_norm
 903         gradxorr_norm=dsqrt(scalar(gradxorr(1,i),gradxorr(1,i)))
 904         if (gradxorr_norm.gt.gradxorr_max) gradxorr_max=gradxorr_norm
 905         gsccorrx_norm=dsqrt(scalar(gsccorx(1,i),gsccorx(1,i)))
 906         if (gsccorrx_norm.gt.gsccorrx_max) gsccorrx_max=gsccorrx_norm
 907         gsclocx_norm=dsqrt(scalar(gsclocx(1,i),gsclocx(1,i)))
 908         if (gsclocx_norm.gt.gsclocx_max) gsclocx_max=gsclocx_norm
 909       enddo
 910       if (gradout) then
 911 #ifdef AIX
 912         open(istat,file=statname,position="append")
 913 #else
 914         open(istat,file=statname,access="append")
 915 #endif
 916         write (istat,'(1h#,21f10.2)') gvdwc_max,gvdwc_scp_max,
 917      &     gelc_max,gvdwpp_max,gradb_max,ghpbc_max,
 918      &     gradcorr_max,gel_loc_max,gcorr3_turn_max,gcorr4_turn_max,
 919      &     gradcorr5_max,gradcorr6_max,gcorr6_turn_max,gsccorc_max,
 920      &     gscloc_max,gvdwx_max,gradx_scp_max,ghpbx_max,gradxorr_max,
 921      &     gsccorx_max,gsclocx_max
 922         close(istat)
 923         if (gvdwc_max.gt.1.0d4) then
 924           write (iout,*) "gvdwc gvdwx gradb gradbx"
 925           do i=nnt,nct
 926             write(iout,'(i5,4(3f10.2,5x))') i,(gvdwc(j,i),gvdwx(j,i),
 927      &        gradb(j,i),gradbx(j,i),j=1,3)
 928           enddo
 929           call pdbout(0.0d0,'cipiszcze',iout)
 930           call flush(iout)
 931         endif
 932       endif
 933       endif
 934 #ifdef DEBUG
 935       write (iout,*) "gradc gradx gloc"
 936       do i=1,nres
 937         write (iout,'(i5,3f10.5,5x,3f10.5,5x,f10.5)')
 938      &   i,(gradc(j,i,icg),j=1,3),(gradx(j,i,icg),j=1,3),gloc(i,icg)
 939       enddo
 940 #endif
 941 #ifdef TIMING
 942       time_sumgradient=time_sumgradient+MPI_Wtime()-time01
 943 #endif
 944       return
 945       end
 946 c-------------------------------------------------------------------------------
 947       subroutine rescale_weights(t_bath)
 948       implicit real*8 (a-h,o-z)
 949       include 'DIMENSIONS'
 950       include 'COMMON.IOUNITS'
 951       include 'COMMON.FFIELD'
 952       include 'COMMON.SBRIDGE'
 953       double precision kfac /2.4d0/
 954       double precision x,x2,x3,x4,x5,licznik /1.12692801104297249644/
 955 c      facT=temp0/t_bath
 956 c      facT=2*temp0/(t_bath+temp0)
 957       if (rescale_mode.eq.0) then
 958         facT=1.0d0
 959         facT2=1.0d0
 960         facT3=1.0d0
 961         facT4=1.0d0
 962         facT5=1.0d0
 963       else if (rescale_mode.eq.1) then
 964         facT=kfac/(kfac-1.0d0+t_bath/temp0)
 965         facT2=kfac**2/(kfac**2-1.0d0+(t_bath/temp0)**2)
 966         facT3=kfac**3/(kfac**3-1.0d0+(t_bath/temp0)**3)
 967         facT4=kfac**4/(kfac**4-1.0d0+(t_bath/temp0)**4)
 968         facT5=kfac**5/(kfac**5-1.0d0+(t_bath/temp0)**5)
 969       else if (rescale_mode.eq.2) then
 970         x=t_bath/temp0
 971         x2=x*x
 972         x3=x2*x
 973         x4=x3*x
 974         x5=x4*x
 975         facT=licznik/dlog(dexp(x)+dexp(-x))
 976         facT2=licznik/dlog(dexp(x2)+dexp(-x2))
 977         facT3=licznik/dlog(dexp(x3)+dexp(-x3))
 978         facT4=licznik/dlog(dexp(x4)+dexp(-x4))
 979         facT5=licznik/dlog(dexp(x5)+dexp(-x5))
 980       else
 981         write (iout,*) "Wrong RESCALE_MODE",rescale_mode
 982         write (*,*) "Wrong RESCALE_MODE",rescale_mode
 983 #ifdef MPI
 984        call MPI_Finalize(MPI_COMM_WORLD,IERROR)
 985 #endif
 986        stop 555
 987       endif
 988       welec=weights(3)*fact
 989       wcorr=weights(4)*fact3
 990       wcorr5=weights(5)*fact4
 991       wcorr6=weights(6)*fact5
 992       wel_loc=weights(7)*fact2
 993       wturn3=weights(8)*fact2
 994       wturn4=weights(9)*fact3
 995       wturn6=weights(10)*fact5
 996       wtor=weights(13)*fact
 997       wtor_d=weights(14)*fact2
 998       wsccor=weights(21)*fact
 999
1000       return
1001       end
1002 C------------------------------------------------------------------------
1003       subroutine enerprint(energia)
1004       implicit real*8 (a-h,o-z)
1005       include 'DIMENSIONS'
1006       include 'COMMON.IOUNITS'
1007       include 'COMMON.FFIELD'
1008       include 'COMMON.SBRIDGE'
1009       include 'COMMON.MD'
1010       double precision energia(0:n_ene)
1011       etot=energia(0)
1012       evdw=energia(1)
1013       evdw2=energia(2)
1014 #ifdef SCP14
1015       evdw2=energia(2)+energia(18)
1016 #else
1017       evdw2=energia(2)
1018 #endif
1019       ees=energia(3)
1020 #ifdef SPLITELE
1021       evdw1=energia(16)
1022 #endif
1023       ecorr=energia(4)
1024       ecorr5=energia(5)
1025       ecorr6=energia(6)
1026       eel_loc=energia(7)
1027       eello_turn3=energia(8)
1028       eello_turn4=energia(9)
1029       eello_turn6=energia(10)
1030       ebe=energia(11)
1031       escloc=energia(12)
1032       etors=energia(13)
1033       etors_d=energia(14)
1034       ehpb=energia(15)
1035       edihcnstr=energia(19)
1036       estr=energia(17)
1037       Uconst=energia(20)
1038       esccor=energia(21)
1039       eliptran=energia(22)
1040       Eafmforce=energia(23)
1041       ethetacnstr=energia(24)
1042 #ifdef SPLITELE
1043       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,evdw1,wvdwpp,
1044      &  estr,wbond,ebe,wang,
1045      &  escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,
1046      &  ecorr,wcorr,
1047      &  ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,
1048      &  eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccro,edihcnstr,
1049      &  ethetacnstr,ebr*nss,Uconst,eliptran,wliptran,Eafmforc,
1050      &  etot
1051    10 format (/'Virtual-chain energies:'//
1052      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
1053      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
1054      & 'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/
1055      & 'EVDWPP=',1pE16.6,' WEIGHT=',1pD16.6,' (p-p VDW)'/
1056      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
1057      & 'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
1058      & 'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
1059      & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
1060      & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
1061      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6,
1062      & ' (SS bridges & dist. cnstr.)'/
1063      & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1064      & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1065      & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1066      & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
1067      & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
1068      & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
1069      & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
1070      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
1071      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
1072      & 'ETHETC= ',1pE16.6,' (valence angle constraints)'/
1073      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
1074      & 'UCONST= ',1pE16.6,' (Constraint energy)'/
1075      & 'ELT=',1pE16.6, ' WEIGHT=',1pD16.6,' (Lipid transfer energy)'/
1076      & 'EAFM=  ',1pE16.6,' (atomic-force microscopy)'/
1077      & 'ETOT=  ',1pE16.6,' (total)')
1078
1079 #else
1080       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,
1081      &  estr,wbond,ebe,wang,
1082      &  escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,
1083      &  ecorr,wcorr,
1084      &  ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,
1085      &  eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccro,edihcnstr,
1086      &  ethetacnstr,ebr*nss,Uconst,eliptran,wliptran,Eafmforc,
1087      &  etot
1088    10 format (/'Virtual-chain energies:'//
1089      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
1090      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
1091      & 'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/
1092      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
1093      & 'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
1094      & 'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
1095      & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
1096      & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
1097      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6,
1098      & ' (SS bridges & dist. cnstr.)'/
1099      & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1100      & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1101      & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1102      & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
1103      & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
1104      & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
1105      & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
1106      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
1107      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
1108      & 'ETHETC= ',1pE16.6,' (valence angle constraints)'/
1109      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
1110      & 'UCONST=',1pE16.6,' (Constraint energy)'/
1111      & 'ELT=',1pE16.6, ' WEIGHT=',1pD16.6,' (Lipid transfer energy)'/
1112      & 'EAFM=  ',1pE16.6,' (atomic-force microscopy)'/
1113      & 'ETOT=  ',1pE16.6,' (total)')
1114 #endif
1115       return
1116       end
1117 C-----------------------------------------------------------------------
1118       subroutine elj(evdw)
1119 C
1120 C This subroutine calculates the interaction energy of nonbonded side chains
1121 C assuming the LJ potential of interaction.
1122 C
1123       implicit real*8 (a-h,o-z)
1124       include 'DIMENSIONS'
1125       parameter (accur=1.0d-10)
1126       include 'COMMON.GEO'
1127       include 'COMMON.VAR'
1128       include 'COMMON.LOCAL'
1129       include 'COMMON.CHAIN'
1130       include 'COMMON.DERIV'
1131       include 'COMMON.INTERACT'
1132       include 'COMMON.TORSION'
1133       include 'COMMON.SBRIDGE'
1134       include 'COMMON.NAMES'
1135       include 'COMMON.IOUNITS'
1136       include 'COMMON.CONTACTS'
1137       dimension gg(3)
1138 c      write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
1139       evdw=0.0D0
1140       do i=iatsc_s,iatsc_e
1141         itypi=iabs(itype(i))
1142         if (itypi.eq.ntyp1) cycle
1143         itypi1=iabs(itype(i+1))
1144         xi=c(1,nres+i)
1145         yi=c(2,nres+i)
1146         zi=c(3,nres+i)
1147 C Change 12/1/95
1148         num_conti=0
1149 C
1150 C Calculate SC interaction energy.
1151 C
1152         do iint=1,nint_gr(i)
1153 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
1154 cd   &                  'iend=',iend(i,iint)
1155           do j=istart(i,iint),iend(i,iint)
1156             itypj=iabs(itype(j))
1157             if (itypj.eq.ntyp1) cycle
1158             xj=c(1,nres+j)-xi
1159             yj=c(2,nres+j)-yi
1160             zj=c(3,nres+j)-zi
1161 C Change 12/1/95 to calculate four-body interactions
1162             rij=xj*xj+yj*yj+zj*zj
1163             rrij=1.0D0/rij
1164 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
1165             eps0ij=eps(itypi,itypj)
1166             fac=rrij**expon2
1167 C have you changed here?
1168             e1=fac*fac*aa
1169             e2=fac*bb
1170             evdwij=e1+e2
1171 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1172 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1173 cd          write (iout,'(2(a3,i3,2x),6(1pd12.4)/2(3(1pd12.4),5x)/)')
1174 cd   &        restyp(itypi),i,restyp(itypj),j,a(itypi,itypj),
1175 cd   &        bb(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,epsi,sigm,
1176 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1177             evdw=evdw+evdwij
1178 C
1179 C Calculate the components of the gradient in DC and X
1180 C
1181             fac=-rrij*(e1+evdwij)
1182             gg(1)=xj*fac
1183             gg(2)=yj*fac
1184             gg(3)=zj*fac
1185             do k=1,3
1186               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1187               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1188               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1189               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1190             enddo
1191 cgrad            do k=i,j-1
1192 cgrad              do l=1,3
1193 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1194 cgrad              enddo
1195 cgrad            enddo
1196 C
1197 C 12/1/95, revised on 5/20/97
1198 C
1199 C Calculate the contact function. The ith column of the array JCONT will
1200 C contain the numbers of atoms that make contacts with the atom I (of numbers
1201 C greater than I). The arrays FACONT and GACONT will contain the values of
1202 C the contact function and its derivative.
1203 C
1204 C Uncomment next line, if the correlation interactions include EVDW explicitly.
1205 c           if (j.gt.i+1 .and. evdwij.le.0.0D0) then
1206 C Uncomment next line, if the correlation interactions are contact function only
1207             if (j.gt.i+1.and. eps0ij.gt.0.0D0) then
1208               rij=dsqrt(rij)
1209               sigij=sigma(itypi,itypj)
1210               r0ij=rs0(itypi,itypj)
1211 C
1212 C Check whether the SC's are not too far to make a contact.
1213 C
1214               rcut=1.5d0*r0ij
1215               call gcont(rij,rcut,1.0d0,0.2d0*rcut,fcont,fprimcont)
1216 C Add a new contact, if the SC's are close enough, but not too close (r<sigma).
1217 C
1218               if (fcont.gt.0.0D0) then
1219 C If the SC-SC distance if close to sigma, apply spline.
1220 cAdam           call gcont(-rij,-1.03d0*sigij,2.0d0*sigij,1.0d0,
1221 cAdam &             fcont1,fprimcont1)
1222 cAdam           fcont1=1.0d0-fcont1
1223 cAdam           if (fcont1.gt.0.0d0) then
1224 cAdam             fprimcont=fprimcont*fcont1+fcont*fprimcont1
1225 cAdam             fcont=fcont*fcont1
1226 cAdam           endif
1227 C Uncomment following 4 lines to have the geometric average of the epsilon0's
1228 cga             eps0ij=1.0d0/dsqrt(eps0ij)
1229 cga             do k=1,3
1230 cga               gg(k)=gg(k)*eps0ij
1231 cga             enddo
1232 cga             eps0ij=-evdwij*eps0ij
1233 C Uncomment for AL's type of SC correlation interactions.
1234 cadam           eps0ij=-evdwij
1235                 num_conti=num_conti+1
1236                 jcont(num_conti,i)=j
1237                 facont(num_conti,i)=fcont*eps0ij
1238                 fprimcont=eps0ij*fprimcont/rij
1239                 fcont=expon*fcont
1240 cAdam           gacont(1,num_conti,i)=-fprimcont*xj+fcont*gg(1)
1241 cAdam           gacont(2,num_conti,i)=-fprimcont*yj+fcont*gg(2)
1242 cAdam           gacont(3,num_conti,i)=-fprimcont*zj+fcont*gg(3)
1243 C Uncomment following 3 lines for Skolnick's type of SC correlation.
1244                 gacont(1,num_conti,i)=-fprimcont*xj
1245                 gacont(2,num_conti,i)=-fprimcont*yj
1246                 gacont(3,num_conti,i)=-fprimcont*zj
1247 cd              write (iout,'(2i5,2f10.5)') i,j,rij,facont(num_conti,i)
1248 cd              write (iout,'(2i3,3f10.5)')
1249 cd   &           i,j,(gacont(kk,num_conti,i),kk=1,3)
1250               endif
1251             endif
1252           enddo      ! j
1253         enddo        ! iint
1254 C Change 12/1/95
1255         num_cont(i)=num_conti
1256       enddo          ! i
1257       do i=1,nct
1258         do j=1,3
1259           gvdwc(j,i)=expon*gvdwc(j,i)
1260           gvdwx(j,i)=expon*gvdwx(j,i)
1261         enddo
1262       enddo
1263 C******************************************************************************
1264 C
1265 C                              N O T E !!!
1266 C
1267 C To save time, the factor of EXPON has been extracted from ALL components
1268 C of GVDWC and GRADX. Remember to multiply them by this factor before further
1269 C use!
1270 C
1271 C******************************************************************************
1272       return
1273       end
1274 C-----------------------------------------------------------------------------
1275       subroutine eljk(evdw)
1276 C
1277 C This subroutine calculates the interaction energy of nonbonded side chains
1278 C assuming the LJK potential of interaction.
1279 C
1280       implicit real*8 (a-h,o-z)
1281       include 'DIMENSIONS'
1282       include 'COMMON.GEO'
1283       include 'COMMON.VAR'
1284       include 'COMMON.LOCAL'
1285       include 'COMMON.CHAIN'
1286       include 'COMMON.DERIV'
1287       include 'COMMON.INTERACT'
1288       include 'COMMON.IOUNITS'
1289       include 'COMMON.NAMES'
1290       dimension gg(3)
1291       logical scheck
1292 c     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
1293       evdw=0.0D0
1294       do i=iatsc_s,iatsc_e
1295         itypi=iabs(itype(i))
1296         if (itypi.eq.ntyp1) cycle
1297         itypi1=iabs(itype(i+1))
1298         xi=c(1,nres+i)
1299         yi=c(2,nres+i)
1300         zi=c(3,nres+i)
1301 C
1302 C Calculate SC interaction energy.
1303 C
1304         do iint=1,nint_gr(i)
1305           do j=istart(i,iint),iend(i,iint)
1306             itypj=iabs(itype(j))
1307             if (itypj.eq.ntyp1) cycle
1308             xj=c(1,nres+j)-xi
1309             yj=c(2,nres+j)-yi
1310             zj=c(3,nres+j)-zi
1311             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1312             fac_augm=rrij**expon
1313             e_augm=augm(itypi,itypj)*fac_augm
1314             r_inv_ij=dsqrt(rrij)
1315             rij=1.0D0/r_inv_ij
1316             r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
1317             fac=r_shift_inv**expon
1318 C have you changed here?
1319             e1=fac*fac*aa
1320             e2=fac*bb
1321             evdwij=e_augm+e1+e2
1322 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1323 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1324 cd          write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
1325 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
1326 cd   &        bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
1327 cd   &        sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
1328 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1329             evdw=evdw+evdwij
1330 C
1331 C Calculate the components of the gradient in DC and X
1332 C
1333             fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
1334             gg(1)=xj*fac
1335             gg(2)=yj*fac
1336             gg(3)=zj*fac
1337             do k=1,3
1338               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1339               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1340               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1341               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1342             enddo
1343 cgrad            do k=i,j-1
1344 cgrad              do l=1,3
1345 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1346 cgrad              enddo
1347 cgrad            enddo
1348           enddo      ! j
1349         enddo        ! iint
1350       enddo          ! i
1351       do i=1,nct
1352         do j=1,3
1353           gvdwc(j,i)=expon*gvdwc(j,i)
1354           gvdwx(j,i)=expon*gvdwx(j,i)
1355         enddo
1356       enddo
1357       return
1358       end
1359 C-----------------------------------------------------------------------------
1360       subroutine ebp(evdw)
1361 C
1362 C This subroutine calculates the interaction energy of nonbonded side chains
1363 C assuming the Berne-Pechukas potential of interaction.
1364 C
1365       implicit real*8 (a-h,o-z)
1366       include 'DIMENSIONS'
1367       include 'COMMON.GEO'
1368       include 'COMMON.VAR'
1369       include 'COMMON.LOCAL'
1370       include 'COMMON.CHAIN'
1371       include 'COMMON.DERIV'
1372       include 'COMMON.NAMES'
1373       include 'COMMON.INTERACT'
1374       include 'COMMON.IOUNITS'
1375       include 'COMMON.CALC'
1376       common /srutu/ icall
1377 c     double precision rrsave(maxdim)
1378       logical lprn
1379       evdw=0.0D0
1380 c     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
1381       evdw=0.0D0
1382 c     if (icall.eq.0) then
1383 c       lprn=.true.
1384 c     else
1385         lprn=.false.
1386 c     endif
1387       ind=0
1388       do i=iatsc_s,iatsc_e
1389         itypi=iabs(itype(i))
1390         if (itypi.eq.ntyp1) cycle
1391         itypi1=iabs(itype(i+1))
1392         xi=c(1,nres+i)
1393         yi=c(2,nres+i)
1394         zi=c(3,nres+i)
1395         dxi=dc_norm(1,nres+i)
1396         dyi=dc_norm(2,nres+i)
1397         dzi=dc_norm(3,nres+i)
1398 c        dsci_inv=dsc_inv(itypi)
1399         dsci_inv=vbld_inv(i+nres)
1400 C
1401 C Calculate SC interaction energy.
1402 C
1403         do iint=1,nint_gr(i)
1404           do j=istart(i,iint),iend(i,iint)
1405             ind=ind+1
1406             itypj=iabs(itype(j))
1407             if (itypj.eq.ntyp1) cycle
1408 c            dscj_inv=dsc_inv(itypj)
1409             dscj_inv=vbld_inv(j+nres)
1410             chi1=chi(itypi,itypj)
1411             chi2=chi(itypj,itypi)
1412             chi12=chi1*chi2
1413             chip1=chip(itypi)
1414             chip2=chip(itypj)
1415             chip12=chip1*chip2
1416             alf1=alp(itypi)
1417             alf2=alp(itypj)
1418             alf12=0.5D0*(alf1+alf2)
1419 C For diagnostics only!!!
1420 c           chi1=0.0D0
1421 c           chi2=0.0D0
1422 c           chi12=0.0D0
1423 c           chip1=0.0D0
1424 c           chip2=0.0D0
1425 c           chip12=0.0D0
1426 c           alf1=0.0D0
1427 c           alf2=0.0D0
1428 c           alf12=0.0D0
1429             xj=c(1,nres+j)-xi
1430             yj=c(2,nres+j)-yi
1431             zj=c(3,nres+j)-zi
1432             dxj=dc_norm(1,nres+j)
1433             dyj=dc_norm(2,nres+j)
1434             dzj=dc_norm(3,nres+j)
1435             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1436 cd          if (icall.eq.0) then
1437 cd            rrsave(ind)=rrij
1438 cd          else
1439 cd            rrij=rrsave(ind)
1440 cd          endif
1441             rij=dsqrt(rrij)
1442 C Calculate the angle-dependent terms of energy & contributions to derivatives.
1443             call sc_angular
1444 C Calculate whole angle-dependent part of epsilon and contributions
1445 C to its derivatives
1446 C have you changed here?
1447             fac=(rrij*sigsq)**expon2
1448             e1=fac*fac*aa
1449             e2=fac*bb
1450             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1451             eps2der=evdwij*eps3rt
1452             eps3der=evdwij*eps2rt
1453             evdwij=evdwij*eps2rt*eps3rt
1454             evdw=evdw+evdwij
1455             if (lprn) then
1456             sigm=dabs(aa/bb)**(1.0D0/6.0D0)
1457             epsi=bb**2/aa
1458 cd            write (iout,'(2(a3,i3,2x),15(0pf7.3))')
1459 cd     &        restyp(itypi),i,restyp(itypj),j,
1460 cd     &        epsi,sigm,chi1,chi2,chip1,chip2,
1461 cd     &        eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
1462 cd     &        om1,om2,om12,1.0D0/dsqrt(rrij),
1463 cd     &        evdwij
1464             endif
1465 C Calculate gradient components.
1466             e1=e1*eps1*eps2rt**2*eps3rt**2
1467             fac=-expon*(e1+evdwij)
1468             sigder=fac/sigsq
1469             fac=rrij*fac
1470 C Calculate radial part of the gradient
1471             gg(1)=xj*fac
1472             gg(2)=yj*fac
1473             gg(3)=zj*fac
1474 C Calculate the angular part of the gradient and sum add the contributions
1475 C to the appropriate components of the Cartesian gradient.
1476             call sc_grad
1477           enddo      ! j
1478         enddo        ! iint
1479       enddo          ! i
1480 c     stop
1481       return
1482       end
1483 C-----------------------------------------------------------------------------
1484       subroutine egb(evdw)
1485 C
1486 C This subroutine calculates the interaction energy of nonbonded side chains
1487 C assuming the Gay-Berne potential of interaction.
1488 C
1489       implicit real*8 (a-h,o-z)
1490       include 'DIMENSIONS'
1491       include 'COMMON.GEO'
1492       include 'COMMON.VAR'
1493       include 'COMMON.LOCAL'
1494       include 'COMMON.CHAIN'
1495       include 'COMMON.DERIV'
1496       include 'COMMON.NAMES'
1497       include 'COMMON.INTERACT'
1498       include 'COMMON.IOUNITS'
1499       include 'COMMON.CALC'
1500       include 'COMMON.CONTROL'
1501       include 'COMMON.SPLITELE'
1502       include 'COMMON.SBRIDGE'
1503       logical lprn
1504       integer xshift,yshift,zshift
1505
1506       evdw=0.0D0
1507 ccccc      energy_dec=.false.
1508 C      print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1509       evdw=0.0D0
1510       lprn=.false.
1511 c     if (icall.eq.0) lprn=.false.
1512       ind=0
1513 C the loop over all 27 posible neigbours (for xshift=0,yshift=0,zshift=0
1514 C we have the original box)
1515 C      do xshift=-1,1
1516 C      do yshift=-1,1
1517 C      do zshift=-1,1
1518       do i=iatsc_s,iatsc_e
1519         itypi=iabs(itype(i))
1520         if (itypi.eq.ntyp1) cycle
1521         itypi1=iabs(itype(i+1))
1522         xi=c(1,nres+i)
1523         yi=c(2,nres+i)
1524         zi=c(3,nres+i)
1525 C Return atom into box, boxxsize is size of box in x dimension
1526 c  134   continue
1527 c        if (xi.gt.((xshift+0.5d0)*boxxsize)) xi=xi-boxxsize
1528 c        if (xi.lt.((xshift-0.5d0)*boxxsize)) xi=xi+boxxsize
1529 C Condition for being inside the proper box
1530 c        if ((xi.gt.((xshift+0.5d0)*boxxsize)).or.
1531 c     &       (xi.lt.((xshift-0.5d0)*boxxsize))) then
1532 c        go to 134
1533 c        endif
1534 c  135   continue
1535 c        if (yi.gt.((yshift+0.5d0)*boxysize)) yi=yi-boxysize
1536 c        if (yi.lt.((yshift-0.5d0)*boxysize)) yi=yi+boxysize
1537 C Condition for being inside the proper box
1538 c        if ((yi.gt.((yshift+0.5d0)*boxysize)).or.
1539 c     &       (yi.lt.((yshift-0.5d0)*boxysize))) then
1540 c        go to 135
1541 c        endif
1542 c  136   continue
1543 c        if (zi.gt.((zshift+0.5d0)*boxzsize)) zi=zi-boxzsize
1544 c        if (zi.lt.((zshift-0.5d0)*boxzsize)) zi=zi+boxzsize
1545 C Condition for being inside the proper box
1546 c        if ((zi.gt.((zshift+0.5d0)*boxzsize)).or.
1547 c     &       (zi.lt.((zshift-0.5d0)*boxzsize))) then
1548 c        go to 136
1549 c        endif
1550           xi=mod(xi,boxxsize)
1551           if (xi.lt.0) xi=xi+boxxsize
1552           yi=mod(yi,boxysize)
1553           if (yi.lt.0) yi=yi+boxysize
1554           zi=mod(zi,boxzsize)
1555           if (zi.lt.0) zi=zi+boxzsize
1556 C define scaling factor for lipids
1557
1558 C        if (positi.le.0) positi=positi+boxzsize
1559 C        print *,i
1560 C first for peptide groups
1561 c for each residue check if it is in lipid or lipid water border area
1562        if ((zi.gt.bordlipbot)
1563      &.and.(zi.lt.bordliptop)) then
1564 C the energy transfer exist
1565         if (zi.lt.buflipbot) then
1566 C what fraction I am in
1567          fracinbuf=1.0d0-
1568      &        ((zi-bordlipbot)/lipbufthick)
1569 C lipbufthick is thickenes of lipid buffore
1570          sslipi=sscalelip(fracinbuf)
1571          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
1572         elseif (zi.gt.bufliptop) then
1573          fracinbuf=1.0d0-((bordliptop-zi)/lipbufthick)
1574          sslipi=sscalelip(fracinbuf)
1575          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
1576         else
1577          sslipi=1.0d0
1578          ssgradlipi=0.0
1579         endif
1580        else
1581          sslipi=0.0d0
1582          ssgradlipi=0.0
1583        endif
1584
1585 C          xi=xi+xshift*boxxsize
1586 C          yi=yi+yshift*boxysize
1587 C          zi=zi+zshift*boxzsize
1588
1589         dxi=dc_norm(1,nres+i)
1590         dyi=dc_norm(2,nres+i)
1591         dzi=dc_norm(3,nres+i)
1592 c        dsci_inv=dsc_inv(itypi)
1593         dsci_inv=vbld_inv(i+nres)
1594 c        write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)
1595 c        write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi
1596 C
1597 C Calculate SC interaction energy.
1598 C
1599         do iint=1,nint_gr(i)
1600           do j=istart(i,iint),iend(i,iint)
1601             IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN
1602
1603 c              write(iout,*) "PRZED ZWYKLE", evdwij
1604               call dyn_ssbond_ene(i,j,evdwij)
1605 c              write(iout,*) "PO ZWYKLE", evdwij
1606
1607               evdw=evdw+evdwij
1608               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)')
1609      &                        'evdw',i,j,evdwij,' ss'
1610 C triple bond artifac removal
1611              do k=j+1,iend(i,iint)
1612 C search over all next residues
1613               if (dyn_ss_mask(k)) then
1614 C check if they are cysteins
1615 C              write(iout,*) 'k=',k
1616
1617 c              write(iout,*) "PRZED TRI", evdwij
1618                evdwij_przed_tri=evdwij
1619               call triple_ssbond_ene(i,j,k,evdwij)
1620 c               if(evdwij_przed_tri.ne.evdwij) then
1621 c                 write (iout,*) "TRI:", evdwij, evdwij_przed_tri
1622 c               endif
1623
1624 c              write(iout,*) "PO TRI", evdwij
1625 C call the energy function that removes the artifical triple disulfide
1626 C bond the soubroutine is located in ssMD.F
1627               evdw=evdw+evdwij
1628               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)')
1629      &                        'evdw',i,j,evdwij,'tss'
1630               endif!dyn_ss_mask(k)
1631              enddo! k
1632             ELSE
1633             ind=ind+1
1634             itypj=iabs(itype(j))
1635             if (itypj.eq.ntyp1) cycle
1636 c            dscj_inv=dsc_inv(itypj)
1637             dscj_inv=vbld_inv(j+nres)
1638 c            write (iout,*) "j",j,dsc_inv(itypj),dscj_inv,
1639 c     &       1.0d0/vbld(j+nres)
1640 c            write (iout,*) "i",i," j", j," itype",itype(i),itype(j)
1641             sig0ij=sigma(itypi,itypj)
1642             chi1=chi(itypi,itypj)
1643             chi2=chi(itypj,itypi)
1644             chi12=chi1*chi2
1645             chip1=chip(itypi)
1646             chip2=chip(itypj)
1647             chip12=chip1*chip2
1648             alf1=alp(itypi)
1649             alf2=alp(itypj)
1650             alf12=0.5D0*(alf1+alf2)
1651 C For diagnostics only!!!
1652 c           chi1=0.0D0
1653 c           chi2=0.0D0
1654 c           chi12=0.0D0
1655 c           chip1=0.0D0
1656 c           chip2=0.0D0
1657 c           chip12=0.0D0
1658 c           alf1=0.0D0
1659 c           alf2=0.0D0
1660 c           alf12=0.0D0
1661             xj=c(1,nres+j)
1662             yj=c(2,nres+j)
1663             zj=c(3,nres+j)
1664 C Return atom J into box the original box
1665 c  137   continue
1666 c        if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
1667 c        if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
1668 C Condition for being inside the proper box
1669 c        if ((xj.gt.((0.5d0)*boxxsize)).or.
1670 c     &       (xj.lt.((-0.5d0)*boxxsize))) then
1671 c        go to 137
1672 c        endif
1673 c  138   continue
1674 c        if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
1675 c        if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
1676 C Condition for being inside the proper box
1677 c        if ((yj.gt.((0.5d0)*boxysize)).or.
1678 c     &       (yj.lt.((-0.5d0)*boxysize))) then
1679 c        go to 138
1680 c        endif
1681 c  139   continue
1682 c        if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
1683 c        if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
1684 C Condition for being inside the proper box
1685 c        if ((zj.gt.((0.5d0)*boxzsize)).or.
1686 c     &       (zj.lt.((-0.5d0)*boxzsize))) then
1687 c        go to 139
1688 c        endif
1689           xj=mod(xj,boxxsize)
1690           if (xj.lt.0) xj=xj+boxxsize
1691           yj=mod(yj,boxysize)
1692           if (yj.lt.0) yj=yj+boxysize
1693           zj=mod(zj,boxzsize)
1694           if (zj.lt.0) zj=zj+boxzsize
1695        if ((zj.gt.bordlipbot)
1696      &.and.(zj.lt.bordliptop)) then
1697 C the energy transfer exist
1698         if (zj.lt.buflipbot) then
1699 C what fraction I am in
1700          fracinbuf=1.0d0-
1701      &        ((zj-bordlipbot)/lipbufthick)
1702 C lipbufthick is thickenes of lipid buffore
1703          sslipj=sscalelip(fracinbuf)
1704          ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
1705         elseif (zj.gt.bufliptop) then
1706          fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
1707          sslipj=sscalelip(fracinbuf)
1708          ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
1709         else
1710          sslipj=1.0d0
1711          ssgradlipj=0.0
1712         endif
1713        else
1714          sslipj=0.0d0
1715          ssgradlipj=0.0
1716        endif
1717       aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
1718      &  +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1719       bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
1720      &  +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1721 C      if (aa.ne.aa_aq(itypi,itypj)) write(63,'(2e10.5)')
1722 C     &(aa-aa_aq(itypi,itypj)),(bb-bb_aq(itypi,itypj))
1723 C      if (ssgradlipj.gt.0.0d0) print *,"??WTF??"
1724 C      print *,sslipi,sslipj,bordlipbot,zi,zj
1725       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
1726       xj_safe=xj
1727       yj_safe=yj
1728       zj_safe=zj
1729       subchap=0
1730       do xshift=-1,1
1731       do yshift=-1,1
1732       do zshift=-1,1
1733           xj=xj_safe+xshift*boxxsize
1734           yj=yj_safe+yshift*boxysize
1735           zj=zj_safe+zshift*boxzsize
1736           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
1737           if(dist_temp.lt.dist_init) then
1738             dist_init=dist_temp
1739             xj_temp=xj
1740             yj_temp=yj
1741             zj_temp=zj
1742             subchap=1
1743           endif
1744        enddo
1745        enddo
1746        enddo
1747        if (subchap.eq.1) then
1748           xj=xj_temp-xi
1749           yj=yj_temp-yi
1750           zj=zj_temp-zi
1751        else
1752           xj=xj_safe-xi
1753           yj=yj_safe-yi
1754           zj=zj_safe-zi
1755        endif
1756             dxj=dc_norm(1,nres+j)
1757             dyj=dc_norm(2,nres+j)
1758             dzj=dc_norm(3,nres+j)
1759 C            xj=xj-xi
1760 C            yj=yj-yi
1761 C            zj=zj-zi
1762 c            write (iout,*) "dcnorj",dxi*dxi+dyi*dyi+dzi*dzi
1763 c            write (iout,*) "j",j," dc_norm",
1764 c     &       dc_norm(1,nres+j),dc_norm(2,nres+j),dc_norm(3,nres+j)
1765             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1766             rij=dsqrt(rrij)
1767             sss=sscale((1.0d0/rij)/sigma(itypi,itypj))
1768             sssgrad=sscagrad((1.0d0/rij)/sigma(itypi,itypj))
1769
1770 c            write (iout,'(a7,4f8.3)')
1771 c    &      "ssscale",sss,((1.0d0/rij)/sigma(itypi,itypj)),r_cut,rlamb
1772             if (sss.gt.0.0d0) then
1773 C Calculate angle-dependent terms of energy and contributions to their
1774 C derivatives.
1775             call sc_angular
1776             sigsq=1.0D0/sigsq
1777             sig=sig0ij*dsqrt(sigsq)
1778             rij_shift=1.0D0/rij-sig+sig0ij
1779 c for diagnostics; uncomment
1780 c            rij_shift=1.2*sig0ij
1781 C I hate to put IF's in the loops, but here don't have another choice!!!!
1782             if (rij_shift.le.0.0D0) then
1783               evdw=1.0D20
1784 cd              write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1785 cd     &        restyp(itypi),i,restyp(itypj),j,
1786 cd     &        rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq)
1787               return
1788             endif
1789             sigder=-sig*sigsq
1790 c---------------------------------------------------------------
1791             rij_shift=1.0D0/rij_shift
1792             fac=rij_shift**expon
1793 C here to start with
1794 C            if (c(i,3).gt.
1795             faclip=fac
1796             e1=fac*fac*aa
1797             e2=fac*bb
1798             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1799             eps2der=evdwij*eps3rt
1800             eps3der=evdwij*eps2rt
1801 C       write(63,'(2i3,2e10.3,2f10.5)') i,j,aa,bb, evdwij,
1802 C     &((sslipi+sslipj)/2.0d0+
1803 C     &(2.0d0-sslipi-sslipj)/2.0d0)
1804 c            write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt,
1805 c     &        " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2
1806             evdwij=evdwij*eps2rt*eps3rt
1807             evdw=evdw+evdwij*sss
1808             if (lprn) then
1809             sigm=dabs(aa/bb)**(1.0D0/6.0D0)
1810             epsi=bb**2/aa
1811             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1812      &        restyp(itypi),i,restyp(itypj),j,
1813      &        epsi,sigm,chi1,chi2,chip1,chip2,
1814      &        eps1,eps2rt**2,eps3rt**2,sig,sig0ij,
1815      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1816      &        evdwij
1817             endif
1818
1819             if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
1820      &                        'evdw',i,j,evdwij
1821
1822 C Calculate gradient components.
1823             e1=e1*eps1*eps2rt**2*eps3rt**2
1824             fac=-expon*(e1+evdwij)*rij_shift
1825             sigder=fac*sigder
1826             fac=rij*fac
1827 c            print '(2i4,6f8.4)',i,j,sss,sssgrad*
1828 c     &      evdwij,fac,sigma(itypi,itypj),expon
1829             fac=fac+evdwij/sss*sssgrad/sigma(itypi,itypj)*rij
1830 c            fac=0.0d0
1831 C Calculate the radial part of the gradient
1832             gg_lipi(3)=eps1*(eps2rt*eps2rt)
1833      &*(eps3rt*eps3rt)*sss/2.0d0*(faclip*faclip*
1834      & (aa_lip(itypi,itypj)-aa_aq(itypi,itypj))
1835      &+faclip*(bb_lip(itypi,itypj)-bb_aq(itypi,itypj)))
1836             gg_lipj(3)=ssgradlipj*gg_lipi(3)
1837             gg_lipi(3)=gg_lipi(3)*ssgradlipi
1838 C            gg_lipi(3)=0.0d0
1839 C            gg_lipj(3)=0.0d0
1840             gg(1)=xj*fac
1841             gg(2)=yj*fac
1842             gg(3)=zj*fac
1843 C Calculate angular part of the gradient.
1844             call sc_grad
1845             endif
1846             ENDIF    ! dyn_ss
1847           enddo      ! j
1848         enddo        ! iint
1849       enddo          ! i
1850 C      enddo          ! zshift
1851 C      enddo          ! yshift
1852 C      enddo          ! xshift
1853 c      write (iout,*) "Number of loop steps in EGB:",ind
1854 cccc      energy_dec=.false.
1855       return
1856       end
1857 C-----------------------------------------------------------------------------
1858       subroutine egbv(evdw)
1859 C
1860 C This subroutine calculates the interaction energy of nonbonded side chains
1861 C assuming the Gay-Berne-Vorobjev potential of interaction.
1862 C
1863       implicit real*8 (a-h,o-z)
1864       include 'DIMENSIONS'
1865       include 'COMMON.GEO'
1866       include 'COMMON.VAR'
1867       include 'COMMON.LOCAL'
1868       include 'COMMON.CHAIN'
1869       include 'COMMON.DERIV'
1870       include 'COMMON.NAMES'
1871       include 'COMMON.INTERACT'
1872       include 'COMMON.IOUNITS'
1873       include 'COMMON.CALC'
1874       common /srutu/ icall
1875       logical lprn
1876       evdw=0.0D0
1877 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1878       evdw=0.0D0
1879       lprn=.false.
1880 c     if (icall.eq.0) lprn=.true.
1881       ind=0
1882       do i=iatsc_s,iatsc_e
1883         itypi=iabs(itype(i))
1884         if (itypi.eq.ntyp1) cycle
1885         itypi1=iabs(itype(i+1))
1886         xi=c(1,nres+i)
1887         yi=c(2,nres+i)
1888         zi=c(3,nres+i)
1889           xi=mod(xi,boxxsize)
1890           if (xi.lt.0) xi=xi+boxxsize
1891           yi=mod(yi,boxysize)
1892           if (yi.lt.0) yi=yi+boxysize
1893           zi=mod(zi,boxzsize)
1894           if (zi.lt.0) zi=zi+boxzsize
1895 C define scaling factor for lipids
1896
1897 C        if (positi.le.0) positi=positi+boxzsize
1898 C        print *,i
1899 C first for peptide groups
1900 c for each residue check if it is in lipid or lipid water border area
1901        if ((zi.gt.bordlipbot)
1902      &.and.(zi.lt.bordliptop)) then
1903 C the energy transfer exist
1904         if (zi.lt.buflipbot) then
1905 C what fraction I am in
1906          fracinbuf=1.0d0-
1907      &        ((zi-bordlipbot)/lipbufthick)
1908 C lipbufthick is thickenes of lipid buffore
1909          sslipi=sscalelip(fracinbuf)
1910          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
1911         elseif (zi.gt.bufliptop) then
1912          fracinbuf=1.0d0-((bordliptop-zi)/lipbufthick)
1913          sslipi=sscalelip(fracinbuf)
1914          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
1915         else
1916          sslipi=1.0d0
1917          ssgradlipi=0.0
1918         endif
1919        else
1920          sslipi=0.0d0
1921          ssgradlipi=0.0
1922        endif
1923
1924         dxi=dc_norm(1,nres+i)
1925         dyi=dc_norm(2,nres+i)
1926         dzi=dc_norm(3,nres+i)
1927 c        dsci_inv=dsc_inv(itypi)
1928         dsci_inv=vbld_inv(i+nres)
1929 C
1930 C Calculate SC interaction energy.
1931 C
1932         do iint=1,nint_gr(i)
1933           do j=istart(i,iint),iend(i,iint)
1934             ind=ind+1
1935             itypj=iabs(itype(j))
1936             if (itypj.eq.ntyp1) cycle
1937 c            dscj_inv=dsc_inv(itypj)
1938             dscj_inv=vbld_inv(j+nres)
1939             sig0ij=sigma(itypi,itypj)
1940             r0ij=r0(itypi,itypj)
1941             chi1=chi(itypi,itypj)
1942             chi2=chi(itypj,itypi)
1943             chi12=chi1*chi2
1944             chip1=chip(itypi)
1945             chip2=chip(itypj)
1946             chip12=chip1*chip2
1947             alf1=alp(itypi)
1948             alf2=alp(itypj)
1949             alf12=0.5D0*(alf1+alf2)
1950 C For diagnostics only!!!
1951 c           chi1=0.0D0
1952 c           chi2=0.0D0
1953 c           chi12=0.0D0
1954 c           chip1=0.0D0
1955 c           chip2=0.0D0
1956 c           chip12=0.0D0
1957 c           alf1=0.0D0
1958 c           alf2=0.0D0
1959 c           alf12=0.0D0
1960 C            xj=c(1,nres+j)-xi
1961 C            yj=c(2,nres+j)-yi
1962 C            zj=c(3,nres+j)-zi
1963           xj=mod(xj,boxxsize)
1964           if (xj.lt.0) xj=xj+boxxsize
1965           yj=mod(yj,boxysize)
1966           if (yj.lt.0) yj=yj+boxysize
1967           zj=mod(zj,boxzsize)
1968           if (zj.lt.0) zj=zj+boxzsize
1969        if ((zj.gt.bordlipbot)
1970      &.and.(zj.lt.bordliptop)) then
1971 C the energy transfer exist
1972         if (zj.lt.buflipbot) then
1973 C what fraction I am in
1974          fracinbuf=1.0d0-
1975      &        ((zj-bordlipbot)/lipbufthick)
1976 C lipbufthick is thickenes of lipid buffore
1977          sslipj=sscalelip(fracinbuf)
1978          ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
1979         elseif (zj.gt.bufliptop) then
1980          fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
1981          sslipj=sscalelip(fracinbuf)
1982          ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
1983         else
1984          sslipj=1.0d0
1985          ssgradlipj=0.0
1986         endif
1987        else
1988          sslipj=0.0d0
1989          ssgradlipj=0.0
1990        endif
1991       aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
1992      &  +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1993       bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
1994      &  +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1995 C      if (aa.ne.aa_aq(itypi,itypj)) write(63,'2e10.5')
1996 C     &(aa-aa_aq(itypi,itypj)),(bb-bb_aq(itypi,itypj))
1997       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
1998       xj_safe=xj
1999       yj_safe=yj
2000       zj_safe=zj
2001       subchap=0
2002       do xshift=-1,1
2003       do yshift=-1,1
2004       do zshift=-1,1
2005           xj=xj_safe+xshift*boxxsize
2006           yj=yj_safe+yshift*boxysize
2007           zj=zj_safe+zshift*boxzsize
2008           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
2009           if(dist_temp.lt.dist_init) then
2010             dist_init=dist_temp
2011             xj_temp=xj
2012             yj_temp=yj
2013             zj_temp=zj
2014             subchap=1
2015           endif
2016        enddo
2017        enddo
2018        enddo
2019        if (subchap.eq.1) then
2020           xj=xj_temp-xi
2021           yj=yj_temp-yi
2022           zj=zj_temp-zi
2023        else
2024           xj=xj_safe-xi
2025           yj=yj_safe-yi
2026           zj=zj_safe-zi
2027        endif
2028             dxj=dc_norm(1,nres+j)
2029             dyj=dc_norm(2,nres+j)
2030             dzj=dc_norm(3,nres+j)
2031             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
2032             rij=dsqrt(rrij)
2033 C Calculate angle-dependent terms of energy and contributions to their
2034 C derivatives.
2035             call sc_angular
2036             sigsq=1.0D0/sigsq
2037             sig=sig0ij*dsqrt(sigsq)
2038             rij_shift=1.0D0/rij-sig+r0ij
2039 C I hate to put IF's in the loops, but here don't have another choice!!!!
2040             if (rij_shift.le.0.0D0) then
2041               evdw=1.0D20
2042               return
2043             endif
2044             sigder=-sig*sigsq
2045 c---------------------------------------------------------------
2046             rij_shift=1.0D0/rij_shift
2047             fac=rij_shift**expon
2048             e1=fac*fac*aa
2049             e2=fac*bb
2050             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
2051             eps2der=evdwij*eps3rt
2052             eps3der=evdwij*eps2rt
2053             fac_augm=rrij**expon
2054             e_augm=augm(itypi,itypj)*fac_augm
2055             evdwij=evdwij*eps2rt*eps3rt
2056             evdw=evdw+evdwij+e_augm
2057             if (lprn) then
2058             sigm=dabs(aa/bb)**(1.0D0/6.0D0)
2059             epsi=bb**2/aa
2060             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
2061      &        restyp(itypi),i,restyp(itypj),j,
2062      &        epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),
2063      &        chi1,chi2,chip1,chip2,
2064      &        eps1,eps2rt**2,eps3rt**2,
2065      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
2066      &        evdwij+e_augm
2067             endif
2068 C Calculate gradient components.
2069             e1=e1*eps1*eps2rt**2*eps3rt**2
2070             fac=-expon*(e1+evdwij)*rij_shift
2071             sigder=fac*sigder
2072             fac=rij*fac-2*expon*rrij*e_augm
2073             fac=fac+evdwij/sss*sssgrad/sigma(itypi,itypj)*rij
2074 C Calculate the radial part of the gradient
2075             gg(1)=xj*fac
2076             gg(2)=yj*fac
2077             gg(3)=zj*fac
2078 C Calculate angular part of the gradient.
2079             call sc_grad
2080           enddo      ! j
2081         enddo        ! iint
2082       enddo          ! i
2083       end
2084 C-----------------------------------------------------------------------------
2085       subroutine sc_angular
2086 C Calculate eps1,eps2,eps3,sigma, and parts of their derivatives in om1,om2,
2087 C om12. Called by ebp, egb, and egbv.
2088       implicit none
2089       include 'COMMON.CALC'
2090       include 'COMMON.IOUNITS'
2091       erij(1)=xj*rij
2092       erij(2)=yj*rij
2093       erij(3)=zj*rij
2094       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
2095       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
2096       om12=dxi*dxj+dyi*dyj+dzi*dzj
2097       chiom12=chi12*om12
2098 C Calculate eps1(om12) and its derivative in om12
2099       faceps1=1.0D0-om12*chiom12
2100       faceps1_inv=1.0D0/faceps1
2101       eps1=dsqrt(faceps1_inv)
2102 C Following variable is eps1*deps1/dom12
2103       eps1_om12=faceps1_inv*chiom12
2104 c diagnostics only
2105 c      faceps1_inv=om12
2106 c      eps1=om12
2107 c      eps1_om12=1.0d0
2108 c      write (iout,*) "om12",om12," eps1",eps1
2109 C Calculate sigma(om1,om2,om12) and the derivatives of sigma**2 in om1,om2,
2110 C and om12.
2111       om1om2=om1*om2
2112       chiom1=chi1*om1
2113       chiom2=chi2*om2
2114       facsig=om1*chiom1+om2*chiom2-2.0D0*om1om2*chiom12
2115       sigsq=1.0D0-facsig*faceps1_inv
2116       sigsq_om1=(chiom1-chiom12*om2)*faceps1_inv
2117       sigsq_om2=(chiom2-chiom12*om1)*faceps1_inv
2118       sigsq_om12=-chi12*(om1om2*faceps1-om12*facsig)*faceps1_inv**2
2119 c diagnostics only
2120 c      sigsq=1.0d0
2121 c      sigsq_om1=0.0d0
2122 c      sigsq_om2=0.0d0
2123 c      sigsq_om12=0.0d0
2124 c      write (iout,*) "chiom1",chiom1," chiom2",chiom2," chiom12",chiom12
2125 c      write (iout,*) "faceps1",faceps1," faceps1_inv",faceps1_inv,
2126 c     &    " eps1",eps1
2127 C Calculate eps2 and its derivatives in om1, om2, and om12.
2128       chipom1=chip1*om1
2129       chipom2=chip2*om2
2130       chipom12=chip12*om12
2131       facp=1.0D0-om12*chipom12
2132       facp_inv=1.0D0/facp
2133       facp1=om1*chipom1+om2*chipom2-2.0D0*om1om2*chipom12
2134 c      write (iout,*) "chipom1",chipom1," chipom2",chipom2,
2135 c     &  " chipom12",chipom12," facp",facp," facp_inv",facp_inv
2136 C Following variable is the square root of eps2
2137       eps2rt=1.0D0-facp1*facp_inv
2138 C Following three variables are the derivatives of the square root of eps
2139 C in om1, om2, and om12.
2140       eps2rt_om1=-4.0D0*(chipom1-chipom12*om2)*facp_inv
2141       eps2rt_om2=-4.0D0*(chipom2-chipom12*om1)*facp_inv
2142       eps2rt_om12=4.0D0*chip12*(om1om2*facp-om12*facp1)*facp_inv**2
2143 C Evaluate the "asymmetric" factor in the VDW constant, eps3
2144       eps3rt=1.0D0-alf1*om1+alf2*om2-alf12*om12
2145 c      write (iout,*) "eps2rt",eps2rt," eps3rt",eps3rt
2146 c      write (iout,*) "eps2rt_om1",eps2rt_om1," eps2rt_om2",eps2rt_om2,
2147 c     &  " eps2rt_om12",eps2rt_om12
2148 C Calculate whole angle-dependent part of epsilon and contributions
2149 C to its derivatives
2150       return
2151       end
2152 C----------------------------------------------------------------------------
2153       subroutine sc_grad
2154       implicit real*8 (a-h,o-z)
2155       include 'DIMENSIONS'
2156       include 'COMMON.CHAIN'
2157       include 'COMMON.DERIV'
2158       include 'COMMON.CALC'
2159       include 'COMMON.IOUNITS'
2160       double precision dcosom1(3),dcosom2(3)
2161 cc      print *,'sss=',sss
2162       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
2163       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
2164       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12
2165      &     -2.0D0*alf12*eps3der+sigder*sigsq_om12
2166 c diagnostics only
2167 c      eom1=0.0d0
2168 c      eom2=0.0d0
2169 c      eom12=evdwij*eps1_om12
2170 c end diagnostics
2171 c      write (iout,*) "eps2der",eps2der," eps3der",eps3der,
2172 c     &  " sigder",sigder
2173 c      write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12
2174 c      write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12
2175       do k=1,3
2176         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
2177         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
2178       enddo
2179       do k=1,3
2180         gg(k)=(gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k))*sss
2181       enddo
2182 c      write (iout,*) "gg",(gg(k),k=1,3)
2183       do k=1,3
2184         gvdwx(k,i)=gvdwx(k,i)-gg(k)+gg_lipi(k)
2185      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
2186      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv*sss
2187         gvdwx(k,j)=gvdwx(k,j)+gg(k)+gg_lipj(k)
2188      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
2189      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv*sss
2190 c        write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
2191 c     &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
2192 c        write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
2193 c     &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
2194       enddo
2195 C
2196 C Calculate the components of the gradient in DC and X
2197 C
2198 cgrad      do k=i,j-1
2199 cgrad        do l=1,3
2200 cgrad          gvdwc(l,k)=gvdwc(l,k)+gg(l)
2201 cgrad        enddo
2202 cgrad      enddo
2203       do l=1,3
2204         gvdwc(l,i)=gvdwc(l,i)-gg(l)+gg_lipi(l)
2205         gvdwc(l,j)=gvdwc(l,j)+gg(l)+gg_lipj(l)
2206       enddo
2207       return
2208       end
2209 C-----------------------------------------------------------------------
2210       subroutine e_softsphere(evdw)
2211 C
2212 C This subroutine calculates the interaction energy of nonbonded side chains
2213 C assuming the LJ potential of interaction.
2214 C
2215       implicit real*8 (a-h,o-z)
2216       include 'DIMENSIONS'
2217       parameter (accur=1.0d-10)
2218       include 'COMMON.GEO'
2219       include 'COMMON.VAR'
2220       include 'COMMON.LOCAL'
2221       include 'COMMON.CHAIN'
2222       include 'COMMON.DERIV'
2223       include 'COMMON.INTERACT'
2224       include 'COMMON.TORSION'
2225       include 'COMMON.SBRIDGE'
2226       include 'COMMON.NAMES'
2227       include 'COMMON.IOUNITS'
2228       include 'COMMON.CONTACTS'
2229       dimension gg(3)
2230 cd    print *,'Entering Esoft_sphere nnt=',nnt,' nct=',nct
2231       evdw=0.0D0
2232       do i=iatsc_s,iatsc_e
2233         itypi=iabs(itype(i))
2234         if (itypi.eq.ntyp1) cycle
2235         itypi1=iabs(itype(i+1))
2236         xi=c(1,nres+i)
2237         yi=c(2,nres+i)
2238         zi=c(3,nres+i)
2239 C
2240 C Calculate SC interaction energy.
2241 C
2242         do iint=1,nint_gr(i)
2243 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
2244 cd   &                  'iend=',iend(i,iint)
2245           do j=istart(i,iint),iend(i,iint)
2246             itypj=iabs(itype(j))
2247             if (itypj.eq.ntyp1) cycle
2248             xj=c(1,nres+j)-xi
2249             yj=c(2,nres+j)-yi
2250             zj=c(3,nres+j)-zi
2251             rij=xj*xj+yj*yj+zj*zj
2252 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
2253             r0ij=r0(itypi,itypj)
2254             r0ijsq=r0ij*r0ij
2255 c            print *,i,j,r0ij,dsqrt(rij)
2256             if (rij.lt.r0ijsq) then
2257               evdwij=0.25d0*(rij-r0ijsq)**2
2258               fac=rij-r0ijsq
2259             else
2260               evdwij=0.0d0
2261               fac=0.0d0
2262             endif
2263             evdw=evdw+evdwij
2264 C
2265 C Calculate the components of the gradient in DC and X
2266 C
2267             gg(1)=xj*fac
2268             gg(2)=yj*fac
2269             gg(3)=zj*fac
2270             do k=1,3
2271               gvdwx(k,i)=gvdwx(k,i)-gg(k)
2272               gvdwx(k,j)=gvdwx(k,j)+gg(k)
2273               gvdwc(k,i)=gvdwc(k,i)-gg(k)
2274               gvdwc(k,j)=gvdwc(k,j)+gg(k)
2275             enddo
2276 cgrad            do k=i,j-1
2277 cgrad              do l=1,3
2278 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
2279 cgrad              enddo
2280 cgrad            enddo
2281           enddo ! j
2282         enddo ! iint
2283       enddo ! i
2284       return
2285       end
2286 C--------------------------------------------------------------------------
2287       subroutine eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,
2288      &              eello_turn4)
2289 C
2290 C Soft-sphere potential of p-p interaction
2291 C
2292       implicit real*8 (a-h,o-z)
2293       include 'DIMENSIONS'
2294       include 'COMMON.CONTROL'
2295       include 'COMMON.IOUNITS'
2296       include 'COMMON.GEO'
2297       include 'COMMON.VAR'
2298       include 'COMMON.LOCAL'
2299       include 'COMMON.CHAIN'
2300       include 'COMMON.DERIV'
2301       include 'COMMON.INTERACT'
2302       include 'COMMON.CONTACTS'
2303       include 'COMMON.TORSION'
2304       include 'COMMON.VECTORS'
2305       include 'COMMON.FFIELD'
2306       dimension ggg(3)
2307 C      write(iout,*) 'In EELEC_soft_sphere'
2308       ees=0.0D0
2309       evdw1=0.0D0
2310       eel_loc=0.0d0
2311       eello_turn3=0.0d0
2312       eello_turn4=0.0d0
2313       ind=0
2314       do i=iatel_s,iatel_e
2315         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
2316         dxi=dc(1,i)
2317         dyi=dc(2,i)
2318         dzi=dc(3,i)
2319         xmedi=c(1,i)+0.5d0*dxi
2320         ymedi=c(2,i)+0.5d0*dyi
2321         zmedi=c(3,i)+0.5d0*dzi
2322           xmedi=mod(xmedi,boxxsize)
2323           if (xmedi.lt.0) xmedi=xmedi+boxxsize
2324           ymedi=mod(ymedi,boxysize)
2325           if (ymedi.lt.0) ymedi=ymedi+boxysize
2326           zmedi=mod(zmedi,boxzsize)
2327           if (zmedi.lt.0) zmedi=zmedi+boxzsize
2328         num_conti=0
2329 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
2330         do j=ielstart(i),ielend(i)
2331           if (itype(j).eq.ntyp1 .or. itype(j+1).eq.ntyp1) cycle
2332           ind=ind+1
2333           iteli=itel(i)
2334           itelj=itel(j)
2335           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
2336           r0ij=rpp(iteli,itelj)
2337           r0ijsq=r0ij*r0ij
2338           dxj=dc(1,j)
2339           dyj=dc(2,j)
2340           dzj=dc(3,j)
2341           xj=c(1,j)+0.5D0*dxj
2342           yj=c(2,j)+0.5D0*dyj
2343           zj=c(3,j)+0.5D0*dzj
2344           xj=mod(xj,boxxsize)
2345           if (xj.lt.0) xj=xj+boxxsize
2346           yj=mod(yj,boxysize)
2347           if (yj.lt.0) yj=yj+boxysize
2348           zj=mod(zj,boxzsize)
2349           if (zj.lt.0) zj=zj+boxzsize
2350       dist_init=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
2351       xj_safe=xj
2352       yj_safe=yj
2353       zj_safe=zj
2354       isubchap=0
2355       do xshift=-1,1
2356       do yshift=-1,1
2357       do zshift=-1,1
2358           xj=xj_safe+xshift*boxxsize
2359           yj=yj_safe+yshift*boxysize
2360           zj=zj_safe+zshift*boxzsize
2361           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
2362           if(dist_temp.lt.dist_init) then
2363             dist_init=dist_temp
2364             xj_temp=xj
2365             yj_temp=yj
2366             zj_temp=zj
2367             isubchap=1
2368           endif
2369        enddo
2370        enddo
2371        enddo
2372        if (isubchap.eq.1) then
2373           xj=xj_temp-xmedi
2374           yj=yj_temp-ymedi
2375           zj=zj_temp-zmedi
2376        else
2377           xj=xj_safe-xmedi
2378           yj=yj_safe-ymedi
2379           zj=zj_safe-zmedi
2380        endif
2381           rij=xj*xj+yj*yj+zj*zj
2382             sss=sscale(sqrt(rij))
2383             sssgrad=sscagrad(sqrt(rij))
2384           if (rij.lt.r0ijsq) then
2385             evdw1ij=0.25d0*(rij-r0ijsq)**2
2386             fac=rij-r0ijsq
2387           else
2388             evdw1ij=0.0d0
2389             fac=0.0d0
2390           endif
2391           evdw1=evdw1+evdw1ij*sss
2392 C
2393 C Calculate contributions to the Cartesian gradient.
2394 C
2395           ggg(1)=fac*xj*sssgrad
2396           ggg(2)=fac*yj*sssgrad
2397           ggg(3)=fac*zj*sssgrad
2398           do k=1,3
2399             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
2400             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
2401           enddo
2402 *
2403 * Loop over residues i+1 thru j-1.
2404 *
2405 cgrad          do k=i+1,j-1
2406 cgrad            do l=1,3
2407 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
2408 cgrad            enddo
2409 cgrad          enddo
2410         enddo ! j
2411       enddo   ! i
2412 cgrad      do i=nnt,nct-1
2413 cgrad        do k=1,3
2414 cgrad          gelc(k,i)=gelc(k,i)+0.5d0*gelc(k,i)
2415 cgrad        enddo
2416 cgrad        do j=i+1,nct-1
2417 cgrad          do k=1,3
2418 cgrad            gelc(k,i)=gelc(k,i)+gelc(k,j)
2419 cgrad          enddo
2420 cgrad        enddo
2421 cgrad      enddo
2422       return
2423       end
2424 c------------------------------------------------------------------------------
2425       subroutine vec_and_deriv
2426       implicit real*8 (a-h,o-z)
2427       include 'DIMENSIONS'
2428 #ifdef MPI
2429       include 'mpif.h'
2430 #endif
2431       include 'COMMON.IOUNITS'
2432       include 'COMMON.GEO'
2433       include 'COMMON.VAR'
2434       include 'COMMON.LOCAL'
2435       include 'COMMON.CHAIN'
2436       include 'COMMON.VECTORS'
2437       include 'COMMON.SETUP'
2438       include 'COMMON.TIME1'
2439       dimension uyder(3,3,2),uzder(3,3,2),vbld_inv_temp(2)
2440 C Compute the local reference systems. For reference system (i), the
2441 C X-axis points from CA(i) to CA(i+1), the Y axis is in the
2442 C CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
2443 #ifdef PARVEC
2444       do i=ivec_start,ivec_end
2445 #else
2446       do i=1,nres-1
2447 #endif
2448           if (i.eq.nres-1) then
2449 C Case of the last full residue
2450 C Compute the Z-axis
2451             call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
2452             costh=dcos(pi-theta(nres))
2453             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2454             do k=1,3
2455               uz(k,i)=fac*uz(k,i)
2456             enddo
2457 C Compute the derivatives of uz
2458             uzder(1,1,1)= 0.0d0
2459             uzder(2,1,1)=-dc_norm(3,i-1)
2460             uzder(3,1,1)= dc_norm(2,i-1)
2461             uzder(1,2,1)= dc_norm(3,i-1)
2462             uzder(2,2,1)= 0.0d0
2463             uzder(3,2,1)=-dc_norm(1,i-1)
2464             uzder(1,3,1)=-dc_norm(2,i-1)
2465             uzder(2,3,1)= dc_norm(1,i-1)
2466             uzder(3,3,1)= 0.0d0
2467             uzder(1,1,2)= 0.0d0
2468             uzder(2,1,2)= dc_norm(3,i)
2469             uzder(3,1,2)=-dc_norm(2,i)
2470             uzder(1,2,2)=-dc_norm(3,i)
2471             uzder(2,2,2)= 0.0d0
2472             uzder(3,2,2)= dc_norm(1,i)
2473             uzder(1,3,2)= dc_norm(2,i)
2474             uzder(2,3,2)=-dc_norm(1,i)
2475             uzder(3,3,2)= 0.0d0
2476 C Compute the Y-axis
2477             facy=fac
2478             do k=1,3
2479               uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
2480             enddo
2481 C Compute the derivatives of uy
2482             do j=1,3
2483               do k=1,3
2484                 uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i)
2485      &                        -dc_norm(k,i)*dc_norm(j,i-1)
2486                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2487               enddo
2488               uyder(j,j,1)=uyder(j,j,1)-costh
2489               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2490             enddo
2491             do j=1,2
2492               do k=1,3
2493                 do l=1,3
2494                   uygrad(l,k,j,i)=uyder(l,k,j)
2495                   uzgrad(l,k,j,i)=uzder(l,k,j)
2496                 enddo
2497               enddo
2498             enddo
2499             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2500             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2501             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2502             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2503           else
2504 C Other residues
2505 C Compute the Z-axis
2506             call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
2507             costh=dcos(pi-theta(i+2))
2508             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2509             do k=1,3
2510               uz(k,i)=fac*uz(k,i)
2511             enddo
2512 C Compute the derivatives of uz
2513             uzder(1,1,1)= 0.0d0
2514             uzder(2,1,1)=-dc_norm(3,i+1)
2515             uzder(3,1,1)= dc_norm(2,i+1)
2516             uzder(1,2,1)= dc_norm(3,i+1)
2517             uzder(2,2,1)= 0.0d0
2518             uzder(3,2,1)=-dc_norm(1,i+1)
2519             uzder(1,3,1)=-dc_norm(2,i+1)
2520             uzder(2,3,1)= dc_norm(1,i+1)
2521             uzder(3,3,1)= 0.0d0
2522             uzder(1,1,2)= 0.0d0
2523             uzder(2,1,2)= dc_norm(3,i)
2524             uzder(3,1,2)=-dc_norm(2,i)
2525             uzder(1,2,2)=-dc_norm(3,i)
2526             uzder(2,2,2)= 0.0d0
2527             uzder(3,2,2)= dc_norm(1,i)
2528             uzder(1,3,2)= dc_norm(2,i)
2529             uzder(2,3,2)=-dc_norm(1,i)
2530             uzder(3,3,2)= 0.0d0
2531 C Compute the Y-axis
2532             facy=fac
2533             do k=1,3
2534               uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
2535             enddo
2536 C Compute the derivatives of uy
2537             do j=1,3
2538               do k=1,3
2539                 uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i)
2540      &                        -dc_norm(k,i)*dc_norm(j,i+1)
2541                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2542               enddo
2543               uyder(j,j,1)=uyder(j,j,1)-costh
2544               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2545             enddo
2546             do j=1,2
2547               do k=1,3
2548                 do l=1,3
2549                   uygrad(l,k,j,i)=uyder(l,k,j)
2550                   uzgrad(l,k,j,i)=uzder(l,k,j)
2551                 enddo
2552               enddo
2553             enddo
2554             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2555             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2556             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2557             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2558           endif
2559       enddo
2560       do i=1,nres-1
2561         vbld_inv_temp(1)=vbld_inv(i+1)
2562         if (i.lt.nres-1) then
2563           vbld_inv_temp(2)=vbld_inv(i+2)
2564           else
2565           vbld_inv_temp(2)=vbld_inv(i)
2566           endif
2567         do j=1,2
2568           do k=1,3
2569             do l=1,3
2570               uygrad(l,k,j,i)=vbld_inv_temp(j)*uygrad(l,k,j,i)
2571               uzgrad(l,k,j,i)=vbld_inv_temp(j)*uzgrad(l,k,j,i)
2572             enddo
2573           enddo
2574         enddo
2575       enddo
2576 #if defined(PARVEC) && defined(MPI)
2577       if (nfgtasks1.gt.1) then
2578         time00=MPI_Wtime()
2579 c        print *,"Processor",fg_rank1,kolor1," ivec_start",ivec_start,
2580 c     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks1-1),
2581 c     &   " ivec_count",(ivec_count(i),i=0,nfgtasks1-1)
2582         call MPI_Allgatherv(uy(1,ivec_start),ivec_count(fg_rank1),
2583      &   MPI_UYZ,uy(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
2584      &   FG_COMM1,IERR)
2585         call MPI_Allgatherv(uz(1,ivec_start),ivec_count(fg_rank1),
2586      &   MPI_UYZ,uz(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
2587      &   FG_COMM1,IERR)
2588         call MPI_Allgatherv(uygrad(1,1,1,ivec_start),
2589      &   ivec_count(fg_rank1),MPI_UYZGRAD,uygrad(1,1,1,1),ivec_count(0),
2590      &   ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2591         call MPI_Allgatherv(uzgrad(1,1,1,ivec_start),
2592      &   ivec_count(fg_rank1),MPI_UYZGRAD,uzgrad(1,1,1,1),ivec_count(0),
2593      &   ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2594         time_gather=time_gather+MPI_Wtime()-time00
2595       endif
2596 c      if (fg_rank.eq.0) then
2597 c        write (iout,*) "Arrays UY and UZ"
2598 c        do i=1,nres-1
2599 c          write (iout,'(i5,3f10.5,5x,3f10.5)') i,(uy(k,i),k=1,3),
2600 c     &     (uz(k,i),k=1,3)
2601 c        enddo
2602 c      endif
2603 #endif
2604       return
2605       end
2606 C-----------------------------------------------------------------------------
2607       subroutine check_vecgrad
2608       implicit real*8 (a-h,o-z)
2609       include 'DIMENSIONS'
2610       include 'COMMON.IOUNITS'
2611       include 'COMMON.GEO'
2612       include 'COMMON.VAR'
2613       include 'COMMON.LOCAL'
2614       include 'COMMON.CHAIN'
2615       include 'COMMON.VECTORS'
2616       dimension uygradt(3,3,2,maxres),uzgradt(3,3,2,maxres)
2617       dimension uyt(3,maxres),uzt(3,maxres)
2618       dimension uygradn(3,3,2),uzgradn(3,3,2),erij(3)
2619       double precision delta /1.0d-7/
2620       call vec_and_deriv
2621 cd      do i=1,nres
2622 crc          write(iout,'(2i5,2(3f10.5,5x))') i,1,dc_norm(:,i)
2623 crc          write(iout,'(2i5,2(3f10.5,5x))') i,2,uy(:,i)
2624 crc          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,uz(:,i)
2625 cd          write(iout,'(2i5,2(3f10.5,5x))') i,1,
2626 cd     &     (dc_norm(if90,i),if90=1,3)
2627 cd          write(iout,'(2i5,2(3f10.5,5x))') i,2,(uy(if90,i),if90=1,3)
2628 cd          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,(uz(if90,i),if90=1,3)
2629 cd          write(iout,'(a)')
2630 cd      enddo
2631       do i=1,nres
2632         do j=1,2
2633           do k=1,3
2634             do l=1,3
2635               uygradt(l,k,j,i)=uygrad(l,k,j,i)
2636               uzgradt(l,k,j,i)=uzgrad(l,k,j,i)
2637             enddo
2638           enddo
2639         enddo
2640       enddo
2641       call vec_and_deriv
2642       do i=1,nres
2643         do j=1,3
2644           uyt(j,i)=uy(j,i)
2645           uzt(j,i)=uz(j,i)
2646         enddo
2647       enddo
2648       do i=1,nres
2649 cd        write (iout,*) 'i=',i
2650         do k=1,3
2651           erij(k)=dc_norm(k,i)
2652         enddo
2653         do j=1,3
2654           do k=1,3
2655             dc_norm(k,i)=erij(k)
2656           enddo
2657           dc_norm(j,i)=dc_norm(j,i)+delta
2658 c          fac=dsqrt(scalar(dc_norm(1,i),dc_norm(1,i)))
2659 c          do k=1,3
2660 c            dc_norm(k,i)=dc_norm(k,i)/fac
2661 c          enddo
2662 c          write (iout,*) (dc_norm(k,i),k=1,3)
2663 c          write (iout,*) (erij(k),k=1,3)
2664           call vec_and_deriv
2665           do k=1,3
2666             uygradn(k,j,1)=(uy(k,i)-uyt(k,i))/delta
2667             uygradn(k,j,2)=(uy(k,i-1)-uyt(k,i-1))/delta
2668             uzgradn(k,j,1)=(uz(k,i)-uzt(k,i))/delta
2669             uzgradn(k,j,2)=(uz(k,i-1)-uzt(k,i-1))/delta
2670           enddo
2671 c          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2672 c     &      j,(uzgradt(k,j,1,i),k=1,3),(uzgradn(k,j,1),k=1,3),
2673 c     &      (uzgradt(k,j,2,i-1),k=1,3),(uzgradn(k,j,2),k=1,3)
2674         enddo
2675         do k=1,3
2676           dc_norm(k,i)=erij(k)
2677         enddo
2678 cd        do k=1,3
2679 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2680 cd     &      k,(uygradt(k,l,1,i),l=1,3),(uygradn(k,l,1),l=1,3),
2681 cd     &      (uygradt(k,l,2,i-1),l=1,3),(uygradn(k,l,2),l=1,3)
2682 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2683 cd     &      k,(uzgradt(k,l,1,i),l=1,3),(uzgradn(k,l,1),l=1,3),
2684 cd     &      (uzgradt(k,l,2,i-1),l=1,3),(uzgradn(k,l,2),l=1,3)
2685 cd          write (iout,'(a)')
2686 cd        enddo
2687       enddo
2688       return
2689       end
2690 C--------------------------------------------------------------------------
2691       subroutine set_matrices
2692       implicit real*8 (a-h,o-z)
2693       include 'DIMENSIONS'
2694 #ifdef MPI
2695       include "mpif.h"
2696       include "COMMON.SETUP"
2697       integer IERR
2698       integer status(MPI_STATUS_SIZE)
2699 #endif
2700       include 'COMMON.IOUNITS'
2701       include 'COMMON.GEO'
2702       include 'COMMON.VAR'
2703       include 'COMMON.LOCAL'
2704       include 'COMMON.CHAIN'
2705       include 'COMMON.DERIV'
2706       include 'COMMON.INTERACT'
2707       include 'COMMON.CONTACTS'
2708       include 'COMMON.TORSION'
2709       include 'COMMON.VECTORS'
2710       include 'COMMON.FFIELD'
2711       double precision auxvec(2),auxmat(2,2)
2712 C
2713 C Compute the virtual-bond-torsional-angle dependent quantities needed
2714 C to calculate the el-loc multibody terms of various order.
2715 C
2716 c      write(iout,*) 'nphi=',nphi,nres
2717 #ifdef PARMAT
2718       do i=ivec_start+2,ivec_end+2
2719 #else
2720       do i=3,nres+1
2721 #endif
2722 #ifdef NEWCORR
2723         if (i.gt. nnt+2 .and. i.lt.nct+2) then
2724           iti = itortyp(itype(i-2))
2725         else
2726           iti=ntortyp+1
2727         endif
2728 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2729         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2730           iti1 = itortyp(itype(i-1))
2731         else
2732           iti1=ntortyp+1
2733         endif
2734 c        write(iout,*),i
2735         b1(1,i-2)=bnew1(1,1,iti)*dsin(theta(i-1)/2.0)
2736      &           +bnew1(2,1,iti)*dsin(theta(i-1))
2737      &           +bnew1(3,1,iti)*dcos(theta(i-1)/2.0)
2738         gtb1(1,i-2)=bnew1(1,1,iti)*dcos(theta(i-1)/2.0d0)/2.0d0
2739      &             +bnew1(2,1,iti)*dcos(theta(i-1))
2740      &             -bnew1(3,1,iti)*dsin(theta(i-1)/2.0d0)/2.0d0
2741 c     &           +bnew1(3,1,iti)*sin(alpha(i))*cos(beta(i))
2742 c     &*(cos(theta(i)/2.0)
2743         b2(1,i-2)=bnew2(1,1,iti)*dsin(theta(i-1)/2.0)
2744      &           +bnew2(2,1,iti)*dsin(theta(i-1))
2745      &           +bnew2(3,1,iti)*dcos(theta(i-1)/2.0)
2746 c     &           +bnew2(3,1,iti)*sin(alpha(i))*cos(beta(i))
2747 c     &*(cos(theta(i)/2.0)
2748         gtb2(1,i-2)=bnew2(1,1,iti)*dcos(theta(i-1)/2.0d0)/2.0d0
2749      &             +bnew2(2,1,iti)*dcos(theta(i-1))
2750      &             -bnew2(3,1,iti)*dsin(theta(i-1)/2.0d0)/2.0d0
2751 c        if (ggb1(1,i).eq.0.0d0) then
2752 c        write(iout,*) 'i=',i,ggb1(1,i),
2753 c     &bnew1(1,1,iti)*cos(theta(i)/2.0)/2.0,
2754 c     &bnew1(2,1,iti)*cos(theta(i)),
2755 c     &bnew1(3,1,iti)*sin(theta(i)/2.0)/2.0
2756 c        endif
2757         b1(2,i-2)=bnew1(1,2,iti)
2758         gtb1(2,i-2)=0.0
2759         b2(2,i-2)=bnew2(1,2,iti)
2760         gtb2(2,i-2)=0.0
2761         EE(1,1,i-2)=eenew(1,iti)*dcos(theta(i-1))
2762         EE(1,2,i-2)=eeold(1,2,iti)
2763         EE(2,1,i-2)=eeold(2,1,iti)
2764         EE(2,2,i-2)=eeold(2,2,iti)
2765         gtEE(1,1,i-2)=-eenew(1,iti)*dsin(theta(i-1))
2766         gtEE(1,2,i-2)=0.0d0
2767         gtEE(2,2,i-2)=0.0d0
2768         gtEE(2,1,i-2)=0.0d0
2769 c        EE(2,2,iti)=0.0d0
2770 c        EE(1,2,iti)=0.5d0*eenew(1,iti)
2771 c        EE(2,1,iti)=0.5d0*eenew(1,iti)
2772 c        b1(2,iti)=bnew1(1,2,iti)*sin(alpha(i))*sin(beta(i))
2773 c        b2(2,iti)=bnew2(1,2,iti)*sin(alpha(i))*sin(beta(i))
2774        b1tilde(1,i-2)=b1(1,i-2)
2775        b1tilde(2,i-2)=-b1(2,i-2)
2776        b2tilde(1,i-2)=b2(1,i-2)
2777        b2tilde(2,i-2)=-b2(2,i-2)
2778 c       write (iout,*) 'i=',i-2,gtb1(2,i-2),gtb1(1,i-2)
2779 c       write(iout,*)  'b1=',b1(1,i-2)
2780 c       write (iout,*) 'theta=', theta(i-1)
2781        enddo
2782 #else
2783         if (i.gt. nnt+2 .and. i.lt.nct+2) then
2784           iti = itortyp(itype(i-2))
2785         else
2786           iti=ntortyp+1
2787         endif
2788 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2789         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2790           iti1 = itortyp(itype(i-1))
2791         else
2792           iti1=ntortyp+1
2793         endif
2794         b1(1,i-2)=b(3,iti)
2795         b1(2,i-2)=b(5,iti)
2796         b2(1,i-2)=b(2,iti)
2797         b2(2,i-2)=b(4,iti)
2798        b1tilde(1,i-2)=b1(1,i-2)
2799        b1tilde(2,i-2)=-b1(2,i-2)
2800        b2tilde(1,i-2)=b2(1,i-2)
2801        b2tilde(2,i-2)=-b2(2,i-2)
2802         EE(1,2,i-2)=eeold(1,2,iti)
2803         EE(2,1,i-2)=eeold(2,1,iti)
2804         EE(2,2,i-2)=eeold(2,2,iti)
2805         EE(1,1,i-2)=eeold(1,1,iti)
2806       enddo
2807 #endif
2808 #ifdef PARMAT
2809       do i=ivec_start+2,ivec_end+2
2810 #else
2811       do i=3,nres+1
2812 #endif
2813         if (i .lt. nres+1) then
2814           sin1=dsin(phi(i))
2815           cos1=dcos(phi(i))
2816           sintab(i-2)=sin1
2817           costab(i-2)=cos1
2818           obrot(1,i-2)=cos1
2819           obrot(2,i-2)=sin1
2820           sin2=dsin(2*phi(i))
2821           cos2=dcos(2*phi(i))
2822           sintab2(i-2)=sin2
2823           costab2(i-2)=cos2
2824           obrot2(1,i-2)=cos2
2825           obrot2(2,i-2)=sin2
2826           Ug(1,1,i-2)=-cos1
2827           Ug(1,2,i-2)=-sin1
2828           Ug(2,1,i-2)=-sin1
2829           Ug(2,2,i-2)= cos1
2830           Ug2(1,1,i-2)=-cos2
2831           Ug2(1,2,i-2)=-sin2
2832           Ug2(2,1,i-2)=-sin2
2833           Ug2(2,2,i-2)= cos2
2834         else
2835           costab(i-2)=1.0d0
2836           sintab(i-2)=0.0d0
2837           obrot(1,i-2)=1.0d0
2838           obrot(2,i-2)=0.0d0
2839           obrot2(1,i-2)=0.0d0
2840           obrot2(2,i-2)=0.0d0
2841           Ug(1,1,i-2)=1.0d0
2842           Ug(1,2,i-2)=0.0d0
2843           Ug(2,1,i-2)=0.0d0
2844           Ug(2,2,i-2)=1.0d0
2845           Ug2(1,1,i-2)=0.0d0
2846           Ug2(1,2,i-2)=0.0d0
2847           Ug2(2,1,i-2)=0.0d0
2848           Ug2(2,2,i-2)=0.0d0
2849         endif
2850         if (i .gt. 3 .and. i .lt. nres+1) then
2851           obrot_der(1,i-2)=-sin1
2852           obrot_der(2,i-2)= cos1
2853           Ugder(1,1,i-2)= sin1
2854           Ugder(1,2,i-2)=-cos1
2855           Ugder(2,1,i-2)=-cos1
2856           Ugder(2,2,i-2)=-sin1
2857           dwacos2=cos2+cos2
2858           dwasin2=sin2+sin2
2859           obrot2_der(1,i-2)=-dwasin2
2860           obrot2_der(2,i-2)= dwacos2
2861           Ug2der(1,1,i-2)= dwasin2
2862           Ug2der(1,2,i-2)=-dwacos2
2863           Ug2der(2,1,i-2)=-dwacos2
2864           Ug2der(2,2,i-2)=-dwasin2
2865         else
2866           obrot_der(1,i-2)=0.0d0
2867           obrot_der(2,i-2)=0.0d0
2868           Ugder(1,1,i-2)=0.0d0
2869           Ugder(1,2,i-2)=0.0d0
2870           Ugder(2,1,i-2)=0.0d0
2871           Ugder(2,2,i-2)=0.0d0
2872           obrot2_der(1,i-2)=0.0d0
2873           obrot2_der(2,i-2)=0.0d0
2874           Ug2der(1,1,i-2)=0.0d0
2875           Ug2der(1,2,i-2)=0.0d0
2876           Ug2der(2,1,i-2)=0.0d0
2877           Ug2der(2,2,i-2)=0.0d0
2878         endif
2879 c        if (i.gt. iatel_s+2 .and. i.lt.iatel_e+5) then
2880         if (i.gt. nnt+2 .and. i.lt.nct+2) then
2881           iti = itortyp(itype(i-2))
2882         else
2883           iti=ntortyp
2884         endif
2885 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2886         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2887           iti1 = itortyp(itype(i-1))
2888         else
2889           iti1=ntortyp
2890         endif
2891 cd        write (iout,*) '*******i',i,' iti1',iti
2892 cd        write (iout,*) 'b1',b1(:,iti)
2893 cd        write (iout,*) 'b2',b2(:,iti)
2894 cd        write (iout,*) 'Ug',Ug(:,:,i-2)
2895 c        if (i .gt. iatel_s+2) then
2896         if (i .gt. nnt+2) then
2897           call matvec2(Ug(1,1,i-2),b2(1,i-2),Ub2(1,i-2))
2898 #ifdef NEWCORR
2899           call matvec2(Ug(1,1,i-2),gtb2(1,i-2),gUb2(1,i-2))
2900 c          write (iout,*) Ug(1,1,i-2),gtb2(1,i-2),gUb2(1,i-2),"chuj"
2901 #endif
2902 c          write(iout,*) "co jest kurwa", iti, EE(1,1,iti),EE(2,1,iti),
2903 c     &    EE(1,2,iti),EE(2,2,iti)
2904           call matmat2(EE(1,1,i-2),Ug(1,1,i-2),EUg(1,1,i-2))
2905           call matmat2(gtEE(1,1,i-2),Ug(1,1,i-2),gtEUg(1,1,i-2))
2906 c          write(iout,*) "Macierz EUG",
2907 c     &    eug(1,1,i-2),eug(1,2,i-2),eug(2,1,i-2),
2908 c     &    eug(2,2,i-2)
2909           if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2910      &    then
2911           call matmat2(CC(1,1,iti),Ug(1,1,i-2),CUg(1,1,i-2))
2912           call matmat2(DD(1,1,iti),Ug(1,1,i-2),DUg(1,1,i-2))
2913           call matmat2(Dtilde(1,1,iti),Ug2(1,1,i-2),DtUg2(1,1,i-2))
2914           call matvec2(Ctilde(1,1,iti1),obrot(1,i-2),Ctobr(1,i-2))
2915           call matvec2(Dtilde(1,1,iti),obrot2(1,i-2),Dtobr2(1,i-2))
2916           endif
2917         else
2918           do k=1,2
2919             Ub2(k,i-2)=0.0d0
2920             Ctobr(k,i-2)=0.0d0
2921             Dtobr2(k,i-2)=0.0d0
2922             do l=1,2
2923               EUg(l,k,i-2)=0.0d0
2924               CUg(l,k,i-2)=0.0d0
2925               DUg(l,k,i-2)=0.0d0
2926               DtUg2(l,k,i-2)=0.0d0
2927             enddo
2928           enddo
2929         endif
2930         call matvec2(Ugder(1,1,i-2),b2(1,i-2),Ub2der(1,i-2))
2931         call matmat2(EE(1,1,i-2),Ugder(1,1,i-2),EUgder(1,1,i-2))
2932         do k=1,2
2933           muder(k,i-2)=Ub2der(k,i-2)
2934         enddo
2935 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2936         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2937           if (itype(i-1).le.ntyp) then
2938             iti1 = itortyp(itype(i-1))
2939           else
2940             iti1=ntortyp
2941           endif
2942         else
2943           iti1=ntortyp
2944         endif
2945         do k=1,2
2946           mu(k,i-2)=Ub2(k,i-2)+b1(k,i-1)
2947         enddo
2948 C        write (iout,*) 'mumu',i,b1(1,i-1),Ub2(1,i-2)
2949 c        write (iout,*) 'mu ',mu(:,i-2),i-2
2950 cd        write (iout,*) 'mu1',mu1(:,i-2)
2951 cd        write (iout,*) 'mu2',mu2(:,i-2)
2952         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
2953      &  then
2954         call matmat2(CC(1,1,iti1),Ugder(1,1,i-2),CUgder(1,1,i-2))
2955         call matmat2(DD(1,1,iti),Ugder(1,1,i-2),DUgder(1,1,i-2))
2956         call matmat2(Dtilde(1,1,iti),Ug2der(1,1,i-2),DtUg2der(1,1,i-2))
2957         call matvec2(Ctilde(1,1,iti1),obrot_der(1,i-2),Ctobrder(1,i-2))
2958         call matvec2(Dtilde(1,1,iti),obrot2_der(1,i-2),Dtobr2der(1,i-2))
2959 C Vectors and matrices dependent on a single virtual-bond dihedral.
2960         call matvec2(DD(1,1,iti),b1tilde(1,i-1),auxvec(1))
2961         call matvec2(Ug2(1,1,i-2),auxvec(1),Ug2Db1t(1,i-2))
2962         call matvec2(Ug2der(1,1,i-2),auxvec(1),Ug2Db1tder(1,i-2))
2963         call matvec2(CC(1,1,iti1),Ub2(1,i-2),CUgb2(1,i-2))
2964         call matvec2(CC(1,1,iti1),Ub2der(1,i-2),CUgb2der(1,i-2))
2965         call matmat2(EUg(1,1,i-2),CC(1,1,iti1),EUgC(1,1,i-2))
2966         call matmat2(EUgder(1,1,i-2),CC(1,1,iti1),EUgCder(1,1,i-2))
2967         call matmat2(EUg(1,1,i-2),DD(1,1,iti1),EUgD(1,1,i-2))
2968         call matmat2(EUgder(1,1,i-2),DD(1,1,iti1),EUgDder(1,1,i-2))
2969         endif
2970       enddo
2971 C Matrices dependent on two consecutive virtual-bond dihedrals.
2972 C The order of matrices is from left to right.
2973       if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
2974      &then
2975 c      do i=max0(ivec_start,2),ivec_end
2976       do i=2,nres-1
2977         call matmat2(DtUg2(1,1,i-1),EUg(1,1,i),DtUg2EUg(1,1,i))
2978         call matmat2(DtUg2der(1,1,i-1),EUg(1,1,i),DtUg2EUgder(1,1,1,i))
2979         call matmat2(DtUg2(1,1,i-1),EUgder(1,1,i),DtUg2EUgder(1,1,2,i))
2980         call transpose2(DtUg2(1,1,i-1),auxmat(1,1))
2981         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUg(1,1,i))
2982         call matmat2(auxmat(1,1),EUgder(1,1,i),Ug2DtEUgder(1,1,2,i))
2983         call transpose2(DtUg2der(1,1,i-1),auxmat(1,1))
2984         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUgder(1,1,1,i))
2985       enddo
2986       endif
2987 #if defined(MPI) && defined(PARMAT)
2988 #ifdef DEBUG
2989 c      if (fg_rank.eq.0) then
2990         write (iout,*) "Arrays UG and UGDER before GATHER"
2991         do i=1,nres-1
2992           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2993      &     ((ug(l,k,i),l=1,2),k=1,2),
2994      &     ((ugder(l,k,i),l=1,2),k=1,2)
2995         enddo
2996         write (iout,*) "Arrays UG2 and UG2DER"
2997         do i=1,nres-1
2998           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2999      &     ((ug2(l,k,i),l=1,2),k=1,2),
3000      &     ((ug2der(l,k,i),l=1,2),k=1,2)
3001         enddo
3002         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
3003         do i=1,nres-1
3004           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3005      &     (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
3006      &     (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
3007         enddo
3008         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
3009         do i=1,nres-1
3010           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3011      &     costab(i),sintab(i),costab2(i),sintab2(i)
3012         enddo
3013         write (iout,*) "Array MUDER"
3014         do i=1,nres-1
3015           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
3016         enddo
3017 c      endif
3018 #endif
3019       if (nfgtasks.gt.1) then
3020         time00=MPI_Wtime()
3021 c        write(iout,*)"Processor",fg_rank,kolor," ivec_start",ivec_start,
3022 c     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks-1),
3023 c     &   " ivec_count",(ivec_count(i),i=0,nfgtasks-1)
3024 #ifdef MATGATHER
3025         call MPI_Allgatherv(Ub2(1,ivec_start),ivec_count(fg_rank1),
3026      &   MPI_MU,Ub2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3027      &   FG_COMM1,IERR)
3028         call MPI_Allgatherv(Ub2der(1,ivec_start),ivec_count(fg_rank1),
3029      &   MPI_MU,Ub2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3030      &   FG_COMM1,IERR)
3031         call MPI_Allgatherv(mu(1,ivec_start),ivec_count(fg_rank1),
3032      &   MPI_MU,mu(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3033      &   FG_COMM1,IERR)
3034         call MPI_Allgatherv(muder(1,ivec_start),ivec_count(fg_rank1),
3035      &   MPI_MU,muder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3036      &   FG_COMM1,IERR)
3037         call MPI_Allgatherv(Eug(1,1,ivec_start),ivec_count(fg_rank1),
3038      &   MPI_MAT1,Eug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3039      &   FG_COMM1,IERR)
3040         call MPI_Allgatherv(Eugder(1,1,ivec_start),ivec_count(fg_rank1),
3041      &   MPI_MAT1,Eugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3042      &   FG_COMM1,IERR)
3043         call MPI_Allgatherv(costab(ivec_start),ivec_count(fg_rank1),
3044      &   MPI_DOUBLE_PRECISION,costab(1),ivec_count(0),ivec_displ(0),
3045      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3046         call MPI_Allgatherv(sintab(ivec_start),ivec_count(fg_rank1),
3047      &   MPI_DOUBLE_PRECISION,sintab(1),ivec_count(0),ivec_displ(0),
3048      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3049         call MPI_Allgatherv(costab2(ivec_start),ivec_count(fg_rank1),
3050      &   MPI_DOUBLE_PRECISION,costab2(1),ivec_count(0),ivec_displ(0),
3051      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3052         call MPI_Allgatherv(sintab2(ivec_start),ivec_count(fg_rank1),
3053      &   MPI_DOUBLE_PRECISION,sintab2(1),ivec_count(0),ivec_displ(0),
3054      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3055         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
3056      &  then
3057         call MPI_Allgatherv(Ctobr(1,ivec_start),ivec_count(fg_rank1),
3058      &   MPI_MU,Ctobr(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3059      &   FG_COMM1,IERR)
3060         call MPI_Allgatherv(Ctobrder(1,ivec_start),ivec_count(fg_rank1),
3061      &   MPI_MU,Ctobrder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3062      &   FG_COMM1,IERR)
3063         call MPI_Allgatherv(Dtobr2(1,ivec_start),ivec_count(fg_rank1),
3064      &   MPI_MU,Dtobr2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3065      &   FG_COMM1,IERR)
3066        call MPI_Allgatherv(Dtobr2der(1,ivec_start),ivec_count(fg_rank1),
3067      &   MPI_MU,Dtobr2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3068      &   FG_COMM1,IERR)
3069         call MPI_Allgatherv(Ug2Db1t(1,ivec_start),ivec_count(fg_rank1),
3070      &   MPI_MU,Ug2Db1t(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3071      &   FG_COMM1,IERR)
3072         call MPI_Allgatherv(Ug2Db1tder(1,ivec_start),
3073      &   ivec_count(fg_rank1),
3074      &   MPI_MU,Ug2Db1tder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3075      &   FG_COMM1,IERR)
3076         call MPI_Allgatherv(CUgb2(1,ivec_start),ivec_count(fg_rank1),
3077      &   MPI_MU,CUgb2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3078      &   FG_COMM1,IERR)
3079         call MPI_Allgatherv(CUgb2der(1,ivec_start),ivec_count(fg_rank1),
3080      &   MPI_MU,CUgb2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3081      &   FG_COMM1,IERR)
3082         call MPI_Allgatherv(Cug(1,1,ivec_start),ivec_count(fg_rank1),
3083      &   MPI_MAT1,Cug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3084      &   FG_COMM1,IERR)
3085         call MPI_Allgatherv(Cugder(1,1,ivec_start),ivec_count(fg_rank1),
3086      &   MPI_MAT1,Cugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3087      &   FG_COMM1,IERR)
3088         call MPI_Allgatherv(Dug(1,1,ivec_start),ivec_count(fg_rank1),
3089      &   MPI_MAT1,Dug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3090      &   FG_COMM1,IERR)
3091         call MPI_Allgatherv(Dugder(1,1,ivec_start),ivec_count(fg_rank1),
3092      &   MPI_MAT1,Dugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3093      &   FG_COMM1,IERR)
3094         call MPI_Allgatherv(Dtug2(1,1,ivec_start),ivec_count(fg_rank1),
3095      &   MPI_MAT1,Dtug2(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3096      &   FG_COMM1,IERR)
3097         call MPI_Allgatherv(Dtug2der(1,1,ivec_start),
3098      &   ivec_count(fg_rank1),
3099      &   MPI_MAT1,Dtug2der(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3100      &   FG_COMM1,IERR)
3101         call MPI_Allgatherv(EugC(1,1,ivec_start),ivec_count(fg_rank1),
3102      &   MPI_MAT1,EugC(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3103      &   FG_COMM1,IERR)
3104        call MPI_Allgatherv(EugCder(1,1,ivec_start),ivec_count(fg_rank1),
3105      &   MPI_MAT1,EugCder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3106      &   FG_COMM1,IERR)
3107         call MPI_Allgatherv(EugD(1,1,ivec_start),ivec_count(fg_rank1),
3108      &   MPI_MAT1,EugD(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3109      &   FG_COMM1,IERR)
3110        call MPI_Allgatherv(EugDder(1,1,ivec_start),ivec_count(fg_rank1),
3111      &   MPI_MAT1,EugDder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3112      &   FG_COMM1,IERR)
3113         call MPI_Allgatherv(DtUg2EUg(1,1,ivec_start),
3114      &   ivec_count(fg_rank1),
3115      &   MPI_MAT1,DtUg2EUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3116      &   FG_COMM1,IERR)
3117         call MPI_Allgatherv(Ug2DtEUg(1,1,ivec_start),
3118      &   ivec_count(fg_rank1),
3119      &   MPI_MAT1,Ug2DtEUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3120      &   FG_COMM1,IERR)
3121         call MPI_Allgatherv(DtUg2EUgder(1,1,1,ivec_start),
3122      &   ivec_count(fg_rank1),
3123      &   MPI_MAT2,DtUg2EUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
3124      &   MPI_MAT2,FG_COMM1,IERR)
3125         call MPI_Allgatherv(Ug2DtEUgder(1,1,1,ivec_start),
3126      &   ivec_count(fg_rank1),
3127      &   MPI_MAT2,Ug2DtEUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
3128      &   MPI_MAT2,FG_COMM1,IERR)
3129         endif
3130 #else
3131 c Passes matrix info through the ring
3132       isend=fg_rank1
3133       irecv=fg_rank1-1
3134       if (irecv.lt.0) irecv=nfgtasks1-1
3135       iprev=irecv
3136       inext=fg_rank1+1
3137       if (inext.ge.nfgtasks1) inext=0
3138       do i=1,nfgtasks1-1
3139 c        write (iout,*) "isend",isend," irecv",irecv
3140 c        call flush(iout)
3141         lensend=lentyp(isend)
3142         lenrecv=lentyp(irecv)
3143 c        write (iout,*) "lensend",lensend," lenrecv",lenrecv
3144 c        call MPI_SENDRECV(ug(1,1,ivec_displ(isend)+1),1,
3145 c     &   MPI_ROTAT1(lensend),inext,2200+isend,
3146 c     &   ug(1,1,ivec_displ(irecv)+1),1,MPI_ROTAT1(lenrecv),
3147 c     &   iprev,2200+irecv,FG_COMM,status,IERR)
3148 c        write (iout,*) "Gather ROTAT1"
3149 c        call flush(iout)
3150 c        call MPI_SENDRECV(obrot(1,ivec_displ(isend)+1),1,
3151 c     &   MPI_ROTAT2(lensend),inext,3300+isend,
3152 c     &   obrot(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
3153 c     &   iprev,3300+irecv,FG_COMM,status,IERR)
3154 c        write (iout,*) "Gather ROTAT2"
3155 c        call flush(iout)
3156         call MPI_SENDRECV(costab(ivec_displ(isend)+1),1,
3157      &   MPI_ROTAT_OLD(lensend),inext,4400+isend,
3158      &   costab(ivec_displ(irecv)+1),1,MPI_ROTAT_OLD(lenrecv),
3159      &   iprev,4400+irecv,FG_COMM,status,IERR)
3160 c        write (iout,*) "Gather ROTAT_OLD"
3161 c        call flush(iout)
3162         call MPI_SENDRECV(mu(1,ivec_displ(isend)+1),1,
3163      &   MPI_PRECOMP11(lensend),inext,5500+isend,
3164      &   mu(1,ivec_displ(irecv)+1),1,MPI_PRECOMP11(lenrecv),
3165      &   iprev,5500+irecv,FG_COMM,status,IERR)
3166 c        write (iout,*) "Gather PRECOMP11"
3167 c        call flush(iout)
3168         call MPI_SENDRECV(Eug(1,1,ivec_displ(isend)+1),1,
3169      &   MPI_PRECOMP12(lensend),inext,6600+isend,
3170      &   Eug(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP12(lenrecv),
3171      &   iprev,6600+irecv,FG_COMM,status,IERR)
3172 c        write (iout,*) "Gather PRECOMP12"
3173 c        call flush(iout)
3174         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
3175      &  then
3176         call MPI_SENDRECV(ug2db1t(1,ivec_displ(isend)+1),1,
3177      &   MPI_ROTAT2(lensend),inext,7700+isend,
3178      &   ug2db1t(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
3179      &   iprev,7700+irecv,FG_COMM,status,IERR)
3180 c        write (iout,*) "Gather PRECOMP21"
3181 c        call flush(iout)
3182         call MPI_SENDRECV(EUgC(1,1,ivec_displ(isend)+1),1,
3183      &   MPI_PRECOMP22(lensend),inext,8800+isend,
3184      &   EUgC(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP22(lenrecv),
3185      &   iprev,8800+irecv,FG_COMM,status,IERR)
3186 c        write (iout,*) "Gather PRECOMP22"
3187 c        call flush(iout)
3188         call MPI_SENDRECV(Ug2DtEUgder(1,1,1,ivec_displ(isend)+1),1,
3189      &   MPI_PRECOMP23(lensend),inext,9900+isend,
3190      &   Ug2DtEUgder(1,1,1,ivec_displ(irecv)+1),1,
3191      &   MPI_PRECOMP23(lenrecv),
3192      &   iprev,9900+irecv,FG_COMM,status,IERR)
3193 c        write (iout,*) "Gather PRECOMP23"
3194 c        call flush(iout)
3195         endif
3196         isend=irecv
3197         irecv=irecv-1
3198         if (irecv.lt.0) irecv=nfgtasks1-1
3199       enddo
3200 #endif
3201         time_gather=time_gather+MPI_Wtime()-time00
3202       endif
3203 #ifdef DEBUG
3204 c      if (fg_rank.eq.0) then
3205         write (iout,*) "Arrays UG and UGDER"
3206         do i=1,nres-1
3207           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3208      &     ((ug(l,k,i),l=1,2),k=1,2),
3209      &     ((ugder(l,k,i),l=1,2),k=1,2)
3210         enddo
3211         write (iout,*) "Arrays UG2 and UG2DER"
3212         do i=1,nres-1
3213           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3214      &     ((ug2(l,k,i),l=1,2),k=1,2),
3215      &     ((ug2der(l,k,i),l=1,2),k=1,2)
3216         enddo
3217         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
3218         do i=1,nres-1
3219           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3220      &     (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
3221      &     (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
3222         enddo
3223         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
3224         do i=1,nres-1
3225           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3226      &     costab(i),sintab(i),costab2(i),sintab2(i)
3227         enddo
3228         write (iout,*) "Array MUDER"
3229         do i=1,nres-1
3230           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
3231         enddo
3232 c      endif
3233 #endif
3234 #endif
3235 cd      do i=1,nres
3236 cd        iti = itortyp(itype(i))
3237 cd        write (iout,*) i
3238 cd        do j=1,2
3239 cd        write (iout,'(2f10.5,5x,2f10.5,5x,2f10.5)')
3240 cd     &  (EE(j,k,iti),k=1,2),(Ug(j,k,i),k=1,2),(EUg(j,k,i),k=1,2)
3241 cd        enddo
3242 cd      enddo
3243       return
3244       end
3245 C--------------------------------------------------------------------------
3246       subroutine eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
3247 C
3248 C This subroutine calculates the average interaction energy and its gradient
3249 C in the virtual-bond vectors between non-adjacent peptide groups, based on
3250 C the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
3251 C The potential depends both on the distance of peptide-group centers and on
3252 C the orientation of the CA-CA virtual bonds.
3253 C
3254       implicit real*8 (a-h,o-z)
3255 #ifdef MPI
3256       include 'mpif.h'
3257 #endif
3258       include 'DIMENSIONS'
3259       include 'COMMON.CONTROL'
3260       include 'COMMON.SETUP'
3261       include 'COMMON.IOUNITS'
3262       include 'COMMON.GEO'
3263       include 'COMMON.VAR'
3264       include 'COMMON.LOCAL'
3265       include 'COMMON.CHAIN'
3266       include 'COMMON.DERIV'
3267       include 'COMMON.INTERACT'
3268       include 'COMMON.CONTACTS'
3269       include 'COMMON.TORSION'
3270       include 'COMMON.VECTORS'
3271       include 'COMMON.FFIELD'
3272       include 'COMMON.TIME1'
3273       include 'COMMON.SPLITELE'
3274       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
3275      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
3276       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
3277      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4),gmuij(4)
3278       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3279      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3280      &    num_conti,j1,j2
3281 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
3282 #ifdef MOMENT
3283       double precision scal_el /1.0d0/
3284 #else
3285       double precision scal_el /0.5d0/
3286 #endif
3287 C 12/13/98
3288 C 13-go grudnia roku pamietnego...
3289       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
3290      &                   0.0d0,1.0d0,0.0d0,
3291      &                   0.0d0,0.0d0,1.0d0/
3292 cd      write(iout,*) 'In EELEC'
3293 cd      do i=1,nloctyp
3294 cd        write(iout,*) 'Type',i
3295 cd        write(iout,*) 'B1',B1(:,i)
3296 cd        write(iout,*) 'B2',B2(:,i)
3297 cd        write(iout,*) 'CC',CC(:,:,i)
3298 cd        write(iout,*) 'DD',DD(:,:,i)
3299 cd        write(iout,*) 'EE',EE(:,:,i)
3300 cd      enddo
3301 cd      call check_vecgrad
3302 cd      stop
3303       if (icheckgrad.eq.1) then
3304         do i=1,nres-1
3305           fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
3306           do k=1,3
3307             dc_norm(k,i)=dc(k,i)*fac
3308           enddo
3309 c          write (iout,*) 'i',i,' fac',fac
3310         enddo
3311       endif
3312       if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
3313      &    .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or.
3314      &    wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
3315 c        call vec_and_deriv
3316 #ifdef TIMING
3317         time01=MPI_Wtime()
3318 #endif
3319         call set_matrices
3320 #ifdef TIMING
3321         time_mat=time_mat+MPI_Wtime()-time01
3322 #endif
3323       endif
3324 cd      do i=1,nres-1
3325 cd        write (iout,*) 'i=',i
3326 cd        do k=1,3
3327 cd        write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
3328 cd        enddo
3329 cd        do k=1,3
3330 cd          write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
3331 cd     &     uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
3332 cd        enddo
3333 cd      enddo
3334       t_eelecij=0.0d0
3335       ees=0.0D0
3336       evdw1=0.0D0
3337       eel_loc=0.0d0
3338       eello_turn3=0.0d0
3339       eello_turn4=0.0d0
3340       ind=0
3341       do i=1,nres
3342         num_cont_hb(i)=0
3343       enddo
3344 cd      print '(a)','Enter EELEC'
3345 cd      write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
3346       do i=1,nres
3347         gel_loc_loc(i)=0.0d0
3348         gcorr_loc(i)=0.0d0
3349       enddo
3350 c
3351 c
3352 c 9/27/08 AL Split the interaction loop to ensure load balancing of turn terms
3353 C
3354 C Loop over i,i+2 and i,i+3 pairs of the peptide groups
3355 C
3356 C 14/01/2014 TURN3,TUNR4 does no go under periodic boundry condition
3357       do i=iturn3_start,iturn3_end
3358         if (i.le.1) cycle
3359 C        write(iout,*) "tu jest i",i
3360         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
3361 C changes suggested by Ana to avoid out of bounds
3362      & .or.((i+4).gt.nres)
3363      & .or.((i-1).le.0)
3364 C end of changes by Ana
3365      &  .or. itype(i+2).eq.ntyp1
3366      &  .or. itype(i+3).eq.ntyp1) cycle
3367         if(i.gt.1)then
3368           if(itype(i-1).eq.ntyp1)cycle
3369         end if
3370         if(i.LT.nres-3)then
3371           if (itype(i+4).eq.ntyp1) cycle
3372         end if
3373         dxi=dc(1,i)
3374         dyi=dc(2,i)
3375         dzi=dc(3,i)
3376         dx_normi=dc_norm(1,i)
3377         dy_normi=dc_norm(2,i)
3378         dz_normi=dc_norm(3,i)
3379         xmedi=c(1,i)+0.5d0*dxi
3380         ymedi=c(2,i)+0.5d0*dyi
3381         zmedi=c(3,i)+0.5d0*dzi
3382           xmedi=mod(xmedi,boxxsize)
3383           if (xmedi.lt.0) xmedi=xmedi+boxxsize
3384           ymedi=mod(ymedi,boxysize)
3385           if (ymedi.lt.0) ymedi=ymedi+boxysize
3386           zmedi=mod(zmedi,boxzsize)
3387           if (zmedi.lt.0) zmedi=zmedi+boxzsize
3388         num_conti=0
3389         call eelecij(i,i+2,ees,evdw1,eel_loc)
3390         if (wturn3.gt.0.0d0) call eturn3(i,eello_turn3)
3391         num_cont_hb(i)=num_conti
3392       enddo
3393       do i=iturn4_start,iturn4_end
3394         if (i.le.1) cycle
3395         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
3396 C changes suggested by Ana to avoid out of bounds
3397      & .or.((i+5).gt.nres)
3398      & .or.((i-1).le.0)
3399 C end of changes suggested by Ana
3400      &    .or. itype(i+3).eq.ntyp1
3401      &    .or. itype(i+4).eq.ntyp1
3402      &    .or. itype(i+5).eq.ntyp1
3403      &    .or. itype(i).eq.ntyp1
3404      &    .or. itype(i-1).eq.ntyp1
3405      &                             ) cycle
3406         dxi=dc(1,i)
3407         dyi=dc(2,i)
3408         dzi=dc(3,i)
3409         dx_normi=dc_norm(1,i)
3410         dy_normi=dc_norm(2,i)
3411         dz_normi=dc_norm(3,i)
3412         xmedi=c(1,i)+0.5d0*dxi
3413         ymedi=c(2,i)+0.5d0*dyi
3414         zmedi=c(3,i)+0.5d0*dzi
3415 C Return atom into box, boxxsize is size of box in x dimension
3416 c  194   continue
3417 c        if (xmedi.gt.((0.5d0)*boxxsize)) xmedi=xmedi-boxxsize
3418 c        if (xmedi.lt.((-0.5d0)*boxxsize)) xmedi=xmedi+boxxsize
3419 C Condition for being inside the proper box
3420 c        if ((xmedi.gt.((0.5d0)*boxxsize)).or.
3421 c     &       (xmedi.lt.((-0.5d0)*boxxsize))) then
3422 c        go to 194
3423 c        endif
3424 c  195   continue
3425 c        if (ymedi.gt.((0.5d0)*boxysize)) ymedi=ymedi-boxysize
3426 c        if (ymedi.lt.((-0.5d0)*boxysize)) ymedi=ymedi+boxysize
3427 C Condition for being inside the proper box
3428 c        if ((ymedi.gt.((0.5d0)*boxysize)).or.
3429 c     &       (ymedi.lt.((-0.5d0)*boxysize))) then
3430 c        go to 195
3431 c        endif
3432 c  196   continue
3433 c        if (zmedi.gt.((0.5d0)*boxzsize)) zmedi=zmedi-boxzsize
3434 c        if (zmedi.lt.((-0.5d0)*boxzsize)) zmedi=zmedi+boxzsize
3435 C Condition for being inside the proper box
3436 c        if ((zmedi.gt.((0.5d0)*boxzsize)).or.
3437 c     &       (zmedi.lt.((-0.5d0)*boxzsize))) then
3438 c        go to 196
3439 c        endif
3440           xmedi=mod(xmedi,boxxsize)
3441           if (xmedi.lt.0) xmedi=xmedi+boxxsize
3442           ymedi=mod(ymedi,boxysize)
3443           if (ymedi.lt.0) ymedi=ymedi+boxysize
3444           zmedi=mod(zmedi,boxzsize)
3445           if (zmedi.lt.0) zmedi=zmedi+boxzsize
3446
3447         num_conti=num_cont_hb(i)
3448 c        write(iout,*) "JESTEM W PETLI"
3449         call eelecij(i,i+3,ees,evdw1,eel_loc)
3450         if (wturn4.gt.0.0d0 .and. itype(i+2).ne.ntyp1)
3451      &   call eturn4(i,eello_turn4)
3452         num_cont_hb(i)=num_conti
3453       enddo   ! i
3454 C Loop over all neighbouring boxes
3455 C      do xshift=-1,1
3456 C      do yshift=-1,1
3457 C      do zshift=-1,1
3458 c
3459 c Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
3460 c
3461 CTU KURWA
3462       do i=iatel_s,iatel_e
3463 C        do i=75,75
3464         if (i.le.1) cycle
3465         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
3466 C changes suggested by Ana to avoid out of bounds
3467      & .or.((i+2).gt.nres)
3468      & .or.((i-1).le.0)
3469 C end of changes by Ana
3470      &  .or. itype(i+2).eq.ntyp1
3471      &  .or. itype(i-1).eq.ntyp1
3472      &                ) cycle
3473         dxi=dc(1,i)
3474         dyi=dc(2,i)
3475         dzi=dc(3,i)
3476         dx_normi=dc_norm(1,i)
3477         dy_normi=dc_norm(2,i)
3478         dz_normi=dc_norm(3,i)
3479         xmedi=c(1,i)+0.5d0*dxi
3480         ymedi=c(2,i)+0.5d0*dyi
3481         zmedi=c(3,i)+0.5d0*dzi
3482           xmedi=mod(xmedi,boxxsize)
3483           if (xmedi.lt.0) xmedi=xmedi+boxxsize
3484           ymedi=mod(ymedi,boxysize)
3485           if (ymedi.lt.0) ymedi=ymedi+boxysize
3486           zmedi=mod(zmedi,boxzsize)
3487           if (zmedi.lt.0) zmedi=zmedi+boxzsize
3488 C          xmedi=xmedi+xshift*boxxsize
3489 C          ymedi=ymedi+yshift*boxysize
3490 C          zmedi=zmedi+zshift*boxzsize
3491
3492 C Return tom into box, boxxsize is size of box in x dimension
3493 c  164   continue
3494 c        if (xmedi.gt.((xshift+0.5d0)*boxxsize)) xmedi=xmedi-boxxsize
3495 c        if (xmedi.lt.((xshift-0.5d0)*boxxsize)) xmedi=xmedi+boxxsize
3496 C Condition for being inside the proper box
3497 c        if ((xmedi.gt.((xshift+0.5d0)*boxxsize)).or.
3498 c     &       (xmedi.lt.((xshift-0.5d0)*boxxsize))) then
3499 c        go to 164
3500 c        endif
3501 c  165   continue
3502 c        if (ymedi.gt.((yshift+0.5d0)*boxysize)) ymedi=ymedi-boxysize
3503 c        if (ymedi.lt.((yshift-0.5d0)*boxysize)) ymedi=ymedi+boxysize
3504 C Condition for being inside the proper box
3505 c        if ((ymedi.gt.((yshift+0.5d0)*boxysize)).or.
3506 c     &       (ymedi.lt.((yshift-0.5d0)*boxysize))) then
3507 c        go to 165
3508 c        endif
3509 c  166   continue
3510 c        if (zmedi.gt.((zshift+0.5d0)*boxzsize)) zmedi=zmedi-boxzsize
3511 c        if (zmedi.lt.((zshift-0.5d0)*boxzsize)) zmedi=zmedi+boxzsize
3512 cC Condition for being inside the proper box
3513 c        if ((zmedi.gt.((zshift+0.5d0)*boxzsize)).or.
3514 c     &       (zmedi.lt.((zshift-0.5d0)*boxzsize))) then
3515 c        go to 166
3516 c        endif
3517
3518 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
3519         num_conti=num_cont_hb(i)
3520 C I TU KURWA
3521         do j=ielstart(i),ielend(i)
3522 C          do j=16,17
3523 C          write (iout,*) i,j
3524          if (j.le.1) cycle
3525           if (itype(j).eq.ntyp1.or. itype(j+1).eq.ntyp1
3526 C changes suggested by Ana to avoid out of bounds
3527      & .or.((j+2).gt.nres)
3528      & .or.((j-1).le.0)
3529 C end of changes by Ana
3530      & .or.itype(j+2).eq.ntyp1
3531      & .or.itype(j-1).eq.ntyp1
3532      &) cycle
3533           call eelecij(i,j,ees,evdw1,eel_loc)
3534         enddo ! j
3535         num_cont_hb(i)=num_conti
3536       enddo   ! i
3537 C     enddo   ! zshift
3538 C      enddo   ! yshift
3539 C      enddo   ! xshift
3540
3541 c      write (iout,*) "Number of loop steps in EELEC:",ind
3542 cd      do i=1,nres
3543 cd        write (iout,'(i3,3f10.5,5x,3f10.5)')
3544 cd     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
3545 cd      enddo
3546 c 12/7/99 Adam eello_turn3 will be considered as a separate energy term
3547 ccc      eel_loc=eel_loc+eello_turn3
3548 cd      print *,"Processor",fg_rank," t_eelecij",t_eelecij
3549       return
3550       end
3551 C-------------------------------------------------------------------------------
3552       subroutine eelecij(i,j,ees,evdw1,eel_loc)
3553       implicit real*8 (a-h,o-z)
3554       include 'DIMENSIONS'
3555 #ifdef MPI
3556       include "mpif.h"
3557 #endif
3558       include 'COMMON.CONTROL'
3559       include 'COMMON.IOUNITS'
3560       include 'COMMON.GEO'
3561       include 'COMMON.VAR'
3562       include 'COMMON.LOCAL'
3563       include 'COMMON.CHAIN'
3564       include 'COMMON.DERIV'
3565       include 'COMMON.INTERACT'
3566       include 'COMMON.CONTACTS'
3567       include 'COMMON.TORSION'
3568       include 'COMMON.VECTORS'
3569       include 'COMMON.FFIELD'
3570       include 'COMMON.TIME1'
3571       include 'COMMON.SPLITELE'
3572       include 'COMMON.SHIELD'
3573       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
3574      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
3575       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
3576      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4),gmuij1(4),gmuji1(4),
3577      &    gmuij2(4),gmuji2(4)
3578       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3579      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3580      &    num_conti,j1,j2
3581 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
3582 #ifdef MOMENT
3583       double precision scal_el /1.0d0/
3584 #else
3585       double precision scal_el /0.5d0/
3586 #endif
3587 C 12/13/98
3588 C 13-go grudnia roku pamietnego...
3589       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
3590      &                   0.0d0,1.0d0,0.0d0,
3591      &                   0.0d0,0.0d0,1.0d0/
3592 c          time00=MPI_Wtime()
3593 cd      write (iout,*) "eelecij",i,j
3594 c          ind=ind+1
3595           iteli=itel(i)
3596           itelj=itel(j)
3597           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
3598           aaa=app(iteli,itelj)
3599           bbb=bpp(iteli,itelj)
3600           ael6i=ael6(iteli,itelj)
3601           ael3i=ael3(iteli,itelj)
3602           dxj=dc(1,j)
3603           dyj=dc(2,j)
3604           dzj=dc(3,j)
3605           dx_normj=dc_norm(1,j)
3606           dy_normj=dc_norm(2,j)
3607           dz_normj=dc_norm(3,j)
3608 C          xj=c(1,j)+0.5D0*dxj-xmedi
3609 C          yj=c(2,j)+0.5D0*dyj-ymedi
3610 C          zj=c(3,j)+0.5D0*dzj-zmedi
3611           xj=c(1,j)+0.5D0*dxj
3612           yj=c(2,j)+0.5D0*dyj
3613           zj=c(3,j)+0.5D0*dzj
3614           xj=mod(xj,boxxsize)
3615           if (xj.lt.0) xj=xj+boxxsize
3616           yj=mod(yj,boxysize)
3617           if (yj.lt.0) yj=yj+boxysize
3618           zj=mod(zj,boxzsize)
3619           if (zj.lt.0) zj=zj+boxzsize
3620           if ((zj.lt.0).or.(xj.lt.0).or.(yj.lt.0)) write (*,*) "CHUJ"
3621       dist_init=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
3622       xj_safe=xj
3623       yj_safe=yj
3624       zj_safe=zj
3625       isubchap=0
3626       do xshift=-1,1
3627       do yshift=-1,1
3628       do zshift=-1,1
3629           xj=xj_safe+xshift*boxxsize
3630           yj=yj_safe+yshift*boxysize
3631           zj=zj_safe+zshift*boxzsize
3632           dist_temp=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
3633           if(dist_temp.lt.dist_init) then
3634             dist_init=dist_temp
3635             xj_temp=xj
3636             yj_temp=yj
3637             zj_temp=zj
3638             isubchap=1
3639           endif
3640        enddo
3641        enddo
3642        enddo
3643        if (isubchap.eq.1) then
3644           xj=xj_temp-xmedi
3645           yj=yj_temp-ymedi
3646           zj=zj_temp-zmedi
3647        else
3648           xj=xj_safe-xmedi
3649           yj=yj_safe-ymedi
3650           zj=zj_safe-zmedi
3651        endif
3652 C        if ((i+3).lt.j) then !this condition keeps for turn3 and turn4 not subject to PBC
3653 c  174   continue
3654 c        if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
3655 c        if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
3656 C Condition for being inside the proper box
3657 c        if ((xj.gt.((0.5d0)*boxxsize)).or.
3658 c     &       (xj.lt.((-0.5d0)*boxxsize))) then
3659 c        go to 174
3660 c        endif
3661 c  175   continue
3662 c        if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
3663 c        if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
3664 C Condition for being inside the proper box
3665 c        if ((yj.gt.((0.5d0)*boxysize)).or.
3666 c     &       (yj.lt.((-0.5d0)*boxysize))) then
3667 c        go to 175
3668 c        endif
3669 c  176   continue
3670 c        if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
3671 c        if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
3672 C Condition for being inside the proper box
3673 c        if ((zj.gt.((0.5d0)*boxzsize)).or.
3674 c     &       (zj.lt.((-0.5d0)*boxzsize))) then
3675 c        go to 176
3676 c        endif
3677 C        endif !endPBC condintion
3678 C        xj=xj-xmedi
3679 C        yj=yj-ymedi
3680 C        zj=zj-zmedi
3681           rij=xj*xj+yj*yj+zj*zj
3682
3683             sss=sscale(sqrt(rij))
3684             sssgrad=sscagrad(sqrt(rij))
3685 c            if (sss.gt.0.0d0) then
3686           rrmij=1.0D0/rij
3687           rij=dsqrt(rij)
3688           rmij=1.0D0/rij
3689           r3ij=rrmij*rmij
3690           r6ij=r3ij*r3ij
3691           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
3692           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
3693           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
3694           fac=cosa-3.0D0*cosb*cosg
3695           ev1=aaa*r6ij*r6ij
3696 c 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
3697           if (j.eq.i+2) ev1=scal_el*ev1
3698           ev2=bbb*r6ij
3699           fac3=ael6i*r6ij
3700           fac4=ael3i*r3ij
3701           evdwij=(ev1+ev2)
3702           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
3703           el2=fac4*fac
3704 C MARYSIA
3705 C          eesij=(el1+el2)
3706 C 12/26/95 - for the evaluation of multi-body H-bonding interactions
3707           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
3708           if (shield_mode.gt.0) then
3709 C          fac_shield(i)=0.4
3710 C          fac_shield(j)=0.6
3711           el1=el1*fac_shield(i)*fac_shield(j)
3712           el2=el2*fac_shield(i)*fac_shield(j)
3713           eesij=(el1+el2)
3714           ees=ees+eesij
3715           else
3716           fac_shield(i)=1.0
3717           fac_shield(j)=1.0
3718           eesij=(el1+el2)
3719           ees=ees+eesij
3720           endif
3721           evdw1=evdw1+evdwij*sss
3722 cd          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
3723 cd     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
3724 cd     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
3725 cd     &      xmedi,ymedi,zmedi,xj,yj,zj
3726
3727           if (energy_dec) then
3728               write (iout,'(a6,2i5,0pf7.3,2i5,2e11.3)')
3729      &'evdw1',i,j,evdwij
3730      &,iteli,itelj,aaa,evdw1
3731               write (iout,'(a6,2i5,0pf7.3,2f8.3)') 'ees',i,j,eesij,
3732      &fac_shield(i),fac_shield(j)
3733           endif
3734
3735 C
3736 C Calculate contributions to the Cartesian gradient.
3737 C
3738 #ifdef SPLITELE
3739           facvdw=-6*rrmij*(ev1+evdwij)*sss
3740           facel=-3*rrmij*(el1+eesij)
3741           fac1=fac
3742           erij(1)=xj*rmij
3743           erij(2)=yj*rmij
3744           erij(3)=zj*rmij
3745
3746 *
3747 * Radial derivatives. First process both termini of the fragment (i,j)
3748 *
3749           ggg(1)=facel*xj
3750           ggg(2)=facel*yj
3751           ggg(3)=facel*zj
3752           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
3753      &  (shield_mode.gt.0)) then
3754 C          print *,i,j
3755           do ilist=1,ishield_list(i)
3756            iresshield=shield_list(ilist,i)
3757            do k=1,3
3758            rlocshield=grad_shield_side(k,ilist,i)*eesij/fac_shield(i)
3759            gshieldx(k,iresshield)=gshieldx(k,iresshield)+
3760      &              rlocshield
3761      & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)
3762             gshieldc(k,iresshield-1)=gshieldc(k,iresshield-1)+rlocshield
3763 C           gshieldc_loc(k,iresshield)=gshieldc_loc(k,iresshield)
3764 C     & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)
3765 C             if (iresshield.gt.i) then
3766 C               do ishi=i+1,iresshield-1
3767 C                gshieldc(k,ishi)=gshieldc(k,ishi)+rlocshield
3768 C     & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)
3769 C
3770 C              enddo
3771 C             else
3772 C               do ishi=iresshield,i
3773 C                gshieldc(k,ishi)=gshieldc(k,ishi)-rlocshield
3774 C     & -grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)
3775 C
3776 C               enddo
3777 C              endif
3778            enddo
3779           enddo
3780           do ilist=1,ishield_list(j)
3781            iresshield=shield_list(ilist,j)
3782            do k=1,3
3783            rlocshield=grad_shield_side(k,ilist,j)*eesij/fac_shield(j)
3784            gshieldx(k,iresshield)=gshieldx(k,iresshield)+
3785      &              rlocshield
3786      & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
3787            gshieldc(k,iresshield-1)=gshieldc(k,iresshield-1)+rlocshield
3788
3789 C     & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
3790 C           gshieldc_loc(k,iresshield)=gshieldc_loc(k,iresshield)
3791 C     & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
3792 C             if (iresshield.gt.j) then
3793 C               do ishi=j+1,iresshield-1
3794 C                gshieldc(k,ishi)=gshieldc(k,ishi)+rlocshield
3795 C     & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
3796 C
3797 C               enddo
3798 C            else
3799 C               do ishi=iresshield,j
3800 C                gshieldc(k,ishi)=gshieldc(k,ishi)-rlocshield
3801 C     & -grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
3802 C               enddo
3803 C              endif
3804            enddo
3805           enddo
3806
3807           do k=1,3
3808             gshieldc(k,i)=gshieldc(k,i)+
3809      &              grad_shield(k,i)*eesij/fac_shield(i)
3810             gshieldc(k,j)=gshieldc(k,j)+
3811      &              grad_shield(k,j)*eesij/fac_shield(j)
3812             gshieldc(k,i-1)=gshieldc(k,i-1)+
3813      &              grad_shield(k,i)*eesij/fac_shield(i)
3814             gshieldc(k,j-1)=gshieldc(k,j-1)+
3815      &              grad_shield(k,j)*eesij/fac_shield(j)
3816
3817            enddo
3818            endif
3819 c          do k=1,3
3820 c            ghalf=0.5D0*ggg(k)
3821 c            gelc(k,i)=gelc(k,i)+ghalf
3822 c            gelc(k,j)=gelc(k,j)+ghalf
3823 c          enddo
3824 c 9/28/08 AL Gradient compotents will be summed only at the end
3825 C           print *,"before", gelc_long(1,i), gelc_long(1,j)
3826           do k=1,3
3827             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
3828 C     &                    +grad_shield(k,j)*eesij/fac_shield(j)
3829             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
3830 C     &                    +grad_shield(k,i)*eesij/fac_shield(i)
3831 C            gelc_long(k,i-1)=gelc_long(k,i-1)
3832 C     &                    +grad_shield(k,i)*eesij/fac_shield(i)
3833 C            gelc_long(k,j-1)=gelc_long(k,j-1)
3834 C     &                    +grad_shield(k,j)*eesij/fac_shield(j)
3835           enddo
3836 C           print *,"bafter", gelc_long(1,i), gelc_long(1,j)
3837
3838 *
3839 * Loop over residues i+1 thru j-1.
3840 *
3841 cgrad          do k=i+1,j-1
3842 cgrad            do l=1,3
3843 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3844 cgrad            enddo
3845 cgrad          enddo
3846           if (sss.gt.0.0) then
3847           ggg(1)=facvdw*xj+sssgrad*rmij*evdwij*xj
3848           ggg(2)=facvdw*yj+sssgrad*rmij*evdwij*yj
3849           ggg(3)=facvdw*zj+sssgrad*rmij*evdwij*zj
3850           else
3851           ggg(1)=0.0
3852           ggg(2)=0.0
3853           ggg(3)=0.0
3854           endif
3855 c          do k=1,3
3856 c            ghalf=0.5D0*ggg(k)
3857 c            gvdwpp(k,i)=gvdwpp(k,i)+ghalf
3858 c            gvdwpp(k,j)=gvdwpp(k,j)+ghalf
3859 c          enddo
3860 c 9/28/08 AL Gradient compotents will be summed only at the end
3861           do k=1,3
3862             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
3863             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
3864           enddo
3865 *
3866 * Loop over residues i+1 thru j-1.
3867 *
3868 cgrad          do k=i+1,j-1
3869 cgrad            do l=1,3
3870 cgrad              gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
3871 cgrad            enddo
3872 cgrad          enddo
3873 #else
3874 C MARYSIA
3875           facvdw=(ev1+evdwij)*sss
3876           facel=(el1+eesij)
3877           fac1=fac
3878           fac=-3*rrmij*(facvdw+facvdw+facel)
3879           erij(1)=xj*rmij
3880           erij(2)=yj*rmij
3881           erij(3)=zj*rmij
3882 *
3883 * Radial derivatives. First process both termini of the fragment (i,j)
3884 *
3885           ggg(1)=fac*xj
3886 C+eesij*grad_shield(1,i)+eesij*grad_shield(1,j)
3887           ggg(2)=fac*yj
3888 C+eesij*grad_shield(2,i)+eesij*grad_shield(2,j)
3889           ggg(3)=fac*zj
3890 C+eesij*grad_shield(3,i)+eesij*grad_shield(3,j)
3891 c          do k=1,3
3892 c            ghalf=0.5D0*ggg(k)
3893 c            gelc(k,i)=gelc(k,i)+ghalf
3894 c            gelc(k,j)=gelc(k,j)+ghalf
3895 c          enddo
3896 c 9/28/08 AL Gradient compotents will be summed only at the end
3897           do k=1,3
3898             gelc_long(k,j)=gelc(k,j)+ggg(k)
3899             gelc_long(k,i)=gelc(k,i)-ggg(k)
3900           enddo
3901 *
3902 * Loop over residues i+1 thru j-1.
3903 *
3904 cgrad          do k=i+1,j-1
3905 cgrad            do l=1,3
3906 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3907 cgrad            enddo
3908 cgrad          enddo
3909 c 9/28/08 AL Gradient compotents will be summed only at the end
3910           ggg(1)=facvdw*xj+sssgrad*rmij*evdwij*xj
3911           ggg(2)=facvdw*yj+sssgrad*rmij*evdwij*yj
3912           ggg(3)=facvdw*zj+sssgrad*rmij*evdwij*zj
3913           do k=1,3
3914             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
3915             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
3916           enddo
3917 #endif
3918 *
3919 * Angular part
3920 *
3921           ecosa=2.0D0*fac3*fac1+fac4
3922           fac4=-3.0D0*fac4
3923           fac3=-6.0D0*fac3
3924           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
3925           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
3926           do k=1,3
3927             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
3928             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
3929           enddo
3930 cd        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
3931 cd   &          (dcosg(k),k=1,3)
3932           do k=1,3
3933             ggg(k)=(ecosb*dcosb(k)+ecosg*dcosg(k))*
3934      &      fac_shield(i)*fac_shield(j)
3935           enddo
3936 c          do k=1,3
3937 c            ghalf=0.5D0*ggg(k)
3938 c            gelc(k,i)=gelc(k,i)+ghalf
3939 c     &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
3940 c     &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3941 c            gelc(k,j)=gelc(k,j)+ghalf
3942 c     &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
3943 c     &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3944 c          enddo
3945 cgrad          do k=i+1,j-1
3946 cgrad            do l=1,3
3947 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3948 cgrad            enddo
3949 cgrad          enddo
3950 C                     print *,"before22", gelc_long(1,i), gelc_long(1,j)
3951           do k=1,3
3952             gelc(k,i)=gelc(k,i)
3953      &           +((ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
3954      &           + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1))
3955      &           *fac_shield(i)*fac_shield(j)
3956             gelc(k,j)=gelc(k,j)
3957      &           +((ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
3958      &           + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1))
3959      &           *fac_shield(i)*fac_shield(j)
3960             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
3961             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
3962           enddo
3963 C           print *,"before33", gelc_long(1,i), gelc_long(1,j)
3964
3965 C MARYSIA
3966 c          endif !sscale
3967           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
3968      &        .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0
3969      &        .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
3970 C
3971 C 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
3972 C   energy of a peptide unit is assumed in the form of a second-order
3973 C   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
3974 C   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
3975 C   are computed for EVERY pair of non-contiguous peptide groups.
3976 C
3977
3978           if (j.lt.nres-1) then
3979             j1=j+1
3980             j2=j-1
3981           else
3982             j1=j-1
3983             j2=j-2
3984           endif
3985           kkk=0
3986           lll=0
3987           do k=1,2
3988             do l=1,2
3989               kkk=kkk+1
3990               muij(kkk)=mu(k,i)*mu(l,j)
3991 c              write(iout,*) 'mumu=', mu(k,i),mu(l,j),i,j,k,l
3992 #ifdef NEWCORR
3993              gmuij1(kkk)=gtb1(k,i+1)*mu(l,j)
3994 c             write(iout,*) 'k=',k,i,gtb1(k,i+1),gtb1(k,i+1)*mu(l,j)
3995              gmuij2(kkk)=gUb2(k,i)*mu(l,j)
3996              gmuji1(kkk)=mu(k,i)*gtb1(l,j+1)
3997 c             write(iout,*) 'l=',l,j,gtb1(l,j+1),gtb1(l,j+1)*mu(k,i)
3998              gmuji2(kkk)=mu(k,i)*gUb2(l,j)
3999 #endif
4000             enddo
4001           enddo
4002 cd         write (iout,*) 'EELEC: i',i,' j',j
4003 cd          write (iout,*) 'j',j,' j1',j1,' j2',j2
4004 cd          write(iout,*) 'muij',muij
4005           ury=scalar(uy(1,i),erij)
4006           urz=scalar(uz(1,i),erij)
4007           vry=scalar(uy(1,j),erij)
4008           vrz=scalar(uz(1,j),erij)
4009           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
4010           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
4011           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
4012           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
4013           fac=dsqrt(-ael6i)*r3ij
4014           a22=a22*fac
4015           a23=a23*fac
4016           a32=a32*fac
4017           a33=a33*fac
4018 cd          write (iout,'(4i5,4f10.5)')
4019 cd     &     i,itortyp(itype(i)),j,itortyp(itype(j)),a22,a23,a32,a33
4020 cd          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
4021 cd          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') uy(:,i),uz(:,i),
4022 cd     &      uy(:,j),uz(:,j)
4023 cd          write (iout,'(4f10.5)')
4024 cd     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
4025 cd     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
4026 cd          write (iout,'(4f10.5)') ury,urz,vry,vrz
4027 cd           write (iout,'(9f10.5/)')
4028 cd     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
4029 C Derivatives of the elements of A in virtual-bond vectors
4030           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
4031           do k=1,3
4032             uryg(k,1)=scalar(erder(1,k),uy(1,i))
4033             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
4034             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
4035             urzg(k,1)=scalar(erder(1,k),uz(1,i))
4036             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
4037             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
4038             vryg(k,1)=scalar(erder(1,k),uy(1,j))
4039             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
4040             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
4041             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
4042             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
4043             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
4044           enddo
4045 C Compute radial contributions to the gradient
4046           facr=-3.0d0*rrmij
4047           a22der=a22*facr
4048           a23der=a23*facr
4049           a32der=a32*facr
4050           a33der=a33*facr
4051           agg(1,1)=a22der*xj
4052           agg(2,1)=a22der*yj
4053           agg(3,1)=a22der*zj
4054           agg(1,2)=a23der*xj
4055           agg(2,2)=a23der*yj
4056           agg(3,2)=a23der*zj
4057           agg(1,3)=a32der*xj
4058           agg(2,3)=a32der*yj
4059           agg(3,3)=a32der*zj
4060           agg(1,4)=a33der*xj
4061           agg(2,4)=a33der*yj
4062           agg(3,4)=a33der*zj
4063 C Add the contributions coming from er
4064           fac3=-3.0d0*fac
4065           do k=1,3
4066             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
4067             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
4068             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
4069             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
4070           enddo
4071           do k=1,3
4072 C Derivatives in DC(i)
4073 cgrad            ghalf1=0.5d0*agg(k,1)
4074 cgrad            ghalf2=0.5d0*agg(k,2)
4075 cgrad            ghalf3=0.5d0*agg(k,3)
4076 cgrad            ghalf4=0.5d0*agg(k,4)
4077             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j))
4078      &      -3.0d0*uryg(k,2)*vry)!+ghalf1
4079             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j))
4080      &      -3.0d0*uryg(k,2)*vrz)!+ghalf2
4081             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j))
4082      &      -3.0d0*urzg(k,2)*vry)!+ghalf3
4083             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j))
4084      &      -3.0d0*urzg(k,2)*vrz)!+ghalf4
4085 C Derivatives in DC(i+1)
4086             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j))
4087      &      -3.0d0*uryg(k,3)*vry)!+agg(k,1)
4088             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j))
4089      &      -3.0d0*uryg(k,3)*vrz)!+agg(k,2)
4090             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j))
4091      &      -3.0d0*urzg(k,3)*vry)!+agg(k,3)
4092             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j))
4093      &      -3.0d0*urzg(k,3)*vrz)!+agg(k,4)
4094 C Derivatives in DC(j)
4095             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i))
4096      &      -3.0d0*vryg(k,2)*ury)!+ghalf1
4097             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i))
4098      &      -3.0d0*vrzg(k,2)*ury)!+ghalf2
4099             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i))
4100      &      -3.0d0*vryg(k,2)*urz)!+ghalf3
4101             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i))
4102      &      -3.0d0*vrzg(k,2)*urz)!+ghalf4
4103 C Derivatives in DC(j+1) or DC(nres-1)
4104             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i))
4105      &      -3.0d0*vryg(k,3)*ury)
4106             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i))
4107      &      -3.0d0*vrzg(k,3)*ury)
4108             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i))
4109      &      -3.0d0*vryg(k,3)*urz)
4110             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i))
4111      &      -3.0d0*vrzg(k,3)*urz)
4112 cgrad            if (j.eq.nres-1 .and. i.lt.j-2) then
4113 cgrad              do l=1,4
4114 cgrad                aggj1(k,l)=aggj1(k,l)+agg(k,l)
4115 cgrad              enddo
4116 cgrad            endif
4117           enddo
4118           acipa(1,1)=a22
4119           acipa(1,2)=a23
4120           acipa(2,1)=a32
4121           acipa(2,2)=a33
4122           a22=-a22
4123           a23=-a23
4124           do l=1,2
4125             do k=1,3
4126               agg(k,l)=-agg(k,l)
4127               aggi(k,l)=-aggi(k,l)
4128               aggi1(k,l)=-aggi1(k,l)
4129               aggj(k,l)=-aggj(k,l)
4130               aggj1(k,l)=-aggj1(k,l)
4131             enddo
4132           enddo
4133           if (j.lt.nres-1) then
4134             a22=-a22
4135             a32=-a32
4136             do l=1,3,2
4137               do k=1,3
4138                 agg(k,l)=-agg(k,l)
4139                 aggi(k,l)=-aggi(k,l)
4140                 aggi1(k,l)=-aggi1(k,l)
4141                 aggj(k,l)=-aggj(k,l)
4142                 aggj1(k,l)=-aggj1(k,l)
4143               enddo
4144             enddo
4145           else
4146             a22=-a22
4147             a23=-a23
4148             a32=-a32
4149             a33=-a33
4150             do l=1,4
4151               do k=1,3
4152                 agg(k,l)=-agg(k,l)
4153                 aggi(k,l)=-aggi(k,l)
4154                 aggi1(k,l)=-aggi1(k,l)
4155                 aggj(k,l)=-aggj(k,l)
4156                 aggj1(k,l)=-aggj1(k,l)
4157               enddo
4158             enddo
4159           endif
4160           ENDIF ! WCORR
4161           IF (wel_loc.gt.0.0d0) THEN
4162 C Contribution to the local-electrostatic energy coming from the i-j pair
4163           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3)
4164      &     +a33*muij(4)
4165 c          write (iout,*) 'i',i,' j',j,itype(i),itype(j),
4166 c     &                     ' eel_loc_ij',eel_loc_ij
4167 C          write(iout,*) 'muije=',i,j,muij(1),muij(2),muij(3),muij(4)
4168 C Calculate patrial derivative for theta angle
4169 #ifdef NEWCORR
4170          geel_loc_ij=a22*gmuij1(1)
4171      &     +a23*gmuij1(2)
4172      &     +a32*gmuij1(3)
4173      &     +a33*gmuij1(4)
4174 c         write(iout,*) "derivative over thatai"
4175 c         write(iout,*) a22*gmuij1(1), a23*gmuij1(2) ,a32*gmuij1(3),
4176 c     &   a33*gmuij1(4)
4177          gloc(nphi+i,icg)=gloc(nphi+i,icg)+
4178      &      geel_loc_ij*wel_loc
4179 c         write(iout,*) "derivative over thatai-1"
4180 c         write(iout,*) a22*gmuij2(1), a23*gmuij2(2) ,a32*gmuij2(3),
4181 c     &   a33*gmuij2(4)
4182          geel_loc_ij=
4183      &     a22*gmuij2(1)
4184      &     +a23*gmuij2(2)
4185      &     +a32*gmuij2(3)
4186      &     +a33*gmuij2(4)
4187          gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
4188      &      geel_loc_ij*wel_loc
4189 c  Derivative over j residue
4190          geel_loc_ji=a22*gmuji1(1)
4191      &     +a23*gmuji1(2)
4192      &     +a32*gmuji1(3)
4193      &     +a33*gmuji1(4)
4194 c         write(iout,*) "derivative over thataj"
4195 c         write(iout,*) a22*gmuji1(1), a23*gmuji1(2) ,a32*gmuji1(3),
4196 c     &   a33*gmuji1(4)
4197
4198         gloc(nphi+j,icg)=gloc(nphi+j,icg)+
4199      &      geel_loc_ji*wel_loc
4200          geel_loc_ji=
4201      &     +a22*gmuji2(1)
4202      &     +a23*gmuji2(2)
4203      &     +a32*gmuji2(3)
4204      &     +a33*gmuji2(4)
4205 c         write(iout,*) "derivative over thataj-1"
4206 c         write(iout,*) a22*gmuji2(1), a23*gmuji2(2) ,a32*gmuji2(3),
4207 c     &   a33*gmuji2(4)
4208          gloc(nphi+j-1,icg)=gloc(nphi+j-1,icg)+
4209      &      geel_loc_ji*wel_loc
4210 #endif
4211 cd          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
4212
4213           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
4214      &            'eelloc',i,j,eel_loc_ij
4215 c           if (eel_loc_ij.ne.0)
4216 c     &      write (iout,'(a4,2i4,8f9.5)')'chuj',
4217 c     &     i,j,a22,muij(1),a23,muij(2),a32,muij(3),a33,muij(4)
4218
4219           eel_loc=eel_loc+eel_loc_ij
4220 C Partial derivatives in virtual-bond dihedral angles gamma
4221           if (i.gt.1)
4222      &    gel_loc_loc(i-1)=gel_loc_loc(i-1)+
4223      &            a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j)
4224      &           +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j)
4225           gel_loc_loc(j-1)=gel_loc_loc(j-1)+
4226      &            a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j)
4227      &           +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j)
4228 C Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
4229           do l=1,3
4230             ggg(l)=agg(l,1)*muij(1)+
4231      &          agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4)
4232             gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l)
4233             gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l)
4234 cgrad            ghalf=0.5d0*ggg(l)
4235 cgrad            gel_loc(l,i)=gel_loc(l,i)+ghalf
4236 cgrad            gel_loc(l,j)=gel_loc(l,j)+ghalf
4237           enddo
4238 cgrad          do k=i+1,j2
4239 cgrad            do l=1,3
4240 cgrad              gel_loc(l,k)=gel_loc(l,k)+ggg(l)
4241 cgrad            enddo
4242 cgrad          enddo
4243 C Remaining derivatives of eello
4244           do l=1,3
4245             gel_loc(l,i)=gel_loc(l,i)+(aggi(l,1)*muij(1)+
4246      &        aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4))
4247             gel_loc(l,i+1)=gel_loc(l,i+1)+(aggi1(l,1)*muij(1)+
4248      &     aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4))
4249             gel_loc(l,j)=gel_loc(l,j)+(aggj(l,1)*muij(1)+
4250      &       aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4))
4251             gel_loc(l,j1)=gel_loc(l,j1)+(aggj1(l,1)*muij(1)+
4252      &     aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4))
4253           enddo
4254           ENDIF
4255 C Change 12/26/95 to calculate four-body contributions to H-bonding energy
4256 c          if (j.gt.i+1 .and. num_conti.le.maxconts) then
4257           if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0
4258      &       .and. num_conti.le.maxconts) then
4259 c            write (iout,*) i,j," entered corr"
4260 C
4261 C Calculate the contact function. The ith column of the array JCONT will
4262 C contain the numbers of atoms that make contacts with the atom I (of numbers
4263 C greater than I). The arrays FACONT and GACONT will contain the values of
4264 C the contact function and its derivative.
4265 c           r0ij=1.02D0*rpp(iteli,itelj)
4266 c           r0ij=1.11D0*rpp(iteli,itelj)
4267             r0ij=2.20D0*rpp(iteli,itelj)
4268 c           r0ij=1.55D0*rpp(iteli,itelj)
4269             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
4270             if (fcont.gt.0.0D0) then
4271               num_conti=num_conti+1
4272               if (num_conti.gt.maxconts) then
4273                 write (iout,*) 'WARNING - max. # of contacts exceeded;',
4274      &                         ' will skip next contacts for this conf.'
4275               else
4276                 jcont_hb(num_conti,i)=j
4277 cd                write (iout,*) "i",i," j",j," num_conti",num_conti,
4278 cd     &           " jcont_hb",jcont_hb(num_conti,i)
4279                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.
4280      &          wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
4281 C 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
4282 C  terms.
4283                 d_cont(num_conti,i)=rij
4284 cd                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
4285 C     --- Electrostatic-interaction matrix ---
4286                 a_chuj(1,1,num_conti,i)=a22
4287                 a_chuj(1,2,num_conti,i)=a23
4288                 a_chuj(2,1,num_conti,i)=a32
4289                 a_chuj(2,2,num_conti,i)=a33
4290 C     --- Gradient of rij
4291                 do kkk=1,3
4292                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
4293                 enddo
4294                 kkll=0
4295                 do k=1,2
4296                   do l=1,2
4297                     kkll=kkll+1
4298                     do m=1,3
4299                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
4300                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
4301                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
4302                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
4303                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
4304                     enddo
4305                   enddo
4306                 enddo
4307                 ENDIF
4308                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
4309 C Calculate contact energies
4310                 cosa4=4.0D0*cosa
4311                 wij=cosa-3.0D0*cosb*cosg
4312                 cosbg1=cosb+cosg
4313                 cosbg2=cosb-cosg
4314 c               fac3=dsqrt(-ael6i)/r0ij**3
4315                 fac3=dsqrt(-ael6i)*r3ij
4316 c                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
4317                 ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
4318                 if (ees0tmp.gt.0) then
4319                   ees0pij=dsqrt(ees0tmp)
4320                 else
4321                   ees0pij=0
4322                 endif
4323 c                ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
4324                 ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
4325                 if (ees0tmp.gt.0) then
4326                   ees0mij=dsqrt(ees0tmp)
4327                 else
4328                   ees0mij=0
4329                 endif
4330 c               ees0mij=0.0D0
4331                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij)
4332                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij)
4333 C Diagnostics. Comment out or remove after debugging!
4334 c               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
4335 c               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
4336 c               ees0m(num_conti,i)=0.0D0
4337 C End diagnostics.
4338 c               write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
4339 c    & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
4340 C Angular derivatives of the contact function
4341                 ees0pij1=fac3/ees0pij
4342                 ees0mij1=fac3/ees0mij
4343                 fac3p=-3.0D0*fac3*rrmij
4344                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
4345                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
4346 c               ees0mij1=0.0D0
4347                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
4348                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
4349                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
4350                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
4351                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
4352                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
4353                 ecosap=ecosa1+ecosa2
4354                 ecosbp=ecosb1+ecosb2
4355                 ecosgp=ecosg1+ecosg2
4356                 ecosam=ecosa1-ecosa2
4357                 ecosbm=ecosb1-ecosb2
4358                 ecosgm=ecosg1-ecosg2
4359 C Diagnostics
4360 c               ecosap=ecosa1
4361 c               ecosbp=ecosb1
4362 c               ecosgp=ecosg1
4363 c               ecosam=0.0D0
4364 c               ecosbm=0.0D0
4365 c               ecosgm=0.0D0
4366 C End diagnostics
4367                 facont_hb(num_conti,i)=fcont
4368                 fprimcont=fprimcont/rij
4369 cd              facont_hb(num_conti,i)=1.0D0
4370 C Following line is for diagnostics.
4371 cd              fprimcont=0.0D0
4372                 do k=1,3
4373                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
4374                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
4375                 enddo
4376                 do k=1,3
4377                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
4378                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
4379                 enddo
4380                 gggp(1)=gggp(1)+ees0pijp*xj
4381                 gggp(2)=gggp(2)+ees0pijp*yj
4382                 gggp(3)=gggp(3)+ees0pijp*zj
4383                 gggm(1)=gggm(1)+ees0mijp*xj
4384                 gggm(2)=gggm(2)+ees0mijp*yj
4385                 gggm(3)=gggm(3)+ees0mijp*zj
4386 C Derivatives due to the contact function
4387                 gacont_hbr(1,num_conti,i)=fprimcont*xj
4388                 gacont_hbr(2,num_conti,i)=fprimcont*yj
4389                 gacont_hbr(3,num_conti,i)=fprimcont*zj
4390                 do k=1,3
4391 c
4392 c 10/24/08 cgrad and ! comments indicate the parts of the code removed
4393 c          following the change of gradient-summation algorithm.
4394 c
4395 cgrad                  ghalfp=0.5D0*gggp(k)
4396 cgrad                  ghalfm=0.5D0*gggm(k)
4397                   gacontp_hb1(k,num_conti,i)=!ghalfp
4398      &              +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i))
4399      &              + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
4400                   gacontp_hb2(k,num_conti,i)=!ghalfp
4401      &              +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j))
4402      &              + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
4403                   gacontp_hb3(k,num_conti,i)=gggp(k)
4404                   gacontm_hb1(k,num_conti,i)=!ghalfm
4405      &              +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i))
4406      &              + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
4407                   gacontm_hb2(k,num_conti,i)=!ghalfm
4408      &              +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j))
4409      &              + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
4410                   gacontm_hb3(k,num_conti,i)=gggm(k)
4411                 enddo
4412 C Diagnostics. Comment out or remove after debugging!
4413 cdiag           do k=1,3
4414 cdiag             gacontp_hb1(k,num_conti,i)=0.0D0
4415 cdiag             gacontp_hb2(k,num_conti,i)=0.0D0
4416 cdiag             gacontp_hb3(k,num_conti,i)=0.0D0
4417 cdiag             gacontm_hb1(k,num_conti,i)=0.0D0
4418 cdiag             gacontm_hb2(k,num_conti,i)=0.0D0
4419 cdiag             gacontm_hb3(k,num_conti,i)=0.0D0
4420 cdiag           enddo
4421               ENDIF ! wcorr
4422               endif  ! num_conti.le.maxconts
4423             endif  ! fcont.gt.0
4424           endif    ! j.gt.i+1
4425           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
4426             do k=1,4
4427               do l=1,3
4428                 ghalf=0.5d0*agg(l,k)
4429                 aggi(l,k)=aggi(l,k)+ghalf
4430                 aggi1(l,k)=aggi1(l,k)+agg(l,k)
4431                 aggj(l,k)=aggj(l,k)+ghalf
4432               enddo
4433             enddo
4434             if (j.eq.nres-1 .and. i.lt.j-2) then
4435               do k=1,4
4436                 do l=1,3
4437                   aggj1(l,k)=aggj1(l,k)+agg(l,k)
4438                 enddo
4439               enddo
4440             endif
4441           endif
4442 c          t_eelecij=t_eelecij+MPI_Wtime()-time00
4443       return
4444       end
4445 C-----------------------------------------------------------------------------
4446       subroutine eturn3(i,eello_turn3)
4447 C Third- and fourth-order contributions from turns
4448       implicit real*8 (a-h,o-z)
4449       include 'DIMENSIONS'
4450       include 'COMMON.IOUNITS'
4451       include 'COMMON.GEO'
4452       include 'COMMON.VAR'
4453       include 'COMMON.LOCAL'
4454       include 'COMMON.CHAIN'
4455       include 'COMMON.DERIV'
4456       include 'COMMON.INTERACT'
4457       include 'COMMON.CONTACTS'
4458       include 'COMMON.TORSION'
4459       include 'COMMON.VECTORS'
4460       include 'COMMON.FFIELD'
4461       include 'COMMON.CONTROL'
4462       dimension ggg(3)
4463       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
4464      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
4465      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2),gpizda1(2,2),
4466      &  gpizda2(2,2),auxgmat1(2,2),auxgmatt1(2,2),
4467      &  auxgmat2(2,2),auxgmatt2(2,2)
4468       double precision agg(3,4),aggi(3,4),aggi1(3,4),
4469      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
4470       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
4471      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
4472      &    num_conti,j1,j2
4473       j=i+2
4474 c      write (iout,*) "eturn3",i,j,j1,j2
4475       a_temp(1,1)=a22
4476       a_temp(1,2)=a23
4477       a_temp(2,1)=a32
4478       a_temp(2,2)=a33
4479 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4480 C
4481 C               Third-order contributions
4482 C
4483 C                 (i+2)o----(i+3)
4484 C                      | |
4485 C                      | |
4486 C                 (i+1)o----i
4487 C
4488 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4489 cd        call checkint_turn3(i,a_temp,eello_turn3_num)
4490         call matmat2(EUg(1,1,i+1),EUg(1,1,i+2),auxmat(1,1))
4491 c auxalary matices for theta gradient
4492 c auxalary matrix for i+1 and constant i+2
4493         call matmat2(gtEUg(1,1,i+1),EUg(1,1,i+2),auxgmat1(1,1))
4494 c auxalary matrix for i+2 and constant i+1
4495         call matmat2(EUg(1,1,i+1),gtEUg(1,1,i+2),auxgmat2(1,1))
4496         call transpose2(auxmat(1,1),auxmat1(1,1))
4497         call transpose2(auxgmat1(1,1),auxgmatt1(1,1))
4498         call transpose2(auxgmat2(1,1),auxgmatt2(1,1))
4499         call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4500         call matmat2(a_temp(1,1),auxgmatt1(1,1),gpizda1(1,1))
4501         call matmat2(a_temp(1,1),auxgmatt2(1,1),gpizda2(1,1))
4502         eello_turn3=eello_turn3+0.5d0*(pizda(1,1)+pizda(2,2))
4503 C Derivatives in theta
4504         gloc(nphi+i,icg)=gloc(nphi+i,icg)
4505      &  +0.5d0*(gpizda1(1,1)+gpizda1(2,2))*wturn3
4506         gloc(nphi+i+1,icg)=gloc(nphi+i+1,icg)
4507      &  +0.5d0*(gpizda2(1,1)+gpizda2(2,2))*wturn3
4508
4509         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
4510      &          'eturn3',i,j,0.5d0*(pizda(1,1)+pizda(2,2))
4511 cd        write (2,*) 'i,',i,' j',j,'eello_turn3',
4512 cd     &    0.5d0*(pizda(1,1)+pizda(2,2)),
4513 cd     &    ' eello_turn3_num',4*eello_turn3_num
4514 C Derivatives in gamma(i)
4515         call matmat2(EUgder(1,1,i+1),EUg(1,1,i+2),auxmat2(1,1))
4516         call transpose2(auxmat2(1,1),auxmat3(1,1))
4517         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
4518         gel_loc_turn3(i)=gel_loc_turn3(i)+0.5d0*(pizda(1,1)+pizda(2,2))
4519 C Derivatives in gamma(i+1)
4520         call matmat2(EUg(1,1,i+1),EUgder(1,1,i+2),auxmat2(1,1))
4521         call transpose2(auxmat2(1,1),auxmat3(1,1))
4522         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
4523         gel_loc_turn3(i+1)=gel_loc_turn3(i+1)
4524      &    +0.5d0*(pizda(1,1)+pizda(2,2))
4525 C Cartesian derivatives
4526         do l=1,3
4527 c            ghalf1=0.5d0*agg(l,1)
4528 c            ghalf2=0.5d0*agg(l,2)
4529 c            ghalf3=0.5d0*agg(l,3)
4530 c            ghalf4=0.5d0*agg(l,4)
4531           a_temp(1,1)=aggi(l,1)!+ghalf1
4532           a_temp(1,2)=aggi(l,2)!+ghalf2
4533           a_temp(2,1)=aggi(l,3)!+ghalf3
4534           a_temp(2,2)=aggi(l,4)!+ghalf4
4535           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4536           gcorr3_turn(l,i)=gcorr3_turn(l,i)
4537      &      +0.5d0*(pizda(1,1)+pizda(2,2))
4538           a_temp(1,1)=aggi1(l,1)!+agg(l,1)
4539           a_temp(1,2)=aggi1(l,2)!+agg(l,2)
4540           a_temp(2,1)=aggi1(l,3)!+agg(l,3)
4541           a_temp(2,2)=aggi1(l,4)!+agg(l,4)
4542           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4543           gcorr3_turn(l,i+1)=gcorr3_turn(l,i+1)
4544      &      +0.5d0*(pizda(1,1)+pizda(2,2))
4545           a_temp(1,1)=aggj(l,1)!+ghalf1
4546           a_temp(1,2)=aggj(l,2)!+ghalf2
4547           a_temp(2,1)=aggj(l,3)!+ghalf3
4548           a_temp(2,2)=aggj(l,4)!+ghalf4
4549           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4550           gcorr3_turn(l,j)=gcorr3_turn(l,j)
4551      &      +0.5d0*(pizda(1,1)+pizda(2,2))
4552           a_temp(1,1)=aggj1(l,1)
4553           a_temp(1,2)=aggj1(l,2)
4554           a_temp(2,1)=aggj1(l,3)
4555           a_temp(2,2)=aggj1(l,4)
4556           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4557           gcorr3_turn(l,j1)=gcorr3_turn(l,j1)
4558      &      +0.5d0*(pizda(1,1)+pizda(2,2))
4559         enddo
4560       return
4561       end
4562 C-------------------------------------------------------------------------------
4563       subroutine eturn4(i,eello_turn4)
4564 C Third- and fourth-order contributions from turns
4565       implicit real*8 (a-h,o-z)
4566       include 'DIMENSIONS'
4567       include 'COMMON.IOUNITS'
4568       include 'COMMON.GEO'
4569       include 'COMMON.VAR'
4570       include 'COMMON.LOCAL'
4571       include 'COMMON.CHAIN'
4572       include 'COMMON.DERIV'
4573       include 'COMMON.INTERACT'
4574       include 'COMMON.CONTACTS'
4575       include 'COMMON.TORSION'
4576       include 'COMMON.VECTORS'
4577       include 'COMMON.FFIELD'
4578       include 'COMMON.CONTROL'
4579       dimension ggg(3)
4580       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
4581      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
4582      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2),auxgvec(2),
4583      &  auxgEvec1(2),auxgEvec2(2),auxgEvec3(2),
4584      &  gte1t(2,2),gte2t(2,2),gte3t(2,2),
4585      &  gte1a(2,2),gtae3(2,2),gtae3e2(2,2), ae3gte2(2,2),
4586      &  gtEpizda1(2,2),gtEpizda2(2,2),gtEpizda3(2,2)
4587       double precision agg(3,4),aggi(3,4),aggi1(3,4),
4588      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
4589       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
4590      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
4591      &    num_conti,j1,j2
4592       j=i+3
4593 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4594 C
4595 C               Fourth-order contributions
4596 C
4597 C                 (i+3)o----(i+4)
4598 C                     /  |
4599 C               (i+2)o   |
4600 C                     \  |
4601 C                 (i+1)o----i
4602 C
4603 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4604 cd        call checkint_turn4(i,a_temp,eello_turn4_num)
4605 c        write (iout,*) "eturn4 i",i," j",j," j1",j1," j2",j2
4606 c        write(iout,*)"WCHODZE W PROGRAM"
4607         a_temp(1,1)=a22
4608         a_temp(1,2)=a23
4609         a_temp(2,1)=a32
4610         a_temp(2,2)=a33
4611         iti1=itortyp(itype(i+1))
4612         iti2=itortyp(itype(i+2))
4613         iti3=itortyp(itype(i+3))
4614 c        write(iout,*) "iti1",iti1," iti2",iti2," iti3",iti3
4615         call transpose2(EUg(1,1,i+1),e1t(1,1))
4616         call transpose2(Eug(1,1,i+2),e2t(1,1))
4617         call transpose2(Eug(1,1,i+3),e3t(1,1))
4618 C Ematrix derivative in theta
4619         call transpose2(gtEUg(1,1,i+1),gte1t(1,1))
4620         call transpose2(gtEug(1,1,i+2),gte2t(1,1))
4621         call transpose2(gtEug(1,1,i+3),gte3t(1,1))
4622         call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4623 c       eta1 in derivative theta
4624         call matmat2(gte1t(1,1),a_temp(1,1),gte1a(1,1))
4625         call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4626 c       auxgvec is derivative of Ub2 so i+3 theta
4627         call matvec2(e1a(1,1),gUb2(1,i+3),auxgvec(1))
4628 c       auxalary matrix of E i+1
4629         call matvec2(gte1a(1,1),Ub2(1,i+3),auxgEvec1(1))
4630 c        s1=0.0
4631 c        gs1=0.0
4632         s1=scalar2(b1(1,i+2),auxvec(1))
4633 c derivative of theta i+2 with constant i+3
4634         gs23=scalar2(gtb1(1,i+2),auxvec(1))
4635 c derivative of theta i+2 with constant i+2
4636         gs32=scalar2(b1(1,i+2),auxgvec(1))
4637 c derivative of E matix in theta of i+1
4638         gsE13=scalar2(b1(1,i+2),auxgEvec1(1))
4639
4640         call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4641 c       ea31 in derivative theta
4642         call matmat2(a_temp(1,1),gte3t(1,1),gtae3(1,1))
4643         call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4644 c auxilary matrix auxgvec of Ub2 with constant E matirx
4645         call matvec2(ae3(1,1),gUb2(1,i+2),auxgvec(1))
4646 c auxilary matrix auxgEvec1 of E matix with Ub2 constant
4647         call matvec2(gtae3(1,1),Ub2(1,i+2),auxgEvec3(1))
4648
4649 c        s2=0.0
4650 c        gs2=0.0
4651         s2=scalar2(b1(1,i+1),auxvec(1))
4652 c derivative of theta i+1 with constant i+3
4653         gs13=scalar2(gtb1(1,i+1),auxvec(1))
4654 c derivative of theta i+2 with constant i+1
4655         gs21=scalar2(b1(1,i+1),auxgvec(1))
4656 c derivative of theta i+3 with constant i+1
4657         gsE31=scalar2(b1(1,i+1),auxgEvec3(1))
4658 c        write(iout,*) gs1,gs2,'i=',i,auxgvec(1),gUb2(1,i+2),gtb1(1,i+2),
4659 c     &  gtb1(1,i+1)
4660         call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4661 c two derivatives over diffetent matrices
4662 c gtae3e2 is derivative over i+3
4663         call matmat2(gtae3(1,1),e2t(1,1),gtae3e2(1,1))
4664 c ae3gte2 is derivative over i+2
4665         call matmat2(ae3(1,1),gte2t(1,1),ae3gte2(1,1))
4666         call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4667 c three possible derivative over theta E matices
4668 c i+1
4669         call matmat2(ae3e2(1,1),gte1t(1,1),gtEpizda1(1,1))
4670 c i+2
4671         call matmat2(ae3gte2(1,1),e1t(1,1),gtEpizda2(1,1))
4672 c i+3
4673         call matmat2(gtae3e2(1,1),e1t(1,1),gtEpizda3(1,1))
4674         s3=0.5d0*(pizda(1,1)+pizda(2,2))
4675
4676         gsEE1=0.5d0*(gtEpizda1(1,1)+gtEpizda1(2,2))
4677         gsEE2=0.5d0*(gtEpizda2(1,1)+gtEpizda2(2,2))
4678         gsEE3=0.5d0*(gtEpizda3(1,1)+gtEpizda3(2,2))
4679
4680         eello_turn4=eello_turn4-(s1+s2+s3)
4681 c             write(iout,*)'chujOWO', auxvec(1),b1(1,iti2)
4682         if (energy_dec) write (iout,'(a6,2i5,0pf7.3,3f7.3)')
4683      &      'eturn4',i,j,-(s1+s2+s3),s1,s2,s3
4684 cd        write (2,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
4685 cd     &    ' eello_turn4_num',8*eello_turn4_num
4686 #ifdef NEWCORR
4687         gloc(nphi+i,icg)=gloc(nphi+i,icg)
4688      &                  -(gs13+gsE13+gsEE1)*wturn4
4689         gloc(nphi+i+1,icg)= gloc(nphi+i+1,icg)
4690      &                    -(gs23+gs21+gsEE2)*wturn4
4691         gloc(nphi+i+2,icg)= gloc(nphi+i+2,icg)
4692      &                    -(gs32+gsE31+gsEE3)*wturn4
4693 c         gloc(nphi+i+1,icg)=gloc(nphi+i+1,icg)-
4694 c     &   gs2
4695 #endif
4696         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
4697      &      'eturn4',i,j,-(s1+s2+s3)
4698 c        write (iout,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
4699 c     &    ' eello_turn4_num',8*eello_turn4_num
4700 C Derivatives in gamma(i)
4701         call transpose2(EUgder(1,1,i+1),e1tder(1,1))
4702         call matmat2(e1tder(1,1),a_temp(1,1),auxmat(1,1))
4703         call matvec2(auxmat(1,1),Ub2(1,i+3),auxvec(1))
4704         s1=scalar2(b1(1,i+2),auxvec(1))
4705         call matmat2(ae3e2(1,1),e1tder(1,1),pizda(1,1))
4706         s3=0.5d0*(pizda(1,1)+pizda(2,2))
4707         gel_loc_turn4(i)=gel_loc_turn4(i)-(s1+s3)
4708 C Derivatives in gamma(i+1)
4709         call transpose2(EUgder(1,1,i+2),e2tder(1,1))
4710         call matvec2(ae3(1,1),Ub2der(1,i+2),auxvec(1))
4711         s2=scalar2(b1(1,i+1),auxvec(1))
4712         call matmat2(ae3(1,1),e2tder(1,1),auxmat(1,1))
4713         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
4714         s3=0.5d0*(pizda(1,1)+pizda(2,2))
4715         gel_loc_turn4(i+1)=gel_loc_turn4(i+1)-(s2+s3)
4716 C Derivatives in gamma(i+2)
4717         call transpose2(EUgder(1,1,i+3),e3tder(1,1))
4718         call matvec2(e1a(1,1),Ub2der(1,i+3),auxvec(1))
4719         s1=scalar2(b1(1,i+2),auxvec(1))
4720         call matmat2(a_temp(1,1),e3tder(1,1),auxmat(1,1))
4721         call matvec2(auxmat(1,1),Ub2(1,i+2),auxvec(1))
4722         s2=scalar2(b1(1,i+1),auxvec(1))
4723         call matmat2(auxmat(1,1),e2t(1,1),auxmat3(1,1))
4724         call matmat2(auxmat3(1,1),e1t(1,1),pizda(1,1))
4725         s3=0.5d0*(pizda(1,1)+pizda(2,2))
4726         gel_loc_turn4(i+2)=gel_loc_turn4(i+2)-(s1+s2+s3)
4727 C Cartesian derivatives
4728 C Derivatives of this turn contributions in DC(i+2)
4729         if (j.lt.nres-1) then
4730           do l=1,3
4731             a_temp(1,1)=agg(l,1)
4732             a_temp(1,2)=agg(l,2)
4733             a_temp(2,1)=agg(l,3)
4734             a_temp(2,2)=agg(l,4)
4735             call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4736             call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4737             s1=scalar2(b1(1,i+2),auxvec(1))
4738             call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4739             call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4740             s2=scalar2(b1(1,i+1),auxvec(1))
4741             call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4742             call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4743             s3=0.5d0*(pizda(1,1)+pizda(2,2))
4744             ggg(l)=-(s1+s2+s3)
4745             gcorr4_turn(l,i+2)=gcorr4_turn(l,i+2)-(s1+s2+s3)
4746           enddo
4747         endif
4748 C Remaining derivatives of this turn contribution
4749         do l=1,3
4750           a_temp(1,1)=aggi(l,1)
4751           a_temp(1,2)=aggi(l,2)
4752           a_temp(2,1)=aggi(l,3)
4753           a_temp(2,2)=aggi(l,4)
4754           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4755           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4756           s1=scalar2(b1(1,i+2),auxvec(1))
4757           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4758           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4759           s2=scalar2(b1(1,i+1),auxvec(1))
4760           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4761           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4762           s3=0.5d0*(pizda(1,1)+pizda(2,2))
4763           gcorr4_turn(l,i)=gcorr4_turn(l,i)-(s1+s2+s3)
4764           a_temp(1,1)=aggi1(l,1)
4765           a_temp(1,2)=aggi1(l,2)
4766           a_temp(2,1)=aggi1(l,3)
4767           a_temp(2,2)=aggi1(l,4)
4768           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4769           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4770           s1=scalar2(b1(1,i+2),auxvec(1))
4771           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4772           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4773           s2=scalar2(b1(1,i+1),auxvec(1))
4774           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4775           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4776           s3=0.5d0*(pizda(1,1)+pizda(2,2))
4777           gcorr4_turn(l,i+1)=gcorr4_turn(l,i+1)-(s1+s2+s3)
4778           a_temp(1,1)=aggj(l,1)
4779           a_temp(1,2)=aggj(l,2)
4780           a_temp(2,1)=aggj(l,3)
4781           a_temp(2,2)=aggj(l,4)
4782           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4783           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4784           s1=scalar2(b1(1,i+2),auxvec(1))
4785           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4786           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4787           s2=scalar2(b1(1,i+1),auxvec(1))
4788           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4789           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4790           s3=0.5d0*(pizda(1,1)+pizda(2,2))
4791           gcorr4_turn(l,j)=gcorr4_turn(l,j)-(s1+s2+s3)
4792           a_temp(1,1)=aggj1(l,1)
4793           a_temp(1,2)=aggj1(l,2)
4794           a_temp(2,1)=aggj1(l,3)
4795           a_temp(2,2)=aggj1(l,4)
4796           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4797           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4798           s1=scalar2(b1(1,i+2),auxvec(1))
4799           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4800           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4801           s2=scalar2(b1(1,i+1),auxvec(1))
4802           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4803           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4804           s3=0.5d0*(pizda(1,1)+pizda(2,2))
4805 c          write (iout,*) "s1",s1," s2",s2," s3",s3," s1+s2+s3",s1+s2+s3
4806           gcorr4_turn(l,j1)=gcorr4_turn(l,j1)-(s1+s2+s3)
4807         enddo
4808       return
4809       end
4810 C-----------------------------------------------------------------------------
4811       subroutine vecpr(u,v,w)
4812       implicit real*8(a-h,o-z)
4813       dimension u(3),v(3),w(3)
4814       w(1)=u(2)*v(3)-u(3)*v(2)
4815       w(2)=-u(1)*v(3)+u(3)*v(1)
4816       w(3)=u(1)*v(2)-u(2)*v(1)
4817       return
4818       end
4819 C-----------------------------------------------------------------------------
4820       subroutine unormderiv(u,ugrad,unorm,ungrad)
4821 C This subroutine computes the derivatives of a normalized vector u, given
4822 C the derivatives computed without normalization conditions, ugrad. Returns
4823 C ungrad.
4824       implicit none
4825       double precision u(3),ugrad(3,3),unorm,ungrad(3,3)
4826       double precision vec(3)
4827       double precision scalar
4828       integer i,j
4829 c      write (2,*) 'ugrad',ugrad
4830 c      write (2,*) 'u',u
4831       do i=1,3
4832         vec(i)=scalar(ugrad(1,i),u(1))
4833       enddo
4834 c      write (2,*) 'vec',vec
4835       do i=1,3
4836         do j=1,3
4837           ungrad(j,i)=(ugrad(j,i)-u(j)*vec(i))*unorm
4838         enddo
4839       enddo
4840 c      write (2,*) 'ungrad',ungrad
4841       return
4842       end
4843 C-----------------------------------------------------------------------------
4844       subroutine escp_soft_sphere(evdw2,evdw2_14)
4845 C
4846 C This subroutine calculates the excluded-volume interaction energy between
4847 C peptide-group centers and side chains and its gradient in virtual-bond and
4848 C side-chain vectors.
4849 C
4850       implicit real*8 (a-h,o-z)
4851       include 'DIMENSIONS'
4852       include 'COMMON.GEO'
4853       include 'COMMON.VAR'
4854       include 'COMMON.LOCAL'
4855       include 'COMMON.CHAIN'
4856       include 'COMMON.DERIV'
4857       include 'COMMON.INTERACT'
4858       include 'COMMON.FFIELD'
4859       include 'COMMON.IOUNITS'
4860       include 'COMMON.CONTROL'
4861       dimension ggg(3)
4862       evdw2=0.0D0
4863       evdw2_14=0.0d0
4864       r0_scp=4.5d0
4865 cd    print '(a)','Enter ESCP'
4866 cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
4867 C      do xshift=-1,1
4868 C      do yshift=-1,1
4869 C      do zshift=-1,1
4870       do i=iatscp_s,iatscp_e
4871         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
4872         iteli=itel(i)
4873         xi=0.5D0*(c(1,i)+c(1,i+1))
4874         yi=0.5D0*(c(2,i)+c(2,i+1))
4875         zi=0.5D0*(c(3,i)+c(3,i+1))
4876 C Return atom into box, boxxsize is size of box in x dimension
4877 c  134   continue
4878 c        if (xi.gt.((xshift+0.5d0)*boxxsize)) xi=xi-boxxsize
4879 c        if (xi.lt.((xshift-0.5d0)*boxxsize)) xi=xi+boxxsize
4880 C Condition for being inside the proper box
4881 c        if ((xi.gt.((xshift+0.5d0)*boxxsize)).or.
4882 c     &       (xi.lt.((xshift-0.5d0)*boxxsize))) then
4883 c        go to 134
4884 c        endif
4885 c  135   continue
4886 c        if (yi.gt.((yshift+0.5d0)*boxysize)) yi=yi-boxysize
4887 c        if (yi.lt.((yshift-0.5d0)*boxysize)) yi=yi+boxysize
4888 C Condition for being inside the proper box
4889 c        if ((yi.gt.((yshift+0.5d0)*boxysize)).or.
4890 c     &       (yi.lt.((yshift-0.5d0)*boxysize))) then
4891 c        go to 135
4892 c c       endif
4893 c  136   continue
4894 c        if (zi.gt.((zshift+0.5d0)*boxzsize)) zi=zi-boxzsize
4895 c        if (zi.lt.((zshift-0.5d0)*boxzsize)) zi=zi+boxzsize
4896 cC Condition for being inside the proper box
4897 c        if ((zi.gt.((zshift+0.5d0)*boxzsize)).or.
4898 c     &       (zi.lt.((zshift-0.5d0)*boxzsize))) then
4899 c        go to 136
4900 c        endif
4901           xi=mod(xi,boxxsize)
4902           if (xi.lt.0) xi=xi+boxxsize
4903           yi=mod(yi,boxysize)
4904           if (yi.lt.0) yi=yi+boxysize
4905           zi=mod(zi,boxzsize)
4906           if (zi.lt.0) zi=zi+boxzsize
4907 C          xi=xi+xshift*boxxsize
4908 C          yi=yi+yshift*boxysize
4909 C          zi=zi+zshift*boxzsize
4910         do iint=1,nscp_gr(i)
4911
4912         do j=iscpstart(i,iint),iscpend(i,iint)
4913           if (itype(j).eq.ntyp1) cycle
4914           itypj=iabs(itype(j))
4915 C Uncomment following three lines for SC-p interactions
4916 c         xj=c(1,nres+j)-xi
4917 c         yj=c(2,nres+j)-yi
4918 c         zj=c(3,nres+j)-zi
4919 C Uncomment following three lines for Ca-p interactions
4920           xj=c(1,j)
4921           yj=c(2,j)
4922           zj=c(3,j)
4923 c  174   continue
4924 c        if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
4925 c        if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
4926 C Condition for being inside the proper box
4927 c        if ((xj.gt.((0.5d0)*boxxsize)).or.
4928 c     &       (xj.lt.((-0.5d0)*boxxsize))) then
4929 c        go to 174
4930 c        endif
4931 c  175   continue
4932 c        if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
4933 c        if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
4934 cC Condition for being inside the proper box
4935 c        if ((yj.gt.((0.5d0)*boxysize)).or.
4936 c     &       (yj.lt.((-0.5d0)*boxysize))) then
4937 c        go to 175
4938 c        endif
4939 c  176   continue
4940 c        if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
4941 c        if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
4942 C Condition for being inside the proper box
4943 c        if ((zj.gt.((0.5d0)*boxzsize)).or.
4944 c     &       (zj.lt.((-0.5d0)*boxzsize))) then
4945 c        go to 176
4946           xj=mod(xj,boxxsize)
4947           if (xj.lt.0) xj=xj+boxxsize
4948           yj=mod(yj,boxysize)
4949           if (yj.lt.0) yj=yj+boxysize
4950           zj=mod(zj,boxzsize)
4951           if (zj.lt.0) zj=zj+boxzsize
4952       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
4953       xj_safe=xj
4954       yj_safe=yj
4955       zj_safe=zj
4956       subchap=0
4957       do xshift=-1,1
4958       do yshift=-1,1
4959       do zshift=-1,1
4960           xj=xj_safe+xshift*boxxsize
4961           yj=yj_safe+yshift*boxysize
4962           zj=zj_safe+zshift*boxzsize
4963           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
4964           if(dist_temp.lt.dist_init) then
4965             dist_init=dist_temp
4966             xj_temp=xj
4967             yj_temp=yj
4968             zj_temp=zj
4969             subchap=1
4970           endif
4971        enddo
4972        enddo
4973        enddo
4974        if (subchap.eq.1) then
4975           xj=xj_temp-xi
4976           yj=yj_temp-yi
4977           zj=zj_temp-zi
4978        else
4979           xj=xj_safe-xi
4980           yj=yj_safe-yi
4981           zj=zj_safe-zi
4982        endif
4983 c c       endif
4984 C          xj=xj-xi
4985 C          yj=yj-yi
4986 C          zj=zj-zi
4987           rij=xj*xj+yj*yj+zj*zj
4988
4989           r0ij=r0_scp
4990           r0ijsq=r0ij*r0ij
4991           if (rij.lt.r0ijsq) then
4992             evdwij=0.25d0*(rij-r0ijsq)**2
4993             fac=rij-r0ijsq
4994           else
4995             evdwij=0.0d0
4996             fac=0.0d0
4997           endif
4998           evdw2=evdw2+evdwij
4999 C
5000 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
5001 C
5002           ggg(1)=xj*fac
5003           ggg(2)=yj*fac
5004           ggg(3)=zj*fac
5005 cgrad          if (j.lt.i) then
5006 cd          write (iout,*) 'j<i'
5007 C Uncomment following three lines for SC-p interactions
5008 c           do k=1,3
5009 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
5010 c           enddo
5011 cgrad          else
5012 cd          write (iout,*) 'j>i'
5013 cgrad            do k=1,3
5014 cgrad              ggg(k)=-ggg(k)
5015 C Uncomment following line for SC-p interactions
5016 c             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
5017 cgrad            enddo
5018 cgrad          endif
5019 cgrad          do k=1,3
5020 cgrad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
5021 cgrad          enddo
5022 cgrad          kstart=min0(i+1,j)
5023 cgrad          kend=max0(i-1,j-1)
5024 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
5025 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
5026 cgrad          do k=kstart,kend
5027 cgrad            do l=1,3
5028 cgrad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
5029 cgrad            enddo
5030 cgrad          enddo
5031           do k=1,3
5032             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
5033             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
5034           enddo
5035         enddo
5036
5037         enddo ! iint
5038       enddo ! i
5039 C      enddo !zshift
5040 C      enddo !yshift
5041 C      enddo !xshift
5042       return
5043       end
5044 C-----------------------------------------------------------------------------
5045       subroutine escp(evdw2,evdw2_14)
5046 C
5047 C This subroutine calculates the excluded-volume interaction energy between
5048 C peptide-group centers and side chains and its gradient in virtual-bond and
5049 C side-chain vectors.
5050 C
5051       implicit real*8 (a-h,o-z)
5052       include 'DIMENSIONS'
5053       include 'COMMON.GEO'
5054       include 'COMMON.VAR'
5055       include 'COMMON.LOCAL'
5056       include 'COMMON.CHAIN'
5057       include 'COMMON.DERIV'
5058       include 'COMMON.INTERACT'
5059       include 'COMMON.FFIELD'
5060       include 'COMMON.IOUNITS'
5061       include 'COMMON.CONTROL'
5062       include 'COMMON.SPLITELE'
5063       dimension ggg(3)
5064       evdw2=0.0D0
5065       evdw2_14=0.0d0
5066 c        print *,boxxsize,boxysize,boxzsize,'wymiary pudla'
5067 cd    print '(a)','Enter ESCP'
5068 cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
5069 C      do xshift=-1,1
5070 C      do yshift=-1,1
5071 C      do zshift=-1,1
5072       do i=iatscp_s,iatscp_e
5073         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
5074         iteli=itel(i)
5075         xi=0.5D0*(c(1,i)+c(1,i+1))
5076         yi=0.5D0*(c(2,i)+c(2,i+1))
5077         zi=0.5D0*(c(3,i)+c(3,i+1))
5078           xi=mod(xi,boxxsize)
5079           if (xi.lt.0) xi=xi+boxxsize
5080           yi=mod(yi,boxysize)
5081           if (yi.lt.0) yi=yi+boxysize
5082           zi=mod(zi,boxzsize)
5083           if (zi.lt.0) zi=zi+boxzsize
5084 c          xi=xi+xshift*boxxsize
5085 c          yi=yi+yshift*boxysize
5086 c          zi=zi+zshift*boxzsize
5087 c        print *,xi,yi,zi,'polozenie i'
5088 C Return atom into box, boxxsize is size of box in x dimension
5089 c  134   continue
5090 c        if (xi.gt.((xshift+0.5d0)*boxxsize)) xi=xi-boxxsize
5091 c        if (xi.lt.((xshift-0.5d0)*boxxsize)) xi=xi+boxxsize
5092 C Condition for being inside the proper box
5093 c        if ((xi.gt.((xshift+0.5d0)*boxxsize)).or.
5094 c     &       (xi.lt.((xshift-0.5d0)*boxxsize))) then
5095 c        go to 134
5096 c        endif
5097 c  135   continue
5098 c          print *,xi,boxxsize,"pierwszy"
5099
5100 c        if (yi.gt.((yshift+0.5d0)*boxysize)) yi=yi-boxysize
5101 c        if (yi.lt.((yshift-0.5d0)*boxysize)) yi=yi+boxysize
5102 C Condition for being inside the proper box
5103 c        if ((yi.gt.((yshift+0.5d0)*boxysize)).or.
5104 c     &       (yi.lt.((yshift-0.5d0)*boxysize))) then
5105 c        go to 135
5106 c        endif
5107 c  136   continue
5108 c        if (zi.gt.((zshift+0.5d0)*boxzsize)) zi=zi-boxzsize
5109 c        if (zi.lt.((zshift-0.5d0)*boxzsize)) zi=zi+boxzsize
5110 C Condition for being inside the proper box
5111 c        if ((zi.gt.((zshift+0.5d0)*boxzsize)).or.
5112 c     &       (zi.lt.((zshift-0.5d0)*boxzsize))) then
5113 c        go to 136
5114 c        endif
5115         do iint=1,nscp_gr(i)
5116
5117         do j=iscpstart(i,iint),iscpend(i,iint)
5118           itypj=iabs(itype(j))
5119           if (itypj.eq.ntyp1) cycle
5120 C Uncomment following three lines for SC-p interactions
5121 c         xj=c(1,nres+j)-xi
5122 c         yj=c(2,nres+j)-yi
5123 c         zj=c(3,nres+j)-zi
5124 C Uncomment following three lines for Ca-p interactions
5125           xj=c(1,j)
5126           yj=c(2,j)
5127           zj=c(3,j)
5128           xj=mod(xj,boxxsize)
5129           if (xj.lt.0) xj=xj+boxxsize
5130           yj=mod(yj,boxysize)
5131           if (yj.lt.0) yj=yj+boxysize
5132           zj=mod(zj,boxzsize)
5133           if (zj.lt.0) zj=zj+boxzsize
5134 c  174   continue
5135 c        if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
5136 c        if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
5137 C Condition for being inside the proper box
5138 c        if ((xj.gt.((0.5d0)*boxxsize)).or.
5139 c     &       (xj.lt.((-0.5d0)*boxxsize))) then
5140 c        go to 174
5141 c        endif
5142 c  175   continue
5143 c        if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
5144 c        if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
5145 cC Condition for being inside the proper box
5146 c        if ((yj.gt.((0.5d0)*boxysize)).or.
5147 c     &       (yj.lt.((-0.5d0)*boxysize))) then
5148 c        go to 175
5149 c        endif
5150 c  176   continue
5151 c        if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
5152 c        if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
5153 C Condition for being inside the proper box
5154 c        if ((zj.gt.((0.5d0)*boxzsize)).or.
5155 c     &       (zj.lt.((-0.5d0)*boxzsize))) then
5156 c        go to 176
5157 c        endif
5158 CHERE IS THE CALCULATION WHICH MIRROR IMAGE IS THE CLOSEST ONE
5159       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
5160       xj_safe=xj
5161       yj_safe=yj
5162       zj_safe=zj
5163       subchap=0
5164       do xshift=-1,1
5165       do yshift=-1,1
5166       do zshift=-1,1
5167           xj=xj_safe+xshift*boxxsize
5168           yj=yj_safe+yshift*boxysize
5169           zj=zj_safe+zshift*boxzsize
5170           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
5171           if(dist_temp.lt.dist_init) then
5172             dist_init=dist_temp
5173             xj_temp=xj
5174             yj_temp=yj
5175             zj_temp=zj
5176             subchap=1
5177           endif
5178        enddo
5179        enddo
5180        enddo
5181        if (subchap.eq.1) then
5182           xj=xj_temp-xi
5183           yj=yj_temp-yi
5184           zj=zj_temp-zi
5185        else
5186           xj=xj_safe-xi
5187           yj=yj_safe-yi
5188           zj=zj_safe-zi
5189        endif
5190 c          print *,xj,yj,zj,'polozenie j'
5191           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
5192 c          print *,rrij
5193           sss=sscale(1.0d0/(dsqrt(rrij)))
5194 c          print *,r_cut,1.0d0/dsqrt(rrij),sss,'tu patrz'
5195 c          if (sss.eq.0) print *,'czasem jest OK'
5196           if (sss.le.0.0d0) cycle
5197           sssgrad=sscagrad(1.0d0/(dsqrt(rrij)))
5198           fac=rrij**expon2
5199           e1=fac*fac*aad(itypj,iteli)
5200           e2=fac*bad(itypj,iteli)
5201           if (iabs(j-i) .le. 2) then
5202             e1=scal14*e1
5203             e2=scal14*e2
5204             evdw2_14=evdw2_14+(e1+e2)*sss
5205           endif
5206           evdwij=e1+e2
5207           evdw2=evdw2+evdwij*sss
5208           if (energy_dec) write (iout,'(a6,2i5,0pf7.3,2i3,3e11.3)')
5209      &        'evdw2',i,j,evdwij,iteli,itypj,fac,aad(itypj,iteli),
5210      &       bad(itypj,iteli)
5211 C
5212 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
5213 C
5214           fac=-(evdwij+e1)*rrij*sss
5215           fac=fac+(evdwij)*sssgrad*dsqrt(rrij)/expon
5216           ggg(1)=xj*fac
5217           ggg(2)=yj*fac
5218           ggg(3)=zj*fac
5219 cgrad          if (j.lt.i) then
5220 cd          write (iout,*) 'j<i'
5221 C Uncomment following three lines for SC-p interactions
5222 c           do k=1,3
5223 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
5224 c           enddo
5225 cgrad          else
5226 cd          write (iout,*) 'j>i'
5227 cgrad            do k=1,3
5228 cgrad              ggg(k)=-ggg(k)
5229 C Uncomment following line for SC-p interactions
5230 ccgrad             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
5231 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
5232 cgrad            enddo
5233 cgrad          endif
5234 cgrad          do k=1,3
5235 cgrad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
5236 cgrad          enddo
5237 cgrad          kstart=min0(i+1,j)
5238 cgrad          kend=max0(i-1,j-1)
5239 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
5240 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
5241 cgrad          do k=kstart,kend
5242 cgrad            do l=1,3
5243 cgrad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
5244 cgrad            enddo
5245 cgrad          enddo
5246           do k=1,3
5247             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
5248             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
5249           enddo
5250 c        endif !endif for sscale cutoff
5251         enddo ! j
5252
5253         enddo ! iint
5254       enddo ! i
5255 c      enddo !zshift
5256 c      enddo !yshift
5257 c      enddo !xshift
5258       do i=1,nct
5259         do j=1,3
5260           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
5261           gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
5262           gradx_scp(j,i)=expon*gradx_scp(j,i)
5263         enddo
5264       enddo
5265 C******************************************************************************
5266 C
5267 C                              N O T E !!!
5268 C
5269 C To save time the factor EXPON has been extracted from ALL components
5270 C of GVDWC and GRADX. Remember to multiply them by this factor before further
5271 C use!
5272 C
5273 C******************************************************************************
5274       return
5275       end
5276 C--------------------------------------------------------------------------
5277       subroutine edis(ehpb)
5278 C
5279 C Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors.
5280 C
5281       implicit real*8 (a-h,o-z)
5282       include 'DIMENSIONS'
5283       include 'COMMON.SBRIDGE'
5284       include 'COMMON.CHAIN'
5285       include 'COMMON.DERIV'
5286       include 'COMMON.VAR'
5287       include 'COMMON.INTERACT'
5288       include 'COMMON.IOUNITS'
5289       include 'COMMON.CONTROL'
5290       dimension ggg(3)
5291       ehpb=0.0D0
5292       do i=1,3
5293        ggg(i)=0.0d0
5294       enddo
5295 C      write (iout,*) ,"link_end",link_end,constr_dist
5296 cd      write(iout,*)'edis: nhpb=',nhpb,' fbr=',fbr
5297 cd      write(iout,*)'link_start=',link_start,' link_end=',link_end
5298       if (link_end.eq.0) return
5299       do i=link_start,link_end
5300 C If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a
5301 C CA-CA distance used in regularization of structure.
5302         ii=ihpb(i)
5303         jj=jhpb(i)
5304 C iii and jjj point to the residues for which the distance is assigned.
5305         if (ii.gt.nres) then
5306           iii=ii-nres
5307           jjj=jj-nres
5308         else
5309           iii=ii
5310           jjj=jj
5311         endif
5312 c        write (iout,*) "i",i," ii",ii," iii",iii," jj",jj," jjj",jjj,
5313 c     &    dhpb(i),dhpb1(i),forcon(i)
5314 C 24/11/03 AL: SS bridges handled separately because of introducing a specific
5315 C    distance and angle dependent SS bond potential.
5316 C        if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and.
5317 C     & iabs(itype(jjj)).eq.1) then
5318 cmc        if (ii.gt.nres .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then
5319 C 18/07/06 MC: Use the convention that the first nss pairs are SS bonds
5320         if (.not.dyn_ss .and. i.le.nss) then
5321 C 15/02/13 CC dynamic SSbond - additional check
5322          if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and.
5323      & iabs(itype(jjj)).eq.1) then
5324           call ssbond_ene(iii,jjj,eij)
5325           ehpb=ehpb+2*eij
5326          endif
5327 cd          write (iout,*) "eij",eij
5328 cd   &   ' waga=',waga,' fac=',fac
5329         else if (ii.gt.nres .and. jj.gt.nres) then
5330 c Restraints from contact prediction
5331           dd=dist(ii,jj)
5332           if (constr_dist.eq.11) then
5333             ehpb=ehpb+fordepth(i)**4.0d0
5334      &          *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i))
5335             fac=fordepth(i)**4.0d0
5336      &          *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd
5337           if (energy_dec) write (iout,'(a6,2i5,3f8.3)') "edisl",ii,jj,
5338      &    ehpb,fordepth(i),dd
5339            else
5340           if (dhpb1(i).gt.0.0d0) then
5341             ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
5342             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
5343 c            write (iout,*) "beta nmr",
5344 c     &        dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
5345           else
5346             dd=dist(ii,jj)
5347             rdis=dd-dhpb(i)
5348 C Get the force constant corresponding to this distance.
5349             waga=forcon(i)
5350 C Calculate the contribution to energy.
5351             ehpb=ehpb+waga*rdis*rdis
5352 c            write (iout,*) "beta reg",dd,waga*rdis*rdis
5353 C
5354 C Evaluate gradient.
5355 C
5356             fac=waga*rdis/dd
5357           endif
5358           endif
5359           do j=1,3
5360             ggg(j)=fac*(c(j,jj)-c(j,ii))
5361           enddo
5362           do j=1,3
5363             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
5364             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
5365           enddo
5366           do k=1,3
5367             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
5368             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
5369           enddo
5370         else
5371 C Calculate the distance between the two points and its difference from the
5372 C target distance.
5373           dd=dist(ii,jj)
5374           if (constr_dist.eq.11) then
5375             ehpb=ehpb+fordepth(i)**4.0d0
5376      &           *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i))
5377             fac=fordepth(i)**4.0d0
5378      &           *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd
5379           if (energy_dec) write (iout,'(a6,2i5,3f8.3)') "edisl",ii,jj,
5380      &    ehpb,fordepth(i),dd
5381            else
5382           if (dhpb1(i).gt.0.0d0) then
5383             ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
5384             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
5385 c            write (iout,*) "alph nmr",
5386 c     &        dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
5387           else
5388             rdis=dd-dhpb(i)
5389 C Get the force constant corresponding to this distance.
5390             waga=forcon(i)
5391 C Calculate the contribution to energy.
5392             ehpb=ehpb+waga*rdis*rdis
5393 c            write (iout,*) "alpha reg",dd,waga*rdis*rdis
5394 C
5395 C Evaluate gradient.
5396 C
5397             fac=waga*rdis/dd
5398           endif
5399           endif
5400             do j=1,3
5401               ggg(j)=fac*(c(j,jj)-c(j,ii))
5402             enddo
5403 cd      print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
5404 C If this is a SC-SC distance, we need to calculate the contributions to the
5405 C Cartesian gradient in the SC vectors (ghpbx).
5406           if (iii.lt.ii) then
5407           do j=1,3
5408             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
5409             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
5410           enddo
5411           endif
5412 cgrad        do j=iii,jjj-1
5413 cgrad          do k=1,3
5414 cgrad            ghpbc(k,j)=ghpbc(k,j)+ggg(k)
5415 cgrad          enddo
5416 cgrad        enddo
5417           do k=1,3
5418             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
5419             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
5420           enddo
5421         endif
5422       enddo
5423       if (constr_dist.ne.11) ehpb=0.5D0*ehpb
5424       return
5425       end
5426 C--------------------------------------------------------------------------
5427       subroutine ssbond_ene(i,j,eij)
5428 C
5429 C Calculate the distance and angle dependent SS-bond potential energy
5430 C using a free-energy function derived based on RHF/6-31G** ab initio
5431 C calculations of diethyl disulfide.
5432 C
5433 C A. Liwo and U. Kozlowska, 11/24/03
5434 C
5435       implicit real*8 (a-h,o-z)
5436       include 'DIMENSIONS'
5437       include 'COMMON.SBRIDGE'
5438       include 'COMMON.CHAIN'
5439       include 'COMMON.DERIV'
5440       include 'COMMON.LOCAL'
5441       include 'COMMON.INTERACT'
5442       include 'COMMON.VAR'
5443       include 'COMMON.IOUNITS'
5444       double precision erij(3),dcosom1(3),dcosom2(3),gg(3)
5445       itypi=iabs(itype(i))
5446       xi=c(1,nres+i)
5447       yi=c(2,nres+i)
5448       zi=c(3,nres+i)
5449       dxi=dc_norm(1,nres+i)
5450       dyi=dc_norm(2,nres+i)
5451       dzi=dc_norm(3,nres+i)
5452 c      dsci_inv=dsc_inv(itypi)
5453       dsci_inv=vbld_inv(nres+i)
5454       itypj=iabs(itype(j))
5455 c      dscj_inv=dsc_inv(itypj)
5456       dscj_inv=vbld_inv(nres+j)
5457       xj=c(1,nres+j)-xi
5458       yj=c(2,nres+j)-yi
5459       zj=c(3,nres+j)-zi
5460       dxj=dc_norm(1,nres+j)
5461       dyj=dc_norm(2,nres+j)
5462       dzj=dc_norm(3,nres+j)
5463       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
5464       rij=dsqrt(rrij)
5465       erij(1)=xj*rij
5466       erij(2)=yj*rij
5467       erij(3)=zj*rij
5468       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
5469       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
5470       om12=dxi*dxj+dyi*dyj+dzi*dzj
5471       do k=1,3
5472         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
5473         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
5474       enddo
5475       rij=1.0d0/rij
5476       deltad=rij-d0cm
5477       deltat1=1.0d0-om1
5478       deltat2=1.0d0+om2
5479       deltat12=om2-om1+2.0d0
5480       cosphi=om12-om1*om2
5481       eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2)
5482      &  +akct*deltad*deltat12
5483      &  +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi+ebr
5484 c      write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth,
5485 c     &  " akct",akct," deltad",deltad," deltat",deltat1,deltat2,
5486 c     &  " deltat12",deltat12," eij",eij
5487       ed=2*akcm*deltad+akct*deltat12
5488       pom1=akct*deltad
5489       pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
5490       eom1=-2*akth*deltat1-pom1-om2*pom2
5491       eom2= 2*akth*deltat2+pom1-om1*pom2
5492       eom12=pom2
5493       do k=1,3
5494         ggk=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
5495         ghpbx(k,i)=ghpbx(k,i)-ggk
5496      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
5497      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
5498         ghpbx(k,j)=ghpbx(k,j)+ggk
5499      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
5500      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
5501         ghpbc(k,i)=ghpbc(k,i)-ggk
5502         ghpbc(k,j)=ghpbc(k,j)+ggk
5503       enddo
5504 C
5505 C Calculate the components of the gradient in DC and X
5506 C
5507 cgrad      do k=i,j-1
5508 cgrad        do l=1,3
5509 cgrad          ghpbc(l,k)=ghpbc(l,k)+gg(l)
5510 cgrad        enddo
5511 cgrad      enddo
5512       return
5513       end
5514 C--------------------------------------------------------------------------
5515       subroutine ebond(estr)
5516 c
5517 c Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
5518 c
5519       implicit real*8 (a-h,o-z)
5520       include 'DIMENSIONS'
5521       include 'COMMON.LOCAL'
5522       include 'COMMON.GEO'
5523       include 'COMMON.INTERACT'
5524       include 'COMMON.DERIV'
5525       include 'COMMON.VAR'
5526       include 'COMMON.CHAIN'
5527       include 'COMMON.IOUNITS'
5528       include 'COMMON.NAMES'
5529       include 'COMMON.FFIELD'
5530       include 'COMMON.CONTROL'
5531       include 'COMMON.SETUP'
5532       double precision u(3),ud(3)
5533       estr=0.0d0
5534       estr1=0.0d0
5535       do i=ibondp_start,ibondp_end
5536         if (itype(i-1).eq.ntyp1 .and. itype(i).eq.ntyp1) cycle
5537 c          estr1=estr1+gnmr1(vbld(i),-1.0d0,distchainmax)
5538 c          do j=1,3
5539 c          gradb(j,i-1)=gnmr1prim(vbld(i),-1.0d0,distchainmax)
5540 c     &      *dc(j,i-1)/vbld(i)
5541 c          enddo
5542 c          if (energy_dec) write(iout,*)
5543 c     &       "estr1",i,gnmr1(vbld(i),-1.0d0,distchainmax)
5544 c        else
5545 C       Checking if it involves dummy (NH3+ or COO-) group
5546          if (itype(i-1).eq.ntyp1 .or. itype(i).eq.ntyp1) then
5547 C YES   vbldpDUM is the equlibrium length of spring for Dummy atom
5548         diff = vbld(i)-vbldpDUM
5549          else
5550 C NO    vbldp0 is the equlibrium lenght of spring for peptide group
5551         diff = vbld(i)-vbldp0
5552          endif
5553         if (energy_dec)    write (iout,'(a7,i5,4f7.3)')
5554      &     "estr bb",i,vbld(i),vbldp0,diff,AKP*diff*diff
5555         estr=estr+diff*diff
5556         do j=1,3
5557           gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)
5558         enddo
5559 c        write (iout,'(i5,3f10.5)') i,(gradb(j,i-1),j=1,3)
5560 c        endif
5561       enddo
5562       estr=0.5d0*AKP*estr+estr1
5563 c
5564 c 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included
5565 c
5566       do i=ibond_start,ibond_end
5567         iti=iabs(itype(i))
5568         if (iti.ne.10 .and. iti.ne.ntyp1) then
5569           nbi=nbondterm(iti)
5570           if (nbi.eq.1) then
5571             diff=vbld(i+nres)-vbldsc0(1,iti)
5572             if (energy_dec)  write (iout,*)
5573      &      "estr sc",i,iti,vbld(i+nres),vbldsc0(1,iti),diff,
5574      &      AKSC(1,iti),AKSC(1,iti)*diff*diff
5575             estr=estr+0.5d0*AKSC(1,iti)*diff*diff
5576             do j=1,3
5577               gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
5578             enddo
5579           else
5580             do j=1,nbi
5581               diff=vbld(i+nres)-vbldsc0(j,iti)
5582               ud(j)=aksc(j,iti)*diff
5583               u(j)=abond0(j,iti)+0.5d0*ud(j)*diff
5584             enddo
5585             uprod=u(1)
5586             do j=2,nbi
5587               uprod=uprod*u(j)
5588             enddo
5589             usum=0.0d0
5590             usumsqder=0.0d0
5591             do j=1,nbi
5592               uprod1=1.0d0
5593               uprod2=1.0d0
5594               do k=1,nbi
5595                 if (k.ne.j) then
5596                   uprod1=uprod1*u(k)
5597                   uprod2=uprod2*u(k)*u(k)
5598                 endif
5599               enddo
5600               usum=usum+uprod1
5601               usumsqder=usumsqder+ud(j)*uprod2
5602             enddo
5603             estr=estr+uprod/usum
5604             do j=1,3
5605              gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
5606             enddo
5607           endif
5608         endif
5609       enddo
5610       return
5611       end
5612 #ifdef CRYST_THETA
5613 C--------------------------------------------------------------------------
5614       subroutine ebend(etheta,ethetacnstr)
5615 C
5616 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
5617 C angles gamma and its derivatives in consecutive thetas and gammas.
5618 C
5619       implicit real*8 (a-h,o-z)
5620       include 'DIMENSIONS'
5621       include 'COMMON.LOCAL'
5622       include 'COMMON.GEO'
5623       include 'COMMON.INTERACT'
5624       include 'COMMON.DERIV'
5625       include 'COMMON.VAR'
5626       include 'COMMON.CHAIN'
5627       include 'COMMON.IOUNITS'
5628       include 'COMMON.NAMES'
5629       include 'COMMON.FFIELD'
5630       include 'COMMON.CONTROL'
5631       include 'COMMON.TORCNSTR'
5632       common /calcthet/ term1,term2,termm,diffak,ratak,
5633      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
5634      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
5635       double precision y(2),z(2)
5636       delta=0.02d0*pi
5637 c      time11=dexp(-2*time)
5638 c      time12=1.0d0
5639       etheta=0.0D0
5640 c     write (*,'(a,i2)') 'EBEND ICG=',icg
5641       do i=ithet_start,ithet_end
5642         if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
5643      &  .or.itype(i).eq.ntyp1) cycle
5644 C Zero the energy function and its derivative at 0 or pi.
5645         call splinthet(theta(i),0.5d0*delta,ss,ssd)
5646         it=itype(i-1)
5647         ichir1=isign(1,itype(i-2))
5648         ichir2=isign(1,itype(i))
5649          if (itype(i-2).eq.10) ichir1=isign(1,itype(i-1))
5650          if (itype(i).eq.10) ichir2=isign(1,itype(i-1))
5651          if (itype(i-1).eq.10) then
5652           itype1=isign(10,itype(i-2))
5653           ichir11=isign(1,itype(i-2))
5654           ichir12=isign(1,itype(i-2))
5655           itype2=isign(10,itype(i))
5656           ichir21=isign(1,itype(i))
5657           ichir22=isign(1,itype(i))
5658          endif
5659
5660         if (i.gt.3 .and. itype(i-3).ne.ntyp1) then
5661 #ifdef OSF
5662           phii=phi(i)
5663           if (phii.ne.phii) phii=150.0
5664 #else
5665           phii=phi(i)
5666 #endif
5667           y(1)=dcos(phii)
5668           y(2)=dsin(phii)
5669         else
5670           y(1)=0.0D0
5671           y(2)=0.0D0
5672         endif
5673         if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
5674 #ifdef OSF
5675           phii1=phi(i+1)
5676           if (phii1.ne.phii1) phii1=150.0
5677           phii1=pinorm(phii1)
5678           z(1)=cos(phii1)
5679 #else
5680           phii1=phi(i+1)
5681 #endif
5682           z(1)=dcos(phii1)
5683           z(2)=dsin(phii1)
5684         else
5685           z(1)=0.0D0
5686           z(2)=0.0D0
5687         endif
5688 C Calculate the "mean" value of theta from the part of the distribution
5689 C dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2).
5690 C In following comments this theta will be referred to as t_c.
5691         thet_pred_mean=0.0d0
5692         do k=1,2
5693             athetk=athet(k,it,ichir1,ichir2)
5694             bthetk=bthet(k,it,ichir1,ichir2)
5695           if (it.eq.10) then
5696              athetk=athet(k,itype1,ichir11,ichir12)
5697              bthetk=bthet(k,itype2,ichir21,ichir22)
5698           endif
5699          thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k)
5700 c         write(iout,*) 'chuj tu', y(k),z(k)
5701         enddo
5702         dthett=thet_pred_mean*ssd
5703         thet_pred_mean=thet_pred_mean*ss+a0thet(it)
5704 C Derivatives of the "mean" values in gamma1 and gamma2.
5705         dthetg1=(-athet(1,it,ichir1,ichir2)*y(2)
5706      &+athet(2,it,ichir1,ichir2)*y(1))*ss
5707          dthetg2=(-bthet(1,it,ichir1,ichir2)*z(2)
5708      &          +bthet(2,it,ichir1,ichir2)*z(1))*ss
5709          if (it.eq.10) then
5710       dthetg1=(-athet(1,itype1,ichir11,ichir12)*y(2)
5711      &+athet(2,itype1,ichir11,ichir12)*y(1))*ss
5712         dthetg2=(-bthet(1,itype2,ichir21,ichir22)*z(2)
5713      &         +bthet(2,itype2,ichir21,ichir22)*z(1))*ss
5714          endif
5715         if (theta(i).gt.pi-delta) then
5716           call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,
5717      &         E_tc0)
5718           call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0)
5719           call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
5720           call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,
5721      &        E_theta)
5722           call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,
5723      &        E_tc)
5724         else if (theta(i).lt.delta) then
5725           call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0)
5726           call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
5727           call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,
5728      &        E_theta)
5729           call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0)
5730           call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,
5731      &        E_tc)
5732         else
5733           call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,
5734      &        E_theta,E_tc)
5735         endif
5736         etheta=etheta+ethetai
5737         if (energy_dec) write (iout,'(a6,i5,0pf7.3,f7.3,i5)')
5738      &      'ebend',i,ethetai,theta(i),itype(i)
5739         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1
5740         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2
5741         gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)+gloc(nphi+i-2,icg)
5742       enddo
5743       ethetacnstr=0.0d0
5744 C      print *,ithetaconstr_start,ithetaconstr_end,"TU"
5745       do i=ithetaconstr_start,ithetaconstr_end
5746         itheta=itheta_constr(i)
5747         thetiii=theta(itheta)
5748         difi=pinorm(thetiii-theta_constr0(i))
5749         if (difi.gt.theta_drange(i)) then
5750           difi=difi-theta_drange(i)
5751           ethetacnstr=ethetcnstr+0.25d0*for_thet_constr(i)*difi**4
5752           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
5753      &    +for_thet_constr(i)*difi**3
5754         else if (difi.lt.-drange(i)) then
5755           difi=difi+drange(i)
5756           ethetacnstr=ethetcnstr+0.25d0*for_thet_constr(i)*difi**4
5757           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
5758      &    +for_thet_constr(i)*difi**3
5759         else
5760           difi=0.0
5761         endif
5762        if (energy_dec) then
5763         write (iout,'(a6,2i5,4f8.3,2e14.5)') "ethetc",
5764      &    i,itheta,rad2deg*thetiii,
5765      &    rad2deg*theta_constr0(i),  rad2deg*theta_drange(i),
5766      &    rad2deg*difi,0.25d0*for_thet_constr(i)*difi**4,
5767      &    gloc(itheta+nphi-2,icg)
5768         endif
5769       enddo
5770
5771 C Ufff.... We've done all this!!!
5772       return
5773       end
5774 C---------------------------------------------------------------------------
5775       subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,
5776      &     E_tc)
5777       implicit real*8 (a-h,o-z)
5778       include 'DIMENSIONS'
5779       include 'COMMON.LOCAL'
5780       include 'COMMON.IOUNITS'
5781       common /calcthet/ term1,term2,termm,diffak,ratak,
5782      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
5783      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
5784 C Calculate the contributions to both Gaussian lobes.
5785 C 6/6/97 - Deform the Gaussians using the factor of 1/(1+time)
5786 C The "polynomial part" of the "standard deviation" of this part of
5787 C the distributioni.
5788 ccc        write (iout,*) thetai,thet_pred_mean
5789         sig=polthet(3,it)
5790         do j=2,0,-1
5791           sig=sig*thet_pred_mean+polthet(j,it)
5792         enddo
5793 C Derivative of the "interior part" of the "standard deviation of the"
5794 C gamma-dependent Gaussian lobe in t_c.
5795         sigtc=3*polthet(3,it)
5796         do j=2,1,-1
5797           sigtc=sigtc*thet_pred_mean+j*polthet(j,it)
5798         enddo
5799         sigtc=sig*sigtc
5800 C Set the parameters of both Gaussian lobes of the distribution.
5801 C "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc)
5802         fac=sig*sig+sigc0(it)
5803         sigcsq=fac+fac
5804         sigc=1.0D0/sigcsq
5805 C Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c
5806         sigsqtc=-4.0D0*sigcsq*sigtc
5807 c       print *,i,sig,sigtc,sigsqtc
5808 C Following variable (sigtc) is d[sigma(t_c)]/dt_c
5809         sigtc=-sigtc/(fac*fac)
5810 C Following variable is sigma(t_c)**(-2)
5811         sigcsq=sigcsq*sigcsq
5812         sig0i=sig0(it)
5813         sig0inv=1.0D0/sig0i**2
5814         delthec=thetai-thet_pred_mean
5815         delthe0=thetai-theta0i
5816         term1=-0.5D0*sigcsq*delthec*delthec
5817         term2=-0.5D0*sig0inv*delthe0*delthe0
5818 C        write (iout,*)'term1',term1,term2,sigcsq,delthec,sig0inv,delthe0
5819 C Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and
5820 C NaNs in taking the logarithm. We extract the largest exponent which is added
5821 C to the energy (this being the log of the distribution) at the end of energy
5822 C term evaluation for this virtual-bond angle.
5823         if (term1.gt.term2) then
5824           termm=term1
5825           term2=dexp(term2-termm)
5826           term1=1.0d0
5827         else
5828           termm=term2
5829           term1=dexp(term1-termm)
5830           term2=1.0d0
5831         endif
5832 C The ratio between the gamma-independent and gamma-dependent lobes of
5833 C the distribution is a Gaussian function of thet_pred_mean too.
5834         diffak=gthet(2,it)-thet_pred_mean
5835         ratak=diffak/gthet(3,it)**2
5836         ak=dexp(gthet(1,it)-0.5D0*diffak*ratak)
5837 C Let's differentiate it in thet_pred_mean NOW.
5838         aktc=ak*ratak
5839 C Now put together the distribution terms to make complete distribution.
5840         termexp=term1+ak*term2
5841         termpre=sigc+ak*sig0i
5842 C Contribution of the bending energy from this theta is just the -log of
5843 C the sum of the contributions from the two lobes and the pre-exponential
5844 C factor. Simple enough, isn't it?
5845         ethetai=(-dlog(termexp)-termm+dlog(termpre))
5846 C       write (iout,*) 'termexp',termexp,termm,termpre,i
5847 C NOW the derivatives!!!
5848 C 6/6/97 Take into account the deformation.
5849         E_theta=(delthec*sigcsq*term1
5850      &       +ak*delthe0*sig0inv*term2)/termexp
5851         E_tc=((sigtc+aktc*sig0i)/termpre
5852      &      -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+
5853      &       aktc*term2)/termexp)
5854       return
5855       end
5856 c-----------------------------------------------------------------------------
5857       subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)
5858       implicit real*8 (a-h,o-z)
5859       include 'DIMENSIONS'
5860       include 'COMMON.LOCAL'
5861       include 'COMMON.IOUNITS'
5862       common /calcthet/ term1,term2,termm,diffak,ratak,
5863      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
5864      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
5865       delthec=thetai-thet_pred_mean
5866       delthe0=thetai-theta0i
5867 C "Thank you" to MAPLE (probably spared one day of hand-differentiation).
5868       t3 = thetai-thet_pred_mean
5869       t6 = t3**2
5870       t9 = term1
5871       t12 = t3*sigcsq
5872       t14 = t12+t6*sigsqtc
5873       t16 = 1.0d0
5874       t21 = thetai-theta0i
5875       t23 = t21**2
5876       t26 = term2
5877       t27 = t21*t26
5878       t32 = termexp
5879       t40 = t32**2
5880       E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9
5881      & -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40
5882      & *(-t12*t9-ak*sig0inv*t27)
5883       return
5884       end
5885 #else
5886 C--------------------------------------------------------------------------
5887       subroutine ebend(etheta,ethetacnstr)
5888 C
5889 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
5890 C angles gamma and its derivatives in consecutive thetas and gammas.
5891 C ab initio-derived potentials from
5892 c Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203
5893 C
5894       implicit real*8 (a-h,o-z)
5895       include 'DIMENSIONS'
5896       include 'COMMON.LOCAL'
5897       include 'COMMON.GEO'
5898       include 'COMMON.INTERACT'
5899       include 'COMMON.DERIV'
5900       include 'COMMON.VAR'
5901       include 'COMMON.CHAIN'
5902       include 'COMMON.IOUNITS'
5903       include 'COMMON.NAMES'
5904       include 'COMMON.FFIELD'
5905       include 'COMMON.CONTROL'
5906       include 'COMMON.TORCNSTR'
5907       double precision coskt(mmaxtheterm),sinkt(mmaxtheterm),
5908      & cosph1(maxsingle),sinph1(maxsingle),cosph2(maxsingle),
5909      & sinph2(maxsingle),cosph1ph2(maxdouble,maxdouble),
5910      & sinph1ph2(maxdouble,maxdouble)
5911       logical lprn /.false./, lprn1 /.false./
5912       etheta=0.0D0
5913       do i=ithet_start,ithet_end
5914 c        print *,i,itype(i-1),itype(i),itype(i-2)
5915         if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
5916      &  .or.itype(i).eq.ntyp1) cycle
5917 C        print *,i,theta(i)
5918         if (iabs(itype(i+1)).eq.20) iblock=2
5919         if (iabs(itype(i+1)).ne.20) iblock=1
5920         dethetai=0.0d0
5921         dephii=0.0d0
5922         dephii1=0.0d0
5923         theti2=0.5d0*theta(i)
5924         ityp2=ithetyp((itype(i-1)))
5925         do k=1,nntheterm
5926           coskt(k)=dcos(k*theti2)
5927           sinkt(k)=dsin(k*theti2)
5928         enddo
5929 C        print *,ethetai
5930         if (i.gt.3 .and. itype(i-3).ne.ntyp1) then
5931 #ifdef OSF
5932           phii=phi(i)
5933           if (phii.ne.phii) phii=150.0
5934 #else
5935           phii=phi(i)
5936 #endif
5937           ityp1=ithetyp((itype(i-2)))
5938 C propagation of chirality for glycine type
5939           do k=1,nsingle
5940             cosph1(k)=dcos(k*phii)
5941             sinph1(k)=dsin(k*phii)
5942           enddo
5943         else
5944           phii=0.0d0
5945           do k=1,nsingle
5946           ityp1=ithetyp((itype(i-2)))
5947             cosph1(k)=0.0d0
5948             sinph1(k)=0.0d0
5949           enddo
5950         endif
5951         if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
5952 #ifdef OSF
5953           phii1=phi(i+1)
5954           if (phii1.ne.phii1) phii1=150.0
5955           phii1=pinorm(phii1)
5956 #else
5957           phii1=phi(i+1)
5958 #endif
5959           ityp3=ithetyp((itype(i)))
5960           do k=1,nsingle
5961             cosph2(k)=dcos(k*phii1)
5962             sinph2(k)=dsin(k*phii1)
5963           enddo
5964         else
5965           phii1=0.0d0
5966           ityp3=ithetyp((itype(i)))
5967           do k=1,nsingle
5968             cosph2(k)=0.0d0
5969             sinph2(k)=0.0d0
5970           enddo
5971         endif
5972         ethetai=aa0thet(ityp1,ityp2,ityp3,iblock)
5973         do k=1,ndouble
5974           do l=1,k-1
5975             ccl=cosph1(l)*cosph2(k-l)
5976             ssl=sinph1(l)*sinph2(k-l)
5977             scl=sinph1(l)*cosph2(k-l)
5978             csl=cosph1(l)*sinph2(k-l)
5979             cosph1ph2(l,k)=ccl-ssl
5980             cosph1ph2(k,l)=ccl+ssl
5981             sinph1ph2(l,k)=scl+csl
5982             sinph1ph2(k,l)=scl-csl
5983           enddo
5984         enddo
5985         if (lprn) then
5986         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,
5987      &    " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
5988         write (iout,*) "coskt and sinkt"
5989         do k=1,nntheterm
5990           write (iout,*) k,coskt(k),sinkt(k)
5991         enddo
5992         endif
5993         do k=1,ntheterm
5994           ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3,iblock)*sinkt(k)
5995           dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3,iblock)
5996      &      *coskt(k)
5997           if (lprn)
5998      &    write (iout,*) "k",k,"
5999      &     aathet",aathet(k,ityp1,ityp2,ityp3,iblock),
6000      &     " ethetai",ethetai
6001         enddo
6002         if (lprn) then
6003         write (iout,*) "cosph and sinph"
6004         do k=1,nsingle
6005           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
6006         enddo
6007         write (iout,*) "cosph1ph2 and sinph2ph2"
6008         do k=2,ndouble
6009           do l=1,k-1
6010             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),
6011      &         sinph1ph2(l,k),sinph1ph2(k,l)
6012           enddo
6013         enddo
6014         write(iout,*) "ethetai",ethetai
6015         endif
6016 C       print *,ethetai
6017         do m=1,ntheterm2
6018           do k=1,nsingle
6019             aux=bbthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)
6020      &         +ccthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k)
6021      &         +ddthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)
6022      &         +eethet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k)
6023             ethetai=ethetai+sinkt(m)*aux
6024             dethetai=dethetai+0.5d0*m*aux*coskt(m)
6025             dephii=dephii+k*sinkt(m)*(
6026      &          ccthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)-
6027      &          bbthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k))
6028             dephii1=dephii1+k*sinkt(m)*(
6029      &          eethet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)-
6030      &          ddthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k))
6031             if (lprn)
6032      &      write (iout,*) "m",m," k",k," bbthet",
6033      &         bbthet(k,m,ityp1,ityp2,ityp3,iblock)," ccthet",
6034      &         ccthet(k,m,ityp1,ityp2,ityp3,iblock)," ddthet",
6035      &         ddthet(k,m,ityp1,ityp2,ityp3,iblock)," eethet",
6036      &         eethet(k,m,ityp1,ityp2,ityp3,iblock)," ethetai",ethetai
6037 C        print *,"tu",cosph1(k),sinph1(k),cosph2(k),sinph2(k)
6038           enddo
6039         enddo
6040 C        print *,"cosph1", (cosph1(k), k=1,nsingle)
6041 C        print *,"cosph2", (cosph2(k), k=1,nsingle)
6042 C        print *,"sinph1", (sinph1(k), k=1,nsingle)
6043 C        print *,"sinph2", (sinph2(k), k=1,nsingle)
6044         if (lprn)
6045      &  write(iout,*) "ethetai",ethetai
6046 C        print *,"tu",cosph1(k),sinph1(k),cosph2(k),sinph2(k)
6047         do m=1,ntheterm3
6048           do k=2,ndouble
6049             do l=1,k-1
6050               aux=ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
6051      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l)+
6052      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
6053      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)
6054               ethetai=ethetai+sinkt(m)*aux
6055               dethetai=dethetai+0.5d0*m*coskt(m)*aux
6056               dephii=dephii+l*sinkt(m)*(
6057      &           -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)-
6058      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
6059      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
6060      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
6061               dephii1=dephii1+(k-l)*sinkt(m)*(
6062      &           -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
6063      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
6064      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)-
6065      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
6066               if (lprn) then
6067               write (iout,*) "m",m," k",k," l",l," ffthet",
6068      &            ffthet(l,k,m,ityp1,ityp2,ityp3,iblock),
6069      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)," ggthet",
6070      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock),
6071      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock),
6072      &            " ethetai",ethetai
6073               write (iout,*) cosph1ph2(l,k)*sinkt(m),
6074      &            cosph1ph2(k,l)*sinkt(m),
6075      &            sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
6076               endif
6077             enddo
6078           enddo
6079         enddo
6080 10      continue
6081 c        lprn1=.true.
6082 C        print *,ethetai
6083         if (lprn1)
6084      &    write (iout,'(i2,3f8.1,9h ethetai ,f10.5)')
6085      &   i,theta(i)*rad2deg,phii*rad2deg,
6086      &   phii1*rad2deg,ethetai
6087 c        lprn1=.false.
6088         etheta=etheta+ethetai
6089         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
6090         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
6091         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)+wang*dethetai
6092       enddo
6093 C now constrains
6094       ethetacnstr=0.0d0
6095 C      print *,ithetaconstr_start,ithetaconstr_end,"TU"
6096       do i=ithetaconstr_start,ithetaconstr_end
6097         itheta=itheta_constr(i)
6098         thetiii=theta(itheta)
6099         difi=pinorm(thetiii-theta_constr0(i))
6100         if (difi.gt.theta_drange(i)) then
6101           difi=difi-theta_drange(i)
6102           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
6103           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
6104      &    +for_thet_constr(i)*difi**3
6105         else if (difi.lt.-drange(i)) then
6106           difi=difi+drange(i)
6107           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
6108           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
6109      &    +for_thet_constr(i)*difi**3
6110         else
6111           difi=0.0
6112         endif
6113        if (energy_dec) then
6114         write (iout,'(a6,2i5,4f8.3,2e14.5)') "ethetc",
6115      &    i,itheta,rad2deg*thetiii,
6116      &    rad2deg*theta_constr0(i),  rad2deg*theta_drange(i),
6117      &    rad2deg*difi,0.25d0*for_thet_constr(i)*difi**4,
6118      &    gloc(itheta+nphi-2,icg)
6119         endif
6120       enddo
6121
6122       return
6123       end
6124 #endif
6125 #ifdef CRYST_SC
6126 c-----------------------------------------------------------------------------
6127       subroutine esc(escloc)
6128 C Calculate the local energy of a side chain and its derivatives in the
6129 C corresponding virtual-bond valence angles THETA and the spherical angles
6130 C ALPHA and OMEGA.
6131       implicit real*8 (a-h,o-z)
6132       include 'DIMENSIONS'
6133       include 'COMMON.GEO'
6134       include 'COMMON.LOCAL'
6135       include 'COMMON.VAR'
6136       include 'COMMON.INTERACT'
6137       include 'COMMON.DERIV'
6138       include 'COMMON.CHAIN'
6139       include 'COMMON.IOUNITS'
6140       include 'COMMON.NAMES'
6141       include 'COMMON.FFIELD'
6142       include 'COMMON.CONTROL'
6143       double precision x(3),dersc(3),xemp(3),dersc0(3),dersc1(3),
6144      &     ddersc0(3),ddummy(3),xtemp(3),temp(3)
6145       common /sccalc/ time11,time12,time112,theti,it,nlobit
6146       delta=0.02d0*pi
6147       escloc=0.0D0
6148 c     write (iout,'(a)') 'ESC'
6149       do i=loc_start,loc_end
6150         it=itype(i)
6151         if (it.eq.ntyp1) cycle
6152         if (it.eq.10) goto 1
6153         nlobit=nlob(iabs(it))
6154 c       print *,'i=',i,' it=',it,' nlobit=',nlobit
6155 c       write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
6156         theti=theta(i+1)-pipol
6157         x(1)=dtan(theti)
6158         x(2)=alph(i)
6159         x(3)=omeg(i)
6160
6161         if (x(2).gt.pi-delta) then
6162           xtemp(1)=x(1)
6163           xtemp(2)=pi-delta
6164           xtemp(3)=x(3)
6165           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
6166           xtemp(2)=pi
6167           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
6168           call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),
6169      &        escloci,dersc(2))
6170           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
6171      &        ddersc0(1),dersc(1))
6172           call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),
6173      &        ddersc0(3),dersc(3))
6174           xtemp(2)=pi-delta
6175           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
6176           xtemp(2)=pi
6177           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
6178           call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,
6179      &            dersc0(2),esclocbi,dersc02)
6180           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
6181      &            dersc12,dersc01)
6182           call splinthet(x(2),0.5d0*delta,ss,ssd)
6183           dersc0(1)=dersc01
6184           dersc0(2)=dersc02
6185           dersc0(3)=0.0d0
6186           do k=1,3
6187             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
6188           enddo
6189           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
6190 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
6191 c    &             esclocbi,ss,ssd
6192           escloci=ss*escloci+(1.0d0-ss)*esclocbi
6193 c         escloci=esclocbi
6194 c         write (iout,*) escloci
6195         else if (x(2).lt.delta) then
6196           xtemp(1)=x(1)
6197           xtemp(2)=delta
6198           xtemp(3)=x(3)
6199           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
6200           xtemp(2)=0.0d0
6201           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
6202           call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),
6203      &        escloci,dersc(2))
6204           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
6205      &        ddersc0(1),dersc(1))
6206           call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),
6207      &        ddersc0(3),dersc(3))
6208           xtemp(2)=delta
6209           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
6210           xtemp(2)=0.0d0
6211           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
6212           call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,
6213      &            dersc0(2),esclocbi,dersc02)
6214           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
6215      &            dersc12,dersc01)
6216           dersc0(1)=dersc01
6217           dersc0(2)=dersc02
6218           dersc0(3)=0.0d0
6219           call splinthet(x(2),0.5d0*delta,ss,ssd)
6220           do k=1,3
6221             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
6222           enddo
6223           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
6224 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
6225 c    &             esclocbi,ss,ssd
6226           escloci=ss*escloci+(1.0d0-ss)*esclocbi
6227 c         write (iout,*) escloci
6228         else
6229           call enesc(x,escloci,dersc,ddummy,.false.)
6230         endif
6231
6232         escloc=escloc+escloci
6233         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
6234      &     'escloc',i,escloci
6235 c       write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
6236
6237         gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
6238      &   wscloc*dersc(1)
6239         gloc(ialph(i,1),icg)=wscloc*dersc(2)
6240         gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
6241     1   continue
6242       enddo
6243       return
6244       end
6245 C---------------------------------------------------------------------------
6246       subroutine enesc(x,escloci,dersc,ddersc,mixed)
6247       implicit real*8 (a-h,o-z)
6248       include 'DIMENSIONS'
6249       include 'COMMON.GEO'
6250       include 'COMMON.LOCAL'
6251       include 'COMMON.IOUNITS'
6252       common /sccalc/ time11,time12,time112,theti,it,nlobit
6253       double precision x(3),z(3),Ax(3,maxlob,-1:1),dersc(3),ddersc(3)
6254       double precision contr(maxlob,-1:1)
6255       logical mixed
6256 c       write (iout,*) 'it=',it,' nlobit=',nlobit
6257         escloc_i=0.0D0
6258         do j=1,3
6259           dersc(j)=0.0D0
6260           if (mixed) ddersc(j)=0.0d0
6261         enddo
6262         x3=x(3)
6263
6264 C Because of periodicity of the dependence of the SC energy in omega we have
6265 C to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
6266 C To avoid underflows, first compute & store the exponents.
6267
6268         do iii=-1,1
6269
6270           x(3)=x3+iii*dwapi
6271
6272           do j=1,nlobit
6273             do k=1,3
6274               z(k)=x(k)-censc(k,j,it)
6275             enddo
6276             do k=1,3
6277               Axk=0.0D0
6278               do l=1,3
6279                 Axk=Axk+gaussc(l,k,j,it)*z(l)
6280               enddo
6281               Ax(k,j,iii)=Axk
6282             enddo
6283             expfac=0.0D0
6284             do k=1,3
6285               expfac=expfac+Ax(k,j,iii)*z(k)
6286             enddo
6287             contr(j,iii)=expfac
6288           enddo ! j
6289
6290         enddo ! iii
6291
6292         x(3)=x3
6293 C As in the case of ebend, we want to avoid underflows in exponentiation and
6294 C subsequent NaNs and INFs in energy calculation.
6295 C Find the largest exponent
6296         emin=contr(1,-1)
6297         do iii=-1,1
6298           do j=1,nlobit
6299             if (emin.gt.contr(j,iii)) emin=contr(j,iii)
6300           enddo
6301         enddo
6302         emin=0.5D0*emin
6303 cd      print *,'it=',it,' emin=',emin
6304
6305 C Compute the contribution to SC energy and derivatives
6306         do iii=-1,1
6307
6308           do j=1,nlobit
6309 #ifdef OSF
6310             adexp=bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin
6311             if(adexp.ne.adexp) adexp=1.0
6312             expfac=dexp(adexp)
6313 #else
6314             expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin)
6315 #endif
6316 cd          print *,'j=',j,' expfac=',expfac
6317             escloc_i=escloc_i+expfac
6318             do k=1,3
6319               dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
6320             enddo
6321             if (mixed) then
6322               do k=1,3,2
6323                 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii)
6324      &            +gaussc(k,2,j,it))*expfac
6325               enddo
6326             endif
6327           enddo
6328
6329         enddo ! iii
6330
6331         dersc(1)=dersc(1)/cos(theti)**2
6332         ddersc(1)=ddersc(1)/cos(theti)**2
6333         ddersc(3)=ddersc(3)
6334
6335         escloci=-(dlog(escloc_i)-emin)
6336         do j=1,3
6337           dersc(j)=dersc(j)/escloc_i
6338         enddo
6339         if (mixed) then
6340           do j=1,3,2
6341             ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
6342           enddo
6343         endif
6344       return
6345       end
6346 C------------------------------------------------------------------------------
6347       subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
6348       implicit real*8 (a-h,o-z)
6349       include 'DIMENSIONS'
6350       include 'COMMON.GEO'
6351       include 'COMMON.LOCAL'
6352       include 'COMMON.IOUNITS'
6353       common /sccalc/ time11,time12,time112,theti,it,nlobit
6354       double precision x(3),z(3),Ax(3,maxlob),dersc(3)
6355       double precision contr(maxlob)
6356       logical mixed
6357
6358       escloc_i=0.0D0
6359
6360       do j=1,3
6361         dersc(j)=0.0D0
6362       enddo
6363
6364       do j=1,nlobit
6365         do k=1,2
6366           z(k)=x(k)-censc(k,j,it)
6367         enddo
6368         z(3)=dwapi
6369         do k=1,3
6370           Axk=0.0D0
6371           do l=1,3
6372             Axk=Axk+gaussc(l,k,j,it)*z(l)
6373           enddo
6374           Ax(k,j)=Axk
6375         enddo
6376         expfac=0.0D0
6377         do k=1,3
6378           expfac=expfac+Ax(k,j)*z(k)
6379         enddo
6380         contr(j)=expfac
6381       enddo ! j
6382
6383 C As in the case of ebend, we want to avoid underflows in exponentiation and
6384 C subsequent NaNs and INFs in energy calculation.
6385 C Find the largest exponent
6386       emin=contr(1)
6387       do j=1,nlobit
6388         if (emin.gt.contr(j)) emin=contr(j)
6389       enddo
6390       emin=0.5D0*emin
6391
6392 C Compute the contribution to SC energy and derivatives
6393
6394       dersc12=0.0d0
6395       do j=1,nlobit
6396         expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j)+emin)
6397         escloc_i=escloc_i+expfac
6398         do k=1,2
6399           dersc(k)=dersc(k)+Ax(k,j)*expfac
6400         enddo
6401         if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j)
6402      &            +gaussc(1,2,j,it))*expfac
6403         dersc(3)=0.0d0
6404       enddo
6405
6406       dersc(1)=dersc(1)/cos(theti)**2
6407       dersc12=dersc12/cos(theti)**2
6408       escloci=-(dlog(escloc_i)-emin)
6409       do j=1,2
6410         dersc(j)=dersc(j)/escloc_i
6411       enddo
6412       if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
6413       return
6414       end
6415 #else
6416 c----------------------------------------------------------------------------------
6417       subroutine esc(escloc)
6418 C Calculate the local energy of a side chain and its derivatives in the
6419 C corresponding virtual-bond valence angles THETA and the spherical angles
6420 C ALPHA and OMEGA derived from AM1 all-atom calculations.
6421 C added by Urszula Kozlowska. 07/11/2007
6422 C
6423       implicit real*8 (a-h,o-z)
6424       include 'DIMENSIONS'
6425       include 'COMMON.GEO'
6426       include 'COMMON.LOCAL'
6427       include 'COMMON.VAR'
6428       include 'COMMON.SCROT'
6429       include 'COMMON.INTERACT'
6430       include 'COMMON.DERIV'
6431       include 'COMMON.CHAIN'
6432       include 'COMMON.IOUNITS'
6433       include 'COMMON.NAMES'
6434       include 'COMMON.FFIELD'
6435       include 'COMMON.CONTROL'
6436       include 'COMMON.VECTORS'
6437       double precision x_prime(3),y_prime(3),z_prime(3)
6438      &    , sumene,dsc_i,dp2_i,x(65),
6439      &     xx,yy,zz,sumene1,sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6,
6440      &    de_dxx,de_dyy,de_dzz,de_dt
6441       double precision s1_t,s1_6_t,s2_t,s2_6_t
6442       double precision
6443      & dXX_Ci1(3),dYY_Ci1(3),dZZ_Ci1(3),dXX_Ci(3),
6444      & dYY_Ci(3),dZZ_Ci(3),dXX_XYZ(3),dYY_XYZ(3),dZZ_XYZ(3),
6445      & dt_dCi(3),dt_dCi1(3)
6446       common /sccalc/ time11,time12,time112,theti,it,nlobit
6447       delta=0.02d0*pi
6448       escloc=0.0D0
6449       do i=loc_start,loc_end
6450         if (itype(i).eq.ntyp1) cycle
6451         costtab(i+1) =dcos(theta(i+1))
6452         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
6453         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
6454         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
6455         cosfac2=0.5d0/(1.0d0+costtab(i+1))
6456         cosfac=dsqrt(cosfac2)
6457         sinfac2=0.5d0/(1.0d0-costtab(i+1))
6458         sinfac=dsqrt(sinfac2)
6459         it=iabs(itype(i))
6460         if (it.eq.10) goto 1
6461 c
6462 C  Compute the axes of tghe local cartesian coordinates system; store in
6463 c   x_prime, y_prime and z_prime
6464 c
6465         do j=1,3
6466           x_prime(j) = 0.00
6467           y_prime(j) = 0.00
6468           z_prime(j) = 0.00
6469         enddo
6470 C        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
6471 C     &   dc_norm(3,i+nres)
6472         do j = 1,3
6473           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
6474           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
6475         enddo
6476         do j = 1,3
6477           z_prime(j) = -uz(j,i-1)*dsign(1.0d0,dfloat(itype(i)))
6478         enddo
6479 c       write (2,*) "i",i
6480 c       write (2,*) "x_prime",(x_prime(j),j=1,3)
6481 c       write (2,*) "y_prime",(y_prime(j),j=1,3)
6482 c       write (2,*) "z_prime",(z_prime(j),j=1,3)
6483 c       write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
6484 c      & " xy",scalar(x_prime(1),y_prime(1)),
6485 c      & " xz",scalar(x_prime(1),z_prime(1)),
6486 c      & " yy",scalar(y_prime(1),y_prime(1)),
6487 c      & " yz",scalar(y_prime(1),z_prime(1)),
6488 c      & " zz",scalar(z_prime(1),z_prime(1))
6489 c
6490 C Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
6491 C to local coordinate system. Store in xx, yy, zz.
6492 c
6493         xx=0.0d0
6494         yy=0.0d0
6495         zz=0.0d0
6496         do j = 1,3
6497           xx = xx + x_prime(j)*dc_norm(j,i+nres)
6498           yy = yy + y_prime(j)*dc_norm(j,i+nres)
6499           zz = zz + z_prime(j)*dc_norm(j,i+nres)
6500         enddo
6501
6502         xxtab(i)=xx
6503         yytab(i)=yy
6504         zztab(i)=zz
6505 C
6506 C Compute the energy of the ith side cbain
6507 C
6508 c        write (2,*) "xx",xx," yy",yy," zz",zz
6509         it=iabs(itype(i))
6510         do j = 1,65
6511           x(j) = sc_parmin(j,it)
6512         enddo
6513 #ifdef CHECK_COORD
6514 Cc diagnostics - remove later
6515         xx1 = dcos(alph(2))
6516         yy1 = dsin(alph(2))*dcos(omeg(2))
6517         zz1 = -dsign(1.0,dfloat(itype(i)))*dsin(alph(2))*dsin(omeg(2))
6518         write(2,'(3f8.1,3f9.3,1x,3f9.3)')
6519      &    alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,
6520      &    xx1,yy1,zz1
6521 C,"  --- ", xx_w,yy_w,zz_w
6522 c end diagnostics
6523 #endif
6524         sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
6525      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
6526      &   + x(10)*yy*zz
6527         sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
6528      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
6529      & + x(20)*yy*zz
6530         sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
6531      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
6532      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
6533      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
6534      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
6535      &  +x(40)*xx*yy*zz
6536         sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
6537      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
6538      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
6539      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
6540      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
6541      &  +x(60)*xx*yy*zz
6542         dsc_i   = 0.743d0+x(61)
6543         dp2_i   = 1.9d0+x(62)
6544         dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
6545      &          *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
6546         dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
6547      &          *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
6548         s1=(1+x(63))/(0.1d0 + dscp1)
6549         s1_6=(1+x(64))/(0.1d0 + dscp1**6)
6550         s2=(1+x(65))/(0.1d0 + dscp2)
6551         s2_6=(1+x(65))/(0.1d0 + dscp2**6)
6552         sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6)
6553      & + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
6554 c        write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
6555 c     &   sumene4,
6556 c     &   dscp1,dscp2,sumene
6557 c        sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6558         escloc = escloc + sumene
6559 c        write (2,*) "i",i," escloc",sumene,escloc,it,itype(i)
6560 c     & ,zz,xx,yy
6561 c#define DEBUG
6562 #ifdef DEBUG
6563 C
6564 C This section to check the numerical derivatives of the energy of ith side
6565 C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
6566 C #define DEBUG in the code to turn it on.
6567 C
6568         write (2,*) "sumene               =",sumene
6569         aincr=1.0d-7
6570         xxsave=xx
6571         xx=xx+aincr
6572         write (2,*) xx,yy,zz
6573         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6574         de_dxx_num=(sumenep-sumene)/aincr
6575         xx=xxsave
6576         write (2,*) "xx+ sumene from enesc=",sumenep
6577         yysave=yy
6578         yy=yy+aincr
6579         write (2,*) xx,yy,zz
6580         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6581         de_dyy_num=(sumenep-sumene)/aincr
6582         yy=yysave
6583         write (2,*) "yy+ sumene from enesc=",sumenep
6584         zzsave=zz
6585         zz=zz+aincr
6586         write (2,*) xx,yy,zz
6587         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6588         de_dzz_num=(sumenep-sumene)/aincr
6589         zz=zzsave
6590         write (2,*) "zz+ sumene from enesc=",sumenep
6591         costsave=cost2tab(i+1)
6592         sintsave=sint2tab(i+1)
6593         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
6594         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
6595         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6596         de_dt_num=(sumenep-sumene)/aincr
6597         write (2,*) " t+ sumene from enesc=",sumenep
6598         cost2tab(i+1)=costsave
6599         sint2tab(i+1)=sintsave
6600 C End of diagnostics section.
6601 #endif
6602 C
6603 C Compute the gradient of esc
6604 C
6605 c        zz=zz*dsign(1.0,dfloat(itype(i)))
6606         pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
6607         pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
6608         pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
6609         pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
6610         pom_dx=dsc_i*dp2_i*cost2tab(i+1)
6611         pom_dy=dsc_i*dp2_i*sint2tab(i+1)
6612         pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
6613         pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
6614         pom1=(sumene3*sint2tab(i+1)+sumene1)
6615      &     *(pom_s1/dscp1+pom_s16*dscp1**4)
6616         pom2=(sumene4*cost2tab(i+1)+sumene2)
6617      &     *(pom_s2/dscp2+pom_s26*dscp2**4)
6618         sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
6619         sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2
6620      &  +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2)
6621      &  +x(40)*yy*zz
6622         sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
6623         sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2
6624      &  +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2)
6625      &  +x(60)*yy*zz
6626         de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6)
6627      &        +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6)
6628      &        +(pom1+pom2)*pom_dx
6629 #ifdef DEBUG
6630         write(2,*), "de_dxx = ", de_dxx,de_dxx_num,itype(i)
6631 #endif
6632 C
6633         sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
6634         sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2
6635      &  +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2)
6636      &  +x(40)*xx*zz
6637         sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
6638         sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz
6639      &  +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz
6640      &  +x(59)*zz**2 +x(60)*xx*zz
6641         de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6)
6642      &        +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6)
6643      &        +(pom1-pom2)*pom_dy
6644 #ifdef DEBUG
6645         write(2,*), "de_dyy = ", de_dyy,de_dyy_num,itype(i)
6646 #endif
6647 C
6648         de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy
6649      &  +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx
6650      &  +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6)
6651      &  +(x(4) + 2*x(7)*zz+  x(8)*xx + x(10)*yy)*(s1+s1_6)
6652      &  +(x(44)+2*x(47)*zz +x(48)*xx   +x(50)*yy  +3*x(53)*zz**2
6653      &  +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy
6654      &  +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6)
6655      &  + ( x(14) + 2*x(17)*zz+  x(18)*xx + x(20)*yy)*(s2+s2_6)
6656 #ifdef DEBUG
6657         write(2,*), "de_dzz = ", de_dzz,de_dzz_num,itype(i)
6658 #endif
6659 C
6660         de_dt =  0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6)
6661      &  -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6)
6662      &  +pom1*pom_dt1+pom2*pom_dt2
6663 #ifdef DEBUG
6664         write(2,*), "de_dt = ", de_dt,de_dt_num,itype(i)
6665 #endif
6666 c#undef DEBUG
6667 c
6668 C
6669        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
6670        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
6671        cosfac2xx=cosfac2*xx
6672        sinfac2yy=sinfac2*yy
6673        do k = 1,3
6674          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))*
6675      &      vbld_inv(i+1)
6676          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))*
6677      &      vbld_inv(i)
6678          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
6679          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
6680 c         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
6681 c     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
6682 c         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
6683 c     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
6684          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
6685          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
6686          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
6687          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
6688          dZZ_Ci1(k)=0.0d0
6689          dZZ_Ci(k)=0.0d0
6690          do j=1,3
6691            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)
6692      &     *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
6693            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)
6694      &     *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
6695          enddo
6696
6697          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
6698          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
6699          dZZ_XYZ(k)=vbld_inv(i+nres)*
6700      &   (z_prime(k)-zz*dC_norm(k,i+nres))
6701 c
6702          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
6703          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
6704        enddo
6705
6706        do k=1,3
6707          dXX_Ctab(k,i)=dXX_Ci(k)
6708          dXX_C1tab(k,i)=dXX_Ci1(k)
6709          dYY_Ctab(k,i)=dYY_Ci(k)
6710          dYY_C1tab(k,i)=dYY_Ci1(k)
6711          dZZ_Ctab(k,i)=dZZ_Ci(k)
6712          dZZ_C1tab(k,i)=dZZ_Ci1(k)
6713          dXX_XYZtab(k,i)=dXX_XYZ(k)
6714          dYY_XYZtab(k,i)=dYY_XYZ(k)
6715          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
6716        enddo
6717
6718        do k = 1,3
6719 c         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
6720 c     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
6721 c         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
6722 c     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
6723 c         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
6724 c     &    dt_dci(k)
6725 c         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
6726 c     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
6727          gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k)
6728      &    +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
6729          gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k)
6730      &    +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
6731          gsclocx(k,i)=                 de_dxx*dxx_XYZ(k)
6732      &    +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
6733        enddo
6734 c       write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
6735 c     &  (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
6736
6737 C to check gradient call subroutine check_grad
6738
6739     1 continue
6740       enddo
6741       return
6742       end
6743 c------------------------------------------------------------------------------
6744       double precision function enesc(x,xx,yy,zz,cost2,sint2)
6745       implicit none
6746       double precision x(65),xx,yy,zz,cost2,sint2,sumene1,sumene2,
6747      & sumene3,sumene4,sumene,dsc_i,dp2_i,dscp1,dscp2,s1,s1_6,s2,s2_6
6748       sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
6749      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
6750      &   + x(10)*yy*zz
6751       sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
6752      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
6753      & + x(20)*yy*zz
6754       sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
6755      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
6756      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
6757      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
6758      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
6759      &  +x(40)*xx*yy*zz
6760       sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
6761      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
6762      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
6763      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
6764      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
6765      &  +x(60)*xx*yy*zz
6766       dsc_i   = 0.743d0+x(61)
6767       dp2_i   = 1.9d0+x(62)
6768       dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
6769      &          *(xx*cost2+yy*sint2))
6770       dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
6771      &          *(xx*cost2-yy*sint2))
6772       s1=(1+x(63))/(0.1d0 + dscp1)
6773       s1_6=(1+x(64))/(0.1d0 + dscp1**6)
6774       s2=(1+x(65))/(0.1d0 + dscp2)
6775       s2_6=(1+x(65))/(0.1d0 + dscp2**6)
6776       sumene = ( sumene3*sint2 + sumene1)*(s1+s1_6)
6777      & + (sumene4*cost2 +sumene2)*(s2+s2_6)
6778       enesc=sumene
6779       return
6780       end
6781 #endif
6782 c------------------------------------------------------------------------------
6783       subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
6784 C
6785 C This procedure calculates two-body contact function g(rij) and its derivative:
6786 C
6787 C           eps0ij                                     !       x < -1
6788 C g(rij) =  esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5)  ! -1 =< x =< 1
6789 C            0                                         !       x > 1
6790 C
6791 C where x=(rij-r0ij)/delta
6792 C
6793 C rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
6794 C
6795       implicit none
6796       double precision rij,r0ij,eps0ij,fcont,fprimcont
6797       double precision x,x2,x4,delta
6798 c     delta=0.02D0*r0ij
6799 c      delta=0.2D0*r0ij
6800       x=(rij-r0ij)/delta
6801       if (x.lt.-1.0D0) then
6802         fcont=eps0ij
6803         fprimcont=0.0D0
6804       else if (x.le.1.0D0) then
6805         x2=x*x
6806         x4=x2*x2
6807         fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
6808         fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
6809       else
6810         fcont=0.0D0
6811         fprimcont=0.0D0
6812       endif
6813       return
6814       end
6815 c------------------------------------------------------------------------------
6816       subroutine splinthet(theti,delta,ss,ssder)
6817       implicit real*8 (a-h,o-z)
6818       include 'DIMENSIONS'
6819       include 'COMMON.VAR'
6820       include 'COMMON.GEO'
6821       thetup=pi-delta
6822       thetlow=delta
6823       if (theti.gt.pipol) then
6824         call gcont(theti,thetup,1.0d0,delta,ss,ssder)
6825       else
6826         call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
6827         ssder=-ssder
6828       endif
6829       return
6830       end
6831 c------------------------------------------------------------------------------
6832       subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
6833       implicit none
6834       double precision x,x0,delta,f0,f1,fprim0,f,fprim
6835       double precision ksi,ksi2,ksi3,a1,a2,a3
6836       a1=fprim0*delta/(f1-f0)
6837       a2=3.0d0-2.0d0*a1
6838       a3=a1-2.0d0
6839       ksi=(x-x0)/delta
6840       ksi2=ksi*ksi
6841       ksi3=ksi2*ksi
6842       f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
6843       fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
6844       return
6845       end
6846 c------------------------------------------------------------------------------
6847       subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
6848       implicit none
6849       double precision x,x0,delta,f0x,f1x,fprim0x,fx
6850       double precision ksi,ksi2,ksi3,a1,a2,a3
6851       ksi=(x-x0)/delta
6852       ksi2=ksi*ksi
6853       ksi3=ksi2*ksi
6854       a1=fprim0x*delta
6855       a2=3*(f1x-f0x)-2*fprim0x*delta
6856       a3=fprim0x*delta-2*(f1x-f0x)
6857       fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
6858       return
6859       end
6860 C-----------------------------------------------------------------------------
6861 #ifdef CRYST_TOR
6862 C-----------------------------------------------------------------------------
6863       subroutine etor(etors,edihcnstr)
6864       implicit real*8 (a-h,o-z)
6865       include 'DIMENSIONS'
6866       include 'COMMON.VAR'
6867       include 'COMMON.GEO'
6868       include 'COMMON.LOCAL'
6869       include 'COMMON.TORSION'
6870       include 'COMMON.INTERACT'
6871       include 'COMMON.DERIV'
6872       include 'COMMON.CHAIN'
6873       include 'COMMON.NAMES'
6874       include 'COMMON.IOUNITS'
6875       include 'COMMON.FFIELD'
6876       include 'COMMON.TORCNSTR'
6877       include 'COMMON.CONTROL'
6878       logical lprn
6879 C Set lprn=.true. for debugging
6880       lprn=.false.
6881 c      lprn=.true.
6882       etors=0.0D0
6883       do i=iphi_start,iphi_end
6884       etors_ii=0.0D0
6885         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
6886      &      .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
6887         itori=itortyp(itype(i-2))
6888         itori1=itortyp(itype(i-1))
6889         phii=phi(i)
6890         gloci=0.0D0
6891 C Proline-Proline pair is a special case...
6892         if (itori.eq.3 .and. itori1.eq.3) then
6893           if (phii.gt.-dwapi3) then
6894             cosphi=dcos(3*phii)
6895             fac=1.0D0/(1.0D0-cosphi)
6896             etorsi=v1(1,3,3)*fac
6897             etorsi=etorsi+etorsi
6898             etors=etors+etorsi-v1(1,3,3)
6899             if (energy_dec) etors_ii=etors_ii+etorsi-v1(1,3,3)
6900             gloci=gloci-3*fac*etorsi*dsin(3*phii)
6901           endif
6902           do j=1,3
6903             v1ij=v1(j+1,itori,itori1)
6904             v2ij=v2(j+1,itori,itori1)
6905             cosphi=dcos(j*phii)
6906             sinphi=dsin(j*phii)
6907             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
6908             if (energy_dec) etors_ii=etors_ii+
6909      &                              v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
6910             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
6911           enddo
6912         else
6913           do j=1,nterm_old
6914             v1ij=v1(j,itori,itori1)
6915             v2ij=v2(j,itori,itori1)
6916             cosphi=dcos(j*phii)
6917             sinphi=dsin(j*phii)
6918             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
6919             if (energy_dec) etors_ii=etors_ii+
6920      &                  v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
6921             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
6922           enddo
6923         endif
6924         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
6925              'etor',i,etors_ii
6926         if (lprn)
6927      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
6928      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
6929      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
6930         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
6931 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
6932       enddo
6933 ! 6/20/98 - dihedral angle constraints
6934       edihcnstr=0.0d0
6935       do i=1,ndih_constr
6936         itori=idih_constr(i)
6937         phii=phi(itori)
6938         difi=phii-phi0(i)
6939         if (difi.gt.drange(i)) then
6940           difi=difi-drange(i)
6941           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
6942           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
6943         else if (difi.lt.-drange(i)) then
6944           difi=difi+drange(i)
6945           edihcnstr=edihcnstr+0.25d0*ftors(i)**difi**4
6946           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
6947         endif
6948 !        write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii,
6949 !     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
6950       enddo
6951 !      write (iout,*) 'edihcnstr',edihcnstr
6952       return
6953       end
6954 c------------------------------------------------------------------------------
6955       subroutine etor_d(etors_d)
6956       etors_d=0.0d0
6957       return
6958       end
6959 c----------------------------------------------------------------------------
6960 #else
6961       subroutine etor(etors,edihcnstr)
6962       implicit real*8 (a-h,o-z)
6963       include 'DIMENSIONS'
6964       include 'COMMON.VAR'
6965       include 'COMMON.GEO'
6966       include 'COMMON.LOCAL'
6967       include 'COMMON.TORSION'
6968       include 'COMMON.INTERACT'
6969       include 'COMMON.DERIV'
6970       include 'COMMON.CHAIN'
6971       include 'COMMON.NAMES'
6972       include 'COMMON.IOUNITS'
6973       include 'COMMON.FFIELD'
6974       include 'COMMON.TORCNSTR'
6975       include 'COMMON.CONTROL'
6976       logical lprn
6977 C Set lprn=.true. for debugging
6978       lprn=.false.
6979 c     lprn=.true.
6980       etors=0.0D0
6981       do i=iphi_start,iphi_end
6982 C ANY TWO ARE DUMMY ATOMS in row CYCLE
6983 c        if (((itype(i-3).eq.ntyp1).and.(itype(i-2).eq.ntyp1)).or.
6984 c     &      ((itype(i-2).eq.ntyp1).and.(itype(i-1).eq.ntyp1))  .or.
6985 c     &      ((itype(i-1).eq.ntyp1).and.(itype(i).eq.ntyp1))) cycle
6986         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
6987      &      .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
6988 C In current verion the ALL DUMMY ATOM POTENTIALS ARE OFF
6989 C For introducing the NH3+ and COO- group please check the etor_d for reference
6990 C and guidance
6991         etors_ii=0.0D0
6992          if (iabs(itype(i)).eq.20) then
6993          iblock=2
6994          else
6995          iblock=1
6996          endif
6997         itori=itortyp(itype(i-2))
6998         itori1=itortyp(itype(i-1))
6999         phii=phi(i)
7000         gloci=0.0D0
7001 C Regular cosine and sine terms
7002         do j=1,nterm(itori,itori1,iblock)
7003           v1ij=v1(j,itori,itori1,iblock)
7004           v2ij=v2(j,itori,itori1,iblock)
7005           cosphi=dcos(j*phii)
7006           sinphi=dsin(j*phii)
7007           etors=etors+v1ij*cosphi+v2ij*sinphi
7008           if (energy_dec) etors_ii=etors_ii+
7009      &                v1ij*cosphi+v2ij*sinphi
7010           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7011         enddo
7012 C Lorentz terms
7013 C                         v1
7014 C  E = SUM ----------------------------------- - v1
7015 C          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
7016 C
7017         cosphi=dcos(0.5d0*phii)
7018         sinphi=dsin(0.5d0*phii)
7019         do j=1,nlor(itori,itori1,iblock)
7020           vl1ij=vlor1(j,itori,itori1)
7021           vl2ij=vlor2(j,itori,itori1)
7022           vl3ij=vlor3(j,itori,itori1)
7023           pom=vl2ij*cosphi+vl3ij*sinphi
7024           pom1=1.0d0/(pom*pom+1.0d0)
7025           etors=etors+vl1ij*pom1
7026           if (energy_dec) etors_ii=etors_ii+
7027      &                vl1ij*pom1
7028           pom=-pom*pom1*pom1
7029           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
7030         enddo
7031 C Subtract the constant term
7032         etors=etors-v0(itori,itori1,iblock)
7033           if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
7034      &         'etor',i,etors_ii-v0(itori,itori1,iblock)
7035         if (lprn)
7036      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
7037      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
7038      &  (v1(j,itori,itori1,iblock),j=1,6),
7039      &  (v2(j,itori,itori1,iblock),j=1,6)
7040         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
7041 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
7042       enddo
7043 ! 6/20/98 - dihedral angle constraints
7044       edihcnstr=0.0d0
7045 c      do i=1,ndih_constr
7046       do i=idihconstr_start,idihconstr_end
7047         itori=idih_constr(i)
7048         phii=phi(itori)
7049         difi=pinorm(phii-phi0(i))
7050         if (difi.gt.drange(i)) then
7051           difi=difi-drange(i)
7052           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
7053           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
7054         else if (difi.lt.-drange(i)) then
7055           difi=difi+drange(i)
7056           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
7057           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
7058         else
7059           difi=0.0
7060         endif
7061        if (energy_dec) then
7062         write (iout,'(a6,2i5,4f8.3,2e14.5)') "edihc",
7063      &    i,itori,rad2deg*phii,
7064      &    rad2deg*phi0(i),  rad2deg*drange(i),
7065      &    rad2deg*difi,0.25d0*ftors(i)*difi**4,gloc(itori-3,icg)
7066         endif
7067       enddo
7068 cd       write (iout,*) 'edihcnstr',edihcnstr
7069       return
7070       end
7071 c----------------------------------------------------------------------------
7072       subroutine etor_d(etors_d)
7073 C 6/23/01 Compute double torsional energy
7074       implicit real*8 (a-h,o-z)
7075       include 'DIMENSIONS'
7076       include 'COMMON.VAR'
7077       include 'COMMON.GEO'
7078       include 'COMMON.LOCAL'
7079       include 'COMMON.TORSION'
7080       include 'COMMON.INTERACT'
7081       include 'COMMON.DERIV'
7082       include 'COMMON.CHAIN'
7083       include 'COMMON.NAMES'
7084       include 'COMMON.IOUNITS'
7085       include 'COMMON.FFIELD'
7086       include 'COMMON.TORCNSTR'
7087       logical lprn
7088 C Set lprn=.true. for debugging
7089       lprn=.false.
7090 c     lprn=.true.
7091       etors_d=0.0D0
7092 c      write(iout,*) "a tu??"
7093       do i=iphid_start,iphid_end
7094 C ANY TWO ARE DUMMY ATOMS in row CYCLE
7095 C        if (((itype(i-3).eq.ntyp1).and.(itype(i-2).eq.ntyp1)).or.
7096 C     &      ((itype(i-2).eq.ntyp1).and.(itype(i-1).eq.ntyp1)).or.
7097 C     &      ((itype(i-1).eq.ntyp1).and.(itype(i).eq.ntyp1))  .or.
7098 C     &      ((itype(i).eq.ntyp1).and.(itype(i+1).eq.ntyp1))) cycle
7099          if ((itype(i-2).eq.ntyp1).or.itype(i-3).eq.ntyp1.or.
7100      &  (itype(i-1).eq.ntyp1).or.(itype(i).eq.ntyp1).or.
7101      &  (itype(i+1).eq.ntyp1)) cycle
7102 C In current verion the ALL DUMMY ATOM POTENTIALS ARE OFF
7103         itori=itortyp(itype(i-2))
7104         itori1=itortyp(itype(i-1))
7105         itori2=itortyp(itype(i))
7106         phii=phi(i)
7107         phii1=phi(i+1)
7108         gloci1=0.0D0
7109         gloci2=0.0D0
7110         iblock=1
7111         if (iabs(itype(i+1)).eq.20) iblock=2
7112 C Iblock=2 Proline type
7113 C ADASKO: WHEN PARAMETERS FOR THIS TYPE OF BLOCKING GROUP IS READY UNCOMMENT
7114 C CHECK WEATHER THERE IS NECCESITY FOR iblock=3 for COO-
7115 C        if (itype(i+1).eq.ntyp1) iblock=3
7116 C The problem of NH3+ group can be resolved by adding new parameters please note if there
7117 C IS or IS NOT need for this
7118 C IF Yes uncomment below and add to parmread.F appropriate changes and to v1cij and so on
7119 C        is (itype(i-3).eq.ntyp1) ntblock=2
7120 C        ntblock is N-terminal blocking group
7121
7122 C Regular cosine and sine terms
7123         do j=1,ntermd_1(itori,itori1,itori2,iblock)
7124 C Example of changes for NH3+ blocking group
7125 C       do j=1,ntermd_1(itori,itori1,itori2,iblock,ntblock)
7126 C          v1cij=v1c(1,j,itori,itori1,itori2,iblock,ntblock)
7127           v1cij=v1c(1,j,itori,itori1,itori2,iblock)
7128           v1sij=v1s(1,j,itori,itori1,itori2,iblock)
7129           v2cij=v1c(2,j,itori,itori1,itori2,iblock)
7130           v2sij=v1s(2,j,itori,itori1,itori2,iblock)
7131           cosphi1=dcos(j*phii)
7132           sinphi1=dsin(j*phii)
7133           cosphi2=dcos(j*phii1)
7134           sinphi2=dsin(j*phii1)
7135           etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+
7136      &     v2cij*cosphi2+v2sij*sinphi2
7137           gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
7138           gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
7139         enddo
7140         do k=2,ntermd_2(itori,itori1,itori2,iblock)
7141           do l=1,k-1
7142             v1cdij = v2c(k,l,itori,itori1,itori2,iblock)
7143             v2cdij = v2c(l,k,itori,itori1,itori2,iblock)
7144             v1sdij = v2s(k,l,itori,itori1,itori2,iblock)
7145             v2sdij = v2s(l,k,itori,itori1,itori2,iblock)
7146             cosphi1p2=dcos(l*phii+(k-l)*phii1)
7147             cosphi1m2=dcos(l*phii-(k-l)*phii1)
7148             sinphi1p2=dsin(l*phii+(k-l)*phii1)
7149             sinphi1m2=dsin(l*phii-(k-l)*phii1)
7150             etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+
7151      &        v1sdij*sinphi1p2+v2sdij*sinphi1m2
7152             gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2
7153      &        -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
7154             gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2
7155      &        -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
7156           enddo
7157         enddo
7158         gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*gloci1
7159         gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*gloci2
7160       enddo
7161       return
7162       end
7163 #endif
7164 c------------------------------------------------------------------------------
7165       subroutine eback_sc_corr(esccor)
7166 c 7/21/2007 Correlations between the backbone-local and side-chain-local
7167 c        conformational states; temporarily implemented as differences
7168 c        between UNRES torsional potentials (dependent on three types of
7169 c        residues) and the torsional potentials dependent on all 20 types
7170 c        of residues computed from AM1  energy surfaces of terminally-blocked
7171 c        amino-acid residues.
7172       implicit real*8 (a-h,o-z)
7173       include 'DIMENSIONS'
7174       include 'COMMON.VAR'
7175       include 'COMMON.GEO'
7176       include 'COMMON.LOCAL'
7177       include 'COMMON.TORSION'
7178       include 'COMMON.SCCOR'
7179       include 'COMMON.INTERACT'
7180       include 'COMMON.DERIV'
7181       include 'COMMON.CHAIN'
7182       include 'COMMON.NAMES'
7183       include 'COMMON.IOUNITS'
7184       include 'COMMON.FFIELD'
7185       include 'COMMON.CONTROL'
7186       logical lprn
7187 C Set lprn=.true. for debugging
7188       lprn=.false.
7189 c      lprn=.true.
7190 c      write (iout,*) "EBACK_SC_COR",itau_start,itau_end
7191       esccor=0.0D0
7192       do i=itau_start,itau_end
7193         if ((itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)) cycle
7194         esccor_ii=0.0D0
7195         isccori=isccortyp(itype(i-2))
7196         isccori1=isccortyp(itype(i-1))
7197 c      write (iout,*) "EBACK_SC_COR",i,nterm_sccor(isccori,isccori1)
7198         phii=phi(i)
7199         do intertyp=1,3 !intertyp
7200 cc Added 09 May 2012 (Adasko)
7201 cc  Intertyp means interaction type of backbone mainchain correlation:
7202 c   1 = SC...Ca...Ca...Ca
7203 c   2 = Ca...Ca...Ca...SC
7204 c   3 = SC...Ca...Ca...SCi
7205         gloci=0.0D0
7206         if (((intertyp.eq.3).and.((itype(i-2).eq.10).or.
7207      &      (itype(i-1).eq.10).or.(itype(i-2).eq.ntyp1).or.
7208      &      (itype(i-1).eq.ntyp1)))
7209      &    .or. ((intertyp.eq.1).and.((itype(i-2).eq.10)
7210      &     .or.(itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)
7211      &     .or.(itype(i).eq.ntyp1)))
7212      &    .or.((intertyp.eq.2).and.((itype(i-1).eq.10).or.
7213      &      (itype(i-1).eq.ntyp1).or.(itype(i-2).eq.ntyp1).or.
7214      &      (itype(i-3).eq.ntyp1)))) cycle
7215         if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1).eq.ntyp1)) cycle
7216         if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres).eq.ntyp1))
7217      & cycle
7218        do j=1,nterm_sccor(isccori,isccori1)
7219           v1ij=v1sccor(j,intertyp,isccori,isccori1)
7220           v2ij=v2sccor(j,intertyp,isccori,isccori1)
7221           cosphi=dcos(j*tauangle(intertyp,i))
7222           sinphi=dsin(j*tauangle(intertyp,i))
7223           esccor=esccor+v1ij*cosphi+v2ij*sinphi
7224           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7225         enddo
7226 c      write (iout,*) "EBACK_SC_COR",i,v1ij*cosphi+v2ij*sinphi,intertyp
7227         gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci
7228         if (lprn)
7229      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
7230      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,isccori,isccori1,
7231      &  (v1sccor(j,intertyp,isccori,isccori1),j=1,6)
7232      & ,(v2sccor(j,intertyp,isccori,isccori1),j=1,6)
7233         gsccor_loc(i-3)=gsccor_loc(i-3)+gloci
7234        enddo !intertyp
7235       enddo
7236
7237       return
7238       end
7239 c----------------------------------------------------------------------------
7240       subroutine multibody(ecorr)
7241 C This subroutine calculates multi-body contributions to energy following
7242 C the idea of Skolnick et al. If side chains I and J make a contact and
7243 C at the same time side chains I+1 and J+1 make a contact, an extra
7244 C contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
7245       implicit real*8 (a-h,o-z)
7246       include 'DIMENSIONS'
7247       include 'COMMON.IOUNITS'
7248       include 'COMMON.DERIV'
7249       include 'COMMON.INTERACT'
7250       include 'COMMON.CONTACTS'
7251       double precision gx(3),gx1(3)
7252       logical lprn
7253
7254 C Set lprn=.true. for debugging
7255       lprn=.false.
7256
7257       if (lprn) then
7258         write (iout,'(a)') 'Contact function values:'
7259         do i=nnt,nct-2
7260           write (iout,'(i2,20(1x,i2,f10.5))')
7261      &        i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
7262         enddo
7263       endif
7264       ecorr=0.0D0
7265       do i=nnt,nct
7266         do j=1,3
7267           gradcorr(j,i)=0.0D0
7268           gradxorr(j,i)=0.0D0
7269         enddo
7270       enddo
7271       do i=nnt,nct-2
7272
7273         DO ISHIFT = 3,4
7274
7275         i1=i+ishift
7276         num_conti=num_cont(i)
7277         num_conti1=num_cont(i1)
7278         do jj=1,num_conti
7279           j=jcont(jj,i)
7280           do kk=1,num_conti1
7281             j1=jcont(kk,i1)
7282             if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
7283 cd          write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
7284 cd   &                   ' ishift=',ishift
7285 C Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
7286 C The system gains extra energy.
7287               ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
7288             endif   ! j1==j+-ishift
7289           enddo     ! kk
7290         enddo       ! jj
7291
7292         ENDDO ! ISHIFT
7293
7294       enddo         ! i
7295       return
7296       end
7297 c------------------------------------------------------------------------------
7298       double precision function esccorr(i,j,k,l,jj,kk)
7299       implicit real*8 (a-h,o-z)
7300       include 'DIMENSIONS'
7301       include 'COMMON.IOUNITS'
7302       include 'COMMON.DERIV'
7303       include 'COMMON.INTERACT'
7304       include 'COMMON.CONTACTS'
7305       double precision gx(3),gx1(3)
7306       logical lprn
7307       lprn=.false.
7308       eij=facont(jj,i)
7309       ekl=facont(kk,k)
7310 cd    write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
7311 C Calculate the multi-body contribution to energy.
7312 C Calculate multi-body contributions to the gradient.
7313 cd    write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
7314 cd   & k,l,(gacont(m,kk,k),m=1,3)
7315       do m=1,3
7316         gx(m) =ekl*gacont(m,jj,i)
7317         gx1(m)=eij*gacont(m,kk,k)
7318         gradxorr(m,i)=gradxorr(m,i)-gx(m)
7319         gradxorr(m,j)=gradxorr(m,j)+gx(m)
7320         gradxorr(m,k)=gradxorr(m,k)-gx1(m)
7321         gradxorr(m,l)=gradxorr(m,l)+gx1(m)
7322       enddo
7323       do m=i,j-1
7324         do ll=1,3
7325           gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
7326         enddo
7327       enddo
7328       do m=k,l-1
7329         do ll=1,3
7330           gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
7331         enddo
7332       enddo
7333       esccorr=-eij*ekl
7334       return
7335       end
7336 c------------------------------------------------------------------------------
7337       subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
7338 C This subroutine calculates multi-body contributions to hydrogen-bonding
7339       implicit real*8 (a-h,o-z)
7340       include 'DIMENSIONS'
7341       include 'COMMON.IOUNITS'
7342 #ifdef MPI
7343       include "mpif.h"
7344       parameter (max_cont=maxconts)
7345       parameter (max_dim=26)
7346       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
7347       double precision zapas(max_dim,maxconts,max_fg_procs),
7348      &  zapas_recv(max_dim,maxconts,max_fg_procs)
7349       common /przechowalnia/ zapas
7350       integer status(MPI_STATUS_SIZE),req(maxconts*2),
7351      &  status_array(MPI_STATUS_SIZE,maxconts*2)
7352 #endif
7353       include 'COMMON.SETUP'
7354       include 'COMMON.FFIELD'
7355       include 'COMMON.DERIV'
7356       include 'COMMON.INTERACT'
7357       include 'COMMON.CONTACTS'
7358       include 'COMMON.CONTROL'
7359       include 'COMMON.LOCAL'
7360       double precision gx(3),gx1(3),time00
7361       logical lprn,ldone
7362
7363 C Set lprn=.true. for debugging
7364       lprn=.false.
7365 #ifdef MPI
7366       n_corr=0
7367       n_corr1=0
7368       if (nfgtasks.le.1) goto 30
7369       if (lprn) then
7370         write (iout,'(a)') 'Contact function values before RECEIVE:'
7371         do i=nnt,nct-2
7372           write (iout,'(2i3,50(1x,i2,f5.2))')
7373      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
7374      &    j=1,num_cont_hb(i))
7375         enddo
7376       endif
7377       call flush(iout)
7378       do i=1,ntask_cont_from
7379         ncont_recv(i)=0
7380       enddo
7381       do i=1,ntask_cont_to
7382         ncont_sent(i)=0
7383       enddo
7384 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
7385 c     & ntask_cont_to
7386 C Make the list of contacts to send to send to other procesors
7387 c      write (iout,*) "limits",max0(iturn4_end-1,iatel_s),iturn3_end
7388 c      call flush(iout)
7389       do i=iturn3_start,iturn3_end
7390 c        write (iout,*) "make contact list turn3",i," num_cont",
7391 c     &    num_cont_hb(i)
7392         call add_hb_contact(i,i+2,iturn3_sent_local(1,i))
7393       enddo
7394       do i=iturn4_start,iturn4_end
7395 c        write (iout,*) "make contact list turn4",i," num_cont",
7396 c     &   num_cont_hb(i)
7397         call add_hb_contact(i,i+3,iturn4_sent_local(1,i))
7398       enddo
7399       do ii=1,nat_sent
7400         i=iat_sent(ii)
7401 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
7402 c     &    num_cont_hb(i)
7403         do j=1,num_cont_hb(i)
7404         do k=1,4
7405           jjc=jcont_hb(j,i)
7406           iproc=iint_sent_local(k,jjc,ii)
7407 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
7408           if (iproc.gt.0) then
7409             ncont_sent(iproc)=ncont_sent(iproc)+1
7410             nn=ncont_sent(iproc)
7411             zapas(1,nn,iproc)=i
7412             zapas(2,nn,iproc)=jjc
7413             zapas(3,nn,iproc)=facont_hb(j,i)
7414             zapas(4,nn,iproc)=ees0p(j,i)
7415             zapas(5,nn,iproc)=ees0m(j,i)
7416             zapas(6,nn,iproc)=gacont_hbr(1,j,i)
7417             zapas(7,nn,iproc)=gacont_hbr(2,j,i)
7418             zapas(8,nn,iproc)=gacont_hbr(3,j,i)
7419             zapas(9,nn,iproc)=gacontm_hb1(1,j,i)
7420             zapas(10,nn,iproc)=gacontm_hb1(2,j,i)
7421             zapas(11,nn,iproc)=gacontm_hb1(3,j,i)
7422             zapas(12,nn,iproc)=gacontp_hb1(1,j,i)
7423             zapas(13,nn,iproc)=gacontp_hb1(2,j,i)
7424             zapas(14,nn,iproc)=gacontp_hb1(3,j,i)
7425             zapas(15,nn,iproc)=gacontm_hb2(1,j,i)
7426             zapas(16,nn,iproc)=gacontm_hb2(2,j,i)
7427             zapas(17,nn,iproc)=gacontm_hb2(3,j,i)
7428             zapas(18,nn,iproc)=gacontp_hb2(1,j,i)
7429             zapas(19,nn,iproc)=gacontp_hb2(2,j,i)
7430             zapas(20,nn,iproc)=gacontp_hb2(3,j,i)
7431             zapas(21,nn,iproc)=gacontm_hb3(1,j,i)
7432             zapas(22,nn,iproc)=gacontm_hb3(2,j,i)
7433             zapas(23,nn,iproc)=gacontm_hb3(3,j,i)
7434             zapas(24,nn,iproc)=gacontp_hb3(1,j,i)
7435             zapas(25,nn,iproc)=gacontp_hb3(2,j,i)
7436             zapas(26,nn,iproc)=gacontp_hb3(3,j,i)
7437           endif
7438         enddo
7439         enddo
7440       enddo
7441       if (lprn) then
7442       write (iout,*)
7443      &  "Numbers of contacts to be sent to other processors",
7444      &  (ncont_sent(i),i=1,ntask_cont_to)
7445       write (iout,*) "Contacts sent"
7446       do ii=1,ntask_cont_to
7447         nn=ncont_sent(ii)
7448         iproc=itask_cont_to(ii)
7449         write (iout,*) nn," contacts to processor",iproc,
7450      &   " of CONT_TO_COMM group"
7451         do i=1,nn
7452           write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
7453         enddo
7454       enddo
7455       call flush(iout)
7456       endif
7457       CorrelType=477
7458       CorrelID=fg_rank+1
7459       CorrelType1=478
7460       CorrelID1=nfgtasks+fg_rank+1
7461       ireq=0
7462 C Receive the numbers of needed contacts from other processors
7463       do ii=1,ntask_cont_from
7464         iproc=itask_cont_from(ii)
7465         ireq=ireq+1
7466         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
7467      &    FG_COMM,req(ireq),IERR)
7468       enddo
7469 c      write (iout,*) "IRECV ended"
7470 c      call flush(iout)
7471 C Send the number of contacts needed by other processors
7472       do ii=1,ntask_cont_to
7473         iproc=itask_cont_to(ii)
7474         ireq=ireq+1
7475         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
7476      &    FG_COMM,req(ireq),IERR)
7477       enddo
7478 c      write (iout,*) "ISEND ended"
7479 c      write (iout,*) "number of requests (nn)",ireq
7480       call flush(iout)
7481       if (ireq.gt.0)
7482      &  call MPI_Waitall(ireq,req,status_array,ierr)
7483 c      write (iout,*)
7484 c     &  "Numbers of contacts to be received from other processors",
7485 c     &  (ncont_recv(i),i=1,ntask_cont_from)
7486 c      call flush(iout)
7487 C Receive contacts
7488       ireq=0
7489       do ii=1,ntask_cont_from
7490         iproc=itask_cont_from(ii)
7491         nn=ncont_recv(ii)
7492 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
7493 c     &   " of CONT_TO_COMM group"
7494         call flush(iout)
7495         if (nn.gt.0) then
7496           ireq=ireq+1
7497           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
7498      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
7499 c          write (iout,*) "ireq,req",ireq,req(ireq)
7500         endif
7501       enddo
7502 C Send the contacts to processors that need them
7503       do ii=1,ntask_cont_to
7504         iproc=itask_cont_to(ii)
7505         nn=ncont_sent(ii)
7506 c        write (iout,*) nn," contacts to processor",iproc,
7507 c     &   " of CONT_TO_COMM group"
7508         if (nn.gt.0) then
7509           ireq=ireq+1
7510           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
7511      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
7512 c          write (iout,*) "ireq,req",ireq,req(ireq)
7513 c          do i=1,nn
7514 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
7515 c          enddo
7516         endif
7517       enddo
7518 c      write (iout,*) "number of requests (contacts)",ireq
7519 c      write (iout,*) "req",(req(i),i=1,4)
7520 c      call flush(iout)
7521       if (ireq.gt.0)
7522      & call MPI_Waitall(ireq,req,status_array,ierr)
7523       do iii=1,ntask_cont_from
7524         iproc=itask_cont_from(iii)
7525         nn=ncont_recv(iii)
7526         if (lprn) then
7527         write (iout,*) "Received",nn," contacts from processor",iproc,
7528      &   " of CONT_FROM_COMM group"
7529         call flush(iout)
7530         do i=1,nn
7531           write(iout,'(2f5.0,4f10.5)')(zapas_recv(j,i,iii),j=1,5)
7532         enddo
7533         call flush(iout)
7534         endif
7535         do i=1,nn
7536           ii=zapas_recv(1,i,iii)
7537 c Flag the received contacts to prevent double-counting
7538           jj=-zapas_recv(2,i,iii)
7539 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
7540 c          call flush(iout)
7541           nnn=num_cont_hb(ii)+1
7542           num_cont_hb(ii)=nnn
7543           jcont_hb(nnn,ii)=jj
7544           facont_hb(nnn,ii)=zapas_recv(3,i,iii)
7545           ees0p(nnn,ii)=zapas_recv(4,i,iii)
7546           ees0m(nnn,ii)=zapas_recv(5,i,iii)
7547           gacont_hbr(1,nnn,ii)=zapas_recv(6,i,iii)
7548           gacont_hbr(2,nnn,ii)=zapas_recv(7,i,iii)
7549           gacont_hbr(3,nnn,ii)=zapas_recv(8,i,iii)
7550           gacontm_hb1(1,nnn,ii)=zapas_recv(9,i,iii)
7551           gacontm_hb1(2,nnn,ii)=zapas_recv(10,i,iii)
7552           gacontm_hb1(3,nnn,ii)=zapas_recv(11,i,iii)
7553           gacontp_hb1(1,nnn,ii)=zapas_recv(12,i,iii)
7554           gacontp_hb1(2,nnn,ii)=zapas_recv(13,i,iii)
7555           gacontp_hb1(3,nnn,ii)=zapas_recv(14,i,iii)
7556           gacontm_hb2(1,nnn,ii)=zapas_recv(15,i,iii)
7557           gacontm_hb2(2,nnn,ii)=zapas_recv(16,i,iii)
7558           gacontm_hb2(3,nnn,ii)=zapas_recv(17,i,iii)
7559           gacontp_hb2(1,nnn,ii)=zapas_recv(18,i,iii)
7560           gacontp_hb2(2,nnn,ii)=zapas_recv(19,i,iii)
7561           gacontp_hb2(3,nnn,ii)=zapas_recv(20,i,iii)
7562           gacontm_hb3(1,nnn,ii)=zapas_recv(21,i,iii)
7563           gacontm_hb3(2,nnn,ii)=zapas_recv(22,i,iii)
7564           gacontm_hb3(3,nnn,ii)=zapas_recv(23,i,iii)
7565           gacontp_hb3(1,nnn,ii)=zapas_recv(24,i,iii)
7566           gacontp_hb3(2,nnn,ii)=zapas_recv(25,i,iii)
7567           gacontp_hb3(3,nnn,ii)=zapas_recv(26,i,iii)
7568         enddo
7569       enddo
7570       call flush(iout)
7571       if (lprn) then
7572         write (iout,'(a)') 'Contact function values after receive:'
7573         do i=nnt,nct-2
7574           write (iout,'(2i3,50(1x,i3,f5.2))')
7575      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
7576      &    j=1,num_cont_hb(i))
7577         enddo
7578         call flush(iout)
7579       endif
7580    30 continue
7581 #endif
7582       if (lprn) then
7583         write (iout,'(a)') 'Contact function values:'
7584         do i=nnt,nct-2
7585           write (iout,'(2i3,50(1x,i3,f5.2))')
7586      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
7587      &    j=1,num_cont_hb(i))
7588         enddo
7589       endif
7590       ecorr=0.0D0
7591 C Remove the loop below after debugging !!!
7592       do i=nnt,nct
7593         do j=1,3
7594           gradcorr(j,i)=0.0D0
7595           gradxorr(j,i)=0.0D0
7596         enddo
7597       enddo
7598 C Calculate the local-electrostatic correlation terms
7599       do i=min0(iatel_s,iturn4_start),max0(iatel_e,iturn3_end)
7600         i1=i+1
7601         num_conti=num_cont_hb(i)
7602         num_conti1=num_cont_hb(i+1)
7603         do jj=1,num_conti
7604           j=jcont_hb(jj,i)
7605           jp=iabs(j)
7606           do kk=1,num_conti1
7607             j1=jcont_hb(kk,i1)
7608             jp1=iabs(j1)
7609 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
7610 c     &         ' jj=',jj,' kk=',kk
7611             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
7612      &          .or. j.lt.0 .and. j1.gt.0) .and.
7613      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
7614 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
7615 C The system gains extra energy.
7616               ecorr=ecorr+ehbcorr(i,jp,i+1,jp1,jj,kk,0.72D0,0.32D0)
7617               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
7618      &            'ecorrh',i,j,ehbcorr(i,j,i+1,j1,jj,kk,0.72D0,0.32D0)
7619               n_corr=n_corr+1
7620             else if (j1.eq.j) then
7621 C Contacts I-J and I-(J+1) occur simultaneously.
7622 C The system loses extra energy.
7623 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
7624             endif
7625           enddo ! kk
7626           do kk=1,num_conti
7627             j1=jcont_hb(kk,i)
7628 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
7629 c    &         ' jj=',jj,' kk=',kk
7630             if (j1.eq.j+1) then
7631 C Contacts I-J and (I+1)-J occur simultaneously.
7632 C The system loses extra energy.
7633 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
7634             endif ! j1==j+1
7635           enddo ! kk
7636         enddo ! jj
7637       enddo ! i
7638       return
7639       end
7640 c------------------------------------------------------------------------------
7641       subroutine add_hb_contact(ii,jj,itask)
7642       implicit real*8 (a-h,o-z)
7643       include "DIMENSIONS"
7644       include "COMMON.IOUNITS"
7645       integer max_cont
7646       integer max_dim
7647       parameter (max_cont=maxconts)
7648       parameter (max_dim=26)
7649       include "COMMON.CONTACTS"
7650       double precision zapas(max_dim,maxconts,max_fg_procs),
7651      &  zapas_recv(max_dim,maxconts,max_fg_procs)
7652       common /przechowalnia/ zapas
7653       integer i,j,ii,jj,iproc,itask(4),nn
7654 c      write (iout,*) "itask",itask
7655       do i=1,2
7656         iproc=itask(i)
7657         if (iproc.gt.0) then
7658           do j=1,num_cont_hb(ii)
7659             jjc=jcont_hb(j,ii)
7660 c            write (iout,*) "i",ii," j",jj," jjc",jjc
7661             if (jjc.eq.jj) then
7662               ncont_sent(iproc)=ncont_sent(iproc)+1
7663               nn=ncont_sent(iproc)
7664               zapas(1,nn,iproc)=ii
7665               zapas(2,nn,iproc)=jjc
7666               zapas(3,nn,iproc)=facont_hb(j,ii)
7667               zapas(4,nn,iproc)=ees0p(j,ii)
7668               zapas(5,nn,iproc)=ees0m(j,ii)
7669               zapas(6,nn,iproc)=gacont_hbr(1,j,ii)
7670               zapas(7,nn,iproc)=gacont_hbr(2,j,ii)
7671               zapas(8,nn,iproc)=gacont_hbr(3,j,ii)
7672               zapas(9,nn,iproc)=gacontm_hb1(1,j,ii)
7673               zapas(10,nn,iproc)=gacontm_hb1(2,j,ii)
7674               zapas(11,nn,iproc)=gacontm_hb1(3,j,ii)
7675               zapas(12,nn,iproc)=gacontp_hb1(1,j,ii)
7676               zapas(13,nn,iproc)=gacontp_hb1(2,j,ii)
7677               zapas(14,nn,iproc)=gacontp_hb1(3,j,ii)
7678               zapas(15,nn,iproc)=gacontm_hb2(1,j,ii)
7679               zapas(16,nn,iproc)=gacontm_hb2(2,j,ii)
7680               zapas(17,nn,iproc)=gacontm_hb2(3,j,ii)
7681               zapas(18,nn,iproc)=gacontp_hb2(1,j,ii)
7682               zapas(19,nn,iproc)=gacontp_hb2(2,j,ii)
7683               zapas(20,nn,iproc)=gacontp_hb2(3,j,ii)
7684               zapas(21,nn,iproc)=gacontm_hb3(1,j,ii)
7685               zapas(22,nn,iproc)=gacontm_hb3(2,j,ii)
7686               zapas(23,nn,iproc)=gacontm_hb3(3,j,ii)
7687               zapas(24,nn,iproc)=gacontp_hb3(1,j,ii)
7688               zapas(25,nn,iproc)=gacontp_hb3(2,j,ii)
7689               zapas(26,nn,iproc)=gacontp_hb3(3,j,ii)
7690               exit
7691             endif
7692           enddo
7693         endif
7694       enddo
7695       return
7696       end
7697 c------------------------------------------------------------------------------
7698       subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,
7699      &  n_corr1)
7700 C This subroutine calculates multi-body contributions to hydrogen-bonding
7701       implicit real*8 (a-h,o-z)
7702       include 'DIMENSIONS'
7703       include 'COMMON.IOUNITS'
7704 #ifdef MPI
7705       include "mpif.h"
7706       parameter (max_cont=maxconts)
7707       parameter (max_dim=70)
7708       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
7709       double precision zapas(max_dim,maxconts,max_fg_procs),
7710      &  zapas_recv(max_dim,maxconts,max_fg_procs)
7711       common /przechowalnia/ zapas
7712       integer status(MPI_STATUS_SIZE),req(maxconts*2),
7713      &  status_array(MPI_STATUS_SIZE,maxconts*2)
7714 #endif
7715       include 'COMMON.SETUP'
7716       include 'COMMON.FFIELD'
7717       include 'COMMON.DERIV'
7718       include 'COMMON.LOCAL'
7719       include 'COMMON.INTERACT'
7720       include 'COMMON.CONTACTS'
7721       include 'COMMON.CHAIN'
7722       include 'COMMON.CONTROL'
7723       double precision gx(3),gx1(3)
7724       integer num_cont_hb_old(maxres)
7725       logical lprn,ldone
7726       double precision eello4,eello5,eelo6,eello_turn6
7727       external eello4,eello5,eello6,eello_turn6
7728 C Set lprn=.true. for debugging
7729       lprn=.false.
7730       eturn6=0.0d0
7731 #ifdef MPI
7732       do i=1,nres
7733         num_cont_hb_old(i)=num_cont_hb(i)
7734       enddo
7735       n_corr=0
7736       n_corr1=0
7737       if (nfgtasks.le.1) goto 30
7738       if (lprn) then
7739         write (iout,'(a)') 'Contact function values before RECEIVE:'
7740         do i=nnt,nct-2
7741           write (iout,'(2i3,50(1x,i2,f5.2))')
7742      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
7743      &    j=1,num_cont_hb(i))
7744         enddo
7745       endif
7746       call flush(iout)
7747       do i=1,ntask_cont_from
7748         ncont_recv(i)=0
7749       enddo
7750       do i=1,ntask_cont_to
7751         ncont_sent(i)=0
7752       enddo
7753 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
7754 c     & ntask_cont_to
7755 C Make the list of contacts to send to send to other procesors
7756       do i=iturn3_start,iturn3_end
7757 c        write (iout,*) "make contact list turn3",i," num_cont",
7758 c     &    num_cont_hb(i)
7759         call add_hb_contact_eello(i,i+2,iturn3_sent_local(1,i))
7760       enddo
7761       do i=iturn4_start,iturn4_end
7762 c        write (iout,*) "make contact list turn4",i," num_cont",
7763 c     &   num_cont_hb(i)
7764         call add_hb_contact_eello(i,i+3,iturn4_sent_local(1,i))
7765       enddo
7766       do ii=1,nat_sent
7767         i=iat_sent(ii)
7768 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
7769 c     &    num_cont_hb(i)
7770         do j=1,num_cont_hb(i)
7771         do k=1,4
7772           jjc=jcont_hb(j,i)
7773           iproc=iint_sent_local(k,jjc,ii)
7774 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
7775           if (iproc.ne.0) then
7776             ncont_sent(iproc)=ncont_sent(iproc)+1
7777             nn=ncont_sent(iproc)
7778             zapas(1,nn,iproc)=i
7779             zapas(2,nn,iproc)=jjc
7780             zapas(3,nn,iproc)=d_cont(j,i)
7781             ind=3
7782             do kk=1,3
7783               ind=ind+1
7784               zapas(ind,nn,iproc)=grij_hb_cont(kk,j,i)
7785             enddo
7786             do kk=1,2
7787               do ll=1,2
7788                 ind=ind+1
7789                 zapas(ind,nn,iproc)=a_chuj(ll,kk,j,i)
7790               enddo
7791             enddo
7792             do jj=1,5
7793               do kk=1,3
7794                 do ll=1,2
7795                   do mm=1,2
7796                     ind=ind+1
7797                     zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,i)
7798                   enddo
7799                 enddo
7800               enddo
7801             enddo
7802           endif
7803         enddo
7804         enddo
7805       enddo
7806       if (lprn) then
7807       write (iout,*)
7808      &  "Numbers of contacts to be sent to other processors",
7809      &  (ncont_sent(i),i=1,ntask_cont_to)
7810       write (iout,*) "Contacts sent"
7811       do ii=1,ntask_cont_to
7812         nn=ncont_sent(ii)
7813         iproc=itask_cont_to(ii)
7814         write (iout,*) nn," contacts to processor",iproc,
7815      &   " of CONT_TO_COMM group"
7816         do i=1,nn
7817           write(iout,'(2f5.0,10f10.5)')(zapas(j,i,ii),j=1,10)
7818         enddo
7819       enddo
7820       call flush(iout)
7821       endif
7822       CorrelType=477
7823       CorrelID=fg_rank+1
7824       CorrelType1=478
7825       CorrelID1=nfgtasks+fg_rank+1
7826       ireq=0
7827 C Receive the numbers of needed contacts from other processors
7828       do ii=1,ntask_cont_from
7829         iproc=itask_cont_from(ii)
7830         ireq=ireq+1
7831         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
7832      &    FG_COMM,req(ireq),IERR)
7833       enddo
7834 c      write (iout,*) "IRECV ended"
7835 c      call flush(iout)
7836 C Send the number of contacts needed by other processors
7837       do ii=1,ntask_cont_to
7838         iproc=itask_cont_to(ii)
7839         ireq=ireq+1
7840         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
7841      &    FG_COMM,req(ireq),IERR)
7842       enddo
7843 c      write (iout,*) "ISEND ended"
7844 c      write (iout,*) "number of requests (nn)",ireq
7845       call flush(iout)
7846       if (ireq.gt.0)
7847      &  call MPI_Waitall(ireq,req,status_array,ierr)
7848 c      write (iout,*)
7849 c     &  "Numbers of contacts to be received from other processors",
7850 c     &  (ncont_recv(i),i=1,ntask_cont_from)
7851 c      call flush(iout)
7852 C Receive contacts
7853       ireq=0
7854       do ii=1,ntask_cont_from
7855         iproc=itask_cont_from(ii)
7856         nn=ncont_recv(ii)
7857 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
7858 c     &   " of CONT_TO_COMM group"
7859         call flush(iout)
7860         if (nn.gt.0) then
7861           ireq=ireq+1
7862           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
7863      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
7864 c          write (iout,*) "ireq,req",ireq,req(ireq)
7865         endif
7866       enddo
7867 C Send the contacts to processors that need them
7868       do ii=1,ntask_cont_to
7869         iproc=itask_cont_to(ii)
7870         nn=ncont_sent(ii)
7871 c        write (iout,*) nn," contacts to processor",iproc,
7872 c     &   " of CONT_TO_COMM group"
7873         if (nn.gt.0) then
7874           ireq=ireq+1
7875           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
7876      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
7877 c          write (iout,*) "ireq,req",ireq,req(ireq)
7878 c          do i=1,nn
7879 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
7880 c          enddo
7881         endif
7882       enddo
7883 c      write (iout,*) "number of requests (contacts)",ireq
7884 c      write (iout,*) "req",(req(i),i=1,4)
7885 c      call flush(iout)
7886       if (ireq.gt.0)
7887      & call MPI_Waitall(ireq,req,status_array,ierr)
7888       do iii=1,ntask_cont_from
7889         iproc=itask_cont_from(iii)
7890         nn=ncont_recv(iii)
7891         if (lprn) then
7892         write (iout,*) "Received",nn," contacts from processor",iproc,
7893      &   " of CONT_FROM_COMM group"
7894         call flush(iout)
7895         do i=1,nn
7896           write(iout,'(2f5.0,10f10.5)')(zapas_recv(j,i,iii),j=1,10)
7897         enddo
7898         call flush(iout)
7899         endif
7900         do i=1,nn
7901           ii=zapas_recv(1,i,iii)
7902 c Flag the received contacts to prevent double-counting
7903           jj=-zapas_recv(2,i,iii)
7904 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
7905 c          call flush(iout)
7906           nnn=num_cont_hb(ii)+1
7907           num_cont_hb(ii)=nnn
7908           jcont_hb(nnn,ii)=jj
7909           d_cont(nnn,ii)=zapas_recv(3,i,iii)
7910           ind=3
7911           do kk=1,3
7912             ind=ind+1
7913             grij_hb_cont(kk,nnn,ii)=zapas_recv(ind,i,iii)
7914           enddo
7915           do kk=1,2
7916             do ll=1,2
7917               ind=ind+1
7918               a_chuj(ll,kk,nnn,ii)=zapas_recv(ind,i,iii)
7919             enddo
7920           enddo
7921           do jj=1,5
7922             do kk=1,3
7923               do ll=1,2
7924                 do mm=1,2
7925                   ind=ind+1
7926                   a_chuj_der(mm,ll,kk,jj,nnn,ii)=zapas_recv(ind,i,iii)
7927                 enddo
7928               enddo
7929             enddo
7930           enddo
7931         enddo
7932       enddo
7933       call flush(iout)
7934       if (lprn) then
7935         write (iout,'(a)') 'Contact function values after receive:'
7936         do i=nnt,nct-2
7937           write (iout,'(2i3,50(1x,i3,5f6.3))')
7938      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
7939      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
7940         enddo
7941         call flush(iout)
7942       endif
7943    30 continue
7944 #endif
7945       if (lprn) then
7946         write (iout,'(a)') 'Contact function values:'
7947         do i=nnt,nct-2
7948           write (iout,'(2i3,50(1x,i2,5f6.3))')
7949      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
7950      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
7951         enddo
7952       endif
7953       ecorr=0.0D0
7954       ecorr5=0.0d0
7955       ecorr6=0.0d0
7956 C Remove the loop below after debugging !!!
7957       do i=nnt,nct
7958         do j=1,3
7959           gradcorr(j,i)=0.0D0
7960           gradxorr(j,i)=0.0D0
7961         enddo
7962       enddo
7963 C Calculate the dipole-dipole interaction energies
7964       if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
7965       do i=iatel_s,iatel_e+1
7966         num_conti=num_cont_hb(i)
7967         do jj=1,num_conti
7968           j=jcont_hb(jj,i)
7969 #ifdef MOMENT
7970           call dipole(i,j,jj)
7971 #endif
7972         enddo
7973       enddo
7974       endif
7975 C Calculate the local-electrostatic correlation terms
7976 c                write (iout,*) "gradcorr5 in eello5 before loop"
7977 c                do iii=1,nres
7978 c                  write (iout,'(i5,3f10.5)')
7979 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
7980 c                enddo
7981       do i=min0(iatel_s,iturn4_start),max0(iatel_e+1,iturn3_end+1)
7982 c        write (iout,*) "corr loop i",i
7983         i1=i+1
7984         num_conti=num_cont_hb(i)
7985         num_conti1=num_cont_hb(i+1)
7986         do jj=1,num_conti
7987           j=jcont_hb(jj,i)
7988           jp=iabs(j)
7989           do kk=1,num_conti1
7990             j1=jcont_hb(kk,i1)
7991             jp1=iabs(j1)
7992 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
7993 c     &         ' jj=',jj,' kk=',kk
7994 c            if (j1.eq.j+1 .or. j1.eq.j-1) then
7995             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
7996      &          .or. j.lt.0 .and. j1.gt.0) .and.
7997      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
7998 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
7999 C The system gains extra energy.
8000               n_corr=n_corr+1
8001               sqd1=dsqrt(d_cont(jj,i))
8002               sqd2=dsqrt(d_cont(kk,i1))
8003               sred_geom = sqd1*sqd2
8004               IF (sred_geom.lt.cutoff_corr) THEN
8005                 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,
8006      &            ekont,fprimcont)
8007 cd               write (iout,*) 'i=',i,' j=',jp,' i1=',i1,' j1=',jp1,
8008 cd     &         ' jj=',jj,' kk=',kk
8009                 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
8010                 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
8011                 do l=1,3
8012                   g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
8013                   g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
8014                 enddo
8015                 n_corr1=n_corr1+1
8016 cd               write (iout,*) 'sred_geom=',sred_geom,
8017 cd     &          ' ekont=',ekont,' fprim=',fprimcont,
8018 cd     &          ' fac_prim1',fac_prim1,' fac_prim2',fac_prim2
8019 cd               write (iout,*) "g_contij",g_contij
8020 cd               write (iout,*) "grij_hb_cont i",grij_hb_cont(:,jj,i)
8021 cd               write (iout,*) "grij_hb_cont i1",grij_hb_cont(:,jj,i1)
8022                 call calc_eello(i,jp,i+1,jp1,jj,kk)
8023                 if (wcorr4.gt.0.0d0)
8024      &            ecorr=ecorr+eello4(i,jp,i+1,jp1,jj,kk)
8025                   if (energy_dec.and.wcorr4.gt.0.0d0)
8026      1                 write (iout,'(a6,4i5,0pf7.3)')
8027      2                'ecorr4',i,j,i+1,j1,eello4(i,jp,i+1,jp1,jj,kk)
8028 c                write (iout,*) "gradcorr5 before eello5"
8029 c                do iii=1,nres
8030 c                  write (iout,'(i5,3f10.5)')
8031 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
8032 c                enddo
8033                 if (wcorr5.gt.0.0d0)
8034      &            ecorr5=ecorr5+eello5(i,jp,i+1,jp1,jj,kk)
8035 c                write (iout,*) "gradcorr5 after eello5"
8036 c                do iii=1,nres
8037 c                  write (iout,'(i5,3f10.5)')
8038 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
8039 c                enddo
8040                   if (energy_dec.and.wcorr5.gt.0.0d0)
8041      1                 write (iout,'(a6,4i5,0pf7.3)')
8042      2                'ecorr5',i,j,i+1,j1,eello5(i,jp,i+1,jp1,jj,kk)
8043 cd                write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
8044 cd                write(2,*)'ijkl',i,jp,i+1,jp1
8045                 if (wcorr6.gt.0.0d0 .and. (jp.ne.i+4 .or. jp1.ne.i+3
8046      &               .or. wturn6.eq.0.0d0))then
8047 cd                  write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
8048                   ecorr6=ecorr6+eello6(i,jp,i+1,jp1,jj,kk)
8049                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
8050      1                'ecorr6',i,j,i+1,j1,eello6(i,jp,i+1,jp1,jj,kk)
8051 cd                write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
8052 cd     &            'ecorr6=',ecorr6
8053 cd                write (iout,'(4e15.5)') sred_geom,
8054 cd     &          dabs(eello4(i,jp,i+1,jp1,jj,kk)),
8055 cd     &          dabs(eello5(i,jp,i+1,jp1,jj,kk)),
8056 cd     &          dabs(eello6(i,jp,i+1,jp1,jj,kk))
8057                 else if (wturn6.gt.0.0d0
8058      &            .and. (jp.eq.i+4 .and. jp1.eq.i+3)) then
8059 cd                  write (iout,*) '******eturn6: i,j,i+1,j1',i,jip,i+1,jp1
8060                   eturn6=eturn6+eello_turn6(i,jj,kk)
8061                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
8062      1                 'eturn6',i,j,i+1,j1,eello_turn6(i,jj,kk)
8063 cd                  write (2,*) 'multibody_eello:eturn6',eturn6
8064                 endif
8065               ENDIF
8066 1111          continue
8067             endif
8068           enddo ! kk
8069         enddo ! jj
8070       enddo ! i
8071       do i=1,nres
8072         num_cont_hb(i)=num_cont_hb_old(i)
8073       enddo
8074 c                write (iout,*) "gradcorr5 in eello5"
8075 c                do iii=1,nres
8076 c                  write (iout,'(i5,3f10.5)')
8077 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
8078 c                enddo
8079       return
8080       end
8081 c------------------------------------------------------------------------------
8082       subroutine add_hb_contact_eello(ii,jj,itask)
8083       implicit real*8 (a-h,o-z)
8084       include "DIMENSIONS"
8085       include "COMMON.IOUNITS"
8086       integer max_cont
8087       integer max_dim
8088       parameter (max_cont=maxconts)
8089       parameter (max_dim=70)
8090       include "COMMON.CONTACTS"
8091       double precision zapas(max_dim,maxconts,max_fg_procs),
8092      &  zapas_recv(max_dim,maxconts,max_fg_procs)
8093       common /przechowalnia/ zapas
8094       integer i,j,ii,jj,iproc,itask(4),nn
8095 c      write (iout,*) "itask",itask
8096       do i=1,2
8097         iproc=itask(i)
8098         if (iproc.gt.0) then
8099           do j=1,num_cont_hb(ii)
8100             jjc=jcont_hb(j,ii)
8101 c            write (iout,*) "send turns i",ii," j",jj," jjc",jjc
8102             if (jjc.eq.jj) then
8103               ncont_sent(iproc)=ncont_sent(iproc)+1
8104               nn=ncont_sent(iproc)
8105               zapas(1,nn,iproc)=ii
8106               zapas(2,nn,iproc)=jjc
8107               zapas(3,nn,iproc)=d_cont(j,ii)
8108               ind=3
8109               do kk=1,3
8110                 ind=ind+1
8111                 zapas(ind,nn,iproc)=grij_hb_cont(kk,j,ii)
8112               enddo
8113               do kk=1,2
8114                 do ll=1,2
8115                   ind=ind+1
8116                   zapas(ind,nn,iproc)=a_chuj(ll,kk,j,ii)
8117                 enddo
8118               enddo
8119               do jj=1,5
8120                 do kk=1,3
8121                   do ll=1,2
8122                     do mm=1,2
8123                       ind=ind+1
8124                       zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,ii)
8125                     enddo
8126                   enddo
8127                 enddo
8128               enddo
8129               exit
8130             endif
8131           enddo
8132         endif
8133       enddo
8134       return
8135       end
8136 c------------------------------------------------------------------------------
8137       double precision function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
8138       implicit real*8 (a-h,o-z)
8139       include 'DIMENSIONS'
8140       include 'COMMON.IOUNITS'
8141       include 'COMMON.DERIV'
8142       include 'COMMON.INTERACT'
8143       include 'COMMON.CONTACTS'
8144       double precision gx(3),gx1(3)
8145       logical lprn
8146       lprn=.false.
8147       eij=facont_hb(jj,i)
8148       ekl=facont_hb(kk,k)
8149       ees0pij=ees0p(jj,i)
8150       ees0pkl=ees0p(kk,k)
8151       ees0mij=ees0m(jj,i)
8152       ees0mkl=ees0m(kk,k)
8153       ekont=eij*ekl
8154       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
8155 cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
8156 C Following 4 lines for diagnostics.
8157 cd    ees0pkl=0.0D0
8158 cd    ees0pij=1.0D0
8159 cd    ees0mkl=0.0D0
8160 cd    ees0mij=1.0D0
8161 c      write (iout,'(2(a,2i3,a,f10.5,a,2f10.5),a,f10.5,a,$)')
8162 c     & 'Contacts ',i,j,
8163 c     & ' eij',eij,' eesij',ees0pij,ees0mij,' and ',k,l
8164 c     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' energy=',ekont*ees,
8165 c     & 'gradcorr_long'
8166 C Calculate the multi-body contribution to energy.
8167 c      ecorr=ecorr+ekont*ees
8168 C Calculate multi-body contributions to the gradient.
8169       coeffpees0pij=coeffp*ees0pij
8170       coeffmees0mij=coeffm*ees0mij
8171       coeffpees0pkl=coeffp*ees0pkl
8172       coeffmees0mkl=coeffm*ees0mkl
8173       do ll=1,3
8174 cgrad        ghalfi=ees*ekl*gacont_hbr(ll,jj,i)
8175         gradcorr(ll,i)=gradcorr(ll,i)!+0.5d0*ghalfi
8176      &  -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+
8177      &  coeffmees0mkl*gacontm_hb1(ll,jj,i))
8178         gradcorr(ll,j)=gradcorr(ll,j)!+0.5d0*ghalfi
8179      &  -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+
8180      &  coeffmees0mkl*gacontm_hb2(ll,jj,i))
8181 cgrad        ghalfk=ees*eij*gacont_hbr(ll,kk,k)
8182         gradcorr(ll,k)=gradcorr(ll,k)!+0.5d0*ghalfk
8183      &  -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+
8184      &  coeffmees0mij*gacontm_hb1(ll,kk,k))
8185         gradcorr(ll,l)=gradcorr(ll,l)!+0.5d0*ghalfk
8186      &  -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+
8187      &  coeffmees0mij*gacontm_hb2(ll,kk,k))
8188         gradlongij=ees*ekl*gacont_hbr(ll,jj,i)-
8189      &     ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+
8190      &     coeffmees0mkl*gacontm_hb3(ll,jj,i))
8191         gradcorr_long(ll,j)=gradcorr_long(ll,j)+gradlongij
8192         gradcorr_long(ll,i)=gradcorr_long(ll,i)-gradlongij
8193         gradlongkl=ees*eij*gacont_hbr(ll,kk,k)-
8194      &     ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+
8195      &     coeffmees0mij*gacontm_hb3(ll,kk,k))
8196         gradcorr_long(ll,l)=gradcorr_long(ll,l)+gradlongkl
8197         gradcorr_long(ll,k)=gradcorr_long(ll,k)-gradlongkl
8198 c        write (iout,'(2f10.5,2x,$)') gradlongij,gradlongkl
8199       enddo
8200 c      write (iout,*)
8201 cgrad      do m=i+1,j-1
8202 cgrad        do ll=1,3
8203 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
8204 cgrad     &     ees*ekl*gacont_hbr(ll,jj,i)-
8205 cgrad     &     ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
8206 cgrad     &     coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
8207 cgrad        enddo
8208 cgrad      enddo
8209 cgrad      do m=k+1,l-1
8210 cgrad        do ll=1,3
8211 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
8212 cgrad     &     ees*eij*gacont_hbr(ll,kk,k)-
8213 cgrad     &     ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
8214 cgrad     &     coeffm*ees0mij*gacontm_hb3(ll,kk,k))
8215 cgrad        enddo
8216 cgrad      enddo
8217 c      write (iout,*) "ehbcorr",ekont*ees
8218       ehbcorr=ekont*ees
8219       return
8220       end
8221 #ifdef MOMENT
8222 C---------------------------------------------------------------------------
8223       subroutine dipole(i,j,jj)
8224       implicit real*8 (a-h,o-z)
8225       include 'DIMENSIONS'
8226       include 'COMMON.IOUNITS'
8227       include 'COMMON.CHAIN'
8228       include 'COMMON.FFIELD'
8229       include 'COMMON.DERIV'
8230       include 'COMMON.INTERACT'
8231       include 'COMMON.CONTACTS'
8232       include 'COMMON.TORSION'
8233       include 'COMMON.VAR'
8234       include 'COMMON.GEO'
8235       dimension dipi(2,2),dipj(2,2),dipderi(2),dipderj(2),auxvec(2),
8236      &  auxmat(2,2)
8237       iti1 = itortyp(itype(i+1))
8238       if (j.lt.nres-1) then
8239         itj1 = itortyp(itype(j+1))
8240       else
8241         itj1=ntortyp
8242       endif
8243       do iii=1,2
8244         dipi(iii,1)=Ub2(iii,i)
8245         dipderi(iii)=Ub2der(iii,i)
8246         dipi(iii,2)=b1(iii,i+1)
8247         dipj(iii,1)=Ub2(iii,j)
8248         dipderj(iii)=Ub2der(iii,j)
8249         dipj(iii,2)=b1(iii,j+1)
8250       enddo
8251       kkk=0
8252       do iii=1,2
8253         call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
8254         do jjj=1,2
8255           kkk=kkk+1
8256           dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
8257         enddo
8258       enddo
8259       do kkk=1,5
8260         do lll=1,3
8261           mmm=0
8262           do iii=1,2
8263             call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),
8264      &        auxvec(1))
8265             do jjj=1,2
8266               mmm=mmm+1
8267               dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
8268             enddo
8269           enddo
8270         enddo
8271       enddo
8272       call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
8273       call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
8274       do iii=1,2
8275         dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
8276       enddo
8277       call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
8278       do iii=1,2
8279         dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
8280       enddo
8281       return
8282       end
8283 #endif
8284 C---------------------------------------------------------------------------
8285       subroutine calc_eello(i,j,k,l,jj,kk)
8286 C
8287 C This subroutine computes matrices and vectors needed to calculate
8288 C the fourth-, fifth-, and sixth-order local-electrostatic terms.
8289 C
8290       implicit real*8 (a-h,o-z)
8291       include 'DIMENSIONS'
8292       include 'COMMON.IOUNITS'
8293       include 'COMMON.CHAIN'
8294       include 'COMMON.DERIV'
8295       include 'COMMON.INTERACT'
8296       include 'COMMON.CONTACTS'
8297       include 'COMMON.TORSION'
8298       include 'COMMON.VAR'
8299       include 'COMMON.GEO'
8300       include 'COMMON.FFIELD'
8301       double precision aa1(2,2),aa2(2,2),aa1t(2,2),aa2t(2,2),
8302      &  aa1tder(2,2,3,5),aa2tder(2,2,3,5),auxmat(2,2)
8303       logical lprn
8304       common /kutas/ lprn
8305 cd      write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
8306 cd     & ' jj=',jj,' kk=',kk
8307 cd      if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
8308 cd      write (iout,*) "a_chujij",((a_chuj(iii,jjj,jj,i),iii=1,2),jjj=1,2)
8309 cd      write (iout,*) "a_chujkl",((a_chuj(iii,jjj,kk,k),iii=1,2),jjj=1,2)
8310       do iii=1,2
8311         do jjj=1,2
8312           aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
8313           aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
8314         enddo
8315       enddo
8316       call transpose2(aa1(1,1),aa1t(1,1))
8317       call transpose2(aa2(1,1),aa2t(1,1))
8318       do kkk=1,5
8319         do lll=1,3
8320           call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),
8321      &      aa1tder(1,1,lll,kkk))
8322           call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),
8323      &      aa2tder(1,1,lll,kkk))
8324         enddo
8325       enddo
8326       if (l.eq.j+1) then
8327 C parallel orientation of the two CA-CA-CA frames.
8328         if (i.gt.1) then
8329           iti=itortyp(itype(i))
8330         else
8331           iti=ntortyp
8332         endif
8333         itk1=itortyp(itype(k+1))
8334         itj=itortyp(itype(j))
8335         if (l.lt.nres-1) then
8336           itl1=itortyp(itype(l+1))
8337         else
8338           itl1=ntortyp
8339         endif
8340 C A1 kernel(j+1) A2T
8341 cd        do iii=1,2
8342 cd          write (iout,'(3f10.5,5x,3f10.5)')
8343 cd     &     (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
8344 cd        enddo
8345         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
8346      &   aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),
8347      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
8348 C Following matrices are needed only for 6-th order cumulants
8349         IF (wcorr6.gt.0.0d0) THEN
8350         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
8351      &   aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),
8352      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
8353         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
8354      &   aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),
8355      &   Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
8356      &   ADtEAderx(1,1,1,1,1,1))
8357         lprn=.false.
8358         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
8359      &   aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),
8360      &   DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
8361      &   ADtEA1derx(1,1,1,1,1,1))
8362         ENDIF
8363 C End 6-th order cumulants
8364 cd        lprn=.false.
8365 cd        if (lprn) then
8366 cd        write (2,*) 'In calc_eello6'
8367 cd        do iii=1,2
8368 cd          write (2,*) 'iii=',iii
8369 cd          do kkk=1,5
8370 cd            write (2,*) 'kkk=',kkk
8371 cd            do jjj=1,2
8372 cd              write (2,'(3(2f10.5),5x)')
8373 cd     &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
8374 cd            enddo
8375 cd          enddo
8376 cd        enddo
8377 cd        endif
8378         call transpose2(EUgder(1,1,k),auxmat(1,1))
8379         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
8380         call transpose2(EUg(1,1,k),auxmat(1,1))
8381         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
8382         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
8383         do iii=1,2
8384           do kkk=1,5
8385             do lll=1,3
8386               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
8387      &          EAEAderx(1,1,lll,kkk,iii,1))
8388             enddo
8389           enddo
8390         enddo
8391 C A1T kernel(i+1) A2
8392         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
8393      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),
8394      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
8395 C Following matrices are needed only for 6-th order cumulants
8396         IF (wcorr6.gt.0.0d0) THEN
8397         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
8398      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),
8399      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
8400         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
8401      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),
8402      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
8403      &   ADtEAderx(1,1,1,1,1,2))
8404         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
8405      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),
8406      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
8407      &   ADtEA1derx(1,1,1,1,1,2))
8408         ENDIF
8409 C End 6-th order cumulants
8410         call transpose2(EUgder(1,1,l),auxmat(1,1))
8411         call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
8412         call transpose2(EUg(1,1,l),auxmat(1,1))
8413         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
8414         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
8415         do iii=1,2
8416           do kkk=1,5
8417             do lll=1,3
8418               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
8419      &          EAEAderx(1,1,lll,kkk,iii,2))
8420             enddo
8421           enddo
8422         enddo
8423 C AEAb1 and AEAb2
8424 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
8425 C They are needed only when the fifth- or the sixth-order cumulants are
8426 C indluded.
8427         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
8428         call transpose2(AEA(1,1,1),auxmat(1,1))
8429         call matvec2(auxmat(1,1),b1(1,i),AEAb1(1,1,1))
8430         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
8431         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
8432         call transpose2(AEAderg(1,1,1),auxmat(1,1))
8433         call matvec2(auxmat(1,1),b1(1,i),AEAb1derg(1,1,1))
8434         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
8435         call matvec2(AEA(1,1,1),b1(1,k+1),AEAb1(1,2,1))
8436         call matvec2(AEAderg(1,1,1),b1(1,k+1),AEAb1derg(1,2,1))
8437         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
8438         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
8439         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
8440         call transpose2(AEA(1,1,2),auxmat(1,1))
8441         call matvec2(auxmat(1,1),b1(1,j),AEAb1(1,1,2))
8442         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
8443         call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
8444         call transpose2(AEAderg(1,1,2),auxmat(1,1))
8445         call matvec2(auxmat(1,1),b1(1,j),AEAb1derg(1,1,2))
8446         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
8447         call matvec2(AEA(1,1,2),b1(1,l+1),AEAb1(1,2,2))
8448         call matvec2(AEAderg(1,1,2),b1(1,l+1),AEAb1derg(1,2,2))
8449         call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
8450         call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
8451         call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
8452 C Calculate the Cartesian derivatives of the vectors.
8453         do iii=1,2
8454           do kkk=1,5
8455             do lll=1,3
8456               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
8457               call matvec2(auxmat(1,1),b1(1,i),
8458      &          AEAb1derx(1,lll,kkk,iii,1,1))
8459               call matvec2(auxmat(1,1),Ub2(1,i),
8460      &          AEAb2derx(1,lll,kkk,iii,1,1))
8461               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
8462      &          AEAb1derx(1,lll,kkk,iii,2,1))
8463               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
8464      &          AEAb2derx(1,lll,kkk,iii,2,1))
8465               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
8466               call matvec2(auxmat(1,1),b1(1,j),
8467      &          AEAb1derx(1,lll,kkk,iii,1,2))
8468               call matvec2(auxmat(1,1),Ub2(1,j),
8469      &          AEAb2derx(1,lll,kkk,iii,1,2))
8470               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,l+1),
8471      &          AEAb1derx(1,lll,kkk,iii,2,2))
8472               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),
8473      &          AEAb2derx(1,lll,kkk,iii,2,2))
8474             enddo
8475           enddo
8476         enddo
8477         ENDIF
8478 C End vectors
8479       else
8480 C Antiparallel orientation of the two CA-CA-CA frames.
8481         if (i.gt.1) then
8482           iti=itortyp(itype(i))
8483         else
8484           iti=ntortyp
8485         endif
8486         itk1=itortyp(itype(k+1))
8487         itl=itortyp(itype(l))
8488         itj=itortyp(itype(j))
8489         if (j.lt.nres-1) then
8490           itj1=itortyp(itype(j+1))
8491         else
8492           itj1=ntortyp
8493         endif
8494 C A2 kernel(j-1)T A1T
8495         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
8496      &   aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),
8497      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
8498 C Following matrices are needed only for 6-th order cumulants
8499         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
8500      &     j.eq.i+4 .and. l.eq.i+3)) THEN
8501         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
8502      &   aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),
8503      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
8504         call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
8505      &   aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),
8506      &   Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
8507      &   ADtEAderx(1,1,1,1,1,1))
8508         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
8509      &   aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),
8510      &   DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
8511      &   ADtEA1derx(1,1,1,1,1,1))
8512         ENDIF
8513 C End 6-th order cumulants
8514         call transpose2(EUgder(1,1,k),auxmat(1,1))
8515         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
8516         call transpose2(EUg(1,1,k),auxmat(1,1))
8517         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
8518         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
8519         do iii=1,2
8520           do kkk=1,5
8521             do lll=1,3
8522               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
8523      &          EAEAderx(1,1,lll,kkk,iii,1))
8524             enddo
8525           enddo
8526         enddo
8527 C A2T kernel(i+1)T A1
8528         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
8529      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),
8530      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
8531 C Following matrices are needed only for 6-th order cumulants
8532         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
8533      &     j.eq.i+4 .and. l.eq.i+3)) THEN
8534         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
8535      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),
8536      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
8537         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
8538      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),
8539      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
8540      &   ADtEAderx(1,1,1,1,1,2))
8541         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
8542      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),
8543      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
8544      &   ADtEA1derx(1,1,1,1,1,2))
8545         ENDIF
8546 C End 6-th order cumulants
8547         call transpose2(EUgder(1,1,j),auxmat(1,1))
8548         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
8549         call transpose2(EUg(1,1,j),auxmat(1,1))
8550         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
8551         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
8552         do iii=1,2
8553           do kkk=1,5
8554             do lll=1,3
8555               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
8556      &          EAEAderx(1,1,lll,kkk,iii,2))
8557             enddo
8558           enddo
8559         enddo
8560 C AEAb1 and AEAb2
8561 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
8562 C They are needed only when the fifth- or the sixth-order cumulants are
8563 C indluded.
8564         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or.
8565      &    (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
8566         call transpose2(AEA(1,1,1),auxmat(1,1))
8567         call matvec2(auxmat(1,1),b1(1,i),AEAb1(1,1,1))
8568         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
8569         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
8570         call transpose2(AEAderg(1,1,1),auxmat(1,1))
8571         call matvec2(auxmat(1,1),b1(1,i),AEAb1derg(1,1,1))
8572         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
8573         call matvec2(AEA(1,1,1),b1(1,k+1),AEAb1(1,2,1))
8574         call matvec2(AEAderg(1,1,1),b1(1,k+1),AEAb1derg(1,2,1))
8575         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
8576         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
8577         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
8578         call transpose2(AEA(1,1,2),auxmat(1,1))
8579         call matvec2(auxmat(1,1),b1(1,j+1),AEAb1(1,1,2))
8580         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
8581         call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
8582         call transpose2(AEAderg(1,1,2),auxmat(1,1))
8583         call matvec2(auxmat(1,1),b1(1,l),AEAb1(1,1,2))
8584         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
8585         call matvec2(AEA(1,1,2),b1(1,j+1),AEAb1(1,2,2))
8586         call matvec2(AEAderg(1,1,2),b1(1,j+1),AEAb1derg(1,2,2))
8587         call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
8588         call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
8589         call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
8590 C Calculate the Cartesian derivatives of the vectors.
8591         do iii=1,2
8592           do kkk=1,5
8593             do lll=1,3
8594               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
8595               call matvec2(auxmat(1,1),b1(1,i),
8596      &          AEAb1derx(1,lll,kkk,iii,1,1))
8597               call matvec2(auxmat(1,1),Ub2(1,i),
8598      &          AEAb2derx(1,lll,kkk,iii,1,1))
8599               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
8600      &          AEAb1derx(1,lll,kkk,iii,2,1))
8601               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
8602      &          AEAb2derx(1,lll,kkk,iii,2,1))
8603               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
8604               call matvec2(auxmat(1,1),b1(1,l),
8605      &          AEAb1derx(1,lll,kkk,iii,1,2))
8606               call matvec2(auxmat(1,1),Ub2(1,l),
8607      &          AEAb2derx(1,lll,kkk,iii,1,2))
8608               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,j+1),
8609      &          AEAb1derx(1,lll,kkk,iii,2,2))
8610               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),
8611      &          AEAb2derx(1,lll,kkk,iii,2,2))
8612             enddo
8613           enddo
8614         enddo
8615         ENDIF
8616 C End vectors
8617       endif
8618       return
8619       end
8620 C---------------------------------------------------------------------------
8621       subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,
8622      &  KK,KKderg,AKA,AKAderg,AKAderx)
8623       implicit none
8624       integer nderg
8625       logical transp
8626       double precision aa1(2,2),aa2t(2,2),aa1derx(2,2,3,5),
8627      &  aa2tderx(2,2,3,5),KK(2,2),KKderg(2,2,nderg),AKA(2,2),
8628      &  AKAderg(2,2,nderg),AKAderx(2,2,3,5,2)
8629       integer iii,kkk,lll
8630       integer jjj,mmm
8631       logical lprn
8632       common /kutas/ lprn
8633       call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
8634       do iii=1,nderg
8635         call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,
8636      &    AKAderg(1,1,iii))
8637       enddo
8638 cd      if (lprn) write (2,*) 'In kernel'
8639       do kkk=1,5
8640 cd        if (lprn) write (2,*) 'kkk=',kkk
8641         do lll=1,3
8642           call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),
8643      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
8644 cd          if (lprn) then
8645 cd            write (2,*) 'lll=',lll
8646 cd            write (2,*) 'iii=1'
8647 cd            do jjj=1,2
8648 cd              write (2,'(3(2f10.5),5x)')
8649 cd     &        (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
8650 cd            enddo
8651 cd          endif
8652           call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),
8653      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
8654 cd          if (lprn) then
8655 cd            write (2,*) 'lll=',lll
8656 cd            write (2,*) 'iii=2'
8657 cd            do jjj=1,2
8658 cd              write (2,'(3(2f10.5),5x)')
8659 cd     &        (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
8660 cd            enddo
8661 cd          endif
8662         enddo
8663       enddo
8664       return
8665       end
8666 C---------------------------------------------------------------------------
8667       double precision function eello4(i,j,k,l,jj,kk)
8668       implicit real*8 (a-h,o-z)
8669       include 'DIMENSIONS'
8670       include 'COMMON.IOUNITS'
8671       include 'COMMON.CHAIN'
8672       include 'COMMON.DERIV'
8673       include 'COMMON.INTERACT'
8674       include 'COMMON.CONTACTS'
8675       include 'COMMON.TORSION'
8676       include 'COMMON.VAR'
8677       include 'COMMON.GEO'
8678       double precision pizda(2,2),ggg1(3),ggg2(3)
8679 cd      if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
8680 cd        eello4=0.0d0
8681 cd        return
8682 cd      endif
8683 cd      print *,'eello4:',i,j,k,l,jj,kk
8684 cd      write (2,*) 'i',i,' j',j,' k',k,' l',l
8685 cd      call checkint4(i,j,k,l,jj,kk,eel4_num)
8686 cold      eij=facont_hb(jj,i)
8687 cold      ekl=facont_hb(kk,k)
8688 cold      ekont=eij*ekl
8689       eel4=-EAEA(1,1,1)-EAEA(2,2,1)
8690 cd      eel41=-EAEA(1,1,2)-EAEA(2,2,2)
8691       gcorr_loc(k-1)=gcorr_loc(k-1)
8692      &   -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
8693       if (l.eq.j+1) then
8694         gcorr_loc(l-1)=gcorr_loc(l-1)
8695      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
8696       else
8697         gcorr_loc(j-1)=gcorr_loc(j-1)
8698      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
8699       endif
8700       do iii=1,2
8701         do kkk=1,5
8702           do lll=1,3
8703             derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1)
8704      &                        -EAEAderx(2,2,lll,kkk,iii,1)
8705 cd            derx(lll,kkk,iii)=0.0d0
8706           enddo
8707         enddo
8708       enddo
8709 cd      gcorr_loc(l-1)=0.0d0
8710 cd      gcorr_loc(j-1)=0.0d0
8711 cd      gcorr_loc(k-1)=0.0d0
8712 cd      eel4=1.0d0
8713 cd      write (iout,*)'Contacts have occurred for peptide groups',
8714 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l,
8715 cd     &  ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
8716       if (j.lt.nres-1) then
8717         j1=j+1
8718         j2=j-1
8719       else
8720         j1=j-1
8721         j2=j-2
8722       endif
8723       if (l.lt.nres-1) then
8724         l1=l+1
8725         l2=l-1
8726       else
8727         l1=l-1
8728         l2=l-2
8729       endif
8730       do ll=1,3
8731 cgrad        ggg1(ll)=eel4*g_contij(ll,1)
8732 cgrad        ggg2(ll)=eel4*g_contij(ll,2)
8733         glongij=eel4*g_contij(ll,1)+ekont*derx(ll,1,1)
8734         glongkl=eel4*g_contij(ll,2)+ekont*derx(ll,1,2)
8735 cgrad        ghalf=0.5d0*ggg1(ll)
8736         gradcorr(ll,i)=gradcorr(ll,i)+ekont*derx(ll,2,1)
8737         gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
8738         gradcorr(ll,j)=gradcorr(ll,j)+ekont*derx(ll,4,1)
8739         gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
8740         gradcorr_long(ll,j)=gradcorr_long(ll,j)+glongij
8741         gradcorr_long(ll,i)=gradcorr_long(ll,i)-glongij
8742 cgrad        ghalf=0.5d0*ggg2(ll)
8743         gradcorr(ll,k)=gradcorr(ll,k)+ekont*derx(ll,2,2)
8744         gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
8745         gradcorr(ll,l)=gradcorr(ll,l)+ekont*derx(ll,4,2)
8746         gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
8747         gradcorr_long(ll,l)=gradcorr_long(ll,l)+glongkl
8748         gradcorr_long(ll,k)=gradcorr_long(ll,k)-glongkl
8749       enddo
8750 cgrad      do m=i+1,j-1
8751 cgrad        do ll=1,3
8752 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
8753 cgrad        enddo
8754 cgrad      enddo
8755 cgrad      do m=k+1,l-1
8756 cgrad        do ll=1,3
8757 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
8758 cgrad        enddo
8759 cgrad      enddo
8760 cgrad      do m=i+2,j2
8761 cgrad        do ll=1,3
8762 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
8763 cgrad        enddo
8764 cgrad      enddo
8765 cgrad      do m=k+2,l2
8766 cgrad        do ll=1,3
8767 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
8768 cgrad        enddo
8769 cgrad      enddo
8770 cd      do iii=1,nres-3
8771 cd        write (2,*) iii,gcorr_loc(iii)
8772 cd      enddo
8773       eello4=ekont*eel4
8774 cd      write (2,*) 'ekont',ekont
8775 cd      write (iout,*) 'eello4',ekont*eel4
8776       return
8777       end
8778 C---------------------------------------------------------------------------
8779       double precision function eello5(i,j,k,l,jj,kk)
8780       implicit real*8 (a-h,o-z)
8781       include 'DIMENSIONS'
8782       include 'COMMON.IOUNITS'
8783       include 'COMMON.CHAIN'
8784       include 'COMMON.DERIV'
8785       include 'COMMON.INTERACT'
8786       include 'COMMON.CONTACTS'
8787       include 'COMMON.TORSION'
8788       include 'COMMON.VAR'
8789       include 'COMMON.GEO'
8790       double precision pizda(2,2),auxmat(2,2),auxmat1(2,2),vv(2)
8791       double precision ggg1(3),ggg2(3)
8792 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8793 C                                                                              C
8794 C                            Parallel chains                                   C
8795 C                                                                              C
8796 C          o             o                   o             o                   C
8797 C         /l\           / \             \   / \           / \   /              C
8798 C        /   \         /   \             \ /   \         /   \ /               C
8799 C       j| o |l1       | o |              o| o |         | o |o                C
8800 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
8801 C      \i/   \         /   \ /             /   \         /   \                 C
8802 C       o    k1             o                                                  C
8803 C         (I)          (II)                (III)          (IV)                 C
8804 C                                                                              C
8805 C      eello5_1        eello5_2            eello5_3       eello5_4             C
8806 C                                                                              C
8807 C                            Antiparallel chains                               C
8808 C                                                                              C
8809 C          o             o                   o             o                   C
8810 C         /j\           / \             \   / \           / \   /              C
8811 C        /   \         /   \             \ /   \         /   \ /               C
8812 C      j1| o |l        | o |              o| o |         | o |o                C
8813 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
8814 C      \i/   \         /   \ /             /   \         /   \                 C
8815 C       o     k1            o                                                  C
8816 C         (I)          (II)                (III)          (IV)                 C
8817 C                                                                              C
8818 C      eello5_1        eello5_2            eello5_3       eello5_4             C
8819 C                                                                              C
8820 C o denotes a local interaction, vertical lines an electrostatic interaction.  C
8821 C                                                                              C
8822 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8823 cd      if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
8824 cd        eello5=0.0d0
8825 cd        return
8826 cd      endif
8827 cd      write (iout,*)
8828 cd     &   'EELLO5: Contacts have occurred for peptide groups',i,j,
8829 cd     &   ' and',k,l
8830       itk=itortyp(itype(k))
8831       itl=itortyp(itype(l))
8832       itj=itortyp(itype(j))
8833       eello5_1=0.0d0
8834       eello5_2=0.0d0
8835       eello5_3=0.0d0
8836       eello5_4=0.0d0
8837 cd      call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
8838 cd     &   eel5_3_num,eel5_4_num)
8839       do iii=1,2
8840         do kkk=1,5
8841           do lll=1,3
8842             derx(lll,kkk,iii)=0.0d0
8843           enddo
8844         enddo
8845       enddo
8846 cd      eij=facont_hb(jj,i)
8847 cd      ekl=facont_hb(kk,k)
8848 cd      ekont=eij*ekl
8849 cd      write (iout,*)'Contacts have occurred for peptide groups',
8850 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l
8851 cd      goto 1111
8852 C Contribution from the graph I.
8853 cd      write (2,*) 'AEA  ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
8854 cd      write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
8855       call transpose2(EUg(1,1,k),auxmat(1,1))
8856       call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
8857       vv(1)=pizda(1,1)-pizda(2,2)
8858       vv(2)=pizda(1,2)+pizda(2,1)
8859       eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k))
8860      & +0.5d0*scalar2(vv(1),Dtobr2(1,i))
8861 C Explicit gradient in virtual-dihedral angles.
8862       if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1)
8863      & +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k))
8864      & +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
8865       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8866       call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
8867       vv(1)=pizda(1,1)-pizda(2,2)
8868       vv(2)=pizda(1,2)+pizda(2,1)
8869       g_corr5_loc(k-1)=g_corr5_loc(k-1)
8870      & +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k))
8871      & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
8872       call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
8873       vv(1)=pizda(1,1)-pizda(2,2)
8874       vv(2)=pizda(1,2)+pizda(2,1)
8875       if (l.eq.j+1) then
8876         if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1)
8877      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
8878      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
8879       else
8880         if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1)
8881      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
8882      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
8883       endif
8884 C Cartesian gradient
8885       do iii=1,2
8886         do kkk=1,5
8887           do lll=1,3
8888             call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),
8889      &        pizda(1,1))
8890             vv(1)=pizda(1,1)-pizda(2,2)
8891             vv(2)=pizda(1,2)+pizda(2,1)
8892             derx(lll,kkk,iii)=derx(lll,kkk,iii)
8893      &       +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k))
8894      &       +0.5d0*scalar2(vv(1),Dtobr2(1,i))
8895           enddo
8896         enddo
8897       enddo
8898 c      goto 1112
8899 c1111  continue
8900 C Contribution from graph II
8901       call transpose2(EE(1,1,itk),auxmat(1,1))
8902       call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
8903       vv(1)=pizda(1,1)+pizda(2,2)
8904       vv(2)=pizda(2,1)-pizda(1,2)
8905       eello5_2=scalar2(AEAb1(1,2,1),b1(1,k))
8906      & -0.5d0*scalar2(vv(1),Ctobr(1,k))
8907 C Explicit gradient in virtual-dihedral angles.
8908       g_corr5_loc(k-1)=g_corr5_loc(k-1)
8909      & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
8910       call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
8911       vv(1)=pizda(1,1)+pizda(2,2)
8912       vv(2)=pizda(2,1)-pizda(1,2)
8913       if (l.eq.j+1) then
8914         g_corr5_loc(l-1)=g_corr5_loc(l-1)
8915      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,k))
8916      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
8917       else
8918         g_corr5_loc(j-1)=g_corr5_loc(j-1)
8919      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,k))
8920      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
8921       endif
8922 C Cartesian gradient
8923       do iii=1,2
8924         do kkk=1,5
8925           do lll=1,3
8926             call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
8927      &        pizda(1,1))
8928             vv(1)=pizda(1,1)+pizda(2,2)
8929             vv(2)=pizda(2,1)-pizda(1,2)
8930             derx(lll,kkk,iii)=derx(lll,kkk,iii)
8931      &       +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,k))
8932      &       -0.5d0*scalar2(vv(1),Ctobr(1,k))
8933           enddo
8934         enddo
8935       enddo
8936 cd      goto 1112
8937 cd1111  continue
8938       if (l.eq.j+1) then
8939 cd        goto 1110
8940 C Parallel orientation
8941 C Contribution from graph III
8942         call transpose2(EUg(1,1,l),auxmat(1,1))
8943         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
8944         vv(1)=pizda(1,1)-pizda(2,2)
8945         vv(2)=pizda(1,2)+pizda(2,1)
8946         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l))
8947      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j))
8948 C Explicit gradient in virtual-dihedral angles.
8949         g_corr5_loc(j-1)=g_corr5_loc(j-1)
8950      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l))
8951      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
8952         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
8953         vv(1)=pizda(1,1)-pizda(2,2)
8954         vv(2)=pizda(1,2)+pizda(2,1)
8955         g_corr5_loc(k-1)=g_corr5_loc(k-1)
8956      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l))
8957      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
8958         call transpose2(EUgder(1,1,l),auxmat1(1,1))
8959         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
8960         vv(1)=pizda(1,1)-pizda(2,2)
8961         vv(2)=pizda(1,2)+pizda(2,1)
8962         g_corr5_loc(l-1)=g_corr5_loc(l-1)
8963      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l))
8964      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
8965 C Cartesian gradient
8966         do iii=1,2
8967           do kkk=1,5
8968             do lll=1,3
8969               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
8970      &          pizda(1,1))
8971               vv(1)=pizda(1,1)-pizda(2,2)
8972               vv(2)=pizda(1,2)+pizda(2,1)
8973               derx(lll,kkk,iii)=derx(lll,kkk,iii)
8974      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l))
8975      &         +0.5d0*scalar2(vv(1),Dtobr2(1,j))
8976             enddo
8977           enddo
8978         enddo
8979 cd        goto 1112
8980 C Contribution from graph IV
8981 cd1110    continue
8982         call transpose2(EE(1,1,itl),auxmat(1,1))
8983         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
8984         vv(1)=pizda(1,1)+pizda(2,2)
8985         vv(2)=pizda(2,1)-pizda(1,2)
8986         eello5_4=scalar2(AEAb1(1,2,2),b1(1,l))
8987      &   -0.5d0*scalar2(vv(1),Ctobr(1,l))
8988 C Explicit gradient in virtual-dihedral angles.
8989         g_corr5_loc(l-1)=g_corr5_loc(l-1)
8990      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
8991         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
8992         vv(1)=pizda(1,1)+pizda(2,2)
8993         vv(2)=pizda(2,1)-pizda(1,2)
8994         g_corr5_loc(k-1)=g_corr5_loc(k-1)
8995      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,l))
8996      &   -0.5d0*scalar2(vv(1),Ctobr(1,l)))
8997 C Cartesian gradient
8998         do iii=1,2
8999           do kkk=1,5
9000             do lll=1,3
9001               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
9002      &          pizda(1,1))
9003               vv(1)=pizda(1,1)+pizda(2,2)
9004               vv(2)=pizda(2,1)-pizda(1,2)
9005               derx(lll,kkk,iii)=derx(lll,kkk,iii)
9006      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,l))
9007      &         -0.5d0*scalar2(vv(1),Ctobr(1,l))
9008             enddo
9009           enddo
9010         enddo
9011       else
9012 C Antiparallel orientation
9013 C Contribution from graph III
9014 c        goto 1110
9015         call transpose2(EUg(1,1,j),auxmat(1,1))
9016         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
9017         vv(1)=pizda(1,1)-pizda(2,2)
9018         vv(2)=pizda(1,2)+pizda(2,1)
9019         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j))
9020      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l))
9021 C Explicit gradient in virtual-dihedral angles.
9022         g_corr5_loc(l-1)=g_corr5_loc(l-1)
9023      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j))
9024      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
9025         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
9026         vv(1)=pizda(1,1)-pizda(2,2)
9027         vv(2)=pizda(1,2)+pizda(2,1)
9028         g_corr5_loc(k-1)=g_corr5_loc(k-1)
9029      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j))
9030      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
9031         call transpose2(EUgder(1,1,j),auxmat1(1,1))
9032         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
9033         vv(1)=pizda(1,1)-pizda(2,2)
9034         vv(2)=pizda(1,2)+pizda(2,1)
9035         g_corr5_loc(j-1)=g_corr5_loc(j-1)
9036      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j))
9037      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
9038 C Cartesian gradient
9039         do iii=1,2
9040           do kkk=1,5
9041             do lll=1,3
9042               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
9043      &          pizda(1,1))
9044               vv(1)=pizda(1,1)-pizda(2,2)
9045               vv(2)=pizda(1,2)+pizda(2,1)
9046               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
9047      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j))
9048      &         +0.5d0*scalar2(vv(1),Dtobr2(1,l))
9049             enddo
9050           enddo
9051         enddo
9052 cd        goto 1112
9053 C Contribution from graph IV
9054 1110    continue
9055         call transpose2(EE(1,1,itj),auxmat(1,1))
9056         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
9057         vv(1)=pizda(1,1)+pizda(2,2)
9058         vv(2)=pizda(2,1)-pizda(1,2)
9059         eello5_4=scalar2(AEAb1(1,2,2),b1(1,j))
9060      &   -0.5d0*scalar2(vv(1),Ctobr(1,j))
9061 C Explicit gradient in virtual-dihedral angles.
9062         g_corr5_loc(j-1)=g_corr5_loc(j-1)
9063      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
9064         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
9065         vv(1)=pizda(1,1)+pizda(2,2)
9066         vv(2)=pizda(2,1)-pizda(1,2)
9067         g_corr5_loc(k-1)=g_corr5_loc(k-1)
9068      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,j))
9069      &   -0.5d0*scalar2(vv(1),Ctobr(1,j)))
9070 C Cartesian gradient
9071         do iii=1,2
9072           do kkk=1,5
9073             do lll=1,3
9074               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
9075      &          pizda(1,1))
9076               vv(1)=pizda(1,1)+pizda(2,2)
9077               vv(2)=pizda(2,1)-pizda(1,2)
9078               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
9079      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,j))
9080      &         -0.5d0*scalar2(vv(1),Ctobr(1,j))
9081             enddo
9082           enddo
9083         enddo
9084       endif
9085 1112  continue
9086       eel5=eello5_1+eello5_2+eello5_3+eello5_4
9087 cd      if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
9088 cd        write (2,*) 'ijkl',i,j,k,l
9089 cd        write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
9090 cd     &     ' eello5_3',eello5_3,' eello5_4',eello5_4
9091 cd      endif
9092 cd      write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
9093 cd      write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
9094 cd      write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
9095 cd      write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
9096       if (j.lt.nres-1) then
9097         j1=j+1
9098         j2=j-1
9099       else
9100         j1=j-1
9101         j2=j-2
9102       endif
9103       if (l.lt.nres-1) then
9104         l1=l+1
9105         l2=l-1
9106       else
9107         l1=l-1
9108         l2=l-2
9109       endif
9110 cd      eij=1.0d0
9111 cd      ekl=1.0d0
9112 cd      ekont=1.0d0
9113 cd      write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
9114 C 2/11/08 AL Gradients over DC's connecting interacting sites will be
9115 C        summed up outside the subrouine as for the other subroutines
9116 C        handling long-range interactions. The old code is commented out
9117 C        with "cgrad" to keep track of changes.
9118       do ll=1,3
9119 cgrad        ggg1(ll)=eel5*g_contij(ll,1)
9120 cgrad        ggg2(ll)=eel5*g_contij(ll,2)
9121         gradcorr5ij=eel5*g_contij(ll,1)+ekont*derx(ll,1,1)
9122         gradcorr5kl=eel5*g_contij(ll,2)+ekont*derx(ll,1,2)
9123 c        write (iout,'(a,3i3,a,5f8.3,2i3,a,5f8.3,a,f8.3)')
9124 c     &   "ecorr5",ll,i,j," derx",derx(ll,2,1),derx(ll,3,1),derx(ll,4,1),
9125 c     &   derx(ll,5,1),k,l," derx",derx(ll,2,2),derx(ll,3,2),
9126 c     &   derx(ll,4,2),derx(ll,5,2)," ekont",ekont
9127 c        write (iout,'(a,3i3,a,3f8.3,2i3,a,3f8.3)')
9128 c     &   "ecorr5",ll,i,j," gradcorr5",g_contij(ll,1),derx(ll,1,1),
9129 c     &   gradcorr5ij,
9130 c     &   k,l," gradcorr5",g_contij(ll,2),derx(ll,1,2),gradcorr5kl
9131 cold        ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
9132 cgrad        ghalf=0.5d0*ggg1(ll)
9133 cd        ghalf=0.0d0
9134         gradcorr5(ll,i)=gradcorr5(ll,i)+ekont*derx(ll,2,1)
9135         gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
9136         gradcorr5(ll,j)=gradcorr5(ll,j)+ekont*derx(ll,4,1)
9137         gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
9138         gradcorr5_long(ll,j)=gradcorr5_long(ll,j)+gradcorr5ij
9139         gradcorr5_long(ll,i)=gradcorr5_long(ll,i)-gradcorr5ij
9140 cold        ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
9141 cgrad        ghalf=0.5d0*ggg2(ll)
9142 cd        ghalf=0.0d0
9143         gradcorr5(ll,k)=gradcorr5(ll,k)+ekont*derx(ll,2,2)
9144         gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
9145         gradcorr5(ll,l)=gradcorr5(ll,l)+ekont*derx(ll,4,2)
9146         gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
9147         gradcorr5_long(ll,l)=gradcorr5_long(ll,l)+gradcorr5kl
9148         gradcorr5_long(ll,k)=gradcorr5_long(ll,k)-gradcorr5kl
9149       enddo
9150 cd      goto 1112
9151 cgrad      do m=i+1,j-1
9152 cgrad        do ll=1,3
9153 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
9154 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
9155 cgrad        enddo
9156 cgrad      enddo
9157 cgrad      do m=k+1,l-1
9158 cgrad        do ll=1,3
9159 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
9160 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
9161 cgrad        enddo
9162 cgrad      enddo
9163 c1112  continue
9164 cgrad      do m=i+2,j2
9165 cgrad        do ll=1,3
9166 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
9167 cgrad        enddo
9168 cgrad      enddo
9169 cgrad      do m=k+2,l2
9170 cgrad        do ll=1,3
9171 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
9172 cgrad        enddo
9173 cgrad      enddo
9174 cd      do iii=1,nres-3
9175 cd        write (2,*) iii,g_corr5_loc(iii)
9176 cd      enddo
9177       eello5=ekont*eel5
9178 cd      write (2,*) 'ekont',ekont
9179 cd      write (iout,*) 'eello5',ekont*eel5
9180       return
9181       end
9182 c--------------------------------------------------------------------------
9183       double precision function eello6(i,j,k,l,jj,kk)
9184       implicit real*8 (a-h,o-z)
9185       include 'DIMENSIONS'
9186       include 'COMMON.IOUNITS'
9187       include 'COMMON.CHAIN'
9188       include 'COMMON.DERIV'
9189       include 'COMMON.INTERACT'
9190       include 'COMMON.CONTACTS'
9191       include 'COMMON.TORSION'
9192       include 'COMMON.VAR'
9193       include 'COMMON.GEO'
9194       include 'COMMON.FFIELD'
9195       double precision ggg1(3),ggg2(3)
9196 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
9197 cd        eello6=0.0d0
9198 cd        return
9199 cd      endif
9200 cd      write (iout,*)
9201 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
9202 cd     &   ' and',k,l
9203       eello6_1=0.0d0
9204       eello6_2=0.0d0
9205       eello6_3=0.0d0
9206       eello6_4=0.0d0
9207       eello6_5=0.0d0
9208       eello6_6=0.0d0
9209 cd      call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
9210 cd     &   eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
9211       do iii=1,2
9212         do kkk=1,5
9213           do lll=1,3
9214             derx(lll,kkk,iii)=0.0d0
9215           enddo
9216         enddo
9217       enddo
9218 cd      eij=facont_hb(jj,i)
9219 cd      ekl=facont_hb(kk,k)
9220 cd      ekont=eij*ekl
9221 cd      eij=1.0d0
9222 cd      ekl=1.0d0
9223 cd      ekont=1.0d0
9224       if (l.eq.j+1) then
9225         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
9226         eello6_2=eello6_graph1(j,i,l,k,2,.false.)
9227         eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
9228         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
9229         eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
9230         eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
9231       else
9232         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
9233         eello6_2=eello6_graph1(l,k,j,i,2,.true.)
9234         eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
9235         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
9236         if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
9237           eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
9238         else
9239           eello6_5=0.0d0
9240         endif
9241         eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
9242       endif
9243 C If turn contributions are considered, they will be handled separately.
9244       eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
9245 cd      write(iout,*) 'eello6_1',eello6_1!,' eel6_1_num',16*eel6_1_num
9246 cd      write(iout,*) 'eello6_2',eello6_2!,' eel6_2_num',16*eel6_2_num
9247 cd      write(iout,*) 'eello6_3',eello6_3!,' eel6_3_num',16*eel6_3_num
9248 cd      write(iout,*) 'eello6_4',eello6_4!,' eel6_4_num',16*eel6_4_num
9249 cd      write(iout,*) 'eello6_5',eello6_5!,' eel6_5_num',16*eel6_5_num
9250 cd      write(iout,*) 'eello6_6',eello6_6!,' eel6_6_num',16*eel6_6_num
9251 cd      goto 1112
9252       if (j.lt.nres-1) then
9253         j1=j+1
9254         j2=j-1
9255       else
9256         j1=j-1
9257         j2=j-2
9258       endif
9259       if (l.lt.nres-1) then
9260         l1=l+1
9261         l2=l-1
9262       else
9263         l1=l-1
9264         l2=l-2
9265       endif
9266       do ll=1,3
9267 cgrad        ggg1(ll)=eel6*g_contij(ll,1)
9268 cgrad        ggg2(ll)=eel6*g_contij(ll,2)
9269 cold        ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
9270 cgrad        ghalf=0.5d0*ggg1(ll)
9271 cd        ghalf=0.0d0
9272         gradcorr6ij=eel6*g_contij(ll,1)+ekont*derx(ll,1,1)
9273         gradcorr6kl=eel6*g_contij(ll,2)+ekont*derx(ll,1,2)
9274         gradcorr6(ll,i)=gradcorr6(ll,i)+ekont*derx(ll,2,1)
9275         gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
9276         gradcorr6(ll,j)=gradcorr6(ll,j)+ekont*derx(ll,4,1)
9277         gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
9278         gradcorr6_long(ll,j)=gradcorr6_long(ll,j)+gradcorr6ij
9279         gradcorr6_long(ll,i)=gradcorr6_long(ll,i)-gradcorr6ij
9280 cgrad        ghalf=0.5d0*ggg2(ll)
9281 cold        ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
9282 cd        ghalf=0.0d0
9283         gradcorr6(ll,k)=gradcorr6(ll,k)+ekont*derx(ll,2,2)
9284         gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
9285         gradcorr6(ll,l)=gradcorr6(ll,l)+ekont*derx(ll,4,2)
9286         gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
9287         gradcorr6_long(ll,l)=gradcorr6_long(ll,l)+gradcorr6kl
9288         gradcorr6_long(ll,k)=gradcorr6_long(ll,k)-gradcorr6kl
9289       enddo
9290 cd      goto 1112
9291 cgrad      do m=i+1,j-1
9292 cgrad        do ll=1,3
9293 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
9294 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
9295 cgrad        enddo
9296 cgrad      enddo
9297 cgrad      do m=k+1,l-1
9298 cgrad        do ll=1,3
9299 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
9300 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
9301 cgrad        enddo
9302 cgrad      enddo
9303 cgrad1112  continue
9304 cgrad      do m=i+2,j2
9305 cgrad        do ll=1,3
9306 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
9307 cgrad        enddo
9308 cgrad      enddo
9309 cgrad      do m=k+2,l2
9310 cgrad        do ll=1,3
9311 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
9312 cgrad        enddo
9313 cgrad      enddo
9314 cd      do iii=1,nres-3
9315 cd        write (2,*) iii,g_corr6_loc(iii)
9316 cd      enddo
9317       eello6=ekont*eel6
9318 cd      write (2,*) 'ekont',ekont
9319 cd      write (iout,*) 'eello6',ekont*eel6
9320       return
9321       end
9322 c--------------------------------------------------------------------------
9323       double precision function eello6_graph1(i,j,k,l,imat,swap)
9324       implicit real*8 (a-h,o-z)
9325       include 'DIMENSIONS'
9326       include 'COMMON.IOUNITS'
9327       include 'COMMON.CHAIN'
9328       include 'COMMON.DERIV'
9329       include 'COMMON.INTERACT'
9330       include 'COMMON.CONTACTS'
9331       include 'COMMON.TORSION'
9332       include 'COMMON.VAR'
9333       include 'COMMON.GEO'
9334       double precision vv(2),vv1(2),pizda(2,2),auxmat(2,2),pizda1(2,2)
9335       logical swap
9336       logical lprn
9337       common /kutas/ lprn
9338 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9339 C                                                                              C
9340 C      Parallel       Antiparallel                                             C
9341 C                                                                              C
9342 C          o             o                                                     C
9343 C         /l\           /j\                                                    C
9344 C        /   \         /   \                                                   C
9345 C       /| o |         | o |\                                                  C
9346 C     \ j|/k\|  /   \  |/k\|l /                                                C
9347 C      \ /   \ /     \ /   \ /                                                 C
9348 C       o     o       o     o                                                  C
9349 C       i             i                                                        C
9350 C                                                                              C
9351 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9352       itk=itortyp(itype(k))
9353       s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
9354       s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
9355       s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
9356       call transpose2(EUgC(1,1,k),auxmat(1,1))
9357       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
9358       vv1(1)=pizda1(1,1)-pizda1(2,2)
9359       vv1(2)=pizda1(1,2)+pizda1(2,1)
9360       s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
9361       vv(1)=AEAb1(1,2,imat)*b1(1,k)-AEAb1(2,2,imat)*b1(2,k)
9362       vv(2)=AEAb1(1,2,imat)*b1(2,k)+AEAb1(2,2,imat)*b1(1,k)
9363       s5=scalar2(vv(1),Dtobr2(1,i))
9364 cd      write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
9365       eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
9366       if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1)
9367      & -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i))
9368      & -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k))
9369      & +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k))
9370      & +0.5d0*scalar2(vv1(1),Dtobr2der(1,i))
9371      & +scalar2(vv(1),Dtobr2der(1,i)))
9372       call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
9373       vv1(1)=pizda1(1,1)-pizda1(2,2)
9374       vv1(2)=pizda1(1,2)+pizda1(2,1)
9375       vv(1)=AEAb1derg(1,2,imat)*b1(1,k)-AEAb1derg(2,2,imat)*b1(2,k)
9376       vv(2)=AEAb1derg(1,2,imat)*b1(2,k)+AEAb1derg(2,2,imat)*b1(1,k)
9377       if (l.eq.j+1) then
9378         g_corr6_loc(l-1)=g_corr6_loc(l-1)
9379      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
9380      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
9381      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
9382      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
9383       else
9384         g_corr6_loc(j-1)=g_corr6_loc(j-1)
9385      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
9386      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
9387      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
9388      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
9389       endif
9390       call transpose2(EUgCder(1,1,k),auxmat(1,1))
9391       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
9392       vv1(1)=pizda1(1,1)-pizda1(2,2)
9393       vv1(2)=pizda1(1,2)+pizda1(2,1)
9394       if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1)
9395      & +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k))
9396      & +scalar2(AEAb2(1,1,imat),CUgb2der(1,k))
9397      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
9398       do iii=1,2
9399         if (swap) then
9400           ind=3-iii
9401         else
9402           ind=iii
9403         endif
9404         do kkk=1,5
9405           do lll=1,3
9406             s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
9407             s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
9408             s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
9409             call transpose2(EUgC(1,1,k),auxmat(1,1))
9410             call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
9411      &        pizda1(1,1))
9412             vv1(1)=pizda1(1,1)-pizda1(2,2)
9413             vv1(2)=pizda1(1,2)+pizda1(2,1)
9414             s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
9415             vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,k)
9416      &       -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,k)
9417             vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,k)
9418      &       +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,k)
9419             s5=scalar2(vv(1),Dtobr2(1,i))
9420             derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
9421           enddo
9422         enddo
9423       enddo
9424       return
9425       end
9426 c----------------------------------------------------------------------------
9427       double precision function eello6_graph2(i,j,k,l,jj,kk,swap)
9428       implicit real*8 (a-h,o-z)
9429       include 'DIMENSIONS'
9430       include 'COMMON.IOUNITS'
9431       include 'COMMON.CHAIN'
9432       include 'COMMON.DERIV'
9433       include 'COMMON.INTERACT'
9434       include 'COMMON.CONTACTS'
9435       include 'COMMON.TORSION'
9436       include 'COMMON.VAR'
9437       include 'COMMON.GEO'
9438       logical swap
9439       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
9440      & auxvec1(2),auxvec2(2),auxmat1(2,2)
9441       logical lprn
9442       common /kutas/ lprn
9443 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9444 C                                                                              C
9445 C      Parallel       Antiparallel                                             C
9446 C                                                                              C
9447 C          o             o                                                     C
9448 C     \   /l\           /j\   /                                                C
9449 C      \ /   \         /   \ /                                                 C
9450 C       o| o |         | o |o                                                  C
9451 C     \ j|/k\|      \  |/k\|l                                                  C
9452 C      \ /   \       \ /   \                                                   C
9453 C       o             o                                                        C
9454 C       i             i                                                        C
9455 C                                                                              C
9456 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9457 cd      write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
9458 C AL 7/4/01 s1 would occur in the sixth-order moment,
9459 C           but not in a cluster cumulant
9460 #ifdef MOMENT
9461       s1=dip(1,jj,i)*dip(1,kk,k)
9462 #endif
9463       call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
9464       s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
9465       call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
9466       s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
9467       call transpose2(EUg(1,1,k),auxmat(1,1))
9468       call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
9469       vv(1)=pizda(1,1)-pizda(2,2)
9470       vv(2)=pizda(1,2)+pizda(2,1)
9471       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
9472 cd      write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
9473 #ifdef MOMENT
9474       eello6_graph2=-(s1+s2+s3+s4)
9475 #else
9476       eello6_graph2=-(s2+s3+s4)
9477 #endif
9478 c      eello6_graph2=-s3
9479 C Derivatives in gamma(i-1)
9480       if (i.gt.1) then
9481 #ifdef MOMENT
9482         s1=dipderg(1,jj,i)*dip(1,kk,k)
9483 #endif
9484         s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
9485         call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
9486         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
9487         s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
9488 #ifdef MOMENT
9489         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
9490 #else
9491         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
9492 #endif
9493 c        g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
9494       endif
9495 C Derivatives in gamma(k-1)
9496 #ifdef MOMENT
9497       s1=dip(1,jj,i)*dipderg(1,kk,k)
9498 #endif
9499       call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
9500       s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
9501       call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
9502       s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
9503       call transpose2(EUgder(1,1,k),auxmat1(1,1))
9504       call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
9505       vv(1)=pizda(1,1)-pizda(2,2)
9506       vv(2)=pizda(1,2)+pizda(2,1)
9507       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
9508 #ifdef MOMENT
9509       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
9510 #else
9511       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
9512 #endif
9513 c      g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
9514 C Derivatives in gamma(j-1) or gamma(l-1)
9515       if (j.gt.1) then
9516 #ifdef MOMENT
9517         s1=dipderg(3,jj,i)*dip(1,kk,k)
9518 #endif
9519         call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
9520         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
9521         s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
9522         call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
9523         vv(1)=pizda(1,1)-pizda(2,2)
9524         vv(2)=pizda(1,2)+pizda(2,1)
9525         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
9526 #ifdef MOMENT
9527         if (swap) then
9528           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
9529         else
9530           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
9531         endif
9532 #endif
9533         g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
9534 c        g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
9535       endif
9536 C Derivatives in gamma(l-1) or gamma(j-1)
9537       if (l.gt.1) then
9538 #ifdef MOMENT
9539         s1=dip(1,jj,i)*dipderg(3,kk,k)
9540 #endif
9541         call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
9542         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
9543         call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
9544         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
9545         call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
9546         vv(1)=pizda(1,1)-pizda(2,2)
9547         vv(2)=pizda(1,2)+pizda(2,1)
9548         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
9549 #ifdef MOMENT
9550         if (swap) then
9551           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
9552         else
9553           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
9554         endif
9555 #endif
9556         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
9557 c        g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
9558       endif
9559 C Cartesian derivatives.
9560       if (lprn) then
9561         write (2,*) 'In eello6_graph2'
9562         do iii=1,2
9563           write (2,*) 'iii=',iii
9564           do kkk=1,5
9565             write (2,*) 'kkk=',kkk
9566             do jjj=1,2
9567               write (2,'(3(2f10.5),5x)')
9568      &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
9569             enddo
9570           enddo
9571         enddo
9572       endif
9573       do iii=1,2
9574         do kkk=1,5
9575           do lll=1,3
9576 #ifdef MOMENT
9577             if (iii.eq.1) then
9578               s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
9579             else
9580               s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
9581             endif
9582 #endif
9583             call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),
9584      &        auxvec(1))
9585             s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
9586             call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),
9587      &        auxvec(1))
9588             s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
9589             call transpose2(EUg(1,1,k),auxmat(1,1))
9590             call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),
9591      &        pizda(1,1))
9592             vv(1)=pizda(1,1)-pizda(2,2)
9593             vv(2)=pizda(1,2)+pizda(2,1)
9594             s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
9595 cd            write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
9596 #ifdef MOMENT
9597             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
9598 #else
9599             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
9600 #endif
9601             if (swap) then
9602               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
9603             else
9604               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
9605             endif
9606           enddo
9607         enddo
9608       enddo
9609       return
9610       end
9611 c----------------------------------------------------------------------------
9612       double precision function eello6_graph3(i,j,k,l,jj,kk,swap)
9613       implicit real*8 (a-h,o-z)
9614       include 'DIMENSIONS'
9615       include 'COMMON.IOUNITS'
9616       include 'COMMON.CHAIN'
9617       include 'COMMON.DERIV'
9618       include 'COMMON.INTERACT'
9619       include 'COMMON.CONTACTS'
9620       include 'COMMON.TORSION'
9621       include 'COMMON.VAR'
9622       include 'COMMON.GEO'
9623       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2)
9624       logical swap
9625 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9626 C                                                                              C
9627 C      Parallel       Antiparallel                                             C
9628 C                                                                              C
9629 C          o             o                                                     C
9630 C         /l\   /   \   /j\                                                    C
9631 C        /   \ /     \ /   \                                                   C
9632 C       /| o |o       o| o |\                                                  C
9633 C       j|/k\|  /      |/k\|l /                                                C
9634 C        /   \ /       /   \ /                                                 C
9635 C       /     o       /     o                                                  C
9636 C       i             i                                                        C
9637 C                                                                              C
9638 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9639 C
9640 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
9641 C           energy moment and not to the cluster cumulant.
9642       iti=itortyp(itype(i))
9643       if (j.lt.nres-1) then
9644         itj1=itortyp(itype(j+1))
9645       else
9646         itj1=ntortyp
9647       endif
9648       itk=itortyp(itype(k))
9649       itk1=itortyp(itype(k+1))
9650       if (l.lt.nres-1) then
9651         itl1=itortyp(itype(l+1))
9652       else
9653         itl1=ntortyp
9654       endif
9655 #ifdef MOMENT
9656       s1=dip(4,jj,i)*dip(4,kk,k)
9657 #endif
9658       call matvec2(AECA(1,1,1),b1(1,k+1),auxvec(1))
9659       s2=0.5d0*scalar2(b1(1,k),auxvec(1))
9660       call matvec2(AECA(1,1,2),b1(1,l+1),auxvec(1))
9661       s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
9662       call transpose2(EE(1,1,itk),auxmat(1,1))
9663       call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
9664       vv(1)=pizda(1,1)+pizda(2,2)
9665       vv(2)=pizda(2,1)-pizda(1,2)
9666       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
9667 cd      write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4,
9668 cd     & "sum",-(s2+s3+s4)
9669 #ifdef MOMENT
9670       eello6_graph3=-(s1+s2+s3+s4)
9671 #else
9672       eello6_graph3=-(s2+s3+s4)
9673 #endif
9674 c      eello6_graph3=-s4
9675 C Derivatives in gamma(k-1)
9676       call matvec2(AECAderg(1,1,2),b1(1,l+1),auxvec(1))
9677       s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
9678       s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
9679       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
9680 C Derivatives in gamma(l-1)
9681       call matvec2(AECAderg(1,1,1),b1(1,k+1),auxvec(1))
9682       s2=0.5d0*scalar2(b1(1,k),auxvec(1))
9683       call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
9684       vv(1)=pizda(1,1)+pizda(2,2)
9685       vv(2)=pizda(2,1)-pizda(1,2)
9686       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
9687       g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
9688 C Cartesian derivatives.
9689       do iii=1,2
9690         do kkk=1,5
9691           do lll=1,3
9692 #ifdef MOMENT
9693             if (iii.eq.1) then
9694               s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
9695             else
9696               s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
9697             endif
9698 #endif
9699             call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
9700      &        auxvec(1))
9701             s2=0.5d0*scalar2(b1(1,k),auxvec(1))
9702             call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,l+1),
9703      &        auxvec(1))
9704             s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
9705             call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),
9706      &        pizda(1,1))
9707             vv(1)=pizda(1,1)+pizda(2,2)
9708             vv(2)=pizda(2,1)-pizda(1,2)
9709             s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
9710 #ifdef MOMENT
9711             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
9712 #else
9713             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
9714 #endif
9715             if (swap) then
9716               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
9717             else
9718               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
9719             endif
9720 c            derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
9721           enddo
9722         enddo
9723       enddo
9724       return
9725       end
9726 c----------------------------------------------------------------------------
9727       double precision function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
9728       implicit real*8 (a-h,o-z)
9729       include 'DIMENSIONS'
9730       include 'COMMON.IOUNITS'
9731       include 'COMMON.CHAIN'
9732       include 'COMMON.DERIV'
9733       include 'COMMON.INTERACT'
9734       include 'COMMON.CONTACTS'
9735       include 'COMMON.TORSION'
9736       include 'COMMON.VAR'
9737       include 'COMMON.GEO'
9738       include 'COMMON.FFIELD'
9739       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
9740      & auxvec1(2),auxmat1(2,2)
9741       logical swap
9742 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9743 C                                                                              C
9744 C      Parallel       Antiparallel                                             C
9745 C                                                                              C
9746 C          o             o                                                     C
9747 C         /l\   /   \   /j\                                                    C
9748 C        /   \ /     \ /   \                                                   C
9749 C       /| o |o       o| o |\                                                  C
9750 C     \ j|/k\|      \  |/k\|l                                                  C
9751 C      \ /   \       \ /   \                                                   C
9752 C       o     \       o     \                                                  C
9753 C       i             i                                                        C
9754 C                                                                              C
9755 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9756 C
9757 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
9758 C           energy moment and not to the cluster cumulant.
9759 cd      write (2,*) 'eello_graph4: wturn6',wturn6
9760       iti=itortyp(itype(i))
9761       itj=itortyp(itype(j))
9762       if (j.lt.nres-1) then
9763         itj1=itortyp(itype(j+1))
9764       else
9765         itj1=ntortyp
9766       endif
9767       itk=itortyp(itype(k))
9768       if (k.lt.nres-1) then
9769         itk1=itortyp(itype(k+1))
9770       else
9771         itk1=ntortyp
9772       endif
9773       itl=itortyp(itype(l))
9774       if (l.lt.nres-1) then
9775         itl1=itortyp(itype(l+1))
9776       else
9777         itl1=ntortyp
9778       endif
9779 cd      write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
9780 cd      write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
9781 cd     & ' itl',itl,' itl1',itl1
9782 #ifdef MOMENT
9783       if (imat.eq.1) then
9784         s1=dip(3,jj,i)*dip(3,kk,k)
9785       else
9786         s1=dip(2,jj,j)*dip(2,kk,l)
9787       endif
9788 #endif
9789       call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
9790       s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
9791       if (j.eq.l+1) then
9792         call matvec2(ADtEA1(1,1,3-imat),b1(1,j+1),auxvec1(1))
9793         s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
9794       else
9795         call matvec2(ADtEA1(1,1,3-imat),b1(1,l+1),auxvec1(1))
9796         s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
9797       endif
9798       call transpose2(EUg(1,1,k),auxmat(1,1))
9799       call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
9800       vv(1)=pizda(1,1)-pizda(2,2)
9801       vv(2)=pizda(2,1)+pizda(1,2)
9802       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9803 cd      write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
9804 #ifdef MOMENT
9805       eello6_graph4=-(s1+s2+s3+s4)
9806 #else
9807       eello6_graph4=-(s2+s3+s4)
9808 #endif
9809 C Derivatives in gamma(i-1)
9810       if (i.gt.1) then
9811 #ifdef MOMENT
9812         if (imat.eq.1) then
9813           s1=dipderg(2,jj,i)*dip(3,kk,k)
9814         else
9815           s1=dipderg(4,jj,j)*dip(2,kk,l)
9816         endif
9817 #endif
9818         s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
9819         if (j.eq.l+1) then
9820           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,j+1),auxvec1(1))
9821           s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
9822         else
9823           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,l+1),auxvec1(1))
9824           s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
9825         endif
9826         s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
9827         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
9828 cd          write (2,*) 'turn6 derivatives'
9829 #ifdef MOMENT
9830           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
9831 #else
9832           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
9833 #endif
9834         else
9835 #ifdef MOMENT
9836           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
9837 #else
9838           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
9839 #endif
9840         endif
9841       endif
9842 C Derivatives in gamma(k-1)
9843 #ifdef MOMENT
9844       if (imat.eq.1) then
9845         s1=dip(3,jj,i)*dipderg(2,kk,k)
9846       else
9847         s1=dip(2,jj,j)*dipderg(4,kk,l)
9848       endif
9849 #endif
9850       call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
9851       s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
9852       if (j.eq.l+1) then
9853         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,j+1),auxvec1(1))
9854         s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
9855       else
9856         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,l+1),auxvec1(1))
9857         s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
9858       endif
9859       call transpose2(EUgder(1,1,k),auxmat1(1,1))
9860       call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
9861       vv(1)=pizda(1,1)-pizda(2,2)
9862       vv(2)=pizda(2,1)+pizda(1,2)
9863       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9864       if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
9865 #ifdef MOMENT
9866         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
9867 #else
9868         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
9869 #endif
9870       else
9871 #ifdef MOMENT
9872         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
9873 #else
9874         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
9875 #endif
9876       endif
9877 C Derivatives in gamma(j-1) or gamma(l-1)
9878       if (l.eq.j+1 .and. l.gt.1) then
9879         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
9880         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
9881         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
9882         vv(1)=pizda(1,1)-pizda(2,2)
9883         vv(2)=pizda(2,1)+pizda(1,2)
9884         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9885         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
9886       else if (j.gt.1) then
9887         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
9888         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
9889         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
9890         vv(1)=pizda(1,1)-pizda(2,2)
9891         vv(2)=pizda(2,1)+pizda(1,2)
9892         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9893         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
9894           gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
9895         else
9896           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
9897         endif
9898       endif
9899 C Cartesian derivatives.
9900       do iii=1,2
9901         do kkk=1,5
9902           do lll=1,3
9903 #ifdef MOMENT
9904             if (iii.eq.1) then
9905               if (imat.eq.1) then
9906                 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
9907               else
9908                 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
9909               endif
9910             else
9911               if (imat.eq.1) then
9912                 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
9913               else
9914                 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
9915               endif
9916             endif
9917 #endif
9918             call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),
9919      &        auxvec(1))
9920             s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
9921             if (j.eq.l+1) then
9922               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
9923      &          b1(1,j+1),auxvec(1))
9924               s3=-0.5d0*scalar2(b1(1,j),auxvec(1))
9925             else
9926               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
9927      &          b1(1,l+1),auxvec(1))
9928               s3=-0.5d0*scalar2(b1(1,l),auxvec(1))
9929             endif
9930             call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
9931      &        pizda(1,1))
9932             vv(1)=pizda(1,1)-pizda(2,2)
9933             vv(2)=pizda(2,1)+pizda(1,2)
9934             s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9935             if (swap) then
9936               if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
9937 #ifdef MOMENT
9938                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
9939      &             -(s1+s2+s4)
9940 #else
9941                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
9942      &             -(s2+s4)
9943 #endif
9944                 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
9945               else
9946 #ifdef MOMENT
9947                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
9948 #else
9949                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
9950 #endif
9951                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
9952               endif
9953             else
9954 #ifdef MOMENT
9955               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
9956 #else
9957               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
9958 #endif
9959               if (l.eq.j+1) then
9960                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
9961               else
9962                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
9963               endif
9964             endif
9965           enddo
9966         enddo
9967       enddo
9968       return
9969       end
9970 c----------------------------------------------------------------------------
9971       double precision function eello_turn6(i,jj,kk)
9972       implicit real*8 (a-h,o-z)
9973       include 'DIMENSIONS'
9974       include 'COMMON.IOUNITS'
9975       include 'COMMON.CHAIN'
9976       include 'COMMON.DERIV'
9977       include 'COMMON.INTERACT'
9978       include 'COMMON.CONTACTS'
9979       include 'COMMON.TORSION'
9980       include 'COMMON.VAR'
9981       include 'COMMON.GEO'
9982       double precision vtemp1(2),vtemp2(2),vtemp3(2),vtemp4(2),
9983      &  atemp(2,2),auxmat(2,2),achuj_temp(2,2),gtemp(2,2),gvec(2),
9984      &  ggg1(3),ggg2(3)
9985       double precision vtemp1d(2),vtemp2d(2),vtemp3d(2),vtemp4d(2),
9986      &  atempd(2,2),auxmatd(2,2),achuj_tempd(2,2),gtempd(2,2),gvecd(2)
9987 C 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
9988 C           the respective energy moment and not to the cluster cumulant.
9989       s1=0.0d0
9990       s8=0.0d0
9991       s13=0.0d0
9992 c
9993       eello_turn6=0.0d0
9994       j=i+4
9995       k=i+1
9996       l=i+3
9997       iti=itortyp(itype(i))
9998       itk=itortyp(itype(k))
9999       itk1=itortyp(itype(k+1))
10000       itl=itortyp(itype(l))
10001       itj=itortyp(itype(j))
10002 cd      write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
10003 cd      write (2,*) 'i',i,' k',k,' j',j,' l',l
10004 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
10005 cd        eello6=0.0d0
10006 cd        return
10007 cd      endif
10008 cd      write (iout,*)
10009 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
10010 cd     &   ' and',k,l
10011 cd      call checkint_turn6(i,jj,kk,eel_turn6_num)
10012       do iii=1,2
10013         do kkk=1,5
10014           do lll=1,3
10015             derx_turn(lll,kkk,iii)=0.0d0
10016           enddo
10017         enddo
10018       enddo
10019 cd      eij=1.0d0
10020 cd      ekl=1.0d0
10021 cd      ekont=1.0d0
10022       eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
10023 cd      eello6_5=0.0d0
10024 cd      write (2,*) 'eello6_5',eello6_5
10025 #ifdef MOMENT
10026       call transpose2(AEA(1,1,1),auxmat(1,1))
10027       call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
10028       ss1=scalar2(Ub2(1,i+2),b1(1,l))
10029       s1 = (auxmat(1,1)+auxmat(2,2))*ss1
10030 #endif
10031       call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1(1))
10032       call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
10033       s2 = scalar2(b1(1,k),vtemp1(1))
10034 #ifdef MOMENT
10035       call transpose2(AEA(1,1,2),atemp(1,1))
10036       call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
10037       call matvec2(Ug2(1,1,i+2),dd(1,1,itk1),vtemp2(1))
10038       s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
10039 #endif
10040       call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
10041       call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
10042       s12 = scalar2(Ub2(1,i+2),vtemp3(1))
10043 #ifdef MOMENT
10044       call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
10045       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
10046       call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
10047       call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
10048       ss13 = scalar2(b1(1,k),vtemp4(1))
10049       s13 = (gtemp(1,1)+gtemp(2,2))*ss13
10050 #endif
10051 c      write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
10052 c      s1=0.0d0
10053 c      s2=0.0d0
10054 c      s8=0.0d0
10055 c      s12=0.0d0
10056 c      s13=0.0d0
10057       eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
10058 C Derivatives in gamma(i+2)
10059       s1d =0.0d0
10060       s8d =0.0d0
10061 #ifdef MOMENT
10062       call transpose2(AEA(1,1,1),auxmatd(1,1))
10063       call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
10064       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
10065       call transpose2(AEAderg(1,1,2),atempd(1,1))
10066       call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
10067       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
10068 #endif
10069       call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
10070       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
10071       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
10072 c      s1d=0.0d0
10073 c      s2d=0.0d0
10074 c      s8d=0.0d0
10075 c      s12d=0.0d0
10076 c      s13d=0.0d0
10077       gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
10078 C Derivatives in gamma(i+3)
10079 #ifdef MOMENT
10080       call transpose2(AEA(1,1,1),auxmatd(1,1))
10081       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
10082       ss1d=scalar2(Ub2der(1,i+2),b1(1,l))
10083       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
10084 #endif
10085       call matvec2(EUgder(1,1,i+2),b1(1,l),vtemp1d(1))
10086       call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
10087       s2d = scalar2(b1(1,k),vtemp1d(1))
10088 #ifdef MOMENT
10089       call matvec2(Ug2der(1,1,i+2),dd(1,1,itk1),vtemp2d(1))
10090       s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2d(1))
10091 #endif
10092       s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
10093 #ifdef MOMENT
10094       call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
10095       call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
10096       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
10097 #endif
10098 c      s1d=0.0d0
10099 c      s2d=0.0d0
10100 c      s8d=0.0d0
10101 c      s12d=0.0d0
10102 c      s13d=0.0d0
10103 #ifdef MOMENT
10104       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
10105      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
10106 #else
10107       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
10108      &               -0.5d0*ekont*(s2d+s12d)
10109 #endif
10110 C Derivatives in gamma(i+4)
10111       call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
10112       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
10113       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
10114 #ifdef MOMENT
10115       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
10116       call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
10117       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
10118 #endif
10119 c      s1d=0.0d0
10120 c      s2d=0.0d0
10121 c      s8d=0.0d0
10122 C      s12d=0.0d0
10123 c      s13d=0.0d0
10124 #ifdef MOMENT
10125       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
10126 #else
10127       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
10128 #endif
10129 C Derivatives in gamma(i+5)
10130 #ifdef MOMENT
10131       call transpose2(AEAderg(1,1,1),auxmatd(1,1))
10132       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
10133       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
10134 #endif
10135       call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1d(1))
10136       call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
10137       s2d = scalar2(b1(1,k),vtemp1d(1))
10138 #ifdef MOMENT
10139       call transpose2(AEA(1,1,2),atempd(1,1))
10140       call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
10141       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
10142 #endif
10143       call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
10144       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
10145 #ifdef MOMENT
10146       call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
10147       ss13d = scalar2(b1(1,k),vtemp4d(1))
10148       s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
10149 #endif
10150 c      s1d=0.0d0
10151 c      s2d=0.0d0
10152 c      s8d=0.0d0
10153 c      s12d=0.0d0
10154 c      s13d=0.0d0
10155 #ifdef MOMENT
10156       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
10157      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
10158 #else
10159       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
10160      &               -0.5d0*ekont*(s2d+s12d)
10161 #endif
10162 C Cartesian derivatives
10163       do iii=1,2
10164         do kkk=1,5
10165           do lll=1,3
10166 #ifdef MOMENT
10167             call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
10168             call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
10169             s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
10170 #endif
10171             call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1(1))
10172             call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),
10173      &          vtemp1d(1))
10174             s2d = scalar2(b1(1,k),vtemp1d(1))
10175 #ifdef MOMENT
10176             call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
10177             call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
10178             s8d = -(atempd(1,1)+atempd(2,2))*
10179      &           scalar2(cc(1,1,itl),vtemp2(1))
10180 #endif
10181             call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),
10182      &           auxmatd(1,1))
10183             call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
10184             s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
10185 c      s1d=0.0d0
10186 c      s2d=0.0d0
10187 c      s8d=0.0d0
10188 c      s12d=0.0d0
10189 c      s13d=0.0d0
10190 #ifdef MOMENT
10191             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
10192      &        - 0.5d0*(s1d+s2d)
10193 #else
10194             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
10195      &        - 0.5d0*s2d
10196 #endif
10197 #ifdef MOMENT
10198             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
10199      &        - 0.5d0*(s8d+s12d)
10200 #else
10201             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
10202      &        - 0.5d0*s12d
10203 #endif
10204           enddo
10205         enddo
10206       enddo
10207 #ifdef MOMENT
10208       do kkk=1,5
10209         do lll=1,3
10210           call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),
10211      &      achuj_tempd(1,1))
10212           call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
10213           call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
10214           s13d=(gtempd(1,1)+gtempd(2,2))*ss13
10215           derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
10216           call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),
10217      &      vtemp4d(1))
10218           ss13d = scalar2(b1(1,k),vtemp4d(1))
10219           s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
10220           derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
10221         enddo
10222       enddo
10223 #endif
10224 cd      write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
10225 cd     &  16*eel_turn6_num
10226 cd      goto 1112
10227       if (j.lt.nres-1) then
10228         j1=j+1
10229         j2=j-1
10230       else
10231         j1=j-1
10232         j2=j-2
10233       endif
10234       if (l.lt.nres-1) then
10235         l1=l+1
10236         l2=l-1
10237       else
10238         l1=l-1
10239         l2=l-2
10240       endif
10241       do ll=1,3
10242 cgrad        ggg1(ll)=eel_turn6*g_contij(ll,1)
10243 cgrad        ggg2(ll)=eel_turn6*g_contij(ll,2)
10244 cgrad        ghalf=0.5d0*ggg1(ll)
10245 cd        ghalf=0.0d0
10246         gturn6ij=eel_turn6*g_contij(ll,1)+ekont*derx_turn(ll,1,1)
10247         gturn6kl=eel_turn6*g_contij(ll,2)+ekont*derx_turn(ll,1,2)
10248         gcorr6_turn(ll,i)=gcorr6_turn(ll,i)!+ghalf
10249      &    +ekont*derx_turn(ll,2,1)
10250         gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
10251         gcorr6_turn(ll,j)=gcorr6_turn(ll,j)!+ghalf
10252      &    +ekont*derx_turn(ll,4,1)
10253         gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
10254         gcorr6_turn_long(ll,j)=gcorr6_turn_long(ll,j)+gturn6ij
10255         gcorr6_turn_long(ll,i)=gcorr6_turn_long(ll,i)-gturn6ij
10256 cgrad        ghalf=0.5d0*ggg2(ll)
10257 cd        ghalf=0.0d0
10258         gcorr6_turn(ll,k)=gcorr6_turn(ll,k)!+ghalf
10259      &    +ekont*derx_turn(ll,2,2)
10260         gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
10261         gcorr6_turn(ll,l)=gcorr6_turn(ll,l)!+ghalf
10262      &    +ekont*derx_turn(ll,4,2)
10263         gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
10264         gcorr6_turn_long(ll,l)=gcorr6_turn_long(ll,l)+gturn6kl
10265         gcorr6_turn_long(ll,k)=gcorr6_turn_long(ll,k)-gturn6kl
10266       enddo
10267 cd      goto 1112
10268 cgrad      do m=i+1,j-1
10269 cgrad        do ll=1,3
10270 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
10271 cgrad        enddo
10272 cgrad      enddo
10273 cgrad      do m=k+1,l-1
10274 cgrad        do ll=1,3
10275 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
10276 cgrad        enddo
10277 cgrad      enddo
10278 cgrad1112  continue
10279 cgrad      do m=i+2,j2
10280 cgrad        do ll=1,3
10281 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
10282 cgrad        enddo
10283 cgrad      enddo
10284 cgrad      do m=k+2,l2
10285 cgrad        do ll=1,3
10286 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
10287 cgrad        enddo
10288 cgrad      enddo
10289 cd      do iii=1,nres-3
10290 cd        write (2,*) iii,g_corr6_loc(iii)
10291 cd      enddo
10292       eello_turn6=ekont*eel_turn6
10293 cd      write (2,*) 'ekont',ekont
10294 cd      write (2,*) 'eel_turn6',ekont*eel_turn6
10295       return
10296       end
10297
10298 C-----------------------------------------------------------------------------
10299       double precision function scalar(u,v)
10300 !DIR$ INLINEALWAYS scalar
10301 #ifndef OSF
10302 cDEC$ ATTRIBUTES FORCEINLINE::scalar
10303 #endif
10304       implicit none
10305       double precision u(3),v(3)
10306 cd      double precision sc
10307 cd      integer i
10308 cd      sc=0.0d0
10309 cd      do i=1,3
10310 cd        sc=sc+u(i)*v(i)
10311 cd      enddo
10312 cd      scalar=sc
10313
10314       scalar=u(1)*v(1)+u(2)*v(2)+u(3)*v(3)
10315       return
10316       end
10317 crc-------------------------------------------------
10318       SUBROUTINE MATVEC2(A1,V1,V2)
10319 !DIR$ INLINEALWAYS MATVEC2
10320 #ifndef OSF
10321 cDEC$ ATTRIBUTES FORCEINLINE::MATVEC2
10322 #endif
10323       implicit real*8 (a-h,o-z)
10324       include 'DIMENSIONS'
10325       DIMENSION A1(2,2),V1(2),V2(2)
10326 c      DO 1 I=1,2
10327 c        VI=0.0
10328 c        DO 3 K=1,2
10329 c    3     VI=VI+A1(I,K)*V1(K)
10330 c        Vaux(I)=VI
10331 c    1 CONTINUE
10332
10333       vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
10334       vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
10335
10336       v2(1)=vaux1
10337       v2(2)=vaux2
10338       END
10339 C---------------------------------------
10340       SUBROUTINE MATMAT2(A1,A2,A3)
10341 #ifndef OSF
10342 cDEC$ ATTRIBUTES FORCEINLINE::MATMAT2
10343 #endif
10344       implicit real*8 (a-h,o-z)
10345       include 'DIMENSIONS'
10346       DIMENSION A1(2,2),A2(2,2),A3(2,2)
10347 c      DIMENSION AI3(2,2)
10348 c        DO  J=1,2
10349 c          A3IJ=0.0
10350 c          DO K=1,2
10351 c           A3IJ=A3IJ+A1(I,K)*A2(K,J)
10352 c          enddo
10353 c          A3(I,J)=A3IJ
10354 c       enddo
10355 c      enddo
10356
10357       ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
10358       ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
10359       ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
10360       ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
10361
10362       A3(1,1)=AI3_11
10363       A3(2,1)=AI3_21
10364       A3(1,2)=AI3_12
10365       A3(2,2)=AI3_22
10366       END
10367
10368 c-------------------------------------------------------------------------
10369       double precision function scalar2(u,v)
10370 !DIR$ INLINEALWAYS scalar2
10371       implicit none
10372       double precision u(2),v(2)
10373       double precision sc
10374       integer i
10375       scalar2=u(1)*v(1)+u(2)*v(2)
10376       return
10377       end
10378
10379 C-----------------------------------------------------------------------------
10380
10381       subroutine transpose2(a,at)
10382 !DIR$ INLINEALWAYS transpose2
10383 #ifndef OSF
10384 cDEC$ ATTRIBUTES FORCEINLINE::transpose2
10385 #endif
10386       implicit none
10387       double precision a(2,2),at(2,2)
10388       at(1,1)=a(1,1)
10389       at(1,2)=a(2,1)
10390       at(2,1)=a(1,2)
10391       at(2,2)=a(2,2)
10392       return
10393       end
10394 c--------------------------------------------------------------------------
10395       subroutine transpose(n,a,at)
10396       implicit none
10397       integer n,i,j
10398       double precision a(n,n),at(n,n)
10399       do i=1,n
10400         do j=1,n
10401           at(j,i)=a(i,j)
10402         enddo
10403       enddo
10404       return
10405       end
10406 C---------------------------------------------------------------------------
10407       subroutine prodmat3(a1,a2,kk,transp,prod)
10408 !DIR$ INLINEALWAYS prodmat3
10409 #ifndef OSF
10410 cDEC$ ATTRIBUTES FORCEINLINE::prodmat3
10411 #endif
10412       implicit none
10413       integer i,j
10414       double precision a1(2,2),a2(2,2),a2t(2,2),kk(2,2),prod(2,2)
10415       logical transp
10416 crc      double precision auxmat(2,2),prod_(2,2)
10417
10418       if (transp) then
10419 crc        call transpose2(kk(1,1),auxmat(1,1))
10420 crc        call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
10421 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
10422
10423            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1)
10424      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
10425            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2)
10426      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
10427            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1)
10428      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
10429            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2)
10430      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
10431
10432       else
10433 crc        call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
10434 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
10435
10436            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1)
10437      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
10438            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2)
10439      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
10440            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1)
10441      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
10442            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2)
10443      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
10444
10445       endif
10446 c      call transpose2(a2(1,1),a2t(1,1))
10447
10448 crc      print *,transp
10449 crc      print *,((prod_(i,j),i=1,2),j=1,2)
10450 crc      print *,((prod(i,j),i=1,2),j=1,2)
10451
10452       return
10453       end
10454 CCC----------------------------------------------
10455       subroutine Eliptransfer(eliptran)
10456       implicit real*8 (a-h,o-z)
10457       include 'DIMENSIONS'
10458       include 'COMMON.GEO'
10459       include 'COMMON.VAR'
10460       include 'COMMON.LOCAL'
10461       include 'COMMON.CHAIN'
10462       include 'COMMON.DERIV'
10463       include 'COMMON.NAMES'
10464       include 'COMMON.INTERACT'
10465       include 'COMMON.IOUNITS'
10466       include 'COMMON.CALC'
10467       include 'COMMON.CONTROL'
10468       include 'COMMON.SPLITELE'
10469       include 'COMMON.SBRIDGE'
10470 C this is done by Adasko
10471 C      print *,"wchodze"
10472 C structure of box:
10473 C      water
10474 C--bordliptop-- buffore starts
10475 C--bufliptop--- here true lipid starts
10476 C      lipid
10477 C--buflipbot--- lipid ends buffore starts
10478 C--bordlipbot--buffore ends
10479       eliptran=0.0
10480       do i=ilip_start,ilip_end
10481 C       do i=1,1
10482         if (itype(i).eq.ntyp1) cycle
10483
10484         positi=(mod(((c(3,i)+c(3,i+1))/2.0d0),boxzsize))
10485         if (positi.le.0) positi=positi+boxzsize
10486 C        print *,i
10487 C first for peptide groups
10488 c for each residue check if it is in lipid or lipid water border area
10489        if ((positi.gt.bordlipbot)
10490      &.and.(positi.lt.bordliptop)) then
10491 C the energy transfer exist
10492         if (positi.lt.buflipbot) then
10493 C what fraction I am in
10494          fracinbuf=1.0d0-
10495      &        ((positi-bordlipbot)/lipbufthick)
10496 C lipbufthick is thickenes of lipid buffore
10497          sslip=sscalelip(fracinbuf)
10498          ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
10499          eliptran=eliptran+sslip*pepliptran
10500          gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
10501          gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
10502 C         gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
10503
10504 C        print *,"doing sccale for lower part"
10505 C         print *,i,sslip,fracinbuf,ssgradlip
10506         elseif (positi.gt.bufliptop) then
10507          fracinbuf=1.0d0-((bordliptop-positi)/lipbufthick)
10508          sslip=sscalelip(fracinbuf)
10509          ssgradlip=sscagradlip(fracinbuf)/lipbufthick
10510          eliptran=eliptran+sslip*pepliptran
10511          gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
10512          gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
10513 C         gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
10514 C          print *, "doing sscalefor top part"
10515 C         print *,i,sslip,fracinbuf,ssgradlip
10516         else
10517          eliptran=eliptran+pepliptran
10518 C         print *,"I am in true lipid"
10519         endif
10520 C       else
10521 C       eliptran=elpitran+0.0 ! I am in water
10522        endif
10523        enddo
10524 C       print *, "nic nie bylo w lipidzie?"
10525 C now multiply all by the peptide group transfer factor
10526 C       eliptran=eliptran*pepliptran
10527 C now the same for side chains
10528 CV       do i=1,1
10529        do i=ilip_start,ilip_end
10530         if (itype(i).eq.ntyp1) cycle
10531         positi=(mod(c(3,i+nres),boxzsize))
10532         if (positi.le.0) positi=positi+boxzsize
10533 C       print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop
10534 c for each residue check if it is in lipid or lipid water border area
10535 C       respos=mod(c(3,i+nres),boxzsize)
10536 C       print *,positi,bordlipbot,buflipbot
10537        if ((positi.gt.bordlipbot)
10538      & .and.(positi.lt.bordliptop)) then
10539 C the energy transfer exist
10540         if (positi.lt.buflipbot) then
10541          fracinbuf=1.0d0-
10542      &     ((positi-bordlipbot)/lipbufthick)
10543 C lipbufthick is thickenes of lipid buffore
10544          sslip=sscalelip(fracinbuf)
10545          ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
10546          eliptran=eliptran+sslip*liptranene(itype(i))
10547          gliptranx(3,i)=gliptranx(3,i)
10548      &+ssgradlip*liptranene(itype(i))
10549          gliptranc(3,i-1)= gliptranc(3,i-1)
10550      &+ssgradlip*liptranene(itype(i))
10551 C         print *,"doing sccale for lower part"
10552         elseif (positi.gt.bufliptop) then
10553          fracinbuf=1.0d0-
10554      &((bordliptop-positi)/lipbufthick)
10555          sslip=sscalelip(fracinbuf)
10556          ssgradlip=sscagradlip(fracinbuf)/lipbufthick
10557          eliptran=eliptran+sslip*liptranene(itype(i))
10558          gliptranx(3,i)=gliptranx(3,i)
10559      &+ssgradlip*liptranene(itype(i))
10560          gliptranc(3,i-1)= gliptranc(3,i-1)
10561      &+ssgradlip*liptranene(itype(i))
10562 C          print *, "doing sscalefor top part",sslip,fracinbuf
10563         else
10564          eliptran=eliptran+liptranene(itype(i))
10565 C         print *,"I am in true lipid"
10566         endif
10567         endif ! if in lipid or buffor
10568 C       else
10569 C       eliptran=elpitran+0.0 ! I am in water
10570        enddo
10571        return
10572        end
10573 C---------------------------------------------------------
10574 C AFM soubroutine for constant force
10575        subroutine AFMforce(Eafmforce)
10576        implicit real*8 (a-h,o-z)
10577       include 'DIMENSIONS'
10578       include 'COMMON.GEO'
10579       include 'COMMON.VAR'
10580       include 'COMMON.LOCAL'
10581       include 'COMMON.CHAIN'
10582       include 'COMMON.DERIV'
10583       include 'COMMON.NAMES'
10584       include 'COMMON.INTERACT'
10585       include 'COMMON.IOUNITS'
10586       include 'COMMON.CALC'
10587       include 'COMMON.CONTROL'
10588       include 'COMMON.SPLITELE'
10589       include 'COMMON.SBRIDGE'
10590       real*8 diffafm(3)
10591       dist=0.0d0
10592       Eafmforce=0.0d0
10593       do i=1,3
10594       diffafm(i)=c(i,afmend)-c(i,afmbeg)
10595       dist=dist+diffafm(i)**2
10596       enddo
10597       dist=dsqrt(dist)
10598       Eafmforce=-forceAFMconst*(dist-distafminit)
10599       do i=1,3
10600       gradafm(i,afmend-1)=-forceAFMconst*diffafm(i)/dist
10601       gradafm(i,afmbeg-1)=forceAFMconst*diffafm(i)/dist
10602       enddo
10603 C      print *,'AFM',Eafmforce
10604       return
10605       end
10606 C---------------------------------------------------------
10607 C AFM subroutine with pseudoconstant velocity
10608        subroutine AFMvel(Eafmforce)
10609        implicit real*8 (a-h,o-z)
10610       include 'DIMENSIONS'
10611       include 'COMMON.GEO'
10612       include 'COMMON.VAR'
10613       include 'COMMON.LOCAL'
10614       include 'COMMON.CHAIN'
10615       include 'COMMON.DERIV'
10616       include 'COMMON.NAMES'
10617       include 'COMMON.INTERACT'
10618       include 'COMMON.IOUNITS'
10619       include 'COMMON.CALC'
10620       include 'COMMON.CONTROL'
10621       include 'COMMON.SPLITELE'
10622       include 'COMMON.SBRIDGE'
10623       real*8 diffafm(3)
10624 C Only for check grad COMMENT if not used for checkgrad
10625 C      totT=3.0d0
10626 C--------------------------------------------------------
10627 C      print *,"wchodze"
10628       dist=0.0d0
10629       Eafmforce=0.0d0
10630       do i=1,3
10631       diffafm(i)=c(i,afmend)-c(i,afmbeg)
10632       dist=dist+diffafm(i)**2
10633       enddo
10634       dist=dsqrt(dist)
10635       Eafmforce=0.5d0*forceAFMconst
10636      & *(distafminit+totTafm*velAFMconst-dist)**2
10637 C      Eafmforce=-forceAFMconst*(dist-distafminit)
10638       do i=1,3
10639       gradafm(i,afmend-1)=-forceAFMconst*
10640      &(distafminit+totTafm*velAFMconst-dist)
10641      &*diffafm(i)/dist
10642       gradafm(i,afmbeg-1)=forceAFMconst*
10643      &(distafminit+totTafm*velAFMconst-dist)
10644      &*diffafm(i)/dist
10645       enddo
10646 C      print *,'AFM',Eafmforce,totTafm*velAFMconst,dist
10647       return
10648       end
10649 C-----------------------------------------------------------
10650 C first for shielding is setting of function of side-chains
10651        subroutine set_shield_fac
10652       implicit real*8 (a-h,o-z)
10653       include 'DIMENSIONS'
10654       include 'COMMON.CHAIN'
10655       include 'COMMON.DERIV'
10656       include 'COMMON.IOUNITS'
10657       include 'COMMON.SHIELD'
10658       include 'COMMON.INTERACT'
10659 C this is the squar root 77 devided by 81 the epislion in lipid (in protein)
10660       double precision div77_81/0.974996043d0/,
10661      &div4_81/0.2222222222d0/,sh_frac_dist_grad(3)
10662
10663 C the vector between center of side_chain and peptide group
10664        double precision pep_side(3),long,side_calf(3),
10665      &pept_group(3),costhet_grad(3),cosphi_grad_long(3),
10666      &cosphi_grad_loc(3),pep_side_norm(3),side_calf_norm(3)
10667 C the line belowe needs to be changed for FGPROC>1
10668       do i=1,nres-1
10669       if ((itype(i).eq.ntyp1).and.itype(i+1).eq.ntyp1) cycle
10670       ishield_list(i)=0
10671 Cif there two consequtive dummy atoms there is no peptide group between them
10672 C the line below has to be changed for FGPROC>1
10673       VolumeTotal=0.0
10674       do k=1,nres
10675        if ((itype(k).eq.ntyp1).or.(itype(k).eq.10)) cycle
10676        dist_pep_side=0.0
10677        dist_side_calf=0.0
10678        do j=1,3
10679 C first lets set vector conecting the ithe side-chain with kth side-chain
10680       pep_side(j)=c(j,k+nres)-(c(j,i)+c(j,i+1))/2.0d0
10681 C      pep_side(j)=2.0d0
10682 C and vector conecting the side-chain with its proper calfa
10683       side_calf(j)=c(j,k+nres)-c(j,k)
10684 C      side_calf(j)=2.0d0
10685       pept_group(j)=c(j,i)-c(j,i+1)
10686 C lets have their lenght
10687       dist_pep_side=pep_side(j)**2+dist_pep_side
10688       dist_side_calf=dist_side_calf+side_calf(j)**2
10689       dist_pept_group=dist_pept_group+pept_group(j)**2
10690       enddo
10691        dist_pep_side=dsqrt(dist_pep_side)
10692        dist_pept_group=dsqrt(dist_pept_group)
10693        dist_side_calf=dsqrt(dist_side_calf)
10694       do j=1,3
10695         pep_side_norm(j)=pep_side(j)/dist_pep_side
10696         side_calf_norm(j)=dist_side_calf
10697       enddo
10698 C now sscale fraction
10699        sh_frac_dist=-(dist_pep_side-rpp(1,1)-buff_shield)/buff_shield
10700 C       print *,buff_shield,"buff"
10701 C now sscale
10702         if (sh_frac_dist.le.0.0) cycle
10703 C If we reach here it means that this side chain reaches the shielding sphere
10704 C Lets add him to the list for gradient
10705         ishield_list(i)=ishield_list(i)+1
10706 C ishield_list is a list of non 0 side-chain that contribute to factor gradient
10707 C this list is essential otherwise problem would be O3
10708         shield_list(ishield_list(i),i)=k
10709 C Lets have the sscale value
10710         if (sh_frac_dist.gt.1.0) then
10711          scale_fac_dist=1.0d0
10712          do j=1,3
10713          sh_frac_dist_grad(j)=0.0d0
10714          enddo
10715         else
10716          scale_fac_dist=-sh_frac_dist*sh_frac_dist
10717      &                   *(2.0*sh_frac_dist-3.0d0)
10718          fac_help_scale=6.0*(sh_frac_dist-sh_frac_dist**2)
10719      &                  /dist_pep_side/buff_shield*0.5
10720 C remember for the final gradient multiply sh_frac_dist_grad(j)
10721 C for side_chain by factor -2 !
10722          do j=1,3
10723          sh_frac_dist_grad(j)=fac_help_scale*pep_side(j)
10724 C         print *,"jestem",scale_fac_dist,fac_help_scale,
10725 C     &                    sh_frac_dist_grad(j)
10726          enddo
10727         endif
10728 C        if ((i.eq.3).and.(k.eq.2)) then
10729 C        print *,i,sh_frac_dist,dist_pep,fac_help_scale,scale_fac_dist
10730 C     & ,"TU"
10731 C        endif
10732
10733 C this is what is now we have the distance scaling now volume...
10734       short=short_r_sidechain(itype(k))
10735       long=long_r_sidechain(itype(k))
10736       costhet=1.0d0/dsqrt(1.0+short**2/dist_pep_side**2)
10737 C now costhet_grad
10738 C       costhet=0.0d0
10739        costhet_fac=costhet**3*short**2*(-0.5)/dist_pep_side**4
10740 C       costhet_fac=0.0d0
10741        do j=1,3
10742          costhet_grad(j)=costhet_fac*pep_side(j)
10743        enddo
10744 C remember for the final gradient multiply costhet_grad(j)
10745 C for side_chain by factor -2 !
10746 C fac alfa is angle between CB_k,CA_k, CA_i,CA_i+1
10747 C pep_side0pept_group is vector multiplication
10748       pep_side0pept_group=0.0
10749       do j=1,3
10750       pep_side0pept_group=pep_side0pept_group+pep_side(j)*side_calf(j)
10751       enddo
10752       cosalfa=(pep_side0pept_group/
10753      & (dist_pep_side*dist_side_calf))
10754       fac_alfa_sin=1.0-cosalfa**2
10755       fac_alfa_sin=dsqrt(fac_alfa_sin)
10756       rkprim=fac_alfa_sin*(long-short)+short
10757 C now costhet_grad
10758        cosphi=1.0d0/dsqrt(1.0+rkprim**2/dist_pep_side**2)
10759        cosphi_fac=cosphi**3*rkprim**2*(-0.5)/dist_pep_side**4
10760
10761        do j=1,3
10762          cosphi_grad_long(j)=cosphi_fac*pep_side(j)
10763      &+cosphi**3*0.5/dist_pep_side**2*(-rkprim)
10764      &*(long-short)/fac_alfa_sin*cosalfa/
10765      &((dist_pep_side*dist_side_calf))*
10766      &((side_calf(j))-cosalfa*
10767      &((pep_side(j)/dist_pep_side)*dist_side_calf))
10768
10769         cosphi_grad_loc(j)=cosphi**3*0.5/dist_pep_side**2*(-rkprim)
10770      &*(long-short)/fac_alfa_sin*cosalfa
10771      &/((dist_pep_side*dist_side_calf))*
10772      &(pep_side(j)-
10773      &cosalfa*side_calf(j)/dist_side_calf*dist_pep_side)
10774        enddo
10775
10776       VofOverlap=VSolvSphere/2.0d0*(1.0-costhet)*(1.0-cosphi)
10777      &                    /VSolvSphere_div
10778 C now the gradient...
10779 C grad_shield is gradient of Calfa for peptide groups
10780 C      write(iout,*) "shield_compon",i,k,VSolvSphere,scale_fac_dist,
10781 C     &               costhet,cosphi
10782 C       write(iout,*) "cosphi_compon",i,k,pep_side0pept_group,
10783 C     & dist_pep_side,dist_side_calf,c(1,k+nres),c(1,k),itype(k)
10784       do j=1,3
10785       grad_shield(j,i)=grad_shield(j,i)
10786 C gradient po skalowaniu
10787      &                +(sh_frac_dist_grad(j)
10788 C  gradient po costhet
10789      &-scale_fac_dist*costhet_grad(j)/(1.0-costhet)
10790      &-scale_fac_dist*(cosphi_grad_long(j))
10791      &/(1.0-cosphi) )*div77_81
10792      &*VofOverlap
10793 C grad_shield_side is Cbeta sidechain gradient
10794       grad_shield_side(j,ishield_list(i),i)=
10795      &        (sh_frac_dist_grad(j)*-2.0d0
10796      &       +scale_fac_dist*costhet_grad(j)*2.0d0/(1.0-costhet)
10797      &       +scale_fac_dist*(cosphi_grad_long(j))
10798      &        *2.0d0/(1.0-cosphi))
10799      &        *div77_81*VofOverlap
10800
10801        grad_shield_loc(j,ishield_list(i),i)=
10802      &   scale_fac_dist*cosphi_grad_loc(j)
10803      &        *2.0d0/(1.0-cosphi)
10804      &        *div77_81*VofOverlap
10805       enddo
10806       VolumeTotal=VolumeTotal+VofOverlap*scale_fac_dist
10807       enddo
10808       fac_shield(i)=VolumeTotal*div77_81+div4_81
10809 C      write(2,*) "TOTAL VOLUME",i,VolumeTotal,fac_shield(i)
10810       enddo
10811       return
10812       end
10813