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