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)') 'ees',i,j,eesij
3732           endif
3733
3734 C
3735 C Calculate contributions to the Cartesian gradient.
3736 C
3737 #ifdef SPLITELE
3738           facvdw=-6*rrmij*(ev1+evdwij)*sss
3739           facel=-3*rrmij*(el1+eesij)
3740           fac1=fac
3741           erij(1)=xj*rmij
3742           erij(2)=yj*rmij
3743           erij(3)=zj*rmij
3744
3745 *
3746 * Radial derivatives. First process both termini of the fragment (i,j)
3747 *
3748           ggg(1)=facel*xj
3749           ggg(2)=facel*yj
3750           ggg(3)=facel*zj
3751           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
3752      &  (shield_mode.gt.0)) then
3753 C          print *,i,j
3754           do ilist=1,ishield_list(i)
3755            iresshield=shield_list(ilist,i)
3756            do k=1,3
3757            rlocshield=grad_shield_side(k,ilist,i)*eesij/fac_shield(i)
3758            gshieldx(k,iresshield)=gshieldx(k,iresshield)+
3759      &              rlocshield
3760      & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)
3761             gshieldc(k,iresshield-1)=gshieldc(k,iresshield-1)+rlocshield
3762 C           gshieldc_loc(k,iresshield)=gshieldc_loc(k,iresshield)
3763 C     & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)
3764 C             if (iresshield.gt.i) then
3765 C               do ishi=i+1,iresshield-1
3766 C                gshieldc(k,ishi)=gshieldc(k,ishi)+rlocshield
3767 C     & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)
3768 C
3769 C              enddo
3770 C             else
3771 C               do ishi=iresshield,i
3772 C                gshieldc(k,ishi)=gshieldc(k,ishi)-rlocshield
3773 C     & -grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)
3774 C
3775 C               enddo
3776 C              endif
3777            enddo
3778           enddo
3779           do ilist=1,ishield_list(j)
3780            iresshield=shield_list(ilist,j)
3781            do k=1,3
3782            rlocshield=grad_shield_side(k,ilist,j)*eesij/fac_shield(j)
3783            gshieldx(k,iresshield)=gshieldx(k,iresshield)+
3784      &              rlocshield
3785      & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
3786            gshieldc(k,iresshield-1)=gshieldc(k,iresshield-1)+rlocshield
3787
3788 C     & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
3789 C           gshieldc_loc(k,iresshield)=gshieldc_loc(k,iresshield)
3790 C     & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
3791 C             if (iresshield.gt.j) then
3792 C               do ishi=j+1,iresshield-1
3793 C                gshieldc(k,ishi)=gshieldc(k,ishi)+rlocshield
3794 C     & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
3795 C
3796 C               enddo
3797 C            else
3798 C               do ishi=iresshield,j
3799 C                gshieldc(k,ishi)=gshieldc(k,ishi)-rlocshield
3800 C     & -grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
3801 C               enddo
3802 C              endif
3803            enddo
3804           enddo
3805
3806           do k=1,3
3807             gshieldc(k,i)=gshieldc(k,i)+
3808      &              grad_shield(k,i)*eesij/fac_shield(i)
3809             gshieldc(k,j)=gshieldc(k,j)+
3810      &              grad_shield(k,j)*eesij/fac_shield(j)
3811             gshieldc(k,i-1)=gshieldc(k,i-1)+
3812      &              grad_shield(k,i)*eesij/fac_shield(i)
3813             gshieldc(k,j-1)=gshieldc(k,j-1)+
3814      &              grad_shield(k,j)*eesij/fac_shield(j)
3815
3816            enddo
3817            endif
3818 c          do k=1,3
3819 c            ghalf=0.5D0*ggg(k)
3820 c            gelc(k,i)=gelc(k,i)+ghalf
3821 c            gelc(k,j)=gelc(k,j)+ghalf
3822 c          enddo
3823 c 9/28/08 AL Gradient compotents will be summed only at the end
3824 C           print *,"before", gelc_long(1,i), gelc_long(1,j)
3825           do k=1,3
3826             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
3827 C     &                    +grad_shield(k,j)*eesij/fac_shield(j)
3828             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
3829 C     &                    +grad_shield(k,i)*eesij/fac_shield(i)
3830 C            gelc_long(k,i-1)=gelc_long(k,i-1)
3831 C     &                    +grad_shield(k,i)*eesij/fac_shield(i)
3832 C            gelc_long(k,j-1)=gelc_long(k,j-1)
3833 C     &                    +grad_shield(k,j)*eesij/fac_shield(j)
3834           enddo
3835 C           print *,"bafter", gelc_long(1,i), gelc_long(1,j)
3836
3837 *
3838 * Loop over residues i+1 thru j-1.
3839 *
3840 cgrad          do k=i+1,j-1
3841 cgrad            do l=1,3
3842 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3843 cgrad            enddo
3844 cgrad          enddo
3845           if (sss.gt.0.0) then
3846           ggg(1)=facvdw*xj+sssgrad*rmij*evdwij*xj
3847           ggg(2)=facvdw*yj+sssgrad*rmij*evdwij*yj
3848           ggg(3)=facvdw*zj+sssgrad*rmij*evdwij*zj
3849           else
3850           ggg(1)=0.0
3851           ggg(2)=0.0
3852           ggg(3)=0.0
3853           endif
3854 c          do k=1,3
3855 c            ghalf=0.5D0*ggg(k)
3856 c            gvdwpp(k,i)=gvdwpp(k,i)+ghalf
3857 c            gvdwpp(k,j)=gvdwpp(k,j)+ghalf
3858 c          enddo
3859 c 9/28/08 AL Gradient compotents will be summed only at the end
3860           do k=1,3
3861             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
3862             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
3863           enddo
3864 *
3865 * Loop over residues i+1 thru j-1.
3866 *
3867 cgrad          do k=i+1,j-1
3868 cgrad            do l=1,3
3869 cgrad              gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
3870 cgrad            enddo
3871 cgrad          enddo
3872 #else
3873 C MARYSIA
3874           facvdw=(ev1+evdwij)*sss
3875           facel=(el1+eesij)
3876           fac1=fac
3877           fac=-3*rrmij*(facvdw+facvdw+facel)
3878           erij(1)=xj*rmij
3879           erij(2)=yj*rmij
3880           erij(3)=zj*rmij
3881 *
3882 * Radial derivatives. First process both termini of the fragment (i,j)
3883 *
3884           ggg(1)=fac*xj
3885 C+eesij*grad_shield(1,i)+eesij*grad_shield(1,j)
3886           ggg(2)=fac*yj
3887 C+eesij*grad_shield(2,i)+eesij*grad_shield(2,j)
3888           ggg(3)=fac*zj
3889 C+eesij*grad_shield(3,i)+eesij*grad_shield(3,j)
3890 c          do k=1,3
3891 c            ghalf=0.5D0*ggg(k)
3892 c            gelc(k,i)=gelc(k,i)+ghalf
3893 c            gelc(k,j)=gelc(k,j)+ghalf
3894 c          enddo
3895 c 9/28/08 AL Gradient compotents will be summed only at the end
3896           do k=1,3
3897             gelc_long(k,j)=gelc(k,j)+ggg(k)
3898             gelc_long(k,i)=gelc(k,i)-ggg(k)
3899           enddo
3900 *
3901 * Loop over residues i+1 thru j-1.
3902 *
3903 cgrad          do k=i+1,j-1
3904 cgrad            do l=1,3
3905 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3906 cgrad            enddo
3907 cgrad          enddo
3908 c 9/28/08 AL Gradient compotents will be summed only at the end
3909           ggg(1)=facvdw*xj+sssgrad*rmij*evdwij*xj
3910           ggg(2)=facvdw*yj+sssgrad*rmij*evdwij*yj
3911           ggg(3)=facvdw*zj+sssgrad*rmij*evdwij*zj
3912           do k=1,3
3913             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
3914             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
3915           enddo
3916 #endif
3917 *
3918 * Angular part
3919 *
3920           ecosa=2.0D0*fac3*fac1+fac4
3921           fac4=-3.0D0*fac4
3922           fac3=-6.0D0*fac3
3923           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
3924           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
3925           do k=1,3
3926             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
3927             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
3928           enddo
3929 cd        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
3930 cd   &          (dcosg(k),k=1,3)
3931           do k=1,3
3932             ggg(k)=(ecosb*dcosb(k)+ecosg*dcosg(k))*
3933      &      fac_shield(i)*fac_shield(j)
3934           enddo
3935 c          do k=1,3
3936 c            ghalf=0.5D0*ggg(k)
3937 c            gelc(k,i)=gelc(k,i)+ghalf
3938 c     &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
3939 c     &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3940 c            gelc(k,j)=gelc(k,j)+ghalf
3941 c     &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
3942 c     &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3943 c          enddo
3944 cgrad          do k=i+1,j-1
3945 cgrad            do l=1,3
3946 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3947 cgrad            enddo
3948 cgrad          enddo
3949 C                     print *,"before22", gelc_long(1,i), gelc_long(1,j)
3950           do k=1,3
3951             gelc(k,i)=gelc(k,i)
3952      &           +((ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
3953      &           + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1))
3954      &           *fac_shield(i)*fac_shield(j)
3955             gelc(k,j)=gelc(k,j)
3956      &           +((ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
3957      &           + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1))
3958      &           *fac_shield(i)*fac_shield(j)
3959             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
3960             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
3961           enddo
3962 C           print *,"before33", gelc_long(1,i), gelc_long(1,j)
3963
3964 C MARYSIA
3965 c          endif !sscale
3966           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
3967      &        .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0
3968      &        .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
3969 C
3970 C 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
3971 C   energy of a peptide unit is assumed in the form of a second-order
3972 C   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
3973 C   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
3974 C   are computed for EVERY pair of non-contiguous peptide groups.
3975 C
3976
3977           if (j.lt.nres-1) then
3978             j1=j+1
3979             j2=j-1
3980           else
3981             j1=j-1
3982             j2=j-2
3983           endif
3984           kkk=0
3985           lll=0
3986           do k=1,2
3987             do l=1,2
3988               kkk=kkk+1
3989               muij(kkk)=mu(k,i)*mu(l,j)
3990 c              write(iout,*) 'mumu=', mu(k,i),mu(l,j),i,j,k,l
3991 #ifdef NEWCORR
3992              gmuij1(kkk)=gtb1(k,i+1)*mu(l,j)
3993 c             write(iout,*) 'k=',k,i,gtb1(k,i+1),gtb1(k,i+1)*mu(l,j)
3994              gmuij2(kkk)=gUb2(k,i)*mu(l,j)
3995              gmuji1(kkk)=mu(k,i)*gtb1(l,j+1)
3996 c             write(iout,*) 'l=',l,j,gtb1(l,j+1),gtb1(l,j+1)*mu(k,i)
3997              gmuji2(kkk)=mu(k,i)*gUb2(l,j)
3998 #endif
3999             enddo
4000           enddo
4001 cd         write (iout,*) 'EELEC: i',i,' j',j
4002 cd          write (iout,*) 'j',j,' j1',j1,' j2',j2
4003 cd          write(iout,*) 'muij',muij
4004           ury=scalar(uy(1,i),erij)
4005           urz=scalar(uz(1,i),erij)
4006           vry=scalar(uy(1,j),erij)
4007           vrz=scalar(uz(1,j),erij)
4008           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
4009           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
4010           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
4011           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
4012           fac=dsqrt(-ael6i)*r3ij
4013           a22=a22*fac
4014           a23=a23*fac
4015           a32=a32*fac
4016           a33=a33*fac
4017 cd          write (iout,'(4i5,4f10.5)')
4018 cd     &     i,itortyp(itype(i)),j,itortyp(itype(j)),a22,a23,a32,a33
4019 cd          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
4020 cd          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') uy(:,i),uz(:,i),
4021 cd     &      uy(:,j),uz(:,j)
4022 cd          write (iout,'(4f10.5)')
4023 cd     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
4024 cd     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
4025 cd          write (iout,'(4f10.5)') ury,urz,vry,vrz
4026 cd           write (iout,'(9f10.5/)')
4027 cd     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
4028 C Derivatives of the elements of A in virtual-bond vectors
4029           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
4030           do k=1,3
4031             uryg(k,1)=scalar(erder(1,k),uy(1,i))
4032             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
4033             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
4034             urzg(k,1)=scalar(erder(1,k),uz(1,i))
4035             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
4036             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
4037             vryg(k,1)=scalar(erder(1,k),uy(1,j))
4038             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
4039             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
4040             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
4041             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
4042             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
4043           enddo
4044 C Compute radial contributions to the gradient
4045           facr=-3.0d0*rrmij
4046           a22der=a22*facr
4047           a23der=a23*facr
4048           a32der=a32*facr
4049           a33der=a33*facr
4050           agg(1,1)=a22der*xj
4051           agg(2,1)=a22der*yj
4052           agg(3,1)=a22der*zj
4053           agg(1,2)=a23der*xj
4054           agg(2,2)=a23der*yj
4055           agg(3,2)=a23der*zj
4056           agg(1,3)=a32der*xj
4057           agg(2,3)=a32der*yj
4058           agg(3,3)=a32der*zj
4059           agg(1,4)=a33der*xj
4060           agg(2,4)=a33der*yj
4061           agg(3,4)=a33der*zj
4062 C Add the contributions coming from er
4063           fac3=-3.0d0*fac
4064           do k=1,3
4065             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
4066             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
4067             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
4068             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
4069           enddo
4070           do k=1,3
4071 C Derivatives in DC(i)
4072 cgrad            ghalf1=0.5d0*agg(k,1)
4073 cgrad            ghalf2=0.5d0*agg(k,2)
4074 cgrad            ghalf3=0.5d0*agg(k,3)
4075 cgrad            ghalf4=0.5d0*agg(k,4)
4076             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j))
4077      &      -3.0d0*uryg(k,2)*vry)!+ghalf1
4078             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j))
4079      &      -3.0d0*uryg(k,2)*vrz)!+ghalf2
4080             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j))
4081      &      -3.0d0*urzg(k,2)*vry)!+ghalf3
4082             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j))
4083      &      -3.0d0*urzg(k,2)*vrz)!+ghalf4
4084 C Derivatives in DC(i+1)
4085             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j))
4086      &      -3.0d0*uryg(k,3)*vry)!+agg(k,1)
4087             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j))
4088      &      -3.0d0*uryg(k,3)*vrz)!+agg(k,2)
4089             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j))
4090      &      -3.0d0*urzg(k,3)*vry)!+agg(k,3)
4091             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j))
4092      &      -3.0d0*urzg(k,3)*vrz)!+agg(k,4)
4093 C Derivatives in DC(j)
4094             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i))
4095      &      -3.0d0*vryg(k,2)*ury)!+ghalf1
4096             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i))
4097      &      -3.0d0*vrzg(k,2)*ury)!+ghalf2
4098             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i))
4099      &      -3.0d0*vryg(k,2)*urz)!+ghalf3
4100             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i))
4101      &      -3.0d0*vrzg(k,2)*urz)!+ghalf4
4102 C Derivatives in DC(j+1) or DC(nres-1)
4103             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i))
4104      &      -3.0d0*vryg(k,3)*ury)
4105             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i))
4106      &      -3.0d0*vrzg(k,3)*ury)
4107             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i))
4108      &      -3.0d0*vryg(k,3)*urz)
4109             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i))
4110      &      -3.0d0*vrzg(k,3)*urz)
4111 cgrad            if (j.eq.nres-1 .and. i.lt.j-2) then
4112 cgrad              do l=1,4
4113 cgrad                aggj1(k,l)=aggj1(k,l)+agg(k,l)
4114 cgrad              enddo
4115 cgrad            endif
4116           enddo
4117           acipa(1,1)=a22
4118           acipa(1,2)=a23
4119           acipa(2,1)=a32
4120           acipa(2,2)=a33
4121           a22=-a22
4122           a23=-a23
4123           do l=1,2
4124             do k=1,3
4125               agg(k,l)=-agg(k,l)
4126               aggi(k,l)=-aggi(k,l)
4127               aggi1(k,l)=-aggi1(k,l)
4128               aggj(k,l)=-aggj(k,l)
4129               aggj1(k,l)=-aggj1(k,l)
4130             enddo
4131           enddo
4132           if (j.lt.nres-1) then
4133             a22=-a22
4134             a32=-a32
4135             do l=1,3,2
4136               do k=1,3
4137                 agg(k,l)=-agg(k,l)
4138                 aggi(k,l)=-aggi(k,l)
4139                 aggi1(k,l)=-aggi1(k,l)
4140                 aggj(k,l)=-aggj(k,l)
4141                 aggj1(k,l)=-aggj1(k,l)
4142               enddo
4143             enddo
4144           else
4145             a22=-a22
4146             a23=-a23
4147             a32=-a32
4148             a33=-a33
4149             do l=1,4
4150               do k=1,3
4151                 agg(k,l)=-agg(k,l)
4152                 aggi(k,l)=-aggi(k,l)
4153                 aggi1(k,l)=-aggi1(k,l)
4154                 aggj(k,l)=-aggj(k,l)
4155                 aggj1(k,l)=-aggj1(k,l)
4156               enddo
4157             enddo
4158           endif
4159           ENDIF ! WCORR
4160           IF (wel_loc.gt.0.0d0) THEN
4161 C Contribution to the local-electrostatic energy coming from the i-j pair
4162           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3)
4163      &     +a33*muij(4)
4164 c          write (iout,*) 'i',i,' j',j,itype(i),itype(j),
4165 c     &                     ' eel_loc_ij',eel_loc_ij
4166 C          write(iout,*) 'muije=',i,j,muij(1),muij(2),muij(3),muij(4)
4167 C Calculate patrial derivative for theta angle
4168 #ifdef NEWCORR
4169          geel_loc_ij=a22*gmuij1(1)
4170      &     +a23*gmuij1(2)
4171      &     +a32*gmuij1(3)
4172      &     +a33*gmuij1(4)
4173 c         write(iout,*) "derivative over thatai"
4174 c         write(iout,*) a22*gmuij1(1), a23*gmuij1(2) ,a32*gmuij1(3),
4175 c     &   a33*gmuij1(4)
4176          gloc(nphi+i,icg)=gloc(nphi+i,icg)+
4177      &      geel_loc_ij*wel_loc
4178 c         write(iout,*) "derivative over thatai-1"
4179 c         write(iout,*) a22*gmuij2(1), a23*gmuij2(2) ,a32*gmuij2(3),
4180 c     &   a33*gmuij2(4)
4181          geel_loc_ij=
4182      &     a22*gmuij2(1)
4183      &     +a23*gmuij2(2)
4184      &     +a32*gmuij2(3)
4185      &     +a33*gmuij2(4)
4186          gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
4187      &      geel_loc_ij*wel_loc
4188 c  Derivative over j residue
4189          geel_loc_ji=a22*gmuji1(1)
4190      &     +a23*gmuji1(2)
4191      &     +a32*gmuji1(3)
4192      &     +a33*gmuji1(4)
4193 c         write(iout,*) "derivative over thataj"
4194 c         write(iout,*) a22*gmuji1(1), a23*gmuji1(2) ,a32*gmuji1(3),
4195 c     &   a33*gmuji1(4)
4196
4197         gloc(nphi+j,icg)=gloc(nphi+j,icg)+
4198      &      geel_loc_ji*wel_loc
4199          geel_loc_ji=
4200      &     +a22*gmuji2(1)
4201      &     +a23*gmuji2(2)
4202      &     +a32*gmuji2(3)
4203      &     +a33*gmuji2(4)
4204 c         write(iout,*) "derivative over thataj-1"
4205 c         write(iout,*) a22*gmuji2(1), a23*gmuji2(2) ,a32*gmuji2(3),
4206 c     &   a33*gmuji2(4)
4207          gloc(nphi+j-1,icg)=gloc(nphi+j-1,icg)+
4208      &      geel_loc_ji*wel_loc
4209 #endif
4210 cd          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
4211
4212           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
4213      &            'eelloc',i,j,eel_loc_ij
4214 c           if (eel_loc_ij.ne.0)
4215 c     &      write (iout,'(a4,2i4,8f9.5)')'chuj',
4216 c     &     i,j,a22,muij(1),a23,muij(2),a32,muij(3),a33,muij(4)
4217
4218           eel_loc=eel_loc+eel_loc_ij
4219 C Partial derivatives in virtual-bond dihedral angles gamma
4220           if (i.gt.1)
4221      &    gel_loc_loc(i-1)=gel_loc_loc(i-1)+
4222      &            a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j)
4223      &           +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j)
4224           gel_loc_loc(j-1)=gel_loc_loc(j-1)+
4225      &            a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j)
4226      &           +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j)
4227 C Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
4228           do l=1,3
4229             ggg(l)=agg(l,1)*muij(1)+
4230      &          agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4)
4231             gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l)
4232             gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l)
4233 cgrad            ghalf=0.5d0*ggg(l)
4234 cgrad            gel_loc(l,i)=gel_loc(l,i)+ghalf
4235 cgrad            gel_loc(l,j)=gel_loc(l,j)+ghalf
4236           enddo
4237 cgrad          do k=i+1,j2
4238 cgrad            do l=1,3
4239 cgrad              gel_loc(l,k)=gel_loc(l,k)+ggg(l)
4240 cgrad            enddo
4241 cgrad          enddo
4242 C Remaining derivatives of eello
4243           do l=1,3
4244             gel_loc(l,i)=gel_loc(l,i)+(aggi(l,1)*muij(1)+
4245      &        aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4))
4246             gel_loc(l,i+1)=gel_loc(l,i+1)+(aggi1(l,1)*muij(1)+
4247      &     aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4))
4248             gel_loc(l,j)=gel_loc(l,j)+(aggj(l,1)*muij(1)+
4249      &       aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4))
4250             gel_loc(l,j1)=gel_loc(l,j1)+(aggj1(l,1)*muij(1)+
4251      &     aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4))
4252           enddo
4253           ENDIF
4254 C Change 12/26/95 to calculate four-body contributions to H-bonding energy
4255 c          if (j.gt.i+1 .and. num_conti.le.maxconts) then
4256           if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0
4257      &       .and. num_conti.le.maxconts) then
4258 c            write (iout,*) i,j," entered corr"
4259 C
4260 C Calculate the contact function. The ith column of the array JCONT will
4261 C contain the numbers of atoms that make contacts with the atom I (of numbers
4262 C greater than I). The arrays FACONT and GACONT will contain the values of
4263 C the contact function and its derivative.
4264 c           r0ij=1.02D0*rpp(iteli,itelj)
4265 c           r0ij=1.11D0*rpp(iteli,itelj)
4266             r0ij=2.20D0*rpp(iteli,itelj)
4267 c           r0ij=1.55D0*rpp(iteli,itelj)
4268             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
4269             if (fcont.gt.0.0D0) then
4270               num_conti=num_conti+1
4271               if (num_conti.gt.maxconts) then
4272                 write (iout,*) 'WARNING - max. # of contacts exceeded;',
4273      &                         ' will skip next contacts for this conf.'
4274               else
4275                 jcont_hb(num_conti,i)=j
4276 cd                write (iout,*) "i",i," j",j," num_conti",num_conti,
4277 cd     &           " jcont_hb",jcont_hb(num_conti,i)
4278                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.
4279      &          wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
4280 C 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
4281 C  terms.
4282                 d_cont(num_conti,i)=rij
4283 cd                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
4284 C     --- Electrostatic-interaction matrix ---
4285                 a_chuj(1,1,num_conti,i)=a22
4286                 a_chuj(1,2,num_conti,i)=a23
4287                 a_chuj(2,1,num_conti,i)=a32
4288                 a_chuj(2,2,num_conti,i)=a33
4289 C     --- Gradient of rij
4290                 do kkk=1,3
4291                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
4292                 enddo
4293                 kkll=0
4294                 do k=1,2
4295                   do l=1,2
4296                     kkll=kkll+1
4297                     do m=1,3
4298                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
4299                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
4300                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
4301                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
4302                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
4303                     enddo
4304                   enddo
4305                 enddo
4306                 ENDIF
4307                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
4308 C Calculate contact energies
4309                 cosa4=4.0D0*cosa
4310                 wij=cosa-3.0D0*cosb*cosg
4311                 cosbg1=cosb+cosg
4312                 cosbg2=cosb-cosg
4313 c               fac3=dsqrt(-ael6i)/r0ij**3
4314                 fac3=dsqrt(-ael6i)*r3ij
4315 c                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
4316                 ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
4317                 if (ees0tmp.gt.0) then
4318                   ees0pij=dsqrt(ees0tmp)
4319                 else
4320                   ees0pij=0
4321                 endif
4322 c                ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
4323                 ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
4324                 if (ees0tmp.gt.0) then
4325                   ees0mij=dsqrt(ees0tmp)
4326                 else
4327                   ees0mij=0
4328                 endif
4329 c               ees0mij=0.0D0
4330                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij)
4331                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij)
4332 C Diagnostics. Comment out or remove after debugging!
4333 c               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
4334 c               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
4335 c               ees0m(num_conti,i)=0.0D0
4336 C End diagnostics.
4337 c               write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
4338 c    & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
4339 C Angular derivatives of the contact function
4340                 ees0pij1=fac3/ees0pij
4341                 ees0mij1=fac3/ees0mij
4342                 fac3p=-3.0D0*fac3*rrmij
4343                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
4344                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
4345 c               ees0mij1=0.0D0
4346                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
4347                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
4348                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
4349                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
4350                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
4351                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
4352                 ecosap=ecosa1+ecosa2
4353                 ecosbp=ecosb1+ecosb2
4354                 ecosgp=ecosg1+ecosg2
4355                 ecosam=ecosa1-ecosa2
4356                 ecosbm=ecosb1-ecosb2
4357                 ecosgm=ecosg1-ecosg2
4358 C Diagnostics
4359 c               ecosap=ecosa1
4360 c               ecosbp=ecosb1
4361 c               ecosgp=ecosg1
4362 c               ecosam=0.0D0
4363 c               ecosbm=0.0D0
4364 c               ecosgm=0.0D0
4365 C End diagnostics
4366                 facont_hb(num_conti,i)=fcont
4367                 fprimcont=fprimcont/rij
4368 cd              facont_hb(num_conti,i)=1.0D0
4369 C Following line is for diagnostics.
4370 cd              fprimcont=0.0D0
4371                 do k=1,3
4372                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
4373                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
4374                 enddo
4375                 do k=1,3
4376                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
4377                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
4378                 enddo
4379                 gggp(1)=gggp(1)+ees0pijp*xj
4380                 gggp(2)=gggp(2)+ees0pijp*yj
4381                 gggp(3)=gggp(3)+ees0pijp*zj
4382                 gggm(1)=gggm(1)+ees0mijp*xj
4383                 gggm(2)=gggm(2)+ees0mijp*yj
4384                 gggm(3)=gggm(3)+ees0mijp*zj
4385 C Derivatives due to the contact function
4386                 gacont_hbr(1,num_conti,i)=fprimcont*xj
4387                 gacont_hbr(2,num_conti,i)=fprimcont*yj
4388                 gacont_hbr(3,num_conti,i)=fprimcont*zj
4389                 do k=1,3
4390 c
4391 c 10/24/08 cgrad and ! comments indicate the parts of the code removed
4392 c          following the change of gradient-summation algorithm.
4393 c
4394 cgrad                  ghalfp=0.5D0*gggp(k)
4395 cgrad                  ghalfm=0.5D0*gggm(k)
4396                   gacontp_hb1(k,num_conti,i)=!ghalfp
4397      &              +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i))
4398      &              + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
4399                   gacontp_hb2(k,num_conti,i)=!ghalfp
4400      &              +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j))
4401      &              + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
4402                   gacontp_hb3(k,num_conti,i)=gggp(k)
4403                   gacontm_hb1(k,num_conti,i)=!ghalfm
4404      &              +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i))
4405      &              + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
4406                   gacontm_hb2(k,num_conti,i)=!ghalfm
4407      &              +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j))
4408      &              + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
4409                   gacontm_hb3(k,num_conti,i)=gggm(k)
4410                 enddo
4411 C Diagnostics. Comment out or remove after debugging!
4412 cdiag           do k=1,3
4413 cdiag             gacontp_hb1(k,num_conti,i)=0.0D0
4414 cdiag             gacontp_hb2(k,num_conti,i)=0.0D0
4415 cdiag             gacontp_hb3(k,num_conti,i)=0.0D0
4416 cdiag             gacontm_hb1(k,num_conti,i)=0.0D0
4417 cdiag             gacontm_hb2(k,num_conti,i)=0.0D0
4418 cdiag             gacontm_hb3(k,num_conti,i)=0.0D0
4419 cdiag           enddo
4420               ENDIF ! wcorr
4421               endif  ! num_conti.le.maxconts
4422             endif  ! fcont.gt.0
4423           endif    ! j.gt.i+1
4424           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
4425             do k=1,4
4426               do l=1,3
4427                 ghalf=0.5d0*agg(l,k)
4428                 aggi(l,k)=aggi(l,k)+ghalf
4429                 aggi1(l,k)=aggi1(l,k)+agg(l,k)
4430                 aggj(l,k)=aggj(l,k)+ghalf
4431               enddo
4432             enddo
4433             if (j.eq.nres-1 .and. i.lt.j-2) then
4434               do k=1,4
4435                 do l=1,3
4436                   aggj1(l,k)=aggj1(l,k)+agg(l,k)
4437                 enddo
4438               enddo
4439             endif
4440           endif
4441 c          t_eelecij=t_eelecij+MPI_Wtime()-time00
4442       return
4443       end
4444 C-----------------------------------------------------------------------------
4445       subroutine eturn3(i,eello_turn3)
4446 C Third- and fourth-order contributions from turns
4447       implicit real*8 (a-h,o-z)
4448       include 'DIMENSIONS'
4449       include 'COMMON.IOUNITS'
4450       include 'COMMON.GEO'
4451       include 'COMMON.VAR'
4452       include 'COMMON.LOCAL'
4453       include 'COMMON.CHAIN'
4454       include 'COMMON.DERIV'
4455       include 'COMMON.INTERACT'
4456       include 'COMMON.CONTACTS'
4457       include 'COMMON.TORSION'
4458       include 'COMMON.VECTORS'
4459       include 'COMMON.FFIELD'
4460       include 'COMMON.CONTROL'
4461       dimension ggg(3)
4462       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
4463      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
4464      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2),gpizda1(2,2),
4465      &  gpizda2(2,2),auxgmat1(2,2),auxgmatt1(2,2),
4466      &  auxgmat2(2,2),auxgmatt2(2,2)
4467       double precision agg(3,4),aggi(3,4),aggi1(3,4),
4468      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
4469       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
4470      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
4471      &    num_conti,j1,j2
4472       j=i+2
4473 c      write (iout,*) "eturn3",i,j,j1,j2
4474       a_temp(1,1)=a22
4475       a_temp(1,2)=a23
4476       a_temp(2,1)=a32
4477       a_temp(2,2)=a33
4478 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4479 C
4480 C               Third-order contributions
4481 C
4482 C                 (i+2)o----(i+3)
4483 C                      | |
4484 C                      | |
4485 C                 (i+1)o----i
4486 C
4487 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4488 cd        call checkint_turn3(i,a_temp,eello_turn3_num)
4489         call matmat2(EUg(1,1,i+1),EUg(1,1,i+2),auxmat(1,1))
4490 c auxalary matices for theta gradient
4491 c auxalary matrix for i+1 and constant i+2
4492         call matmat2(gtEUg(1,1,i+1),EUg(1,1,i+2),auxgmat1(1,1))
4493 c auxalary matrix for i+2 and constant i+1
4494         call matmat2(EUg(1,1,i+1),gtEUg(1,1,i+2),auxgmat2(1,1))
4495         call transpose2(auxmat(1,1),auxmat1(1,1))
4496         call transpose2(auxgmat1(1,1),auxgmatt1(1,1))
4497         call transpose2(auxgmat2(1,1),auxgmatt2(1,1))
4498         call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4499         call matmat2(a_temp(1,1),auxgmatt1(1,1),gpizda1(1,1))
4500         call matmat2(a_temp(1,1),auxgmatt2(1,1),gpizda2(1,1))
4501         eello_turn3=eello_turn3+0.5d0*(pizda(1,1)+pizda(2,2))
4502 C Derivatives in theta
4503         gloc(nphi+i,icg)=gloc(nphi+i,icg)
4504      &  +0.5d0*(gpizda1(1,1)+gpizda1(2,2))*wturn3
4505         gloc(nphi+i+1,icg)=gloc(nphi+i+1,icg)
4506      &  +0.5d0*(gpizda2(1,1)+gpizda2(2,2))*wturn3
4507
4508         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
4509      &          'eturn3',i,j,0.5d0*(pizda(1,1)+pizda(2,2))
4510 cd        write (2,*) 'i,',i,' j',j,'eello_turn3',
4511 cd     &    0.5d0*(pizda(1,1)+pizda(2,2)),
4512 cd     &    ' eello_turn3_num',4*eello_turn3_num
4513 C Derivatives in gamma(i)
4514         call matmat2(EUgder(1,1,i+1),EUg(1,1,i+2),auxmat2(1,1))
4515         call transpose2(auxmat2(1,1),auxmat3(1,1))
4516         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
4517         gel_loc_turn3(i)=gel_loc_turn3(i)+0.5d0*(pizda(1,1)+pizda(2,2))
4518 C Derivatives in gamma(i+1)
4519         call matmat2(EUg(1,1,i+1),EUgder(1,1,i+2),auxmat2(1,1))
4520         call transpose2(auxmat2(1,1),auxmat3(1,1))
4521         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
4522         gel_loc_turn3(i+1)=gel_loc_turn3(i+1)
4523      &    +0.5d0*(pizda(1,1)+pizda(2,2))
4524 C Cartesian derivatives
4525         do l=1,3
4526 c            ghalf1=0.5d0*agg(l,1)
4527 c            ghalf2=0.5d0*agg(l,2)
4528 c            ghalf3=0.5d0*agg(l,3)
4529 c            ghalf4=0.5d0*agg(l,4)
4530           a_temp(1,1)=aggi(l,1)!+ghalf1
4531           a_temp(1,2)=aggi(l,2)!+ghalf2
4532           a_temp(2,1)=aggi(l,3)!+ghalf3
4533           a_temp(2,2)=aggi(l,4)!+ghalf4
4534           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4535           gcorr3_turn(l,i)=gcorr3_turn(l,i)
4536      &      +0.5d0*(pizda(1,1)+pizda(2,2))
4537           a_temp(1,1)=aggi1(l,1)!+agg(l,1)
4538           a_temp(1,2)=aggi1(l,2)!+agg(l,2)
4539           a_temp(2,1)=aggi1(l,3)!+agg(l,3)
4540           a_temp(2,2)=aggi1(l,4)!+agg(l,4)
4541           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4542           gcorr3_turn(l,i+1)=gcorr3_turn(l,i+1)
4543      &      +0.5d0*(pizda(1,1)+pizda(2,2))
4544           a_temp(1,1)=aggj(l,1)!+ghalf1
4545           a_temp(1,2)=aggj(l,2)!+ghalf2
4546           a_temp(2,1)=aggj(l,3)!+ghalf3
4547           a_temp(2,2)=aggj(l,4)!+ghalf4
4548           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4549           gcorr3_turn(l,j)=gcorr3_turn(l,j)
4550      &      +0.5d0*(pizda(1,1)+pizda(2,2))
4551           a_temp(1,1)=aggj1(l,1)
4552           a_temp(1,2)=aggj1(l,2)
4553           a_temp(2,1)=aggj1(l,3)
4554           a_temp(2,2)=aggj1(l,4)
4555           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4556           gcorr3_turn(l,j1)=gcorr3_turn(l,j1)
4557      &      +0.5d0*(pizda(1,1)+pizda(2,2))
4558         enddo
4559       return
4560       end
4561 C-------------------------------------------------------------------------------
4562       subroutine eturn4(i,eello_turn4)
4563 C Third- and fourth-order contributions from turns
4564       implicit real*8 (a-h,o-z)
4565       include 'DIMENSIONS'
4566       include 'COMMON.IOUNITS'
4567       include 'COMMON.GEO'
4568       include 'COMMON.VAR'
4569       include 'COMMON.LOCAL'
4570       include 'COMMON.CHAIN'
4571       include 'COMMON.DERIV'
4572       include 'COMMON.INTERACT'
4573       include 'COMMON.CONTACTS'
4574       include 'COMMON.TORSION'
4575       include 'COMMON.VECTORS'
4576       include 'COMMON.FFIELD'
4577       include 'COMMON.CONTROL'
4578       dimension ggg(3)
4579       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
4580      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
4581      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2),auxgvec(2),
4582      &  auxgEvec1(2),auxgEvec2(2),auxgEvec3(2),
4583      &  gte1t(2,2),gte2t(2,2),gte3t(2,2),
4584      &  gte1a(2,2),gtae3(2,2),gtae3e2(2,2), ae3gte2(2,2),
4585      &  gtEpizda1(2,2),gtEpizda2(2,2),gtEpizda3(2,2)
4586       double precision agg(3,4),aggi(3,4),aggi1(3,4),
4587      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
4588       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
4589      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
4590      &    num_conti,j1,j2
4591       j=i+3
4592 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4593 C
4594 C               Fourth-order contributions
4595 C
4596 C                 (i+3)o----(i+4)
4597 C                     /  |
4598 C               (i+2)o   |
4599 C                     \  |
4600 C                 (i+1)o----i
4601 C
4602 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4603 cd        call checkint_turn4(i,a_temp,eello_turn4_num)
4604 c        write (iout,*) "eturn4 i",i," j",j," j1",j1," j2",j2
4605 c        write(iout,*)"WCHODZE W PROGRAM"
4606         a_temp(1,1)=a22
4607         a_temp(1,2)=a23
4608         a_temp(2,1)=a32
4609         a_temp(2,2)=a33
4610         iti1=itortyp(itype(i+1))
4611         iti2=itortyp(itype(i+2))
4612         iti3=itortyp(itype(i+3))
4613 c        write(iout,*) "iti1",iti1," iti2",iti2," iti3",iti3
4614         call transpose2(EUg(1,1,i+1),e1t(1,1))
4615         call transpose2(Eug(1,1,i+2),e2t(1,1))
4616         call transpose2(Eug(1,1,i+3),e3t(1,1))
4617 C Ematrix derivative in theta
4618         call transpose2(gtEUg(1,1,i+1),gte1t(1,1))
4619         call transpose2(gtEug(1,1,i+2),gte2t(1,1))
4620         call transpose2(gtEug(1,1,i+3),gte3t(1,1))
4621         call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4622 c       eta1 in derivative theta
4623         call matmat2(gte1t(1,1),a_temp(1,1),gte1a(1,1))
4624         call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4625 c       auxgvec is derivative of Ub2 so i+3 theta
4626         call matvec2(e1a(1,1),gUb2(1,i+3),auxgvec(1))
4627 c       auxalary matrix of E i+1
4628         call matvec2(gte1a(1,1),Ub2(1,i+3),auxgEvec1(1))
4629 c        s1=0.0
4630 c        gs1=0.0
4631         s1=scalar2(b1(1,i+2),auxvec(1))
4632 c derivative of theta i+2 with constant i+3
4633         gs23=scalar2(gtb1(1,i+2),auxvec(1))
4634 c derivative of theta i+2 with constant i+2
4635         gs32=scalar2(b1(1,i+2),auxgvec(1))
4636 c derivative of E matix in theta of i+1
4637         gsE13=scalar2(b1(1,i+2),auxgEvec1(1))
4638
4639         call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4640 c       ea31 in derivative theta
4641         call matmat2(a_temp(1,1),gte3t(1,1),gtae3(1,1))
4642         call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4643 c auxilary matrix auxgvec of Ub2 with constant E matirx
4644         call matvec2(ae3(1,1),gUb2(1,i+2),auxgvec(1))
4645 c auxilary matrix auxgEvec1 of E matix with Ub2 constant
4646         call matvec2(gtae3(1,1),Ub2(1,i+2),auxgEvec3(1))
4647
4648 c        s2=0.0
4649 c        gs2=0.0
4650         s2=scalar2(b1(1,i+1),auxvec(1))
4651 c derivative of theta i+1 with constant i+3
4652         gs13=scalar2(gtb1(1,i+1),auxvec(1))
4653 c derivative of theta i+2 with constant i+1
4654         gs21=scalar2(b1(1,i+1),auxgvec(1))
4655 c derivative of theta i+3 with constant i+1
4656         gsE31=scalar2(b1(1,i+1),auxgEvec3(1))
4657 c        write(iout,*) gs1,gs2,'i=',i,auxgvec(1),gUb2(1,i+2),gtb1(1,i+2),
4658 c     &  gtb1(1,i+1)
4659         call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4660 c two derivatives over diffetent matrices
4661 c gtae3e2 is derivative over i+3
4662         call matmat2(gtae3(1,1),e2t(1,1),gtae3e2(1,1))
4663 c ae3gte2 is derivative over i+2
4664         call matmat2(ae3(1,1),gte2t(1,1),ae3gte2(1,1))
4665         call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4666 c three possible derivative over theta E matices
4667 c i+1
4668         call matmat2(ae3e2(1,1),gte1t(1,1),gtEpizda1(1,1))
4669 c i+2
4670         call matmat2(ae3gte2(1,1),e1t(1,1),gtEpizda2(1,1))
4671 c i+3
4672         call matmat2(gtae3e2(1,1),e1t(1,1),gtEpizda3(1,1))
4673         s3=0.5d0*(pizda(1,1)+pizda(2,2))
4674
4675         gsEE1=0.5d0*(gtEpizda1(1,1)+gtEpizda1(2,2))
4676         gsEE2=0.5d0*(gtEpizda2(1,1)+gtEpizda2(2,2))
4677         gsEE3=0.5d0*(gtEpizda3(1,1)+gtEpizda3(2,2))
4678
4679         eello_turn4=eello_turn4-(s1+s2+s3)
4680 c             write(iout,*)'chujOWO', auxvec(1),b1(1,iti2)
4681         if (energy_dec) write (iout,'(a6,2i5,0pf7.3,3f7.3)')
4682      &      'eturn4',i,j,-(s1+s2+s3),s1,s2,s3
4683 cd        write (2,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
4684 cd     &    ' eello_turn4_num',8*eello_turn4_num
4685 #ifdef NEWCORR
4686         gloc(nphi+i,icg)=gloc(nphi+i,icg)
4687      &                  -(gs13+gsE13+gsEE1)*wturn4
4688         gloc(nphi+i+1,icg)= gloc(nphi+i+1,icg)
4689      &                    -(gs23+gs21+gsEE2)*wturn4
4690         gloc(nphi+i+2,icg)= gloc(nphi+i+2,icg)
4691      &                    -(gs32+gsE31+gsEE3)*wturn4
4692 c         gloc(nphi+i+1,icg)=gloc(nphi+i+1,icg)-
4693 c     &   gs2
4694 #endif
4695         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
4696      &      'eturn4',i,j,-(s1+s2+s3)
4697 c        write (iout,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
4698 c     &    ' eello_turn4_num',8*eello_turn4_num
4699 C Derivatives in gamma(i)
4700         call transpose2(EUgder(1,1,i+1),e1tder(1,1))
4701         call matmat2(e1tder(1,1),a_temp(1,1),auxmat(1,1))
4702         call matvec2(auxmat(1,1),Ub2(1,i+3),auxvec(1))
4703         s1=scalar2(b1(1,i+2),auxvec(1))
4704         call matmat2(ae3e2(1,1),e1tder(1,1),pizda(1,1))
4705         s3=0.5d0*(pizda(1,1)+pizda(2,2))
4706         gel_loc_turn4(i)=gel_loc_turn4(i)-(s1+s3)
4707 C Derivatives in gamma(i+1)
4708         call transpose2(EUgder(1,1,i+2),e2tder(1,1))
4709         call matvec2(ae3(1,1),Ub2der(1,i+2),auxvec(1))
4710         s2=scalar2(b1(1,i+1),auxvec(1))
4711         call matmat2(ae3(1,1),e2tder(1,1),auxmat(1,1))
4712         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
4713         s3=0.5d0*(pizda(1,1)+pizda(2,2))
4714         gel_loc_turn4(i+1)=gel_loc_turn4(i+1)-(s2+s3)
4715 C Derivatives in gamma(i+2)
4716         call transpose2(EUgder(1,1,i+3),e3tder(1,1))
4717         call matvec2(e1a(1,1),Ub2der(1,i+3),auxvec(1))
4718         s1=scalar2(b1(1,i+2),auxvec(1))
4719         call matmat2(a_temp(1,1),e3tder(1,1),auxmat(1,1))
4720         call matvec2(auxmat(1,1),Ub2(1,i+2),auxvec(1))
4721         s2=scalar2(b1(1,i+1),auxvec(1))
4722         call matmat2(auxmat(1,1),e2t(1,1),auxmat3(1,1))
4723         call matmat2(auxmat3(1,1),e1t(1,1),pizda(1,1))
4724         s3=0.5d0*(pizda(1,1)+pizda(2,2))
4725         gel_loc_turn4(i+2)=gel_loc_turn4(i+2)-(s1+s2+s3)
4726 C Cartesian derivatives
4727 C Derivatives of this turn contributions in DC(i+2)
4728         if (j.lt.nres-1) then
4729           do l=1,3
4730             a_temp(1,1)=agg(l,1)
4731             a_temp(1,2)=agg(l,2)
4732             a_temp(2,1)=agg(l,3)
4733             a_temp(2,2)=agg(l,4)
4734             call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4735             call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4736             s1=scalar2(b1(1,i+2),auxvec(1))
4737             call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4738             call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4739             s2=scalar2(b1(1,i+1),auxvec(1))
4740             call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4741             call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4742             s3=0.5d0*(pizda(1,1)+pizda(2,2))
4743             ggg(l)=-(s1+s2+s3)
4744             gcorr4_turn(l,i+2)=gcorr4_turn(l,i+2)-(s1+s2+s3)
4745           enddo
4746         endif
4747 C Remaining derivatives of this turn contribution
4748         do l=1,3
4749           a_temp(1,1)=aggi(l,1)
4750           a_temp(1,2)=aggi(l,2)
4751           a_temp(2,1)=aggi(l,3)
4752           a_temp(2,2)=aggi(l,4)
4753           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4754           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4755           s1=scalar2(b1(1,i+2),auxvec(1))
4756           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4757           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4758           s2=scalar2(b1(1,i+1),auxvec(1))
4759           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4760           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4761           s3=0.5d0*(pizda(1,1)+pizda(2,2))
4762           gcorr4_turn(l,i)=gcorr4_turn(l,i)-(s1+s2+s3)
4763           a_temp(1,1)=aggi1(l,1)
4764           a_temp(1,2)=aggi1(l,2)
4765           a_temp(2,1)=aggi1(l,3)
4766           a_temp(2,2)=aggi1(l,4)
4767           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4768           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4769           s1=scalar2(b1(1,i+2),auxvec(1))
4770           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4771           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4772           s2=scalar2(b1(1,i+1),auxvec(1))
4773           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4774           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4775           s3=0.5d0*(pizda(1,1)+pizda(2,2))
4776           gcorr4_turn(l,i+1)=gcorr4_turn(l,i+1)-(s1+s2+s3)
4777           a_temp(1,1)=aggj(l,1)
4778           a_temp(1,2)=aggj(l,2)
4779           a_temp(2,1)=aggj(l,3)
4780           a_temp(2,2)=aggj(l,4)
4781           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4782           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4783           s1=scalar2(b1(1,i+2),auxvec(1))
4784           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4785           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4786           s2=scalar2(b1(1,i+1),auxvec(1))
4787           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4788           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4789           s3=0.5d0*(pizda(1,1)+pizda(2,2))
4790           gcorr4_turn(l,j)=gcorr4_turn(l,j)-(s1+s2+s3)
4791           a_temp(1,1)=aggj1(l,1)
4792           a_temp(1,2)=aggj1(l,2)
4793           a_temp(2,1)=aggj1(l,3)
4794           a_temp(2,2)=aggj1(l,4)
4795           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4796           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4797           s1=scalar2(b1(1,i+2),auxvec(1))
4798           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4799           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4800           s2=scalar2(b1(1,i+1),auxvec(1))
4801           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4802           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4803           s3=0.5d0*(pizda(1,1)+pizda(2,2))
4804 c          write (iout,*) "s1",s1," s2",s2," s3",s3," s1+s2+s3",s1+s2+s3
4805           gcorr4_turn(l,j1)=gcorr4_turn(l,j1)-(s1+s2+s3)
4806         enddo
4807       return
4808       end
4809 C-----------------------------------------------------------------------------
4810       subroutine vecpr(u,v,w)
4811       implicit real*8(a-h,o-z)
4812       dimension u(3),v(3),w(3)
4813       w(1)=u(2)*v(3)-u(3)*v(2)
4814       w(2)=-u(1)*v(3)+u(3)*v(1)
4815       w(3)=u(1)*v(2)-u(2)*v(1)
4816       return
4817       end
4818 C-----------------------------------------------------------------------------
4819       subroutine unormderiv(u,ugrad,unorm,ungrad)
4820 C This subroutine computes the derivatives of a normalized vector u, given
4821 C the derivatives computed without normalization conditions, ugrad. Returns
4822 C ungrad.
4823       implicit none
4824       double precision u(3),ugrad(3,3),unorm,ungrad(3,3)
4825       double precision vec(3)
4826       double precision scalar
4827       integer i,j
4828 c      write (2,*) 'ugrad',ugrad
4829 c      write (2,*) 'u',u
4830       do i=1,3
4831         vec(i)=scalar(ugrad(1,i),u(1))
4832       enddo
4833 c      write (2,*) 'vec',vec
4834       do i=1,3
4835         do j=1,3
4836           ungrad(j,i)=(ugrad(j,i)-u(j)*vec(i))*unorm
4837         enddo
4838       enddo
4839 c      write (2,*) 'ungrad',ungrad
4840       return
4841       end
4842 C-----------------------------------------------------------------------------
4843       subroutine escp_soft_sphere(evdw2,evdw2_14)
4844 C
4845 C This subroutine calculates the excluded-volume interaction energy between
4846 C peptide-group centers and side chains and its gradient in virtual-bond and
4847 C side-chain vectors.
4848 C
4849       implicit real*8 (a-h,o-z)
4850       include 'DIMENSIONS'
4851       include 'COMMON.GEO'
4852       include 'COMMON.VAR'
4853       include 'COMMON.LOCAL'
4854       include 'COMMON.CHAIN'
4855       include 'COMMON.DERIV'
4856       include 'COMMON.INTERACT'
4857       include 'COMMON.FFIELD'
4858       include 'COMMON.IOUNITS'
4859       include 'COMMON.CONTROL'
4860       dimension ggg(3)
4861       evdw2=0.0D0
4862       evdw2_14=0.0d0
4863       r0_scp=4.5d0
4864 cd    print '(a)','Enter ESCP'
4865 cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
4866 C      do xshift=-1,1
4867 C      do yshift=-1,1
4868 C      do zshift=-1,1
4869       do i=iatscp_s,iatscp_e
4870         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
4871         iteli=itel(i)
4872         xi=0.5D0*(c(1,i)+c(1,i+1))
4873         yi=0.5D0*(c(2,i)+c(2,i+1))
4874         zi=0.5D0*(c(3,i)+c(3,i+1))
4875 C Return atom into box, boxxsize is size of box in x dimension
4876 c  134   continue
4877 c        if (xi.gt.((xshift+0.5d0)*boxxsize)) xi=xi-boxxsize
4878 c        if (xi.lt.((xshift-0.5d0)*boxxsize)) xi=xi+boxxsize
4879 C Condition for being inside the proper box
4880 c        if ((xi.gt.((xshift+0.5d0)*boxxsize)).or.
4881 c     &       (xi.lt.((xshift-0.5d0)*boxxsize))) then
4882 c        go to 134
4883 c        endif
4884 c  135   continue
4885 c        if (yi.gt.((yshift+0.5d0)*boxysize)) yi=yi-boxysize
4886 c        if (yi.lt.((yshift-0.5d0)*boxysize)) yi=yi+boxysize
4887 C Condition for being inside the proper box
4888 c        if ((yi.gt.((yshift+0.5d0)*boxysize)).or.
4889 c     &       (yi.lt.((yshift-0.5d0)*boxysize))) then
4890 c        go to 135
4891 c c       endif
4892 c  136   continue
4893 c        if (zi.gt.((zshift+0.5d0)*boxzsize)) zi=zi-boxzsize
4894 c        if (zi.lt.((zshift-0.5d0)*boxzsize)) zi=zi+boxzsize
4895 cC Condition for being inside the proper box
4896 c        if ((zi.gt.((zshift+0.5d0)*boxzsize)).or.
4897 c     &       (zi.lt.((zshift-0.5d0)*boxzsize))) then
4898 c        go to 136
4899 c        endif
4900           xi=mod(xi,boxxsize)
4901           if (xi.lt.0) xi=xi+boxxsize
4902           yi=mod(yi,boxysize)
4903           if (yi.lt.0) yi=yi+boxysize
4904           zi=mod(zi,boxzsize)
4905           if (zi.lt.0) zi=zi+boxzsize
4906 C          xi=xi+xshift*boxxsize
4907 C          yi=yi+yshift*boxysize
4908 C          zi=zi+zshift*boxzsize
4909         do iint=1,nscp_gr(i)
4910
4911         do j=iscpstart(i,iint),iscpend(i,iint)
4912           if (itype(j).eq.ntyp1) cycle
4913           itypj=iabs(itype(j))
4914 C Uncomment following three lines for SC-p interactions
4915 c         xj=c(1,nres+j)-xi
4916 c         yj=c(2,nres+j)-yi
4917 c         zj=c(3,nres+j)-zi
4918 C Uncomment following three lines for Ca-p interactions
4919           xj=c(1,j)
4920           yj=c(2,j)
4921           zj=c(3,j)
4922 c  174   continue
4923 c        if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
4924 c        if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
4925 C Condition for being inside the proper box
4926 c        if ((xj.gt.((0.5d0)*boxxsize)).or.
4927 c     &       (xj.lt.((-0.5d0)*boxxsize))) then
4928 c        go to 174
4929 c        endif
4930 c  175   continue
4931 c        if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
4932 c        if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
4933 cC Condition for being inside the proper box
4934 c        if ((yj.gt.((0.5d0)*boxysize)).or.
4935 c     &       (yj.lt.((-0.5d0)*boxysize))) then
4936 c        go to 175
4937 c        endif
4938 c  176   continue
4939 c        if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
4940 c        if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
4941 C Condition for being inside the proper box
4942 c        if ((zj.gt.((0.5d0)*boxzsize)).or.
4943 c     &       (zj.lt.((-0.5d0)*boxzsize))) then
4944 c        go to 176
4945           xj=mod(xj,boxxsize)
4946           if (xj.lt.0) xj=xj+boxxsize
4947           yj=mod(yj,boxysize)
4948           if (yj.lt.0) yj=yj+boxysize
4949           zj=mod(zj,boxzsize)
4950           if (zj.lt.0) zj=zj+boxzsize
4951       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
4952       xj_safe=xj
4953       yj_safe=yj
4954       zj_safe=zj
4955       subchap=0
4956       do xshift=-1,1
4957       do yshift=-1,1
4958       do zshift=-1,1
4959           xj=xj_safe+xshift*boxxsize
4960           yj=yj_safe+yshift*boxysize
4961           zj=zj_safe+zshift*boxzsize
4962           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
4963           if(dist_temp.lt.dist_init) then
4964             dist_init=dist_temp
4965             xj_temp=xj
4966             yj_temp=yj
4967             zj_temp=zj
4968             subchap=1
4969           endif
4970        enddo
4971        enddo
4972        enddo
4973        if (subchap.eq.1) then
4974           xj=xj_temp-xi
4975           yj=yj_temp-yi
4976           zj=zj_temp-zi
4977        else
4978           xj=xj_safe-xi
4979           yj=yj_safe-yi
4980           zj=zj_safe-zi
4981        endif
4982 c c       endif
4983 C          xj=xj-xi
4984 C          yj=yj-yi
4985 C          zj=zj-zi
4986           rij=xj*xj+yj*yj+zj*zj
4987
4988           r0ij=r0_scp
4989           r0ijsq=r0ij*r0ij
4990           if (rij.lt.r0ijsq) then
4991             evdwij=0.25d0*(rij-r0ijsq)**2
4992             fac=rij-r0ijsq
4993           else
4994             evdwij=0.0d0
4995             fac=0.0d0
4996           endif
4997           evdw2=evdw2+evdwij
4998 C
4999 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
5000 C
5001           ggg(1)=xj*fac
5002           ggg(2)=yj*fac
5003           ggg(3)=zj*fac
5004 cgrad          if (j.lt.i) then
5005 cd          write (iout,*) 'j<i'
5006 C Uncomment following three lines for SC-p interactions
5007 c           do k=1,3
5008 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
5009 c           enddo
5010 cgrad          else
5011 cd          write (iout,*) 'j>i'
5012 cgrad            do k=1,3
5013 cgrad              ggg(k)=-ggg(k)
5014 C Uncomment following line for SC-p interactions
5015 c             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
5016 cgrad            enddo
5017 cgrad          endif
5018 cgrad          do k=1,3
5019 cgrad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
5020 cgrad          enddo
5021 cgrad          kstart=min0(i+1,j)
5022 cgrad          kend=max0(i-1,j-1)
5023 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
5024 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
5025 cgrad          do k=kstart,kend
5026 cgrad            do l=1,3
5027 cgrad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
5028 cgrad            enddo
5029 cgrad          enddo
5030           do k=1,3
5031             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
5032             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
5033           enddo
5034         enddo
5035
5036         enddo ! iint
5037       enddo ! i
5038 C      enddo !zshift
5039 C      enddo !yshift
5040 C      enddo !xshift
5041       return
5042       end
5043 C-----------------------------------------------------------------------------
5044       subroutine escp(evdw2,evdw2_14)
5045 C
5046 C This subroutine calculates the excluded-volume interaction energy between
5047 C peptide-group centers and side chains and its gradient in virtual-bond and
5048 C side-chain vectors.
5049 C
5050       implicit real*8 (a-h,o-z)
5051       include 'DIMENSIONS'
5052       include 'COMMON.GEO'
5053       include 'COMMON.VAR'
5054       include 'COMMON.LOCAL'
5055       include 'COMMON.CHAIN'
5056       include 'COMMON.DERIV'
5057       include 'COMMON.INTERACT'
5058       include 'COMMON.FFIELD'
5059       include 'COMMON.IOUNITS'
5060       include 'COMMON.CONTROL'
5061       include 'COMMON.SPLITELE'
5062       dimension ggg(3)
5063       evdw2=0.0D0
5064       evdw2_14=0.0d0
5065 c        print *,boxxsize,boxysize,boxzsize,'wymiary pudla'
5066 cd    print '(a)','Enter ESCP'
5067 cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
5068 C      do xshift=-1,1
5069 C      do yshift=-1,1
5070 C      do zshift=-1,1
5071       do i=iatscp_s,iatscp_e
5072         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
5073         iteli=itel(i)
5074         xi=0.5D0*(c(1,i)+c(1,i+1))
5075         yi=0.5D0*(c(2,i)+c(2,i+1))
5076         zi=0.5D0*(c(3,i)+c(3,i+1))
5077           xi=mod(xi,boxxsize)
5078           if (xi.lt.0) xi=xi+boxxsize
5079           yi=mod(yi,boxysize)
5080           if (yi.lt.0) yi=yi+boxysize
5081           zi=mod(zi,boxzsize)
5082           if (zi.lt.0) zi=zi+boxzsize
5083 c          xi=xi+xshift*boxxsize
5084 c          yi=yi+yshift*boxysize
5085 c          zi=zi+zshift*boxzsize
5086 c        print *,xi,yi,zi,'polozenie i'
5087 C Return atom into box, boxxsize is size of box in x dimension
5088 c  134   continue
5089 c        if (xi.gt.((xshift+0.5d0)*boxxsize)) xi=xi-boxxsize
5090 c        if (xi.lt.((xshift-0.5d0)*boxxsize)) xi=xi+boxxsize
5091 C Condition for being inside the proper box
5092 c        if ((xi.gt.((xshift+0.5d0)*boxxsize)).or.
5093 c     &       (xi.lt.((xshift-0.5d0)*boxxsize))) then
5094 c        go to 134
5095 c        endif
5096 c  135   continue
5097 c          print *,xi,boxxsize,"pierwszy"
5098
5099 c        if (yi.gt.((yshift+0.5d0)*boxysize)) yi=yi-boxysize
5100 c        if (yi.lt.((yshift-0.5d0)*boxysize)) yi=yi+boxysize
5101 C Condition for being inside the proper box
5102 c        if ((yi.gt.((yshift+0.5d0)*boxysize)).or.
5103 c     &       (yi.lt.((yshift-0.5d0)*boxysize))) then
5104 c        go to 135
5105 c        endif
5106 c  136   continue
5107 c        if (zi.gt.((zshift+0.5d0)*boxzsize)) zi=zi-boxzsize
5108 c        if (zi.lt.((zshift-0.5d0)*boxzsize)) zi=zi+boxzsize
5109 C Condition for being inside the proper box
5110 c        if ((zi.gt.((zshift+0.5d0)*boxzsize)).or.
5111 c     &       (zi.lt.((zshift-0.5d0)*boxzsize))) then
5112 c        go to 136
5113 c        endif
5114         do iint=1,nscp_gr(i)
5115
5116         do j=iscpstart(i,iint),iscpend(i,iint)
5117           itypj=iabs(itype(j))
5118           if (itypj.eq.ntyp1) cycle
5119 C Uncomment following three lines for SC-p interactions
5120 c         xj=c(1,nres+j)-xi
5121 c         yj=c(2,nres+j)-yi
5122 c         zj=c(3,nres+j)-zi
5123 C Uncomment following three lines for Ca-p interactions
5124           xj=c(1,j)
5125           yj=c(2,j)
5126           zj=c(3,j)
5127           xj=mod(xj,boxxsize)
5128           if (xj.lt.0) xj=xj+boxxsize
5129           yj=mod(yj,boxysize)
5130           if (yj.lt.0) yj=yj+boxysize
5131           zj=mod(zj,boxzsize)
5132           if (zj.lt.0) zj=zj+boxzsize
5133 c  174   continue
5134 c        if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
5135 c        if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
5136 C Condition for being inside the proper box
5137 c        if ((xj.gt.((0.5d0)*boxxsize)).or.
5138 c     &       (xj.lt.((-0.5d0)*boxxsize))) then
5139 c        go to 174
5140 c        endif
5141 c  175   continue
5142 c        if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
5143 c        if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
5144 cC Condition for being inside the proper box
5145 c        if ((yj.gt.((0.5d0)*boxysize)).or.
5146 c     &       (yj.lt.((-0.5d0)*boxysize))) then
5147 c        go to 175
5148 c        endif
5149 c  176   continue
5150 c        if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
5151 c        if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
5152 C Condition for being inside the proper box
5153 c        if ((zj.gt.((0.5d0)*boxzsize)).or.
5154 c     &       (zj.lt.((-0.5d0)*boxzsize))) then
5155 c        go to 176
5156 c        endif
5157 CHERE IS THE CALCULATION WHICH MIRROR IMAGE IS THE CLOSEST ONE
5158       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
5159       xj_safe=xj
5160       yj_safe=yj
5161       zj_safe=zj
5162       subchap=0
5163       do xshift=-1,1
5164       do yshift=-1,1
5165       do zshift=-1,1
5166           xj=xj_safe+xshift*boxxsize
5167           yj=yj_safe+yshift*boxysize
5168           zj=zj_safe+zshift*boxzsize
5169           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
5170           if(dist_temp.lt.dist_init) then
5171             dist_init=dist_temp
5172             xj_temp=xj
5173             yj_temp=yj
5174             zj_temp=zj
5175             subchap=1
5176           endif
5177        enddo
5178        enddo
5179        enddo
5180        if (subchap.eq.1) then
5181           xj=xj_temp-xi
5182           yj=yj_temp-yi
5183           zj=zj_temp-zi
5184        else
5185           xj=xj_safe-xi
5186           yj=yj_safe-yi
5187           zj=zj_safe-zi
5188        endif
5189 c          print *,xj,yj,zj,'polozenie j'
5190           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
5191 c          print *,rrij
5192           sss=sscale(1.0d0/(dsqrt(rrij)))
5193 c          print *,r_cut,1.0d0/dsqrt(rrij),sss,'tu patrz'
5194 c          if (sss.eq.0) print *,'czasem jest OK'
5195           if (sss.le.0.0d0) cycle
5196           sssgrad=sscagrad(1.0d0/(dsqrt(rrij)))
5197           fac=rrij**expon2
5198           e1=fac*fac*aad(itypj,iteli)
5199           e2=fac*bad(itypj,iteli)
5200           if (iabs(j-i) .le. 2) then
5201             e1=scal14*e1
5202             e2=scal14*e2
5203             evdw2_14=evdw2_14+(e1+e2)*sss
5204           endif
5205           evdwij=e1+e2
5206           evdw2=evdw2+evdwij*sss
5207           if (energy_dec) write (iout,'(a6,2i5,0pf7.3,2i3,3e11.3)')
5208      &        'evdw2',i,j,evdwij,iteli,itypj,fac,aad(itypj,iteli),
5209      &       bad(itypj,iteli)
5210 C
5211 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
5212 C
5213           fac=-(evdwij+e1)*rrij*sss
5214           fac=fac+(evdwij)*sssgrad*dsqrt(rrij)/expon
5215           ggg(1)=xj*fac
5216           ggg(2)=yj*fac
5217           ggg(3)=zj*fac
5218 cgrad          if (j.lt.i) then
5219 cd          write (iout,*) 'j<i'
5220 C Uncomment following three lines for SC-p interactions
5221 c           do k=1,3
5222 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
5223 c           enddo
5224 cgrad          else
5225 cd          write (iout,*) 'j>i'
5226 cgrad            do k=1,3
5227 cgrad              ggg(k)=-ggg(k)
5228 C Uncomment following line for SC-p interactions
5229 ccgrad             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
5230 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
5231 cgrad            enddo
5232 cgrad          endif
5233 cgrad          do k=1,3
5234 cgrad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
5235 cgrad          enddo
5236 cgrad          kstart=min0(i+1,j)
5237 cgrad          kend=max0(i-1,j-1)
5238 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
5239 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
5240 cgrad          do k=kstart,kend
5241 cgrad            do l=1,3
5242 cgrad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
5243 cgrad            enddo
5244 cgrad          enddo
5245           do k=1,3
5246             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
5247             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
5248           enddo
5249 c        endif !endif for sscale cutoff
5250         enddo ! j
5251
5252         enddo ! iint
5253       enddo ! i
5254 c      enddo !zshift
5255 c      enddo !yshift
5256 c      enddo !xshift
5257       do i=1,nct
5258         do j=1,3
5259           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
5260           gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
5261           gradx_scp(j,i)=expon*gradx_scp(j,i)
5262         enddo
5263       enddo
5264 C******************************************************************************
5265 C
5266 C                              N O T E !!!
5267 C
5268 C To save time the factor EXPON has been extracted from ALL components
5269 C of GVDWC and GRADX. Remember to multiply them by this factor before further
5270 C use!
5271 C
5272 C******************************************************************************
5273       return
5274       end
5275 C--------------------------------------------------------------------------
5276       subroutine edis(ehpb)
5277 C
5278 C Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors.
5279 C
5280       implicit real*8 (a-h,o-z)
5281       include 'DIMENSIONS'
5282       include 'COMMON.SBRIDGE'
5283       include 'COMMON.CHAIN'
5284       include 'COMMON.DERIV'
5285       include 'COMMON.VAR'
5286       include 'COMMON.INTERACT'
5287       include 'COMMON.IOUNITS'
5288       include 'COMMON.CONTROL'
5289       dimension ggg(3)
5290       ehpb=0.0D0
5291       do i=1,3
5292        ggg(i)=0.0d0
5293       enddo
5294 C      write (iout,*) ,"link_end",link_end,constr_dist
5295 cd      write(iout,*)'edis: nhpb=',nhpb,' fbr=',fbr
5296 cd      write(iout,*)'link_start=',link_start,' link_end=',link_end
5297       if (link_end.eq.0) return
5298       do i=link_start,link_end
5299 C If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a
5300 C CA-CA distance used in regularization of structure.
5301         ii=ihpb(i)
5302         jj=jhpb(i)
5303 C iii and jjj point to the residues for which the distance is assigned.
5304         if (ii.gt.nres) then
5305           iii=ii-nres
5306           jjj=jj-nres
5307         else
5308           iii=ii
5309           jjj=jj
5310         endif
5311 c        write (iout,*) "i",i," ii",ii," iii",iii," jj",jj," jjj",jjj,
5312 c     &    dhpb(i),dhpb1(i),forcon(i)
5313 C 24/11/03 AL: SS bridges handled separately because of introducing a specific
5314 C    distance and angle dependent SS bond potential.
5315 C        if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and.
5316 C     & iabs(itype(jjj)).eq.1) then
5317 cmc        if (ii.gt.nres .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then
5318 C 18/07/06 MC: Use the convention that the first nss pairs are SS bonds
5319         if (.not.dyn_ss .and. i.le.nss) then
5320 C 15/02/13 CC dynamic SSbond - additional check
5321          if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and.
5322      & iabs(itype(jjj)).eq.1) then
5323           call ssbond_ene(iii,jjj,eij)
5324           ehpb=ehpb+2*eij
5325          endif
5326 cd          write (iout,*) "eij",eij
5327 cd   &   ' waga=',waga,' fac=',fac
5328         else if (ii.gt.nres .and. jj.gt.nres) then
5329 c Restraints from contact prediction
5330           dd=dist(ii,jj)
5331           if (constr_dist.eq.11) then
5332             ehpb=ehpb+fordepth(i)**4.0d0
5333      &          *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i))
5334             fac=fordepth(i)**4.0d0
5335      &          *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd
5336           if (energy_dec) write (iout,'(a6,2i5,3f8.3)') "edisl",ii,jj,
5337      &    ehpb,fordepth(i),dd
5338            else
5339           if (dhpb1(i).gt.0.0d0) then
5340             ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
5341             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
5342 c            write (iout,*) "beta nmr",
5343 c     &        dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
5344           else
5345             dd=dist(ii,jj)
5346             rdis=dd-dhpb(i)
5347 C Get the force constant corresponding to this distance.
5348             waga=forcon(i)
5349 C Calculate the contribution to energy.
5350             ehpb=ehpb+waga*rdis*rdis
5351 c            write (iout,*) "beta reg",dd,waga*rdis*rdis
5352 C
5353 C Evaluate gradient.
5354 C
5355             fac=waga*rdis/dd
5356           endif
5357           endif
5358           do j=1,3
5359             ggg(j)=fac*(c(j,jj)-c(j,ii))
5360           enddo
5361           do j=1,3
5362             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
5363             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
5364           enddo
5365           do k=1,3
5366             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
5367             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
5368           enddo
5369         else
5370 C Calculate the distance between the two points and its difference from the
5371 C target distance.
5372           dd=dist(ii,jj)
5373           if (constr_dist.eq.11) then
5374             ehpb=ehpb+fordepth(i)**4.0d0
5375      &           *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i))
5376             fac=fordepth(i)**4.0d0
5377      &           *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd
5378           if (energy_dec) write (iout,'(a6,2i5,3f8.3)') "edisl",ii,jj,
5379      &    ehpb,fordepth(i),dd
5380            else
5381           if (dhpb1(i).gt.0.0d0) then
5382             ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
5383             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
5384 c            write (iout,*) "alph nmr",
5385 c     &        dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
5386           else
5387             rdis=dd-dhpb(i)
5388 C Get the force constant corresponding to this distance.
5389             waga=forcon(i)
5390 C Calculate the contribution to energy.
5391             ehpb=ehpb+waga*rdis*rdis
5392 c            write (iout,*) "alpha reg",dd,waga*rdis*rdis
5393 C
5394 C Evaluate gradient.
5395 C
5396             fac=waga*rdis/dd
5397           endif
5398           endif
5399             do j=1,3
5400               ggg(j)=fac*(c(j,jj)-c(j,ii))
5401             enddo
5402 cd      print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
5403 C If this is a SC-SC distance, we need to calculate the contributions to the
5404 C Cartesian gradient in the SC vectors (ghpbx).
5405           if (iii.lt.ii) then
5406           do j=1,3
5407             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
5408             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
5409           enddo
5410           endif
5411 cgrad        do j=iii,jjj-1
5412 cgrad          do k=1,3
5413 cgrad            ghpbc(k,j)=ghpbc(k,j)+ggg(k)
5414 cgrad          enddo
5415 cgrad        enddo
5416           do k=1,3
5417             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
5418             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
5419           enddo
5420         endif
5421       enddo
5422       if (constr_dist.ne.11) ehpb=0.5D0*ehpb
5423       return
5424       end
5425 C--------------------------------------------------------------------------
5426       subroutine ssbond_ene(i,j,eij)
5427 C
5428 C Calculate the distance and angle dependent SS-bond potential energy
5429 C using a free-energy function derived based on RHF/6-31G** ab initio
5430 C calculations of diethyl disulfide.
5431 C
5432 C A. Liwo and U. Kozlowska, 11/24/03
5433 C
5434       implicit real*8 (a-h,o-z)
5435       include 'DIMENSIONS'
5436       include 'COMMON.SBRIDGE'
5437       include 'COMMON.CHAIN'
5438       include 'COMMON.DERIV'
5439       include 'COMMON.LOCAL'
5440       include 'COMMON.INTERACT'
5441       include 'COMMON.VAR'
5442       include 'COMMON.IOUNITS'
5443       double precision erij(3),dcosom1(3),dcosom2(3),gg(3)
5444       itypi=iabs(itype(i))
5445       xi=c(1,nres+i)
5446       yi=c(2,nres+i)
5447       zi=c(3,nres+i)
5448       dxi=dc_norm(1,nres+i)
5449       dyi=dc_norm(2,nres+i)
5450       dzi=dc_norm(3,nres+i)
5451 c      dsci_inv=dsc_inv(itypi)
5452       dsci_inv=vbld_inv(nres+i)
5453       itypj=iabs(itype(j))
5454 c      dscj_inv=dsc_inv(itypj)
5455       dscj_inv=vbld_inv(nres+j)
5456       xj=c(1,nres+j)-xi
5457       yj=c(2,nres+j)-yi
5458       zj=c(3,nres+j)-zi
5459       dxj=dc_norm(1,nres+j)
5460       dyj=dc_norm(2,nres+j)
5461       dzj=dc_norm(3,nres+j)
5462       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
5463       rij=dsqrt(rrij)
5464       erij(1)=xj*rij
5465       erij(2)=yj*rij
5466       erij(3)=zj*rij
5467       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
5468       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
5469       om12=dxi*dxj+dyi*dyj+dzi*dzj
5470       do k=1,3
5471         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
5472         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
5473       enddo
5474       rij=1.0d0/rij
5475       deltad=rij-d0cm
5476       deltat1=1.0d0-om1
5477       deltat2=1.0d0+om2
5478       deltat12=om2-om1+2.0d0
5479       cosphi=om12-om1*om2
5480       eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2)
5481      &  +akct*deltad*deltat12
5482      &  +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi+ebr
5483 c      write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth,
5484 c     &  " akct",akct," deltad",deltad," deltat",deltat1,deltat2,
5485 c     &  " deltat12",deltat12," eij",eij
5486       ed=2*akcm*deltad+akct*deltat12
5487       pom1=akct*deltad
5488       pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
5489       eom1=-2*akth*deltat1-pom1-om2*pom2
5490       eom2= 2*akth*deltat2+pom1-om1*pom2
5491       eom12=pom2
5492       do k=1,3
5493         ggk=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
5494         ghpbx(k,i)=ghpbx(k,i)-ggk
5495      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
5496      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
5497         ghpbx(k,j)=ghpbx(k,j)+ggk
5498      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
5499      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
5500         ghpbc(k,i)=ghpbc(k,i)-ggk
5501         ghpbc(k,j)=ghpbc(k,j)+ggk
5502       enddo
5503 C
5504 C Calculate the components of the gradient in DC and X
5505 C
5506 cgrad      do k=i,j-1
5507 cgrad        do l=1,3
5508 cgrad          ghpbc(l,k)=ghpbc(l,k)+gg(l)
5509 cgrad        enddo
5510 cgrad      enddo
5511       return
5512       end
5513 C--------------------------------------------------------------------------
5514       subroutine ebond(estr)
5515 c
5516 c Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
5517 c
5518       implicit real*8 (a-h,o-z)
5519       include 'DIMENSIONS'
5520       include 'COMMON.LOCAL'
5521       include 'COMMON.GEO'
5522       include 'COMMON.INTERACT'
5523       include 'COMMON.DERIV'
5524       include 'COMMON.VAR'
5525       include 'COMMON.CHAIN'
5526       include 'COMMON.IOUNITS'
5527       include 'COMMON.NAMES'
5528       include 'COMMON.FFIELD'
5529       include 'COMMON.CONTROL'
5530       include 'COMMON.SETUP'
5531       double precision u(3),ud(3)
5532       estr=0.0d0
5533       estr1=0.0d0
5534       do i=ibondp_start,ibondp_end
5535         if (itype(i-1).eq.ntyp1 .and. itype(i).eq.ntyp1) cycle
5536 c          estr1=estr1+gnmr1(vbld(i),-1.0d0,distchainmax)
5537 c          do j=1,3
5538 c          gradb(j,i-1)=gnmr1prim(vbld(i),-1.0d0,distchainmax)
5539 c     &      *dc(j,i-1)/vbld(i)
5540 c          enddo
5541 c          if (energy_dec) write(iout,*)
5542 c     &       "estr1",i,gnmr1(vbld(i),-1.0d0,distchainmax)
5543 c        else
5544 C       Checking if it involves dummy (NH3+ or COO-) group
5545          if (itype(i-1).eq.ntyp1 .or. itype(i).eq.ntyp1) then
5546 C YES   vbldpDUM is the equlibrium length of spring for Dummy atom
5547         diff = vbld(i)-vbldpDUM
5548          else
5549 C NO    vbldp0 is the equlibrium lenght of spring for peptide group
5550         diff = vbld(i)-vbldp0
5551          endif
5552         if (energy_dec)    write (iout,'(a7,i5,4f7.3)')
5553      &     "estr bb",i,vbld(i),vbldp0,diff,AKP*diff*diff
5554         estr=estr+diff*diff
5555         do j=1,3
5556           gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)
5557         enddo
5558 c        write (iout,'(i5,3f10.5)') i,(gradb(j,i-1),j=1,3)
5559 c        endif
5560       enddo
5561       estr=0.5d0*AKP*estr+estr1
5562 c
5563 c 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included
5564 c
5565       do i=ibond_start,ibond_end
5566         iti=iabs(itype(i))
5567         if (iti.ne.10 .and. iti.ne.ntyp1) then
5568           nbi=nbondterm(iti)
5569           if (nbi.eq.1) then
5570             diff=vbld(i+nres)-vbldsc0(1,iti)
5571             if (energy_dec)  write (iout,*)
5572      &      "estr sc",i,iti,vbld(i+nres),vbldsc0(1,iti),diff,
5573      &      AKSC(1,iti),AKSC(1,iti)*diff*diff
5574             estr=estr+0.5d0*AKSC(1,iti)*diff*diff
5575             do j=1,3
5576               gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
5577             enddo
5578           else
5579             do j=1,nbi
5580               diff=vbld(i+nres)-vbldsc0(j,iti)
5581               ud(j)=aksc(j,iti)*diff
5582               u(j)=abond0(j,iti)+0.5d0*ud(j)*diff
5583             enddo
5584             uprod=u(1)
5585             do j=2,nbi
5586               uprod=uprod*u(j)
5587             enddo
5588             usum=0.0d0
5589             usumsqder=0.0d0
5590             do j=1,nbi
5591               uprod1=1.0d0
5592               uprod2=1.0d0
5593               do k=1,nbi
5594                 if (k.ne.j) then
5595                   uprod1=uprod1*u(k)
5596                   uprod2=uprod2*u(k)*u(k)
5597                 endif
5598               enddo
5599               usum=usum+uprod1
5600               usumsqder=usumsqder+ud(j)*uprod2
5601             enddo
5602             estr=estr+uprod/usum
5603             do j=1,3
5604              gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
5605             enddo
5606           endif
5607         endif
5608       enddo
5609       return
5610       end
5611 #ifdef CRYST_THETA
5612 C--------------------------------------------------------------------------
5613       subroutine ebend(etheta,ethetacnstr)
5614 C
5615 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
5616 C angles gamma and its derivatives in consecutive thetas and gammas.
5617 C
5618       implicit real*8 (a-h,o-z)
5619       include 'DIMENSIONS'
5620       include 'COMMON.LOCAL'
5621       include 'COMMON.GEO'
5622       include 'COMMON.INTERACT'
5623       include 'COMMON.DERIV'
5624       include 'COMMON.VAR'
5625       include 'COMMON.CHAIN'
5626       include 'COMMON.IOUNITS'
5627       include 'COMMON.NAMES'
5628       include 'COMMON.FFIELD'
5629       include 'COMMON.CONTROL'
5630       include 'COMMON.TORCNSTR'
5631       common /calcthet/ term1,term2,termm,diffak,ratak,
5632      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
5633      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
5634       double precision y(2),z(2)
5635       delta=0.02d0*pi
5636 c      time11=dexp(-2*time)
5637 c      time12=1.0d0
5638       etheta=0.0D0
5639 c     write (*,'(a,i2)') 'EBEND ICG=',icg
5640       do i=ithet_start,ithet_end
5641         if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
5642      &  .or.itype(i).eq.ntyp1) cycle
5643 C Zero the energy function and its derivative at 0 or pi.
5644         call splinthet(theta(i),0.5d0*delta,ss,ssd)
5645         it=itype(i-1)
5646         ichir1=isign(1,itype(i-2))
5647         ichir2=isign(1,itype(i))
5648          if (itype(i-2).eq.10) ichir1=isign(1,itype(i-1))
5649          if (itype(i).eq.10) ichir2=isign(1,itype(i-1))
5650          if (itype(i-1).eq.10) then
5651           itype1=isign(10,itype(i-2))
5652           ichir11=isign(1,itype(i-2))
5653           ichir12=isign(1,itype(i-2))
5654           itype2=isign(10,itype(i))
5655           ichir21=isign(1,itype(i))
5656           ichir22=isign(1,itype(i))
5657          endif
5658
5659         if (i.gt.3 .and. itype(i-3).ne.ntyp1) then
5660 #ifdef OSF
5661           phii=phi(i)
5662           if (phii.ne.phii) phii=150.0
5663 #else
5664           phii=phi(i)
5665 #endif
5666           y(1)=dcos(phii)
5667           y(2)=dsin(phii)
5668         else
5669           y(1)=0.0D0
5670           y(2)=0.0D0
5671         endif
5672         if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
5673 #ifdef OSF
5674           phii1=phi(i+1)
5675           if (phii1.ne.phii1) phii1=150.0
5676           phii1=pinorm(phii1)
5677           z(1)=cos(phii1)
5678 #else
5679           phii1=phi(i+1)
5680 #endif
5681           z(1)=dcos(phii1)
5682           z(2)=dsin(phii1)
5683         else
5684           z(1)=0.0D0
5685           z(2)=0.0D0
5686         endif
5687 C Calculate the "mean" value of theta from the part of the distribution
5688 C dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2).
5689 C In following comments this theta will be referred to as t_c.
5690         thet_pred_mean=0.0d0
5691         do k=1,2
5692             athetk=athet(k,it,ichir1,ichir2)
5693             bthetk=bthet(k,it,ichir1,ichir2)
5694           if (it.eq.10) then
5695              athetk=athet(k,itype1,ichir11,ichir12)
5696              bthetk=bthet(k,itype2,ichir21,ichir22)
5697           endif
5698          thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k)
5699 c         write(iout,*) 'chuj tu', y(k),z(k)
5700         enddo
5701         dthett=thet_pred_mean*ssd
5702         thet_pred_mean=thet_pred_mean*ss+a0thet(it)
5703 C Derivatives of the "mean" values in gamma1 and gamma2.
5704         dthetg1=(-athet(1,it,ichir1,ichir2)*y(2)
5705      &+athet(2,it,ichir1,ichir2)*y(1))*ss
5706          dthetg2=(-bthet(1,it,ichir1,ichir2)*z(2)
5707      &          +bthet(2,it,ichir1,ichir2)*z(1))*ss
5708          if (it.eq.10) then
5709       dthetg1=(-athet(1,itype1,ichir11,ichir12)*y(2)
5710      &+athet(2,itype1,ichir11,ichir12)*y(1))*ss
5711         dthetg2=(-bthet(1,itype2,ichir21,ichir22)*z(2)
5712      &         +bthet(2,itype2,ichir21,ichir22)*z(1))*ss
5713          endif
5714         if (theta(i).gt.pi-delta) then
5715           call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,
5716      &         E_tc0)
5717           call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0)
5718           call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
5719           call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,
5720      &        E_theta)
5721           call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,
5722      &        E_tc)
5723         else if (theta(i).lt.delta) then
5724           call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0)
5725           call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
5726           call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,
5727      &        E_theta)
5728           call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0)
5729           call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,
5730      &        E_tc)
5731         else
5732           call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,
5733      &        E_theta,E_tc)
5734         endif
5735         etheta=etheta+ethetai
5736         if (energy_dec) write (iout,'(a6,i5,0pf7.3,f7.3,i5)')
5737      &      'ebend',i,ethetai,theta(i),itype(i)
5738         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1
5739         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2
5740         gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)+gloc(nphi+i-2,icg)
5741       enddo
5742       ethetacnstr=0.0d0
5743 C      print *,ithetaconstr_start,ithetaconstr_end,"TU"
5744       do i=ithetaconstr_start,ithetaconstr_end
5745         itheta=itheta_constr(i)
5746         thetiii=theta(itheta)
5747         difi=pinorm(thetiii-theta_constr0(i))
5748         if (difi.gt.theta_drange(i)) then
5749           difi=difi-theta_drange(i)
5750           ethetacnstr=ethetcnstr+0.25d0*for_thet_constr(i)*difi**4
5751           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
5752      &    +for_thet_constr(i)*difi**3
5753         else if (difi.lt.-drange(i)) then
5754           difi=difi+drange(i)
5755           ethetacnstr=ethetcnstr+0.25d0*for_thet_constr(i)*difi**4
5756           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
5757      &    +for_thet_constr(i)*difi**3
5758         else
5759           difi=0.0
5760         endif
5761        if (energy_dec) then
5762         write (iout,'(a6,2i5,4f8.3,2e14.5)') "ethetc",
5763      &    i,itheta,rad2deg*thetiii,
5764      &    rad2deg*theta_constr0(i),  rad2deg*theta_drange(i),
5765      &    rad2deg*difi,0.25d0*for_thet_constr(i)*difi**4,
5766      &    gloc(itheta+nphi-2,icg)
5767         endif
5768       enddo
5769
5770 C Ufff.... We've done all this!!!
5771       return
5772       end
5773 C---------------------------------------------------------------------------
5774       subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,
5775      &     E_tc)
5776       implicit real*8 (a-h,o-z)
5777       include 'DIMENSIONS'
5778       include 'COMMON.LOCAL'
5779       include 'COMMON.IOUNITS'
5780       common /calcthet/ term1,term2,termm,diffak,ratak,
5781      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
5782      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
5783 C Calculate the contributions to both Gaussian lobes.
5784 C 6/6/97 - Deform the Gaussians using the factor of 1/(1+time)
5785 C The "polynomial part" of the "standard deviation" of this part of
5786 C the distributioni.
5787 ccc        write (iout,*) thetai,thet_pred_mean
5788         sig=polthet(3,it)
5789         do j=2,0,-1
5790           sig=sig*thet_pred_mean+polthet(j,it)
5791         enddo
5792 C Derivative of the "interior part" of the "standard deviation of the"
5793 C gamma-dependent Gaussian lobe in t_c.
5794         sigtc=3*polthet(3,it)
5795         do j=2,1,-1
5796           sigtc=sigtc*thet_pred_mean+j*polthet(j,it)
5797         enddo
5798         sigtc=sig*sigtc
5799 C Set the parameters of both Gaussian lobes of the distribution.
5800 C "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc)
5801         fac=sig*sig+sigc0(it)
5802         sigcsq=fac+fac
5803         sigc=1.0D0/sigcsq
5804 C Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c
5805         sigsqtc=-4.0D0*sigcsq*sigtc
5806 c       print *,i,sig,sigtc,sigsqtc
5807 C Following variable (sigtc) is d[sigma(t_c)]/dt_c
5808         sigtc=-sigtc/(fac*fac)
5809 C Following variable is sigma(t_c)**(-2)
5810         sigcsq=sigcsq*sigcsq
5811         sig0i=sig0(it)
5812         sig0inv=1.0D0/sig0i**2
5813         delthec=thetai-thet_pred_mean
5814         delthe0=thetai-theta0i
5815         term1=-0.5D0*sigcsq*delthec*delthec
5816         term2=-0.5D0*sig0inv*delthe0*delthe0
5817 C        write (iout,*)'term1',term1,term2,sigcsq,delthec,sig0inv,delthe0
5818 C Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and
5819 C NaNs in taking the logarithm. We extract the largest exponent which is added
5820 C to the energy (this being the log of the distribution) at the end of energy
5821 C term evaluation for this virtual-bond angle.
5822         if (term1.gt.term2) then
5823           termm=term1
5824           term2=dexp(term2-termm)
5825           term1=1.0d0
5826         else
5827           termm=term2
5828           term1=dexp(term1-termm)
5829           term2=1.0d0
5830         endif
5831 C The ratio between the gamma-independent and gamma-dependent lobes of
5832 C the distribution is a Gaussian function of thet_pred_mean too.
5833         diffak=gthet(2,it)-thet_pred_mean
5834         ratak=diffak/gthet(3,it)**2
5835         ak=dexp(gthet(1,it)-0.5D0*diffak*ratak)
5836 C Let's differentiate it in thet_pred_mean NOW.
5837         aktc=ak*ratak
5838 C Now put together the distribution terms to make complete distribution.
5839         termexp=term1+ak*term2
5840         termpre=sigc+ak*sig0i
5841 C Contribution of the bending energy from this theta is just the -log of
5842 C the sum of the contributions from the two lobes and the pre-exponential
5843 C factor. Simple enough, isn't it?
5844         ethetai=(-dlog(termexp)-termm+dlog(termpre))
5845 C       write (iout,*) 'termexp',termexp,termm,termpre,i
5846 C NOW the derivatives!!!
5847 C 6/6/97 Take into account the deformation.
5848         E_theta=(delthec*sigcsq*term1
5849      &       +ak*delthe0*sig0inv*term2)/termexp
5850         E_tc=((sigtc+aktc*sig0i)/termpre
5851      &      -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+
5852      &       aktc*term2)/termexp)
5853       return
5854       end
5855 c-----------------------------------------------------------------------------
5856       subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)
5857       implicit real*8 (a-h,o-z)
5858       include 'DIMENSIONS'
5859       include 'COMMON.LOCAL'
5860       include 'COMMON.IOUNITS'
5861       common /calcthet/ term1,term2,termm,diffak,ratak,
5862      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
5863      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
5864       delthec=thetai-thet_pred_mean
5865       delthe0=thetai-theta0i
5866 C "Thank you" to MAPLE (probably spared one day of hand-differentiation).
5867       t3 = thetai-thet_pred_mean
5868       t6 = t3**2
5869       t9 = term1
5870       t12 = t3*sigcsq
5871       t14 = t12+t6*sigsqtc
5872       t16 = 1.0d0
5873       t21 = thetai-theta0i
5874       t23 = t21**2
5875       t26 = term2
5876       t27 = t21*t26
5877       t32 = termexp
5878       t40 = t32**2
5879       E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9
5880      & -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40
5881      & *(-t12*t9-ak*sig0inv*t27)
5882       return
5883       end
5884 #else
5885 C--------------------------------------------------------------------------
5886       subroutine ebend(etheta,ethetacnstr)
5887 C
5888 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
5889 C angles gamma and its derivatives in consecutive thetas and gammas.
5890 C ab initio-derived potentials from
5891 c Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203
5892 C
5893       implicit real*8 (a-h,o-z)
5894       include 'DIMENSIONS'
5895       include 'COMMON.LOCAL'
5896       include 'COMMON.GEO'
5897       include 'COMMON.INTERACT'
5898       include 'COMMON.DERIV'
5899       include 'COMMON.VAR'
5900       include 'COMMON.CHAIN'
5901       include 'COMMON.IOUNITS'
5902       include 'COMMON.NAMES'
5903       include 'COMMON.FFIELD'
5904       include 'COMMON.CONTROL'
5905       include 'COMMON.TORCNSTR'
5906       double precision coskt(mmaxtheterm),sinkt(mmaxtheterm),
5907      & cosph1(maxsingle),sinph1(maxsingle),cosph2(maxsingle),
5908      & sinph2(maxsingle),cosph1ph2(maxdouble,maxdouble),
5909      & sinph1ph2(maxdouble,maxdouble)
5910       logical lprn /.false./, lprn1 /.false./
5911       etheta=0.0D0
5912       do i=ithet_start,ithet_end
5913 c        print *,i,itype(i-1),itype(i),itype(i-2)
5914         if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
5915      &  .or.itype(i).eq.ntyp1) cycle
5916 C        print *,i,theta(i)
5917         if (iabs(itype(i+1)).eq.20) iblock=2
5918         if (iabs(itype(i+1)).ne.20) iblock=1
5919         dethetai=0.0d0
5920         dephii=0.0d0
5921         dephii1=0.0d0
5922         theti2=0.5d0*theta(i)
5923         ityp2=ithetyp((itype(i-1)))
5924         do k=1,nntheterm
5925           coskt(k)=dcos(k*theti2)
5926           sinkt(k)=dsin(k*theti2)
5927         enddo
5928 C        print *,ethetai
5929         if (i.gt.3 .and. itype(i-3).ne.ntyp1) then
5930 #ifdef OSF
5931           phii=phi(i)
5932           if (phii.ne.phii) phii=150.0
5933 #else
5934           phii=phi(i)
5935 #endif
5936           ityp1=ithetyp((itype(i-2)))
5937 C propagation of chirality for glycine type
5938           do k=1,nsingle
5939             cosph1(k)=dcos(k*phii)
5940             sinph1(k)=dsin(k*phii)
5941           enddo
5942         else
5943           phii=0.0d0
5944           do k=1,nsingle
5945           ityp1=ithetyp((itype(i-2)))
5946             cosph1(k)=0.0d0
5947             sinph1(k)=0.0d0
5948           enddo
5949         endif
5950         if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
5951 #ifdef OSF
5952           phii1=phi(i+1)
5953           if (phii1.ne.phii1) phii1=150.0
5954           phii1=pinorm(phii1)
5955 #else
5956           phii1=phi(i+1)
5957 #endif
5958           ityp3=ithetyp((itype(i)))
5959           do k=1,nsingle
5960             cosph2(k)=dcos(k*phii1)
5961             sinph2(k)=dsin(k*phii1)
5962           enddo
5963         else
5964           phii1=0.0d0
5965           ityp3=ithetyp((itype(i)))
5966           do k=1,nsingle
5967             cosph2(k)=0.0d0
5968             sinph2(k)=0.0d0
5969           enddo
5970         endif
5971         ethetai=aa0thet(ityp1,ityp2,ityp3,iblock)
5972         do k=1,ndouble
5973           do l=1,k-1
5974             ccl=cosph1(l)*cosph2(k-l)
5975             ssl=sinph1(l)*sinph2(k-l)
5976             scl=sinph1(l)*cosph2(k-l)
5977             csl=cosph1(l)*sinph2(k-l)
5978             cosph1ph2(l,k)=ccl-ssl
5979             cosph1ph2(k,l)=ccl+ssl
5980             sinph1ph2(l,k)=scl+csl
5981             sinph1ph2(k,l)=scl-csl
5982           enddo
5983         enddo
5984         if (lprn) then
5985         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,
5986      &    " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
5987         write (iout,*) "coskt and sinkt"
5988         do k=1,nntheterm
5989           write (iout,*) k,coskt(k),sinkt(k)
5990         enddo
5991         endif
5992         do k=1,ntheterm
5993           ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3,iblock)*sinkt(k)
5994           dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3,iblock)
5995      &      *coskt(k)
5996           if (lprn)
5997      &    write (iout,*) "k",k,"
5998      &     aathet",aathet(k,ityp1,ityp2,ityp3,iblock),
5999      &     " ethetai",ethetai
6000         enddo
6001         if (lprn) then
6002         write (iout,*) "cosph and sinph"
6003         do k=1,nsingle
6004           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
6005         enddo
6006         write (iout,*) "cosph1ph2 and sinph2ph2"
6007         do k=2,ndouble
6008           do l=1,k-1
6009             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),
6010      &         sinph1ph2(l,k),sinph1ph2(k,l)
6011           enddo
6012         enddo
6013         write(iout,*) "ethetai",ethetai
6014         endif
6015 C       print *,ethetai
6016         do m=1,ntheterm2
6017           do k=1,nsingle
6018             aux=bbthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)
6019      &         +ccthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k)
6020      &         +ddthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)
6021      &         +eethet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k)
6022             ethetai=ethetai+sinkt(m)*aux
6023             dethetai=dethetai+0.5d0*m*aux*coskt(m)
6024             dephii=dephii+k*sinkt(m)*(
6025      &          ccthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)-
6026      &          bbthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k))
6027             dephii1=dephii1+k*sinkt(m)*(
6028      &          eethet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)-
6029      &          ddthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k))
6030             if (lprn)
6031      &      write (iout,*) "m",m," k",k," bbthet",
6032      &         bbthet(k,m,ityp1,ityp2,ityp3,iblock)," ccthet",
6033      &         ccthet(k,m,ityp1,ityp2,ityp3,iblock)," ddthet",
6034      &         ddthet(k,m,ityp1,ityp2,ityp3,iblock)," eethet",
6035      &         eethet(k,m,ityp1,ityp2,ityp3,iblock)," ethetai",ethetai
6036 C        print *,"tu",cosph1(k),sinph1(k),cosph2(k),sinph2(k)
6037           enddo
6038         enddo
6039 C        print *,"cosph1", (cosph1(k), k=1,nsingle)
6040 C        print *,"cosph2", (cosph2(k), k=1,nsingle)
6041 C        print *,"sinph1", (sinph1(k), k=1,nsingle)
6042 C        print *,"sinph2", (sinph2(k), k=1,nsingle)
6043         if (lprn)
6044      &  write(iout,*) "ethetai",ethetai
6045 C        print *,"tu",cosph1(k),sinph1(k),cosph2(k),sinph2(k)
6046         do m=1,ntheterm3
6047           do k=2,ndouble
6048             do l=1,k-1
6049               aux=ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
6050      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l)+
6051      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
6052      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)
6053               ethetai=ethetai+sinkt(m)*aux
6054               dethetai=dethetai+0.5d0*m*coskt(m)*aux
6055               dephii=dephii+l*sinkt(m)*(
6056      &           -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)-
6057      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
6058      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
6059      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
6060               dephii1=dephii1+(k-l)*sinkt(m)*(
6061      &           -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
6062      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
6063      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)-
6064      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
6065               if (lprn) then
6066               write (iout,*) "m",m," k",k," l",l," ffthet",
6067      &            ffthet(l,k,m,ityp1,ityp2,ityp3,iblock),
6068      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)," ggthet",
6069      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock),
6070      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock),
6071      &            " ethetai",ethetai
6072               write (iout,*) cosph1ph2(l,k)*sinkt(m),
6073      &            cosph1ph2(k,l)*sinkt(m),
6074      &            sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
6075               endif
6076             enddo
6077           enddo
6078         enddo
6079 10      continue
6080 c        lprn1=.true.
6081 C        print *,ethetai
6082         if (lprn1)
6083      &    write (iout,'(i2,3f8.1,9h ethetai ,f10.5)')
6084      &   i,theta(i)*rad2deg,phii*rad2deg,
6085      &   phii1*rad2deg,ethetai
6086 c        lprn1=.false.
6087         etheta=etheta+ethetai
6088         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
6089         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
6090         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)+wang*dethetai
6091       enddo
6092 C now constrains
6093       ethetacnstr=0.0d0
6094 C      print *,ithetaconstr_start,ithetaconstr_end,"TU"
6095       do i=ithetaconstr_start,ithetaconstr_end
6096         itheta=itheta_constr(i)
6097         thetiii=theta(itheta)
6098         difi=pinorm(thetiii-theta_constr0(i))
6099         if (difi.gt.theta_drange(i)) then
6100           difi=difi-theta_drange(i)
6101           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
6102           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
6103      &    +for_thet_constr(i)*difi**3
6104         else if (difi.lt.-drange(i)) then
6105           difi=difi+drange(i)
6106           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
6107           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
6108      &    +for_thet_constr(i)*difi**3
6109         else
6110           difi=0.0
6111         endif
6112        if (energy_dec) then
6113         write (iout,'(a6,2i5,4f8.3,2e14.5)') "ethetc",
6114      &    i,itheta,rad2deg*thetiii,
6115      &    rad2deg*theta_constr0(i),  rad2deg*theta_drange(i),
6116      &    rad2deg*difi,0.25d0*for_thet_constr(i)*difi**4,
6117      &    gloc(itheta+nphi-2,icg)
6118         endif
6119       enddo
6120
6121       return
6122       end
6123 #endif
6124 #ifdef CRYST_SC
6125 c-----------------------------------------------------------------------------
6126       subroutine esc(escloc)
6127 C Calculate the local energy of a side chain and its derivatives in the
6128 C corresponding virtual-bond valence angles THETA and the spherical angles
6129 C ALPHA and OMEGA.
6130       implicit real*8 (a-h,o-z)
6131       include 'DIMENSIONS'
6132       include 'COMMON.GEO'
6133       include 'COMMON.LOCAL'
6134       include 'COMMON.VAR'
6135       include 'COMMON.INTERACT'
6136       include 'COMMON.DERIV'
6137       include 'COMMON.CHAIN'
6138       include 'COMMON.IOUNITS'
6139       include 'COMMON.NAMES'
6140       include 'COMMON.FFIELD'
6141       include 'COMMON.CONTROL'
6142       double precision x(3),dersc(3),xemp(3),dersc0(3),dersc1(3),
6143      &     ddersc0(3),ddummy(3),xtemp(3),temp(3)
6144       common /sccalc/ time11,time12,time112,theti,it,nlobit
6145       delta=0.02d0*pi
6146       escloc=0.0D0
6147 c     write (iout,'(a)') 'ESC'
6148       do i=loc_start,loc_end
6149         it=itype(i)
6150         if (it.eq.ntyp1) cycle
6151         if (it.eq.10) goto 1
6152         nlobit=nlob(iabs(it))
6153 c       print *,'i=',i,' it=',it,' nlobit=',nlobit
6154 c       write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
6155         theti=theta(i+1)-pipol
6156         x(1)=dtan(theti)
6157         x(2)=alph(i)
6158         x(3)=omeg(i)
6159
6160         if (x(2).gt.pi-delta) then
6161           xtemp(1)=x(1)
6162           xtemp(2)=pi-delta
6163           xtemp(3)=x(3)
6164           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
6165           xtemp(2)=pi
6166           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
6167           call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),
6168      &        escloci,dersc(2))
6169           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
6170      &        ddersc0(1),dersc(1))
6171           call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),
6172      &        ddersc0(3),dersc(3))
6173           xtemp(2)=pi-delta
6174           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
6175           xtemp(2)=pi
6176           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
6177           call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,
6178      &            dersc0(2),esclocbi,dersc02)
6179           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
6180      &            dersc12,dersc01)
6181           call splinthet(x(2),0.5d0*delta,ss,ssd)
6182           dersc0(1)=dersc01
6183           dersc0(2)=dersc02
6184           dersc0(3)=0.0d0
6185           do k=1,3
6186             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
6187           enddo
6188           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
6189 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
6190 c    &             esclocbi,ss,ssd
6191           escloci=ss*escloci+(1.0d0-ss)*esclocbi
6192 c         escloci=esclocbi
6193 c         write (iout,*) escloci
6194         else if (x(2).lt.delta) then
6195           xtemp(1)=x(1)
6196           xtemp(2)=delta
6197           xtemp(3)=x(3)
6198           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
6199           xtemp(2)=0.0d0
6200           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
6201           call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),
6202      &        escloci,dersc(2))
6203           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
6204      &        ddersc0(1),dersc(1))
6205           call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),
6206      &        ddersc0(3),dersc(3))
6207           xtemp(2)=delta
6208           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
6209           xtemp(2)=0.0d0
6210           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
6211           call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,
6212      &            dersc0(2),esclocbi,dersc02)
6213           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
6214      &            dersc12,dersc01)
6215           dersc0(1)=dersc01
6216           dersc0(2)=dersc02
6217           dersc0(3)=0.0d0
6218           call splinthet(x(2),0.5d0*delta,ss,ssd)
6219           do k=1,3
6220             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
6221           enddo
6222           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
6223 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
6224 c    &             esclocbi,ss,ssd
6225           escloci=ss*escloci+(1.0d0-ss)*esclocbi
6226 c         write (iout,*) escloci
6227         else
6228           call enesc(x,escloci,dersc,ddummy,.false.)
6229         endif
6230
6231         escloc=escloc+escloci
6232         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
6233      &     'escloc',i,escloci
6234 c       write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
6235
6236         gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
6237      &   wscloc*dersc(1)
6238         gloc(ialph(i,1),icg)=wscloc*dersc(2)
6239         gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
6240     1   continue
6241       enddo
6242       return
6243       end
6244 C---------------------------------------------------------------------------
6245       subroutine enesc(x,escloci,dersc,ddersc,mixed)
6246       implicit real*8 (a-h,o-z)
6247       include 'DIMENSIONS'
6248       include 'COMMON.GEO'
6249       include 'COMMON.LOCAL'
6250       include 'COMMON.IOUNITS'
6251       common /sccalc/ time11,time12,time112,theti,it,nlobit
6252       double precision x(3),z(3),Ax(3,maxlob,-1:1),dersc(3),ddersc(3)
6253       double precision contr(maxlob,-1:1)
6254       logical mixed
6255 c       write (iout,*) 'it=',it,' nlobit=',nlobit
6256         escloc_i=0.0D0
6257         do j=1,3
6258           dersc(j)=0.0D0
6259           if (mixed) ddersc(j)=0.0d0
6260         enddo
6261         x3=x(3)
6262
6263 C Because of periodicity of the dependence of the SC energy in omega we have
6264 C to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
6265 C To avoid underflows, first compute & store the exponents.
6266
6267         do iii=-1,1
6268
6269           x(3)=x3+iii*dwapi
6270
6271           do j=1,nlobit
6272             do k=1,3
6273               z(k)=x(k)-censc(k,j,it)
6274             enddo
6275             do k=1,3
6276               Axk=0.0D0
6277               do l=1,3
6278                 Axk=Axk+gaussc(l,k,j,it)*z(l)
6279               enddo
6280               Ax(k,j,iii)=Axk
6281             enddo
6282             expfac=0.0D0
6283             do k=1,3
6284               expfac=expfac+Ax(k,j,iii)*z(k)
6285             enddo
6286             contr(j,iii)=expfac
6287           enddo ! j
6288
6289         enddo ! iii
6290
6291         x(3)=x3
6292 C As in the case of ebend, we want to avoid underflows in exponentiation and
6293 C subsequent NaNs and INFs in energy calculation.
6294 C Find the largest exponent
6295         emin=contr(1,-1)
6296         do iii=-1,1
6297           do j=1,nlobit
6298             if (emin.gt.contr(j,iii)) emin=contr(j,iii)
6299           enddo
6300         enddo
6301         emin=0.5D0*emin
6302 cd      print *,'it=',it,' emin=',emin
6303
6304 C Compute the contribution to SC energy and derivatives
6305         do iii=-1,1
6306
6307           do j=1,nlobit
6308 #ifdef OSF
6309             adexp=bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin
6310             if(adexp.ne.adexp) adexp=1.0
6311             expfac=dexp(adexp)
6312 #else
6313             expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin)
6314 #endif
6315 cd          print *,'j=',j,' expfac=',expfac
6316             escloc_i=escloc_i+expfac
6317             do k=1,3
6318               dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
6319             enddo
6320             if (mixed) then
6321               do k=1,3,2
6322                 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii)
6323      &            +gaussc(k,2,j,it))*expfac
6324               enddo
6325             endif
6326           enddo
6327
6328         enddo ! iii
6329
6330         dersc(1)=dersc(1)/cos(theti)**2
6331         ddersc(1)=ddersc(1)/cos(theti)**2
6332         ddersc(3)=ddersc(3)
6333
6334         escloci=-(dlog(escloc_i)-emin)
6335         do j=1,3
6336           dersc(j)=dersc(j)/escloc_i
6337         enddo
6338         if (mixed) then
6339           do j=1,3,2
6340             ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
6341           enddo
6342         endif
6343       return
6344       end
6345 C------------------------------------------------------------------------------
6346       subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
6347       implicit real*8 (a-h,o-z)
6348       include 'DIMENSIONS'
6349       include 'COMMON.GEO'
6350       include 'COMMON.LOCAL'
6351       include 'COMMON.IOUNITS'
6352       common /sccalc/ time11,time12,time112,theti,it,nlobit
6353       double precision x(3),z(3),Ax(3,maxlob),dersc(3)
6354       double precision contr(maxlob)
6355       logical mixed
6356
6357       escloc_i=0.0D0
6358
6359       do j=1,3
6360         dersc(j)=0.0D0
6361       enddo
6362
6363       do j=1,nlobit
6364         do k=1,2
6365           z(k)=x(k)-censc(k,j,it)
6366         enddo
6367         z(3)=dwapi
6368         do k=1,3
6369           Axk=0.0D0
6370           do l=1,3
6371             Axk=Axk+gaussc(l,k,j,it)*z(l)
6372           enddo
6373           Ax(k,j)=Axk
6374         enddo
6375         expfac=0.0D0
6376         do k=1,3
6377           expfac=expfac+Ax(k,j)*z(k)
6378         enddo
6379         contr(j)=expfac
6380       enddo ! j
6381
6382 C As in the case of ebend, we want to avoid underflows in exponentiation and
6383 C subsequent NaNs and INFs in energy calculation.
6384 C Find the largest exponent
6385       emin=contr(1)
6386       do j=1,nlobit
6387         if (emin.gt.contr(j)) emin=contr(j)
6388       enddo
6389       emin=0.5D0*emin
6390
6391 C Compute the contribution to SC energy and derivatives
6392
6393       dersc12=0.0d0
6394       do j=1,nlobit
6395         expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j)+emin)
6396         escloc_i=escloc_i+expfac
6397         do k=1,2
6398           dersc(k)=dersc(k)+Ax(k,j)*expfac
6399         enddo
6400         if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j)
6401      &            +gaussc(1,2,j,it))*expfac
6402         dersc(3)=0.0d0
6403       enddo
6404
6405       dersc(1)=dersc(1)/cos(theti)**2
6406       dersc12=dersc12/cos(theti)**2
6407       escloci=-(dlog(escloc_i)-emin)
6408       do j=1,2
6409         dersc(j)=dersc(j)/escloc_i
6410       enddo
6411       if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
6412       return
6413       end
6414 #else
6415 c----------------------------------------------------------------------------------
6416       subroutine esc(escloc)
6417 C Calculate the local energy of a side chain and its derivatives in the
6418 C corresponding virtual-bond valence angles THETA and the spherical angles
6419 C ALPHA and OMEGA derived from AM1 all-atom calculations.
6420 C added by Urszula Kozlowska. 07/11/2007
6421 C
6422       implicit real*8 (a-h,o-z)
6423       include 'DIMENSIONS'
6424       include 'COMMON.GEO'
6425       include 'COMMON.LOCAL'
6426       include 'COMMON.VAR'
6427       include 'COMMON.SCROT'
6428       include 'COMMON.INTERACT'
6429       include 'COMMON.DERIV'
6430       include 'COMMON.CHAIN'
6431       include 'COMMON.IOUNITS'
6432       include 'COMMON.NAMES'
6433       include 'COMMON.FFIELD'
6434       include 'COMMON.CONTROL'
6435       include 'COMMON.VECTORS'
6436       double precision x_prime(3),y_prime(3),z_prime(3)
6437      &    , sumene,dsc_i,dp2_i,x(65),
6438      &     xx,yy,zz,sumene1,sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6,
6439      &    de_dxx,de_dyy,de_dzz,de_dt
6440       double precision s1_t,s1_6_t,s2_t,s2_6_t
6441       double precision
6442      & dXX_Ci1(3),dYY_Ci1(3),dZZ_Ci1(3),dXX_Ci(3),
6443      & dYY_Ci(3),dZZ_Ci(3),dXX_XYZ(3),dYY_XYZ(3),dZZ_XYZ(3),
6444      & dt_dCi(3),dt_dCi1(3)
6445       common /sccalc/ time11,time12,time112,theti,it,nlobit
6446       delta=0.02d0*pi
6447       escloc=0.0D0
6448       do i=loc_start,loc_end
6449         if (itype(i).eq.ntyp1) cycle
6450         costtab(i+1) =dcos(theta(i+1))
6451         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
6452         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
6453         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
6454         cosfac2=0.5d0/(1.0d0+costtab(i+1))
6455         cosfac=dsqrt(cosfac2)
6456         sinfac2=0.5d0/(1.0d0-costtab(i+1))
6457         sinfac=dsqrt(sinfac2)
6458         it=iabs(itype(i))
6459         if (it.eq.10) goto 1
6460 c
6461 C  Compute the axes of tghe local cartesian coordinates system; store in
6462 c   x_prime, y_prime and z_prime
6463 c
6464         do j=1,3
6465           x_prime(j) = 0.00
6466           y_prime(j) = 0.00
6467           z_prime(j) = 0.00
6468         enddo
6469 C        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
6470 C     &   dc_norm(3,i+nres)
6471         do j = 1,3
6472           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
6473           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
6474         enddo
6475         do j = 1,3
6476           z_prime(j) = -uz(j,i-1)*dsign(1.0d0,dfloat(itype(i)))
6477         enddo
6478 c       write (2,*) "i",i
6479 c       write (2,*) "x_prime",(x_prime(j),j=1,3)
6480 c       write (2,*) "y_prime",(y_prime(j),j=1,3)
6481 c       write (2,*) "z_prime",(z_prime(j),j=1,3)
6482 c       write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
6483 c      & " xy",scalar(x_prime(1),y_prime(1)),
6484 c      & " xz",scalar(x_prime(1),z_prime(1)),
6485 c      & " yy",scalar(y_prime(1),y_prime(1)),
6486 c      & " yz",scalar(y_prime(1),z_prime(1)),
6487 c      & " zz",scalar(z_prime(1),z_prime(1))
6488 c
6489 C Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
6490 C to local coordinate system. Store in xx, yy, zz.
6491 c
6492         xx=0.0d0
6493         yy=0.0d0
6494         zz=0.0d0
6495         do j = 1,3
6496           xx = xx + x_prime(j)*dc_norm(j,i+nres)
6497           yy = yy + y_prime(j)*dc_norm(j,i+nres)
6498           zz = zz + z_prime(j)*dc_norm(j,i+nres)
6499         enddo
6500
6501         xxtab(i)=xx
6502         yytab(i)=yy
6503         zztab(i)=zz
6504 C
6505 C Compute the energy of the ith side cbain
6506 C
6507 c        write (2,*) "xx",xx," yy",yy," zz",zz
6508         it=iabs(itype(i))
6509         do j = 1,65
6510           x(j) = sc_parmin(j,it)
6511         enddo
6512 #ifdef CHECK_COORD
6513 Cc diagnostics - remove later
6514         xx1 = dcos(alph(2))
6515         yy1 = dsin(alph(2))*dcos(omeg(2))
6516         zz1 = -dsign(1.0,dfloat(itype(i)))*dsin(alph(2))*dsin(omeg(2))
6517         write(2,'(3f8.1,3f9.3,1x,3f9.3)')
6518      &    alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,
6519      &    xx1,yy1,zz1
6520 C,"  --- ", xx_w,yy_w,zz_w
6521 c end diagnostics
6522 #endif
6523         sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
6524      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
6525      &   + x(10)*yy*zz
6526         sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
6527      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
6528      & + x(20)*yy*zz
6529         sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
6530      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
6531      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
6532      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
6533      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
6534      &  +x(40)*xx*yy*zz
6535         sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
6536      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
6537      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
6538      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
6539      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
6540      &  +x(60)*xx*yy*zz
6541         dsc_i   = 0.743d0+x(61)
6542         dp2_i   = 1.9d0+x(62)
6543         dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
6544      &          *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
6545         dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
6546      &          *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
6547         s1=(1+x(63))/(0.1d0 + dscp1)
6548         s1_6=(1+x(64))/(0.1d0 + dscp1**6)
6549         s2=(1+x(65))/(0.1d0 + dscp2)
6550         s2_6=(1+x(65))/(0.1d0 + dscp2**6)
6551         sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6)
6552      & + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
6553 c        write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
6554 c     &   sumene4,
6555 c     &   dscp1,dscp2,sumene
6556 c        sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6557         escloc = escloc + sumene
6558 c        write (2,*) "i",i," escloc",sumene,escloc,it,itype(i)
6559 c     & ,zz,xx,yy
6560 c#define DEBUG
6561 #ifdef DEBUG
6562 C
6563 C This section to check the numerical derivatives of the energy of ith side
6564 C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
6565 C #define DEBUG in the code to turn it on.
6566 C
6567         write (2,*) "sumene               =",sumene
6568         aincr=1.0d-7
6569         xxsave=xx
6570         xx=xx+aincr
6571         write (2,*) xx,yy,zz
6572         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6573         de_dxx_num=(sumenep-sumene)/aincr
6574         xx=xxsave
6575         write (2,*) "xx+ sumene from enesc=",sumenep
6576         yysave=yy
6577         yy=yy+aincr
6578         write (2,*) xx,yy,zz
6579         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6580         de_dyy_num=(sumenep-sumene)/aincr
6581         yy=yysave
6582         write (2,*) "yy+ sumene from enesc=",sumenep
6583         zzsave=zz
6584         zz=zz+aincr
6585         write (2,*) xx,yy,zz
6586         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6587         de_dzz_num=(sumenep-sumene)/aincr
6588         zz=zzsave
6589         write (2,*) "zz+ sumene from enesc=",sumenep
6590         costsave=cost2tab(i+1)
6591         sintsave=sint2tab(i+1)
6592         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
6593         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
6594         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6595         de_dt_num=(sumenep-sumene)/aincr
6596         write (2,*) " t+ sumene from enesc=",sumenep
6597         cost2tab(i+1)=costsave
6598         sint2tab(i+1)=sintsave
6599 C End of diagnostics section.
6600 #endif
6601 C
6602 C Compute the gradient of esc
6603 C
6604 c        zz=zz*dsign(1.0,dfloat(itype(i)))
6605         pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
6606         pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
6607         pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
6608         pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
6609         pom_dx=dsc_i*dp2_i*cost2tab(i+1)
6610         pom_dy=dsc_i*dp2_i*sint2tab(i+1)
6611         pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
6612         pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
6613         pom1=(sumene3*sint2tab(i+1)+sumene1)
6614      &     *(pom_s1/dscp1+pom_s16*dscp1**4)
6615         pom2=(sumene4*cost2tab(i+1)+sumene2)
6616      &     *(pom_s2/dscp2+pom_s26*dscp2**4)
6617         sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
6618         sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2
6619      &  +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2)
6620      &  +x(40)*yy*zz
6621         sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
6622         sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2
6623      &  +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2)
6624      &  +x(60)*yy*zz
6625         de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6)
6626      &        +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6)
6627      &        +(pom1+pom2)*pom_dx
6628 #ifdef DEBUG
6629         write(2,*), "de_dxx = ", de_dxx,de_dxx_num,itype(i)
6630 #endif
6631 C
6632         sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
6633         sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2
6634      &  +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2)
6635      &  +x(40)*xx*zz
6636         sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
6637         sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz
6638      &  +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz
6639      &  +x(59)*zz**2 +x(60)*xx*zz
6640         de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6)
6641      &        +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6)
6642      &        +(pom1-pom2)*pom_dy
6643 #ifdef DEBUG
6644         write(2,*), "de_dyy = ", de_dyy,de_dyy_num,itype(i)
6645 #endif
6646 C
6647         de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy
6648      &  +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx
6649      &  +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6)
6650      &  +(x(4) + 2*x(7)*zz+  x(8)*xx + x(10)*yy)*(s1+s1_6)
6651      &  +(x(44)+2*x(47)*zz +x(48)*xx   +x(50)*yy  +3*x(53)*zz**2
6652      &  +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy
6653      &  +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6)
6654      &  + ( x(14) + 2*x(17)*zz+  x(18)*xx + x(20)*yy)*(s2+s2_6)
6655 #ifdef DEBUG
6656         write(2,*), "de_dzz = ", de_dzz,de_dzz_num,itype(i)
6657 #endif
6658 C
6659         de_dt =  0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6)
6660      &  -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6)
6661      &  +pom1*pom_dt1+pom2*pom_dt2
6662 #ifdef DEBUG
6663         write(2,*), "de_dt = ", de_dt,de_dt_num,itype(i)
6664 #endif
6665 c#undef DEBUG
6666 c
6667 C
6668        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
6669        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
6670        cosfac2xx=cosfac2*xx
6671        sinfac2yy=sinfac2*yy
6672        do k = 1,3
6673          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))*
6674      &      vbld_inv(i+1)
6675          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))*
6676      &      vbld_inv(i)
6677          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
6678          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
6679 c         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
6680 c     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
6681 c         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
6682 c     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
6683          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
6684          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
6685          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
6686          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
6687          dZZ_Ci1(k)=0.0d0
6688          dZZ_Ci(k)=0.0d0
6689          do j=1,3
6690            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)
6691      &     *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
6692            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)
6693      &     *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
6694          enddo
6695
6696          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
6697          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
6698          dZZ_XYZ(k)=vbld_inv(i+nres)*
6699      &   (z_prime(k)-zz*dC_norm(k,i+nres))
6700 c
6701          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
6702          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
6703        enddo
6704
6705        do k=1,3
6706          dXX_Ctab(k,i)=dXX_Ci(k)
6707          dXX_C1tab(k,i)=dXX_Ci1(k)
6708          dYY_Ctab(k,i)=dYY_Ci(k)
6709          dYY_C1tab(k,i)=dYY_Ci1(k)
6710          dZZ_Ctab(k,i)=dZZ_Ci(k)
6711          dZZ_C1tab(k,i)=dZZ_Ci1(k)
6712          dXX_XYZtab(k,i)=dXX_XYZ(k)
6713          dYY_XYZtab(k,i)=dYY_XYZ(k)
6714          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
6715        enddo
6716
6717        do k = 1,3
6718 c         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
6719 c     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
6720 c         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
6721 c     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
6722 c         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
6723 c     &    dt_dci(k)
6724 c         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
6725 c     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
6726          gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k)
6727      &    +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
6728          gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k)
6729      &    +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
6730          gsclocx(k,i)=                 de_dxx*dxx_XYZ(k)
6731      &    +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
6732        enddo
6733 c       write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
6734 c     &  (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
6735
6736 C to check gradient call subroutine check_grad
6737
6738     1 continue
6739       enddo
6740       return
6741       end
6742 c------------------------------------------------------------------------------
6743       double precision function enesc(x,xx,yy,zz,cost2,sint2)
6744       implicit none
6745       double precision x(65),xx,yy,zz,cost2,sint2,sumene1,sumene2,
6746      & sumene3,sumene4,sumene,dsc_i,dp2_i,dscp1,dscp2,s1,s1_6,s2,s2_6
6747       sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
6748      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
6749      &   + x(10)*yy*zz
6750       sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
6751      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
6752      & + x(20)*yy*zz
6753       sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
6754      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
6755      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
6756      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
6757      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
6758      &  +x(40)*xx*yy*zz
6759       sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
6760      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
6761      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
6762      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
6763      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
6764      &  +x(60)*xx*yy*zz
6765       dsc_i   = 0.743d0+x(61)
6766       dp2_i   = 1.9d0+x(62)
6767       dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
6768      &          *(xx*cost2+yy*sint2))
6769       dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
6770      &          *(xx*cost2-yy*sint2))
6771       s1=(1+x(63))/(0.1d0 + dscp1)
6772       s1_6=(1+x(64))/(0.1d0 + dscp1**6)
6773       s2=(1+x(65))/(0.1d0 + dscp2)
6774       s2_6=(1+x(65))/(0.1d0 + dscp2**6)
6775       sumene = ( sumene3*sint2 + sumene1)*(s1+s1_6)
6776      & + (sumene4*cost2 +sumene2)*(s2+s2_6)
6777       enesc=sumene
6778       return
6779       end
6780 #endif
6781 c------------------------------------------------------------------------------
6782       subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
6783 C
6784 C This procedure calculates two-body contact function g(rij) and its derivative:
6785 C
6786 C           eps0ij                                     !       x < -1
6787 C g(rij) =  esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5)  ! -1 =< x =< 1
6788 C            0                                         !       x > 1
6789 C
6790 C where x=(rij-r0ij)/delta
6791 C
6792 C rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
6793 C
6794       implicit none
6795       double precision rij,r0ij,eps0ij,fcont,fprimcont
6796       double precision x,x2,x4,delta
6797 c     delta=0.02D0*r0ij
6798 c      delta=0.2D0*r0ij
6799       x=(rij-r0ij)/delta
6800       if (x.lt.-1.0D0) then
6801         fcont=eps0ij
6802         fprimcont=0.0D0
6803       else if (x.le.1.0D0) then
6804         x2=x*x
6805         x4=x2*x2
6806         fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
6807         fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
6808       else
6809         fcont=0.0D0
6810         fprimcont=0.0D0
6811       endif
6812       return
6813       end
6814 c------------------------------------------------------------------------------
6815       subroutine splinthet(theti,delta,ss,ssder)
6816       implicit real*8 (a-h,o-z)
6817       include 'DIMENSIONS'
6818       include 'COMMON.VAR'
6819       include 'COMMON.GEO'
6820       thetup=pi-delta
6821       thetlow=delta
6822       if (theti.gt.pipol) then
6823         call gcont(theti,thetup,1.0d0,delta,ss,ssder)
6824       else
6825         call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
6826         ssder=-ssder
6827       endif
6828       return
6829       end
6830 c------------------------------------------------------------------------------
6831       subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
6832       implicit none
6833       double precision x,x0,delta,f0,f1,fprim0,f,fprim
6834       double precision ksi,ksi2,ksi3,a1,a2,a3
6835       a1=fprim0*delta/(f1-f0)
6836       a2=3.0d0-2.0d0*a1
6837       a3=a1-2.0d0
6838       ksi=(x-x0)/delta
6839       ksi2=ksi*ksi
6840       ksi3=ksi2*ksi
6841       f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
6842       fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
6843       return
6844       end
6845 c------------------------------------------------------------------------------
6846       subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
6847       implicit none
6848       double precision x,x0,delta,f0x,f1x,fprim0x,fx
6849       double precision ksi,ksi2,ksi3,a1,a2,a3
6850       ksi=(x-x0)/delta
6851       ksi2=ksi*ksi
6852       ksi3=ksi2*ksi
6853       a1=fprim0x*delta
6854       a2=3*(f1x-f0x)-2*fprim0x*delta
6855       a3=fprim0x*delta-2*(f1x-f0x)
6856       fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
6857       return
6858       end
6859 C-----------------------------------------------------------------------------
6860 #ifdef CRYST_TOR
6861 C-----------------------------------------------------------------------------
6862       subroutine etor(etors,edihcnstr)
6863       implicit real*8 (a-h,o-z)
6864       include 'DIMENSIONS'
6865       include 'COMMON.VAR'
6866       include 'COMMON.GEO'
6867       include 'COMMON.LOCAL'
6868       include 'COMMON.TORSION'
6869       include 'COMMON.INTERACT'
6870       include 'COMMON.DERIV'
6871       include 'COMMON.CHAIN'
6872       include 'COMMON.NAMES'
6873       include 'COMMON.IOUNITS'
6874       include 'COMMON.FFIELD'
6875       include 'COMMON.TORCNSTR'
6876       include 'COMMON.CONTROL'
6877       logical lprn
6878 C Set lprn=.true. for debugging
6879       lprn=.false.
6880 c      lprn=.true.
6881       etors=0.0D0
6882       do i=iphi_start,iphi_end
6883       etors_ii=0.0D0
6884         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
6885      &      .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
6886         itori=itortyp(itype(i-2))
6887         itori1=itortyp(itype(i-1))
6888         phii=phi(i)
6889         gloci=0.0D0
6890 C Proline-Proline pair is a special case...
6891         if (itori.eq.3 .and. itori1.eq.3) then
6892           if (phii.gt.-dwapi3) then
6893             cosphi=dcos(3*phii)
6894             fac=1.0D0/(1.0D0-cosphi)
6895             etorsi=v1(1,3,3)*fac
6896             etorsi=etorsi+etorsi
6897             etors=etors+etorsi-v1(1,3,3)
6898             if (energy_dec) etors_ii=etors_ii+etorsi-v1(1,3,3)
6899             gloci=gloci-3*fac*etorsi*dsin(3*phii)
6900           endif
6901           do j=1,3
6902             v1ij=v1(j+1,itori,itori1)
6903             v2ij=v2(j+1,itori,itori1)
6904             cosphi=dcos(j*phii)
6905             sinphi=dsin(j*phii)
6906             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
6907             if (energy_dec) etors_ii=etors_ii+
6908      &                              v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
6909             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
6910           enddo
6911         else
6912           do j=1,nterm_old
6913             v1ij=v1(j,itori,itori1)
6914             v2ij=v2(j,itori,itori1)
6915             cosphi=dcos(j*phii)
6916             sinphi=dsin(j*phii)
6917             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
6918             if (energy_dec) etors_ii=etors_ii+
6919      &                  v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
6920             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
6921           enddo
6922         endif
6923         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
6924              'etor',i,etors_ii
6925         if (lprn)
6926      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
6927      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
6928      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
6929         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
6930 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
6931       enddo
6932 ! 6/20/98 - dihedral angle constraints
6933       edihcnstr=0.0d0
6934       do i=1,ndih_constr
6935         itori=idih_constr(i)
6936         phii=phi(itori)
6937         difi=phii-phi0(i)
6938         if (difi.gt.drange(i)) then
6939           difi=difi-drange(i)
6940           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
6941           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
6942         else if (difi.lt.-drange(i)) then
6943           difi=difi+drange(i)
6944           edihcnstr=edihcnstr+0.25d0*ftors(i)**difi**4
6945           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
6946         endif
6947 !        write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii,
6948 !     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
6949       enddo
6950 !      write (iout,*) 'edihcnstr',edihcnstr
6951       return
6952       end
6953 c------------------------------------------------------------------------------
6954       subroutine etor_d(etors_d)
6955       etors_d=0.0d0
6956       return
6957       end
6958 c----------------------------------------------------------------------------
6959 #else
6960       subroutine etor(etors,edihcnstr)
6961       implicit real*8 (a-h,o-z)
6962       include 'DIMENSIONS'
6963       include 'COMMON.VAR'
6964       include 'COMMON.GEO'
6965       include 'COMMON.LOCAL'
6966       include 'COMMON.TORSION'
6967       include 'COMMON.INTERACT'
6968       include 'COMMON.DERIV'
6969       include 'COMMON.CHAIN'
6970       include 'COMMON.NAMES'
6971       include 'COMMON.IOUNITS'
6972       include 'COMMON.FFIELD'
6973       include 'COMMON.TORCNSTR'
6974       include 'COMMON.CONTROL'
6975       logical lprn
6976 C Set lprn=.true. for debugging
6977       lprn=.false.
6978 c     lprn=.true.
6979       etors=0.0D0
6980       do i=iphi_start,iphi_end
6981 C ANY TWO ARE DUMMY ATOMS in row CYCLE
6982 c        if (((itype(i-3).eq.ntyp1).and.(itype(i-2).eq.ntyp1)).or.
6983 c     &      ((itype(i-2).eq.ntyp1).and.(itype(i-1).eq.ntyp1))  .or.
6984 c     &      ((itype(i-1).eq.ntyp1).and.(itype(i).eq.ntyp1))) cycle
6985         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
6986      &      .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
6987 C In current verion the ALL DUMMY ATOM POTENTIALS ARE OFF
6988 C For introducing the NH3+ and COO- group please check the etor_d for reference
6989 C and guidance
6990         etors_ii=0.0D0
6991          if (iabs(itype(i)).eq.20) then
6992          iblock=2
6993          else
6994          iblock=1
6995          endif
6996         itori=itortyp(itype(i-2))
6997         itori1=itortyp(itype(i-1))
6998         phii=phi(i)
6999         gloci=0.0D0
7000 C Regular cosine and sine terms
7001         do j=1,nterm(itori,itori1,iblock)
7002           v1ij=v1(j,itori,itori1,iblock)
7003           v2ij=v2(j,itori,itori1,iblock)
7004           cosphi=dcos(j*phii)
7005           sinphi=dsin(j*phii)
7006           etors=etors+v1ij*cosphi+v2ij*sinphi
7007           if (energy_dec) etors_ii=etors_ii+
7008      &                v1ij*cosphi+v2ij*sinphi
7009           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7010         enddo
7011 C Lorentz terms
7012 C                         v1
7013 C  E = SUM ----------------------------------- - v1
7014 C          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
7015 C
7016         cosphi=dcos(0.5d0*phii)
7017         sinphi=dsin(0.5d0*phii)
7018         do j=1,nlor(itori,itori1,iblock)
7019           vl1ij=vlor1(j,itori,itori1)
7020           vl2ij=vlor2(j,itori,itori1)
7021           vl3ij=vlor3(j,itori,itori1)
7022           pom=vl2ij*cosphi+vl3ij*sinphi
7023           pom1=1.0d0/(pom*pom+1.0d0)
7024           etors=etors+vl1ij*pom1
7025           if (energy_dec) etors_ii=etors_ii+
7026      &                vl1ij*pom1
7027           pom=-pom*pom1*pom1
7028           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
7029         enddo
7030 C Subtract the constant term
7031         etors=etors-v0(itori,itori1,iblock)
7032           if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
7033      &         'etor',i,etors_ii-v0(itori,itori1,iblock)
7034         if (lprn)
7035      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
7036      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
7037      &  (v1(j,itori,itori1,iblock),j=1,6),
7038      &  (v2(j,itori,itori1,iblock),j=1,6)
7039         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
7040 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
7041       enddo
7042 ! 6/20/98 - dihedral angle constraints
7043       edihcnstr=0.0d0
7044 c      do i=1,ndih_constr
7045       do i=idihconstr_start,idihconstr_end
7046         itori=idih_constr(i)
7047         phii=phi(itori)
7048         difi=pinorm(phii-phi0(i))
7049         if (difi.gt.drange(i)) then
7050           difi=difi-drange(i)
7051           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
7052           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
7053         else if (difi.lt.-drange(i)) then
7054           difi=difi+drange(i)
7055           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
7056           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
7057         else
7058           difi=0.0
7059         endif
7060        if (energy_dec) then
7061         write (iout,'(a6,2i5,4f8.3,2e14.5)') "edihc",
7062      &    i,itori,rad2deg*phii,
7063      &    rad2deg*phi0(i),  rad2deg*drange(i),
7064      &    rad2deg*difi,0.25d0*ftors(i)*difi**4,gloc(itori-3,icg)
7065         endif
7066       enddo
7067 cd       write (iout,*) 'edihcnstr',edihcnstr
7068       return
7069       end
7070 c----------------------------------------------------------------------------
7071       subroutine etor_d(etors_d)
7072 C 6/23/01 Compute double torsional energy
7073       implicit real*8 (a-h,o-z)
7074       include 'DIMENSIONS'
7075       include 'COMMON.VAR'
7076       include 'COMMON.GEO'
7077       include 'COMMON.LOCAL'
7078       include 'COMMON.TORSION'
7079       include 'COMMON.INTERACT'
7080       include 'COMMON.DERIV'
7081       include 'COMMON.CHAIN'
7082       include 'COMMON.NAMES'
7083       include 'COMMON.IOUNITS'
7084       include 'COMMON.FFIELD'
7085       include 'COMMON.TORCNSTR'
7086       logical lprn
7087 C Set lprn=.true. for debugging
7088       lprn=.false.
7089 c     lprn=.true.
7090       etors_d=0.0D0
7091 c      write(iout,*) "a tu??"
7092       do i=iphid_start,iphid_end
7093 C ANY TWO ARE DUMMY ATOMS in row CYCLE
7094 C        if (((itype(i-3).eq.ntyp1).and.(itype(i-2).eq.ntyp1)).or.
7095 C     &      ((itype(i-2).eq.ntyp1).and.(itype(i-1).eq.ntyp1)).or.
7096 C     &      ((itype(i-1).eq.ntyp1).and.(itype(i).eq.ntyp1))  .or.
7097 C     &      ((itype(i).eq.ntyp1).and.(itype(i+1).eq.ntyp1))) cycle
7098          if ((itype(i-2).eq.ntyp1).or.itype(i-3).eq.ntyp1.or.
7099      &  (itype(i-1).eq.ntyp1).or.(itype(i).eq.ntyp1).or.
7100      &  (itype(i+1).eq.ntyp1)) cycle
7101 C In current verion the ALL DUMMY ATOM POTENTIALS ARE OFF
7102         itori=itortyp(itype(i-2))
7103         itori1=itortyp(itype(i-1))
7104         itori2=itortyp(itype(i))
7105         phii=phi(i)
7106         phii1=phi(i+1)
7107         gloci1=0.0D0
7108         gloci2=0.0D0
7109         iblock=1
7110         if (iabs(itype(i+1)).eq.20) iblock=2
7111 C Iblock=2 Proline type
7112 C ADASKO: WHEN PARAMETERS FOR THIS TYPE OF BLOCKING GROUP IS READY UNCOMMENT
7113 C CHECK WEATHER THERE IS NECCESITY FOR iblock=3 for COO-
7114 C        if (itype(i+1).eq.ntyp1) iblock=3
7115 C The problem of NH3+ group can be resolved by adding new parameters please note if there
7116 C IS or IS NOT need for this
7117 C IF Yes uncomment below and add to parmread.F appropriate changes and to v1cij and so on
7118 C        is (itype(i-3).eq.ntyp1) ntblock=2
7119 C        ntblock is N-terminal blocking group
7120
7121 C Regular cosine and sine terms
7122         do j=1,ntermd_1(itori,itori1,itori2,iblock)
7123 C Example of changes for NH3+ blocking group
7124 C       do j=1,ntermd_1(itori,itori1,itori2,iblock,ntblock)
7125 C          v1cij=v1c(1,j,itori,itori1,itori2,iblock,ntblock)
7126           v1cij=v1c(1,j,itori,itori1,itori2,iblock)
7127           v1sij=v1s(1,j,itori,itori1,itori2,iblock)
7128           v2cij=v1c(2,j,itori,itori1,itori2,iblock)
7129           v2sij=v1s(2,j,itori,itori1,itori2,iblock)
7130           cosphi1=dcos(j*phii)
7131           sinphi1=dsin(j*phii)
7132           cosphi2=dcos(j*phii1)
7133           sinphi2=dsin(j*phii1)
7134           etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+
7135      &     v2cij*cosphi2+v2sij*sinphi2
7136           gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
7137           gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
7138         enddo
7139         do k=2,ntermd_2(itori,itori1,itori2,iblock)
7140           do l=1,k-1
7141             v1cdij = v2c(k,l,itori,itori1,itori2,iblock)
7142             v2cdij = v2c(l,k,itori,itori1,itori2,iblock)
7143             v1sdij = v2s(k,l,itori,itori1,itori2,iblock)
7144             v2sdij = v2s(l,k,itori,itori1,itori2,iblock)
7145             cosphi1p2=dcos(l*phii+(k-l)*phii1)
7146             cosphi1m2=dcos(l*phii-(k-l)*phii1)
7147             sinphi1p2=dsin(l*phii+(k-l)*phii1)
7148             sinphi1m2=dsin(l*phii-(k-l)*phii1)
7149             etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+
7150      &        v1sdij*sinphi1p2+v2sdij*sinphi1m2
7151             gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2
7152      &        -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
7153             gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2
7154      &        -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
7155           enddo
7156         enddo
7157         gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*gloci1
7158         gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*gloci2
7159       enddo
7160       return
7161       end
7162 #endif
7163 c------------------------------------------------------------------------------
7164       subroutine eback_sc_corr(esccor)
7165 c 7/21/2007 Correlations between the backbone-local and side-chain-local
7166 c        conformational states; temporarily implemented as differences
7167 c        between UNRES torsional potentials (dependent on three types of
7168 c        residues) and the torsional potentials dependent on all 20 types
7169 c        of residues computed from AM1  energy surfaces of terminally-blocked
7170 c        amino-acid residues.
7171       implicit real*8 (a-h,o-z)
7172       include 'DIMENSIONS'
7173       include 'COMMON.VAR'
7174       include 'COMMON.GEO'
7175       include 'COMMON.LOCAL'
7176       include 'COMMON.TORSION'
7177       include 'COMMON.SCCOR'
7178       include 'COMMON.INTERACT'
7179       include 'COMMON.DERIV'
7180       include 'COMMON.CHAIN'
7181       include 'COMMON.NAMES'
7182       include 'COMMON.IOUNITS'
7183       include 'COMMON.FFIELD'
7184       include 'COMMON.CONTROL'
7185       logical lprn
7186 C Set lprn=.true. for debugging
7187       lprn=.false.
7188 c      lprn=.true.
7189 c      write (iout,*) "EBACK_SC_COR",itau_start,itau_end
7190       esccor=0.0D0
7191       do i=itau_start,itau_end
7192         if ((itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)) cycle
7193         esccor_ii=0.0D0
7194         isccori=isccortyp(itype(i-2))
7195         isccori1=isccortyp(itype(i-1))
7196 c      write (iout,*) "EBACK_SC_COR",i,nterm_sccor(isccori,isccori1)
7197         phii=phi(i)
7198         do intertyp=1,3 !intertyp
7199 cc Added 09 May 2012 (Adasko)
7200 cc  Intertyp means interaction type of backbone mainchain correlation:
7201 c   1 = SC...Ca...Ca...Ca
7202 c   2 = Ca...Ca...Ca...SC
7203 c   3 = SC...Ca...Ca...SCi
7204         gloci=0.0D0
7205         if (((intertyp.eq.3).and.((itype(i-2).eq.10).or.
7206      &      (itype(i-1).eq.10).or.(itype(i-2).eq.ntyp1).or.
7207      &      (itype(i-1).eq.ntyp1)))
7208      &    .or. ((intertyp.eq.1).and.((itype(i-2).eq.10)
7209      &     .or.(itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)
7210      &     .or.(itype(i).eq.ntyp1)))
7211      &    .or.((intertyp.eq.2).and.((itype(i-1).eq.10).or.
7212      &      (itype(i-1).eq.ntyp1).or.(itype(i-2).eq.ntyp1).or.
7213      &      (itype(i-3).eq.ntyp1)))) cycle
7214         if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1).eq.ntyp1)) cycle
7215         if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres).eq.ntyp1))
7216      & cycle
7217        do j=1,nterm_sccor(isccori,isccori1)
7218           v1ij=v1sccor(j,intertyp,isccori,isccori1)
7219           v2ij=v2sccor(j,intertyp,isccori,isccori1)
7220           cosphi=dcos(j*tauangle(intertyp,i))
7221           sinphi=dsin(j*tauangle(intertyp,i))
7222           esccor=esccor+v1ij*cosphi+v2ij*sinphi
7223           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7224         enddo
7225 c      write (iout,*) "EBACK_SC_COR",i,v1ij*cosphi+v2ij*sinphi,intertyp
7226         gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci
7227         if (lprn)
7228      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
7229      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,isccori,isccori1,
7230      &  (v1sccor(j,intertyp,isccori,isccori1),j=1,6)
7231      & ,(v2sccor(j,intertyp,isccori,isccori1),j=1,6)
7232         gsccor_loc(i-3)=gsccor_loc(i-3)+gloci
7233        enddo !intertyp
7234       enddo
7235
7236       return
7237       end
7238 c----------------------------------------------------------------------------
7239       subroutine multibody(ecorr)
7240 C This subroutine calculates multi-body contributions to energy following
7241 C the idea of Skolnick et al. If side chains I and J make a contact and
7242 C at the same time side chains I+1 and J+1 make a contact, an extra
7243 C contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
7244       implicit real*8 (a-h,o-z)
7245       include 'DIMENSIONS'
7246       include 'COMMON.IOUNITS'
7247       include 'COMMON.DERIV'
7248       include 'COMMON.INTERACT'
7249       include 'COMMON.CONTACTS'
7250       double precision gx(3),gx1(3)
7251       logical lprn
7252
7253 C Set lprn=.true. for debugging
7254       lprn=.false.
7255
7256       if (lprn) then
7257         write (iout,'(a)') 'Contact function values:'
7258         do i=nnt,nct-2
7259           write (iout,'(i2,20(1x,i2,f10.5))')
7260      &        i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
7261         enddo
7262       endif
7263       ecorr=0.0D0
7264       do i=nnt,nct
7265         do j=1,3
7266           gradcorr(j,i)=0.0D0
7267           gradxorr(j,i)=0.0D0
7268         enddo
7269       enddo
7270       do i=nnt,nct-2
7271
7272         DO ISHIFT = 3,4
7273
7274         i1=i+ishift
7275         num_conti=num_cont(i)
7276         num_conti1=num_cont(i1)
7277         do jj=1,num_conti
7278           j=jcont(jj,i)
7279           do kk=1,num_conti1
7280             j1=jcont(kk,i1)
7281             if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
7282 cd          write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
7283 cd   &                   ' ishift=',ishift
7284 C Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
7285 C The system gains extra energy.
7286               ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
7287             endif   ! j1==j+-ishift
7288           enddo     ! kk
7289         enddo       ! jj
7290
7291         ENDDO ! ISHIFT
7292
7293       enddo         ! i
7294       return
7295       end
7296 c------------------------------------------------------------------------------
7297       double precision function esccorr(i,j,k,l,jj,kk)
7298       implicit real*8 (a-h,o-z)
7299       include 'DIMENSIONS'
7300       include 'COMMON.IOUNITS'
7301       include 'COMMON.DERIV'
7302       include 'COMMON.INTERACT'
7303       include 'COMMON.CONTACTS'
7304       double precision gx(3),gx1(3)
7305       logical lprn
7306       lprn=.false.
7307       eij=facont(jj,i)
7308       ekl=facont(kk,k)
7309 cd    write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
7310 C Calculate the multi-body contribution to energy.
7311 C Calculate multi-body contributions to the gradient.
7312 cd    write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
7313 cd   & k,l,(gacont(m,kk,k),m=1,3)
7314       do m=1,3
7315         gx(m) =ekl*gacont(m,jj,i)
7316         gx1(m)=eij*gacont(m,kk,k)
7317         gradxorr(m,i)=gradxorr(m,i)-gx(m)
7318         gradxorr(m,j)=gradxorr(m,j)+gx(m)
7319         gradxorr(m,k)=gradxorr(m,k)-gx1(m)
7320         gradxorr(m,l)=gradxorr(m,l)+gx1(m)
7321       enddo
7322       do m=i,j-1
7323         do ll=1,3
7324           gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
7325         enddo
7326       enddo
7327       do m=k,l-1
7328         do ll=1,3
7329           gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
7330         enddo
7331       enddo
7332       esccorr=-eij*ekl
7333       return
7334       end
7335 c------------------------------------------------------------------------------
7336       subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
7337 C This subroutine calculates multi-body contributions to hydrogen-bonding
7338       implicit real*8 (a-h,o-z)
7339       include 'DIMENSIONS'
7340       include 'COMMON.IOUNITS'
7341 #ifdef MPI
7342       include "mpif.h"
7343       parameter (max_cont=maxconts)
7344       parameter (max_dim=26)
7345       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
7346       double precision zapas(max_dim,maxconts,max_fg_procs),
7347      &  zapas_recv(max_dim,maxconts,max_fg_procs)
7348       common /przechowalnia/ zapas
7349       integer status(MPI_STATUS_SIZE),req(maxconts*2),
7350      &  status_array(MPI_STATUS_SIZE,maxconts*2)
7351 #endif
7352       include 'COMMON.SETUP'
7353       include 'COMMON.FFIELD'
7354       include 'COMMON.DERIV'
7355       include 'COMMON.INTERACT'
7356       include 'COMMON.CONTACTS'
7357       include 'COMMON.CONTROL'
7358       include 'COMMON.LOCAL'
7359       double precision gx(3),gx1(3),time00
7360       logical lprn,ldone
7361
7362 C Set lprn=.true. for debugging
7363       lprn=.false.
7364 #ifdef MPI
7365       n_corr=0
7366       n_corr1=0
7367       if (nfgtasks.le.1) goto 30
7368       if (lprn) then
7369         write (iout,'(a)') 'Contact function values before RECEIVE:'
7370         do i=nnt,nct-2
7371           write (iout,'(2i3,50(1x,i2,f5.2))')
7372      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
7373      &    j=1,num_cont_hb(i))
7374         enddo
7375       endif
7376       call flush(iout)
7377       do i=1,ntask_cont_from
7378         ncont_recv(i)=0
7379       enddo
7380       do i=1,ntask_cont_to
7381         ncont_sent(i)=0
7382       enddo
7383 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
7384 c     & ntask_cont_to
7385 C Make the list of contacts to send to send to other procesors
7386 c      write (iout,*) "limits",max0(iturn4_end-1,iatel_s),iturn3_end
7387 c      call flush(iout)
7388       do i=iturn3_start,iturn3_end
7389 c        write (iout,*) "make contact list turn3",i," num_cont",
7390 c     &    num_cont_hb(i)
7391         call add_hb_contact(i,i+2,iturn3_sent_local(1,i))
7392       enddo
7393       do i=iturn4_start,iturn4_end
7394 c        write (iout,*) "make contact list turn4",i," num_cont",
7395 c     &   num_cont_hb(i)
7396         call add_hb_contact(i,i+3,iturn4_sent_local(1,i))
7397       enddo
7398       do ii=1,nat_sent
7399         i=iat_sent(ii)
7400 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
7401 c     &    num_cont_hb(i)
7402         do j=1,num_cont_hb(i)
7403         do k=1,4
7404           jjc=jcont_hb(j,i)
7405           iproc=iint_sent_local(k,jjc,ii)
7406 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
7407           if (iproc.gt.0) then
7408             ncont_sent(iproc)=ncont_sent(iproc)+1
7409             nn=ncont_sent(iproc)
7410             zapas(1,nn,iproc)=i
7411             zapas(2,nn,iproc)=jjc
7412             zapas(3,nn,iproc)=facont_hb(j,i)
7413             zapas(4,nn,iproc)=ees0p(j,i)
7414             zapas(5,nn,iproc)=ees0m(j,i)
7415             zapas(6,nn,iproc)=gacont_hbr(1,j,i)
7416             zapas(7,nn,iproc)=gacont_hbr(2,j,i)
7417             zapas(8,nn,iproc)=gacont_hbr(3,j,i)
7418             zapas(9,nn,iproc)=gacontm_hb1(1,j,i)
7419             zapas(10,nn,iproc)=gacontm_hb1(2,j,i)
7420             zapas(11,nn,iproc)=gacontm_hb1(3,j,i)
7421             zapas(12,nn,iproc)=gacontp_hb1(1,j,i)
7422             zapas(13,nn,iproc)=gacontp_hb1(2,j,i)
7423             zapas(14,nn,iproc)=gacontp_hb1(3,j,i)
7424             zapas(15,nn,iproc)=gacontm_hb2(1,j,i)
7425             zapas(16,nn,iproc)=gacontm_hb2(2,j,i)
7426             zapas(17,nn,iproc)=gacontm_hb2(3,j,i)
7427             zapas(18,nn,iproc)=gacontp_hb2(1,j,i)
7428             zapas(19,nn,iproc)=gacontp_hb2(2,j,i)
7429             zapas(20,nn,iproc)=gacontp_hb2(3,j,i)
7430             zapas(21,nn,iproc)=gacontm_hb3(1,j,i)
7431             zapas(22,nn,iproc)=gacontm_hb3(2,j,i)
7432             zapas(23,nn,iproc)=gacontm_hb3(3,j,i)
7433             zapas(24,nn,iproc)=gacontp_hb3(1,j,i)
7434             zapas(25,nn,iproc)=gacontp_hb3(2,j,i)
7435             zapas(26,nn,iproc)=gacontp_hb3(3,j,i)
7436           endif
7437         enddo
7438         enddo
7439       enddo
7440       if (lprn) then
7441       write (iout,*)
7442      &  "Numbers of contacts to be sent to other processors",
7443      &  (ncont_sent(i),i=1,ntask_cont_to)
7444       write (iout,*) "Contacts sent"
7445       do ii=1,ntask_cont_to
7446         nn=ncont_sent(ii)
7447         iproc=itask_cont_to(ii)
7448         write (iout,*) nn," contacts to processor",iproc,
7449      &   " of CONT_TO_COMM group"
7450         do i=1,nn
7451           write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
7452         enddo
7453       enddo
7454       call flush(iout)
7455       endif
7456       CorrelType=477
7457       CorrelID=fg_rank+1
7458       CorrelType1=478
7459       CorrelID1=nfgtasks+fg_rank+1
7460       ireq=0
7461 C Receive the numbers of needed contacts from other processors
7462       do ii=1,ntask_cont_from
7463         iproc=itask_cont_from(ii)
7464         ireq=ireq+1
7465         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
7466      &    FG_COMM,req(ireq),IERR)
7467       enddo
7468 c      write (iout,*) "IRECV ended"
7469 c      call flush(iout)
7470 C Send the number of contacts needed by other processors
7471       do ii=1,ntask_cont_to
7472         iproc=itask_cont_to(ii)
7473         ireq=ireq+1
7474         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
7475      &    FG_COMM,req(ireq),IERR)
7476       enddo
7477 c      write (iout,*) "ISEND ended"
7478 c      write (iout,*) "number of requests (nn)",ireq
7479       call flush(iout)
7480       if (ireq.gt.0)
7481      &  call MPI_Waitall(ireq,req,status_array,ierr)
7482 c      write (iout,*)
7483 c     &  "Numbers of contacts to be received from other processors",
7484 c     &  (ncont_recv(i),i=1,ntask_cont_from)
7485 c      call flush(iout)
7486 C Receive contacts
7487       ireq=0
7488       do ii=1,ntask_cont_from
7489         iproc=itask_cont_from(ii)
7490         nn=ncont_recv(ii)
7491 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
7492 c     &   " of CONT_TO_COMM group"
7493         call flush(iout)
7494         if (nn.gt.0) then
7495           ireq=ireq+1
7496           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
7497      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
7498 c          write (iout,*) "ireq,req",ireq,req(ireq)
7499         endif
7500       enddo
7501 C Send the contacts to processors that need them
7502       do ii=1,ntask_cont_to
7503         iproc=itask_cont_to(ii)
7504         nn=ncont_sent(ii)
7505 c        write (iout,*) nn," contacts to processor",iproc,
7506 c     &   " of CONT_TO_COMM group"
7507         if (nn.gt.0) then
7508           ireq=ireq+1
7509           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
7510      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
7511 c          write (iout,*) "ireq,req",ireq,req(ireq)
7512 c          do i=1,nn
7513 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
7514 c          enddo
7515         endif
7516       enddo
7517 c      write (iout,*) "number of requests (contacts)",ireq
7518 c      write (iout,*) "req",(req(i),i=1,4)
7519 c      call flush(iout)
7520       if (ireq.gt.0)
7521      & call MPI_Waitall(ireq,req,status_array,ierr)
7522       do iii=1,ntask_cont_from
7523         iproc=itask_cont_from(iii)
7524         nn=ncont_recv(iii)
7525         if (lprn) then
7526         write (iout,*) "Received",nn," contacts from processor",iproc,
7527      &   " of CONT_FROM_COMM group"
7528         call flush(iout)
7529         do i=1,nn
7530           write(iout,'(2f5.0,4f10.5)')(zapas_recv(j,i,iii),j=1,5)
7531         enddo
7532         call flush(iout)
7533         endif
7534         do i=1,nn
7535           ii=zapas_recv(1,i,iii)
7536 c Flag the received contacts to prevent double-counting
7537           jj=-zapas_recv(2,i,iii)
7538 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
7539 c          call flush(iout)
7540           nnn=num_cont_hb(ii)+1
7541           num_cont_hb(ii)=nnn
7542           jcont_hb(nnn,ii)=jj
7543           facont_hb(nnn,ii)=zapas_recv(3,i,iii)
7544           ees0p(nnn,ii)=zapas_recv(4,i,iii)
7545           ees0m(nnn,ii)=zapas_recv(5,i,iii)
7546           gacont_hbr(1,nnn,ii)=zapas_recv(6,i,iii)
7547           gacont_hbr(2,nnn,ii)=zapas_recv(7,i,iii)
7548           gacont_hbr(3,nnn,ii)=zapas_recv(8,i,iii)
7549           gacontm_hb1(1,nnn,ii)=zapas_recv(9,i,iii)
7550           gacontm_hb1(2,nnn,ii)=zapas_recv(10,i,iii)
7551           gacontm_hb1(3,nnn,ii)=zapas_recv(11,i,iii)
7552           gacontp_hb1(1,nnn,ii)=zapas_recv(12,i,iii)
7553           gacontp_hb1(2,nnn,ii)=zapas_recv(13,i,iii)
7554           gacontp_hb1(3,nnn,ii)=zapas_recv(14,i,iii)
7555           gacontm_hb2(1,nnn,ii)=zapas_recv(15,i,iii)
7556           gacontm_hb2(2,nnn,ii)=zapas_recv(16,i,iii)
7557           gacontm_hb2(3,nnn,ii)=zapas_recv(17,i,iii)
7558           gacontp_hb2(1,nnn,ii)=zapas_recv(18,i,iii)
7559           gacontp_hb2(2,nnn,ii)=zapas_recv(19,i,iii)
7560           gacontp_hb2(3,nnn,ii)=zapas_recv(20,i,iii)
7561           gacontm_hb3(1,nnn,ii)=zapas_recv(21,i,iii)
7562           gacontm_hb3(2,nnn,ii)=zapas_recv(22,i,iii)
7563           gacontm_hb3(3,nnn,ii)=zapas_recv(23,i,iii)
7564           gacontp_hb3(1,nnn,ii)=zapas_recv(24,i,iii)
7565           gacontp_hb3(2,nnn,ii)=zapas_recv(25,i,iii)
7566           gacontp_hb3(3,nnn,ii)=zapas_recv(26,i,iii)
7567         enddo
7568       enddo
7569       call flush(iout)
7570       if (lprn) then
7571         write (iout,'(a)') 'Contact function values after receive:'
7572         do i=nnt,nct-2
7573           write (iout,'(2i3,50(1x,i3,f5.2))')
7574      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
7575      &    j=1,num_cont_hb(i))
7576         enddo
7577         call flush(iout)
7578       endif
7579    30 continue
7580 #endif
7581       if (lprn) then
7582         write (iout,'(a)') 'Contact function values:'
7583         do i=nnt,nct-2
7584           write (iout,'(2i3,50(1x,i3,f5.2))')
7585      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
7586      &    j=1,num_cont_hb(i))
7587         enddo
7588       endif
7589       ecorr=0.0D0
7590 C Remove the loop below after debugging !!!
7591       do i=nnt,nct
7592         do j=1,3
7593           gradcorr(j,i)=0.0D0
7594           gradxorr(j,i)=0.0D0
7595         enddo
7596       enddo
7597 C Calculate the local-electrostatic correlation terms
7598       do i=min0(iatel_s,iturn4_start),max0(iatel_e,iturn3_end)
7599         i1=i+1
7600         num_conti=num_cont_hb(i)
7601         num_conti1=num_cont_hb(i+1)
7602         do jj=1,num_conti
7603           j=jcont_hb(jj,i)
7604           jp=iabs(j)
7605           do kk=1,num_conti1
7606             j1=jcont_hb(kk,i1)
7607             jp1=iabs(j1)
7608 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
7609 c     &         ' jj=',jj,' kk=',kk
7610             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
7611      &          .or. j.lt.0 .and. j1.gt.0) .and.
7612      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
7613 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
7614 C The system gains extra energy.
7615               ecorr=ecorr+ehbcorr(i,jp,i+1,jp1,jj,kk,0.72D0,0.32D0)
7616               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
7617      &            'ecorrh',i,j,ehbcorr(i,j,i+1,j1,jj,kk,0.72D0,0.32D0)
7618               n_corr=n_corr+1
7619             else if (j1.eq.j) then
7620 C Contacts I-J and I-(J+1) occur simultaneously.
7621 C The system loses extra energy.
7622 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
7623             endif
7624           enddo ! kk
7625           do kk=1,num_conti
7626             j1=jcont_hb(kk,i)
7627 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
7628 c    &         ' jj=',jj,' kk=',kk
7629             if (j1.eq.j+1) then
7630 C Contacts I-J and (I+1)-J occur simultaneously.
7631 C The system loses extra energy.
7632 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
7633             endif ! j1==j+1
7634           enddo ! kk
7635         enddo ! jj
7636       enddo ! i
7637       return
7638       end
7639 c------------------------------------------------------------------------------
7640       subroutine add_hb_contact(ii,jj,itask)
7641       implicit real*8 (a-h,o-z)
7642       include "DIMENSIONS"
7643       include "COMMON.IOUNITS"
7644       integer max_cont
7645       integer max_dim
7646       parameter (max_cont=maxconts)
7647       parameter (max_dim=26)
7648       include "COMMON.CONTACTS"
7649       double precision zapas(max_dim,maxconts,max_fg_procs),
7650      &  zapas_recv(max_dim,maxconts,max_fg_procs)
7651       common /przechowalnia/ zapas
7652       integer i,j,ii,jj,iproc,itask(4),nn
7653 c      write (iout,*) "itask",itask
7654       do i=1,2
7655         iproc=itask(i)
7656         if (iproc.gt.0) then
7657           do j=1,num_cont_hb(ii)
7658             jjc=jcont_hb(j,ii)
7659 c            write (iout,*) "i",ii," j",jj," jjc",jjc
7660             if (jjc.eq.jj) then
7661               ncont_sent(iproc)=ncont_sent(iproc)+1
7662               nn=ncont_sent(iproc)
7663               zapas(1,nn,iproc)=ii
7664               zapas(2,nn,iproc)=jjc
7665               zapas(3,nn,iproc)=facont_hb(j,ii)
7666               zapas(4,nn,iproc)=ees0p(j,ii)
7667               zapas(5,nn,iproc)=ees0m(j,ii)
7668               zapas(6,nn,iproc)=gacont_hbr(1,j,ii)
7669               zapas(7,nn,iproc)=gacont_hbr(2,j,ii)
7670               zapas(8,nn,iproc)=gacont_hbr(3,j,ii)
7671               zapas(9,nn,iproc)=gacontm_hb1(1,j,ii)
7672               zapas(10,nn,iproc)=gacontm_hb1(2,j,ii)
7673               zapas(11,nn,iproc)=gacontm_hb1(3,j,ii)
7674               zapas(12,nn,iproc)=gacontp_hb1(1,j,ii)
7675               zapas(13,nn,iproc)=gacontp_hb1(2,j,ii)
7676               zapas(14,nn,iproc)=gacontp_hb1(3,j,ii)
7677               zapas(15,nn,iproc)=gacontm_hb2(1,j,ii)
7678               zapas(16,nn,iproc)=gacontm_hb2(2,j,ii)
7679               zapas(17,nn,iproc)=gacontm_hb2(3,j,ii)
7680               zapas(18,nn,iproc)=gacontp_hb2(1,j,ii)
7681               zapas(19,nn,iproc)=gacontp_hb2(2,j,ii)
7682               zapas(20,nn,iproc)=gacontp_hb2(3,j,ii)
7683               zapas(21,nn,iproc)=gacontm_hb3(1,j,ii)
7684               zapas(22,nn,iproc)=gacontm_hb3(2,j,ii)
7685               zapas(23,nn,iproc)=gacontm_hb3(3,j,ii)
7686               zapas(24,nn,iproc)=gacontp_hb3(1,j,ii)
7687               zapas(25,nn,iproc)=gacontp_hb3(2,j,ii)
7688               zapas(26,nn,iproc)=gacontp_hb3(3,j,ii)
7689               exit
7690             endif
7691           enddo
7692         endif
7693       enddo
7694       return
7695       end
7696 c------------------------------------------------------------------------------
7697       subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,
7698      &  n_corr1)
7699 C This subroutine calculates multi-body contributions to hydrogen-bonding
7700       implicit real*8 (a-h,o-z)
7701       include 'DIMENSIONS'
7702       include 'COMMON.IOUNITS'
7703 #ifdef MPI
7704       include "mpif.h"
7705       parameter (max_cont=maxconts)
7706       parameter (max_dim=70)
7707       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
7708       double precision zapas(max_dim,maxconts,max_fg_procs),
7709      &  zapas_recv(max_dim,maxconts,max_fg_procs)
7710       common /przechowalnia/ zapas
7711       integer status(MPI_STATUS_SIZE),req(maxconts*2),
7712      &  status_array(MPI_STATUS_SIZE,maxconts*2)
7713 #endif
7714       include 'COMMON.SETUP'
7715       include 'COMMON.FFIELD'
7716       include 'COMMON.DERIV'
7717       include 'COMMON.LOCAL'
7718       include 'COMMON.INTERACT'
7719       include 'COMMON.CONTACTS'
7720       include 'COMMON.CHAIN'
7721       include 'COMMON.CONTROL'
7722       double precision gx(3),gx1(3)
7723       integer num_cont_hb_old(maxres)
7724       logical lprn,ldone
7725       double precision eello4,eello5,eelo6,eello_turn6
7726       external eello4,eello5,eello6,eello_turn6
7727 C Set lprn=.true. for debugging
7728       lprn=.false.
7729       eturn6=0.0d0
7730 #ifdef MPI
7731       do i=1,nres
7732         num_cont_hb_old(i)=num_cont_hb(i)
7733       enddo
7734       n_corr=0
7735       n_corr1=0
7736       if (nfgtasks.le.1) goto 30
7737       if (lprn) then
7738         write (iout,'(a)') 'Contact function values before RECEIVE:'
7739         do i=nnt,nct-2
7740           write (iout,'(2i3,50(1x,i2,f5.2))')
7741      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
7742      &    j=1,num_cont_hb(i))
7743         enddo
7744       endif
7745       call flush(iout)
7746       do i=1,ntask_cont_from
7747         ncont_recv(i)=0
7748       enddo
7749       do i=1,ntask_cont_to
7750         ncont_sent(i)=0
7751       enddo
7752 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
7753 c     & ntask_cont_to
7754 C Make the list of contacts to send to send to other procesors
7755       do i=iturn3_start,iturn3_end
7756 c        write (iout,*) "make contact list turn3",i," num_cont",
7757 c     &    num_cont_hb(i)
7758         call add_hb_contact_eello(i,i+2,iturn3_sent_local(1,i))
7759       enddo
7760       do i=iturn4_start,iturn4_end
7761 c        write (iout,*) "make contact list turn4",i," num_cont",
7762 c     &   num_cont_hb(i)
7763         call add_hb_contact_eello(i,i+3,iturn4_sent_local(1,i))
7764       enddo
7765       do ii=1,nat_sent
7766         i=iat_sent(ii)
7767 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
7768 c     &    num_cont_hb(i)
7769         do j=1,num_cont_hb(i)
7770         do k=1,4
7771           jjc=jcont_hb(j,i)
7772           iproc=iint_sent_local(k,jjc,ii)
7773 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
7774           if (iproc.ne.0) then
7775             ncont_sent(iproc)=ncont_sent(iproc)+1
7776             nn=ncont_sent(iproc)
7777             zapas(1,nn,iproc)=i
7778             zapas(2,nn,iproc)=jjc
7779             zapas(3,nn,iproc)=d_cont(j,i)
7780             ind=3
7781             do kk=1,3
7782               ind=ind+1
7783               zapas(ind,nn,iproc)=grij_hb_cont(kk,j,i)
7784             enddo
7785             do kk=1,2
7786               do ll=1,2
7787                 ind=ind+1
7788                 zapas(ind,nn,iproc)=a_chuj(ll,kk,j,i)
7789               enddo
7790             enddo
7791             do jj=1,5
7792               do kk=1,3
7793                 do ll=1,2
7794                   do mm=1,2
7795                     ind=ind+1
7796                     zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,i)
7797                   enddo
7798                 enddo
7799               enddo
7800             enddo
7801           endif
7802         enddo
7803         enddo
7804       enddo
7805       if (lprn) then
7806       write (iout,*)
7807      &  "Numbers of contacts to be sent to other processors",
7808      &  (ncont_sent(i),i=1,ntask_cont_to)
7809       write (iout,*) "Contacts sent"
7810       do ii=1,ntask_cont_to
7811         nn=ncont_sent(ii)
7812         iproc=itask_cont_to(ii)
7813         write (iout,*) nn," contacts to processor",iproc,
7814      &   " of CONT_TO_COMM group"
7815         do i=1,nn
7816           write(iout,'(2f5.0,10f10.5)')(zapas(j,i,ii),j=1,10)
7817         enddo
7818       enddo
7819       call flush(iout)
7820       endif
7821       CorrelType=477
7822       CorrelID=fg_rank+1
7823       CorrelType1=478
7824       CorrelID1=nfgtasks+fg_rank+1
7825       ireq=0
7826 C Receive the numbers of needed contacts from other processors
7827       do ii=1,ntask_cont_from
7828         iproc=itask_cont_from(ii)
7829         ireq=ireq+1
7830         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
7831      &    FG_COMM,req(ireq),IERR)
7832       enddo
7833 c      write (iout,*) "IRECV ended"
7834 c      call flush(iout)
7835 C Send the number of contacts needed by other processors
7836       do ii=1,ntask_cont_to
7837         iproc=itask_cont_to(ii)
7838         ireq=ireq+1
7839         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
7840      &    FG_COMM,req(ireq),IERR)
7841       enddo
7842 c      write (iout,*) "ISEND ended"
7843 c      write (iout,*) "number of requests (nn)",ireq
7844       call flush(iout)
7845       if (ireq.gt.0)
7846      &  call MPI_Waitall(ireq,req,status_array,ierr)
7847 c      write (iout,*)
7848 c     &  "Numbers of contacts to be received from other processors",
7849 c     &  (ncont_recv(i),i=1,ntask_cont_from)
7850 c      call flush(iout)
7851 C Receive contacts
7852       ireq=0
7853       do ii=1,ntask_cont_from
7854         iproc=itask_cont_from(ii)
7855         nn=ncont_recv(ii)
7856 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
7857 c     &   " of CONT_TO_COMM group"
7858         call flush(iout)
7859         if (nn.gt.0) then
7860           ireq=ireq+1
7861           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
7862      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
7863 c          write (iout,*) "ireq,req",ireq,req(ireq)
7864         endif
7865       enddo
7866 C Send the contacts to processors that need them
7867       do ii=1,ntask_cont_to
7868         iproc=itask_cont_to(ii)
7869         nn=ncont_sent(ii)
7870 c        write (iout,*) nn," contacts to processor",iproc,
7871 c     &   " of CONT_TO_COMM group"
7872         if (nn.gt.0) then
7873           ireq=ireq+1
7874           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
7875      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
7876 c          write (iout,*) "ireq,req",ireq,req(ireq)
7877 c          do i=1,nn
7878 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
7879 c          enddo
7880         endif
7881       enddo
7882 c      write (iout,*) "number of requests (contacts)",ireq
7883 c      write (iout,*) "req",(req(i),i=1,4)
7884 c      call flush(iout)
7885       if (ireq.gt.0)
7886      & call MPI_Waitall(ireq,req,status_array,ierr)
7887       do iii=1,ntask_cont_from
7888         iproc=itask_cont_from(iii)
7889         nn=ncont_recv(iii)
7890         if (lprn) then
7891         write (iout,*) "Received",nn," contacts from processor",iproc,
7892      &   " of CONT_FROM_COMM group"
7893         call flush(iout)
7894         do i=1,nn
7895           write(iout,'(2f5.0,10f10.5)')(zapas_recv(j,i,iii),j=1,10)
7896         enddo
7897         call flush(iout)
7898         endif
7899         do i=1,nn
7900           ii=zapas_recv(1,i,iii)
7901 c Flag the received contacts to prevent double-counting
7902           jj=-zapas_recv(2,i,iii)
7903 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
7904 c          call flush(iout)
7905           nnn=num_cont_hb(ii)+1
7906           num_cont_hb(ii)=nnn
7907           jcont_hb(nnn,ii)=jj
7908           d_cont(nnn,ii)=zapas_recv(3,i,iii)
7909           ind=3
7910           do kk=1,3
7911             ind=ind+1
7912             grij_hb_cont(kk,nnn,ii)=zapas_recv(ind,i,iii)
7913           enddo
7914           do kk=1,2
7915             do ll=1,2
7916               ind=ind+1
7917               a_chuj(ll,kk,nnn,ii)=zapas_recv(ind,i,iii)
7918             enddo
7919           enddo
7920           do jj=1,5
7921             do kk=1,3
7922               do ll=1,2
7923                 do mm=1,2
7924                   ind=ind+1
7925                   a_chuj_der(mm,ll,kk,jj,nnn,ii)=zapas_recv(ind,i,iii)
7926                 enddo
7927               enddo
7928             enddo
7929           enddo
7930         enddo
7931       enddo
7932       call flush(iout)
7933       if (lprn) then
7934         write (iout,'(a)') 'Contact function values after receive:'
7935         do i=nnt,nct-2
7936           write (iout,'(2i3,50(1x,i3,5f6.3))')
7937      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
7938      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
7939         enddo
7940         call flush(iout)
7941       endif
7942    30 continue
7943 #endif
7944       if (lprn) then
7945         write (iout,'(a)') 'Contact function values:'
7946         do i=nnt,nct-2
7947           write (iout,'(2i3,50(1x,i2,5f6.3))')
7948      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
7949      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
7950         enddo
7951       endif
7952       ecorr=0.0D0
7953       ecorr5=0.0d0
7954       ecorr6=0.0d0
7955 C Remove the loop below after debugging !!!
7956       do i=nnt,nct
7957         do j=1,3
7958           gradcorr(j,i)=0.0D0
7959           gradxorr(j,i)=0.0D0
7960         enddo
7961       enddo
7962 C Calculate the dipole-dipole interaction energies
7963       if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
7964       do i=iatel_s,iatel_e+1
7965         num_conti=num_cont_hb(i)
7966         do jj=1,num_conti
7967           j=jcont_hb(jj,i)
7968 #ifdef MOMENT
7969           call dipole(i,j,jj)
7970 #endif
7971         enddo
7972       enddo
7973       endif
7974 C Calculate the local-electrostatic correlation terms
7975 c                write (iout,*) "gradcorr5 in eello5 before loop"
7976 c                do iii=1,nres
7977 c                  write (iout,'(i5,3f10.5)')
7978 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
7979 c                enddo
7980       do i=min0(iatel_s,iturn4_start),max0(iatel_e+1,iturn3_end+1)
7981 c        write (iout,*) "corr loop i",i
7982         i1=i+1
7983         num_conti=num_cont_hb(i)
7984         num_conti1=num_cont_hb(i+1)
7985         do jj=1,num_conti
7986           j=jcont_hb(jj,i)
7987           jp=iabs(j)
7988           do kk=1,num_conti1
7989             j1=jcont_hb(kk,i1)
7990             jp1=iabs(j1)
7991 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
7992 c     &         ' jj=',jj,' kk=',kk
7993 c            if (j1.eq.j+1 .or. j1.eq.j-1) then
7994             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
7995      &          .or. j.lt.0 .and. j1.gt.0) .and.
7996      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
7997 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
7998 C The system gains extra energy.
7999               n_corr=n_corr+1
8000               sqd1=dsqrt(d_cont(jj,i))
8001               sqd2=dsqrt(d_cont(kk,i1))
8002               sred_geom = sqd1*sqd2
8003               IF (sred_geom.lt.cutoff_corr) THEN
8004                 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,
8005      &            ekont,fprimcont)
8006 cd               write (iout,*) 'i=',i,' j=',jp,' i1=',i1,' j1=',jp1,
8007 cd     &         ' jj=',jj,' kk=',kk
8008                 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
8009                 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
8010                 do l=1,3
8011                   g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
8012                   g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
8013                 enddo
8014                 n_corr1=n_corr1+1
8015 cd               write (iout,*) 'sred_geom=',sred_geom,
8016 cd     &          ' ekont=',ekont,' fprim=',fprimcont,
8017 cd     &          ' fac_prim1',fac_prim1,' fac_prim2',fac_prim2
8018 cd               write (iout,*) "g_contij",g_contij
8019 cd               write (iout,*) "grij_hb_cont i",grij_hb_cont(:,jj,i)
8020 cd               write (iout,*) "grij_hb_cont i1",grij_hb_cont(:,jj,i1)
8021                 call calc_eello(i,jp,i+1,jp1,jj,kk)
8022                 if (wcorr4.gt.0.0d0)
8023      &            ecorr=ecorr+eello4(i,jp,i+1,jp1,jj,kk)
8024                   if (energy_dec.and.wcorr4.gt.0.0d0)
8025      1                 write (iout,'(a6,4i5,0pf7.3)')
8026      2                'ecorr4',i,j,i+1,j1,eello4(i,jp,i+1,jp1,jj,kk)
8027 c                write (iout,*) "gradcorr5 before eello5"
8028 c                do iii=1,nres
8029 c                  write (iout,'(i5,3f10.5)')
8030 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
8031 c                enddo
8032                 if (wcorr5.gt.0.0d0)
8033      &            ecorr5=ecorr5+eello5(i,jp,i+1,jp1,jj,kk)
8034 c                write (iout,*) "gradcorr5 after eello5"
8035 c                do iii=1,nres
8036 c                  write (iout,'(i5,3f10.5)')
8037 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
8038 c                enddo
8039                   if (energy_dec.and.wcorr5.gt.0.0d0)
8040      1                 write (iout,'(a6,4i5,0pf7.3)')
8041      2                'ecorr5',i,j,i+1,j1,eello5(i,jp,i+1,jp1,jj,kk)
8042 cd                write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
8043 cd                write(2,*)'ijkl',i,jp,i+1,jp1
8044                 if (wcorr6.gt.0.0d0 .and. (jp.ne.i+4 .or. jp1.ne.i+3
8045      &               .or. wturn6.eq.0.0d0))then
8046 cd                  write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
8047                   ecorr6=ecorr6+eello6(i,jp,i+1,jp1,jj,kk)
8048                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
8049      1                'ecorr6',i,j,i+1,j1,eello6(i,jp,i+1,jp1,jj,kk)
8050 cd                write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
8051 cd     &            'ecorr6=',ecorr6
8052 cd                write (iout,'(4e15.5)') sred_geom,
8053 cd     &          dabs(eello4(i,jp,i+1,jp1,jj,kk)),
8054 cd     &          dabs(eello5(i,jp,i+1,jp1,jj,kk)),
8055 cd     &          dabs(eello6(i,jp,i+1,jp1,jj,kk))
8056                 else if (wturn6.gt.0.0d0
8057      &            .and. (jp.eq.i+4 .and. jp1.eq.i+3)) then
8058 cd                  write (iout,*) '******eturn6: i,j,i+1,j1',i,jip,i+1,jp1
8059                   eturn6=eturn6+eello_turn6(i,jj,kk)
8060                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
8061      1                 'eturn6',i,j,i+1,j1,eello_turn6(i,jj,kk)
8062 cd                  write (2,*) 'multibody_eello:eturn6',eturn6
8063                 endif
8064               ENDIF
8065 1111          continue
8066             endif
8067           enddo ! kk
8068         enddo ! jj
8069       enddo ! i
8070       do i=1,nres
8071         num_cont_hb(i)=num_cont_hb_old(i)
8072       enddo
8073 c                write (iout,*) "gradcorr5 in eello5"
8074 c                do iii=1,nres
8075 c                  write (iout,'(i5,3f10.5)')
8076 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
8077 c                enddo
8078       return
8079       end
8080 c------------------------------------------------------------------------------
8081       subroutine add_hb_contact_eello(ii,jj,itask)
8082       implicit real*8 (a-h,o-z)
8083       include "DIMENSIONS"
8084       include "COMMON.IOUNITS"
8085       integer max_cont
8086       integer max_dim
8087       parameter (max_cont=maxconts)
8088       parameter (max_dim=70)
8089       include "COMMON.CONTACTS"
8090       double precision zapas(max_dim,maxconts,max_fg_procs),
8091      &  zapas_recv(max_dim,maxconts,max_fg_procs)
8092       common /przechowalnia/ zapas
8093       integer i,j,ii,jj,iproc,itask(4),nn
8094 c      write (iout,*) "itask",itask
8095       do i=1,2
8096         iproc=itask(i)
8097         if (iproc.gt.0) then
8098           do j=1,num_cont_hb(ii)
8099             jjc=jcont_hb(j,ii)
8100 c            write (iout,*) "send turns i",ii," j",jj," jjc",jjc
8101             if (jjc.eq.jj) then
8102               ncont_sent(iproc)=ncont_sent(iproc)+1
8103               nn=ncont_sent(iproc)
8104               zapas(1,nn,iproc)=ii
8105               zapas(2,nn,iproc)=jjc
8106               zapas(3,nn,iproc)=d_cont(j,ii)
8107               ind=3
8108               do kk=1,3
8109                 ind=ind+1
8110                 zapas(ind,nn,iproc)=grij_hb_cont(kk,j,ii)
8111               enddo
8112               do kk=1,2
8113                 do ll=1,2
8114                   ind=ind+1
8115                   zapas(ind,nn,iproc)=a_chuj(ll,kk,j,ii)
8116                 enddo
8117               enddo
8118               do jj=1,5
8119                 do kk=1,3
8120                   do ll=1,2
8121                     do mm=1,2
8122                       ind=ind+1
8123                       zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,ii)
8124                     enddo
8125                   enddo
8126                 enddo
8127               enddo
8128               exit
8129             endif
8130           enddo
8131         endif
8132       enddo
8133       return
8134       end
8135 c------------------------------------------------------------------------------
8136       double precision function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
8137       implicit real*8 (a-h,o-z)
8138       include 'DIMENSIONS'
8139       include 'COMMON.IOUNITS'
8140       include 'COMMON.DERIV'
8141       include 'COMMON.INTERACT'
8142       include 'COMMON.CONTACTS'
8143       double precision gx(3),gx1(3)
8144       logical lprn
8145       lprn=.false.
8146       eij=facont_hb(jj,i)
8147       ekl=facont_hb(kk,k)
8148       ees0pij=ees0p(jj,i)
8149       ees0pkl=ees0p(kk,k)
8150       ees0mij=ees0m(jj,i)
8151       ees0mkl=ees0m(kk,k)
8152       ekont=eij*ekl
8153       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
8154 cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
8155 C Following 4 lines for diagnostics.
8156 cd    ees0pkl=0.0D0
8157 cd    ees0pij=1.0D0
8158 cd    ees0mkl=0.0D0
8159 cd    ees0mij=1.0D0
8160 c      write (iout,'(2(a,2i3,a,f10.5,a,2f10.5),a,f10.5,a,$)')
8161 c     & 'Contacts ',i,j,
8162 c     & ' eij',eij,' eesij',ees0pij,ees0mij,' and ',k,l
8163 c     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' energy=',ekont*ees,
8164 c     & 'gradcorr_long'
8165 C Calculate the multi-body contribution to energy.
8166 c      ecorr=ecorr+ekont*ees
8167 C Calculate multi-body contributions to the gradient.
8168       coeffpees0pij=coeffp*ees0pij
8169       coeffmees0mij=coeffm*ees0mij
8170       coeffpees0pkl=coeffp*ees0pkl
8171       coeffmees0mkl=coeffm*ees0mkl
8172       do ll=1,3
8173 cgrad        ghalfi=ees*ekl*gacont_hbr(ll,jj,i)
8174         gradcorr(ll,i)=gradcorr(ll,i)!+0.5d0*ghalfi
8175      &  -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+
8176      &  coeffmees0mkl*gacontm_hb1(ll,jj,i))
8177         gradcorr(ll,j)=gradcorr(ll,j)!+0.5d0*ghalfi
8178      &  -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+
8179      &  coeffmees0mkl*gacontm_hb2(ll,jj,i))
8180 cgrad        ghalfk=ees*eij*gacont_hbr(ll,kk,k)
8181         gradcorr(ll,k)=gradcorr(ll,k)!+0.5d0*ghalfk
8182      &  -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+
8183      &  coeffmees0mij*gacontm_hb1(ll,kk,k))
8184         gradcorr(ll,l)=gradcorr(ll,l)!+0.5d0*ghalfk
8185      &  -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+
8186      &  coeffmees0mij*gacontm_hb2(ll,kk,k))
8187         gradlongij=ees*ekl*gacont_hbr(ll,jj,i)-
8188      &     ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+
8189      &     coeffmees0mkl*gacontm_hb3(ll,jj,i))
8190         gradcorr_long(ll,j)=gradcorr_long(ll,j)+gradlongij
8191         gradcorr_long(ll,i)=gradcorr_long(ll,i)-gradlongij
8192         gradlongkl=ees*eij*gacont_hbr(ll,kk,k)-
8193      &     ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+
8194      &     coeffmees0mij*gacontm_hb3(ll,kk,k))
8195         gradcorr_long(ll,l)=gradcorr_long(ll,l)+gradlongkl
8196         gradcorr_long(ll,k)=gradcorr_long(ll,k)-gradlongkl
8197 c        write (iout,'(2f10.5,2x,$)') gradlongij,gradlongkl
8198       enddo
8199 c      write (iout,*)
8200 cgrad      do m=i+1,j-1
8201 cgrad        do ll=1,3
8202 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
8203 cgrad     &     ees*ekl*gacont_hbr(ll,jj,i)-
8204 cgrad     &     ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
8205 cgrad     &     coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
8206 cgrad        enddo
8207 cgrad      enddo
8208 cgrad      do m=k+1,l-1
8209 cgrad        do ll=1,3
8210 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
8211 cgrad     &     ees*eij*gacont_hbr(ll,kk,k)-
8212 cgrad     &     ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
8213 cgrad     &     coeffm*ees0mij*gacontm_hb3(ll,kk,k))
8214 cgrad        enddo
8215 cgrad      enddo
8216 c      write (iout,*) "ehbcorr",ekont*ees
8217       ehbcorr=ekont*ees
8218       return
8219       end
8220 #ifdef MOMENT
8221 C---------------------------------------------------------------------------
8222       subroutine dipole(i,j,jj)
8223       implicit real*8 (a-h,o-z)
8224       include 'DIMENSIONS'
8225       include 'COMMON.IOUNITS'
8226       include 'COMMON.CHAIN'
8227       include 'COMMON.FFIELD'
8228       include 'COMMON.DERIV'
8229       include 'COMMON.INTERACT'
8230       include 'COMMON.CONTACTS'
8231       include 'COMMON.TORSION'
8232       include 'COMMON.VAR'
8233       include 'COMMON.GEO'
8234       dimension dipi(2,2),dipj(2,2),dipderi(2),dipderj(2),auxvec(2),
8235      &  auxmat(2,2)
8236       iti1 = itortyp(itype(i+1))
8237       if (j.lt.nres-1) then
8238         itj1 = itortyp(itype(j+1))
8239       else
8240         itj1=ntortyp
8241       endif
8242       do iii=1,2
8243         dipi(iii,1)=Ub2(iii,i)
8244         dipderi(iii)=Ub2der(iii,i)
8245         dipi(iii,2)=b1(iii,i+1)
8246         dipj(iii,1)=Ub2(iii,j)
8247         dipderj(iii)=Ub2der(iii,j)
8248         dipj(iii,2)=b1(iii,j+1)
8249       enddo
8250       kkk=0
8251       do iii=1,2
8252         call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
8253         do jjj=1,2
8254           kkk=kkk+1
8255           dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
8256         enddo
8257       enddo
8258       do kkk=1,5
8259         do lll=1,3
8260           mmm=0
8261           do iii=1,2
8262             call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),
8263      &        auxvec(1))
8264             do jjj=1,2
8265               mmm=mmm+1
8266               dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
8267             enddo
8268           enddo
8269         enddo
8270       enddo
8271       call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
8272       call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
8273       do iii=1,2
8274         dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
8275       enddo
8276       call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
8277       do iii=1,2
8278         dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
8279       enddo
8280       return
8281       end
8282 #endif
8283 C---------------------------------------------------------------------------
8284       subroutine calc_eello(i,j,k,l,jj,kk)
8285 C
8286 C This subroutine computes matrices and vectors needed to calculate
8287 C the fourth-, fifth-, and sixth-order local-electrostatic terms.
8288 C
8289       implicit real*8 (a-h,o-z)
8290       include 'DIMENSIONS'
8291       include 'COMMON.IOUNITS'
8292       include 'COMMON.CHAIN'
8293       include 'COMMON.DERIV'
8294       include 'COMMON.INTERACT'
8295       include 'COMMON.CONTACTS'
8296       include 'COMMON.TORSION'
8297       include 'COMMON.VAR'
8298       include 'COMMON.GEO'
8299       include 'COMMON.FFIELD'
8300       double precision aa1(2,2),aa2(2,2),aa1t(2,2),aa2t(2,2),
8301      &  aa1tder(2,2,3,5),aa2tder(2,2,3,5),auxmat(2,2)
8302       logical lprn
8303       common /kutas/ lprn
8304 cd      write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
8305 cd     & ' jj=',jj,' kk=',kk
8306 cd      if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
8307 cd      write (iout,*) "a_chujij",((a_chuj(iii,jjj,jj,i),iii=1,2),jjj=1,2)
8308 cd      write (iout,*) "a_chujkl",((a_chuj(iii,jjj,kk,k),iii=1,2),jjj=1,2)
8309       do iii=1,2
8310         do jjj=1,2
8311           aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
8312           aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
8313         enddo
8314       enddo
8315       call transpose2(aa1(1,1),aa1t(1,1))
8316       call transpose2(aa2(1,1),aa2t(1,1))
8317       do kkk=1,5
8318         do lll=1,3
8319           call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),
8320      &      aa1tder(1,1,lll,kkk))
8321           call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),
8322      &      aa2tder(1,1,lll,kkk))
8323         enddo
8324       enddo
8325       if (l.eq.j+1) then
8326 C parallel orientation of the two CA-CA-CA frames.
8327         if (i.gt.1) then
8328           iti=itortyp(itype(i))
8329         else
8330           iti=ntortyp
8331         endif
8332         itk1=itortyp(itype(k+1))
8333         itj=itortyp(itype(j))
8334         if (l.lt.nres-1) then
8335           itl1=itortyp(itype(l+1))
8336         else
8337           itl1=ntortyp
8338         endif
8339 C A1 kernel(j+1) A2T
8340 cd        do iii=1,2
8341 cd          write (iout,'(3f10.5,5x,3f10.5)')
8342 cd     &     (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
8343 cd        enddo
8344         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
8345      &   aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),
8346      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
8347 C Following matrices are needed only for 6-th order cumulants
8348         IF (wcorr6.gt.0.0d0) THEN
8349         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
8350      &   aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),
8351      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
8352         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
8353      &   aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),
8354      &   Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
8355      &   ADtEAderx(1,1,1,1,1,1))
8356         lprn=.false.
8357         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
8358      &   aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),
8359      &   DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
8360      &   ADtEA1derx(1,1,1,1,1,1))
8361         ENDIF
8362 C End 6-th order cumulants
8363 cd        lprn=.false.
8364 cd        if (lprn) then
8365 cd        write (2,*) 'In calc_eello6'
8366 cd        do iii=1,2
8367 cd          write (2,*) 'iii=',iii
8368 cd          do kkk=1,5
8369 cd            write (2,*) 'kkk=',kkk
8370 cd            do jjj=1,2
8371 cd              write (2,'(3(2f10.5),5x)')
8372 cd     &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
8373 cd            enddo
8374 cd          enddo
8375 cd        enddo
8376 cd        endif
8377         call transpose2(EUgder(1,1,k),auxmat(1,1))
8378         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
8379         call transpose2(EUg(1,1,k),auxmat(1,1))
8380         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
8381         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
8382         do iii=1,2
8383           do kkk=1,5
8384             do lll=1,3
8385               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
8386      &          EAEAderx(1,1,lll,kkk,iii,1))
8387             enddo
8388           enddo
8389         enddo
8390 C A1T kernel(i+1) A2
8391         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
8392      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),
8393      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
8394 C Following matrices are needed only for 6-th order cumulants
8395         IF (wcorr6.gt.0.0d0) THEN
8396         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
8397      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),
8398      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
8399         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
8400      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),
8401      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
8402      &   ADtEAderx(1,1,1,1,1,2))
8403         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
8404      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),
8405      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
8406      &   ADtEA1derx(1,1,1,1,1,2))
8407         ENDIF
8408 C End 6-th order cumulants
8409         call transpose2(EUgder(1,1,l),auxmat(1,1))
8410         call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
8411         call transpose2(EUg(1,1,l),auxmat(1,1))
8412         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
8413         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
8414         do iii=1,2
8415           do kkk=1,5
8416             do lll=1,3
8417               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
8418      &          EAEAderx(1,1,lll,kkk,iii,2))
8419             enddo
8420           enddo
8421         enddo
8422 C AEAb1 and AEAb2
8423 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
8424 C They are needed only when the fifth- or the sixth-order cumulants are
8425 C indluded.
8426         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
8427         call transpose2(AEA(1,1,1),auxmat(1,1))
8428         call matvec2(auxmat(1,1),b1(1,i),AEAb1(1,1,1))
8429         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
8430         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
8431         call transpose2(AEAderg(1,1,1),auxmat(1,1))
8432         call matvec2(auxmat(1,1),b1(1,i),AEAb1derg(1,1,1))
8433         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
8434         call matvec2(AEA(1,1,1),b1(1,k+1),AEAb1(1,2,1))
8435         call matvec2(AEAderg(1,1,1),b1(1,k+1),AEAb1derg(1,2,1))
8436         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
8437         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
8438         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
8439         call transpose2(AEA(1,1,2),auxmat(1,1))
8440         call matvec2(auxmat(1,1),b1(1,j),AEAb1(1,1,2))
8441         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
8442         call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
8443         call transpose2(AEAderg(1,1,2),auxmat(1,1))
8444         call matvec2(auxmat(1,1),b1(1,j),AEAb1derg(1,1,2))
8445         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
8446         call matvec2(AEA(1,1,2),b1(1,l+1),AEAb1(1,2,2))
8447         call matvec2(AEAderg(1,1,2),b1(1,l+1),AEAb1derg(1,2,2))
8448         call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
8449         call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
8450         call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
8451 C Calculate the Cartesian derivatives of the vectors.
8452         do iii=1,2
8453           do kkk=1,5
8454             do lll=1,3
8455               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
8456               call matvec2(auxmat(1,1),b1(1,i),
8457      &          AEAb1derx(1,lll,kkk,iii,1,1))
8458               call matvec2(auxmat(1,1),Ub2(1,i),
8459      &          AEAb2derx(1,lll,kkk,iii,1,1))
8460               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
8461      &          AEAb1derx(1,lll,kkk,iii,2,1))
8462               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
8463      &          AEAb2derx(1,lll,kkk,iii,2,1))
8464               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
8465               call matvec2(auxmat(1,1),b1(1,j),
8466      &          AEAb1derx(1,lll,kkk,iii,1,2))
8467               call matvec2(auxmat(1,1),Ub2(1,j),
8468      &          AEAb2derx(1,lll,kkk,iii,1,2))
8469               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,l+1),
8470      &          AEAb1derx(1,lll,kkk,iii,2,2))
8471               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),
8472      &          AEAb2derx(1,lll,kkk,iii,2,2))
8473             enddo
8474           enddo
8475         enddo
8476         ENDIF
8477 C End vectors
8478       else
8479 C Antiparallel orientation of the two CA-CA-CA frames.
8480         if (i.gt.1) then
8481           iti=itortyp(itype(i))
8482         else
8483           iti=ntortyp
8484         endif
8485         itk1=itortyp(itype(k+1))
8486         itl=itortyp(itype(l))
8487         itj=itortyp(itype(j))
8488         if (j.lt.nres-1) then
8489           itj1=itortyp(itype(j+1))
8490         else
8491           itj1=ntortyp
8492         endif
8493 C A2 kernel(j-1)T A1T
8494         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
8495      &   aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),
8496      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
8497 C Following matrices are needed only for 6-th order cumulants
8498         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
8499      &     j.eq.i+4 .and. l.eq.i+3)) THEN
8500         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
8501      &   aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),
8502      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
8503         call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
8504      &   aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),
8505      &   Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
8506      &   ADtEAderx(1,1,1,1,1,1))
8507         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
8508      &   aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),
8509      &   DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
8510      &   ADtEA1derx(1,1,1,1,1,1))
8511         ENDIF
8512 C End 6-th order cumulants
8513         call transpose2(EUgder(1,1,k),auxmat(1,1))
8514         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
8515         call transpose2(EUg(1,1,k),auxmat(1,1))
8516         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
8517         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
8518         do iii=1,2
8519           do kkk=1,5
8520             do lll=1,3
8521               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
8522      &          EAEAderx(1,1,lll,kkk,iii,1))
8523             enddo
8524           enddo
8525         enddo
8526 C A2T kernel(i+1)T A1
8527         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
8528      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),
8529      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
8530 C Following matrices are needed only for 6-th order cumulants
8531         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
8532      &     j.eq.i+4 .and. l.eq.i+3)) THEN
8533         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
8534      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),
8535      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
8536         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
8537      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),
8538      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
8539      &   ADtEAderx(1,1,1,1,1,2))
8540         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
8541      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),
8542      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
8543      &   ADtEA1derx(1,1,1,1,1,2))
8544         ENDIF
8545 C End 6-th order cumulants
8546         call transpose2(EUgder(1,1,j),auxmat(1,1))
8547         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
8548         call transpose2(EUg(1,1,j),auxmat(1,1))
8549         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
8550         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
8551         do iii=1,2
8552           do kkk=1,5
8553             do lll=1,3
8554               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
8555      &          EAEAderx(1,1,lll,kkk,iii,2))
8556             enddo
8557           enddo
8558         enddo
8559 C AEAb1 and AEAb2
8560 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
8561 C They are needed only when the fifth- or the sixth-order cumulants are
8562 C indluded.
8563         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or.
8564      &    (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
8565         call transpose2(AEA(1,1,1),auxmat(1,1))
8566         call matvec2(auxmat(1,1),b1(1,i),AEAb1(1,1,1))
8567         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
8568         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
8569         call transpose2(AEAderg(1,1,1),auxmat(1,1))
8570         call matvec2(auxmat(1,1),b1(1,i),AEAb1derg(1,1,1))
8571         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
8572         call matvec2(AEA(1,1,1),b1(1,k+1),AEAb1(1,2,1))
8573         call matvec2(AEAderg(1,1,1),b1(1,k+1),AEAb1derg(1,2,1))
8574         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
8575         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
8576         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
8577         call transpose2(AEA(1,1,2),auxmat(1,1))
8578         call matvec2(auxmat(1,1),b1(1,j+1),AEAb1(1,1,2))
8579         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
8580         call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
8581         call transpose2(AEAderg(1,1,2),auxmat(1,1))
8582         call matvec2(auxmat(1,1),b1(1,l),AEAb1(1,1,2))
8583         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
8584         call matvec2(AEA(1,1,2),b1(1,j+1),AEAb1(1,2,2))
8585         call matvec2(AEAderg(1,1,2),b1(1,j+1),AEAb1derg(1,2,2))
8586         call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
8587         call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
8588         call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
8589 C Calculate the Cartesian derivatives of the vectors.
8590         do iii=1,2
8591           do kkk=1,5
8592             do lll=1,3
8593               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
8594               call matvec2(auxmat(1,1),b1(1,i),
8595      &          AEAb1derx(1,lll,kkk,iii,1,1))
8596               call matvec2(auxmat(1,1),Ub2(1,i),
8597      &          AEAb2derx(1,lll,kkk,iii,1,1))
8598               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
8599      &          AEAb1derx(1,lll,kkk,iii,2,1))
8600               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
8601      &          AEAb2derx(1,lll,kkk,iii,2,1))
8602               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
8603               call matvec2(auxmat(1,1),b1(1,l),
8604      &          AEAb1derx(1,lll,kkk,iii,1,2))
8605               call matvec2(auxmat(1,1),Ub2(1,l),
8606      &          AEAb2derx(1,lll,kkk,iii,1,2))
8607               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,j+1),
8608      &          AEAb1derx(1,lll,kkk,iii,2,2))
8609               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),
8610      &          AEAb2derx(1,lll,kkk,iii,2,2))
8611             enddo
8612           enddo
8613         enddo
8614         ENDIF
8615 C End vectors
8616       endif
8617       return
8618       end
8619 C---------------------------------------------------------------------------
8620       subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,
8621      &  KK,KKderg,AKA,AKAderg,AKAderx)
8622       implicit none
8623       integer nderg
8624       logical transp
8625       double precision aa1(2,2),aa2t(2,2),aa1derx(2,2,3,5),
8626      &  aa2tderx(2,2,3,5),KK(2,2),KKderg(2,2,nderg),AKA(2,2),
8627      &  AKAderg(2,2,nderg),AKAderx(2,2,3,5,2)
8628       integer iii,kkk,lll
8629       integer jjj,mmm
8630       logical lprn
8631       common /kutas/ lprn
8632       call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
8633       do iii=1,nderg
8634         call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,
8635      &    AKAderg(1,1,iii))
8636       enddo
8637 cd      if (lprn) write (2,*) 'In kernel'
8638       do kkk=1,5
8639 cd        if (lprn) write (2,*) 'kkk=',kkk
8640         do lll=1,3
8641           call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),
8642      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
8643 cd          if (lprn) then
8644 cd            write (2,*) 'lll=',lll
8645 cd            write (2,*) 'iii=1'
8646 cd            do jjj=1,2
8647 cd              write (2,'(3(2f10.5),5x)')
8648 cd     &        (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
8649 cd            enddo
8650 cd          endif
8651           call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),
8652      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
8653 cd          if (lprn) then
8654 cd            write (2,*) 'lll=',lll
8655 cd            write (2,*) 'iii=2'
8656 cd            do jjj=1,2
8657 cd              write (2,'(3(2f10.5),5x)')
8658 cd     &        (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
8659 cd            enddo
8660 cd          endif
8661         enddo
8662       enddo
8663       return
8664       end
8665 C---------------------------------------------------------------------------
8666       double precision function eello4(i,j,k,l,jj,kk)
8667       implicit real*8 (a-h,o-z)
8668       include 'DIMENSIONS'
8669       include 'COMMON.IOUNITS'
8670       include 'COMMON.CHAIN'
8671       include 'COMMON.DERIV'
8672       include 'COMMON.INTERACT'
8673       include 'COMMON.CONTACTS'
8674       include 'COMMON.TORSION'
8675       include 'COMMON.VAR'
8676       include 'COMMON.GEO'
8677       double precision pizda(2,2),ggg1(3),ggg2(3)
8678 cd      if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
8679 cd        eello4=0.0d0
8680 cd        return
8681 cd      endif
8682 cd      print *,'eello4:',i,j,k,l,jj,kk
8683 cd      write (2,*) 'i',i,' j',j,' k',k,' l',l
8684 cd      call checkint4(i,j,k,l,jj,kk,eel4_num)
8685 cold      eij=facont_hb(jj,i)
8686 cold      ekl=facont_hb(kk,k)
8687 cold      ekont=eij*ekl
8688       eel4=-EAEA(1,1,1)-EAEA(2,2,1)
8689 cd      eel41=-EAEA(1,1,2)-EAEA(2,2,2)
8690       gcorr_loc(k-1)=gcorr_loc(k-1)
8691      &   -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
8692       if (l.eq.j+1) then
8693         gcorr_loc(l-1)=gcorr_loc(l-1)
8694      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
8695       else
8696         gcorr_loc(j-1)=gcorr_loc(j-1)
8697      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
8698       endif
8699       do iii=1,2
8700         do kkk=1,5
8701           do lll=1,3
8702             derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1)
8703      &                        -EAEAderx(2,2,lll,kkk,iii,1)
8704 cd            derx(lll,kkk,iii)=0.0d0
8705           enddo
8706         enddo
8707       enddo
8708 cd      gcorr_loc(l-1)=0.0d0
8709 cd      gcorr_loc(j-1)=0.0d0
8710 cd      gcorr_loc(k-1)=0.0d0
8711 cd      eel4=1.0d0
8712 cd      write (iout,*)'Contacts have occurred for peptide groups',
8713 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l,
8714 cd     &  ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
8715       if (j.lt.nres-1) then
8716         j1=j+1
8717         j2=j-1
8718       else
8719         j1=j-1
8720         j2=j-2
8721       endif
8722       if (l.lt.nres-1) then
8723         l1=l+1
8724         l2=l-1
8725       else
8726         l1=l-1
8727         l2=l-2
8728       endif
8729       do ll=1,3
8730 cgrad        ggg1(ll)=eel4*g_contij(ll,1)
8731 cgrad        ggg2(ll)=eel4*g_contij(ll,2)
8732         glongij=eel4*g_contij(ll,1)+ekont*derx(ll,1,1)
8733         glongkl=eel4*g_contij(ll,2)+ekont*derx(ll,1,2)
8734 cgrad        ghalf=0.5d0*ggg1(ll)
8735         gradcorr(ll,i)=gradcorr(ll,i)+ekont*derx(ll,2,1)
8736         gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
8737         gradcorr(ll,j)=gradcorr(ll,j)+ekont*derx(ll,4,1)
8738         gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
8739         gradcorr_long(ll,j)=gradcorr_long(ll,j)+glongij
8740         gradcorr_long(ll,i)=gradcorr_long(ll,i)-glongij
8741 cgrad        ghalf=0.5d0*ggg2(ll)
8742         gradcorr(ll,k)=gradcorr(ll,k)+ekont*derx(ll,2,2)
8743         gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
8744         gradcorr(ll,l)=gradcorr(ll,l)+ekont*derx(ll,4,2)
8745         gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
8746         gradcorr_long(ll,l)=gradcorr_long(ll,l)+glongkl
8747         gradcorr_long(ll,k)=gradcorr_long(ll,k)-glongkl
8748       enddo
8749 cgrad      do m=i+1,j-1
8750 cgrad        do ll=1,3
8751 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
8752 cgrad        enddo
8753 cgrad      enddo
8754 cgrad      do m=k+1,l-1
8755 cgrad        do ll=1,3
8756 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
8757 cgrad        enddo
8758 cgrad      enddo
8759 cgrad      do m=i+2,j2
8760 cgrad        do ll=1,3
8761 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
8762 cgrad        enddo
8763 cgrad      enddo
8764 cgrad      do m=k+2,l2
8765 cgrad        do ll=1,3
8766 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
8767 cgrad        enddo
8768 cgrad      enddo
8769 cd      do iii=1,nres-3
8770 cd        write (2,*) iii,gcorr_loc(iii)
8771 cd      enddo
8772       eello4=ekont*eel4
8773 cd      write (2,*) 'ekont',ekont
8774 cd      write (iout,*) 'eello4',ekont*eel4
8775       return
8776       end
8777 C---------------------------------------------------------------------------
8778       double precision function eello5(i,j,k,l,jj,kk)
8779       implicit real*8 (a-h,o-z)
8780       include 'DIMENSIONS'
8781       include 'COMMON.IOUNITS'
8782       include 'COMMON.CHAIN'
8783       include 'COMMON.DERIV'
8784       include 'COMMON.INTERACT'
8785       include 'COMMON.CONTACTS'
8786       include 'COMMON.TORSION'
8787       include 'COMMON.VAR'
8788       include 'COMMON.GEO'
8789       double precision pizda(2,2),auxmat(2,2),auxmat1(2,2),vv(2)
8790       double precision ggg1(3),ggg2(3)
8791 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8792 C                                                                              C
8793 C                            Parallel chains                                   C
8794 C                                                                              C
8795 C          o             o                   o             o                   C
8796 C         /l\           / \             \   / \           / \   /              C
8797 C        /   \         /   \             \ /   \         /   \ /               C
8798 C       j| o |l1       | o |              o| o |         | o |o                C
8799 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
8800 C      \i/   \         /   \ /             /   \         /   \                 C
8801 C       o    k1             o                                                  C
8802 C         (I)          (II)                (III)          (IV)                 C
8803 C                                                                              C
8804 C      eello5_1        eello5_2            eello5_3       eello5_4             C
8805 C                                                                              C
8806 C                            Antiparallel chains                               C
8807 C                                                                              C
8808 C          o             o                   o             o                   C
8809 C         /j\           / \             \   / \           / \   /              C
8810 C        /   \         /   \             \ /   \         /   \ /               C
8811 C      j1| o |l        | o |              o| o |         | o |o                C
8812 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
8813 C      \i/   \         /   \ /             /   \         /   \                 C
8814 C       o     k1            o                                                  C
8815 C         (I)          (II)                (III)          (IV)                 C
8816 C                                                                              C
8817 C      eello5_1        eello5_2            eello5_3       eello5_4             C
8818 C                                                                              C
8819 C o denotes a local interaction, vertical lines an electrostatic interaction.  C
8820 C                                                                              C
8821 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8822 cd      if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
8823 cd        eello5=0.0d0
8824 cd        return
8825 cd      endif
8826 cd      write (iout,*)
8827 cd     &   'EELLO5: Contacts have occurred for peptide groups',i,j,
8828 cd     &   ' and',k,l
8829       itk=itortyp(itype(k))
8830       itl=itortyp(itype(l))
8831       itj=itortyp(itype(j))
8832       eello5_1=0.0d0
8833       eello5_2=0.0d0
8834       eello5_3=0.0d0
8835       eello5_4=0.0d0
8836 cd      call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
8837 cd     &   eel5_3_num,eel5_4_num)
8838       do iii=1,2
8839         do kkk=1,5
8840           do lll=1,3
8841             derx(lll,kkk,iii)=0.0d0
8842           enddo
8843         enddo
8844       enddo
8845 cd      eij=facont_hb(jj,i)
8846 cd      ekl=facont_hb(kk,k)
8847 cd      ekont=eij*ekl
8848 cd      write (iout,*)'Contacts have occurred for peptide groups',
8849 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l
8850 cd      goto 1111
8851 C Contribution from the graph I.
8852 cd      write (2,*) 'AEA  ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
8853 cd      write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
8854       call transpose2(EUg(1,1,k),auxmat(1,1))
8855       call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
8856       vv(1)=pizda(1,1)-pizda(2,2)
8857       vv(2)=pizda(1,2)+pizda(2,1)
8858       eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k))
8859      & +0.5d0*scalar2(vv(1),Dtobr2(1,i))
8860 C Explicit gradient in virtual-dihedral angles.
8861       if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1)
8862      & +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k))
8863      & +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
8864       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8865       call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
8866       vv(1)=pizda(1,1)-pizda(2,2)
8867       vv(2)=pizda(1,2)+pizda(2,1)
8868       g_corr5_loc(k-1)=g_corr5_loc(k-1)
8869      & +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k))
8870      & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
8871       call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
8872       vv(1)=pizda(1,1)-pizda(2,2)
8873       vv(2)=pizda(1,2)+pizda(2,1)
8874       if (l.eq.j+1) then
8875         if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1)
8876      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
8877      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
8878       else
8879         if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1)
8880      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
8881      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
8882       endif
8883 C Cartesian gradient
8884       do iii=1,2
8885         do kkk=1,5
8886           do lll=1,3
8887             call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),
8888      &        pizda(1,1))
8889             vv(1)=pizda(1,1)-pizda(2,2)
8890             vv(2)=pizda(1,2)+pizda(2,1)
8891             derx(lll,kkk,iii)=derx(lll,kkk,iii)
8892      &       +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k))
8893      &       +0.5d0*scalar2(vv(1),Dtobr2(1,i))
8894           enddo
8895         enddo
8896       enddo
8897 c      goto 1112
8898 c1111  continue
8899 C Contribution from graph II
8900       call transpose2(EE(1,1,itk),auxmat(1,1))
8901       call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
8902       vv(1)=pizda(1,1)+pizda(2,2)
8903       vv(2)=pizda(2,1)-pizda(1,2)
8904       eello5_2=scalar2(AEAb1(1,2,1),b1(1,k))
8905      & -0.5d0*scalar2(vv(1),Ctobr(1,k))
8906 C Explicit gradient in virtual-dihedral angles.
8907       g_corr5_loc(k-1)=g_corr5_loc(k-1)
8908      & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
8909       call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
8910       vv(1)=pizda(1,1)+pizda(2,2)
8911       vv(2)=pizda(2,1)-pizda(1,2)
8912       if (l.eq.j+1) then
8913         g_corr5_loc(l-1)=g_corr5_loc(l-1)
8914      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,k))
8915      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
8916       else
8917         g_corr5_loc(j-1)=g_corr5_loc(j-1)
8918      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,k))
8919      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
8920       endif
8921 C Cartesian gradient
8922       do iii=1,2
8923         do kkk=1,5
8924           do lll=1,3
8925             call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
8926      &        pizda(1,1))
8927             vv(1)=pizda(1,1)+pizda(2,2)
8928             vv(2)=pizda(2,1)-pizda(1,2)
8929             derx(lll,kkk,iii)=derx(lll,kkk,iii)
8930      &       +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,k))
8931      &       -0.5d0*scalar2(vv(1),Ctobr(1,k))
8932           enddo
8933         enddo
8934       enddo
8935 cd      goto 1112
8936 cd1111  continue
8937       if (l.eq.j+1) then
8938 cd        goto 1110
8939 C Parallel orientation
8940 C Contribution from graph III
8941         call transpose2(EUg(1,1,l),auxmat(1,1))
8942         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
8943         vv(1)=pizda(1,1)-pizda(2,2)
8944         vv(2)=pizda(1,2)+pizda(2,1)
8945         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l))
8946      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j))
8947 C Explicit gradient in virtual-dihedral angles.
8948         g_corr5_loc(j-1)=g_corr5_loc(j-1)
8949      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l))
8950      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
8951         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
8952         vv(1)=pizda(1,1)-pizda(2,2)
8953         vv(2)=pizda(1,2)+pizda(2,1)
8954         g_corr5_loc(k-1)=g_corr5_loc(k-1)
8955      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l))
8956      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
8957         call transpose2(EUgder(1,1,l),auxmat1(1,1))
8958         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
8959         vv(1)=pizda(1,1)-pizda(2,2)
8960         vv(2)=pizda(1,2)+pizda(2,1)
8961         g_corr5_loc(l-1)=g_corr5_loc(l-1)
8962      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l))
8963      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
8964 C Cartesian gradient
8965         do iii=1,2
8966           do kkk=1,5
8967             do lll=1,3
8968               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
8969      &          pizda(1,1))
8970               vv(1)=pizda(1,1)-pizda(2,2)
8971               vv(2)=pizda(1,2)+pizda(2,1)
8972               derx(lll,kkk,iii)=derx(lll,kkk,iii)
8973      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l))
8974      &         +0.5d0*scalar2(vv(1),Dtobr2(1,j))
8975             enddo
8976           enddo
8977         enddo
8978 cd        goto 1112
8979 C Contribution from graph IV
8980 cd1110    continue
8981         call transpose2(EE(1,1,itl),auxmat(1,1))
8982         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
8983         vv(1)=pizda(1,1)+pizda(2,2)
8984         vv(2)=pizda(2,1)-pizda(1,2)
8985         eello5_4=scalar2(AEAb1(1,2,2),b1(1,l))
8986      &   -0.5d0*scalar2(vv(1),Ctobr(1,l))
8987 C Explicit gradient in virtual-dihedral angles.
8988         g_corr5_loc(l-1)=g_corr5_loc(l-1)
8989      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
8990         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
8991         vv(1)=pizda(1,1)+pizda(2,2)
8992         vv(2)=pizda(2,1)-pizda(1,2)
8993         g_corr5_loc(k-1)=g_corr5_loc(k-1)
8994      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,l))
8995      &   -0.5d0*scalar2(vv(1),Ctobr(1,l)))
8996 C Cartesian gradient
8997         do iii=1,2
8998           do kkk=1,5
8999             do lll=1,3
9000               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
9001      &          pizda(1,1))
9002               vv(1)=pizda(1,1)+pizda(2,2)
9003               vv(2)=pizda(2,1)-pizda(1,2)
9004               derx(lll,kkk,iii)=derx(lll,kkk,iii)
9005      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,l))
9006      &         -0.5d0*scalar2(vv(1),Ctobr(1,l))
9007             enddo
9008           enddo
9009         enddo
9010       else
9011 C Antiparallel orientation
9012 C Contribution from graph III
9013 c        goto 1110
9014         call transpose2(EUg(1,1,j),auxmat(1,1))
9015         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
9016         vv(1)=pizda(1,1)-pizda(2,2)
9017         vv(2)=pizda(1,2)+pizda(2,1)
9018         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j))
9019      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l))
9020 C Explicit gradient in virtual-dihedral angles.
9021         g_corr5_loc(l-1)=g_corr5_loc(l-1)
9022      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j))
9023      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
9024         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
9025         vv(1)=pizda(1,1)-pizda(2,2)
9026         vv(2)=pizda(1,2)+pizda(2,1)
9027         g_corr5_loc(k-1)=g_corr5_loc(k-1)
9028      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j))
9029      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
9030         call transpose2(EUgder(1,1,j),auxmat1(1,1))
9031         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
9032         vv(1)=pizda(1,1)-pizda(2,2)
9033         vv(2)=pizda(1,2)+pizda(2,1)
9034         g_corr5_loc(j-1)=g_corr5_loc(j-1)
9035      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j))
9036      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
9037 C Cartesian gradient
9038         do iii=1,2
9039           do kkk=1,5
9040             do lll=1,3
9041               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
9042      &          pizda(1,1))
9043               vv(1)=pizda(1,1)-pizda(2,2)
9044               vv(2)=pizda(1,2)+pizda(2,1)
9045               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
9046      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j))
9047      &         +0.5d0*scalar2(vv(1),Dtobr2(1,l))
9048             enddo
9049           enddo
9050         enddo
9051 cd        goto 1112
9052 C Contribution from graph IV
9053 1110    continue
9054         call transpose2(EE(1,1,itj),auxmat(1,1))
9055         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
9056         vv(1)=pizda(1,1)+pizda(2,2)
9057         vv(2)=pizda(2,1)-pizda(1,2)
9058         eello5_4=scalar2(AEAb1(1,2,2),b1(1,j))
9059      &   -0.5d0*scalar2(vv(1),Ctobr(1,j))
9060 C Explicit gradient in virtual-dihedral angles.
9061         g_corr5_loc(j-1)=g_corr5_loc(j-1)
9062      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
9063         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
9064         vv(1)=pizda(1,1)+pizda(2,2)
9065         vv(2)=pizda(2,1)-pizda(1,2)
9066         g_corr5_loc(k-1)=g_corr5_loc(k-1)
9067      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,j))
9068      &   -0.5d0*scalar2(vv(1),Ctobr(1,j)))
9069 C Cartesian gradient
9070         do iii=1,2
9071           do kkk=1,5
9072             do lll=1,3
9073               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
9074      &          pizda(1,1))
9075               vv(1)=pizda(1,1)+pizda(2,2)
9076               vv(2)=pizda(2,1)-pizda(1,2)
9077               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
9078      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,j))
9079      &         -0.5d0*scalar2(vv(1),Ctobr(1,j))
9080             enddo
9081           enddo
9082         enddo
9083       endif
9084 1112  continue
9085       eel5=eello5_1+eello5_2+eello5_3+eello5_4
9086 cd      if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
9087 cd        write (2,*) 'ijkl',i,j,k,l
9088 cd        write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
9089 cd     &     ' eello5_3',eello5_3,' eello5_4',eello5_4
9090 cd      endif
9091 cd      write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
9092 cd      write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
9093 cd      write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
9094 cd      write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
9095       if (j.lt.nres-1) then
9096         j1=j+1
9097         j2=j-1
9098       else
9099         j1=j-1
9100         j2=j-2
9101       endif
9102       if (l.lt.nres-1) then
9103         l1=l+1
9104         l2=l-1
9105       else
9106         l1=l-1
9107         l2=l-2
9108       endif
9109 cd      eij=1.0d0
9110 cd      ekl=1.0d0
9111 cd      ekont=1.0d0
9112 cd      write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
9113 C 2/11/08 AL Gradients over DC's connecting interacting sites will be
9114 C        summed up outside the subrouine as for the other subroutines
9115 C        handling long-range interactions. The old code is commented out
9116 C        with "cgrad" to keep track of changes.
9117       do ll=1,3
9118 cgrad        ggg1(ll)=eel5*g_contij(ll,1)
9119 cgrad        ggg2(ll)=eel5*g_contij(ll,2)
9120         gradcorr5ij=eel5*g_contij(ll,1)+ekont*derx(ll,1,1)
9121         gradcorr5kl=eel5*g_contij(ll,2)+ekont*derx(ll,1,2)
9122 c        write (iout,'(a,3i3,a,5f8.3,2i3,a,5f8.3,a,f8.3)')
9123 c     &   "ecorr5",ll,i,j," derx",derx(ll,2,1),derx(ll,3,1),derx(ll,4,1),
9124 c     &   derx(ll,5,1),k,l," derx",derx(ll,2,2),derx(ll,3,2),
9125 c     &   derx(ll,4,2),derx(ll,5,2)," ekont",ekont
9126 c        write (iout,'(a,3i3,a,3f8.3,2i3,a,3f8.3)')
9127 c     &   "ecorr5",ll,i,j," gradcorr5",g_contij(ll,1),derx(ll,1,1),
9128 c     &   gradcorr5ij,
9129 c     &   k,l," gradcorr5",g_contij(ll,2),derx(ll,1,2),gradcorr5kl
9130 cold        ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
9131 cgrad        ghalf=0.5d0*ggg1(ll)
9132 cd        ghalf=0.0d0
9133         gradcorr5(ll,i)=gradcorr5(ll,i)+ekont*derx(ll,2,1)
9134         gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
9135         gradcorr5(ll,j)=gradcorr5(ll,j)+ekont*derx(ll,4,1)
9136         gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
9137         gradcorr5_long(ll,j)=gradcorr5_long(ll,j)+gradcorr5ij
9138         gradcorr5_long(ll,i)=gradcorr5_long(ll,i)-gradcorr5ij
9139 cold        ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
9140 cgrad        ghalf=0.5d0*ggg2(ll)
9141 cd        ghalf=0.0d0
9142         gradcorr5(ll,k)=gradcorr5(ll,k)+ekont*derx(ll,2,2)
9143         gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
9144         gradcorr5(ll,l)=gradcorr5(ll,l)+ekont*derx(ll,4,2)
9145         gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
9146         gradcorr5_long(ll,l)=gradcorr5_long(ll,l)+gradcorr5kl
9147         gradcorr5_long(ll,k)=gradcorr5_long(ll,k)-gradcorr5kl
9148       enddo
9149 cd      goto 1112
9150 cgrad      do m=i+1,j-1
9151 cgrad        do ll=1,3
9152 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
9153 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
9154 cgrad        enddo
9155 cgrad      enddo
9156 cgrad      do m=k+1,l-1
9157 cgrad        do ll=1,3
9158 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
9159 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
9160 cgrad        enddo
9161 cgrad      enddo
9162 c1112  continue
9163 cgrad      do m=i+2,j2
9164 cgrad        do ll=1,3
9165 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
9166 cgrad        enddo
9167 cgrad      enddo
9168 cgrad      do m=k+2,l2
9169 cgrad        do ll=1,3
9170 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
9171 cgrad        enddo
9172 cgrad      enddo
9173 cd      do iii=1,nres-3
9174 cd        write (2,*) iii,g_corr5_loc(iii)
9175 cd      enddo
9176       eello5=ekont*eel5
9177 cd      write (2,*) 'ekont',ekont
9178 cd      write (iout,*) 'eello5',ekont*eel5
9179       return
9180       end
9181 c--------------------------------------------------------------------------
9182       double precision function eello6(i,j,k,l,jj,kk)
9183       implicit real*8 (a-h,o-z)
9184       include 'DIMENSIONS'
9185       include 'COMMON.IOUNITS'
9186       include 'COMMON.CHAIN'
9187       include 'COMMON.DERIV'
9188       include 'COMMON.INTERACT'
9189       include 'COMMON.CONTACTS'
9190       include 'COMMON.TORSION'
9191       include 'COMMON.VAR'
9192       include 'COMMON.GEO'
9193       include 'COMMON.FFIELD'
9194       double precision ggg1(3),ggg2(3)
9195 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
9196 cd        eello6=0.0d0
9197 cd        return
9198 cd      endif
9199 cd      write (iout,*)
9200 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
9201 cd     &   ' and',k,l
9202       eello6_1=0.0d0
9203       eello6_2=0.0d0
9204       eello6_3=0.0d0
9205       eello6_4=0.0d0
9206       eello6_5=0.0d0
9207       eello6_6=0.0d0
9208 cd      call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
9209 cd     &   eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
9210       do iii=1,2
9211         do kkk=1,5
9212           do lll=1,3
9213             derx(lll,kkk,iii)=0.0d0
9214           enddo
9215         enddo
9216       enddo
9217 cd      eij=facont_hb(jj,i)
9218 cd      ekl=facont_hb(kk,k)
9219 cd      ekont=eij*ekl
9220 cd      eij=1.0d0
9221 cd      ekl=1.0d0
9222 cd      ekont=1.0d0
9223       if (l.eq.j+1) then
9224         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
9225         eello6_2=eello6_graph1(j,i,l,k,2,.false.)
9226         eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
9227         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
9228         eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
9229         eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
9230       else
9231         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
9232         eello6_2=eello6_graph1(l,k,j,i,2,.true.)
9233         eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
9234         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
9235         if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
9236           eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
9237         else
9238           eello6_5=0.0d0
9239         endif
9240         eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
9241       endif
9242 C If turn contributions are considered, they will be handled separately.
9243       eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
9244 cd      write(iout,*) 'eello6_1',eello6_1!,' eel6_1_num',16*eel6_1_num
9245 cd      write(iout,*) 'eello6_2',eello6_2!,' eel6_2_num',16*eel6_2_num
9246 cd      write(iout,*) 'eello6_3',eello6_3!,' eel6_3_num',16*eel6_3_num
9247 cd      write(iout,*) 'eello6_4',eello6_4!,' eel6_4_num',16*eel6_4_num
9248 cd      write(iout,*) 'eello6_5',eello6_5!,' eel6_5_num',16*eel6_5_num
9249 cd      write(iout,*) 'eello6_6',eello6_6!,' eel6_6_num',16*eel6_6_num
9250 cd      goto 1112
9251       if (j.lt.nres-1) then
9252         j1=j+1
9253         j2=j-1
9254       else
9255         j1=j-1
9256         j2=j-2
9257       endif
9258       if (l.lt.nres-1) then
9259         l1=l+1
9260         l2=l-1
9261       else
9262         l1=l-1
9263         l2=l-2
9264       endif
9265       do ll=1,3
9266 cgrad        ggg1(ll)=eel6*g_contij(ll,1)
9267 cgrad        ggg2(ll)=eel6*g_contij(ll,2)
9268 cold        ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
9269 cgrad        ghalf=0.5d0*ggg1(ll)
9270 cd        ghalf=0.0d0
9271         gradcorr6ij=eel6*g_contij(ll,1)+ekont*derx(ll,1,1)
9272         gradcorr6kl=eel6*g_contij(ll,2)+ekont*derx(ll,1,2)
9273         gradcorr6(ll,i)=gradcorr6(ll,i)+ekont*derx(ll,2,1)
9274         gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
9275         gradcorr6(ll,j)=gradcorr6(ll,j)+ekont*derx(ll,4,1)
9276         gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
9277         gradcorr6_long(ll,j)=gradcorr6_long(ll,j)+gradcorr6ij
9278         gradcorr6_long(ll,i)=gradcorr6_long(ll,i)-gradcorr6ij
9279 cgrad        ghalf=0.5d0*ggg2(ll)
9280 cold        ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
9281 cd        ghalf=0.0d0
9282         gradcorr6(ll,k)=gradcorr6(ll,k)+ekont*derx(ll,2,2)
9283         gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
9284         gradcorr6(ll,l)=gradcorr6(ll,l)+ekont*derx(ll,4,2)
9285         gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
9286         gradcorr6_long(ll,l)=gradcorr6_long(ll,l)+gradcorr6kl
9287         gradcorr6_long(ll,k)=gradcorr6_long(ll,k)-gradcorr6kl
9288       enddo
9289 cd      goto 1112
9290 cgrad      do m=i+1,j-1
9291 cgrad        do ll=1,3
9292 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
9293 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
9294 cgrad        enddo
9295 cgrad      enddo
9296 cgrad      do m=k+1,l-1
9297 cgrad        do ll=1,3
9298 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
9299 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
9300 cgrad        enddo
9301 cgrad      enddo
9302 cgrad1112  continue
9303 cgrad      do m=i+2,j2
9304 cgrad        do ll=1,3
9305 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
9306 cgrad        enddo
9307 cgrad      enddo
9308 cgrad      do m=k+2,l2
9309 cgrad        do ll=1,3
9310 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
9311 cgrad        enddo
9312 cgrad      enddo
9313 cd      do iii=1,nres-3
9314 cd        write (2,*) iii,g_corr6_loc(iii)
9315 cd      enddo
9316       eello6=ekont*eel6
9317 cd      write (2,*) 'ekont',ekont
9318 cd      write (iout,*) 'eello6',ekont*eel6
9319       return
9320       end
9321 c--------------------------------------------------------------------------
9322       double precision function eello6_graph1(i,j,k,l,imat,swap)
9323       implicit real*8 (a-h,o-z)
9324       include 'DIMENSIONS'
9325       include 'COMMON.IOUNITS'
9326       include 'COMMON.CHAIN'
9327       include 'COMMON.DERIV'
9328       include 'COMMON.INTERACT'
9329       include 'COMMON.CONTACTS'
9330       include 'COMMON.TORSION'
9331       include 'COMMON.VAR'
9332       include 'COMMON.GEO'
9333       double precision vv(2),vv1(2),pizda(2,2),auxmat(2,2),pizda1(2,2)
9334       logical swap
9335       logical lprn
9336       common /kutas/ lprn
9337 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9338 C                                                                              C
9339 C      Parallel       Antiparallel                                             C
9340 C                                                                              C
9341 C          o             o                                                     C
9342 C         /l\           /j\                                                    C
9343 C        /   \         /   \                                                   C
9344 C       /| o |         | o |\                                                  C
9345 C     \ j|/k\|  /   \  |/k\|l /                                                C
9346 C      \ /   \ /     \ /   \ /                                                 C
9347 C       o     o       o     o                                                  C
9348 C       i             i                                                        C
9349 C                                                                              C
9350 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9351       itk=itortyp(itype(k))
9352       s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
9353       s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
9354       s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
9355       call transpose2(EUgC(1,1,k),auxmat(1,1))
9356       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
9357       vv1(1)=pizda1(1,1)-pizda1(2,2)
9358       vv1(2)=pizda1(1,2)+pizda1(2,1)
9359       s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
9360       vv(1)=AEAb1(1,2,imat)*b1(1,k)-AEAb1(2,2,imat)*b1(2,k)
9361       vv(2)=AEAb1(1,2,imat)*b1(2,k)+AEAb1(2,2,imat)*b1(1,k)
9362       s5=scalar2(vv(1),Dtobr2(1,i))
9363 cd      write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
9364       eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
9365       if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1)
9366      & -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i))
9367      & -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k))
9368      & +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k))
9369      & +0.5d0*scalar2(vv1(1),Dtobr2der(1,i))
9370      & +scalar2(vv(1),Dtobr2der(1,i)))
9371       call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
9372       vv1(1)=pizda1(1,1)-pizda1(2,2)
9373       vv1(2)=pizda1(1,2)+pizda1(2,1)
9374       vv(1)=AEAb1derg(1,2,imat)*b1(1,k)-AEAb1derg(2,2,imat)*b1(2,k)
9375       vv(2)=AEAb1derg(1,2,imat)*b1(2,k)+AEAb1derg(2,2,imat)*b1(1,k)
9376       if (l.eq.j+1) then
9377         g_corr6_loc(l-1)=g_corr6_loc(l-1)
9378      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
9379      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
9380      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
9381      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
9382       else
9383         g_corr6_loc(j-1)=g_corr6_loc(j-1)
9384      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
9385      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
9386      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
9387      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
9388       endif
9389       call transpose2(EUgCder(1,1,k),auxmat(1,1))
9390       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
9391       vv1(1)=pizda1(1,1)-pizda1(2,2)
9392       vv1(2)=pizda1(1,2)+pizda1(2,1)
9393       if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1)
9394      & +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k))
9395      & +scalar2(AEAb2(1,1,imat),CUgb2der(1,k))
9396      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
9397       do iii=1,2
9398         if (swap) then
9399           ind=3-iii
9400         else
9401           ind=iii
9402         endif
9403         do kkk=1,5
9404           do lll=1,3
9405             s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
9406             s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
9407             s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
9408             call transpose2(EUgC(1,1,k),auxmat(1,1))
9409             call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
9410      &        pizda1(1,1))
9411             vv1(1)=pizda1(1,1)-pizda1(2,2)
9412             vv1(2)=pizda1(1,2)+pizda1(2,1)
9413             s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
9414             vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,k)
9415      &       -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,k)
9416             vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,k)
9417      &       +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,k)
9418             s5=scalar2(vv(1),Dtobr2(1,i))
9419             derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
9420           enddo
9421         enddo
9422       enddo
9423       return
9424       end
9425 c----------------------------------------------------------------------------
9426       double precision function eello6_graph2(i,j,k,l,jj,kk,swap)
9427       implicit real*8 (a-h,o-z)
9428       include 'DIMENSIONS'
9429       include 'COMMON.IOUNITS'
9430       include 'COMMON.CHAIN'
9431       include 'COMMON.DERIV'
9432       include 'COMMON.INTERACT'
9433       include 'COMMON.CONTACTS'
9434       include 'COMMON.TORSION'
9435       include 'COMMON.VAR'
9436       include 'COMMON.GEO'
9437       logical swap
9438       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
9439      & auxvec1(2),auxvec2(2),auxmat1(2,2)
9440       logical lprn
9441       common /kutas/ lprn
9442 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9443 C                                                                              C
9444 C      Parallel       Antiparallel                                             C
9445 C                                                                              C
9446 C          o             o                                                     C
9447 C     \   /l\           /j\   /                                                C
9448 C      \ /   \         /   \ /                                                 C
9449 C       o| o |         | o |o                                                  C
9450 C     \ j|/k\|      \  |/k\|l                                                  C
9451 C      \ /   \       \ /   \                                                   C
9452 C       o             o                                                        C
9453 C       i             i                                                        C
9454 C                                                                              C
9455 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9456 cd      write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
9457 C AL 7/4/01 s1 would occur in the sixth-order moment,
9458 C           but not in a cluster cumulant
9459 #ifdef MOMENT
9460       s1=dip(1,jj,i)*dip(1,kk,k)
9461 #endif
9462       call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
9463       s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
9464       call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
9465       s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
9466       call transpose2(EUg(1,1,k),auxmat(1,1))
9467       call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
9468       vv(1)=pizda(1,1)-pizda(2,2)
9469       vv(2)=pizda(1,2)+pizda(2,1)
9470       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
9471 cd      write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
9472 #ifdef MOMENT
9473       eello6_graph2=-(s1+s2+s3+s4)
9474 #else
9475       eello6_graph2=-(s2+s3+s4)
9476 #endif
9477 c      eello6_graph2=-s3
9478 C Derivatives in gamma(i-1)
9479       if (i.gt.1) then
9480 #ifdef MOMENT
9481         s1=dipderg(1,jj,i)*dip(1,kk,k)
9482 #endif
9483         s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
9484         call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
9485         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
9486         s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
9487 #ifdef MOMENT
9488         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
9489 #else
9490         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
9491 #endif
9492 c        g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
9493       endif
9494 C Derivatives in gamma(k-1)
9495 #ifdef MOMENT
9496       s1=dip(1,jj,i)*dipderg(1,kk,k)
9497 #endif
9498       call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
9499       s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
9500       call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
9501       s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
9502       call transpose2(EUgder(1,1,k),auxmat1(1,1))
9503       call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
9504       vv(1)=pizda(1,1)-pizda(2,2)
9505       vv(2)=pizda(1,2)+pizda(2,1)
9506       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
9507 #ifdef MOMENT
9508       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
9509 #else
9510       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
9511 #endif
9512 c      g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
9513 C Derivatives in gamma(j-1) or gamma(l-1)
9514       if (j.gt.1) then
9515 #ifdef MOMENT
9516         s1=dipderg(3,jj,i)*dip(1,kk,k)
9517 #endif
9518         call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
9519         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
9520         s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
9521         call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
9522         vv(1)=pizda(1,1)-pizda(2,2)
9523         vv(2)=pizda(1,2)+pizda(2,1)
9524         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
9525 #ifdef MOMENT
9526         if (swap) then
9527           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
9528         else
9529           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
9530         endif
9531 #endif
9532         g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
9533 c        g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
9534       endif
9535 C Derivatives in gamma(l-1) or gamma(j-1)
9536       if (l.gt.1) then
9537 #ifdef MOMENT
9538         s1=dip(1,jj,i)*dipderg(3,kk,k)
9539 #endif
9540         call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
9541         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
9542         call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
9543         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
9544         call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
9545         vv(1)=pizda(1,1)-pizda(2,2)
9546         vv(2)=pizda(1,2)+pizda(2,1)
9547         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
9548 #ifdef MOMENT
9549         if (swap) then
9550           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
9551         else
9552           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
9553         endif
9554 #endif
9555         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
9556 c        g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
9557       endif
9558 C Cartesian derivatives.
9559       if (lprn) then
9560         write (2,*) 'In eello6_graph2'
9561         do iii=1,2
9562           write (2,*) 'iii=',iii
9563           do kkk=1,5
9564             write (2,*) 'kkk=',kkk
9565             do jjj=1,2
9566               write (2,'(3(2f10.5),5x)')
9567      &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
9568             enddo
9569           enddo
9570         enddo
9571       endif
9572       do iii=1,2
9573         do kkk=1,5
9574           do lll=1,3
9575 #ifdef MOMENT
9576             if (iii.eq.1) then
9577               s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
9578             else
9579               s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
9580             endif
9581 #endif
9582             call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),
9583      &        auxvec(1))
9584             s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
9585             call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),
9586      &        auxvec(1))
9587             s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
9588             call transpose2(EUg(1,1,k),auxmat(1,1))
9589             call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),
9590      &        pizda(1,1))
9591             vv(1)=pizda(1,1)-pizda(2,2)
9592             vv(2)=pizda(1,2)+pizda(2,1)
9593             s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
9594 cd            write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
9595 #ifdef MOMENT
9596             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
9597 #else
9598             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
9599 #endif
9600             if (swap) then
9601               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
9602             else
9603               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
9604             endif
9605           enddo
9606         enddo
9607       enddo
9608       return
9609       end
9610 c----------------------------------------------------------------------------
9611       double precision function eello6_graph3(i,j,k,l,jj,kk,swap)
9612       implicit real*8 (a-h,o-z)
9613       include 'DIMENSIONS'
9614       include 'COMMON.IOUNITS'
9615       include 'COMMON.CHAIN'
9616       include 'COMMON.DERIV'
9617       include 'COMMON.INTERACT'
9618       include 'COMMON.CONTACTS'
9619       include 'COMMON.TORSION'
9620       include 'COMMON.VAR'
9621       include 'COMMON.GEO'
9622       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2)
9623       logical swap
9624 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9625 C                                                                              C
9626 C      Parallel       Antiparallel                                             C
9627 C                                                                              C
9628 C          o             o                                                     C
9629 C         /l\   /   \   /j\                                                    C
9630 C        /   \ /     \ /   \                                                   C
9631 C       /| o |o       o| o |\                                                  C
9632 C       j|/k\|  /      |/k\|l /                                                C
9633 C        /   \ /       /   \ /                                                 C
9634 C       /     o       /     o                                                  C
9635 C       i             i                                                        C
9636 C                                                                              C
9637 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9638 C
9639 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
9640 C           energy moment and not to the cluster cumulant.
9641       iti=itortyp(itype(i))
9642       if (j.lt.nres-1) then
9643         itj1=itortyp(itype(j+1))
9644       else
9645         itj1=ntortyp
9646       endif
9647       itk=itortyp(itype(k))
9648       itk1=itortyp(itype(k+1))
9649       if (l.lt.nres-1) then
9650         itl1=itortyp(itype(l+1))
9651       else
9652         itl1=ntortyp
9653       endif
9654 #ifdef MOMENT
9655       s1=dip(4,jj,i)*dip(4,kk,k)
9656 #endif
9657       call matvec2(AECA(1,1,1),b1(1,k+1),auxvec(1))
9658       s2=0.5d0*scalar2(b1(1,k),auxvec(1))
9659       call matvec2(AECA(1,1,2),b1(1,l+1),auxvec(1))
9660       s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
9661       call transpose2(EE(1,1,itk),auxmat(1,1))
9662       call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
9663       vv(1)=pizda(1,1)+pizda(2,2)
9664       vv(2)=pizda(2,1)-pizda(1,2)
9665       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
9666 cd      write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4,
9667 cd     & "sum",-(s2+s3+s4)
9668 #ifdef MOMENT
9669       eello6_graph3=-(s1+s2+s3+s4)
9670 #else
9671       eello6_graph3=-(s2+s3+s4)
9672 #endif
9673 c      eello6_graph3=-s4
9674 C Derivatives in gamma(k-1)
9675       call matvec2(AECAderg(1,1,2),b1(1,l+1),auxvec(1))
9676       s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
9677       s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
9678       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
9679 C Derivatives in gamma(l-1)
9680       call matvec2(AECAderg(1,1,1),b1(1,k+1),auxvec(1))
9681       s2=0.5d0*scalar2(b1(1,k),auxvec(1))
9682       call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
9683       vv(1)=pizda(1,1)+pizda(2,2)
9684       vv(2)=pizda(2,1)-pizda(1,2)
9685       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
9686       g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
9687 C Cartesian derivatives.
9688       do iii=1,2
9689         do kkk=1,5
9690           do lll=1,3
9691 #ifdef MOMENT
9692             if (iii.eq.1) then
9693               s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
9694             else
9695               s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
9696             endif
9697 #endif
9698             call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
9699      &        auxvec(1))
9700             s2=0.5d0*scalar2(b1(1,k),auxvec(1))
9701             call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,l+1),
9702      &        auxvec(1))
9703             s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
9704             call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),
9705      &        pizda(1,1))
9706             vv(1)=pizda(1,1)+pizda(2,2)
9707             vv(2)=pizda(2,1)-pizda(1,2)
9708             s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
9709 #ifdef MOMENT
9710             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
9711 #else
9712             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
9713 #endif
9714             if (swap) then
9715               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
9716             else
9717               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
9718             endif
9719 c            derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
9720           enddo
9721         enddo
9722       enddo
9723       return
9724       end
9725 c----------------------------------------------------------------------------
9726       double precision function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
9727       implicit real*8 (a-h,o-z)
9728       include 'DIMENSIONS'
9729       include 'COMMON.IOUNITS'
9730       include 'COMMON.CHAIN'
9731       include 'COMMON.DERIV'
9732       include 'COMMON.INTERACT'
9733       include 'COMMON.CONTACTS'
9734       include 'COMMON.TORSION'
9735       include 'COMMON.VAR'
9736       include 'COMMON.GEO'
9737       include 'COMMON.FFIELD'
9738       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
9739      & auxvec1(2),auxmat1(2,2)
9740       logical swap
9741 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9742 C                                                                              C
9743 C      Parallel       Antiparallel                                             C
9744 C                                                                              C
9745 C          o             o                                                     C
9746 C         /l\   /   \   /j\                                                    C
9747 C        /   \ /     \ /   \                                                   C
9748 C       /| o |o       o| o |\                                                  C
9749 C     \ j|/k\|      \  |/k\|l                                                  C
9750 C      \ /   \       \ /   \                                                   C
9751 C       o     \       o     \                                                  C
9752 C       i             i                                                        C
9753 C                                                                              C
9754 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9755 C
9756 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
9757 C           energy moment and not to the cluster cumulant.
9758 cd      write (2,*) 'eello_graph4: wturn6',wturn6
9759       iti=itortyp(itype(i))
9760       itj=itortyp(itype(j))
9761       if (j.lt.nres-1) then
9762         itj1=itortyp(itype(j+1))
9763       else
9764         itj1=ntortyp
9765       endif
9766       itk=itortyp(itype(k))
9767       if (k.lt.nres-1) then
9768         itk1=itortyp(itype(k+1))
9769       else
9770         itk1=ntortyp
9771       endif
9772       itl=itortyp(itype(l))
9773       if (l.lt.nres-1) then
9774         itl1=itortyp(itype(l+1))
9775       else
9776         itl1=ntortyp
9777       endif
9778 cd      write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
9779 cd      write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
9780 cd     & ' itl',itl,' itl1',itl1
9781 #ifdef MOMENT
9782       if (imat.eq.1) then
9783         s1=dip(3,jj,i)*dip(3,kk,k)
9784       else
9785         s1=dip(2,jj,j)*dip(2,kk,l)
9786       endif
9787 #endif
9788       call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
9789       s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
9790       if (j.eq.l+1) then
9791         call matvec2(ADtEA1(1,1,3-imat),b1(1,j+1),auxvec1(1))
9792         s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
9793       else
9794         call matvec2(ADtEA1(1,1,3-imat),b1(1,l+1),auxvec1(1))
9795         s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
9796       endif
9797       call transpose2(EUg(1,1,k),auxmat(1,1))
9798       call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
9799       vv(1)=pizda(1,1)-pizda(2,2)
9800       vv(2)=pizda(2,1)+pizda(1,2)
9801       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9802 cd      write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
9803 #ifdef MOMENT
9804       eello6_graph4=-(s1+s2+s3+s4)
9805 #else
9806       eello6_graph4=-(s2+s3+s4)
9807 #endif
9808 C Derivatives in gamma(i-1)
9809       if (i.gt.1) then
9810 #ifdef MOMENT
9811         if (imat.eq.1) then
9812           s1=dipderg(2,jj,i)*dip(3,kk,k)
9813         else
9814           s1=dipderg(4,jj,j)*dip(2,kk,l)
9815         endif
9816 #endif
9817         s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
9818         if (j.eq.l+1) then
9819           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,j+1),auxvec1(1))
9820           s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
9821         else
9822           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,l+1),auxvec1(1))
9823           s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
9824         endif
9825         s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
9826         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
9827 cd          write (2,*) 'turn6 derivatives'
9828 #ifdef MOMENT
9829           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
9830 #else
9831           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
9832 #endif
9833         else
9834 #ifdef MOMENT
9835           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
9836 #else
9837           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
9838 #endif
9839         endif
9840       endif
9841 C Derivatives in gamma(k-1)
9842 #ifdef MOMENT
9843       if (imat.eq.1) then
9844         s1=dip(3,jj,i)*dipderg(2,kk,k)
9845       else
9846         s1=dip(2,jj,j)*dipderg(4,kk,l)
9847       endif
9848 #endif
9849       call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
9850       s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
9851       if (j.eq.l+1) then
9852         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,j+1),auxvec1(1))
9853         s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
9854       else
9855         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,l+1),auxvec1(1))
9856         s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
9857       endif
9858       call transpose2(EUgder(1,1,k),auxmat1(1,1))
9859       call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
9860       vv(1)=pizda(1,1)-pizda(2,2)
9861       vv(2)=pizda(2,1)+pizda(1,2)
9862       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9863       if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
9864 #ifdef MOMENT
9865         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
9866 #else
9867         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
9868 #endif
9869       else
9870 #ifdef MOMENT
9871         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
9872 #else
9873         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
9874 #endif
9875       endif
9876 C Derivatives in gamma(j-1) or gamma(l-1)
9877       if (l.eq.j+1 .and. l.gt.1) then
9878         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
9879         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
9880         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
9881         vv(1)=pizda(1,1)-pizda(2,2)
9882         vv(2)=pizda(2,1)+pizda(1,2)
9883         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9884         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
9885       else if (j.gt.1) then
9886         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
9887         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
9888         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
9889         vv(1)=pizda(1,1)-pizda(2,2)
9890         vv(2)=pizda(2,1)+pizda(1,2)
9891         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9892         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
9893           gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
9894         else
9895           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
9896         endif
9897       endif
9898 C Cartesian derivatives.
9899       do iii=1,2
9900         do kkk=1,5
9901           do lll=1,3
9902 #ifdef MOMENT
9903             if (iii.eq.1) then
9904               if (imat.eq.1) then
9905                 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
9906               else
9907                 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
9908               endif
9909             else
9910               if (imat.eq.1) then
9911                 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
9912               else
9913                 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
9914               endif
9915             endif
9916 #endif
9917             call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),
9918      &        auxvec(1))
9919             s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
9920             if (j.eq.l+1) then
9921               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
9922      &          b1(1,j+1),auxvec(1))
9923               s3=-0.5d0*scalar2(b1(1,j),auxvec(1))
9924             else
9925               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
9926      &          b1(1,l+1),auxvec(1))
9927               s3=-0.5d0*scalar2(b1(1,l),auxvec(1))
9928             endif
9929             call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
9930      &        pizda(1,1))
9931             vv(1)=pizda(1,1)-pizda(2,2)
9932             vv(2)=pizda(2,1)+pizda(1,2)
9933             s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9934             if (swap) then
9935               if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
9936 #ifdef MOMENT
9937                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
9938      &             -(s1+s2+s4)
9939 #else
9940                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
9941      &             -(s2+s4)
9942 #endif
9943                 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
9944               else
9945 #ifdef MOMENT
9946                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
9947 #else
9948                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
9949 #endif
9950                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
9951               endif
9952             else
9953 #ifdef MOMENT
9954               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
9955 #else
9956               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
9957 #endif
9958               if (l.eq.j+1) then
9959                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
9960               else
9961                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
9962               endif
9963             endif
9964           enddo
9965         enddo
9966       enddo
9967       return
9968       end
9969 c----------------------------------------------------------------------------
9970       double precision function eello_turn6(i,jj,kk)
9971       implicit real*8 (a-h,o-z)
9972       include 'DIMENSIONS'
9973       include 'COMMON.IOUNITS'
9974       include 'COMMON.CHAIN'
9975       include 'COMMON.DERIV'
9976       include 'COMMON.INTERACT'
9977       include 'COMMON.CONTACTS'
9978       include 'COMMON.TORSION'
9979       include 'COMMON.VAR'
9980       include 'COMMON.GEO'
9981       double precision vtemp1(2),vtemp2(2),vtemp3(2),vtemp4(2),
9982      &  atemp(2,2),auxmat(2,2),achuj_temp(2,2),gtemp(2,2),gvec(2),
9983      &  ggg1(3),ggg2(3)
9984       double precision vtemp1d(2),vtemp2d(2),vtemp3d(2),vtemp4d(2),
9985      &  atempd(2,2),auxmatd(2,2),achuj_tempd(2,2),gtempd(2,2),gvecd(2)
9986 C 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
9987 C           the respective energy moment and not to the cluster cumulant.
9988       s1=0.0d0
9989       s8=0.0d0
9990       s13=0.0d0
9991 c
9992       eello_turn6=0.0d0
9993       j=i+4
9994       k=i+1
9995       l=i+3
9996       iti=itortyp(itype(i))
9997       itk=itortyp(itype(k))
9998       itk1=itortyp(itype(k+1))
9999       itl=itortyp(itype(l))
10000       itj=itortyp(itype(j))
10001 cd      write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
10002 cd      write (2,*) 'i',i,' k',k,' j',j,' l',l
10003 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
10004 cd        eello6=0.0d0
10005 cd        return
10006 cd      endif
10007 cd      write (iout,*)
10008 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
10009 cd     &   ' and',k,l
10010 cd      call checkint_turn6(i,jj,kk,eel_turn6_num)
10011       do iii=1,2
10012         do kkk=1,5
10013           do lll=1,3
10014             derx_turn(lll,kkk,iii)=0.0d0
10015           enddo
10016         enddo
10017       enddo
10018 cd      eij=1.0d0
10019 cd      ekl=1.0d0
10020 cd      ekont=1.0d0
10021       eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
10022 cd      eello6_5=0.0d0
10023 cd      write (2,*) 'eello6_5',eello6_5
10024 #ifdef MOMENT
10025       call transpose2(AEA(1,1,1),auxmat(1,1))
10026       call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
10027       ss1=scalar2(Ub2(1,i+2),b1(1,l))
10028       s1 = (auxmat(1,1)+auxmat(2,2))*ss1
10029 #endif
10030       call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1(1))
10031       call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
10032       s2 = scalar2(b1(1,k),vtemp1(1))
10033 #ifdef MOMENT
10034       call transpose2(AEA(1,1,2),atemp(1,1))
10035       call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
10036       call matvec2(Ug2(1,1,i+2),dd(1,1,itk1),vtemp2(1))
10037       s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
10038 #endif
10039       call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
10040       call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
10041       s12 = scalar2(Ub2(1,i+2),vtemp3(1))
10042 #ifdef MOMENT
10043       call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
10044       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
10045       call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
10046       call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
10047       ss13 = scalar2(b1(1,k),vtemp4(1))
10048       s13 = (gtemp(1,1)+gtemp(2,2))*ss13
10049 #endif
10050 c      write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
10051 c      s1=0.0d0
10052 c      s2=0.0d0
10053 c      s8=0.0d0
10054 c      s12=0.0d0
10055 c      s13=0.0d0
10056       eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
10057 C Derivatives in gamma(i+2)
10058       s1d =0.0d0
10059       s8d =0.0d0
10060 #ifdef MOMENT
10061       call transpose2(AEA(1,1,1),auxmatd(1,1))
10062       call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
10063       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
10064       call transpose2(AEAderg(1,1,2),atempd(1,1))
10065       call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
10066       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
10067 #endif
10068       call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
10069       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
10070       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
10071 c      s1d=0.0d0
10072 c      s2d=0.0d0
10073 c      s8d=0.0d0
10074 c      s12d=0.0d0
10075 c      s13d=0.0d0
10076       gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
10077 C Derivatives in gamma(i+3)
10078 #ifdef MOMENT
10079       call transpose2(AEA(1,1,1),auxmatd(1,1))
10080       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
10081       ss1d=scalar2(Ub2der(1,i+2),b1(1,l))
10082       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
10083 #endif
10084       call matvec2(EUgder(1,1,i+2),b1(1,l),vtemp1d(1))
10085       call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
10086       s2d = scalar2(b1(1,k),vtemp1d(1))
10087 #ifdef MOMENT
10088       call matvec2(Ug2der(1,1,i+2),dd(1,1,itk1),vtemp2d(1))
10089       s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2d(1))
10090 #endif
10091       s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
10092 #ifdef MOMENT
10093       call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
10094       call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
10095       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
10096 #endif
10097 c      s1d=0.0d0
10098 c      s2d=0.0d0
10099 c      s8d=0.0d0
10100 c      s12d=0.0d0
10101 c      s13d=0.0d0
10102 #ifdef MOMENT
10103       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
10104      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
10105 #else
10106       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
10107      &               -0.5d0*ekont*(s2d+s12d)
10108 #endif
10109 C Derivatives in gamma(i+4)
10110       call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
10111       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
10112       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
10113 #ifdef MOMENT
10114       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
10115       call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
10116       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
10117 #endif
10118 c      s1d=0.0d0
10119 c      s2d=0.0d0
10120 c      s8d=0.0d0
10121 C      s12d=0.0d0
10122 c      s13d=0.0d0
10123 #ifdef MOMENT
10124       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
10125 #else
10126       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
10127 #endif
10128 C Derivatives in gamma(i+5)
10129 #ifdef MOMENT
10130       call transpose2(AEAderg(1,1,1),auxmatd(1,1))
10131       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
10132       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
10133 #endif
10134       call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1d(1))
10135       call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
10136       s2d = scalar2(b1(1,k),vtemp1d(1))
10137 #ifdef MOMENT
10138       call transpose2(AEA(1,1,2),atempd(1,1))
10139       call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
10140       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
10141 #endif
10142       call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
10143       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
10144 #ifdef MOMENT
10145       call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
10146       ss13d = scalar2(b1(1,k),vtemp4d(1))
10147       s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
10148 #endif
10149 c      s1d=0.0d0
10150 c      s2d=0.0d0
10151 c      s8d=0.0d0
10152 c      s12d=0.0d0
10153 c      s13d=0.0d0
10154 #ifdef MOMENT
10155       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
10156      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
10157 #else
10158       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
10159      &               -0.5d0*ekont*(s2d+s12d)
10160 #endif
10161 C Cartesian derivatives
10162       do iii=1,2
10163         do kkk=1,5
10164           do lll=1,3
10165 #ifdef MOMENT
10166             call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
10167             call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
10168             s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
10169 #endif
10170             call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1(1))
10171             call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),
10172      &          vtemp1d(1))
10173             s2d = scalar2(b1(1,k),vtemp1d(1))
10174 #ifdef MOMENT
10175             call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
10176             call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
10177             s8d = -(atempd(1,1)+atempd(2,2))*
10178      &           scalar2(cc(1,1,itl),vtemp2(1))
10179 #endif
10180             call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),
10181      &           auxmatd(1,1))
10182             call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
10183             s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
10184 c      s1d=0.0d0
10185 c      s2d=0.0d0
10186 c      s8d=0.0d0
10187 c      s12d=0.0d0
10188 c      s13d=0.0d0
10189 #ifdef MOMENT
10190             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
10191      &        - 0.5d0*(s1d+s2d)
10192 #else
10193             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
10194      &        - 0.5d0*s2d
10195 #endif
10196 #ifdef MOMENT
10197             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
10198      &        - 0.5d0*(s8d+s12d)
10199 #else
10200             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
10201      &        - 0.5d0*s12d
10202 #endif
10203           enddo
10204         enddo
10205       enddo
10206 #ifdef MOMENT
10207       do kkk=1,5
10208         do lll=1,3
10209           call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),
10210      &      achuj_tempd(1,1))
10211           call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
10212           call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
10213           s13d=(gtempd(1,1)+gtempd(2,2))*ss13
10214           derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
10215           call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),
10216      &      vtemp4d(1))
10217           ss13d = scalar2(b1(1,k),vtemp4d(1))
10218           s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
10219           derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
10220         enddo
10221       enddo
10222 #endif
10223 cd      write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
10224 cd     &  16*eel_turn6_num
10225 cd      goto 1112
10226       if (j.lt.nres-1) then
10227         j1=j+1
10228         j2=j-1
10229       else
10230         j1=j-1
10231         j2=j-2
10232       endif
10233       if (l.lt.nres-1) then
10234         l1=l+1
10235         l2=l-1
10236       else
10237         l1=l-1
10238         l2=l-2
10239       endif
10240       do ll=1,3
10241 cgrad        ggg1(ll)=eel_turn6*g_contij(ll,1)
10242 cgrad        ggg2(ll)=eel_turn6*g_contij(ll,2)
10243 cgrad        ghalf=0.5d0*ggg1(ll)
10244 cd        ghalf=0.0d0
10245         gturn6ij=eel_turn6*g_contij(ll,1)+ekont*derx_turn(ll,1,1)
10246         gturn6kl=eel_turn6*g_contij(ll,2)+ekont*derx_turn(ll,1,2)
10247         gcorr6_turn(ll,i)=gcorr6_turn(ll,i)!+ghalf
10248      &    +ekont*derx_turn(ll,2,1)
10249         gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
10250         gcorr6_turn(ll,j)=gcorr6_turn(ll,j)!+ghalf
10251      &    +ekont*derx_turn(ll,4,1)
10252         gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
10253         gcorr6_turn_long(ll,j)=gcorr6_turn_long(ll,j)+gturn6ij
10254         gcorr6_turn_long(ll,i)=gcorr6_turn_long(ll,i)-gturn6ij
10255 cgrad        ghalf=0.5d0*ggg2(ll)
10256 cd        ghalf=0.0d0
10257         gcorr6_turn(ll,k)=gcorr6_turn(ll,k)!+ghalf
10258      &    +ekont*derx_turn(ll,2,2)
10259         gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
10260         gcorr6_turn(ll,l)=gcorr6_turn(ll,l)!+ghalf
10261      &    +ekont*derx_turn(ll,4,2)
10262         gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
10263         gcorr6_turn_long(ll,l)=gcorr6_turn_long(ll,l)+gturn6kl
10264         gcorr6_turn_long(ll,k)=gcorr6_turn_long(ll,k)-gturn6kl
10265       enddo
10266 cd      goto 1112
10267 cgrad      do m=i+1,j-1
10268 cgrad        do ll=1,3
10269 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
10270 cgrad        enddo
10271 cgrad      enddo
10272 cgrad      do m=k+1,l-1
10273 cgrad        do ll=1,3
10274 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
10275 cgrad        enddo
10276 cgrad      enddo
10277 cgrad1112  continue
10278 cgrad      do m=i+2,j2
10279 cgrad        do ll=1,3
10280 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
10281 cgrad        enddo
10282 cgrad      enddo
10283 cgrad      do m=k+2,l2
10284 cgrad        do ll=1,3
10285 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
10286 cgrad        enddo
10287 cgrad      enddo
10288 cd      do iii=1,nres-3
10289 cd        write (2,*) iii,g_corr6_loc(iii)
10290 cd      enddo
10291       eello_turn6=ekont*eel_turn6
10292 cd      write (2,*) 'ekont',ekont
10293 cd      write (2,*) 'eel_turn6',ekont*eel_turn6
10294       return
10295       end
10296
10297 C-----------------------------------------------------------------------------
10298       double precision function scalar(u,v)
10299 !DIR$ INLINEALWAYS scalar
10300 #ifndef OSF
10301 cDEC$ ATTRIBUTES FORCEINLINE::scalar
10302 #endif
10303       implicit none
10304       double precision u(3),v(3)
10305 cd      double precision sc
10306 cd      integer i
10307 cd      sc=0.0d0
10308 cd      do i=1,3
10309 cd        sc=sc+u(i)*v(i)
10310 cd      enddo
10311 cd      scalar=sc
10312
10313       scalar=u(1)*v(1)+u(2)*v(2)+u(3)*v(3)
10314       return
10315       end
10316 crc-------------------------------------------------
10317       SUBROUTINE MATVEC2(A1,V1,V2)
10318 !DIR$ INLINEALWAYS MATVEC2
10319 #ifndef OSF
10320 cDEC$ ATTRIBUTES FORCEINLINE::MATVEC2
10321 #endif
10322       implicit real*8 (a-h,o-z)
10323       include 'DIMENSIONS'
10324       DIMENSION A1(2,2),V1(2),V2(2)
10325 c      DO 1 I=1,2
10326 c        VI=0.0
10327 c        DO 3 K=1,2
10328 c    3     VI=VI+A1(I,K)*V1(K)
10329 c        Vaux(I)=VI
10330 c    1 CONTINUE
10331
10332       vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
10333       vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
10334
10335       v2(1)=vaux1
10336       v2(2)=vaux2
10337       END
10338 C---------------------------------------
10339       SUBROUTINE MATMAT2(A1,A2,A3)
10340 #ifndef OSF
10341 cDEC$ ATTRIBUTES FORCEINLINE::MATMAT2
10342 #endif
10343       implicit real*8 (a-h,o-z)
10344       include 'DIMENSIONS'
10345       DIMENSION A1(2,2),A2(2,2),A3(2,2)
10346 c      DIMENSION AI3(2,2)
10347 c        DO  J=1,2
10348 c          A3IJ=0.0
10349 c          DO K=1,2
10350 c           A3IJ=A3IJ+A1(I,K)*A2(K,J)
10351 c          enddo
10352 c          A3(I,J)=A3IJ
10353 c       enddo
10354 c      enddo
10355
10356       ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
10357       ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
10358       ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
10359       ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
10360
10361       A3(1,1)=AI3_11
10362       A3(2,1)=AI3_21
10363       A3(1,2)=AI3_12
10364       A3(2,2)=AI3_22
10365       END
10366
10367 c-------------------------------------------------------------------------
10368       double precision function scalar2(u,v)
10369 !DIR$ INLINEALWAYS scalar2
10370       implicit none
10371       double precision u(2),v(2)
10372       double precision sc
10373       integer i
10374       scalar2=u(1)*v(1)+u(2)*v(2)
10375       return
10376       end
10377
10378 C-----------------------------------------------------------------------------
10379
10380       subroutine transpose2(a,at)
10381 !DIR$ INLINEALWAYS transpose2
10382 #ifndef OSF
10383 cDEC$ ATTRIBUTES FORCEINLINE::transpose2
10384 #endif
10385       implicit none
10386       double precision a(2,2),at(2,2)
10387       at(1,1)=a(1,1)
10388       at(1,2)=a(2,1)
10389       at(2,1)=a(1,2)
10390       at(2,2)=a(2,2)
10391       return
10392       end
10393 c--------------------------------------------------------------------------
10394       subroutine transpose(n,a,at)
10395       implicit none
10396       integer n,i,j
10397       double precision a(n,n),at(n,n)
10398       do i=1,n
10399         do j=1,n
10400           at(j,i)=a(i,j)
10401         enddo
10402       enddo
10403       return
10404       end
10405 C---------------------------------------------------------------------------
10406       subroutine prodmat3(a1,a2,kk,transp,prod)
10407 !DIR$ INLINEALWAYS prodmat3
10408 #ifndef OSF
10409 cDEC$ ATTRIBUTES FORCEINLINE::prodmat3
10410 #endif
10411       implicit none
10412       integer i,j
10413       double precision a1(2,2),a2(2,2),a2t(2,2),kk(2,2),prod(2,2)
10414       logical transp
10415 crc      double precision auxmat(2,2),prod_(2,2)
10416
10417       if (transp) then
10418 crc        call transpose2(kk(1,1),auxmat(1,1))
10419 crc        call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
10420 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
10421
10422            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1)
10423      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
10424            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2)
10425      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
10426            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1)
10427      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
10428            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2)
10429      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
10430
10431       else
10432 crc        call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
10433 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
10434
10435            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1)
10436      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
10437            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2)
10438      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
10439            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1)
10440      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
10441            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2)
10442      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
10443
10444       endif
10445 c      call transpose2(a2(1,1),a2t(1,1))
10446
10447 crc      print *,transp
10448 crc      print *,((prod_(i,j),i=1,2),j=1,2)
10449 crc      print *,((prod(i,j),i=1,2),j=1,2)
10450
10451       return
10452       end
10453 CCC----------------------------------------------
10454       subroutine Eliptransfer(eliptran)
10455       implicit real*8 (a-h,o-z)
10456       include 'DIMENSIONS'
10457       include 'COMMON.GEO'
10458       include 'COMMON.VAR'
10459       include 'COMMON.LOCAL'
10460       include 'COMMON.CHAIN'
10461       include 'COMMON.DERIV'
10462       include 'COMMON.NAMES'
10463       include 'COMMON.INTERACT'
10464       include 'COMMON.IOUNITS'
10465       include 'COMMON.CALC'
10466       include 'COMMON.CONTROL'
10467       include 'COMMON.SPLITELE'
10468       include 'COMMON.SBRIDGE'
10469 C this is done by Adasko
10470 C      print *,"wchodze"
10471 C structure of box:
10472 C      water
10473 C--bordliptop-- buffore starts
10474 C--bufliptop--- here true lipid starts
10475 C      lipid
10476 C--buflipbot--- lipid ends buffore starts
10477 C--bordlipbot--buffore ends
10478       eliptran=0.0
10479       do i=ilip_start,ilip_end
10480 C       do i=1,1
10481         if (itype(i).eq.ntyp1) cycle
10482
10483         positi=(mod(((c(3,i)+c(3,i+1))/2.0d0),boxzsize))
10484         if (positi.le.0) positi=positi+boxzsize
10485 C        print *,i
10486 C first for peptide groups
10487 c for each residue check if it is in lipid or lipid water border area
10488        if ((positi.gt.bordlipbot)
10489      &.and.(positi.lt.bordliptop)) then
10490 C the energy transfer exist
10491         if (positi.lt.buflipbot) then
10492 C what fraction I am in
10493          fracinbuf=1.0d0-
10494      &        ((positi-bordlipbot)/lipbufthick)
10495 C lipbufthick is thickenes of lipid buffore
10496          sslip=sscalelip(fracinbuf)
10497          ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
10498          eliptran=eliptran+sslip*pepliptran
10499          gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
10500          gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
10501 C         gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
10502
10503 C        print *,"doing sccale for lower part"
10504 C         print *,i,sslip,fracinbuf,ssgradlip
10505         elseif (positi.gt.bufliptop) then
10506          fracinbuf=1.0d0-((bordliptop-positi)/lipbufthick)
10507          sslip=sscalelip(fracinbuf)
10508          ssgradlip=sscagradlip(fracinbuf)/lipbufthick
10509          eliptran=eliptran+sslip*pepliptran
10510          gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
10511          gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
10512 C         gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
10513 C          print *, "doing sscalefor top part"
10514 C         print *,i,sslip,fracinbuf,ssgradlip
10515         else
10516          eliptran=eliptran+pepliptran
10517 C         print *,"I am in true lipid"
10518         endif
10519 C       else
10520 C       eliptran=elpitran+0.0 ! I am in water
10521        endif
10522        enddo
10523 C       print *, "nic nie bylo w lipidzie?"
10524 C now multiply all by the peptide group transfer factor
10525 C       eliptran=eliptran*pepliptran
10526 C now the same for side chains
10527 CV       do i=1,1
10528        do i=ilip_start,ilip_end
10529         if (itype(i).eq.ntyp1) cycle
10530         positi=(mod(c(3,i+nres),boxzsize))
10531         if (positi.le.0) positi=positi+boxzsize
10532 C       print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop
10533 c for each residue check if it is in lipid or lipid water border area
10534 C       respos=mod(c(3,i+nres),boxzsize)
10535 C       print *,positi,bordlipbot,buflipbot
10536        if ((positi.gt.bordlipbot)
10537      & .and.(positi.lt.bordliptop)) then
10538 C the energy transfer exist
10539         if (positi.lt.buflipbot) then
10540          fracinbuf=1.0d0-
10541      &     ((positi-bordlipbot)/lipbufthick)
10542 C lipbufthick is thickenes of lipid buffore
10543          sslip=sscalelip(fracinbuf)
10544          ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
10545          eliptran=eliptran+sslip*liptranene(itype(i))
10546          gliptranx(3,i)=gliptranx(3,i)
10547      &+ssgradlip*liptranene(itype(i))
10548          gliptranc(3,i-1)= gliptranc(3,i-1)
10549      &+ssgradlip*liptranene(itype(i))
10550 C         print *,"doing sccale for lower part"
10551         elseif (positi.gt.bufliptop) then
10552          fracinbuf=1.0d0-
10553      &((bordliptop-positi)/lipbufthick)
10554          sslip=sscalelip(fracinbuf)
10555          ssgradlip=sscagradlip(fracinbuf)/lipbufthick
10556          eliptran=eliptran+sslip*liptranene(itype(i))
10557          gliptranx(3,i)=gliptranx(3,i)
10558      &+ssgradlip*liptranene(itype(i))
10559          gliptranc(3,i-1)= gliptranc(3,i-1)
10560      &+ssgradlip*liptranene(itype(i))
10561 C          print *, "doing sscalefor top part",sslip,fracinbuf
10562         else
10563          eliptran=eliptran+liptranene(itype(i))
10564 C         print *,"I am in true lipid"
10565         endif
10566         endif ! if in lipid or buffor
10567 C       else
10568 C       eliptran=elpitran+0.0 ! I am in water
10569        enddo
10570        return
10571        end
10572 C---------------------------------------------------------
10573 C AFM soubroutine for constant force
10574        subroutine AFMforce(Eafmforce)
10575        implicit real*8 (a-h,o-z)
10576       include 'DIMENSIONS'
10577       include 'COMMON.GEO'
10578       include 'COMMON.VAR'
10579       include 'COMMON.LOCAL'
10580       include 'COMMON.CHAIN'
10581       include 'COMMON.DERIV'
10582       include 'COMMON.NAMES'
10583       include 'COMMON.INTERACT'
10584       include 'COMMON.IOUNITS'
10585       include 'COMMON.CALC'
10586       include 'COMMON.CONTROL'
10587       include 'COMMON.SPLITELE'
10588       include 'COMMON.SBRIDGE'
10589       real*8 diffafm(3)
10590       dist=0.0d0
10591       Eafmforce=0.0d0
10592       do i=1,3
10593       diffafm(i)=c(i,afmend)-c(i,afmbeg)
10594       dist=dist+diffafm(i)**2
10595       enddo
10596       dist=dsqrt(dist)
10597       Eafmforce=-forceAFMconst*(dist-distafminit)
10598       do i=1,3
10599       gradafm(i,afmend-1)=-forceAFMconst*diffafm(i)/dist
10600       gradafm(i,afmbeg-1)=forceAFMconst*diffafm(i)/dist
10601       enddo
10602 C      print *,'AFM',Eafmforce
10603       return
10604       end
10605 C---------------------------------------------------------
10606 C AFM subroutine with pseudoconstant velocity
10607        subroutine AFMvel(Eafmforce)
10608        implicit real*8 (a-h,o-z)
10609       include 'DIMENSIONS'
10610       include 'COMMON.GEO'
10611       include 'COMMON.VAR'
10612       include 'COMMON.LOCAL'
10613       include 'COMMON.CHAIN'
10614       include 'COMMON.DERIV'
10615       include 'COMMON.NAMES'
10616       include 'COMMON.INTERACT'
10617       include 'COMMON.IOUNITS'
10618       include 'COMMON.CALC'
10619       include 'COMMON.CONTROL'
10620       include 'COMMON.SPLITELE'
10621       include 'COMMON.SBRIDGE'
10622       real*8 diffafm(3)
10623 C Only for check grad COMMENT if not used for checkgrad
10624 C      totT=3.0d0
10625 C--------------------------------------------------------
10626 C      print *,"wchodze"
10627       dist=0.0d0
10628       Eafmforce=0.0d0
10629       do i=1,3
10630       diffafm(i)=c(i,afmend)-c(i,afmbeg)
10631       dist=dist+diffafm(i)**2
10632       enddo
10633       dist=dsqrt(dist)
10634       Eafmforce=0.5d0*forceAFMconst
10635      & *(distafminit+totTafm*velAFMconst-dist)**2
10636 C      Eafmforce=-forceAFMconst*(dist-distafminit)
10637       do i=1,3
10638       gradafm(i,afmend-1)=-forceAFMconst*
10639      &(distafminit+totTafm*velAFMconst-dist)
10640      &*diffafm(i)/dist
10641       gradafm(i,afmbeg-1)=forceAFMconst*
10642      &(distafminit+totTafm*velAFMconst-dist)
10643      &*diffafm(i)/dist
10644       enddo
10645 C      print *,'AFM',Eafmforce,totTafm*velAFMconst,dist
10646       return
10647       end
10648 C-----------------------------------------------------------
10649 C first for shielding is setting of function of side-chains
10650        subroutine set_shield_fac
10651       implicit real*8 (a-h,o-z)
10652       include 'DIMENSIONS'
10653       include 'COMMON.CHAIN'
10654       include 'COMMON.DERIV'
10655       include 'COMMON.IOUNITS'
10656       include 'COMMON.SHIELD'
10657       include 'COMMON.INTERACT'
10658 C this is the squar root 77 devided by 81 the epislion in lipid (in protein)
10659       double precision div77_81/0.974996043d0/,
10660      &div4_81/0.2222222222d0/,sh_frac_dist_grad(3)
10661
10662 C the vector between center of side_chain and peptide group
10663        double precision pep_side(3),long,side_calf(3),
10664      &pept_group(3),costhet_grad(3),cosphi_grad_long(3),
10665      &cosphi_grad_loc(3),pep_side_norm(3),side_calf_norm(3)
10666 C the line belowe needs to be changed for FGPROC>1
10667       do i=1,nres-1
10668       if ((itype(i).eq.ntyp1).and.itype(i+1).eq.ntyp1) cycle
10669       ishield_list(i)=0
10670 Cif there two consequtive dummy atoms there is no peptide group between them
10671 C the line below has to be changed for FGPROC>1
10672       VolumeTotal=0.0
10673       do k=1,nres
10674        if ((itype(k).eq.ntyp1).or.(itype(k).eq.10)) cycle
10675        dist_pep_side=0.0
10676        dist_side_calf=0.0
10677        do j=1,3
10678 C first lets set vector conecting the ithe side-chain with kth side-chain
10679       pep_side(j)=c(j,k+nres)-(c(j,i)+c(j,i+1))/2.0d0
10680 C      pep_side(j)=2.0d0
10681 C and vector conecting the side-chain with its proper calfa
10682       side_calf(j)=c(j,k+nres)-c(j,k)
10683 C      side_calf(j)=2.0d0
10684       pept_group(j)=c(j,i)-c(j,i+1)
10685 C lets have their lenght
10686       dist_pep_side=pep_side(j)**2+dist_pep_side
10687       dist_side_calf=dist_side_calf+side_calf(j)**2
10688       dist_pept_group=dist_pept_group+pept_group(j)**2
10689       enddo
10690        dist_pep_side=dsqrt(dist_pep_side)
10691        dist_pept_group=dsqrt(dist_pept_group)
10692        dist_side_calf=dsqrt(dist_side_calf)
10693       do j=1,3
10694         pep_side_norm(j)=pep_side(j)/dist_pep_side
10695         side_calf_norm(j)=dist_side_calf
10696       enddo
10697 C now sscale fraction
10698        sh_frac_dist=-(dist_pep_side-rpp(1,1)-buff_shield)/buff_shield
10699 C       print *,buff_shield,"buff"
10700 C now sscale
10701         if (sh_frac_dist.le.0.0) cycle
10702 C If we reach here it means that this side chain reaches the shielding sphere
10703 C Lets add him to the list for gradient
10704         ishield_list(i)=ishield_list(i)+1
10705 C ishield_list is a list of non 0 side-chain that contribute to factor gradient
10706 C this list is essential otherwise problem would be O3
10707         shield_list(ishield_list(i),i)=k
10708 C Lets have the sscale value
10709         if (sh_frac_dist.gt.1.0) then
10710          scale_fac_dist=1.0d0
10711          do j=1,3
10712          sh_frac_dist_grad(j)=0.0d0
10713          enddo
10714         else
10715          scale_fac_dist=-sh_frac_dist*sh_frac_dist
10716      &                   *(2.0*sh_frac_dist-3.0d0)
10717          fac_help_scale=6.0*(sh_frac_dist-sh_frac_dist**2)
10718      &                  /dist_pep_side/buff_shield*0.5
10719 C remember for the final gradient multiply sh_frac_dist_grad(j)
10720 C for side_chain by factor -2 !
10721          do j=1,3
10722          sh_frac_dist_grad(j)=fac_help_scale*pep_side(j)
10723 C         print *,"jestem",scale_fac_dist,fac_help_scale,
10724 C     &                    sh_frac_dist_grad(j)
10725          enddo
10726         endif
10727 C        if ((i.eq.3).and.(k.eq.2)) then
10728 C        print *,i,sh_frac_dist,dist_pep,fac_help_scale,scale_fac_dist
10729 C     & ,"TU"
10730 C        endif
10731
10732 C this is what is now we have the distance scaling now volume...
10733       short=short_r_sidechain(itype(k))
10734       long=long_r_sidechain(itype(k))
10735       costhet=1.0d0/dsqrt(1.0+short**2/dist_pep_side**2)
10736 C now costhet_grad
10737 C       costhet=0.0d0
10738        costhet_fac=costhet**3*short**2*(-0.5)/dist_pep_side**4
10739 C       costhet_fac=0.0d0
10740        do j=1,3
10741          costhet_grad(j)=costhet_fac*pep_side(j)
10742        enddo
10743 C remember for the final gradient multiply costhet_grad(j)
10744 C for side_chain by factor -2 !
10745 C fac alfa is angle between CB_k,CA_k, CA_i,CA_i+1
10746 C pep_side0pept_group is vector multiplication
10747       pep_side0pept_group=0.0
10748       do j=1,3
10749       pep_side0pept_group=pep_side0pept_group+pep_side(j)*side_calf(j)
10750       enddo
10751       cosalfa=(pep_side0pept_group/
10752      & (dist_pep_side*dist_side_calf))
10753       fac_alfa_sin=1.0-cosalfa**2
10754       fac_alfa_sin=dsqrt(fac_alfa_sin)
10755       rkprim=fac_alfa_sin*(long-short)+short
10756 C now costhet_grad
10757        cosphi=1.0d0/dsqrt(1.0+rkprim**2/dist_pep_side**2)
10758        cosphi_fac=cosphi**3*rkprim**2*(-0.5)/dist_pep_side**4
10759
10760        do j=1,3
10761          cosphi_grad_long(j)=cosphi_fac*pep_side(j)
10762      &+cosphi**3*0.5/dist_pep_side**2*(-rkprim)
10763      &*(long-short)/fac_alfa_sin*cosalfa/
10764      &((dist_pep_side*dist_side_calf))*
10765      &((side_calf(j))-cosalfa*
10766      &((pep_side(j)/dist_pep_side)*dist_side_calf))
10767
10768         cosphi_grad_loc(j)=cosphi**3*0.5/dist_pep_side**2*(-rkprim)
10769      &*(long-short)/fac_alfa_sin*cosalfa
10770      &/((dist_pep_side*dist_side_calf))*
10771      &(pep_side(j)-
10772      &cosalfa*side_calf(j)/dist_side_calf*dist_pep_side)
10773        enddo
10774
10775       VofOverlap=VSolvSphere/2.0d0*(1.0-costhet)*(1.0-cosphi)
10776      &                    /VSolvSphere_div
10777 C now the gradient...
10778 C grad_shield is gradient of Calfa for peptide groups
10779       do j=1,3
10780       grad_shield(j,i)=grad_shield(j,i)
10781 C gradient po skalowaniu
10782      &                +(sh_frac_dist_grad(j)
10783 C  gradient po costhet
10784      &-scale_fac_dist*costhet_grad(j)/(1.0-costhet)
10785      &-scale_fac_dist*(cosphi_grad_long(j))
10786      &/(1.0-cosphi) )*div77_81
10787      &*VofOverlap
10788 C grad_shield_side is Cbeta sidechain gradient
10789       grad_shield_side(j,ishield_list(i),i)=
10790      &        (sh_frac_dist_grad(j)*-2.0d0
10791      &       +scale_fac_dist*costhet_grad(j)*2.0d0/(1.0-costhet)
10792      &       +scale_fac_dist*(cosphi_grad_long(j))
10793      &        *2.0d0/(1.0-cosphi))
10794      &        *div77_81*VofOverlap
10795
10796        grad_shield_loc(j,ishield_list(i),i)=
10797      &   scale_fac_dist*cosphi_grad_loc(j)
10798      &        *2.0d0/(1.0-cosphi)
10799      &        *div77_81*VofOverlap
10800       enddo
10801       VolumeTotal=VolumeTotal+VofOverlap*scale_fac_dist
10802       enddo
10803       fac_shield(i)=VolumeTotal*div77_81+div4_81
10804 C      write(2,*) "TOTAL VOLUME",i,VolumeTotal,fac_shield(i)
10805       enddo
10806       return
10807       end
10808