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      print *,"Processor",myrank," left VEC_AND_DERIV"
 141       if (ipot.lt.6) then
 142 #ifdef SPLITELE
 143          if (welec.gt.0d0.or.wvdwpp.gt.0d0.or.wel_loc.gt.0d0.or.
 144      &       wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0
 145      &       .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0
 146      &       .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
 147 #else
 148          if (welec.gt.0d0.or.wel_loc.gt.0d0.or.
 149      &       wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0
 150      &       .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0
 151      &       .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
 152 #endif
 153             call eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
 154          else
 155             ees=0.0d0
 156             evdw1=0.0d0
 157             eel_loc=0.0d0
 158             eello_turn3=0.0d0
 159             eello_turn4=0.0d0
 160          endif
 161       else
 162         write (iout,*) "Soft-spheer ELEC potential"
 163 c        call eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,
 164 c     &   eello_turn4)
 165       endif
 166 c      print *,"Processor",myrank," computed UELEC"
 167 C
 168 C Calculate excluded-volume interaction energy between peptide groups
 169 C and side chains.
 170 C
 171       if (ipot.lt.6) then
 172        if(wscp.gt.0d0) then
 173         call escp(evdw2,evdw2_14)
 174        else
 175         evdw2=0
 176         evdw2_14=0
 177        endif
 178       else
 179 c        write (iout,*) "Soft-sphere SCP potential"
 180         call escp_soft_sphere(evdw2,evdw2_14)
 181       endif
 182 c
 183 c Calculate the bond-stretching energy
 184 c
 185       call ebond(estr)
 186 C
 187 C Calculate the disulfide-bridge and other energy and the contributions
 188 C from other distance constraints.
 189 cd    print *,'Calling EHPB'
 190       call edis(ehpb)
 191 cd    print *,'EHPB exitted succesfully.'
 192 C
 193 C Calculate the virtual-bond-angle energy.
 194 C
 195       if (wang.gt.0d0) then
 196         call ebend(ebe)
 197       else
 198         ebe=0
 199       endif
 200 c      print *,"Processor",myrank," computed UB"
 201 C
 202 C Calculate the SC local energy.
 203 C
 204 C      print *,"TU DOCHODZE?"
 205       call esc(escloc)
 206 c      print *,"Processor",myrank," computed USC"
 207 C
 208 C Calculate the virtual-bond torsional energy.
 209 C
 210 cd    print *,'nterm=',nterm
 211       if (wtor.gt.0) then
 212        call etor(etors,edihcnstr)
 213       else
 214        etors=0
 215        edihcnstr=0
 216       endif
 217 c      print *,"Processor",myrank," computed Utor"
 218 C
 219 C 6/23/01 Calculate double-torsional energy
 220 C
 221       if (wtor_d.gt.0) then
 222        call etor_d(etors_d)
 223       else
 224        etors_d=0
 225       endif
 226 c      print *,"Processor",myrank," computed Utord"
 227 C
 228 C 21/5/07 Calculate local sicdechain correlation energy
 229 C
 230       if (wsccor.gt.0.0d0) then
 231         call eback_sc_corr(esccor)
 232       else
 233         esccor=0.0d0
 234       endif
 235 C      print *,"PRZED MULIt"
 236 c      print *,"Processor",myrank," computed Usccorr"
 237 C
 238 C 12/1/95 Multi-body terms
 239 C
 240       n_corr=0
 241       n_corr1=0
 242       if ((wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0
 243      &    .or. wturn6.gt.0.0d0) .and. ipot.lt.6) then
 244          call multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1)
 245 cd         write(2,*)'multibody_eello n_corr=',n_corr,' n_corr1=',n_corr1,
 246 cd     &" ecorr",ecorr," ecorr5",ecorr5," ecorr6",ecorr6," eturn6",eturn6
 247       else
 248          ecorr=0.0d0
 249          ecorr5=0.0d0
 250          ecorr6=0.0d0
 251          eturn6=0.0d0
 252       endif
 253       if ((wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) .and. ipot.lt.6) then
 254          call multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
 255 cd         write (iout,*) "multibody_hb ecorr",ecorr
 256       endif
 257 c      print *,"Processor",myrank," computed Ucorr"
 258 C
 259 C If performing constraint dynamics, call the constraint energy
 260 C  after the equilibration time
 261       if(usampl.and.totT.gt.eq_time) then
 262          call EconstrQ
 263          call Econstr_back
 264       else
 265          Uconst=0.0d0
 266          Uconst_back=0.0d0
 267       endif
 268 C 01/27/2015 added by adasko
 269 C the energy component below is energy transfer into lipid environment
 270 C based on partition function
 271 C      print *,"przed lipidami"
 272       if (wliptran.gt.0) then
 273         call Eliptransfer(eliptran)
 274       endif
 275 C      print *,"za lipidami"
 276 #ifdef TIMING
 277       time_enecalc=time_enecalc+MPI_Wtime()-time00
 278 #endif
 279 c      print *,"Processor",myrank," computed Uconstr"
 280 #ifdef TIMING
 281       time00=MPI_Wtime()
 282 #endif
 283 c
 284 C Sum the energies
 285 C
 286       energia(1)=evdw
 287 #ifdef SCP14
 288       energia(2)=evdw2-evdw2_14
 289       energia(18)=evdw2_14
 290 #else
 291       energia(2)=evdw2
 292       energia(18)=0.0d0
 293 #endif
 294 #ifdef SPLITELE
 295       energia(3)=ees
 296       energia(16)=evdw1
 297 #else
 298       energia(3)=ees+evdw1
 299       energia(16)=0.0d0
 300 #endif
 301       energia(4)=ecorr
 302       energia(5)=ecorr5
 303       energia(6)=ecorr6
 304       energia(7)=eel_loc
 305       energia(8)=eello_turn3
 306       energia(9)=eello_turn4
 307       energia(10)=eturn6
 308       energia(11)=ebe
 309       energia(12)=escloc
 310       energia(13)=etors
 311       energia(14)=etors_d
 312       energia(15)=ehpb
 313       energia(19)=edihcnstr
 314       energia(17)=estr
 315       energia(20)=Uconst+Uconst_back
 316       energia(21)=esccor
 317       energia(22)=eliptran
 318 c    Here are the energies showed per procesor if the are more processors
 319 c    per molecule then we sum it up in sum_energy subroutine
 320 c      print *," Processor",myrank," calls SUM_ENERGY"
 321       call sum_energy(energia,.true.)
 322       if (dyn_ss) call dyn_set_nss
 323 c      print *," Processor",myrank," left SUM_ENERGY"
 324 #ifdef TIMING
 325       time_sumene=time_sumene+MPI_Wtime()-time00
 326 #endif
 327       return
 328       end
 329 c-------------------------------------------------------------------------------
 330       subroutine sum_energy(energia,reduce)
 331       implicit real*8 (a-h,o-z)
 332       include 'DIMENSIONS'
 333 #ifndef ISNAN
 334       external proc_proc
 335 #ifdef WINPGI
 336 cMS$ATTRIBUTES C ::  proc_proc
 337 #endif
 338 #endif
 339 #ifdef MPI
 340       include "mpif.h"
 341 #endif
 342       include 'COMMON.SETUP'
 343       include 'COMMON.IOUNITS'
 344       double precision energia(0:n_ene),enebuff(0:n_ene+1)
 345       include 'COMMON.FFIELD'
 346       include 'COMMON.DERIV'
 347       include 'COMMON.INTERACT'
 348       include 'COMMON.SBRIDGE'
 349       include 'COMMON.CHAIN'
 350       include 'COMMON.VAR'
 351       include 'COMMON.CONTROL'
 352       include 'COMMON.TIME1'
 353       logical reduce
 354 #ifdef MPI
 355       if (nfgtasks.gt.1 .and. reduce) then
 356 #ifdef DEBUG
 357         write (iout,*) "energies before REDUCE"
 358         call enerprint(energia)
 359         call flush(iout)
 360 #endif
 361         do i=0,n_ene
 362           enebuff(i)=energia(i)
 363         enddo
 364         time00=MPI_Wtime()
 365         call MPI_Barrier(FG_COMM,IERR)
 366         time_barrier_e=time_barrier_e+MPI_Wtime()-time00
 367         time00=MPI_Wtime()
 368         call MPI_Reduce(enebuff(0),energia(0),n_ene+1,
 369      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 370 #ifdef DEBUG
 371         write (iout,*) "energies after REDUCE"
 372         call enerprint(energia)
 373         call flush(iout)
 374 #endif
 375         time_Reduce=time_Reduce+MPI_Wtime()-time00
 376       endif
 377       if (fg_rank.eq.0) then
 378 #endif
 379       evdw=energia(1)
 380 #ifdef SCP14
 381       evdw2=energia(2)+energia(18)
 382       evdw2_14=energia(18)
 383 #else
 384       evdw2=energia(2)
 385 #endif
 386 #ifdef SPLITELE
 387       ees=energia(3)
 388       evdw1=energia(16)
 389 #else
 390       ees=energia(3)
 391       evdw1=0.0d0
 392 #endif
 393       ecorr=energia(4)
 394       ecorr5=energia(5)
 395       ecorr6=energia(6)
 396       eel_loc=energia(7)
 397       eello_turn3=energia(8)
 398       eello_turn4=energia(9)
 399       eturn6=energia(10)
 400       ebe=energia(11)
 401       escloc=energia(12)
 402       etors=energia(13)
 403       etors_d=energia(14)
 404       ehpb=energia(15)
 405       edihcnstr=energia(19)
 406       estr=energia(17)
 407       Uconst=energia(20)
 408       esccor=energia(21)
 409       eliptran=energia(22)
 410 #ifdef SPLITELE
 411       etot=wsc*evdw+wscp*evdw2+welec*ees+wvdwpp*evdw1
 412      & +wang*ebe+wtor*etors+wscloc*escloc
 413      & +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5
 414      & +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3
 415      & +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d
 416      & +wbond*estr+Uconst+wsccor*esccor+wliptran*eliptran
 417 #else
 418       etot=wsc*evdw+wscp*evdw2+welec*(ees+evdw1)
 419      & +wang*ebe+wtor*etors+wscloc*escloc
 420      & +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5
 421      & +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3
 422      & +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d
 423      & +wbond*estr+Uconst+wsccor*esccor+wliptran*eliptran
 424 #endif
 425       energia(0)=etot
 426 c detecting NaNQ
 427 #ifdef ISNAN
 428 #ifdef AIX
 429       if (isnan(etot).ne.0) energia(0)=1.0d+99
 430 #else
 431       if (isnan(etot)) energia(0)=1.0d+99
 432 #endif
 433 #else
 434       i=0
 435 #ifdef WINPGI
 436       idumm=proc_proc(etot,i)
 437 #else
 438       call proc_proc(etot,i)
 439 #endif
 440       if(i.eq.1)energia(0)=1.0d+99
 441 #endif
 442 #ifdef MPI
 443       endif
 444 #endif
 445       return
 446       end
 447 c-------------------------------------------------------------------------------
 448       subroutine sum_gradient
 449       implicit real*8 (a-h,o-z)
 450       include 'DIMENSIONS'
 451 #ifndef ISNAN
 452       external proc_proc
 453 #ifdef WINPGI
 454 cMS$ATTRIBUTES C ::  proc_proc
 455 #endif
 456 #endif
 457 #ifdef MPI
 458       include 'mpif.h'
 459 #endif
 460       double precision gradbufc(3,-1:maxres),gradbufx(3,-1:maxres),
 461      & glocbuf(4*maxres),gradbufc_sum(3,-1:maxres)
 462      & ,gloc_scbuf(3,-1:maxres)
 463       include 'COMMON.SETUP'
 464       include 'COMMON.IOUNITS'
 465       include 'COMMON.FFIELD'
 466       include 'COMMON.DERIV'
 467       include 'COMMON.INTERACT'
 468       include 'COMMON.SBRIDGE'
 469       include 'COMMON.CHAIN'
 470       include 'COMMON.VAR'
 471       include 'COMMON.CONTROL'
 472       include 'COMMON.TIME1'
 473       include 'COMMON.MAXGRAD'
 474       include 'COMMON.SCCOR'
 475 #ifdef TIMING
 476       time01=MPI_Wtime()
 477 #endif
 478 #ifdef DEBUG
 479       write (iout,*) "sum_gradient gvdwc, gvdwx"
 480       do i=1,nres
 481         write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)')
 482      &   i,(gvdwx(j,i),j=1,3),(gvdwc(j,i),j=1,3)
 483       enddo
 484       call flush(iout)
 485 #endif
 486 #ifdef MPI
 487 C FG slaves call the following matching MPI_Bcast in ERGASTULUM
 488         if (nfgtasks.gt.1 .and. fg_rank.eq.0)
 489      &    call MPI_Bcast(1,1,MPI_INTEGER,king,FG_COMM,IERROR)
 490 #endif
 491 C
 492 C 9/29/08 AL Transform parts of gradients in site coordinates to the gradient
 493 C            in virtual-bond-vector coordinates
 494 C
 495 #ifdef DEBUG
 496 c      write (iout,*) "gel_loc gel_loc_long and gel_loc_loc"
 497 c      do i=1,nres-1
 498 c        write (iout,'(i5,3f10.5,2x,3f10.5,2x,f10.5)')
 499 c     &   i,(gel_loc(j,i),j=1,3),(gel_loc_long(j,i),j=1,3),gel_loc_loc(i)
 500 c      enddo
 501 c      write (iout,*) "gel_loc_tur3 gel_loc_turn4"
 502 c      do i=1,nres-1
 503 c        write (iout,'(i5,3f10.5,2x,f10.5)')
 504 c     &  i,(gcorr4_turn(j,i),j=1,3),gel_loc_turn4(i)
 505 c      enddo
 506       write (iout,*) "gradcorr5 gradcorr5_long gradcorr5_loc"
 507       do i=1,nres
 508         write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)')
 509      &   i,(gradcorr5(j,i),j=1,3),(gradcorr5_long(j,i),j=1,3),
 510      &   g_corr5_loc(i)
 511       enddo
 512       call flush(iout)
 513 #endif
 514 #ifdef SPLITELE
 515       do i=0,nct
 516         do j=1,3
 517           gradbufc(j,i)=wsc*gvdwc(j,i)+
 518      &                wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+
 519      &                welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+
 520      &                wel_loc*gel_loc_long(j,i)+
 521      &                wcorr*gradcorr_long(j,i)+
 522      &                wcorr5*gradcorr5_long(j,i)+
 523      &                wcorr6*gradcorr6_long(j,i)+
 524      &                wturn6*gcorr6_turn_long(j,i)+
 525      &                wstrain*ghpbc(j,i)
 526      &                +wliptran*gliptranc(j,i)
 527
 528         enddo
 529       enddo
 530 #else
 531       do i=0,nct
 532         do j=1,3
 533           gradbufc(j,i)=wsc*gvdwc(j,i)+
 534      &                wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+
 535      &                welec*gelc_long(j,i)+
 536      &                wbond*gradb(j,i)+
 537      &                wel_loc*gel_loc_long(j,i)+
 538      &                wcorr*gradcorr_long(j,i)+
 539      &                wcorr5*gradcorr5_long(j,i)+
 540      &                wcorr6*gradcorr6_long(j,i)+
 541      &                wturn6*gcorr6_turn_long(j,i)+
 542      &                wstrain*ghpbc(j,i)
 543      &                +wliptran*gliptranc(j,i)
 544         enddo
 545       enddo
 546 #endif
 547 #ifdef MPI
 548       if (nfgtasks.gt.1) then
 549       time00=MPI_Wtime()
 550 #ifdef DEBUG
 551       write (iout,*) "gradbufc before allreduce"
 552       do i=1,nres
 553         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 554       enddo
 555       call flush(iout)
 556 #endif
 557       do i=0,nres
 558         do j=1,3
 559           gradbufc_sum(j,i)=gradbufc(j,i)
 560         enddo
 561       enddo
 562 c      call MPI_AllReduce(gradbufc(1,1),gradbufc_sum(1,1),3*nres,
 563 c     &    MPI_DOUBLE_PRECISION,MPI_SUM,FG_COMM,IERR)
 564 c      time_reduce=time_reduce+MPI_Wtime()-time00
 565 #ifdef DEBUG
 566 c      write (iout,*) "gradbufc_sum after allreduce"
 567 c      do i=1,nres
 568 c        write (iout,'(i3,3f10.5)') i,(gradbufc_sum(j,i),j=1,3)
 569 c      enddo
 570 c      call flush(iout)
 571 #endif
 572 #ifdef TIMING
 573 c      time_allreduce=time_allreduce+MPI_Wtime()-time00
 574 #endif
 575       do i=nnt,nres
 576         do k=1,3
 577           gradbufc(k,i)=0.0d0
 578         enddo
 579       enddo
 580 #ifdef DEBUG
 581       write (iout,*) "igrad_start",igrad_start," igrad_end",igrad_end
 582       write (iout,*) (i," jgrad_start",jgrad_start(i),
 583      &                  " jgrad_end  ",jgrad_end(i),
 584      &                  i=igrad_start,igrad_end)
 585 #endif
 586 c
 587 c Obsolete and inefficient code; we can make the effort O(n) and, therefore,
 588 c do not parallelize this part.
 589 c
 590 c      do i=igrad_start,igrad_end
 591 c        do j=jgrad_start(i),jgrad_end(i)
 592 c          do k=1,3
 593 c            gradbufc(k,i)=gradbufc(k,i)+gradbufc_sum(k,j)
 594 c          enddo
 595 c        enddo
 596 c      enddo
 597       do j=1,3
 598         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
 599       enddo
 600       do i=nres-2,-1,-1
 601         do j=1,3
 602           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
 603         enddo
 604       enddo
 605 #ifdef DEBUG
 606       write (iout,*) "gradbufc after summing"
 607       do i=1,nres
 608         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 609       enddo
 610       call flush(iout)
 611 #endif
 612       else
 613 #endif
 614 #ifdef DEBUG
 615       write (iout,*) "gradbufc"
 616       do i=1,nres
 617         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 618       enddo
 619       call flush(iout)
 620 #endif
 621       do i=-1,nres
 622         do j=1,3
 623           gradbufc_sum(j,i)=gradbufc(j,i)
 624           gradbufc(j,i)=0.0d0
 625         enddo
 626       enddo
 627       do j=1,3
 628         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
 629       enddo
 630       do i=nres-2,-1,-1
 631         do j=1,3
 632           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
 633         enddo
 634       enddo
 635 c      do i=nnt,nres-1
 636 c        do k=1,3
 637 c          gradbufc(k,i)=0.0d0
 638 c        enddo
 639 c        do j=i+1,nres
 640 c          do k=1,3
 641 c            gradbufc(k,i)=gradbufc(k,i)+gradbufc(k,j)
 642 c          enddo
 643 c        enddo
 644 c      enddo
 645 #ifdef DEBUG
 646       write (iout,*) "gradbufc after summing"
 647       do i=1,nres
 648         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 649       enddo
 650       call flush(iout)
 651 #endif
 652 #ifdef MPI
 653       endif
 654 #endif
 655       do k=1,3
 656         gradbufc(k,nres)=0.0d0
 657       enddo
 658       do i=-1,nct
 659         do j=1,3
 660 #ifdef SPLITELE
 661           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+
 662      &                wel_loc*gel_loc(j,i)+
 663      &                0.5d0*(wscp*gvdwc_scpp(j,i)+
 664      &                welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+
 665      &                wel_loc*gel_loc_long(j,i)+
 666      &                wcorr*gradcorr_long(j,i)+
 667      &                wcorr5*gradcorr5_long(j,i)+
 668      &                wcorr6*gradcorr6_long(j,i)+
 669      &                wturn6*gcorr6_turn_long(j,i))+
 670      &                wbond*gradb(j,i)+
 671      &                wcorr*gradcorr(j,i)+
 672      &                wturn3*gcorr3_turn(j,i)+
 673      &                wturn4*gcorr4_turn(j,i)+
 674      &                wcorr5*gradcorr5(j,i)+
 675      &                wcorr6*gradcorr6(j,i)+
 676      &                wturn6*gcorr6_turn(j,i)+
 677      &                wsccor*gsccorc(j,i)
 678      &               +wscloc*gscloc(j,i)
 679      &               +wliptran*gliptranc(j,i)
 680 #else
 681           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+
 682      &                wel_loc*gel_loc(j,i)+
 683      &                0.5d0*(wscp*gvdwc_scpp(j,i)+
 684      &                welec*gelc_long(j,i)
 685      &                wel_loc*gel_loc_long(j,i)+
 686      &                wcorr*gcorr_long(j,i)+
 687      &                wcorr5*gradcorr5_long(j,i)+
 688      &                wcorr6*gradcorr6_long(j,i)+
 689      &                wturn6*gcorr6_turn_long(j,i))+
 690      &                wbond*gradb(j,i)+
 691      &                wcorr*gradcorr(j,i)+
 692      &                wturn3*gcorr3_turn(j,i)+
 693      &                wturn4*gcorr4_turn(j,i)+
 694      &                wcorr5*gradcorr5(j,i)+
 695      &                wcorr6*gradcorr6(j,i)+
 696      &                wturn6*gcorr6_turn(j,i)+
 697      &                wsccor*gsccorc(j,i)
 698      &               +wscloc*gscloc(j,i)
 699      &               +wliptran*gliptranc(j,i)
 700 #endif
 701           gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+
 702      &                  wbond*gradbx(j,i)+
 703      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
 704      &                  wsccor*gsccorx(j,i)
 705      &                 +wscloc*gsclocx(j,i)
 706      &                 +wliptran*gliptranx(j,i)
 707         enddo
 708       enddo
 709 #ifdef DEBUG
 710       write (iout,*) "gloc before adding corr"
 711       do i=1,4*nres
 712         write (iout,*) i,gloc(i,icg)
 713       enddo
 714 #endif
 715       do i=1,nres-3
 716         gloc(i,icg)=gloc(i,icg)+wcorr*gcorr_loc(i)
 717      &   +wcorr5*g_corr5_loc(i)
 718      &   +wcorr6*g_corr6_loc(i)
 719      &   +wturn4*gel_loc_turn4(i)
 720      &   +wturn3*gel_loc_turn3(i)
 721      &   +wturn6*gel_loc_turn6(i)
 722      &   +wel_loc*gel_loc_loc(i)
 723       enddo
 724 #ifdef DEBUG
 725       write (iout,*) "gloc after adding corr"
 726       do i=1,4*nres
 727         write (iout,*) i,gloc(i,icg)
 728       enddo
 729 #endif
 730 #ifdef MPI
 731       if (nfgtasks.gt.1) then
 732         do j=1,3
 733           do i=1,nres
 734             gradbufc(j,i)=gradc(j,i,icg)
 735             gradbufx(j,i)=gradx(j,i,icg)
 736           enddo
 737         enddo
 738         do i=1,4*nres
 739           glocbuf(i)=gloc(i,icg)
 740         enddo
 741 c#define DEBUG
 742 #ifdef DEBUG
 743       write (iout,*) "gloc_sc before reduce"
 744       do i=1,nres
 745        do j=1,1
 746         write (iout,*) i,j,gloc_sc(j,i,icg)
 747        enddo
 748       enddo
 749 #endif
 750 c#undef DEBUG
 751         do i=1,nres
 752          do j=1,3
 753           gloc_scbuf(j,i)=gloc_sc(j,i,icg)
 754          enddo
 755         enddo
 756         time00=MPI_Wtime()
 757         call MPI_Barrier(FG_COMM,IERR)
 758         time_barrier_g=time_barrier_g+MPI_Wtime()-time00
 759         time00=MPI_Wtime()
 760         call MPI_Reduce(gradbufc(1,1),gradc(1,1,icg),3*nres,
 761      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 762         call MPI_Reduce(gradbufx(1,1),gradx(1,1,icg),3*nres,
 763      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 764         call MPI_Reduce(glocbuf(1),gloc(1,icg),4*nres,
 765      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 766         time_reduce=time_reduce+MPI_Wtime()-time00
 767         call MPI_Reduce(gloc_scbuf(1,1),gloc_sc(1,1,icg),3*nres,
 768      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 769         time_reduce=time_reduce+MPI_Wtime()-time00
 770 c#define DEBUG
 771 #ifdef DEBUG
 772       write (iout,*) "gloc_sc after reduce"
 773       do i=1,nres
 774        do j=1,1
 775         write (iout,*) i,j,gloc_sc(j,i,icg)
 776        enddo
 777       enddo
 778 #endif
 779 c#undef DEBUG
 780 #ifdef DEBUG
 781       write (iout,*) "gloc after reduce"
 782       do i=1,4*nres
 783         write (iout,*) i,gloc(i,icg)
 784       enddo
 785 #endif
 786       endif
 787 #endif
 788       if (gnorm_check) then
 789 c
 790 c Compute the maximum elements of the gradient
 791 c
 792       gvdwc_max=0.0d0
 793       gvdwc_scp_max=0.0d0
 794       gelc_max=0.0d0
 795       gvdwpp_max=0.0d0
 796       gradb_max=0.0d0
 797       ghpbc_max=0.0d0
 798       gradcorr_max=0.0d0
 799       gel_loc_max=0.0d0
 800       gcorr3_turn_max=0.0d0
 801       gcorr4_turn_max=0.0d0
 802       gradcorr5_max=0.0d0
 803       gradcorr6_max=0.0d0
 804       gcorr6_turn_max=0.0d0
 805       gsccorc_max=0.0d0
 806       gscloc_max=0.0d0
 807       gvdwx_max=0.0d0
 808       gradx_scp_max=0.0d0
 809       ghpbx_max=0.0d0
 810       gradxorr_max=0.0d0
 811       gsccorx_max=0.0d0
 812       gsclocx_max=0.0d0
 813       do i=1,nct
 814         gvdwc_norm=dsqrt(scalar(gvdwc(1,i),gvdwc(1,i)))
 815         if (gvdwc_norm.gt.gvdwc_max) gvdwc_max=gvdwc_norm
 816         gvdwc_scp_norm=dsqrt(scalar(gvdwc_scp(1,i),gvdwc_scp(1,i)))
 817         if (gvdwc_scp_norm.gt.gvdwc_scp_max)
 818      &   gvdwc_scp_max=gvdwc_scp_norm
 819         gelc_norm=dsqrt(scalar(gelc(1,i),gelc(1,i)))
 820         if (gelc_norm.gt.gelc_max) gelc_max=gelc_norm
 821         gvdwpp_norm=dsqrt(scalar(gvdwpp(1,i),gvdwpp(1,i)))
 822         if (gvdwpp_norm.gt.gvdwpp_max) gvdwpp_max=gvdwpp_norm
 823         gradb_norm=dsqrt(scalar(gradb(1,i),gradb(1,i)))
 824         if (gradb_norm.gt.gradb_max) gradb_max=gradb_norm
 825         ghpbc_norm=dsqrt(scalar(ghpbc(1,i),ghpbc(1,i)))
 826         if (ghpbc_norm.gt.ghpbc_max) ghpbc_max=ghpbc_norm
 827         gradcorr_norm=dsqrt(scalar(gradcorr(1,i),gradcorr(1,i)))
 828         if (gradcorr_norm.gt.gradcorr_max) gradcorr_max=gradcorr_norm
 829         gel_loc_norm=dsqrt(scalar(gel_loc(1,i),gel_loc(1,i)))
 830         if (gel_loc_norm.gt.gel_loc_max) gel_loc_max=gel_loc_norm
 831         gcorr3_turn_norm=dsqrt(scalar(gcorr3_turn(1,i),
 832      &    gcorr3_turn(1,i)))
 833         if (gcorr3_turn_norm.gt.gcorr3_turn_max)
 834      &    gcorr3_turn_max=gcorr3_turn_norm
 835         gcorr4_turn_norm=dsqrt(scalar(gcorr4_turn(1,i),
 836      &    gcorr4_turn(1,i)))
 837         if (gcorr4_turn_norm.gt.gcorr4_turn_max)
 838      &    gcorr4_turn_max=gcorr4_turn_norm
 839         gradcorr5_norm=dsqrt(scalar(gradcorr5(1,i),gradcorr5(1,i)))
 840         if (gradcorr5_norm.gt.gradcorr5_max)
 841      &    gradcorr5_max=gradcorr5_norm
 842         gradcorr6_norm=dsqrt(scalar(gradcorr6(1,i),gradcorr6(1,i)))
 843         if (gradcorr6_norm.gt.gradcorr6_max) gcorr6_max=gradcorr6_norm
 844         gcorr6_turn_norm=dsqrt(scalar(gcorr6_turn(1,i),
 845      &    gcorr6_turn(1,i)))
 846         if (gcorr6_turn_norm.gt.gcorr6_turn_max)
 847      &    gcorr6_turn_max=gcorr6_turn_norm
 848         gsccorr_norm=dsqrt(scalar(gsccorc(1,i),gsccorc(1,i)))
 849         if (gsccorr_norm.gt.gsccorr_max) gsccorr_max=gsccorr_norm
 850         gscloc_norm=dsqrt(scalar(gscloc(1,i),gscloc(1,i)))
 851         if (gscloc_norm.gt.gscloc_max) gscloc_max=gscloc_norm
 852         gvdwx_norm=dsqrt(scalar(gvdwx(1,i),gvdwx(1,i)))
 853         if (gvdwx_norm.gt.gvdwx_max) gvdwx_max=gvdwx_norm
 854         gradx_scp_norm=dsqrt(scalar(gradx_scp(1,i),gradx_scp(1,i)))
 855         if (gradx_scp_norm.gt.gradx_scp_max)
 856      &    gradx_scp_max=gradx_scp_norm
 857         ghpbx_norm=dsqrt(scalar(ghpbx(1,i),ghpbx(1,i)))
 858         if (ghpbx_norm.gt.ghpbx_max) ghpbx_max=ghpbx_norm
 859         gradxorr_norm=dsqrt(scalar(gradxorr(1,i),gradxorr(1,i)))
 860         if (gradxorr_norm.gt.gradxorr_max) gradxorr_max=gradxorr_norm
 861         gsccorrx_norm=dsqrt(scalar(gsccorx(1,i),gsccorx(1,i)))
 862         if (gsccorrx_norm.gt.gsccorrx_max) gsccorrx_max=gsccorrx_norm
 863         gsclocx_norm=dsqrt(scalar(gsclocx(1,i),gsclocx(1,i)))
 864         if (gsclocx_norm.gt.gsclocx_max) gsclocx_max=gsclocx_norm
 865       enddo
 866       if (gradout) then
 867 #ifdef AIX
 868         open(istat,file=statname,position="append")
 869 #else
 870         open(istat,file=statname,access="append")
 871 #endif
 872         write (istat,'(1h#,21f10.2)') gvdwc_max,gvdwc_scp_max,
 873      &     gelc_max,gvdwpp_max,gradb_max,ghpbc_max,
 874      &     gradcorr_max,gel_loc_max,gcorr3_turn_max,gcorr4_turn_max,
 875      &     gradcorr5_max,gradcorr6_max,gcorr6_turn_max,gsccorc_max,
 876      &     gscloc_max,gvdwx_max,gradx_scp_max,ghpbx_max,gradxorr_max,
 877      &     gsccorx_max,gsclocx_max
 878         close(istat)
 879         if (gvdwc_max.gt.1.0d4) then
 880           write (iout,*) "gvdwc gvdwx gradb gradbx"
 881           do i=nnt,nct
 882             write(iout,'(i5,4(3f10.2,5x))') i,(gvdwc(j,i),gvdwx(j,i),
 883      &        gradb(j,i),gradbx(j,i),j=1,3)
 884           enddo
 885           call pdbout(0.0d0,'cipiszcze',iout)
 886           call flush(iout)
 887         endif
 888       endif
 889       endif
 890 #ifdef DEBUG
 891       write (iout,*) "gradc gradx gloc"
 892       do i=1,nres
 893         write (iout,'(i5,3f10.5,5x,3f10.5,5x,f10.5)')
 894      &   i,(gradc(j,i,icg),j=1,3),(gradx(j,i,icg),j=1,3),gloc(i,icg)
 895       enddo
 896 #endif
 897 #ifdef TIMING
 898       time_sumgradient=time_sumgradient+MPI_Wtime()-time01
 899 #endif
 900       return
 901       end
 902 c-------------------------------------------------------------------------------
 903       subroutine rescale_weights(t_bath)
 904       implicit real*8 (a-h,o-z)
 905       include 'DIMENSIONS'
 906       include 'COMMON.IOUNITS'
 907       include 'COMMON.FFIELD'
 908       include 'COMMON.SBRIDGE'
 909       double precision kfac /2.4d0/
 910       double precision x,x2,x3,x4,x5,licznik /1.12692801104297249644/
 911 c      facT=temp0/t_bath
 912 c      facT=2*temp0/(t_bath+temp0)
 913       if (rescale_mode.eq.0) then
 914         facT=1.0d0
 915         facT2=1.0d0
 916         facT3=1.0d0
 917         facT4=1.0d0
 918         facT5=1.0d0
 919       else if (rescale_mode.eq.1) then
 920         facT=kfac/(kfac-1.0d0+t_bath/temp0)
 921         facT2=kfac**2/(kfac**2-1.0d0+(t_bath/temp0)**2)
 922         facT3=kfac**3/(kfac**3-1.0d0+(t_bath/temp0)**3)
 923         facT4=kfac**4/(kfac**4-1.0d0+(t_bath/temp0)**4)
 924         facT5=kfac**5/(kfac**5-1.0d0+(t_bath/temp0)**5)
 925       else if (rescale_mode.eq.2) then
 926         x=t_bath/temp0
 927         x2=x*x
 928         x3=x2*x
 929         x4=x3*x
 930         x5=x4*x
 931         facT=licznik/dlog(dexp(x)+dexp(-x))
 932         facT2=licznik/dlog(dexp(x2)+dexp(-x2))
 933         facT3=licznik/dlog(dexp(x3)+dexp(-x3))
 934         facT4=licznik/dlog(dexp(x4)+dexp(-x4))
 935         facT5=licznik/dlog(dexp(x5)+dexp(-x5))
 936       else
 937         write (iout,*) "Wrong RESCALE_MODE",rescale_mode
 938         write (*,*) "Wrong RESCALE_MODE",rescale_mode
 939 #ifdef MPI
 940        call MPI_Finalize(MPI_COMM_WORLD,IERROR)
 941 #endif
 942        stop 555
 943       endif
 944       welec=weights(3)*fact
 945       wcorr=weights(4)*fact3
 946       wcorr5=weights(5)*fact4
 947       wcorr6=weights(6)*fact5
 948       wel_loc=weights(7)*fact2
 949       wturn3=weights(8)*fact2
 950       wturn4=weights(9)*fact3
 951       wturn6=weights(10)*fact5
 952       wtor=weights(13)*fact
 953       wtor_d=weights(14)*fact2
 954       wsccor=weights(21)*fact
 955
 956       return
 957       end
 958 C------------------------------------------------------------------------
 959       subroutine enerprint(energia)
 960       implicit real*8 (a-h,o-z)
 961       include 'DIMENSIONS'
 962       include 'COMMON.IOUNITS'
 963       include 'COMMON.FFIELD'
 964       include 'COMMON.SBRIDGE'
 965       include 'COMMON.MD'
 966       double precision energia(0:n_ene)
 967       etot=energia(0)
 968       evdw=energia(1)
 969       evdw2=energia(2)
 970 #ifdef SCP14
 971       evdw2=energia(2)+energia(18)
 972 #else
 973       evdw2=energia(2)
 974 #endif
 975       ees=energia(3)
 976 #ifdef SPLITELE
 977       evdw1=energia(16)
 978 #endif
 979       ecorr=energia(4)
 980       ecorr5=energia(5)
 981       ecorr6=energia(6)
 982       eel_loc=energia(7)
 983       eello_turn3=energia(8)
 984       eello_turn4=energia(9)
 985       eello_turn6=energia(10)
 986       ebe=energia(11)
 987       escloc=energia(12)
 988       etors=energia(13)
 989       etors_d=energia(14)
 990       ehpb=energia(15)
 991       edihcnstr=energia(19)
 992       estr=energia(17)
 993       Uconst=energia(20)
 994       esccor=energia(21)
 995       eliptran=energia(22)
 996 #ifdef SPLITELE
 997       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,evdw1,wvdwpp,
 998      &  estr,wbond,ebe,wang,
 999      &  escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,
1000      &  ecorr,wcorr,
1001      &  ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,
1002      &  eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccor,
1003      &  edihcnstr,ebr*nss,
1004      &  Uconst,eliptran,wliptran,etot
1005    10 format (/'Virtual-chain energies:'//
1006      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
1007      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
1008      & 'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/
1009      & 'EVDWPP=',1pE16.6,' WEIGHT=',1pD16.6,' (p-p VDW)'/
1010      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
1011      & 'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
1012      & 'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
1013      & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
1014      & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
1015      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6,
1016      & ' (SS bridges & dist. cnstr.)'/
1017      & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1018      & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1019      & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1020      & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
1021      & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
1022      & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
1023      & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
1024      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
1025      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
1026      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
1027      & 'UCONST= ',1pE16.6,' (Constraint energy)'/
1028      & 'ELT=',1pE16.6, ' WEIGHT=',1pD16.6,' (Lipid transfer energy)'/
1029      & 'ETOT=  ',1pE16.6,' (total)')
1030 #else
1031       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,
1032      &  estr,wbond,ebe,wang,
1033      &  escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,
1034      &  ecorr,wcorr,
1035      &  ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,
1036      &  eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccro,edihcnstr,
1037      &  ebr*nss,Uconst,eliptran,wliptran,etot
1038    10 format (/'Virtual-chain energies:'//
1039      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
1040      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
1041      & 'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/
1042      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
1043      & 'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
1044      & 'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
1045      & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
1046      & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
1047      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6,
1048      & ' (SS bridges & dist. cnstr.)'/
1049      & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1050      & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1051      & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1052      & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
1053      & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
1054      & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
1055      & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
1056      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
1057      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
1058      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
1059      & 'UCONST=',1pE16.6,' (Constraint energy)'/
1060      & 'ELT=',1pE16.6, ' WEIGHT=',1pD16.6,' (Lipid transfer energy)'/
1061      & 'ETOT=  ',1pE16.6,' (total)')
1062 #endif
1063       return
1064       end
1065 C-----------------------------------------------------------------------
1066       subroutine elj(evdw)
1067 C
1068 C This subroutine calculates the interaction energy of nonbonded side chains
1069 C assuming the LJ potential of interaction.
1070 C
1071       implicit real*8 (a-h,o-z)
1072       include 'DIMENSIONS'
1073       parameter (accur=1.0d-10)
1074       include 'COMMON.GEO'
1075       include 'COMMON.VAR'
1076       include 'COMMON.LOCAL'
1077       include 'COMMON.CHAIN'
1078       include 'COMMON.DERIV'
1079       include 'COMMON.INTERACT'
1080       include 'COMMON.TORSION'
1081       include 'COMMON.SBRIDGE'
1082       include 'COMMON.NAMES'
1083       include 'COMMON.IOUNITS'
1084       include 'COMMON.CONTACTS'
1085       dimension gg(3)
1086 c      write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
1087       evdw=0.0D0
1088       do i=iatsc_s,iatsc_e
1089         itypi=iabs(itype(i))
1090         if (itypi.eq.ntyp1) cycle
1091         itypi1=iabs(itype(i+1))
1092         xi=c(1,nres+i)
1093         yi=c(2,nres+i)
1094         zi=c(3,nres+i)
1095 C Change 12/1/95
1096         num_conti=0
1097 C
1098 C Calculate SC interaction energy.
1099 C
1100         do iint=1,nint_gr(i)
1101 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
1102 cd   &                  'iend=',iend(i,iint)
1103           do j=istart(i,iint),iend(i,iint)
1104             itypj=iabs(itype(j))
1105             if (itypj.eq.ntyp1) cycle
1106             xj=c(1,nres+j)-xi
1107             yj=c(2,nres+j)-yi
1108             zj=c(3,nres+j)-zi
1109 C Change 12/1/95 to calculate four-body interactions
1110             rij=xj*xj+yj*yj+zj*zj
1111             rrij=1.0D0/rij
1112 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
1113             eps0ij=eps(itypi,itypj)
1114             fac=rrij**expon2
1115 C have you changed here?
1116             e1=fac*fac*aa
1117             e2=fac*bb
1118             evdwij=e1+e2
1119 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1120 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1121 cd          write (iout,'(2(a3,i3,2x),6(1pd12.4)/2(3(1pd12.4),5x)/)')
1122 cd   &        restyp(itypi),i,restyp(itypj),j,a(itypi,itypj),
1123 cd   &        bb(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,epsi,sigm,
1124 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1125             evdw=evdw+evdwij
1126 C
1127 C Calculate the components of the gradient in DC and X
1128 C
1129             fac=-rrij*(e1+evdwij)
1130             gg(1)=xj*fac
1131             gg(2)=yj*fac
1132             gg(3)=zj*fac
1133             do k=1,3
1134               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1135               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1136               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1137               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1138             enddo
1139 cgrad            do k=i,j-1
1140 cgrad              do l=1,3
1141 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1142 cgrad              enddo
1143 cgrad            enddo
1144 C
1145 C 12/1/95, revised on 5/20/97
1146 C
1147 C Calculate the contact function. The ith column of the array JCONT will
1148 C contain the numbers of atoms that make contacts with the atom I (of numbers
1149 C greater than I). The arrays FACONT and GACONT will contain the values of
1150 C the contact function and its derivative.
1151 C
1152 C Uncomment next line, if the correlation interactions include EVDW explicitly.
1153 c           if (j.gt.i+1 .and. evdwij.le.0.0D0) then
1154 C Uncomment next line, if the correlation interactions are contact function only
1155             if (j.gt.i+1.and. eps0ij.gt.0.0D0) then
1156               rij=dsqrt(rij)
1157               sigij=sigma(itypi,itypj)
1158               r0ij=rs0(itypi,itypj)
1159 C
1160 C Check whether the SC's are not too far to make a contact.
1161 C
1162               rcut=1.5d0*r0ij
1163               call gcont(rij,rcut,1.0d0,0.2d0*rcut,fcont,fprimcont)
1164 C Add a new contact, if the SC's are close enough, but not too close (r<sigma).
1165 C
1166               if (fcont.gt.0.0D0) then
1167 C If the SC-SC distance if close to sigma, apply spline.
1168 cAdam           call gcont(-rij,-1.03d0*sigij,2.0d0*sigij,1.0d0,
1169 cAdam &             fcont1,fprimcont1)
1170 cAdam           fcont1=1.0d0-fcont1
1171 cAdam           if (fcont1.gt.0.0d0) then
1172 cAdam             fprimcont=fprimcont*fcont1+fcont*fprimcont1
1173 cAdam             fcont=fcont*fcont1
1174 cAdam           endif
1175 C Uncomment following 4 lines to have the geometric average of the epsilon0's
1176 cga             eps0ij=1.0d0/dsqrt(eps0ij)
1177 cga             do k=1,3
1178 cga               gg(k)=gg(k)*eps0ij
1179 cga             enddo
1180 cga             eps0ij=-evdwij*eps0ij
1181 C Uncomment for AL's type of SC correlation interactions.
1182 cadam           eps0ij=-evdwij
1183                 num_conti=num_conti+1
1184                 jcont(num_conti,i)=j
1185                 facont(num_conti,i)=fcont*eps0ij
1186                 fprimcont=eps0ij*fprimcont/rij
1187                 fcont=expon*fcont
1188 cAdam           gacont(1,num_conti,i)=-fprimcont*xj+fcont*gg(1)
1189 cAdam           gacont(2,num_conti,i)=-fprimcont*yj+fcont*gg(2)
1190 cAdam           gacont(3,num_conti,i)=-fprimcont*zj+fcont*gg(3)
1191 C Uncomment following 3 lines for Skolnick's type of SC correlation.
1192                 gacont(1,num_conti,i)=-fprimcont*xj
1193                 gacont(2,num_conti,i)=-fprimcont*yj
1194                 gacont(3,num_conti,i)=-fprimcont*zj
1195 cd              write (iout,'(2i5,2f10.5)') i,j,rij,facont(num_conti,i)
1196 cd              write (iout,'(2i3,3f10.5)')
1197 cd   &           i,j,(gacont(kk,num_conti,i),kk=1,3)
1198               endif
1199             endif
1200           enddo      ! j
1201         enddo        ! iint
1202 C Change 12/1/95
1203         num_cont(i)=num_conti
1204       enddo          ! i
1205       do i=1,nct
1206         do j=1,3
1207           gvdwc(j,i)=expon*gvdwc(j,i)
1208           gvdwx(j,i)=expon*gvdwx(j,i)
1209         enddo
1210       enddo
1211 C******************************************************************************
1212 C
1213 C                              N O T E !!!
1214 C
1215 C To save time, the factor of EXPON has been extracted from ALL components
1216 C of GVDWC and GRADX. Remember to multiply them by this factor before further
1217 C use!
1218 C
1219 C******************************************************************************
1220       return
1221       end
1222 C-----------------------------------------------------------------------------
1223       subroutine eljk(evdw)
1224 C
1225 C This subroutine calculates the interaction energy of nonbonded side chains
1226 C assuming the LJK potential of interaction.
1227 C
1228       implicit real*8 (a-h,o-z)
1229       include 'DIMENSIONS'
1230       include 'COMMON.GEO'
1231       include 'COMMON.VAR'
1232       include 'COMMON.LOCAL'
1233       include 'COMMON.CHAIN'
1234       include 'COMMON.DERIV'
1235       include 'COMMON.INTERACT'
1236       include 'COMMON.IOUNITS'
1237       include 'COMMON.NAMES'
1238       dimension gg(3)
1239       logical scheck
1240 c     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
1241       evdw=0.0D0
1242       do i=iatsc_s,iatsc_e
1243         itypi=iabs(itype(i))
1244         if (itypi.eq.ntyp1) cycle
1245         itypi1=iabs(itype(i+1))
1246         xi=c(1,nres+i)
1247         yi=c(2,nres+i)
1248         zi=c(3,nres+i)
1249 C
1250 C Calculate SC interaction energy.
1251 C
1252         do iint=1,nint_gr(i)
1253           do j=istart(i,iint),iend(i,iint)
1254             itypj=iabs(itype(j))
1255             if (itypj.eq.ntyp1) cycle
1256             xj=c(1,nres+j)-xi
1257             yj=c(2,nres+j)-yi
1258             zj=c(3,nres+j)-zi
1259             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1260             fac_augm=rrij**expon
1261             e_augm=augm(itypi,itypj)*fac_augm
1262             r_inv_ij=dsqrt(rrij)
1263             rij=1.0D0/r_inv_ij
1264             r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
1265             fac=r_shift_inv**expon
1266 C have you changed here?
1267             e1=fac*fac*aa
1268             e2=fac*bb
1269             evdwij=e_augm+e1+e2
1270 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1271 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1272 cd          write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
1273 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
1274 cd   &        bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
1275 cd   &        sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
1276 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1277             evdw=evdw+evdwij
1278 C
1279 C Calculate the components of the gradient in DC and X
1280 C
1281             fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
1282             gg(1)=xj*fac
1283             gg(2)=yj*fac
1284             gg(3)=zj*fac
1285             do k=1,3
1286               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1287               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1288               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1289               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1290             enddo
1291 cgrad            do k=i,j-1
1292 cgrad              do l=1,3
1293 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1294 cgrad              enddo
1295 cgrad            enddo
1296           enddo      ! j
1297         enddo        ! iint
1298       enddo          ! i
1299       do i=1,nct
1300         do j=1,3
1301           gvdwc(j,i)=expon*gvdwc(j,i)
1302           gvdwx(j,i)=expon*gvdwx(j,i)
1303         enddo
1304       enddo
1305       return
1306       end
1307 C-----------------------------------------------------------------------------
1308       subroutine ebp(evdw)
1309 C
1310 C This subroutine calculates the interaction energy of nonbonded side chains
1311 C assuming the Berne-Pechukas potential of interaction.
1312 C
1313       implicit real*8 (a-h,o-z)
1314       include 'DIMENSIONS'
1315       include 'COMMON.GEO'
1316       include 'COMMON.VAR'
1317       include 'COMMON.LOCAL'
1318       include 'COMMON.CHAIN'
1319       include 'COMMON.DERIV'
1320       include 'COMMON.NAMES'
1321       include 'COMMON.INTERACT'
1322       include 'COMMON.IOUNITS'
1323       include 'COMMON.CALC'
1324       common /srutu/ icall
1325 c     double precision rrsave(maxdim)
1326       logical lprn
1327       evdw=0.0D0
1328 c     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
1329       evdw=0.0D0
1330 c     if (icall.eq.0) then
1331 c       lprn=.true.
1332 c     else
1333         lprn=.false.
1334 c     endif
1335       ind=0
1336       do i=iatsc_s,iatsc_e
1337         itypi=iabs(itype(i))
1338         if (itypi.eq.ntyp1) cycle
1339         itypi1=iabs(itype(i+1))
1340         xi=c(1,nres+i)
1341         yi=c(2,nres+i)
1342         zi=c(3,nres+i)
1343         dxi=dc_norm(1,nres+i)
1344         dyi=dc_norm(2,nres+i)
1345         dzi=dc_norm(3,nres+i)
1346 c        dsci_inv=dsc_inv(itypi)
1347         dsci_inv=vbld_inv(i+nres)
1348 C
1349 C Calculate SC interaction energy.
1350 C
1351         do iint=1,nint_gr(i)
1352           do j=istart(i,iint),iend(i,iint)
1353             ind=ind+1
1354             itypj=iabs(itype(j))
1355             if (itypj.eq.ntyp1) cycle
1356 c            dscj_inv=dsc_inv(itypj)
1357             dscj_inv=vbld_inv(j+nres)
1358             chi1=chi(itypi,itypj)
1359             chi2=chi(itypj,itypi)
1360             chi12=chi1*chi2
1361             chip1=chip(itypi)
1362             chip2=chip(itypj)
1363             chip12=chip1*chip2
1364             alf1=alp(itypi)
1365             alf2=alp(itypj)
1366             alf12=0.5D0*(alf1+alf2)
1367 C For diagnostics only!!!
1368 c           chi1=0.0D0
1369 c           chi2=0.0D0
1370 c           chi12=0.0D0
1371 c           chip1=0.0D0
1372 c           chip2=0.0D0
1373 c           chip12=0.0D0
1374 c           alf1=0.0D0
1375 c           alf2=0.0D0
1376 c           alf12=0.0D0
1377             xj=c(1,nres+j)-xi
1378             yj=c(2,nres+j)-yi
1379             zj=c(3,nres+j)-zi
1380             dxj=dc_norm(1,nres+j)
1381             dyj=dc_norm(2,nres+j)
1382             dzj=dc_norm(3,nres+j)
1383             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1384 cd          if (icall.eq.0) then
1385 cd            rrsave(ind)=rrij
1386 cd          else
1387 cd            rrij=rrsave(ind)
1388 cd          endif
1389             rij=dsqrt(rrij)
1390 C Calculate the angle-dependent terms of energy & contributions to derivatives.
1391             call sc_angular
1392 C Calculate whole angle-dependent part of epsilon and contributions
1393 C to its derivatives
1394 C have you changed here?
1395             fac=(rrij*sigsq)**expon2
1396             e1=fac*fac*aa
1397             e2=fac*bb
1398             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1399             eps2der=evdwij*eps3rt
1400             eps3der=evdwij*eps2rt
1401             evdwij=evdwij*eps2rt*eps3rt
1402             evdw=evdw+evdwij
1403             if (lprn) then
1404             sigm=dabs(aa/bb)**(1.0D0/6.0D0)
1405             epsi=bb**2/aa
1406 cd            write (iout,'(2(a3,i3,2x),15(0pf7.3))')
1407 cd     &        restyp(itypi),i,restyp(itypj),j,
1408 cd     &        epsi,sigm,chi1,chi2,chip1,chip2,
1409 cd     &        eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
1410 cd     &        om1,om2,om12,1.0D0/dsqrt(rrij),
1411 cd     &        evdwij
1412             endif
1413 C Calculate gradient components.
1414             e1=e1*eps1*eps2rt**2*eps3rt**2
1415             fac=-expon*(e1+evdwij)
1416             sigder=fac/sigsq
1417             fac=rrij*fac
1418 C Calculate radial part of the gradient
1419             gg(1)=xj*fac
1420             gg(2)=yj*fac
1421             gg(3)=zj*fac
1422 C Calculate the angular part of the gradient and sum add the contributions
1423 C to the appropriate components of the Cartesian gradient.
1424             call sc_grad
1425           enddo      ! j
1426         enddo        ! iint
1427       enddo          ! i
1428 c     stop
1429       return
1430       end
1431 C-----------------------------------------------------------------------------
1432       subroutine egb(evdw)
1433 C
1434 C This subroutine calculates the interaction energy of nonbonded side chains
1435 C assuming the Gay-Berne potential of interaction.
1436 C
1437       implicit real*8 (a-h,o-z)
1438       include 'DIMENSIONS'
1439       include 'COMMON.GEO'
1440       include 'COMMON.VAR'
1441       include 'COMMON.LOCAL'
1442       include 'COMMON.CHAIN'
1443       include 'COMMON.DERIV'
1444       include 'COMMON.NAMES'
1445       include 'COMMON.INTERACT'
1446       include 'COMMON.IOUNITS'
1447       include 'COMMON.CALC'
1448       include 'COMMON.CONTROL'
1449       include 'COMMON.SPLITELE'
1450       include 'COMMON.SBRIDGE'
1451       logical lprn
1452       integer xshift,yshift,zshift
1453       evdw=0.0D0
1454 ccccc      energy_dec=.false.
1455 C      print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1456       evdw=0.0D0
1457       lprn=.false.
1458 c     if (icall.eq.0) lprn=.false.
1459       ind=0
1460 C the loop over all 27 posible neigbours (for xshift=0,yshift=0,zshift=0
1461 C we have the original box)
1462 C      do xshift=-1,1
1463 C      do yshift=-1,1
1464 C      do zshift=-1,1
1465       do i=iatsc_s,iatsc_e
1466         itypi=iabs(itype(i))
1467         if (itypi.eq.ntyp1) cycle
1468         itypi1=iabs(itype(i+1))
1469         xi=c(1,nres+i)
1470         yi=c(2,nres+i)
1471         zi=c(3,nres+i)
1472 C Return atom into box, boxxsize is size of box in x dimension
1473 c  134   continue
1474 c        if (xi.gt.((xshift+0.5d0)*boxxsize)) xi=xi-boxxsize
1475 c        if (xi.lt.((xshift-0.5d0)*boxxsize)) xi=xi+boxxsize
1476 C Condition for being inside the proper box
1477 c        if ((xi.gt.((xshift+0.5d0)*boxxsize)).or.
1478 c     &       (xi.lt.((xshift-0.5d0)*boxxsize))) then
1479 c        go to 134
1480 c        endif
1481 c  135   continue
1482 c        if (yi.gt.((yshift+0.5d0)*boxysize)) yi=yi-boxysize
1483 c        if (yi.lt.((yshift-0.5d0)*boxysize)) yi=yi+boxysize
1484 C Condition for being inside the proper box
1485 c        if ((yi.gt.((yshift+0.5d0)*boxysize)).or.
1486 c     &       (yi.lt.((yshift-0.5d0)*boxysize))) then
1487 c        go to 135
1488 c        endif
1489 c  136   continue
1490 c        if (zi.gt.((zshift+0.5d0)*boxzsize)) zi=zi-boxzsize
1491 c        if (zi.lt.((zshift-0.5d0)*boxzsize)) zi=zi+boxzsize
1492 C Condition for being inside the proper box
1493 c        if ((zi.gt.((zshift+0.5d0)*boxzsize)).or.
1494 c     &       (zi.lt.((zshift-0.5d0)*boxzsize))) then
1495 c        go to 136
1496 c        endif
1497           xi=mod(xi,boxxsize)
1498           if (xi.lt.0) xi=xi+boxxsize
1499           yi=mod(yi,boxysize)
1500           if (yi.lt.0) yi=yi+boxysize
1501           zi=mod(zi,boxzsize)
1502           if (zi.lt.0) zi=zi+boxzsize
1503 C define scaling factor for lipids
1504
1505 C        if (positi.le.0) positi=positi+boxzsize
1506 C        print *,i
1507 C first for peptide groups
1508 c for each residue check if it is in lipid or lipid water border area
1509        if ((zi.gt.bordlipbot)
1510      &.and.(zi.lt.bordliptop)) then
1511 C the energy transfer exist
1512         if (zi.lt.buflipbot) then
1513 C what fraction I am in
1514          fracinbuf=1.0d0-
1515      &        ((zi-bordlipbot)/lipbufthick)
1516 C lipbufthick is thickenes of lipid buffore
1517          sslipi=sscalelip(fracinbuf)
1518          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
1519         elseif (zi.gt.bufliptop) then
1520          fracinbuf=1.0d0-((bordliptop-zi)/lipbufthick)
1521          sslipi=sscalelip(fracinbuf)
1522          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
1523         else
1524          sslipi=1.0d0
1525          ssgradlipi=0.0
1526         endif
1527        else
1528          sslipi=0.0d0
1529          ssgradlipi=0.0
1530        endif
1531
1532 C          xi=xi+xshift*boxxsize
1533 C          yi=yi+yshift*boxysize
1534 C          zi=zi+zshift*boxzsize
1535
1536         dxi=dc_norm(1,nres+i)
1537         dyi=dc_norm(2,nres+i)
1538         dzi=dc_norm(3,nres+i)
1539 c        dsci_inv=dsc_inv(itypi)
1540         dsci_inv=vbld_inv(i+nres)
1541 c        write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)
1542 c        write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi
1543 C
1544 C Calculate SC interaction energy.
1545 C
1546         do iint=1,nint_gr(i)
1547           do j=istart(i,iint),iend(i,iint)
1548             IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN
1549               call dyn_ssbond_ene(i,j,evdwij)
1550               evdw=evdw+evdwij
1551               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)')
1552      &                        'evdw',i,j,evdwij,' ss'
1553             ELSE
1554             ind=ind+1
1555             itypj=iabs(itype(j))
1556             if (itypj.eq.ntyp1) cycle
1557 c            dscj_inv=dsc_inv(itypj)
1558             dscj_inv=vbld_inv(j+nres)
1559 c            write (iout,*) "j",j,dsc_inv(itypj),dscj_inv,
1560 c     &       1.0d0/vbld(j+nres)
1561 c            write (iout,*) "i",i," j", j," itype",itype(i),itype(j)
1562             sig0ij=sigma(itypi,itypj)
1563             chi1=chi(itypi,itypj)
1564             chi2=chi(itypj,itypi)
1565             chi12=chi1*chi2
1566             chip1=chip(itypi)
1567             chip2=chip(itypj)
1568             chip12=chip1*chip2
1569             alf1=alp(itypi)
1570             alf2=alp(itypj)
1571             alf12=0.5D0*(alf1+alf2)
1572 C For diagnostics only!!!
1573 c           chi1=0.0D0
1574 c           chi2=0.0D0
1575 c           chi12=0.0D0
1576 c           chip1=0.0D0
1577 c           chip2=0.0D0
1578 c           chip12=0.0D0
1579 c           alf1=0.0D0
1580 c           alf2=0.0D0
1581 c           alf12=0.0D0
1582             xj=c(1,nres+j)
1583             yj=c(2,nres+j)
1584             zj=c(3,nres+j)
1585 C Return atom J into box the original box
1586 c  137   continue
1587 c        if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
1588 c        if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
1589 C Condition for being inside the proper box
1590 c        if ((xj.gt.((0.5d0)*boxxsize)).or.
1591 c     &       (xj.lt.((-0.5d0)*boxxsize))) then
1592 c        go to 137
1593 c        endif
1594 c  138   continue
1595 c        if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
1596 c        if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
1597 C Condition for being inside the proper box
1598 c        if ((yj.gt.((0.5d0)*boxysize)).or.
1599 c     &       (yj.lt.((-0.5d0)*boxysize))) then
1600 c        go to 138
1601 c        endif
1602 c  139   continue
1603 c        if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
1604 c        if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
1605 C Condition for being inside the proper box
1606 c        if ((zj.gt.((0.5d0)*boxzsize)).or.
1607 c     &       (zj.lt.((-0.5d0)*boxzsize))) then
1608 c        go to 139
1609 c        endif
1610           xj=mod(xj,boxxsize)
1611           if (xj.lt.0) xj=xj+boxxsize
1612           yj=mod(yj,boxysize)
1613           if (yj.lt.0) yj=yj+boxysize
1614           zj=mod(zj,boxzsize)
1615           if (zj.lt.0) zj=zj+boxzsize
1616        if ((zj.gt.bordlipbot)
1617      &.and.(zj.lt.bordliptop)) then
1618 C the energy transfer exist
1619         if (zj.lt.buflipbot) then
1620 C what fraction I am in
1621          fracinbuf=1.0d0-
1622      &        ((zj-bordlipbot)/lipbufthick)
1623 C lipbufthick is thickenes of lipid buffore
1624          sslipj=sscalelip(fracinbuf)
1625          ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
1626         elseif (zi.gt.bufliptop) then
1627          fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
1628          sslipj=sscalelip(fracinbuf)
1629          ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
1630         else
1631          sslipj=1.0d0
1632          ssgradlipj=0.0
1633         endif
1634        else
1635          sslipj=0.0d0
1636          ssgradlipj=0.0
1637        endif
1638       aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
1639      &  +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1640       bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
1641      &  +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1642       if (aa.ne.aa_aq(itypi,itypj)) write(63,'(2e10.5)')
1643      &(aa-aa_aq(itypi,itypj)),(bb-bb_aq(itypi,itypj))
1644 C      if (ssgradlipj.gt.0.0d0) print *,"??WTF??"
1645       print *,sslipi,sslipj,bordlipbot,zi,zj
1646       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
1647       xj_safe=xj
1648       yj_safe=yj
1649       zj_safe=zj
1650       subchap=0
1651       do xshift=-1,1
1652       do yshift=-1,1
1653       do zshift=-1,1
1654           xj=xj_safe+xshift*boxxsize
1655           yj=yj_safe+yshift*boxysize
1656           zj=zj_safe+zshift*boxzsize
1657           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
1658           if(dist_temp.lt.dist_init) then
1659             dist_init=dist_temp
1660             xj_temp=xj
1661             yj_temp=yj
1662             zj_temp=zj
1663             subchap=1
1664           endif
1665        enddo
1666        enddo
1667        enddo
1668        if (subchap.eq.1) then
1669           xj=xj_temp-xi
1670           yj=yj_temp-yi
1671           zj=zj_temp-zi
1672        else
1673           xj=xj_safe-xi
1674           yj=yj_safe-yi
1675           zj=zj_safe-zi
1676        endif
1677             dxj=dc_norm(1,nres+j)
1678             dyj=dc_norm(2,nres+j)
1679             dzj=dc_norm(3,nres+j)
1680 C            xj=xj-xi
1681 C            yj=yj-yi
1682 C            zj=zj-zi
1683 c            write (iout,*) "dcnorj",dxi*dxi+dyi*dyi+dzi*dzi
1684 c            write (iout,*) "j",j," dc_norm",
1685 c     &       dc_norm(1,nres+j),dc_norm(2,nres+j),dc_norm(3,nres+j)
1686             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1687             rij=dsqrt(rrij)
1688             sss=sscale((1.0d0/rij)/sigma(itypi,itypj))
1689             sssgrad=sscagrad((1.0d0/rij)/sigma(itypi,itypj))
1690
1691 c            write (iout,'(a7,4f8.3)')
1692 c    &      "ssscale",sss,((1.0d0/rij)/sigma(itypi,itypj)),r_cut,rlamb
1693             if (sss.gt.0.0d0) then
1694 C Calculate angle-dependent terms of energy and contributions to their
1695 C derivatives.
1696             call sc_angular
1697             sigsq=1.0D0/sigsq
1698             sig=sig0ij*dsqrt(sigsq)
1699             rij_shift=1.0D0/rij-sig+sig0ij
1700 c for diagnostics; uncomment
1701 c            rij_shift=1.2*sig0ij
1702 C I hate to put IF's in the loops, but here don't have another choice!!!!
1703             if (rij_shift.le.0.0D0) then
1704               evdw=1.0D20
1705 cd              write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1706 cd     &        restyp(itypi),i,restyp(itypj),j,
1707 cd     &        rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq)
1708               return
1709             endif
1710             sigder=-sig*sigsq
1711 c---------------------------------------------------------------
1712             rij_shift=1.0D0/rij_shift
1713             fac=rij_shift**expon
1714 C here to start with
1715 C            if (c(i,3).gt.
1716             faclip=fac
1717             e1=fac*fac*aa
1718             e2=fac*bb
1719             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1720             eps2der=evdwij*eps3rt
1721             eps3der=evdwij*eps2rt
1722 C       write(63,'(2i3,2e10.3,2f10.5)') i,j,aa,bb, evdwij,
1723 C     &((sslipi+sslipj)/2.0d0+
1724 C     &(2.0d0-sslipi-sslipj)/2.0d0)
1725 c            write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt,
1726 c     &        " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2
1727             evdwij=evdwij*eps2rt*eps3rt
1728             evdw=evdw+evdwij*sss
1729             if (lprn) then
1730             sigm=dabs(aa/bb)**(1.0D0/6.0D0)
1731             epsi=bb**2/aa
1732             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1733      &        restyp(itypi),i,restyp(itypj),j,
1734      &        epsi,sigm,chi1,chi2,chip1,chip2,
1735      &        eps1,eps2rt**2,eps3rt**2,sig,sig0ij,
1736      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1737      &        evdwij
1738             endif
1739
1740             if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
1741      &                        'evdw',i,j,evdwij
1742
1743 C Calculate gradient components.
1744             e1=e1*eps1*eps2rt**2*eps3rt**2
1745             fac=-expon*(e1+evdwij)*rij_shift
1746             sigder=fac*sigder
1747             fac=rij*fac
1748 c            print '(2i4,6f8.4)',i,j,sss,sssgrad*
1749 c     &      evdwij,fac,sigma(itypi,itypj),expon
1750             fac=fac+evdwij/sss*sssgrad/sigma(itypi,itypj)*rij
1751 c            fac=0.0d0
1752 C Calculate the radial part of the gradient
1753             gg_lipi(3)=eps1*(eps2rt*eps2rt)
1754      &*(eps3rt*eps3rt)*sss/2.0d0*(faclip*faclip*
1755      & (aa_lip(itypi,itypj)-aa_aq(itypi,itypj))
1756      &+faclip*(bb_lip(itypi,itypj)-bb_aq(itypi,itypj)))
1757             gg_lipj(3)=ssgradlipj*gg_lipi(3)
1758             gg_lipi(3)=gg_lipi(3)*ssgradlipi
1759 C            gg_lipi(3)=0.0d0
1760 C            gg_lipj(3)=0.0d0
1761             gg(1)=xj*fac
1762             gg(2)=yj*fac
1763             gg(3)=zj*fac
1764 C Calculate angular part of the gradient.
1765             call sc_grad
1766             endif
1767             ENDIF    ! dyn_ss
1768           enddo      ! j
1769         enddo        ! iint
1770       enddo          ! i
1771 C      enddo          ! zshift
1772 C      enddo          ! yshift
1773 C      enddo          ! xshift
1774 c      write (iout,*) "Number of loop steps in EGB:",ind
1775 cccc      energy_dec=.false.
1776       return
1777       end
1778 C-----------------------------------------------------------------------------
1779       subroutine egbv(evdw)
1780 C
1781 C This subroutine calculates the interaction energy of nonbonded side chains
1782 C assuming the Gay-Berne-Vorobjev potential of interaction.
1783 C
1784       implicit real*8 (a-h,o-z)
1785       include 'DIMENSIONS'
1786       include 'COMMON.GEO'
1787       include 'COMMON.VAR'
1788       include 'COMMON.LOCAL'
1789       include 'COMMON.CHAIN'
1790       include 'COMMON.DERIV'
1791       include 'COMMON.NAMES'
1792       include 'COMMON.INTERACT'
1793       include 'COMMON.IOUNITS'
1794       include 'COMMON.CALC'
1795       common /srutu/ icall
1796       logical lprn
1797       evdw=0.0D0
1798 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1799       evdw=0.0D0
1800       lprn=.false.
1801 c     if (icall.eq.0) lprn=.true.
1802       ind=0
1803       do i=iatsc_s,iatsc_e
1804         itypi=iabs(itype(i))
1805         if (itypi.eq.ntyp1) cycle
1806         itypi1=iabs(itype(i+1))
1807         xi=c(1,nres+i)
1808         yi=c(2,nres+i)
1809         zi=c(3,nres+i)
1810           xi=mod(xi,boxxsize)
1811           if (xi.lt.0) xi=xi+boxxsize
1812           yi=mod(yi,boxysize)
1813           if (yi.lt.0) yi=yi+boxysize
1814           zi=mod(zi,boxzsize)
1815           if (zi.lt.0) zi=zi+boxzsize
1816 C define scaling factor for lipids
1817
1818 C        if (positi.le.0) positi=positi+boxzsize
1819 C        print *,i
1820 C first for peptide groups
1821 c for each residue check if it is in lipid or lipid water border area
1822        if ((zi.gt.bordlipbot)
1823      &.and.(zi.lt.bordliptop)) then
1824 C the energy transfer exist
1825         if (zi.lt.buflipbot) then
1826 C what fraction I am in
1827          fracinbuf=1.0d0-
1828      &        ((positi-bordlipbot)/lipbufthick)
1829 C lipbufthick is thickenes of lipid buffore
1830          sslipi=sscalelip(fracinbuf)
1831          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
1832         elseif (zi.gt.bufliptop) then
1833          fracinbuf=1.0d0-((bordliptop-positi)/lipbufthick)
1834          sslipi=sscalelip(fracinbuf)
1835          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
1836         else
1837          sslipi=1.0d0
1838          ssgradlipi=0.0
1839         endif
1840        else
1841          sslipi=0.0d0
1842          ssgradlipi=0.0
1843        endif
1844
1845         dxi=dc_norm(1,nres+i)
1846         dyi=dc_norm(2,nres+i)
1847         dzi=dc_norm(3,nres+i)
1848 c        dsci_inv=dsc_inv(itypi)
1849         dsci_inv=vbld_inv(i+nres)
1850 C
1851 C Calculate SC interaction energy.
1852 C
1853         do iint=1,nint_gr(i)
1854           do j=istart(i,iint),iend(i,iint)
1855             ind=ind+1
1856             itypj=iabs(itype(j))
1857             if (itypj.eq.ntyp1) cycle
1858 c            dscj_inv=dsc_inv(itypj)
1859             dscj_inv=vbld_inv(j+nres)
1860             sig0ij=sigma(itypi,itypj)
1861             r0ij=r0(itypi,itypj)
1862             chi1=chi(itypi,itypj)
1863             chi2=chi(itypj,itypi)
1864             chi12=chi1*chi2
1865             chip1=chip(itypi)
1866             chip2=chip(itypj)
1867             chip12=chip1*chip2
1868             alf1=alp(itypi)
1869             alf2=alp(itypj)
1870             alf12=0.5D0*(alf1+alf2)
1871 C For diagnostics only!!!
1872 c           chi1=0.0D0
1873 c           chi2=0.0D0
1874 c           chi12=0.0D0
1875 c           chip1=0.0D0
1876 c           chip2=0.0D0
1877 c           chip12=0.0D0
1878 c           alf1=0.0D0
1879 c           alf2=0.0D0
1880 c           alf12=0.0D0
1881 C            xj=c(1,nres+j)-xi
1882 C            yj=c(2,nres+j)-yi
1883 C            zj=c(3,nres+j)-zi
1884           xj=mod(xj,boxxsize)
1885           if (xj.lt.0) xj=xj+boxxsize
1886           yj=mod(yj,boxysize)
1887           if (yj.lt.0) yj=yj+boxysize
1888           zj=mod(zj,boxzsize)
1889           if (zj.lt.0) zj=zj+boxzsize
1890        if ((zj.gt.bordlipbot)
1891      &.and.(zj.lt.bordliptop)) then
1892 C the energy transfer exist
1893         if (zj.lt.buflipbot) then
1894 C what fraction I am in
1895          fracinbuf=1.0d0-
1896      &        ((positi-bordlipbot)/lipbufthick)
1897 C lipbufthick is thickenes of lipid buffore
1898          sslipj=sscalelip(fracinbuf)
1899          ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
1900         elseif (zi.gt.bufliptop) then
1901          fracinbuf=1.0d0-((bordliptop-positi)/lipbufthick)
1902          sslipj=sscalelip(fracinbuf)
1903          ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
1904         else
1905          sslipj=1.0d0
1906          ssgradlipj=0.0
1907         endif
1908        else
1909          sslipj=0.0d0
1910          ssgradlipj=0.0
1911        endif
1912       aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
1913      &  +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1914       bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
1915      &  +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1916 C      if (aa.ne.aa_aq(itypi,itypj)) write(63,'2e10.5')
1917 C     &(aa-aa_aq(itypi,itypj)),(bb-bb_aq(itypi,itypj))
1918       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
1919       xj_safe=xj
1920       yj_safe=yj
1921       zj_safe=zj
1922       subchap=0
1923       do xshift=-1,1
1924       do yshift=-1,1
1925       do zshift=-1,1
1926           xj=xj_safe+xshift*boxxsize
1927           yj=yj_safe+yshift*boxysize
1928           zj=zj_safe+zshift*boxzsize
1929           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
1930           if(dist_temp.lt.dist_init) then
1931             dist_init=dist_temp
1932             xj_temp=xj
1933             yj_temp=yj
1934             zj_temp=zj
1935             subchap=1
1936           endif
1937        enddo
1938        enddo
1939        enddo
1940        if (subchap.eq.1) then
1941           xj=xj_temp-xi
1942           yj=yj_temp-yi
1943           zj=zj_temp-zi
1944        else
1945           xj=xj_safe-xi
1946           yj=yj_safe-yi
1947           zj=zj_safe-zi
1948        endif
1949             dxj=dc_norm(1,nres+j)
1950             dyj=dc_norm(2,nres+j)
1951             dzj=dc_norm(3,nres+j)
1952             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1953             rij=dsqrt(rrij)
1954 C Calculate angle-dependent terms of energy and contributions to their
1955 C derivatives.
1956             call sc_angular
1957             sigsq=1.0D0/sigsq
1958             sig=sig0ij*dsqrt(sigsq)
1959             rij_shift=1.0D0/rij-sig+r0ij
1960 C I hate to put IF's in the loops, but here don't have another choice!!!!
1961             if (rij_shift.le.0.0D0) then
1962               evdw=1.0D20
1963               return
1964             endif
1965             sigder=-sig*sigsq
1966 c---------------------------------------------------------------
1967             rij_shift=1.0D0/rij_shift
1968             fac=rij_shift**expon
1969             e1=fac*fac*aa
1970             e2=fac*bb
1971             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1972             eps2der=evdwij*eps3rt
1973             eps3der=evdwij*eps2rt
1974             fac_augm=rrij**expon
1975             e_augm=augm(itypi,itypj)*fac_augm
1976             evdwij=evdwij*eps2rt*eps3rt
1977             evdw=evdw+evdwij+e_augm
1978             if (lprn) then
1979             sigm=dabs(aa/bb)**(1.0D0/6.0D0)
1980             epsi=bb**2/aa
1981             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1982      &        restyp(itypi),i,restyp(itypj),j,
1983      &        epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),
1984      &        chi1,chi2,chip1,chip2,
1985      &        eps1,eps2rt**2,eps3rt**2,
1986      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1987      &        evdwij+e_augm
1988             endif
1989 C Calculate gradient components.
1990             e1=e1*eps1*eps2rt**2*eps3rt**2
1991             fac=-expon*(e1+evdwij)*rij_shift
1992             sigder=fac*sigder
1993             fac=rij*fac-2*expon*rrij*e_augm
1994             fac=fac+evdwij/sss*sssgrad/sigma(itypi,itypj)*rij
1995 C Calculate the radial part of the gradient
1996             gg(1)=xj*fac
1997             gg(2)=yj*fac
1998             gg(3)=zj*fac
1999 C Calculate angular part of the gradient.
2000             call sc_grad
2001           enddo      ! j
2002         enddo        ! iint
2003       enddo          ! i
2004       end
2005 C-----------------------------------------------------------------------------
2006       subroutine sc_angular
2007 C Calculate eps1,eps2,eps3,sigma, and parts of their derivatives in om1,om2,
2008 C om12. Called by ebp, egb, and egbv.
2009       implicit none
2010       include 'COMMON.CALC'
2011       include 'COMMON.IOUNITS'
2012       erij(1)=xj*rij
2013       erij(2)=yj*rij
2014       erij(3)=zj*rij
2015       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
2016       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
2017       om12=dxi*dxj+dyi*dyj+dzi*dzj
2018       chiom12=chi12*om12
2019 C Calculate eps1(om12) and its derivative in om12
2020       faceps1=1.0D0-om12*chiom12
2021       faceps1_inv=1.0D0/faceps1
2022       eps1=dsqrt(faceps1_inv)
2023 C Following variable is eps1*deps1/dom12
2024       eps1_om12=faceps1_inv*chiom12
2025 c diagnostics only
2026 c      faceps1_inv=om12
2027 c      eps1=om12
2028 c      eps1_om12=1.0d0
2029 c      write (iout,*) "om12",om12," eps1",eps1
2030 C Calculate sigma(om1,om2,om12) and the derivatives of sigma**2 in om1,om2,
2031 C and om12.
2032       om1om2=om1*om2
2033       chiom1=chi1*om1
2034       chiom2=chi2*om2
2035       facsig=om1*chiom1+om2*chiom2-2.0D0*om1om2*chiom12
2036       sigsq=1.0D0-facsig*faceps1_inv
2037       sigsq_om1=(chiom1-chiom12*om2)*faceps1_inv
2038       sigsq_om2=(chiom2-chiom12*om1)*faceps1_inv
2039       sigsq_om12=-chi12*(om1om2*faceps1-om12*facsig)*faceps1_inv**2
2040 c diagnostics only
2041 c      sigsq=1.0d0
2042 c      sigsq_om1=0.0d0
2043 c      sigsq_om2=0.0d0
2044 c      sigsq_om12=0.0d0
2045 c      write (iout,*) "chiom1",chiom1," chiom2",chiom2," chiom12",chiom12
2046 c      write (iout,*) "faceps1",faceps1," faceps1_inv",faceps1_inv,
2047 c     &    " eps1",eps1
2048 C Calculate eps2 and its derivatives in om1, om2, and om12.
2049       chipom1=chip1*om1
2050       chipom2=chip2*om2
2051       chipom12=chip12*om12
2052       facp=1.0D0-om12*chipom12
2053       facp_inv=1.0D0/facp
2054       facp1=om1*chipom1+om2*chipom2-2.0D0*om1om2*chipom12
2055 c      write (iout,*) "chipom1",chipom1," chipom2",chipom2,
2056 c     &  " chipom12",chipom12," facp",facp," facp_inv",facp_inv
2057 C Following variable is the square root of eps2
2058       eps2rt=1.0D0-facp1*facp_inv
2059 C Following three variables are the derivatives of the square root of eps
2060 C in om1, om2, and om12.
2061       eps2rt_om1=-4.0D0*(chipom1-chipom12*om2)*facp_inv
2062       eps2rt_om2=-4.0D0*(chipom2-chipom12*om1)*facp_inv
2063       eps2rt_om12=4.0D0*chip12*(om1om2*facp-om12*facp1)*facp_inv**2
2064 C Evaluate the "asymmetric" factor in the VDW constant, eps3
2065       eps3rt=1.0D0-alf1*om1+alf2*om2-alf12*om12
2066 c      write (iout,*) "eps2rt",eps2rt," eps3rt",eps3rt
2067 c      write (iout,*) "eps2rt_om1",eps2rt_om1," eps2rt_om2",eps2rt_om2,
2068 c     &  " eps2rt_om12",eps2rt_om12
2069 C Calculate whole angle-dependent part of epsilon and contributions
2070 C to its derivatives
2071       return
2072       end
2073 C----------------------------------------------------------------------------
2074       subroutine sc_grad
2075       implicit real*8 (a-h,o-z)
2076       include 'DIMENSIONS'
2077       include 'COMMON.CHAIN'
2078       include 'COMMON.DERIV'
2079       include 'COMMON.CALC'
2080       include 'COMMON.IOUNITS'
2081       double precision dcosom1(3),dcosom2(3)
2082 cc      print *,'sss=',sss
2083       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
2084       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
2085       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12
2086      &     -2.0D0*alf12*eps3der+sigder*sigsq_om12
2087 c diagnostics only
2088 c      eom1=0.0d0
2089 c      eom2=0.0d0
2090 c      eom12=evdwij*eps1_om12
2091 c end diagnostics
2092 c      write (iout,*) "eps2der",eps2der," eps3der",eps3der,
2093 c     &  " sigder",sigder
2094 c      write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12
2095 c      write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12
2096       do k=1,3
2097         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
2098         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
2099       enddo
2100       do k=1,3
2101         gg(k)=(gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k))*sss
2102       enddo
2103 c      write (iout,*) "gg",(gg(k),k=1,3)
2104       do k=1,3
2105         gvdwx(k,i)=gvdwx(k,i)-gg(k)+gg_lipi(k)
2106      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
2107      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv*sss
2108         gvdwx(k,j)=gvdwx(k,j)+gg(k)+gg_lipj(k)
2109      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
2110      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv*sss
2111 c        write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
2112 c     &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
2113 c        write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
2114 c     &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
2115       enddo
2116 C
2117 C Calculate the components of the gradient in DC and X
2118 C
2119 cgrad      do k=i,j-1
2120 cgrad        do l=1,3
2121 cgrad          gvdwc(l,k)=gvdwc(l,k)+gg(l)
2122 cgrad        enddo
2123 cgrad      enddo
2124       do l=1,3
2125         gvdwc(l,i)=gvdwc(l,i)-gg(l)+gg_lipi(l)
2126         gvdwc(l,j)=gvdwc(l,j)+gg(l)+gg_lipj(l)
2127       enddo
2128       return
2129       end
2130 C-----------------------------------------------------------------------
2131       subroutine e_softsphere(evdw)
2132 C
2133 C This subroutine calculates the interaction energy of nonbonded side chains
2134 C assuming the LJ potential of interaction.
2135 C
2136       implicit real*8 (a-h,o-z)
2137       include 'DIMENSIONS'
2138       parameter (accur=1.0d-10)
2139       include 'COMMON.GEO'
2140       include 'COMMON.VAR'
2141       include 'COMMON.LOCAL'
2142       include 'COMMON.CHAIN'
2143       include 'COMMON.DERIV'
2144       include 'COMMON.INTERACT'
2145       include 'COMMON.TORSION'
2146       include 'COMMON.SBRIDGE'
2147       include 'COMMON.NAMES'
2148       include 'COMMON.IOUNITS'
2149       include 'COMMON.CONTACTS'
2150       dimension gg(3)
2151 cd    print *,'Entering Esoft_sphere nnt=',nnt,' nct=',nct
2152       evdw=0.0D0
2153       do i=iatsc_s,iatsc_e
2154         itypi=iabs(itype(i))
2155         if (itypi.eq.ntyp1) cycle
2156         itypi1=iabs(itype(i+1))
2157         xi=c(1,nres+i)
2158         yi=c(2,nres+i)
2159         zi=c(3,nres+i)
2160 C
2161 C Calculate SC interaction energy.
2162 C
2163         do iint=1,nint_gr(i)
2164 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
2165 cd   &                  'iend=',iend(i,iint)
2166           do j=istart(i,iint),iend(i,iint)
2167             itypj=iabs(itype(j))
2168             if (itypj.eq.ntyp1) cycle
2169             xj=c(1,nres+j)-xi
2170             yj=c(2,nres+j)-yi
2171             zj=c(3,nres+j)-zi
2172             rij=xj*xj+yj*yj+zj*zj
2173 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
2174             r0ij=r0(itypi,itypj)
2175             r0ijsq=r0ij*r0ij
2176 c            print *,i,j,r0ij,dsqrt(rij)
2177             if (rij.lt.r0ijsq) then
2178               evdwij=0.25d0*(rij-r0ijsq)**2
2179               fac=rij-r0ijsq
2180             else
2181               evdwij=0.0d0
2182               fac=0.0d0
2183             endif
2184             evdw=evdw+evdwij
2185 C
2186 C Calculate the components of the gradient in DC and X
2187 C
2188             gg(1)=xj*fac
2189             gg(2)=yj*fac
2190             gg(3)=zj*fac
2191             do k=1,3
2192               gvdwx(k,i)=gvdwx(k,i)-gg(k)
2193               gvdwx(k,j)=gvdwx(k,j)+gg(k)
2194               gvdwc(k,i)=gvdwc(k,i)-gg(k)
2195               gvdwc(k,j)=gvdwc(k,j)+gg(k)
2196             enddo
2197 cgrad            do k=i,j-1
2198 cgrad              do l=1,3
2199 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
2200 cgrad              enddo
2201 cgrad            enddo
2202           enddo ! j
2203         enddo ! iint
2204       enddo ! i
2205       return
2206       end
2207 C--------------------------------------------------------------------------
2208       subroutine eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,
2209      &              eello_turn4)
2210 C
2211 C Soft-sphere potential of p-p interaction
2212 C
2213       implicit real*8 (a-h,o-z)
2214       include 'DIMENSIONS'
2215       include 'COMMON.CONTROL'
2216       include 'COMMON.IOUNITS'
2217       include 'COMMON.GEO'
2218       include 'COMMON.VAR'
2219       include 'COMMON.LOCAL'
2220       include 'COMMON.CHAIN'
2221       include 'COMMON.DERIV'
2222       include 'COMMON.INTERACT'
2223       include 'COMMON.CONTACTS'
2224       include 'COMMON.TORSION'
2225       include 'COMMON.VECTORS'
2226       include 'COMMON.FFIELD'
2227       dimension ggg(3)
2228 C      write(iout,*) 'In EELEC_soft_sphere'
2229       ees=0.0D0
2230       evdw1=0.0D0
2231       eel_loc=0.0d0
2232       eello_turn3=0.0d0
2233       eello_turn4=0.0d0
2234       ind=0
2235       do i=iatel_s,iatel_e
2236         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
2237         dxi=dc(1,i)
2238         dyi=dc(2,i)
2239         dzi=dc(3,i)
2240         xmedi=c(1,i)+0.5d0*dxi
2241         ymedi=c(2,i)+0.5d0*dyi
2242         zmedi=c(3,i)+0.5d0*dzi
2243           xmedi=mod(xmedi,boxxsize)
2244           if (xmedi.lt.0) xmedi=xmedi+boxxsize
2245           ymedi=mod(ymedi,boxysize)
2246           if (ymedi.lt.0) ymedi=ymedi+boxysize
2247           zmedi=mod(zmedi,boxzsize)
2248           if (zmedi.lt.0) zmedi=zmedi+boxzsize
2249         num_conti=0
2250 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
2251         do j=ielstart(i),ielend(i)
2252           if (itype(j).eq.ntyp1 .or. itype(j+1).eq.ntyp1) cycle
2253           ind=ind+1
2254           iteli=itel(i)
2255           itelj=itel(j)
2256           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
2257           r0ij=rpp(iteli,itelj)
2258           r0ijsq=r0ij*r0ij
2259           dxj=dc(1,j)
2260           dyj=dc(2,j)
2261           dzj=dc(3,j)
2262           xj=c(1,j)+0.5D0*dxj
2263           yj=c(2,j)+0.5D0*dyj
2264           zj=c(3,j)+0.5D0*dzj
2265           xj=mod(xj,boxxsize)
2266           if (xj.lt.0) xj=xj+boxxsize
2267           yj=mod(yj,boxysize)
2268           if (yj.lt.0) yj=yj+boxysize
2269           zj=mod(zj,boxzsize)
2270           if (zj.lt.0) zj=zj+boxzsize
2271       dist_init=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
2272       xj_safe=xj
2273       yj_safe=yj
2274       zj_safe=zj
2275       isubchap=0
2276       do xshift=-1,1
2277       do yshift=-1,1
2278       do zshift=-1,1
2279           xj=xj_safe+xshift*boxxsize
2280           yj=yj_safe+yshift*boxysize
2281           zj=zj_safe+zshift*boxzsize
2282           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
2283           if(dist_temp.lt.dist_init) then
2284             dist_init=dist_temp
2285             xj_temp=xj
2286             yj_temp=yj
2287             zj_temp=zj
2288             isubchap=1
2289           endif
2290        enddo
2291        enddo
2292        enddo
2293        if (isubchap.eq.1) then
2294           xj=xj_temp-xmedi
2295           yj=yj_temp-ymedi
2296           zj=zj_temp-zmedi
2297        else
2298           xj=xj_safe-xmedi
2299           yj=yj_safe-ymedi
2300           zj=zj_safe-zmedi
2301        endif
2302           rij=xj*xj+yj*yj+zj*zj
2303             sss=sscale(sqrt(rij))
2304             sssgrad=sscagrad(sqrt(rij))
2305           if (rij.lt.r0ijsq) then
2306             evdw1ij=0.25d0*(rij-r0ijsq)**2
2307             fac=rij-r0ijsq
2308           else
2309             evdw1ij=0.0d0
2310             fac=0.0d0
2311           endif
2312           evdw1=evdw1+evdw1ij*sss
2313 C
2314 C Calculate contributions to the Cartesian gradient.
2315 C
2316           ggg(1)=fac*xj*sssgrad
2317           ggg(2)=fac*yj*sssgrad
2318           ggg(3)=fac*zj*sssgrad
2319           do k=1,3
2320             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
2321             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
2322           enddo
2323 *
2324 * Loop over residues i+1 thru j-1.
2325 *
2326 cgrad          do k=i+1,j-1
2327 cgrad            do l=1,3
2328 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
2329 cgrad            enddo
2330 cgrad          enddo
2331         enddo ! j
2332       enddo   ! i
2333 cgrad      do i=nnt,nct-1
2334 cgrad        do k=1,3
2335 cgrad          gelc(k,i)=gelc(k,i)+0.5d0*gelc(k,i)
2336 cgrad        enddo
2337 cgrad        do j=i+1,nct-1
2338 cgrad          do k=1,3
2339 cgrad            gelc(k,i)=gelc(k,i)+gelc(k,j)
2340 cgrad          enddo
2341 cgrad        enddo
2342 cgrad      enddo
2343       return
2344       end
2345 c------------------------------------------------------------------------------
2346       subroutine vec_and_deriv
2347       implicit real*8 (a-h,o-z)
2348       include 'DIMENSIONS'
2349 #ifdef MPI
2350       include 'mpif.h'
2351 #endif
2352       include 'COMMON.IOUNITS'
2353       include 'COMMON.GEO'
2354       include 'COMMON.VAR'
2355       include 'COMMON.LOCAL'
2356       include 'COMMON.CHAIN'
2357       include 'COMMON.VECTORS'
2358       include 'COMMON.SETUP'
2359       include 'COMMON.TIME1'
2360       dimension uyder(3,3,2),uzder(3,3,2),vbld_inv_temp(2)
2361 C Compute the local reference systems. For reference system (i), the
2362 C X-axis points from CA(i) to CA(i+1), the Y axis is in the
2363 C CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
2364 #ifdef PARVEC
2365       do i=ivec_start,ivec_end
2366 #else
2367       do i=1,nres-1
2368 #endif
2369           if (i.eq.nres-1) then
2370 C Case of the last full residue
2371 C Compute the Z-axis
2372             call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
2373             costh=dcos(pi-theta(nres))
2374             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2375             do k=1,3
2376               uz(k,i)=fac*uz(k,i)
2377             enddo
2378 C Compute the derivatives of uz
2379             uzder(1,1,1)= 0.0d0
2380             uzder(2,1,1)=-dc_norm(3,i-1)
2381             uzder(3,1,1)= dc_norm(2,i-1)
2382             uzder(1,2,1)= dc_norm(3,i-1)
2383             uzder(2,2,1)= 0.0d0
2384             uzder(3,2,1)=-dc_norm(1,i-1)
2385             uzder(1,3,1)=-dc_norm(2,i-1)
2386             uzder(2,3,1)= dc_norm(1,i-1)
2387             uzder(3,3,1)= 0.0d0
2388             uzder(1,1,2)= 0.0d0
2389             uzder(2,1,2)= dc_norm(3,i)
2390             uzder(3,1,2)=-dc_norm(2,i)
2391             uzder(1,2,2)=-dc_norm(3,i)
2392             uzder(2,2,2)= 0.0d0
2393             uzder(3,2,2)= dc_norm(1,i)
2394             uzder(1,3,2)= dc_norm(2,i)
2395             uzder(2,3,2)=-dc_norm(1,i)
2396             uzder(3,3,2)= 0.0d0
2397 C Compute the Y-axis
2398             facy=fac
2399             do k=1,3
2400               uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
2401             enddo
2402 C Compute the derivatives of uy
2403             do j=1,3
2404               do k=1,3
2405                 uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i)
2406      &                        -dc_norm(k,i)*dc_norm(j,i-1)
2407                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2408               enddo
2409               uyder(j,j,1)=uyder(j,j,1)-costh
2410               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2411             enddo
2412             do j=1,2
2413               do k=1,3
2414                 do l=1,3
2415                   uygrad(l,k,j,i)=uyder(l,k,j)
2416                   uzgrad(l,k,j,i)=uzder(l,k,j)
2417                 enddo
2418               enddo
2419             enddo
2420             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2421             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2422             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2423             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2424           else
2425 C Other residues
2426 C Compute the Z-axis
2427             call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
2428             costh=dcos(pi-theta(i+2))
2429             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2430             do k=1,3
2431               uz(k,i)=fac*uz(k,i)
2432             enddo
2433 C Compute the derivatives of uz
2434             uzder(1,1,1)= 0.0d0
2435             uzder(2,1,1)=-dc_norm(3,i+1)
2436             uzder(3,1,1)= dc_norm(2,i+1)
2437             uzder(1,2,1)= dc_norm(3,i+1)
2438             uzder(2,2,1)= 0.0d0
2439             uzder(3,2,1)=-dc_norm(1,i+1)
2440             uzder(1,3,1)=-dc_norm(2,i+1)
2441             uzder(2,3,1)= dc_norm(1,i+1)
2442             uzder(3,3,1)= 0.0d0
2443             uzder(1,1,2)= 0.0d0
2444             uzder(2,1,2)= dc_norm(3,i)
2445             uzder(3,1,2)=-dc_norm(2,i)
2446             uzder(1,2,2)=-dc_norm(3,i)
2447             uzder(2,2,2)= 0.0d0
2448             uzder(3,2,2)= dc_norm(1,i)
2449             uzder(1,3,2)= dc_norm(2,i)
2450             uzder(2,3,2)=-dc_norm(1,i)
2451             uzder(3,3,2)= 0.0d0
2452 C Compute the Y-axis
2453             facy=fac
2454             do k=1,3
2455               uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
2456             enddo
2457 C Compute the derivatives of uy
2458             do j=1,3
2459               do k=1,3
2460                 uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i)
2461      &                        -dc_norm(k,i)*dc_norm(j,i+1)
2462                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2463               enddo
2464               uyder(j,j,1)=uyder(j,j,1)-costh
2465               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2466             enddo
2467             do j=1,2
2468               do k=1,3
2469                 do l=1,3
2470                   uygrad(l,k,j,i)=uyder(l,k,j)
2471                   uzgrad(l,k,j,i)=uzder(l,k,j)
2472                 enddo
2473               enddo
2474             enddo
2475             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2476             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2477             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2478             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2479           endif
2480       enddo
2481       do i=1,nres-1
2482         vbld_inv_temp(1)=vbld_inv(i+1)
2483         if (i.lt.nres-1) then
2484           vbld_inv_temp(2)=vbld_inv(i+2)
2485           else
2486           vbld_inv_temp(2)=vbld_inv(i)
2487           endif
2488         do j=1,2
2489           do k=1,3
2490             do l=1,3
2491               uygrad(l,k,j,i)=vbld_inv_temp(j)*uygrad(l,k,j,i)
2492               uzgrad(l,k,j,i)=vbld_inv_temp(j)*uzgrad(l,k,j,i)
2493             enddo
2494           enddo
2495         enddo
2496       enddo
2497 #if defined(PARVEC) && defined(MPI)
2498       if (nfgtasks1.gt.1) then
2499         time00=MPI_Wtime()
2500 c        print *,"Processor",fg_rank1,kolor1," ivec_start",ivec_start,
2501 c     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks1-1),
2502 c     &   " ivec_count",(ivec_count(i),i=0,nfgtasks1-1)
2503         call MPI_Allgatherv(uy(1,ivec_start),ivec_count(fg_rank1),
2504      &   MPI_UYZ,uy(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
2505      &   FG_COMM1,IERR)
2506         call MPI_Allgatherv(uz(1,ivec_start),ivec_count(fg_rank1),
2507      &   MPI_UYZ,uz(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
2508      &   FG_COMM1,IERR)
2509         call MPI_Allgatherv(uygrad(1,1,1,ivec_start),
2510      &   ivec_count(fg_rank1),MPI_UYZGRAD,uygrad(1,1,1,1),ivec_count(0),
2511      &   ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2512         call MPI_Allgatherv(uzgrad(1,1,1,ivec_start),
2513      &   ivec_count(fg_rank1),MPI_UYZGRAD,uzgrad(1,1,1,1),ivec_count(0),
2514      &   ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2515         time_gather=time_gather+MPI_Wtime()-time00
2516       endif
2517 c      if (fg_rank.eq.0) then
2518 c        write (iout,*) "Arrays UY and UZ"
2519 c        do i=1,nres-1
2520 c          write (iout,'(i5,3f10.5,5x,3f10.5)') i,(uy(k,i),k=1,3),
2521 c     &     (uz(k,i),k=1,3)
2522 c        enddo
2523 c      endif
2524 #endif
2525       return
2526       end
2527 C-----------------------------------------------------------------------------
2528       subroutine check_vecgrad
2529       implicit real*8 (a-h,o-z)
2530       include 'DIMENSIONS'
2531       include 'COMMON.IOUNITS'
2532       include 'COMMON.GEO'
2533       include 'COMMON.VAR'
2534       include 'COMMON.LOCAL'
2535       include 'COMMON.CHAIN'
2536       include 'COMMON.VECTORS'
2537       dimension uygradt(3,3,2,maxres),uzgradt(3,3,2,maxres)
2538       dimension uyt(3,maxres),uzt(3,maxres)
2539       dimension uygradn(3,3,2),uzgradn(3,3,2),erij(3)
2540       double precision delta /1.0d-7/
2541       call vec_and_deriv
2542 cd      do i=1,nres
2543 crc          write(iout,'(2i5,2(3f10.5,5x))') i,1,dc_norm(:,i)
2544 crc          write(iout,'(2i5,2(3f10.5,5x))') i,2,uy(:,i)
2545 crc          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,uz(:,i)
2546 cd          write(iout,'(2i5,2(3f10.5,5x))') i,1,
2547 cd     &     (dc_norm(if90,i),if90=1,3)
2548 cd          write(iout,'(2i5,2(3f10.5,5x))') i,2,(uy(if90,i),if90=1,3)
2549 cd          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,(uz(if90,i),if90=1,3)
2550 cd          write(iout,'(a)')
2551 cd      enddo
2552       do i=1,nres
2553         do j=1,2
2554           do k=1,3
2555             do l=1,3
2556               uygradt(l,k,j,i)=uygrad(l,k,j,i)
2557               uzgradt(l,k,j,i)=uzgrad(l,k,j,i)
2558             enddo
2559           enddo
2560         enddo
2561       enddo
2562       call vec_and_deriv
2563       do i=1,nres
2564         do j=1,3
2565           uyt(j,i)=uy(j,i)
2566           uzt(j,i)=uz(j,i)
2567         enddo
2568       enddo
2569       do i=1,nres
2570 cd        write (iout,*) 'i=',i
2571         do k=1,3
2572           erij(k)=dc_norm(k,i)
2573         enddo
2574         do j=1,3
2575           do k=1,3
2576             dc_norm(k,i)=erij(k)
2577           enddo
2578           dc_norm(j,i)=dc_norm(j,i)+delta
2579 c          fac=dsqrt(scalar(dc_norm(1,i),dc_norm(1,i)))
2580 c          do k=1,3
2581 c            dc_norm(k,i)=dc_norm(k,i)/fac
2582 c          enddo
2583 c          write (iout,*) (dc_norm(k,i),k=1,3)
2584 c          write (iout,*) (erij(k),k=1,3)
2585           call vec_and_deriv
2586           do k=1,3
2587             uygradn(k,j,1)=(uy(k,i)-uyt(k,i))/delta
2588             uygradn(k,j,2)=(uy(k,i-1)-uyt(k,i-1))/delta
2589             uzgradn(k,j,1)=(uz(k,i)-uzt(k,i))/delta
2590             uzgradn(k,j,2)=(uz(k,i-1)-uzt(k,i-1))/delta
2591           enddo
2592 c          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2593 c     &      j,(uzgradt(k,j,1,i),k=1,3),(uzgradn(k,j,1),k=1,3),
2594 c     &      (uzgradt(k,j,2,i-1),k=1,3),(uzgradn(k,j,2),k=1,3)
2595         enddo
2596         do k=1,3
2597           dc_norm(k,i)=erij(k)
2598         enddo
2599 cd        do k=1,3
2600 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2601 cd     &      k,(uygradt(k,l,1,i),l=1,3),(uygradn(k,l,1),l=1,3),
2602 cd     &      (uygradt(k,l,2,i-1),l=1,3),(uygradn(k,l,2),l=1,3)
2603 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2604 cd     &      k,(uzgradt(k,l,1,i),l=1,3),(uzgradn(k,l,1),l=1,3),
2605 cd     &      (uzgradt(k,l,2,i-1),l=1,3),(uzgradn(k,l,2),l=1,3)
2606 cd          write (iout,'(a)')
2607 cd        enddo
2608       enddo
2609       return
2610       end
2611 C--------------------------------------------------------------------------
2612       subroutine set_matrices
2613       implicit real*8 (a-h,o-z)
2614       include 'DIMENSIONS'
2615 #ifdef MPI
2616       include "mpif.h"
2617       include "COMMON.SETUP"
2618       integer IERR
2619       integer status(MPI_STATUS_SIZE)
2620 #endif
2621       include 'COMMON.IOUNITS'
2622       include 'COMMON.GEO'
2623       include 'COMMON.VAR'
2624       include 'COMMON.LOCAL'
2625       include 'COMMON.CHAIN'
2626       include 'COMMON.DERIV'
2627       include 'COMMON.INTERACT'
2628       include 'COMMON.CONTACTS'
2629       include 'COMMON.TORSION'
2630       include 'COMMON.VECTORS'
2631       include 'COMMON.FFIELD'
2632       double precision auxvec(2),auxmat(2,2)
2633 C
2634 C Compute the virtual-bond-torsional-angle dependent quantities needed
2635 C to calculate the el-loc multibody terms of various order.
2636 C
2637 #ifdef PARMAT
2638       do i=ivec_start+2,ivec_end+2
2639 #else
2640       do i=3,nres+1
2641 #endif
2642         if (i .lt. nres+1) then
2643           sin1=dsin(phi(i))
2644           cos1=dcos(phi(i))
2645           sintab(i-2)=sin1
2646           costab(i-2)=cos1
2647           obrot(1,i-2)=cos1
2648           obrot(2,i-2)=sin1
2649           sin2=dsin(2*phi(i))
2650           cos2=dcos(2*phi(i))
2651           sintab2(i-2)=sin2
2652           costab2(i-2)=cos2
2653           obrot2(1,i-2)=cos2
2654           obrot2(2,i-2)=sin2
2655           Ug(1,1,i-2)=-cos1
2656           Ug(1,2,i-2)=-sin1
2657           Ug(2,1,i-2)=-sin1
2658           Ug(2,2,i-2)= cos1
2659           Ug2(1,1,i-2)=-cos2
2660           Ug2(1,2,i-2)=-sin2
2661           Ug2(2,1,i-2)=-sin2
2662           Ug2(2,2,i-2)= cos2
2663         else
2664           costab(i-2)=1.0d0
2665           sintab(i-2)=0.0d0
2666           obrot(1,i-2)=1.0d0
2667           obrot(2,i-2)=0.0d0
2668           obrot2(1,i-2)=0.0d0
2669           obrot2(2,i-2)=0.0d0
2670           Ug(1,1,i-2)=1.0d0
2671           Ug(1,2,i-2)=0.0d0
2672           Ug(2,1,i-2)=0.0d0
2673           Ug(2,2,i-2)=1.0d0
2674           Ug2(1,1,i-2)=0.0d0
2675           Ug2(1,2,i-2)=0.0d0
2676           Ug2(2,1,i-2)=0.0d0
2677           Ug2(2,2,i-2)=0.0d0
2678         endif
2679         if (i .gt. 3 .and. i .lt. nres+1) then
2680           obrot_der(1,i-2)=-sin1
2681           obrot_der(2,i-2)= cos1
2682           Ugder(1,1,i-2)= sin1
2683           Ugder(1,2,i-2)=-cos1
2684           Ugder(2,1,i-2)=-cos1
2685           Ugder(2,2,i-2)=-sin1
2686           dwacos2=cos2+cos2
2687           dwasin2=sin2+sin2
2688           obrot2_der(1,i-2)=-dwasin2
2689           obrot2_der(2,i-2)= dwacos2
2690           Ug2der(1,1,i-2)= dwasin2
2691           Ug2der(1,2,i-2)=-dwacos2
2692           Ug2der(2,1,i-2)=-dwacos2
2693           Ug2der(2,2,i-2)=-dwasin2
2694         else
2695           obrot_der(1,i-2)=0.0d0
2696           obrot_der(2,i-2)=0.0d0
2697           Ugder(1,1,i-2)=0.0d0
2698           Ugder(1,2,i-2)=0.0d0
2699           Ugder(2,1,i-2)=0.0d0
2700           Ugder(2,2,i-2)=0.0d0
2701           obrot2_der(1,i-2)=0.0d0
2702           obrot2_der(2,i-2)=0.0d0
2703           Ug2der(1,1,i-2)=0.0d0
2704           Ug2der(1,2,i-2)=0.0d0
2705           Ug2der(2,1,i-2)=0.0d0
2706           Ug2der(2,2,i-2)=0.0d0
2707         endif
2708 c        if (i.gt. iatel_s+2 .and. i.lt.iatel_e+5) then
2709         if (i.gt. nnt+2 .and. i.lt.nct+2) then
2710           iti = itortyp(itype(i-2))
2711         else
2712           iti=ntortyp
2713         endif
2714 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2715         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2716           iti1 = itortyp(itype(i-1))
2717         else
2718           iti1=ntortyp
2719         endif
2720 cd        write (iout,*) '*******i',i,' iti1',iti
2721 cd        write (iout,*) 'b1',b1(:,iti)
2722 cd        write (iout,*) 'b2',b2(:,iti)
2723 cd        write (iout,*) 'Ug',Ug(:,:,i-2)
2724 c        if (i .gt. iatel_s+2) then
2725         if (i .gt. nnt+2) then
2726           call matvec2(Ug(1,1,i-2),b2(1,iti),Ub2(1,i-2))
2727           call matmat2(EE(1,1,iti),Ug(1,1,i-2),EUg(1,1,i-2))
2728           if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2729      &    then
2730           call matmat2(CC(1,1,iti),Ug(1,1,i-2),CUg(1,1,i-2))
2731           call matmat2(DD(1,1,iti),Ug(1,1,i-2),DUg(1,1,i-2))
2732           call matmat2(Dtilde(1,1,iti),Ug2(1,1,i-2),DtUg2(1,1,i-2))
2733           call matvec2(Ctilde(1,1,iti1),obrot(1,i-2),Ctobr(1,i-2))
2734           call matvec2(Dtilde(1,1,iti),obrot2(1,i-2),Dtobr2(1,i-2))
2735           endif
2736         else
2737           do k=1,2
2738             Ub2(k,i-2)=0.0d0
2739             Ctobr(k,i-2)=0.0d0
2740             Dtobr2(k,i-2)=0.0d0
2741             do l=1,2
2742               EUg(l,k,i-2)=0.0d0
2743               CUg(l,k,i-2)=0.0d0
2744               DUg(l,k,i-2)=0.0d0
2745               DtUg2(l,k,i-2)=0.0d0
2746             enddo
2747           enddo
2748         endif
2749         call matvec2(Ugder(1,1,i-2),b2(1,iti),Ub2der(1,i-2))
2750         call matmat2(EE(1,1,iti),Ugder(1,1,i-2),EUgder(1,1,i-2))
2751         do k=1,2
2752           muder(k,i-2)=Ub2der(k,i-2)
2753         enddo
2754 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2755         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2756           if (itype(i-1).le.ntyp) then
2757             iti1 = itortyp(itype(i-1))
2758           else
2759             iti1=ntortyp
2760           endif
2761         else
2762           iti1=ntortyp
2763         endif
2764         do k=1,2
2765           mu(k,i-2)=Ub2(k,i-2)+b1(k,iti1)
2766         enddo
2767 cd        write (iout,*) 'mu ',mu(:,i-2)
2768 cd        write (iout,*) 'mu1',mu1(:,i-2)
2769 cd        write (iout,*) 'mu2',mu2(:,i-2)
2770         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
2771      &  then
2772         call matmat2(CC(1,1,iti1),Ugder(1,1,i-2),CUgder(1,1,i-2))
2773         call matmat2(DD(1,1,iti),Ugder(1,1,i-2),DUgder(1,1,i-2))
2774         call matmat2(Dtilde(1,1,iti),Ug2der(1,1,i-2),DtUg2der(1,1,i-2))
2775         call matvec2(Ctilde(1,1,iti1),obrot_der(1,i-2),Ctobrder(1,i-2))
2776         call matvec2(Dtilde(1,1,iti),obrot2_der(1,i-2),Dtobr2der(1,i-2))
2777 C Vectors and matrices dependent on a single virtual-bond dihedral.
2778         call matvec2(DD(1,1,iti),b1tilde(1,iti1),auxvec(1))
2779         call matvec2(Ug2(1,1,i-2),auxvec(1),Ug2Db1t(1,i-2))
2780         call matvec2(Ug2der(1,1,i-2),auxvec(1),Ug2Db1tder(1,i-2))
2781         call matvec2(CC(1,1,iti1),Ub2(1,i-2),CUgb2(1,i-2))
2782         call matvec2(CC(1,1,iti1),Ub2der(1,i-2),CUgb2der(1,i-2))
2783         call matmat2(EUg(1,1,i-2),CC(1,1,iti1),EUgC(1,1,i-2))
2784         call matmat2(EUgder(1,1,i-2),CC(1,1,iti1),EUgCder(1,1,i-2))
2785         call matmat2(EUg(1,1,i-2),DD(1,1,iti1),EUgD(1,1,i-2))
2786         call matmat2(EUgder(1,1,i-2),DD(1,1,iti1),EUgDder(1,1,i-2))
2787         endif
2788       enddo
2789 C Matrices dependent on two consecutive virtual-bond dihedrals.
2790 C The order of matrices is from left to right.
2791       if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
2792      &then
2793 c      do i=max0(ivec_start,2),ivec_end
2794       do i=2,nres-1
2795         call matmat2(DtUg2(1,1,i-1),EUg(1,1,i),DtUg2EUg(1,1,i))
2796         call matmat2(DtUg2der(1,1,i-1),EUg(1,1,i),DtUg2EUgder(1,1,1,i))
2797         call matmat2(DtUg2(1,1,i-1),EUgder(1,1,i),DtUg2EUgder(1,1,2,i))
2798         call transpose2(DtUg2(1,1,i-1),auxmat(1,1))
2799         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUg(1,1,i))
2800         call matmat2(auxmat(1,1),EUgder(1,1,i),Ug2DtEUgder(1,1,2,i))
2801         call transpose2(DtUg2der(1,1,i-1),auxmat(1,1))
2802         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUgder(1,1,1,i))
2803       enddo
2804       endif
2805 #if defined(MPI) && defined(PARMAT)
2806 #ifdef DEBUG
2807 c      if (fg_rank.eq.0) then
2808         write (iout,*) "Arrays UG and UGDER before GATHER"
2809         do i=1,nres-1
2810           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2811      &     ((ug(l,k,i),l=1,2),k=1,2),
2812      &     ((ugder(l,k,i),l=1,2),k=1,2)
2813         enddo
2814         write (iout,*) "Arrays UG2 and UG2DER"
2815         do i=1,nres-1
2816           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2817      &     ((ug2(l,k,i),l=1,2),k=1,2),
2818      &     ((ug2der(l,k,i),l=1,2),k=1,2)
2819         enddo
2820         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
2821         do i=1,nres-1
2822           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2823      &     (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
2824      &     (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
2825         enddo
2826         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
2827         do i=1,nres-1
2828           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2829      &     costab(i),sintab(i),costab2(i),sintab2(i)
2830         enddo
2831         write (iout,*) "Array MUDER"
2832         do i=1,nres-1
2833           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
2834         enddo
2835 c      endif
2836 #endif
2837       if (nfgtasks.gt.1) then
2838         time00=MPI_Wtime()
2839 c        write(iout,*)"Processor",fg_rank,kolor," ivec_start",ivec_start,
2840 c     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks-1),
2841 c     &   " ivec_count",(ivec_count(i),i=0,nfgtasks-1)
2842 #ifdef MATGATHER
2843         call MPI_Allgatherv(Ub2(1,ivec_start),ivec_count(fg_rank1),
2844      &   MPI_MU,Ub2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2845      &   FG_COMM1,IERR)
2846         call MPI_Allgatherv(Ub2der(1,ivec_start),ivec_count(fg_rank1),
2847      &   MPI_MU,Ub2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2848      &   FG_COMM1,IERR)
2849         call MPI_Allgatherv(mu(1,ivec_start),ivec_count(fg_rank1),
2850      &   MPI_MU,mu(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2851      &   FG_COMM1,IERR)
2852         call MPI_Allgatherv(muder(1,ivec_start),ivec_count(fg_rank1),
2853      &   MPI_MU,muder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2854      &   FG_COMM1,IERR)
2855         call MPI_Allgatherv(Eug(1,1,ivec_start),ivec_count(fg_rank1),
2856      &   MPI_MAT1,Eug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2857      &   FG_COMM1,IERR)
2858         call MPI_Allgatherv(Eugder(1,1,ivec_start),ivec_count(fg_rank1),
2859      &   MPI_MAT1,Eugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2860      &   FG_COMM1,IERR)
2861         call MPI_Allgatherv(costab(ivec_start),ivec_count(fg_rank1),
2862      &   MPI_DOUBLE_PRECISION,costab(1),ivec_count(0),ivec_displ(0),
2863      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2864         call MPI_Allgatherv(sintab(ivec_start),ivec_count(fg_rank1),
2865      &   MPI_DOUBLE_PRECISION,sintab(1),ivec_count(0),ivec_displ(0),
2866      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2867         call MPI_Allgatherv(costab2(ivec_start),ivec_count(fg_rank1),
2868      &   MPI_DOUBLE_PRECISION,costab2(1),ivec_count(0),ivec_displ(0),
2869      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2870         call MPI_Allgatherv(sintab2(ivec_start),ivec_count(fg_rank1),
2871      &   MPI_DOUBLE_PRECISION,sintab2(1),ivec_count(0),ivec_displ(0),
2872      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2873         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2874      &  then
2875         call MPI_Allgatherv(Ctobr(1,ivec_start),ivec_count(fg_rank1),
2876      &   MPI_MU,Ctobr(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2877      &   FG_COMM1,IERR)
2878         call MPI_Allgatherv(Ctobrder(1,ivec_start),ivec_count(fg_rank1),
2879      &   MPI_MU,Ctobrder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2880      &   FG_COMM1,IERR)
2881         call MPI_Allgatherv(Dtobr2(1,ivec_start),ivec_count(fg_rank1),
2882      &   MPI_MU,Dtobr2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2883      &   FG_COMM1,IERR)
2884        call MPI_Allgatherv(Dtobr2der(1,ivec_start),ivec_count(fg_rank1),
2885      &   MPI_MU,Dtobr2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2886      &   FG_COMM1,IERR)
2887         call MPI_Allgatherv(Ug2Db1t(1,ivec_start),ivec_count(fg_rank1),
2888      &   MPI_MU,Ug2Db1t(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2889      &   FG_COMM1,IERR)
2890         call MPI_Allgatherv(Ug2Db1tder(1,ivec_start),
2891      &   ivec_count(fg_rank1),
2892      &   MPI_MU,Ug2Db1tder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2893      &   FG_COMM1,IERR)
2894         call MPI_Allgatherv(CUgb2(1,ivec_start),ivec_count(fg_rank1),
2895      &   MPI_MU,CUgb2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2896      &   FG_COMM1,IERR)
2897         call MPI_Allgatherv(CUgb2der(1,ivec_start),ivec_count(fg_rank1),
2898      &   MPI_MU,CUgb2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2899      &   FG_COMM1,IERR)
2900         call MPI_Allgatherv(Cug(1,1,ivec_start),ivec_count(fg_rank1),
2901      &   MPI_MAT1,Cug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2902      &   FG_COMM1,IERR)
2903         call MPI_Allgatherv(Cugder(1,1,ivec_start),ivec_count(fg_rank1),
2904      &   MPI_MAT1,Cugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2905      &   FG_COMM1,IERR)
2906         call MPI_Allgatherv(Dug(1,1,ivec_start),ivec_count(fg_rank1),
2907      &   MPI_MAT1,Dug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2908      &   FG_COMM1,IERR)
2909         call MPI_Allgatherv(Dugder(1,1,ivec_start),ivec_count(fg_rank1),
2910      &   MPI_MAT1,Dugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2911      &   FG_COMM1,IERR)
2912         call MPI_Allgatherv(Dtug2(1,1,ivec_start),ivec_count(fg_rank1),
2913      &   MPI_MAT1,Dtug2(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2914      &   FG_COMM1,IERR)
2915         call MPI_Allgatherv(Dtug2der(1,1,ivec_start),
2916      &   ivec_count(fg_rank1),
2917      &   MPI_MAT1,Dtug2der(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2918      &   FG_COMM1,IERR)
2919         call MPI_Allgatherv(EugC(1,1,ivec_start),ivec_count(fg_rank1),
2920      &   MPI_MAT1,EugC(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2921      &   FG_COMM1,IERR)
2922        call MPI_Allgatherv(EugCder(1,1,ivec_start),ivec_count(fg_rank1),
2923      &   MPI_MAT1,EugCder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2924      &   FG_COMM1,IERR)
2925         call MPI_Allgatherv(EugD(1,1,ivec_start),ivec_count(fg_rank1),
2926      &   MPI_MAT1,EugD(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2927      &   FG_COMM1,IERR)
2928        call MPI_Allgatherv(EugDder(1,1,ivec_start),ivec_count(fg_rank1),
2929      &   MPI_MAT1,EugDder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2930      &   FG_COMM1,IERR)
2931         call MPI_Allgatherv(DtUg2EUg(1,1,ivec_start),
2932      &   ivec_count(fg_rank1),
2933      &   MPI_MAT1,DtUg2EUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2934      &   FG_COMM1,IERR)
2935         call MPI_Allgatherv(Ug2DtEUg(1,1,ivec_start),
2936      &   ivec_count(fg_rank1),
2937      &   MPI_MAT1,Ug2DtEUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2938      &   FG_COMM1,IERR)
2939         call MPI_Allgatherv(DtUg2EUgder(1,1,1,ivec_start),
2940      &   ivec_count(fg_rank1),
2941      &   MPI_MAT2,DtUg2EUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
2942      &   MPI_MAT2,FG_COMM1,IERR)
2943         call MPI_Allgatherv(Ug2DtEUgder(1,1,1,ivec_start),
2944      &   ivec_count(fg_rank1),
2945      &   MPI_MAT2,Ug2DtEUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
2946      &   MPI_MAT2,FG_COMM1,IERR)
2947         endif
2948 #else
2949 c Passes matrix info through the ring
2950       isend=fg_rank1
2951       irecv=fg_rank1-1
2952       if (irecv.lt.0) irecv=nfgtasks1-1
2953       iprev=irecv
2954       inext=fg_rank1+1
2955       if (inext.ge.nfgtasks1) inext=0
2956       do i=1,nfgtasks1-1
2957 c        write (iout,*) "isend",isend," irecv",irecv
2958 c        call flush(iout)
2959         lensend=lentyp(isend)
2960         lenrecv=lentyp(irecv)
2961 c        write (iout,*) "lensend",lensend," lenrecv",lenrecv
2962 c        call MPI_SENDRECV(ug(1,1,ivec_displ(isend)+1),1,
2963 c     &   MPI_ROTAT1(lensend),inext,2200+isend,
2964 c     &   ug(1,1,ivec_displ(irecv)+1),1,MPI_ROTAT1(lenrecv),
2965 c     &   iprev,2200+irecv,FG_COMM,status,IERR)
2966 c        write (iout,*) "Gather ROTAT1"
2967 c        call flush(iout)
2968 c        call MPI_SENDRECV(obrot(1,ivec_displ(isend)+1),1,
2969 c     &   MPI_ROTAT2(lensend),inext,3300+isend,
2970 c     &   obrot(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
2971 c     &   iprev,3300+irecv,FG_COMM,status,IERR)
2972 c        write (iout,*) "Gather ROTAT2"
2973 c        call flush(iout)
2974         call MPI_SENDRECV(costab(ivec_displ(isend)+1),1,
2975      &   MPI_ROTAT_OLD(lensend),inext,4400+isend,
2976      &   costab(ivec_displ(irecv)+1),1,MPI_ROTAT_OLD(lenrecv),
2977      &   iprev,4400+irecv,FG_COMM,status,IERR)
2978 c        write (iout,*) "Gather ROTAT_OLD"
2979 c        call flush(iout)
2980         call MPI_SENDRECV(mu(1,ivec_displ(isend)+1),1,
2981      &   MPI_PRECOMP11(lensend),inext,5500+isend,
2982      &   mu(1,ivec_displ(irecv)+1),1,MPI_PRECOMP11(lenrecv),
2983      &   iprev,5500+irecv,FG_COMM,status,IERR)
2984 c        write (iout,*) "Gather PRECOMP11"
2985 c        call flush(iout)
2986         call MPI_SENDRECV(Eug(1,1,ivec_displ(isend)+1),1,
2987      &   MPI_PRECOMP12(lensend),inext,6600+isend,
2988      &   Eug(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP12(lenrecv),
2989      &   iprev,6600+irecv,FG_COMM,status,IERR)
2990 c        write (iout,*) "Gather PRECOMP12"
2991 c        call flush(iout)
2992         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2993      &  then
2994         call MPI_SENDRECV(ug2db1t(1,ivec_displ(isend)+1),1,
2995      &   MPI_ROTAT2(lensend),inext,7700+isend,
2996      &   ug2db1t(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
2997      &   iprev,7700+irecv,FG_COMM,status,IERR)
2998 c        write (iout,*) "Gather PRECOMP21"
2999 c        call flush(iout)
3000         call MPI_SENDRECV(EUgC(1,1,ivec_displ(isend)+1),1,
3001      &   MPI_PRECOMP22(lensend),inext,8800+isend,
3002      &   EUgC(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP22(lenrecv),
3003      &   iprev,8800+irecv,FG_COMM,status,IERR)
3004 c        write (iout,*) "Gather PRECOMP22"
3005 c        call flush(iout)
3006         call MPI_SENDRECV(Ug2DtEUgder(1,1,1,ivec_displ(isend)+1),1,
3007      &   MPI_PRECOMP23(lensend),inext,9900+isend,
3008      &   Ug2DtEUgder(1,1,1,ivec_displ(irecv)+1),1,
3009      &   MPI_PRECOMP23(lenrecv),
3010      &   iprev,9900+irecv,FG_COMM,status,IERR)
3011 c        write (iout,*) "Gather PRECOMP23"
3012 c        call flush(iout)
3013         endif
3014         isend=irecv
3015         irecv=irecv-1
3016         if (irecv.lt.0) irecv=nfgtasks1-1
3017       enddo
3018 #endif
3019         time_gather=time_gather+MPI_Wtime()-time00
3020       endif
3021 #ifdef DEBUG
3022 c      if (fg_rank.eq.0) then
3023         write (iout,*) "Arrays UG and UGDER"
3024         do i=1,nres-1
3025           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3026      &     ((ug(l,k,i),l=1,2),k=1,2),
3027      &     ((ugder(l,k,i),l=1,2),k=1,2)
3028         enddo
3029         write (iout,*) "Arrays UG2 and UG2DER"
3030         do i=1,nres-1
3031           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3032      &     ((ug2(l,k,i),l=1,2),k=1,2),
3033      &     ((ug2der(l,k,i),l=1,2),k=1,2)
3034         enddo
3035         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
3036         do i=1,nres-1
3037           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3038      &     (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
3039      &     (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
3040         enddo
3041         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
3042         do i=1,nres-1
3043           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3044      &     costab(i),sintab(i),costab2(i),sintab2(i)
3045         enddo
3046         write (iout,*) "Array MUDER"
3047         do i=1,nres-1
3048           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
3049         enddo
3050 c      endif
3051 #endif
3052 #endif
3053 cd      do i=1,nres
3054 cd        iti = itortyp(itype(i))
3055 cd        write (iout,*) i
3056 cd        do j=1,2
3057 cd        write (iout,'(2f10.5,5x,2f10.5,5x,2f10.5)')
3058 cd     &  (EE(j,k,iti),k=1,2),(Ug(j,k,i),k=1,2),(EUg(j,k,i),k=1,2)
3059 cd        enddo
3060 cd      enddo
3061       return
3062       end
3063 C--------------------------------------------------------------------------
3064       subroutine eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
3065 C
3066 C This subroutine calculates the average interaction energy and its gradient
3067 C in the virtual-bond vectors between non-adjacent peptide groups, based on
3068 C the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
3069 C The potential depends both on the distance of peptide-group centers and on
3070 C the orientation of the CA-CA virtual bonds.
3071 C
3072       implicit real*8 (a-h,o-z)
3073 #ifdef MPI
3074       include 'mpif.h'
3075 #endif
3076       include 'DIMENSIONS'
3077       include 'COMMON.CONTROL'
3078       include 'COMMON.SETUP'
3079       include 'COMMON.IOUNITS'
3080       include 'COMMON.GEO'
3081       include 'COMMON.VAR'
3082       include 'COMMON.LOCAL'
3083       include 'COMMON.CHAIN'
3084       include 'COMMON.DERIV'
3085       include 'COMMON.INTERACT'
3086       include 'COMMON.CONTACTS'
3087       include 'COMMON.TORSION'
3088       include 'COMMON.VECTORS'
3089       include 'COMMON.FFIELD'
3090       include 'COMMON.TIME1'
3091       include 'COMMON.SPLITELE'
3092       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
3093      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
3094       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
3095      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4)
3096       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3097      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3098      &    num_conti,j1,j2
3099 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
3100 #ifdef MOMENT
3101       double precision scal_el /1.0d0/
3102 #else
3103       double precision scal_el /0.5d0/
3104 #endif
3105 C 12/13/98
3106 C 13-go grudnia roku pamietnego...
3107       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
3108      &                   0.0d0,1.0d0,0.0d0,
3109      &                   0.0d0,0.0d0,1.0d0/
3110 cd      write(iout,*) 'In EELEC'
3111 cd      do i=1,nloctyp
3112 cd        write(iout,*) 'Type',i
3113 cd        write(iout,*) 'B1',B1(:,i)
3114 cd        write(iout,*) 'B2',B2(:,i)
3115 cd        write(iout,*) 'CC',CC(:,:,i)
3116 cd        write(iout,*) 'DD',DD(:,:,i)
3117 cd        write(iout,*) 'EE',EE(:,:,i)
3118 cd      enddo
3119 cd      call check_vecgrad
3120 cd      stop
3121       if (icheckgrad.eq.1) then
3122         do i=1,nres-1
3123           fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
3124           do k=1,3
3125             dc_norm(k,i)=dc(k,i)*fac
3126           enddo
3127 c          write (iout,*) 'i',i,' fac',fac
3128         enddo
3129       endif
3130       if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
3131      &    .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or.
3132      &    wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
3133 c        call vec_and_deriv
3134 #ifdef TIMING
3135         time01=MPI_Wtime()
3136 #endif
3137         call set_matrices
3138 #ifdef TIMING
3139         time_mat=time_mat+MPI_Wtime()-time01
3140 #endif
3141       endif
3142 cd      do i=1,nres-1
3143 cd        write (iout,*) 'i=',i
3144 cd        do k=1,3
3145 cd        write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
3146 cd        enddo
3147 cd        do k=1,3
3148 cd          write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
3149 cd     &     uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
3150 cd        enddo
3151 cd      enddo
3152       t_eelecij=0.0d0
3153       ees=0.0D0
3154       evdw1=0.0D0
3155       eel_loc=0.0d0
3156       eello_turn3=0.0d0
3157       eello_turn4=0.0d0
3158       ind=0
3159       do i=1,nres
3160         num_cont_hb(i)=0
3161       enddo
3162 cd      print '(a)','Enter EELEC'
3163 cd      write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
3164       do i=1,nres
3165         gel_loc_loc(i)=0.0d0
3166         gcorr_loc(i)=0.0d0
3167       enddo
3168 c
3169 c
3170 c 9/27/08 AL Split the interaction loop to ensure load balancing of turn terms
3171 C
3172 C Loop over i,i+2 and i,i+3 pairs of the peptide groups
3173 C
3174 C 14/01/2014 TURN3,TUNR4 does no go under periodic boundry condition
3175       do i=iturn3_start,iturn3_end
3176         if (i.le.1) cycle
3177 C        write(iout,*) "tu jest i",i
3178         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
3179      &  .or. itype(i+2).eq.ntyp1
3180      &  .or. itype(i+3).eq.ntyp1
3181      &  .or. itype(i-1).eq.ntyp1
3182      &  .or. itype(i+4).eq.ntyp1
3183      &  ) cycle
3184         dxi=dc(1,i)
3185         dyi=dc(2,i)
3186         dzi=dc(3,i)
3187         dx_normi=dc_norm(1,i)
3188         dy_normi=dc_norm(2,i)
3189         dz_normi=dc_norm(3,i)
3190         xmedi=c(1,i)+0.5d0*dxi
3191         ymedi=c(2,i)+0.5d0*dyi
3192         zmedi=c(3,i)+0.5d0*dzi
3193           xmedi=mod(xmedi,boxxsize)
3194           if (xmedi.lt.0) xmedi=xmedi+boxxsize
3195           ymedi=mod(ymedi,boxysize)
3196           if (ymedi.lt.0) ymedi=ymedi+boxysize
3197           zmedi=mod(zmedi,boxzsize)
3198           if (zmedi.lt.0) zmedi=zmedi+boxzsize
3199         num_conti=0
3200         call eelecij(i,i+2,ees,evdw1,eel_loc)
3201         if (wturn3.gt.0.0d0) call eturn3(i,eello_turn3)
3202         num_cont_hb(i)=num_conti
3203       enddo
3204       do i=iturn4_start,iturn4_end
3205         if (i.le.1) cycle
3206         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
3207      &    .or. itype(i+3).eq.ntyp1
3208      &    .or. itype(i+4).eq.ntyp1
3209      &    .or. itype(i+5).eq.ntyp1
3210      &    .or. itype(i).eq.ntyp1
3211      &    .or. itype(i-1).eq.ntyp1
3212      &                             ) cycle
3213         dxi=dc(1,i)
3214         dyi=dc(2,i)
3215         dzi=dc(3,i)
3216         dx_normi=dc_norm(1,i)
3217         dy_normi=dc_norm(2,i)
3218         dz_normi=dc_norm(3,i)
3219         xmedi=c(1,i)+0.5d0*dxi
3220         ymedi=c(2,i)+0.5d0*dyi
3221         zmedi=c(3,i)+0.5d0*dzi
3222 C Return atom into box, boxxsize is size of box in x dimension
3223 c  194   continue
3224 c        if (xmedi.gt.((0.5d0)*boxxsize)) xmedi=xmedi-boxxsize
3225 c        if (xmedi.lt.((-0.5d0)*boxxsize)) xmedi=xmedi+boxxsize
3226 C Condition for being inside the proper box
3227 c        if ((xmedi.gt.((0.5d0)*boxxsize)).or.
3228 c     &       (xmedi.lt.((-0.5d0)*boxxsize))) then
3229 c        go to 194
3230 c        endif
3231 c  195   continue
3232 c        if (ymedi.gt.((0.5d0)*boxysize)) ymedi=ymedi-boxysize
3233 c        if (ymedi.lt.((-0.5d0)*boxysize)) ymedi=ymedi+boxysize
3234 C Condition for being inside the proper box
3235 c        if ((ymedi.gt.((0.5d0)*boxysize)).or.
3236 c     &       (ymedi.lt.((-0.5d0)*boxysize))) then
3237 c        go to 195
3238 c        endif
3239 c  196   continue
3240 c        if (zmedi.gt.((0.5d0)*boxzsize)) zmedi=zmedi-boxzsize
3241 c        if (zmedi.lt.((-0.5d0)*boxzsize)) zmedi=zmedi+boxzsize
3242 C Condition for being inside the proper box
3243 c        if ((zmedi.gt.((0.5d0)*boxzsize)).or.
3244 c     &       (zmedi.lt.((-0.5d0)*boxzsize))) then
3245 c        go to 196
3246 c        endif
3247           xmedi=mod(xmedi,boxxsize)
3248           if (xmedi.lt.0) xmedi=xmedi+boxxsize
3249           ymedi=mod(ymedi,boxysize)
3250           if (ymedi.lt.0) ymedi=ymedi+boxysize
3251           zmedi=mod(zmedi,boxzsize)
3252           if (zmedi.lt.0) zmedi=zmedi+boxzsize
3253
3254         num_conti=num_cont_hb(i)
3255         call eelecij(i,i+3,ees,evdw1,eel_loc)
3256         if (wturn4.gt.0.0d0 .and. itype(i+2).ne.ntyp1)
3257      &   call eturn4(i,eello_turn4)
3258         num_cont_hb(i)=num_conti
3259       enddo   ! i
3260 C Loop over all neighbouring boxes
3261 C      do xshift=-1,1
3262 C      do yshift=-1,1
3263 C      do zshift=-1,1
3264 c
3265 c Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
3266 c
3267       do i=iatel_s,iatel_e
3268         if (i.le.1) cycle
3269         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
3270      &  .or. itype(i+2).eq.ntyp1
3271      &  .or. itype(i-1).eq.ntyp1
3272      &                ) cycle
3273         dxi=dc(1,i)
3274         dyi=dc(2,i)
3275         dzi=dc(3,i)
3276         dx_normi=dc_norm(1,i)
3277         dy_normi=dc_norm(2,i)
3278         dz_normi=dc_norm(3,i)
3279         xmedi=c(1,i)+0.5d0*dxi
3280         ymedi=c(2,i)+0.5d0*dyi
3281         zmedi=c(3,i)+0.5d0*dzi
3282           xmedi=mod(xmedi,boxxsize)
3283           if (xmedi.lt.0) xmedi=xmedi+boxxsize
3284           ymedi=mod(ymedi,boxysize)
3285           if (ymedi.lt.0) ymedi=ymedi+boxysize
3286           zmedi=mod(zmedi,boxzsize)
3287           if (zmedi.lt.0) zmedi=zmedi+boxzsize
3288 C          xmedi=xmedi+xshift*boxxsize
3289 C          ymedi=ymedi+yshift*boxysize
3290 C          zmedi=zmedi+zshift*boxzsize
3291
3292 C Return tom into box, boxxsize is size of box in x dimension
3293 c  164   continue
3294 c        if (xmedi.gt.((xshift+0.5d0)*boxxsize)) xmedi=xmedi-boxxsize
3295 c        if (xmedi.lt.((xshift-0.5d0)*boxxsize)) xmedi=xmedi+boxxsize
3296 C Condition for being inside the proper box
3297 c        if ((xmedi.gt.((xshift+0.5d0)*boxxsize)).or.
3298 c     &       (xmedi.lt.((xshift-0.5d0)*boxxsize))) then
3299 c        go to 164
3300 c        endif
3301 c  165   continue
3302 c        if (ymedi.gt.((yshift+0.5d0)*boxysize)) ymedi=ymedi-boxysize
3303 c        if (ymedi.lt.((yshift-0.5d0)*boxysize)) ymedi=ymedi+boxysize
3304 C Condition for being inside the proper box
3305 c        if ((ymedi.gt.((yshift+0.5d0)*boxysize)).or.
3306 c     &       (ymedi.lt.((yshift-0.5d0)*boxysize))) then
3307 c        go to 165
3308 c        endif
3309 c  166   continue
3310 c        if (zmedi.gt.((zshift+0.5d0)*boxzsize)) zmedi=zmedi-boxzsize
3311 c        if (zmedi.lt.((zshift-0.5d0)*boxzsize)) zmedi=zmedi+boxzsize
3312 cC Condition for being inside the proper box
3313 c        if ((zmedi.gt.((zshift+0.5d0)*boxzsize)).or.
3314 c     &       (zmedi.lt.((zshift-0.5d0)*boxzsize))) then
3315 c        go to 166
3316 c        endif
3317
3318 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
3319         num_conti=num_cont_hb(i)
3320         do j=ielstart(i),ielend(i)
3321 C          write (iout,*) i,j
3322          if (j.le.1) cycle
3323           if (itype(j).eq.ntyp1.or. itype(j+1).eq.ntyp1
3324      & .or.itype(j+2).eq.ntyp1
3325      & .or.itype(j-1).eq.ntyp1
3326      &) cycle
3327           call eelecij(i,j,ees,evdw1,eel_loc)
3328         enddo ! j
3329         num_cont_hb(i)=num_conti
3330       enddo   ! i
3331 C     enddo   ! zshift
3332 C      enddo   ! yshift
3333 C      enddo   ! xshift
3334
3335 c      write (iout,*) "Number of loop steps in EELEC:",ind
3336 cd      do i=1,nres
3337 cd        write (iout,'(i3,3f10.5,5x,3f10.5)')
3338 cd     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
3339 cd      enddo
3340 c 12/7/99 Adam eello_turn3 will be considered as a separate energy term
3341 ccc      eel_loc=eel_loc+eello_turn3
3342 cd      print *,"Processor",fg_rank," t_eelecij",t_eelecij
3343       return
3344       end
3345 C-------------------------------------------------------------------------------
3346       subroutine eelecij(i,j,ees,evdw1,eel_loc)
3347       implicit real*8 (a-h,o-z)
3348       include 'DIMENSIONS'
3349 #ifdef MPI
3350       include "mpif.h"
3351 #endif
3352       include 'COMMON.CONTROL'
3353       include 'COMMON.IOUNITS'
3354       include 'COMMON.GEO'
3355       include 'COMMON.VAR'
3356       include 'COMMON.LOCAL'
3357       include 'COMMON.CHAIN'
3358       include 'COMMON.DERIV'
3359       include 'COMMON.INTERACT'
3360       include 'COMMON.CONTACTS'
3361       include 'COMMON.TORSION'
3362       include 'COMMON.VECTORS'
3363       include 'COMMON.FFIELD'
3364       include 'COMMON.TIME1'
3365       include 'COMMON.SPLITELE'
3366       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
3367      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
3368       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
3369      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4)
3370       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3371      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3372      &    num_conti,j1,j2
3373 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
3374 #ifdef MOMENT
3375       double precision scal_el /1.0d0/
3376 #else
3377       double precision scal_el /0.5d0/
3378 #endif
3379 C 12/13/98
3380 C 13-go grudnia roku pamietnego...
3381       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
3382      &                   0.0d0,1.0d0,0.0d0,
3383      &                   0.0d0,0.0d0,1.0d0/
3384 c          time00=MPI_Wtime()
3385 cd      write (iout,*) "eelecij",i,j
3386 c          ind=ind+1
3387           iteli=itel(i)
3388           itelj=itel(j)
3389           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
3390           aaa=app(iteli,itelj)
3391           bbb=bpp(iteli,itelj)
3392           ael6i=ael6(iteli,itelj)
3393           ael3i=ael3(iteli,itelj)
3394           dxj=dc(1,j)
3395           dyj=dc(2,j)
3396           dzj=dc(3,j)
3397           dx_normj=dc_norm(1,j)
3398           dy_normj=dc_norm(2,j)
3399           dz_normj=dc_norm(3,j)
3400 C          xj=c(1,j)+0.5D0*dxj-xmedi
3401 C          yj=c(2,j)+0.5D0*dyj-ymedi
3402 C          zj=c(3,j)+0.5D0*dzj-zmedi
3403           xj=c(1,j)+0.5D0*dxj
3404           yj=c(2,j)+0.5D0*dyj
3405           zj=c(3,j)+0.5D0*dzj
3406           xj=mod(xj,boxxsize)
3407           if (xj.lt.0) xj=xj+boxxsize
3408           yj=mod(yj,boxysize)
3409           if (yj.lt.0) yj=yj+boxysize
3410           zj=mod(zj,boxzsize)
3411           if (zj.lt.0) zj=zj+boxzsize
3412           if ((zj.lt.0).or.(xj.lt.0).or.(yj.lt.0)) write (*,*) "CHUJ"
3413       dist_init=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
3414       xj_safe=xj
3415       yj_safe=yj
3416       zj_safe=zj
3417       isubchap=0
3418       do xshift=-1,1
3419       do yshift=-1,1
3420       do zshift=-1,1
3421           xj=xj_safe+xshift*boxxsize
3422           yj=yj_safe+yshift*boxysize
3423           zj=zj_safe+zshift*boxzsize
3424           dist_temp=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
3425           if(dist_temp.lt.dist_init) then
3426             dist_init=dist_temp
3427             xj_temp=xj
3428             yj_temp=yj
3429             zj_temp=zj
3430             isubchap=1
3431           endif
3432        enddo
3433        enddo
3434        enddo
3435        if (isubchap.eq.1) then
3436           xj=xj_temp-xmedi
3437           yj=yj_temp-ymedi
3438           zj=zj_temp-zmedi
3439        else
3440           xj=xj_safe-xmedi
3441           yj=yj_safe-ymedi
3442           zj=zj_safe-zmedi
3443        endif
3444 C        if ((i+3).lt.j) then !this condition keeps for turn3 and turn4 not subject to PBC
3445 c  174   continue
3446 c        if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
3447 c        if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
3448 C Condition for being inside the proper box
3449 c        if ((xj.gt.((0.5d0)*boxxsize)).or.
3450 c     &       (xj.lt.((-0.5d0)*boxxsize))) then
3451 c        go to 174
3452 c        endif
3453 c  175   continue
3454 c        if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
3455 c        if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
3456 C Condition for being inside the proper box
3457 c        if ((yj.gt.((0.5d0)*boxysize)).or.
3458 c     &       (yj.lt.((-0.5d0)*boxysize))) then
3459 c        go to 175
3460 c        endif
3461 c  176   continue
3462 c        if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
3463 c        if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
3464 C Condition for being inside the proper box
3465 c        if ((zj.gt.((0.5d0)*boxzsize)).or.
3466 c     &       (zj.lt.((-0.5d0)*boxzsize))) then
3467 c        go to 176
3468 c        endif
3469 C        endif !endPBC condintion
3470 C        xj=xj-xmedi
3471 C        yj=yj-ymedi
3472 C        zj=zj-zmedi
3473           rij=xj*xj+yj*yj+zj*zj
3474
3475             sss=sscale(sqrt(rij))
3476             sssgrad=sscagrad(sqrt(rij))
3477 c            if (sss.gt.0.0d0) then
3478           rrmij=1.0D0/rij
3479           rij=dsqrt(rij)
3480           rmij=1.0D0/rij
3481           r3ij=rrmij*rmij
3482           r6ij=r3ij*r3ij
3483           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
3484           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
3485           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
3486           fac=cosa-3.0D0*cosb*cosg
3487           ev1=aaa*r6ij*r6ij
3488 c 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
3489           if (j.eq.i+2) ev1=scal_el*ev1
3490           ev2=bbb*r6ij
3491           fac3=ael6i*r6ij
3492           fac4=ael3i*r3ij
3493           evdwij=(ev1+ev2)
3494           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
3495           el2=fac4*fac
3496 C MARYSIA
3497           eesij=(el1+el2)
3498 C 12/26/95 - for the evaluation of multi-body H-bonding interactions
3499           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
3500           ees=ees+eesij
3501           evdw1=evdw1+evdwij*sss
3502 cd          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
3503 cd     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
3504 cd     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
3505 cd     &      xmedi,ymedi,zmedi,xj,yj,zj
3506
3507           if (energy_dec) then
3508               write (iout,'(a6,2i5,0pf7.3,2i5,2e11.3)')
3509      &'evdw1',i,j,evdwij
3510      &,iteli,itelj,aaa,evdw1
3511               write (iout,'(a6,2i5,0pf7.3)') 'ees',i,j,eesij
3512           endif
3513
3514 C
3515 C Calculate contributions to the Cartesian gradient.
3516 C
3517 #ifdef SPLITELE
3518           facvdw=-6*rrmij*(ev1+evdwij)*sss
3519           facel=-3*rrmij*(el1+eesij)
3520           fac1=fac
3521           erij(1)=xj*rmij
3522           erij(2)=yj*rmij
3523           erij(3)=zj*rmij
3524 *
3525 * Radial derivatives. First process both termini of the fragment (i,j)
3526 *
3527           ggg(1)=facel*xj
3528           ggg(2)=facel*yj
3529           ggg(3)=facel*zj
3530 c          do k=1,3
3531 c            ghalf=0.5D0*ggg(k)
3532 c            gelc(k,i)=gelc(k,i)+ghalf
3533 c            gelc(k,j)=gelc(k,j)+ghalf
3534 c          enddo
3535 c 9/28/08 AL Gradient compotents will be summed only at the end
3536           do k=1,3
3537             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
3538             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
3539           enddo
3540 *
3541 * Loop over residues i+1 thru j-1.
3542 *
3543 cgrad          do k=i+1,j-1
3544 cgrad            do l=1,3
3545 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3546 cgrad            enddo
3547 cgrad          enddo
3548           if (sss.gt.0.0) then
3549           ggg(1)=facvdw*xj+sssgrad*rmij*evdwij*xj
3550           ggg(2)=facvdw*yj+sssgrad*rmij*evdwij*yj
3551           ggg(3)=facvdw*zj+sssgrad*rmij*evdwij*zj
3552           else
3553           ggg(1)=0.0
3554           ggg(2)=0.0
3555           ggg(3)=0.0
3556           endif
3557 c          do k=1,3
3558 c            ghalf=0.5D0*ggg(k)
3559 c            gvdwpp(k,i)=gvdwpp(k,i)+ghalf
3560 c            gvdwpp(k,j)=gvdwpp(k,j)+ghalf
3561 c          enddo
3562 c 9/28/08 AL Gradient compotents will be summed only at the end
3563           do k=1,3
3564             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
3565             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
3566           enddo
3567 *
3568 * Loop over residues i+1 thru j-1.
3569 *
3570 cgrad          do k=i+1,j-1
3571 cgrad            do l=1,3
3572 cgrad              gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
3573 cgrad            enddo
3574 cgrad          enddo
3575 #else
3576 C MARYSIA
3577           facvdw=(ev1+evdwij)*sss
3578           facel=(el1+eesij)
3579           fac1=fac
3580           fac=-3*rrmij*(facvdw+facvdw+facel)
3581           erij(1)=xj*rmij
3582           erij(2)=yj*rmij
3583           erij(3)=zj*rmij
3584 *
3585 * Radial derivatives. First process both termini of the fragment (i,j)
3586 *
3587           ggg(1)=fac*xj
3588           ggg(2)=fac*yj
3589           ggg(3)=fac*zj
3590 c          do k=1,3
3591 c            ghalf=0.5D0*ggg(k)
3592 c            gelc(k,i)=gelc(k,i)+ghalf
3593 c            gelc(k,j)=gelc(k,j)+ghalf
3594 c          enddo
3595 c 9/28/08 AL Gradient compotents will be summed only at the end
3596           do k=1,3
3597             gelc_long(k,j)=gelc(k,j)+ggg(k)
3598             gelc_long(k,i)=gelc(k,i)-ggg(k)
3599           enddo
3600 *
3601 * Loop over residues i+1 thru j-1.
3602 *
3603 cgrad          do k=i+1,j-1
3604 cgrad            do l=1,3
3605 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3606 cgrad            enddo
3607 cgrad          enddo
3608 c 9/28/08 AL Gradient compotents will be summed only at the end
3609           ggg(1)=facvdw*xj+sssgrad*rmij*evdwij*xj
3610           ggg(2)=facvdw*yj+sssgrad*rmij*evdwij*yj
3611           ggg(3)=facvdw*zj+sssgrad*rmij*evdwij*zj
3612           do k=1,3
3613             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
3614             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
3615           enddo
3616 #endif
3617 *
3618 * Angular part
3619 *
3620           ecosa=2.0D0*fac3*fac1+fac4
3621           fac4=-3.0D0*fac4
3622           fac3=-6.0D0*fac3
3623           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
3624           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
3625           do k=1,3
3626             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
3627             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
3628           enddo
3629 cd        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
3630 cd   &          (dcosg(k),k=1,3)
3631           do k=1,3
3632             ggg(k)=ecosb*dcosb(k)+ecosg*dcosg(k)
3633           enddo
3634 c          do k=1,3
3635 c            ghalf=0.5D0*ggg(k)
3636 c            gelc(k,i)=gelc(k,i)+ghalf
3637 c     &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
3638 c     &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3639 c            gelc(k,j)=gelc(k,j)+ghalf
3640 c     &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
3641 c     &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3642 c          enddo
3643 cgrad          do k=i+1,j-1
3644 cgrad            do l=1,3
3645 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3646 cgrad            enddo
3647 cgrad          enddo
3648           do k=1,3
3649             gelc(k,i)=gelc(k,i)
3650      &           +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
3651      &           + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3652             gelc(k,j)=gelc(k,j)
3653      &           +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
3654      &           + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3655             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
3656             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
3657           enddo
3658 C MARYSIA
3659 c          endif !sscale
3660           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
3661      &        .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0
3662      &        .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
3663 C
3664 C 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
3665 C   energy of a peptide unit is assumed in the form of a second-order
3666 C   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
3667 C   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
3668 C   are computed for EVERY pair of non-contiguous peptide groups.
3669 C
3670           if (j.lt.nres-1) then
3671             j1=j+1
3672             j2=j-1
3673           else
3674             j1=j-1
3675             j2=j-2
3676           endif
3677           kkk=0
3678           do k=1,2
3679             do l=1,2
3680               kkk=kkk+1
3681               muij(kkk)=mu(k,i)*mu(l,j)
3682             enddo
3683           enddo
3684 cd         write (iout,*) 'EELEC: i',i,' j',j
3685 cd          write (iout,*) 'j',j,' j1',j1,' j2',j2
3686 cd          write(iout,*) 'muij',muij
3687           ury=scalar(uy(1,i),erij)
3688           urz=scalar(uz(1,i),erij)
3689           vry=scalar(uy(1,j),erij)
3690           vrz=scalar(uz(1,j),erij)
3691           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
3692           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
3693           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
3694           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
3695           fac=dsqrt(-ael6i)*r3ij
3696           a22=a22*fac
3697           a23=a23*fac
3698           a32=a32*fac
3699           a33=a33*fac
3700 cd          write (iout,'(4i5,4f10.5)')
3701 cd     &     i,itortyp(itype(i)),j,itortyp(itype(j)),a22,a23,a32,a33
3702 cd          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
3703 cd          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') uy(:,i),uz(:,i),
3704 cd     &      uy(:,j),uz(:,j)
3705 cd          write (iout,'(4f10.5)')
3706 cd     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
3707 cd     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
3708 cd          write (iout,'(4f10.5)') ury,urz,vry,vrz
3709 cd           write (iout,'(9f10.5/)')
3710 cd     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
3711 C Derivatives of the elements of A in virtual-bond vectors
3712           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
3713           do k=1,3
3714             uryg(k,1)=scalar(erder(1,k),uy(1,i))
3715             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
3716             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
3717             urzg(k,1)=scalar(erder(1,k),uz(1,i))
3718             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
3719             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
3720             vryg(k,1)=scalar(erder(1,k),uy(1,j))
3721             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
3722             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
3723             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
3724             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
3725             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
3726           enddo
3727 C Compute radial contributions to the gradient
3728           facr=-3.0d0*rrmij
3729           a22der=a22*facr
3730           a23der=a23*facr
3731           a32der=a32*facr
3732           a33der=a33*facr
3733           agg(1,1)=a22der*xj
3734           agg(2,1)=a22der*yj
3735           agg(3,1)=a22der*zj
3736           agg(1,2)=a23der*xj
3737           agg(2,2)=a23der*yj
3738           agg(3,2)=a23der*zj
3739           agg(1,3)=a32der*xj
3740           agg(2,3)=a32der*yj
3741           agg(3,3)=a32der*zj
3742           agg(1,4)=a33der*xj
3743           agg(2,4)=a33der*yj
3744           agg(3,4)=a33der*zj
3745 C Add the contributions coming from er
3746           fac3=-3.0d0*fac
3747           do k=1,3
3748             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
3749             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
3750             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
3751             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
3752           enddo
3753           do k=1,3
3754 C Derivatives in DC(i)
3755 cgrad            ghalf1=0.5d0*agg(k,1)
3756 cgrad            ghalf2=0.5d0*agg(k,2)
3757 cgrad            ghalf3=0.5d0*agg(k,3)
3758 cgrad            ghalf4=0.5d0*agg(k,4)
3759             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j))
3760      &      -3.0d0*uryg(k,2)*vry)!+ghalf1
3761             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j))
3762      &      -3.0d0*uryg(k,2)*vrz)!+ghalf2
3763             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j))
3764      &      -3.0d0*urzg(k,2)*vry)!+ghalf3
3765             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j))
3766      &      -3.0d0*urzg(k,2)*vrz)!+ghalf4
3767 C Derivatives in DC(i+1)
3768             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j))
3769      &      -3.0d0*uryg(k,3)*vry)!+agg(k,1)
3770             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j))
3771      &      -3.0d0*uryg(k,3)*vrz)!+agg(k,2)
3772             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j))
3773      &      -3.0d0*urzg(k,3)*vry)!+agg(k,3)
3774             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j))
3775      &      -3.0d0*urzg(k,3)*vrz)!+agg(k,4)
3776 C Derivatives in DC(j)
3777             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i))
3778      &      -3.0d0*vryg(k,2)*ury)!+ghalf1
3779             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i))
3780      &      -3.0d0*vrzg(k,2)*ury)!+ghalf2
3781             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i))
3782      &      -3.0d0*vryg(k,2)*urz)!+ghalf3
3783             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i))
3784      &      -3.0d0*vrzg(k,2)*urz)!+ghalf4
3785 C Derivatives in DC(j+1) or DC(nres-1)
3786             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i))
3787      &      -3.0d0*vryg(k,3)*ury)
3788             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i))
3789      &      -3.0d0*vrzg(k,3)*ury)
3790             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i))
3791      &      -3.0d0*vryg(k,3)*urz)
3792             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i))
3793      &      -3.0d0*vrzg(k,3)*urz)
3794 cgrad            if (j.eq.nres-1 .and. i.lt.j-2) then
3795 cgrad              do l=1,4
3796 cgrad                aggj1(k,l)=aggj1(k,l)+agg(k,l)
3797 cgrad              enddo
3798 cgrad            endif
3799           enddo
3800           acipa(1,1)=a22
3801           acipa(1,2)=a23
3802           acipa(2,1)=a32
3803           acipa(2,2)=a33
3804           a22=-a22
3805           a23=-a23
3806           do l=1,2
3807             do k=1,3
3808               agg(k,l)=-agg(k,l)
3809               aggi(k,l)=-aggi(k,l)
3810               aggi1(k,l)=-aggi1(k,l)
3811               aggj(k,l)=-aggj(k,l)
3812               aggj1(k,l)=-aggj1(k,l)
3813             enddo
3814           enddo
3815           if (j.lt.nres-1) then
3816             a22=-a22
3817             a32=-a32
3818             do l=1,3,2
3819               do k=1,3
3820                 agg(k,l)=-agg(k,l)
3821                 aggi(k,l)=-aggi(k,l)
3822                 aggi1(k,l)=-aggi1(k,l)
3823                 aggj(k,l)=-aggj(k,l)
3824                 aggj1(k,l)=-aggj1(k,l)
3825               enddo
3826             enddo
3827           else
3828             a22=-a22
3829             a23=-a23
3830             a32=-a32
3831             a33=-a33
3832             do l=1,4
3833               do k=1,3
3834                 agg(k,l)=-agg(k,l)
3835                 aggi(k,l)=-aggi(k,l)
3836                 aggi1(k,l)=-aggi1(k,l)
3837                 aggj(k,l)=-aggj(k,l)
3838                 aggj1(k,l)=-aggj1(k,l)
3839               enddo
3840             enddo
3841           endif
3842           ENDIF ! WCORR
3843           IF (wel_loc.gt.0.0d0) THEN
3844 C Contribution to the local-electrostatic energy coming from the i-j pair
3845           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3)
3846      &     +a33*muij(4)
3847 c          write (iout,*) 'i',i,' j',j,itype(i),itype(j),
3848 c     &                     ' eel_loc_ij',eel_loc_ij
3849
3850           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3851      &            'eelloc',i,j,eel_loc_ij
3852 c           if (eel_loc_ij.ne.0)
3853 c     &      write (iout,'(a4,2i4,8f9.5)')'chuj',
3854 c     &     i,j,a22,muij(1),a23,muij(2),a32,muij(3),a33,muij(4)
3855
3856           eel_loc=eel_loc+eel_loc_ij
3857 C Partial derivatives in virtual-bond dihedral angles gamma
3858           if (i.gt.1)
3859      &    gel_loc_loc(i-1)=gel_loc_loc(i-1)+
3860      &            a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j)
3861      &           +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j)
3862           gel_loc_loc(j-1)=gel_loc_loc(j-1)+
3863      &            a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j)
3864      &           +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j)
3865 C Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
3866           do l=1,3
3867             ggg(l)=agg(l,1)*muij(1)+
3868      &          agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4)
3869             gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l)
3870             gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l)
3871 cgrad            ghalf=0.5d0*ggg(l)
3872 cgrad            gel_loc(l,i)=gel_loc(l,i)+ghalf
3873 cgrad            gel_loc(l,j)=gel_loc(l,j)+ghalf
3874           enddo
3875 cgrad          do k=i+1,j2
3876 cgrad            do l=1,3
3877 cgrad              gel_loc(l,k)=gel_loc(l,k)+ggg(l)
3878 cgrad            enddo
3879 cgrad          enddo
3880 C Remaining derivatives of eello
3881           do l=1,3
3882             gel_loc(l,i)=gel_loc(l,i)+(aggi(l,1)*muij(1)+
3883      &        aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4))
3884             gel_loc(l,i+1)=gel_loc(l,i+1)+(aggi1(l,1)*muij(1)+
3885      &     aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4))
3886             gel_loc(l,j)=gel_loc(l,j)+(aggj(l,1)*muij(1)+
3887      &       aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4))
3888             gel_loc(l,j1)=gel_loc(l,j1)+(aggj1(l,1)*muij(1)+
3889      &     aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4))
3890           enddo
3891           ENDIF
3892 C Change 12/26/95 to calculate four-body contributions to H-bonding energy
3893 c          if (j.gt.i+1 .and. num_conti.le.maxconts) then
3894           if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0
3895      &       .and. num_conti.le.maxconts) then
3896 c            write (iout,*) i,j," entered corr"
3897 C
3898 C Calculate the contact function. The ith column of the array JCONT will
3899 C contain the numbers of atoms that make contacts with the atom I (of numbers
3900 C greater than I). The arrays FACONT and GACONT will contain the values of
3901 C the contact function and its derivative.
3902 c           r0ij=1.02D0*rpp(iteli,itelj)
3903 c           r0ij=1.11D0*rpp(iteli,itelj)
3904             r0ij=2.20D0*rpp(iteli,itelj)
3905 c           r0ij=1.55D0*rpp(iteli,itelj)
3906             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
3907             if (fcont.gt.0.0D0) then
3908               num_conti=num_conti+1
3909               if (num_conti.gt.maxconts) then
3910                 write (iout,*) 'WARNING - max. # of contacts exceeded;',
3911      &                         ' will skip next contacts for this conf.'
3912               else
3913                 jcont_hb(num_conti,i)=j
3914 cd                write (iout,*) "i",i," j",j," num_conti",num_conti,
3915 cd     &           " jcont_hb",jcont_hb(num_conti,i)
3916                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.
3917      &          wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
3918 C 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
3919 C  terms.
3920                 d_cont(num_conti,i)=rij
3921 cd                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
3922 C     --- Electrostatic-interaction matrix ---
3923                 a_chuj(1,1,num_conti,i)=a22
3924                 a_chuj(1,2,num_conti,i)=a23
3925                 a_chuj(2,1,num_conti,i)=a32
3926                 a_chuj(2,2,num_conti,i)=a33
3927 C     --- Gradient of rij
3928                 do kkk=1,3
3929                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
3930                 enddo
3931                 kkll=0
3932                 do k=1,2
3933                   do l=1,2
3934                     kkll=kkll+1
3935                     do m=1,3
3936                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
3937                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
3938                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
3939                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
3940                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
3941                     enddo
3942                   enddo
3943                 enddo
3944                 ENDIF
3945                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
3946 C Calculate contact energies
3947                 cosa4=4.0D0*cosa
3948                 wij=cosa-3.0D0*cosb*cosg
3949                 cosbg1=cosb+cosg
3950                 cosbg2=cosb-cosg
3951 c               fac3=dsqrt(-ael6i)/r0ij**3
3952                 fac3=dsqrt(-ael6i)*r3ij
3953 c                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
3954                 ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
3955                 if (ees0tmp.gt.0) then
3956                   ees0pij=dsqrt(ees0tmp)
3957                 else
3958                   ees0pij=0
3959                 endif
3960 c                ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
3961                 ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
3962                 if (ees0tmp.gt.0) then
3963                   ees0mij=dsqrt(ees0tmp)
3964                 else
3965                   ees0mij=0
3966                 endif
3967 c               ees0mij=0.0D0
3968                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij)
3969                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij)
3970 C Diagnostics. Comment out or remove after debugging!
3971 c               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
3972 c               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
3973 c               ees0m(num_conti,i)=0.0D0
3974 C End diagnostics.
3975 c               write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
3976 c    & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
3977 C Angular derivatives of the contact function
3978                 ees0pij1=fac3/ees0pij
3979                 ees0mij1=fac3/ees0mij
3980                 fac3p=-3.0D0*fac3*rrmij
3981                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
3982                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
3983 c               ees0mij1=0.0D0
3984                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
3985                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
3986                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
3987                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
3988                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
3989                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
3990                 ecosap=ecosa1+ecosa2
3991                 ecosbp=ecosb1+ecosb2
3992                 ecosgp=ecosg1+ecosg2
3993                 ecosam=ecosa1-ecosa2
3994                 ecosbm=ecosb1-ecosb2
3995                 ecosgm=ecosg1-ecosg2
3996 C Diagnostics
3997 c               ecosap=ecosa1
3998 c               ecosbp=ecosb1
3999 c               ecosgp=ecosg1
4000 c               ecosam=0.0D0
4001 c               ecosbm=0.0D0
4002 c               ecosgm=0.0D0
4003 C End diagnostics
4004                 facont_hb(num_conti,i)=fcont
4005                 fprimcont=fprimcont/rij
4006 cd              facont_hb(num_conti,i)=1.0D0
4007 C Following line is for diagnostics.
4008 cd              fprimcont=0.0D0
4009                 do k=1,3
4010                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
4011                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
4012                 enddo
4013                 do k=1,3
4014                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
4015                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
4016                 enddo
4017                 gggp(1)=gggp(1)+ees0pijp*xj
4018                 gggp(2)=gggp(2)+ees0pijp*yj
4019                 gggp(3)=gggp(3)+ees0pijp*zj
4020                 gggm(1)=gggm(1)+ees0mijp*xj
4021                 gggm(2)=gggm(2)+ees0mijp*yj
4022                 gggm(3)=gggm(3)+ees0mijp*zj
4023 C Derivatives due to the contact function
4024                 gacont_hbr(1,num_conti,i)=fprimcont*xj
4025                 gacont_hbr(2,num_conti,i)=fprimcont*yj
4026                 gacont_hbr(3,num_conti,i)=fprimcont*zj
4027                 do k=1,3
4028 c
4029 c 10/24/08 cgrad and ! comments indicate the parts of the code removed
4030 c          following the change of gradient-summation algorithm.
4031 c
4032 cgrad                  ghalfp=0.5D0*gggp(k)
4033 cgrad                  ghalfm=0.5D0*gggm(k)
4034                   gacontp_hb1(k,num_conti,i)=!ghalfp
4035      &              +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i))
4036      &              + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
4037                   gacontp_hb2(k,num_conti,i)=!ghalfp
4038      &              +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j))
4039      &              + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
4040                   gacontp_hb3(k,num_conti,i)=gggp(k)
4041                   gacontm_hb1(k,num_conti,i)=!ghalfm
4042      &              +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i))
4043      &              + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
4044                   gacontm_hb2(k,num_conti,i)=!ghalfm
4045      &              +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j))
4046      &              + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
4047                   gacontm_hb3(k,num_conti,i)=gggm(k)
4048                 enddo
4049 C Diagnostics. Comment out or remove after debugging!
4050 cdiag           do k=1,3
4051 cdiag             gacontp_hb1(k,num_conti,i)=0.0D0
4052 cdiag             gacontp_hb2(k,num_conti,i)=0.0D0
4053 cdiag             gacontp_hb3(k,num_conti,i)=0.0D0
4054 cdiag             gacontm_hb1(k,num_conti,i)=0.0D0
4055 cdiag             gacontm_hb2(k,num_conti,i)=0.0D0
4056 cdiag             gacontm_hb3(k,num_conti,i)=0.0D0
4057 cdiag           enddo
4058               ENDIF ! wcorr
4059               endif  ! num_conti.le.maxconts
4060             endif  ! fcont.gt.0
4061           endif    ! j.gt.i+1
4062           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
4063             do k=1,4
4064               do l=1,3
4065                 ghalf=0.5d0*agg(l,k)
4066                 aggi(l,k)=aggi(l,k)+ghalf
4067                 aggi1(l,k)=aggi1(l,k)+agg(l,k)
4068                 aggj(l,k)=aggj(l,k)+ghalf
4069               enddo
4070             enddo
4071             if (j.eq.nres-1 .and. i.lt.j-2) then
4072               do k=1,4
4073                 do l=1,3
4074                   aggj1(l,k)=aggj1(l,k)+agg(l,k)
4075                 enddo
4076               enddo
4077             endif
4078           endif
4079 c          t_eelecij=t_eelecij+MPI_Wtime()-time00
4080       return
4081       end
4082 C-----------------------------------------------------------------------------
4083       subroutine eturn3(i,eello_turn3)
4084 C Third- and fourth-order contributions from turns
4085       implicit real*8 (a-h,o-z)
4086       include 'DIMENSIONS'
4087       include 'COMMON.IOUNITS'
4088       include 'COMMON.GEO'
4089       include 'COMMON.VAR'
4090       include 'COMMON.LOCAL'
4091       include 'COMMON.CHAIN'
4092       include 'COMMON.DERIV'
4093       include 'COMMON.INTERACT'
4094       include 'COMMON.CONTACTS'
4095       include 'COMMON.TORSION'
4096       include 'COMMON.VECTORS'
4097       include 'COMMON.FFIELD'
4098       include 'COMMON.CONTROL'
4099       dimension ggg(3)
4100       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
4101      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
4102      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2)
4103       double precision agg(3,4),aggi(3,4),aggi1(3,4),
4104      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
4105       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
4106      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
4107      &    num_conti,j1,j2
4108       j=i+2
4109 c      write (iout,*) "eturn3",i,j,j1,j2
4110       a_temp(1,1)=a22
4111       a_temp(1,2)=a23
4112       a_temp(2,1)=a32
4113       a_temp(2,2)=a33
4114 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4115 C
4116 C               Third-order contributions
4117 C
4118 C                 (i+2)o----(i+3)
4119 C                      | |
4120 C                      | |
4121 C                 (i+1)o----i
4122 C
4123 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4124 cd        call checkint_turn3(i,a_temp,eello_turn3_num)
4125         call matmat2(EUg(1,1,i+1),EUg(1,1,i+2),auxmat(1,1))
4126         call transpose2(auxmat(1,1),auxmat1(1,1))
4127         call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4128         eello_turn3=eello_turn3+0.5d0*(pizda(1,1)+pizda(2,2))
4129         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
4130      &          'eturn3',i,j,0.5d0*(pizda(1,1)+pizda(2,2))
4131 cd        write (2,*) 'i,',i,' j',j,'eello_turn3',
4132 cd     &    0.5d0*(pizda(1,1)+pizda(2,2)),
4133 cd     &    ' eello_turn3_num',4*eello_turn3_num
4134 C Derivatives in gamma(i)
4135         call matmat2(EUgder(1,1,i+1),EUg(1,1,i+2),auxmat2(1,1))
4136         call transpose2(auxmat2(1,1),auxmat3(1,1))
4137         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
4138         gel_loc_turn3(i)=gel_loc_turn3(i)+0.5d0*(pizda(1,1)+pizda(2,2))
4139 C Derivatives in gamma(i+1)
4140         call matmat2(EUg(1,1,i+1),EUgder(1,1,i+2),auxmat2(1,1))
4141         call transpose2(auxmat2(1,1),auxmat3(1,1))
4142         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
4143         gel_loc_turn3(i+1)=gel_loc_turn3(i+1)
4144      &    +0.5d0*(pizda(1,1)+pizda(2,2))
4145 C Cartesian derivatives
4146         do l=1,3
4147 c            ghalf1=0.5d0*agg(l,1)
4148 c            ghalf2=0.5d0*agg(l,2)
4149 c            ghalf3=0.5d0*agg(l,3)
4150 c            ghalf4=0.5d0*agg(l,4)
4151           a_temp(1,1)=aggi(l,1)!+ghalf1
4152           a_temp(1,2)=aggi(l,2)!+ghalf2
4153           a_temp(2,1)=aggi(l,3)!+ghalf3
4154           a_temp(2,2)=aggi(l,4)!+ghalf4
4155           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4156           gcorr3_turn(l,i)=gcorr3_turn(l,i)
4157      &      +0.5d0*(pizda(1,1)+pizda(2,2))
4158           a_temp(1,1)=aggi1(l,1)!+agg(l,1)
4159           a_temp(1,2)=aggi1(l,2)!+agg(l,2)
4160           a_temp(2,1)=aggi1(l,3)!+agg(l,3)
4161           a_temp(2,2)=aggi1(l,4)!+agg(l,4)
4162           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4163           gcorr3_turn(l,i+1)=gcorr3_turn(l,i+1)
4164      &      +0.5d0*(pizda(1,1)+pizda(2,2))
4165           a_temp(1,1)=aggj(l,1)!+ghalf1
4166           a_temp(1,2)=aggj(l,2)!+ghalf2
4167           a_temp(2,1)=aggj(l,3)!+ghalf3
4168           a_temp(2,2)=aggj(l,4)!+ghalf4
4169           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4170           gcorr3_turn(l,j)=gcorr3_turn(l,j)
4171      &      +0.5d0*(pizda(1,1)+pizda(2,2))
4172           a_temp(1,1)=aggj1(l,1)
4173           a_temp(1,2)=aggj1(l,2)
4174           a_temp(2,1)=aggj1(l,3)
4175           a_temp(2,2)=aggj1(l,4)
4176           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4177           gcorr3_turn(l,j1)=gcorr3_turn(l,j1)
4178      &      +0.5d0*(pizda(1,1)+pizda(2,2))
4179         enddo
4180       return
4181       end
4182 C-------------------------------------------------------------------------------
4183       subroutine eturn4(i,eello_turn4)
4184 C Third- and fourth-order contributions from turns
4185       implicit real*8 (a-h,o-z)
4186       include 'DIMENSIONS'
4187       include 'COMMON.IOUNITS'
4188       include 'COMMON.GEO'
4189       include 'COMMON.VAR'
4190       include 'COMMON.LOCAL'
4191       include 'COMMON.CHAIN'
4192       include 'COMMON.DERIV'
4193       include 'COMMON.INTERACT'
4194       include 'COMMON.CONTACTS'
4195       include 'COMMON.TORSION'
4196       include 'COMMON.VECTORS'
4197       include 'COMMON.FFIELD'
4198       include 'COMMON.CONTROL'
4199       dimension ggg(3)
4200       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
4201      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
4202      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2)
4203       double precision agg(3,4),aggi(3,4),aggi1(3,4),
4204      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
4205       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
4206      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
4207      &    num_conti,j1,j2
4208       j=i+3
4209 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4210 C
4211 C               Fourth-order contributions
4212 C
4213 C                 (i+3)o----(i+4)
4214 C                     /  |
4215 C               (i+2)o   |
4216 C                     \  |
4217 C                 (i+1)o----i
4218 C
4219 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4220 cd        call checkint_turn4(i,a_temp,eello_turn4_num)
4221 c        write (iout,*) "eturn4 i",i," j",j," j1",j1," j2",j2
4222         a_temp(1,1)=a22
4223         a_temp(1,2)=a23
4224         a_temp(2,1)=a32
4225         a_temp(2,2)=a33
4226         iti1=itortyp(itype(i+1))
4227         iti2=itortyp(itype(i+2))
4228         iti3=itortyp(itype(i+3))
4229 c        write(iout,*) "iti1",iti1," iti2",iti2," iti3",iti3
4230         call transpose2(EUg(1,1,i+1),e1t(1,1))
4231         call transpose2(Eug(1,1,i+2),e2t(1,1))
4232         call transpose2(Eug(1,1,i+3),e3t(1,1))
4233         call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4234         call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4235         s1=scalar2(b1(1,iti2),auxvec(1))
4236         call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4237         call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4238         s2=scalar2(b1(1,iti1),auxvec(1))
4239         call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4240         call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4241         s3=0.5d0*(pizda(1,1)+pizda(2,2))
4242         eello_turn4=eello_turn4-(s1+s2+s3)
4243 c             write(iout,*)'chujOWO', auxvec(1),b1(1,iti2)
4244         if (energy_dec) write (iout,'(a6,2i5,0pf7.3,3f7.3)')
4245      &      'eturn4',i,j,-(s1+s2+s3),s1,s2,s3
4246 cd        write (2,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
4247 cd     &    ' eello_turn4_num',8*eello_turn4_num
4248 C Derivatives in gamma(i)
4249         call transpose2(EUgder(1,1,i+1),e1tder(1,1))
4250         call matmat2(e1tder(1,1),a_temp(1,1),auxmat(1,1))
4251         call matvec2(auxmat(1,1),Ub2(1,i+3),auxvec(1))
4252         s1=scalar2(b1(1,iti2),auxvec(1))
4253         call matmat2(ae3e2(1,1),e1tder(1,1),pizda(1,1))
4254         s3=0.5d0*(pizda(1,1)+pizda(2,2))
4255         gel_loc_turn4(i)=gel_loc_turn4(i)-(s1+s3)
4256 C Derivatives in gamma(i+1)
4257         call transpose2(EUgder(1,1,i+2),e2tder(1,1))
4258         call matvec2(ae3(1,1),Ub2der(1,i+2),auxvec(1))
4259         s2=scalar2(b1(1,iti1),auxvec(1))
4260         call matmat2(ae3(1,1),e2tder(1,1),auxmat(1,1))
4261         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
4262         s3=0.5d0*(pizda(1,1)+pizda(2,2))
4263         gel_loc_turn4(i+1)=gel_loc_turn4(i+1)-(s2+s3)
4264 C Derivatives in gamma(i+2)
4265         call transpose2(EUgder(1,1,i+3),e3tder(1,1))
4266         call matvec2(e1a(1,1),Ub2der(1,i+3),auxvec(1))
4267         s1=scalar2(b1(1,iti2),auxvec(1))
4268         call matmat2(a_temp(1,1),e3tder(1,1),auxmat(1,1))
4269         call matvec2(auxmat(1,1),Ub2(1,i+2),auxvec(1))
4270         s2=scalar2(b1(1,iti1),auxvec(1))
4271         call matmat2(auxmat(1,1),e2t(1,1),auxmat3(1,1))
4272         call matmat2(auxmat3(1,1),e1t(1,1),pizda(1,1))
4273         s3=0.5d0*(pizda(1,1)+pizda(2,2))
4274         gel_loc_turn4(i+2)=gel_loc_turn4(i+2)-(s1+s2+s3)
4275 C Cartesian derivatives
4276 C Derivatives of this turn contributions in DC(i+2)
4277         if (j.lt.nres-1) then
4278           do l=1,3
4279             a_temp(1,1)=agg(l,1)
4280             a_temp(1,2)=agg(l,2)
4281             a_temp(2,1)=agg(l,3)
4282             a_temp(2,2)=agg(l,4)
4283             call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4284             call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4285             s1=scalar2(b1(1,iti2),auxvec(1))
4286             call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4287             call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4288             s2=scalar2(b1(1,iti1),auxvec(1))
4289             call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4290             call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4291             s3=0.5d0*(pizda(1,1)+pizda(2,2))
4292             ggg(l)=-(s1+s2+s3)
4293             gcorr4_turn(l,i+2)=gcorr4_turn(l,i+2)-(s1+s2+s3)
4294           enddo
4295         endif
4296 C Remaining derivatives of this turn contribution
4297         do l=1,3
4298           a_temp(1,1)=aggi(l,1)
4299           a_temp(1,2)=aggi(l,2)
4300           a_temp(2,1)=aggi(l,3)
4301           a_temp(2,2)=aggi(l,4)
4302           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4303           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4304           s1=scalar2(b1(1,iti2),auxvec(1))
4305           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4306           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4307           s2=scalar2(b1(1,iti1),auxvec(1))
4308           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4309           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4310           s3=0.5d0*(pizda(1,1)+pizda(2,2))
4311           gcorr4_turn(l,i)=gcorr4_turn(l,i)-(s1+s2+s3)
4312           a_temp(1,1)=aggi1(l,1)
4313           a_temp(1,2)=aggi1(l,2)
4314           a_temp(2,1)=aggi1(l,3)
4315           a_temp(2,2)=aggi1(l,4)
4316           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4317           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4318           s1=scalar2(b1(1,iti2),auxvec(1))
4319           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4320           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4321           s2=scalar2(b1(1,iti1),auxvec(1))
4322           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4323           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4324           s3=0.5d0*(pizda(1,1)+pizda(2,2))
4325           gcorr4_turn(l,i+1)=gcorr4_turn(l,i+1)-(s1+s2+s3)
4326           a_temp(1,1)=aggj(l,1)
4327           a_temp(1,2)=aggj(l,2)
4328           a_temp(2,1)=aggj(l,3)
4329           a_temp(2,2)=aggj(l,4)
4330           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4331           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4332           s1=scalar2(b1(1,iti2),auxvec(1))
4333           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4334           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4335           s2=scalar2(b1(1,iti1),auxvec(1))
4336           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4337           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4338           s3=0.5d0*(pizda(1,1)+pizda(2,2))
4339           gcorr4_turn(l,j)=gcorr4_turn(l,j)-(s1+s2+s3)
4340           a_temp(1,1)=aggj1(l,1)
4341           a_temp(1,2)=aggj1(l,2)
4342           a_temp(2,1)=aggj1(l,3)
4343           a_temp(2,2)=aggj1(l,4)
4344           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4345           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4346           s1=scalar2(b1(1,iti2),auxvec(1))
4347           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4348           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4349           s2=scalar2(b1(1,iti1),auxvec(1))
4350           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4351           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4352           s3=0.5d0*(pizda(1,1)+pizda(2,2))
4353 c          write (iout,*) "s1",s1," s2",s2," s3",s3," s1+s2+s3",s1+s2+s3
4354           gcorr4_turn(l,j1)=gcorr4_turn(l,j1)-(s1+s2+s3)
4355         enddo
4356       return
4357       end
4358 C-----------------------------------------------------------------------------
4359       subroutine vecpr(u,v,w)
4360       implicit real*8(a-h,o-z)
4361       dimension u(3),v(3),w(3)
4362       w(1)=u(2)*v(3)-u(3)*v(2)
4363       w(2)=-u(1)*v(3)+u(3)*v(1)
4364       w(3)=u(1)*v(2)-u(2)*v(1)
4365       return
4366       end
4367 C-----------------------------------------------------------------------------
4368       subroutine unormderiv(u,ugrad,unorm,ungrad)
4369 C This subroutine computes the derivatives of a normalized vector u, given
4370 C the derivatives computed without normalization conditions, ugrad. Returns
4371 C ungrad.
4372       implicit none
4373       double precision u(3),ugrad(3,3),unorm,ungrad(3,3)
4374       double precision vec(3)
4375       double precision scalar
4376       integer i,j
4377 c      write (2,*) 'ugrad',ugrad
4378 c      write (2,*) 'u',u
4379       do i=1,3
4380         vec(i)=scalar(ugrad(1,i),u(1))
4381       enddo
4382 c      write (2,*) 'vec',vec
4383       do i=1,3
4384         do j=1,3
4385           ungrad(j,i)=(ugrad(j,i)-u(j)*vec(i))*unorm
4386         enddo
4387       enddo
4388 c      write (2,*) 'ungrad',ungrad
4389       return
4390       end
4391 C-----------------------------------------------------------------------------
4392       subroutine escp_soft_sphere(evdw2,evdw2_14)
4393 C
4394 C This subroutine calculates the excluded-volume interaction energy between
4395 C peptide-group centers and side chains and its gradient in virtual-bond and
4396 C side-chain vectors.
4397 C
4398       implicit real*8 (a-h,o-z)
4399       include 'DIMENSIONS'
4400       include 'COMMON.GEO'
4401       include 'COMMON.VAR'
4402       include 'COMMON.LOCAL'
4403       include 'COMMON.CHAIN'
4404       include 'COMMON.DERIV'
4405       include 'COMMON.INTERACT'
4406       include 'COMMON.FFIELD'
4407       include 'COMMON.IOUNITS'
4408       include 'COMMON.CONTROL'
4409       dimension ggg(3)
4410       evdw2=0.0D0
4411       evdw2_14=0.0d0
4412       r0_scp=4.5d0
4413 cd    print '(a)','Enter ESCP'
4414 cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
4415 C      do xshift=-1,1
4416 C      do yshift=-1,1
4417 C      do zshift=-1,1
4418       do i=iatscp_s,iatscp_e
4419         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
4420         iteli=itel(i)
4421         xi=0.5D0*(c(1,i)+c(1,i+1))
4422         yi=0.5D0*(c(2,i)+c(2,i+1))
4423         zi=0.5D0*(c(3,i)+c(3,i+1))
4424 C Return atom into box, boxxsize is size of box in x dimension
4425 c  134   continue
4426 c        if (xi.gt.((xshift+0.5d0)*boxxsize)) xi=xi-boxxsize
4427 c        if (xi.lt.((xshift-0.5d0)*boxxsize)) xi=xi+boxxsize
4428 C Condition for being inside the proper box
4429 c        if ((xi.gt.((xshift+0.5d0)*boxxsize)).or.
4430 c     &       (xi.lt.((xshift-0.5d0)*boxxsize))) then
4431 c        go to 134
4432 c        endif
4433 c  135   continue
4434 c        if (yi.gt.((yshift+0.5d0)*boxysize)) yi=yi-boxysize
4435 c        if (yi.lt.((yshift-0.5d0)*boxysize)) yi=yi+boxysize
4436 C Condition for being inside the proper box
4437 c        if ((yi.gt.((yshift+0.5d0)*boxysize)).or.
4438 c     &       (yi.lt.((yshift-0.5d0)*boxysize))) then
4439 c        go to 135
4440 c c       endif
4441 c  136   continue
4442 c        if (zi.gt.((zshift+0.5d0)*boxzsize)) zi=zi-boxzsize
4443 c        if (zi.lt.((zshift-0.5d0)*boxzsize)) zi=zi+boxzsize
4444 cC Condition for being inside the proper box
4445 c        if ((zi.gt.((zshift+0.5d0)*boxzsize)).or.
4446 c     &       (zi.lt.((zshift-0.5d0)*boxzsize))) then
4447 c        go to 136
4448 c        endif
4449           xi=mod(xi,boxxsize)
4450           if (xi.lt.0) xi=xi+boxxsize
4451           yi=mod(yi,boxysize)
4452           if (yi.lt.0) yi=yi+boxysize
4453           zi=mod(zi,boxzsize)
4454           if (zi.lt.0) zi=zi+boxzsize
4455 C          xi=xi+xshift*boxxsize
4456 C          yi=yi+yshift*boxysize
4457 C          zi=zi+zshift*boxzsize
4458         do iint=1,nscp_gr(i)
4459
4460         do j=iscpstart(i,iint),iscpend(i,iint)
4461           if (itype(j).eq.ntyp1) cycle
4462           itypj=iabs(itype(j))
4463 C Uncomment following three lines for SC-p interactions
4464 c         xj=c(1,nres+j)-xi
4465 c         yj=c(2,nres+j)-yi
4466 c         zj=c(3,nres+j)-zi
4467 C Uncomment following three lines for Ca-p interactions
4468           xj=c(1,j)
4469           yj=c(2,j)
4470           zj=c(3,j)
4471 c  174   continue
4472 c        if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
4473 c        if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
4474 C Condition for being inside the proper box
4475 c        if ((xj.gt.((0.5d0)*boxxsize)).or.
4476 c     &       (xj.lt.((-0.5d0)*boxxsize))) then
4477 c        go to 174
4478 c        endif
4479 c  175   continue
4480 c        if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
4481 c        if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
4482 cC Condition for being inside the proper box
4483 c        if ((yj.gt.((0.5d0)*boxysize)).or.
4484 c     &       (yj.lt.((-0.5d0)*boxysize))) then
4485 c        go to 175
4486 c        endif
4487 c  176   continue
4488 c        if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
4489 c        if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
4490 C Condition for being inside the proper box
4491 c        if ((zj.gt.((0.5d0)*boxzsize)).or.
4492 c     &       (zj.lt.((-0.5d0)*boxzsize))) then
4493 c        go to 176
4494           xj=mod(xj,boxxsize)
4495           if (xj.lt.0) xj=xj+boxxsize
4496           yj=mod(yj,boxysize)
4497           if (yj.lt.0) yj=yj+boxysize
4498           zj=mod(zj,boxzsize)
4499           if (zj.lt.0) zj=zj+boxzsize
4500       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
4501       xj_safe=xj
4502       yj_safe=yj
4503       zj_safe=zj
4504       subchap=0
4505       do xshift=-1,1
4506       do yshift=-1,1
4507       do zshift=-1,1
4508           xj=xj_safe+xshift*boxxsize
4509           yj=yj_safe+yshift*boxysize
4510           zj=zj_safe+zshift*boxzsize
4511           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
4512           if(dist_temp.lt.dist_init) then
4513             dist_init=dist_temp
4514             xj_temp=xj
4515             yj_temp=yj
4516             zj_temp=zj
4517             subchap=1
4518           endif
4519        enddo
4520        enddo
4521        enddo
4522        if (subchap.eq.1) then
4523           xj=xj_temp-xi
4524           yj=yj_temp-yi
4525           zj=zj_temp-zi
4526        else
4527           xj=xj_safe-xi
4528           yj=yj_safe-yi
4529           zj=zj_safe-zi
4530        endif
4531 c c       endif
4532 C          xj=xj-xi
4533 C          yj=yj-yi
4534 C          zj=zj-zi
4535           rij=xj*xj+yj*yj+zj*zj
4536
4537           r0ij=r0_scp
4538           r0ijsq=r0ij*r0ij
4539           if (rij.lt.r0ijsq) then
4540             evdwij=0.25d0*(rij-r0ijsq)**2
4541             fac=rij-r0ijsq
4542           else
4543             evdwij=0.0d0
4544             fac=0.0d0
4545           endif
4546           evdw2=evdw2+evdwij
4547 C
4548 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
4549 C
4550           ggg(1)=xj*fac
4551           ggg(2)=yj*fac
4552           ggg(3)=zj*fac
4553 cgrad          if (j.lt.i) then
4554 cd          write (iout,*) 'j<i'
4555 C Uncomment following three lines for SC-p interactions
4556 c           do k=1,3
4557 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
4558 c           enddo
4559 cgrad          else
4560 cd          write (iout,*) 'j>i'
4561 cgrad            do k=1,3
4562 cgrad              ggg(k)=-ggg(k)
4563 C Uncomment following line for SC-p interactions
4564 c             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
4565 cgrad            enddo
4566 cgrad          endif
4567 cgrad          do k=1,3
4568 cgrad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
4569 cgrad          enddo
4570 cgrad          kstart=min0(i+1,j)
4571 cgrad          kend=max0(i-1,j-1)
4572 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
4573 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
4574 cgrad          do k=kstart,kend
4575 cgrad            do l=1,3
4576 cgrad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
4577 cgrad            enddo
4578 cgrad          enddo
4579           do k=1,3
4580             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
4581             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
4582           enddo
4583         enddo
4584
4585         enddo ! iint
4586       enddo ! i
4587 C      enddo !zshift
4588 C      enddo !yshift
4589 C      enddo !xshift
4590       return
4591       end
4592 C-----------------------------------------------------------------------------
4593       subroutine escp(evdw2,evdw2_14)
4594 C
4595 C This subroutine calculates the excluded-volume interaction energy between
4596 C peptide-group centers and side chains and its gradient in virtual-bond and
4597 C side-chain vectors.
4598 C
4599       implicit real*8 (a-h,o-z)
4600       include 'DIMENSIONS'
4601       include 'COMMON.GEO'
4602       include 'COMMON.VAR'
4603       include 'COMMON.LOCAL'
4604       include 'COMMON.CHAIN'
4605       include 'COMMON.DERIV'
4606       include 'COMMON.INTERACT'
4607       include 'COMMON.FFIELD'
4608       include 'COMMON.IOUNITS'
4609       include 'COMMON.CONTROL'
4610       include 'COMMON.SPLITELE'
4611       dimension ggg(3)
4612       evdw2=0.0D0
4613       evdw2_14=0.0d0
4614 c        print *,boxxsize,boxysize,boxzsize,'wymiary pudla'
4615 cd    print '(a)','Enter ESCP'
4616 cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
4617 C      do xshift=-1,1
4618 C      do yshift=-1,1
4619 C      do zshift=-1,1
4620       do i=iatscp_s,iatscp_e
4621         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
4622         iteli=itel(i)
4623         xi=0.5D0*(c(1,i)+c(1,i+1))
4624         yi=0.5D0*(c(2,i)+c(2,i+1))
4625         zi=0.5D0*(c(3,i)+c(3,i+1))
4626           xi=mod(xi,boxxsize)
4627           if (xi.lt.0) xi=xi+boxxsize
4628           yi=mod(yi,boxysize)
4629           if (yi.lt.0) yi=yi+boxysize
4630           zi=mod(zi,boxzsize)
4631           if (zi.lt.0) zi=zi+boxzsize
4632 c          xi=xi+xshift*boxxsize
4633 c          yi=yi+yshift*boxysize
4634 c          zi=zi+zshift*boxzsize
4635 c        print *,xi,yi,zi,'polozenie i'
4636 C Return atom into box, boxxsize is size of box in x dimension
4637 c  134   continue
4638 c        if (xi.gt.((xshift+0.5d0)*boxxsize)) xi=xi-boxxsize
4639 c        if (xi.lt.((xshift-0.5d0)*boxxsize)) xi=xi+boxxsize
4640 C Condition for being inside the proper box
4641 c        if ((xi.gt.((xshift+0.5d0)*boxxsize)).or.
4642 c     &       (xi.lt.((xshift-0.5d0)*boxxsize))) then
4643 c        go to 134
4644 c        endif
4645 c  135   continue
4646 c          print *,xi,boxxsize,"pierwszy"
4647
4648 c        if (yi.gt.((yshift+0.5d0)*boxysize)) yi=yi-boxysize
4649 c        if (yi.lt.((yshift-0.5d0)*boxysize)) yi=yi+boxysize
4650 C Condition for being inside the proper box
4651 c        if ((yi.gt.((yshift+0.5d0)*boxysize)).or.
4652 c     &       (yi.lt.((yshift-0.5d0)*boxysize))) then
4653 c        go to 135
4654 c        endif
4655 c  136   continue
4656 c        if (zi.gt.((zshift+0.5d0)*boxzsize)) zi=zi-boxzsize
4657 c        if (zi.lt.((zshift-0.5d0)*boxzsize)) zi=zi+boxzsize
4658 C Condition for being inside the proper box
4659 c        if ((zi.gt.((zshift+0.5d0)*boxzsize)).or.
4660 c     &       (zi.lt.((zshift-0.5d0)*boxzsize))) then
4661 c        go to 136
4662 c        endif
4663         do iint=1,nscp_gr(i)
4664
4665         do j=iscpstart(i,iint),iscpend(i,iint)
4666           itypj=iabs(itype(j))
4667           if (itypj.eq.ntyp1) cycle
4668 C Uncomment following three lines for SC-p interactions
4669 c         xj=c(1,nres+j)-xi
4670 c         yj=c(2,nres+j)-yi
4671 c         zj=c(3,nres+j)-zi
4672 C Uncomment following three lines for Ca-p interactions
4673           xj=c(1,j)
4674           yj=c(2,j)
4675           zj=c(3,j)
4676           xj=mod(xj,boxxsize)
4677           if (xj.lt.0) xj=xj+boxxsize
4678           yj=mod(yj,boxysize)
4679           if (yj.lt.0) yj=yj+boxysize
4680           zj=mod(zj,boxzsize)
4681           if (zj.lt.0) zj=zj+boxzsize
4682 c  174   continue
4683 c        if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
4684 c        if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
4685 C Condition for being inside the proper box
4686 c        if ((xj.gt.((0.5d0)*boxxsize)).or.
4687 c     &       (xj.lt.((-0.5d0)*boxxsize))) then
4688 c        go to 174
4689 c        endif
4690 c  175   continue
4691 c        if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
4692 c        if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
4693 cC Condition for being inside the proper box
4694 c        if ((yj.gt.((0.5d0)*boxysize)).or.
4695 c     &       (yj.lt.((-0.5d0)*boxysize))) then
4696 c        go to 175
4697 c        endif
4698 c  176   continue
4699 c        if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
4700 c        if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
4701 C Condition for being inside the proper box
4702 c        if ((zj.gt.((0.5d0)*boxzsize)).or.
4703 c     &       (zj.lt.((-0.5d0)*boxzsize))) then
4704 c        go to 176
4705 c        endif
4706 CHERE IS THE CALCULATION WHICH MIRROR IMAGE IS THE CLOSEST ONE
4707       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
4708       xj_safe=xj
4709       yj_safe=yj
4710       zj_safe=zj
4711       subchap=0
4712       do xshift=-1,1
4713       do yshift=-1,1
4714       do zshift=-1,1
4715           xj=xj_safe+xshift*boxxsize
4716           yj=yj_safe+yshift*boxysize
4717           zj=zj_safe+zshift*boxzsize
4718           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
4719           if(dist_temp.lt.dist_init) then
4720             dist_init=dist_temp
4721             xj_temp=xj
4722             yj_temp=yj
4723             zj_temp=zj
4724             subchap=1
4725           endif
4726        enddo
4727        enddo
4728        enddo
4729        if (subchap.eq.1) then
4730           xj=xj_temp-xi
4731           yj=yj_temp-yi
4732           zj=zj_temp-zi
4733        else
4734           xj=xj_safe-xi
4735           yj=yj_safe-yi
4736           zj=zj_safe-zi
4737        endif
4738 c          print *,xj,yj,zj,'polozenie j'
4739           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
4740 c          print *,rrij
4741           sss=sscale(1.0d0/(dsqrt(rrij)))
4742 c          print *,r_cut,1.0d0/dsqrt(rrij),sss,'tu patrz'
4743 c          if (sss.eq.0) print *,'czasem jest OK'
4744           if (sss.le.0.0d0) cycle
4745           sssgrad=sscagrad(1.0d0/(dsqrt(rrij)))
4746           fac=rrij**expon2
4747           e1=fac*fac*aad(itypj,iteli)
4748           e2=fac*bad(itypj,iteli)
4749           if (iabs(j-i) .le. 2) then
4750             e1=scal14*e1
4751             e2=scal14*e2
4752             evdw2_14=evdw2_14+(e1+e2)*sss
4753           endif
4754           evdwij=e1+e2
4755           evdw2=evdw2+evdwij*sss
4756           if (energy_dec) write (iout,'(a6,2i5,0pf7.3,2i3,3e11.3)')
4757      &        'evdw2',i,j,evdwij,iteli,itypj,fac,aad(itypj,iteli),
4758      &       bad(itypj,iteli)
4759 C
4760 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
4761 C
4762           fac=-(evdwij+e1)*rrij*sss
4763           fac=fac+(evdwij)*sssgrad*dsqrt(rrij)/expon
4764           ggg(1)=xj*fac
4765           ggg(2)=yj*fac
4766           ggg(3)=zj*fac
4767 cgrad          if (j.lt.i) then
4768 cd          write (iout,*) 'j<i'
4769 C Uncomment following three lines for SC-p interactions
4770 c           do k=1,3
4771 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
4772 c           enddo
4773 cgrad          else
4774 cd          write (iout,*) 'j>i'
4775 cgrad            do k=1,3
4776 cgrad              ggg(k)=-ggg(k)
4777 C Uncomment following line for SC-p interactions
4778 ccgrad             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
4779 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
4780 cgrad            enddo
4781 cgrad          endif
4782 cgrad          do k=1,3
4783 cgrad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
4784 cgrad          enddo
4785 cgrad          kstart=min0(i+1,j)
4786 cgrad          kend=max0(i-1,j-1)
4787 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
4788 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
4789 cgrad          do k=kstart,kend
4790 cgrad            do l=1,3
4791 cgrad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
4792 cgrad            enddo
4793 cgrad          enddo
4794           do k=1,3
4795             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
4796             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
4797           enddo
4798 c        endif !endif for sscale cutoff
4799         enddo ! j
4800
4801         enddo ! iint
4802       enddo ! i
4803 c      enddo !zshift
4804 c      enddo !yshift
4805 c      enddo !xshift
4806       do i=1,nct
4807         do j=1,3
4808           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
4809           gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
4810           gradx_scp(j,i)=expon*gradx_scp(j,i)
4811         enddo
4812       enddo
4813 C******************************************************************************
4814 C
4815 C                              N O T E !!!
4816 C
4817 C To save time the factor EXPON has been extracted from ALL components
4818 C of GVDWC and GRADX. Remember to multiply them by this factor before further
4819 C use!
4820 C
4821 C******************************************************************************
4822       return
4823       end
4824 C--------------------------------------------------------------------------
4825       subroutine edis(ehpb)
4826 C
4827 C Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors.
4828 C
4829       implicit real*8 (a-h,o-z)
4830       include 'DIMENSIONS'
4831       include 'COMMON.SBRIDGE'
4832       include 'COMMON.CHAIN'
4833       include 'COMMON.DERIV'
4834       include 'COMMON.VAR'
4835       include 'COMMON.INTERACT'
4836       include 'COMMON.IOUNITS'
4837       dimension ggg(3)
4838       ehpb=0.0D0
4839 cd      write(iout,*)'edis: nhpb=',nhpb,' fbr=',fbr
4840 cd      write(iout,*)'link_start=',link_start,' link_end=',link_end
4841       if (link_end.eq.0) return
4842       do i=link_start,link_end
4843 C If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a
4844 C CA-CA distance used in regularization of structure.
4845         ii=ihpb(i)
4846         jj=jhpb(i)
4847 C iii and jjj point to the residues for which the distance is assigned.
4848         if (ii.gt.nres) then
4849           iii=ii-nres
4850           jjj=jj-nres
4851         else
4852           iii=ii
4853           jjj=jj
4854         endif
4855 c        write (iout,*) "i",i," ii",ii," iii",iii," jj",jj," jjj",jjj,
4856 c     &    dhpb(i),dhpb1(i),forcon(i)
4857 C 24/11/03 AL: SS bridges handled separately because of introducing a specific
4858 C    distance and angle dependent SS bond potential.
4859 C        if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and.
4860 C     & iabs(itype(jjj)).eq.1) then
4861 cmc        if (ii.gt.nres .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then
4862 C 18/07/06 MC: Use the convention that the first nss pairs are SS bonds
4863         if (.not.dyn_ss .and. i.le.nss) then
4864 C 15/02/13 CC dynamic SSbond - additional check
4865          if (ii.gt.nres
4866      &       .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then
4867           call ssbond_ene(iii,jjj,eij)
4868           ehpb=ehpb+2*eij
4869          endif
4870 cd          write (iout,*) "eij",eij
4871         else
4872 C Calculate the distance between the two points and its difference from the
4873 C target distance.
4874           dd=dist(ii,jj)
4875             rdis=dd-dhpb(i)
4876 C Get the force constant corresponding to this distance.
4877             waga=forcon(i)
4878 C Calculate the contribution to energy.
4879             ehpb=ehpb+waga*rdis*rdis
4880 C
4881 C Evaluate gradient.
4882 C
4883             fac=waga*rdis/dd
4884 cd      print *,'i=',i,' ii=',ii,' jj=',jj,' dhpb=',dhpb(i),' dd=',dd,
4885 cd   &   ' waga=',waga,' fac=',fac
4886             do j=1,3
4887               ggg(j)=fac*(c(j,jj)-c(j,ii))
4888             enddo
4889 cd      print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
4890 C If this is a SC-SC distance, we need to calculate the contributions to the
4891 C Cartesian gradient in the SC vectors (ghpbx).
4892           if (iii.lt.ii) then
4893           do j=1,3
4894             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
4895             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
4896           enddo
4897           endif
4898 cgrad        do j=iii,jjj-1
4899 cgrad          do k=1,3
4900 cgrad            ghpbc(k,j)=ghpbc(k,j)+ggg(k)
4901 cgrad          enddo
4902 cgrad        enddo
4903           do k=1,3
4904             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
4905             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
4906           enddo
4907         endif
4908       enddo
4909       ehpb=0.5D0*ehpb
4910       return
4911       end
4912 C--------------------------------------------------------------------------
4913       subroutine ssbond_ene(i,j,eij)
4914 C
4915 C Calculate the distance and angle dependent SS-bond potential energy
4916 C using a free-energy function derived based on RHF/6-31G** ab initio
4917 C calculations of diethyl disulfide.
4918 C
4919 C A. Liwo and U. Kozlowska, 11/24/03
4920 C
4921       implicit real*8 (a-h,o-z)
4922       include 'DIMENSIONS'
4923       include 'COMMON.SBRIDGE'
4924       include 'COMMON.CHAIN'
4925       include 'COMMON.DERIV'
4926       include 'COMMON.LOCAL'
4927       include 'COMMON.INTERACT'
4928       include 'COMMON.VAR'
4929       include 'COMMON.IOUNITS'
4930       double precision erij(3),dcosom1(3),dcosom2(3),gg(3)
4931       itypi=iabs(itype(i))
4932       xi=c(1,nres+i)
4933       yi=c(2,nres+i)
4934       zi=c(3,nres+i)
4935       dxi=dc_norm(1,nres+i)
4936       dyi=dc_norm(2,nres+i)
4937       dzi=dc_norm(3,nres+i)
4938 c      dsci_inv=dsc_inv(itypi)
4939       dsci_inv=vbld_inv(nres+i)
4940       itypj=iabs(itype(j))
4941 c      dscj_inv=dsc_inv(itypj)
4942       dscj_inv=vbld_inv(nres+j)
4943       xj=c(1,nres+j)-xi
4944       yj=c(2,nres+j)-yi
4945       zj=c(3,nres+j)-zi
4946       dxj=dc_norm(1,nres+j)
4947       dyj=dc_norm(2,nres+j)
4948       dzj=dc_norm(3,nres+j)
4949       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
4950       rij=dsqrt(rrij)
4951       erij(1)=xj*rij
4952       erij(2)=yj*rij
4953       erij(3)=zj*rij
4954       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
4955       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
4956       om12=dxi*dxj+dyi*dyj+dzi*dzj
4957       do k=1,3
4958         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
4959         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
4960       enddo
4961       rij=1.0d0/rij
4962       deltad=rij-d0cm
4963       deltat1=1.0d0-om1
4964       deltat2=1.0d0+om2
4965       deltat12=om2-om1+2.0d0
4966       cosphi=om12-om1*om2
4967       eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2)
4968      &  +akct*deltad*deltat12
4969      &  +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi+ebr
4970 c      write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth,
4971 c     &  " akct",akct," deltad",deltad," deltat",deltat1,deltat2,
4972 c     &  " deltat12",deltat12," eij",eij
4973       ed=2*akcm*deltad+akct*deltat12
4974       pom1=akct*deltad
4975       pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
4976       eom1=-2*akth*deltat1-pom1-om2*pom2
4977       eom2= 2*akth*deltat2+pom1-om1*pom2
4978       eom12=pom2
4979       do k=1,3
4980         ggk=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
4981         ghpbx(k,i)=ghpbx(k,i)-ggk
4982      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
4983      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
4984         ghpbx(k,j)=ghpbx(k,j)+ggk
4985      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
4986      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
4987         ghpbc(k,i)=ghpbc(k,i)-ggk
4988         ghpbc(k,j)=ghpbc(k,j)+ggk
4989       enddo
4990 C
4991 C Calculate the components of the gradient in DC and X
4992 C
4993 cgrad      do k=i,j-1
4994 cgrad        do l=1,3
4995 cgrad          ghpbc(l,k)=ghpbc(l,k)+gg(l)
4996 cgrad        enddo
4997 cgrad      enddo
4998       return
4999       end
5000 C--------------------------------------------------------------------------
5001       subroutine ebond(estr)
5002 c
5003 c Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
5004 c
5005       implicit real*8 (a-h,o-z)
5006       include 'DIMENSIONS'
5007       include 'COMMON.LOCAL'
5008       include 'COMMON.GEO'
5009       include 'COMMON.INTERACT'
5010       include 'COMMON.DERIV'
5011       include 'COMMON.VAR'
5012       include 'COMMON.CHAIN'
5013       include 'COMMON.IOUNITS'
5014       include 'COMMON.NAMES'
5015       include 'COMMON.FFIELD'
5016       include 'COMMON.CONTROL'
5017       include 'COMMON.SETUP'
5018       double precision u(3),ud(3)
5019       estr=0.0d0
5020       estr1=0.0d0
5021       do i=ibondp_start,ibondp_end
5022         if (itype(i-1).eq.ntyp1 .and. itype(i).eq.ntyp1) cycle
5023 c          estr1=estr1+gnmr1(vbld(i),-1.0d0,distchainmax)
5024 c          do j=1,3
5025 c          gradb(j,i-1)=gnmr1prim(vbld(i),-1.0d0,distchainmax)
5026 c     &      *dc(j,i-1)/vbld(i)
5027 c          enddo
5028 c          if (energy_dec) write(iout,*)
5029 c     &       "estr1",i,gnmr1(vbld(i),-1.0d0,distchainmax)
5030 c        else
5031 C       Checking if it involves dummy (NH3+ or COO-) group
5032          if (itype(i-1).eq.ntyp1 .or. itype(i).eq.ntyp1) then
5033 C YES   vbldpDUM is the equlibrium length of spring for Dummy atom
5034         diff = vbld(i)-vbldpDUM
5035          else
5036 C NO    vbldp0 is the equlibrium lenght of spring for peptide group
5037         diff = vbld(i)-vbldp0
5038          endif
5039         if (energy_dec)    write (iout,'(a7,i5,4f7.3)')
5040      &     "estr bb",i,vbld(i),vbldp0,diff,AKP*diff*diff
5041         estr=estr+diff*diff
5042         do j=1,3
5043           gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)
5044         enddo
5045 c        write (iout,'(i5,3f10.5)') i,(gradb(j,i-1),j=1,3)
5046 c        endif
5047       enddo
5048       estr=0.5d0*AKP*estr+estr1
5049 c
5050 c 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included
5051 c
5052       do i=ibond_start,ibond_end
5053         iti=iabs(itype(i))
5054         if (iti.ne.10 .and. iti.ne.ntyp1) then
5055           nbi=nbondterm(iti)
5056           if (nbi.eq.1) then
5057             diff=vbld(i+nres)-vbldsc0(1,iti)
5058             if (energy_dec)  write (iout,*)
5059      &      "estr sc",i,iti,vbld(i+nres),vbldsc0(1,iti),diff,
5060      &      AKSC(1,iti),AKSC(1,iti)*diff*diff
5061             estr=estr+0.5d0*AKSC(1,iti)*diff*diff
5062             do j=1,3
5063               gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
5064             enddo
5065           else
5066             do j=1,nbi
5067               diff=vbld(i+nres)-vbldsc0(j,iti)
5068               ud(j)=aksc(j,iti)*diff
5069               u(j)=abond0(j,iti)+0.5d0*ud(j)*diff
5070             enddo
5071             uprod=u(1)
5072             do j=2,nbi
5073               uprod=uprod*u(j)
5074             enddo
5075             usum=0.0d0
5076             usumsqder=0.0d0
5077             do j=1,nbi
5078               uprod1=1.0d0
5079               uprod2=1.0d0
5080               do k=1,nbi
5081                 if (k.ne.j) then
5082                   uprod1=uprod1*u(k)
5083                   uprod2=uprod2*u(k)*u(k)
5084                 endif
5085               enddo
5086               usum=usum+uprod1
5087               usumsqder=usumsqder+ud(j)*uprod2
5088             enddo
5089             estr=estr+uprod/usum
5090             do j=1,3
5091              gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
5092             enddo
5093           endif
5094         endif
5095       enddo
5096       return
5097       end
5098 #ifdef CRYST_THETA
5099 C--------------------------------------------------------------------------
5100       subroutine ebend(etheta)
5101 C
5102 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
5103 C angles gamma and its derivatives in consecutive thetas and gammas.
5104 C
5105       implicit real*8 (a-h,o-z)
5106       include 'DIMENSIONS'
5107       include 'COMMON.LOCAL'
5108       include 'COMMON.GEO'
5109       include 'COMMON.INTERACT'
5110       include 'COMMON.DERIV'
5111       include 'COMMON.VAR'
5112       include 'COMMON.CHAIN'
5113       include 'COMMON.IOUNITS'
5114       include 'COMMON.NAMES'
5115       include 'COMMON.FFIELD'
5116       include 'COMMON.CONTROL'
5117       common /calcthet/ term1,term2,termm,diffak,ratak,
5118      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
5119      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
5120       double precision y(2),z(2)
5121       delta=0.02d0*pi
5122 c      time11=dexp(-2*time)
5123 c      time12=1.0d0
5124       etheta=0.0D0
5125 c     write (*,'(a,i2)') 'EBEND ICG=',icg
5126       do i=ithet_start,ithet_end
5127         if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
5128      &  .or.itype(i).eq.ntyp1) cycle
5129 C Zero the energy function and its derivative at 0 or pi.
5130         call splinthet(theta(i),0.5d0*delta,ss,ssd)
5131         it=itype(i-1)
5132         ichir1=isign(1,itype(i-2))
5133         ichir2=isign(1,itype(i))
5134          if (itype(i-2).eq.10) ichir1=isign(1,itype(i-1))
5135          if (itype(i).eq.10) ichir2=isign(1,itype(i-1))
5136          if (itype(i-1).eq.10) then
5137           itype1=isign(10,itype(i-2))
5138           ichir11=isign(1,itype(i-2))
5139           ichir12=isign(1,itype(i-2))
5140           itype2=isign(10,itype(i))
5141           ichir21=isign(1,itype(i))
5142           ichir22=isign(1,itype(i))
5143          endif
5144
5145         if (i.gt.3 .and. itype(i-3).ne.ntyp1) then
5146 #ifdef OSF
5147           phii=phi(i)
5148           if (phii.ne.phii) phii=150.0
5149 #else
5150           phii=phi(i)
5151 #endif
5152           y(1)=dcos(phii)
5153           y(2)=dsin(phii)
5154         else
5155           y(1)=0.0D0
5156           y(2)=0.0D0
5157         endif
5158         if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
5159 #ifdef OSF
5160           phii1=phi(i+1)
5161           if (phii1.ne.phii1) phii1=150.0
5162           phii1=pinorm(phii1)
5163           z(1)=cos(phii1)
5164 #else
5165           phii1=phi(i+1)
5166 #endif
5167           z(1)=dcos(phii1)
5168           z(2)=dsin(phii1)
5169         else
5170           z(1)=0.0D0
5171           z(2)=0.0D0
5172         endif
5173 C Calculate the "mean" value of theta from the part of the distribution
5174 C dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2).
5175 C In following comments this theta will be referred to as t_c.
5176         thet_pred_mean=0.0d0
5177         do k=1,2
5178             athetk=athet(k,it,ichir1,ichir2)
5179             bthetk=bthet(k,it,ichir1,ichir2)
5180           if (it.eq.10) then
5181              athetk=athet(k,itype1,ichir11,ichir12)
5182              bthetk=bthet(k,itype2,ichir21,ichir22)
5183           endif
5184          thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k)
5185 c         write(iout,*) 'chuj tu', y(k),z(k)
5186         enddo
5187         dthett=thet_pred_mean*ssd
5188         thet_pred_mean=thet_pred_mean*ss+a0thet(it)
5189 C Derivatives of the "mean" values in gamma1 and gamma2.
5190         dthetg1=(-athet(1,it,ichir1,ichir2)*y(2)
5191      &+athet(2,it,ichir1,ichir2)*y(1))*ss
5192          dthetg2=(-bthet(1,it,ichir1,ichir2)*z(2)
5193      &          +bthet(2,it,ichir1,ichir2)*z(1))*ss
5194          if (it.eq.10) then
5195       dthetg1=(-athet(1,itype1,ichir11,ichir12)*y(2)
5196      &+athet(2,itype1,ichir11,ichir12)*y(1))*ss
5197         dthetg2=(-bthet(1,itype2,ichir21,ichir22)*z(2)
5198      &         +bthet(2,itype2,ichir21,ichir22)*z(1))*ss
5199          endif
5200         if (theta(i).gt.pi-delta) then
5201           call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,
5202      &         E_tc0)
5203           call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0)
5204           call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
5205           call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,
5206      &        E_theta)
5207           call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,
5208      &        E_tc)
5209         else if (theta(i).lt.delta) then
5210           call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0)
5211           call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
5212           call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,
5213      &        E_theta)
5214           call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0)
5215           call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,
5216      &        E_tc)
5217         else
5218           call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,
5219      &        E_theta,E_tc)
5220         endif
5221         etheta=etheta+ethetai
5222         if (energy_dec) write (iout,'(a6,i5,0pf7.3,f7.3,i5)')
5223      &      'ebend',i,ethetai,theta(i),itype(i)
5224         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1
5225         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2
5226         gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)+gloc(nphi+i-2,icg)
5227       enddo
5228 C Ufff.... We've done all this!!!
5229       return
5230       end
5231 C---------------------------------------------------------------------------
5232       subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,
5233      &     E_tc)
5234       implicit real*8 (a-h,o-z)
5235       include 'DIMENSIONS'
5236       include 'COMMON.LOCAL'
5237       include 'COMMON.IOUNITS'
5238       common /calcthet/ term1,term2,termm,diffak,ratak,
5239      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
5240      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
5241 C Calculate the contributions to both Gaussian lobes.
5242 C 6/6/97 - Deform the Gaussians using the factor of 1/(1+time)
5243 C The "polynomial part" of the "standard deviation" of this part of
5244 C the distributioni.
5245 ccc        write (iout,*) thetai,thet_pred_mean
5246         sig=polthet(3,it)
5247         do j=2,0,-1
5248           sig=sig*thet_pred_mean+polthet(j,it)
5249         enddo
5250 C Derivative of the "interior part" of the "standard deviation of the"
5251 C gamma-dependent Gaussian lobe in t_c.
5252         sigtc=3*polthet(3,it)
5253         do j=2,1,-1
5254           sigtc=sigtc*thet_pred_mean+j*polthet(j,it)
5255         enddo
5256         sigtc=sig*sigtc
5257 C Set the parameters of both Gaussian lobes of the distribution.
5258 C "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc)
5259         fac=sig*sig+sigc0(it)
5260         sigcsq=fac+fac
5261         sigc=1.0D0/sigcsq
5262 C Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c
5263         sigsqtc=-4.0D0*sigcsq*sigtc
5264 c       print *,i,sig,sigtc,sigsqtc
5265 C Following variable (sigtc) is d[sigma(t_c)]/dt_c
5266         sigtc=-sigtc/(fac*fac)
5267 C Following variable is sigma(t_c)**(-2)
5268         sigcsq=sigcsq*sigcsq
5269         sig0i=sig0(it)
5270         sig0inv=1.0D0/sig0i**2
5271         delthec=thetai-thet_pred_mean
5272         delthe0=thetai-theta0i
5273         term1=-0.5D0*sigcsq*delthec*delthec
5274         term2=-0.5D0*sig0inv*delthe0*delthe0
5275 C        write (iout,*)'term1',term1,term2,sigcsq,delthec,sig0inv,delthe0
5276 C Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and
5277 C NaNs in taking the logarithm. We extract the largest exponent which is added
5278 C to the energy (this being the log of the distribution) at the end of energy
5279 C term evaluation for this virtual-bond angle.
5280         if (term1.gt.term2) then
5281           termm=term1
5282           term2=dexp(term2-termm)
5283           term1=1.0d0
5284         else
5285           termm=term2
5286           term1=dexp(term1-termm)
5287           term2=1.0d0
5288         endif
5289 C The ratio between the gamma-independent and gamma-dependent lobes of
5290 C the distribution is a Gaussian function of thet_pred_mean too.
5291         diffak=gthet(2,it)-thet_pred_mean
5292         ratak=diffak/gthet(3,it)**2
5293         ak=dexp(gthet(1,it)-0.5D0*diffak*ratak)
5294 C Let's differentiate it in thet_pred_mean NOW.
5295         aktc=ak*ratak
5296 C Now put together the distribution terms to make complete distribution.
5297         termexp=term1+ak*term2
5298         termpre=sigc+ak*sig0i
5299 C Contribution of the bending energy from this theta is just the -log of
5300 C the sum of the contributions from the two lobes and the pre-exponential
5301 C factor. Simple enough, isn't it?
5302         ethetai=(-dlog(termexp)-termm+dlog(termpre))
5303 C       write (iout,*) 'termexp',termexp,termm,termpre,i
5304 C NOW the derivatives!!!
5305 C 6/6/97 Take into account the deformation.
5306         E_theta=(delthec*sigcsq*term1
5307      &       +ak*delthe0*sig0inv*term2)/termexp
5308         E_tc=((sigtc+aktc*sig0i)/termpre
5309      &      -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+
5310      &       aktc*term2)/termexp)
5311       return
5312       end
5313 c-----------------------------------------------------------------------------
5314       subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)
5315       implicit real*8 (a-h,o-z)
5316       include 'DIMENSIONS'
5317       include 'COMMON.LOCAL'
5318       include 'COMMON.IOUNITS'
5319       common /calcthet/ term1,term2,termm,diffak,ratak,
5320      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
5321      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
5322       delthec=thetai-thet_pred_mean
5323       delthe0=thetai-theta0i
5324 C "Thank you" to MAPLE (probably spared one day of hand-differentiation).
5325       t3 = thetai-thet_pred_mean
5326       t6 = t3**2
5327       t9 = term1
5328       t12 = t3*sigcsq
5329       t14 = t12+t6*sigsqtc
5330       t16 = 1.0d0
5331       t21 = thetai-theta0i
5332       t23 = t21**2
5333       t26 = term2
5334       t27 = t21*t26
5335       t32 = termexp
5336       t40 = t32**2
5337       E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9
5338      & -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40
5339      & *(-t12*t9-ak*sig0inv*t27)
5340       return
5341       end
5342 #else
5343 C--------------------------------------------------------------------------
5344       subroutine ebend(etheta)
5345 C
5346 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
5347 C angles gamma and its derivatives in consecutive thetas and gammas.
5348 C ab initio-derived potentials from
5349 c Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203
5350 C
5351       implicit real*8 (a-h,o-z)
5352       include 'DIMENSIONS'
5353       include 'COMMON.LOCAL'
5354       include 'COMMON.GEO'
5355       include 'COMMON.INTERACT'
5356       include 'COMMON.DERIV'
5357       include 'COMMON.VAR'
5358       include 'COMMON.CHAIN'
5359       include 'COMMON.IOUNITS'
5360       include 'COMMON.NAMES'
5361       include 'COMMON.FFIELD'
5362       include 'COMMON.CONTROL'
5363       double precision coskt(mmaxtheterm),sinkt(mmaxtheterm),
5364      & cosph1(maxsingle),sinph1(maxsingle),cosph2(maxsingle),
5365      & sinph2(maxsingle),cosph1ph2(maxdouble,maxdouble),
5366      & sinph1ph2(maxdouble,maxdouble)
5367       logical lprn /.false./, lprn1 /.false./
5368       etheta=0.0D0
5369       do i=ithet_start,ithet_end
5370 c        print *,i,itype(i-1),itype(i),itype(i-2)
5371         if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
5372      &  .or.itype(i).eq.ntyp1) cycle
5373 C In current verion the ALL DUMMY ATOM POTENTIALS ARE OFF
5374
5375         if (iabs(itype(i+1)).eq.20) iblock=2
5376         if (iabs(itype(i+1)).ne.20) iblock=1
5377         dethetai=0.0d0
5378         dephii=0.0d0
5379         dephii1=0.0d0
5380         theti2=0.5d0*theta(i)
5381         ityp2=ithetyp((itype(i-1)))
5382         do k=1,nntheterm
5383           coskt(k)=dcos(k*theti2)
5384           sinkt(k)=dsin(k*theti2)
5385         enddo
5386         if (i.gt.3 .and. itype(i-3).ne.ntyp1) then
5387 #ifdef OSF
5388           phii=phi(i)
5389           if (phii.ne.phii) phii=150.0
5390 #else
5391           phii=phi(i)
5392 #endif
5393           ityp1=ithetyp((itype(i-2)))
5394 C propagation of chirality for glycine type
5395           do k=1,nsingle
5396             cosph1(k)=dcos(k*phii)
5397             sinph1(k)=dsin(k*phii)
5398           enddo
5399         else
5400           phii=0.0d0
5401           ityp1=nthetyp+1
5402           do k=1,nsingle
5403             cosph1(k)=0.0d0
5404             sinph1(k)=0.0d0
5405           enddo
5406         endif
5407         if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
5408 #ifdef OSF
5409           phii1=phi(i+1)
5410           if (phii1.ne.phii1) phii1=150.0
5411           phii1=pinorm(phii1)
5412 #else
5413           phii1=phi(i+1)
5414 #endif
5415           ityp3=ithetyp((itype(i)))
5416           do k=1,nsingle
5417             cosph2(k)=dcos(k*phii1)
5418             sinph2(k)=dsin(k*phii1)
5419           enddo
5420         else
5421           phii1=0.0d0
5422           ityp3=nthetyp+1
5423           do k=1,nsingle
5424             cosph2(k)=0.0d0
5425             sinph2(k)=0.0d0
5426           enddo
5427         endif
5428         ethetai=aa0thet(ityp1,ityp2,ityp3,iblock)
5429         do k=1,ndouble
5430           do l=1,k-1
5431             ccl=cosph1(l)*cosph2(k-l)
5432             ssl=sinph1(l)*sinph2(k-l)
5433             scl=sinph1(l)*cosph2(k-l)
5434             csl=cosph1(l)*sinph2(k-l)
5435             cosph1ph2(l,k)=ccl-ssl
5436             cosph1ph2(k,l)=ccl+ssl
5437             sinph1ph2(l,k)=scl+csl
5438             sinph1ph2(k,l)=scl-csl
5439           enddo
5440         enddo
5441         if (lprn) then
5442         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,
5443      &    " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
5444         write (iout,*) "coskt and sinkt"
5445         do k=1,nntheterm
5446           write (iout,*) k,coskt(k),sinkt(k)
5447         enddo
5448         endif
5449         do k=1,ntheterm
5450           ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3,iblock)*sinkt(k)
5451           dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3,iblock)
5452      &      *coskt(k)
5453           if (lprn)
5454      &    write (iout,*) "k",k,"
5455      &     aathet",aathet(k,ityp1,ityp2,ityp3,iblock),
5456      &     " ethetai",ethetai
5457         enddo
5458         if (lprn) then
5459         write (iout,*) "cosph and sinph"
5460         do k=1,nsingle
5461           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
5462         enddo
5463         write (iout,*) "cosph1ph2 and sinph2ph2"
5464         do k=2,ndouble
5465           do l=1,k-1
5466             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),
5467      &         sinph1ph2(l,k),sinph1ph2(k,l)
5468           enddo
5469         enddo
5470         write(iout,*) "ethetai",ethetai
5471         endif
5472         do m=1,ntheterm2
5473           do k=1,nsingle
5474             aux=bbthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)
5475      &         +ccthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k)
5476      &         +ddthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)
5477      &         +eethet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k)
5478             ethetai=ethetai+sinkt(m)*aux
5479             dethetai=dethetai+0.5d0*m*aux*coskt(m)
5480             dephii=dephii+k*sinkt(m)*(
5481      &          ccthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)-
5482      &          bbthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k))
5483             dephii1=dephii1+k*sinkt(m)*(
5484      &          eethet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)-
5485      &          ddthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k))
5486             if (lprn)
5487      &      write (iout,*) "m",m," k",k," bbthet",
5488      &         bbthet(k,m,ityp1,ityp2,ityp3,iblock)," ccthet",
5489      &         ccthet(k,m,ityp1,ityp2,ityp3,iblock)," ddthet",
5490      &         ddthet(k,m,ityp1,ityp2,ityp3,iblock)," eethet",
5491      &         eethet(k,m,ityp1,ityp2,ityp3,iblock)," ethetai",ethetai
5492           enddo
5493         enddo
5494         if (lprn)
5495      &  write(iout,*) "ethetai",ethetai
5496         do m=1,ntheterm3
5497           do k=2,ndouble
5498             do l=1,k-1
5499               aux=ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
5500      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l)+
5501      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
5502      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)
5503               ethetai=ethetai+sinkt(m)*aux
5504               dethetai=dethetai+0.5d0*m*coskt(m)*aux
5505               dephii=dephii+l*sinkt(m)*(
5506      &           -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)-
5507      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
5508      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
5509      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
5510               dephii1=dephii1+(k-l)*sinkt(m)*(
5511      &           -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
5512      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
5513      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)-
5514      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
5515               if (lprn) then
5516               write (iout,*) "m",m," k",k," l",l," ffthet",
5517      &            ffthet(l,k,m,ityp1,ityp2,ityp3,iblock),
5518      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)," ggthet",
5519      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock),
5520      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock),
5521      &            " ethetai",ethetai
5522               write (iout,*) cosph1ph2(l,k)*sinkt(m),
5523      &            cosph1ph2(k,l)*sinkt(m),
5524      &            sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
5525               endif
5526             enddo
5527           enddo
5528         enddo
5529 10      continue
5530 c        lprn1=.true.
5531         if (lprn1)
5532      &    write (iout,'(i2,3f8.1,9h ethetai ,f10.5)')
5533      &   i,theta(i)*rad2deg,phii*rad2deg,
5534      &   phii1*rad2deg,ethetai
5535 c        lprn1=.false.
5536         etheta=etheta+ethetai
5537         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
5538         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
5539         gloc(nphi+i-2,icg)=wang*dethetai+ gloc(nphi+i-2,icg)
5540       enddo
5541       return
5542       end
5543 #endif
5544 #ifdef CRYST_SC
5545 c-----------------------------------------------------------------------------
5546       subroutine esc(escloc)
5547 C Calculate the local energy of a side chain and its derivatives in the
5548 C corresponding virtual-bond valence angles THETA and the spherical angles
5549 C ALPHA and OMEGA.
5550       implicit real*8 (a-h,o-z)
5551       include 'DIMENSIONS'
5552       include 'COMMON.GEO'
5553       include 'COMMON.LOCAL'
5554       include 'COMMON.VAR'
5555       include 'COMMON.INTERACT'
5556       include 'COMMON.DERIV'
5557       include 'COMMON.CHAIN'
5558       include 'COMMON.IOUNITS'
5559       include 'COMMON.NAMES'
5560       include 'COMMON.FFIELD'
5561       include 'COMMON.CONTROL'
5562       double precision x(3),dersc(3),xemp(3),dersc0(3),dersc1(3),
5563      &     ddersc0(3),ddummy(3),xtemp(3),temp(3)
5564       common /sccalc/ time11,time12,time112,theti,it,nlobit
5565       delta=0.02d0*pi
5566       escloc=0.0D0
5567 c     write (iout,'(a)') 'ESC'
5568       do i=loc_start,loc_end
5569         it=itype(i)
5570         if (it.eq.ntyp1) cycle
5571         if (it.eq.10) goto 1
5572         nlobit=nlob(iabs(it))
5573 c       print *,'i=',i,' it=',it,' nlobit=',nlobit
5574 c       write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
5575         theti=theta(i+1)-pipol
5576         x(1)=dtan(theti)
5577         x(2)=alph(i)
5578         x(3)=omeg(i)
5579
5580         if (x(2).gt.pi-delta) then
5581           xtemp(1)=x(1)
5582           xtemp(2)=pi-delta
5583           xtemp(3)=x(3)
5584           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
5585           xtemp(2)=pi
5586           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
5587           call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),
5588      &        escloci,dersc(2))
5589           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
5590      &        ddersc0(1),dersc(1))
5591           call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),
5592      &        ddersc0(3),dersc(3))
5593           xtemp(2)=pi-delta
5594           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
5595           xtemp(2)=pi
5596           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
5597           call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,
5598      &            dersc0(2),esclocbi,dersc02)
5599           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
5600      &            dersc12,dersc01)
5601           call splinthet(x(2),0.5d0*delta,ss,ssd)
5602           dersc0(1)=dersc01
5603           dersc0(2)=dersc02
5604           dersc0(3)=0.0d0
5605           do k=1,3
5606             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
5607           enddo
5608           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
5609 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
5610 c    &             esclocbi,ss,ssd
5611           escloci=ss*escloci+(1.0d0-ss)*esclocbi
5612 c         escloci=esclocbi
5613 c         write (iout,*) escloci
5614         else if (x(2).lt.delta) then
5615           xtemp(1)=x(1)
5616           xtemp(2)=delta
5617           xtemp(3)=x(3)
5618           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
5619           xtemp(2)=0.0d0
5620           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
5621           call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),
5622      &        escloci,dersc(2))
5623           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
5624      &        ddersc0(1),dersc(1))
5625           call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),
5626      &        ddersc0(3),dersc(3))
5627           xtemp(2)=delta
5628           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
5629           xtemp(2)=0.0d0
5630           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
5631           call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,
5632      &            dersc0(2),esclocbi,dersc02)
5633           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
5634      &            dersc12,dersc01)
5635           dersc0(1)=dersc01
5636           dersc0(2)=dersc02
5637           dersc0(3)=0.0d0
5638           call splinthet(x(2),0.5d0*delta,ss,ssd)
5639           do k=1,3
5640             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
5641           enddo
5642           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
5643 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
5644 c    &             esclocbi,ss,ssd
5645           escloci=ss*escloci+(1.0d0-ss)*esclocbi
5646 c         write (iout,*) escloci
5647         else
5648           call enesc(x,escloci,dersc,ddummy,.false.)
5649         endif
5650
5651         escloc=escloc+escloci
5652         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
5653      &     'escloc',i,escloci
5654 c       write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
5655
5656         gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
5657      &   wscloc*dersc(1)
5658         gloc(ialph(i,1),icg)=wscloc*dersc(2)
5659         gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
5660     1   continue
5661       enddo
5662       return
5663       end
5664 C---------------------------------------------------------------------------
5665       subroutine enesc(x,escloci,dersc,ddersc,mixed)
5666       implicit real*8 (a-h,o-z)
5667       include 'DIMENSIONS'
5668       include 'COMMON.GEO'
5669       include 'COMMON.LOCAL'
5670       include 'COMMON.IOUNITS'
5671       common /sccalc/ time11,time12,time112,theti,it,nlobit
5672       double precision x(3),z(3),Ax(3,maxlob,-1:1),dersc(3),ddersc(3)
5673       double precision contr(maxlob,-1:1)
5674       logical mixed
5675 c       write (iout,*) 'it=',it,' nlobit=',nlobit
5676         escloc_i=0.0D0
5677         do j=1,3
5678           dersc(j)=0.0D0
5679           if (mixed) ddersc(j)=0.0d0
5680         enddo
5681         x3=x(3)
5682
5683 C Because of periodicity of the dependence of the SC energy in omega we have
5684 C to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
5685 C To avoid underflows, first compute & store the exponents.
5686
5687         do iii=-1,1
5688
5689           x(3)=x3+iii*dwapi
5690
5691           do j=1,nlobit
5692             do k=1,3
5693               z(k)=x(k)-censc(k,j,it)
5694             enddo
5695             do k=1,3
5696               Axk=0.0D0
5697               do l=1,3
5698                 Axk=Axk+gaussc(l,k,j,it)*z(l)
5699               enddo
5700               Ax(k,j,iii)=Axk
5701             enddo
5702             expfac=0.0D0
5703             do k=1,3
5704               expfac=expfac+Ax(k,j,iii)*z(k)
5705             enddo
5706             contr(j,iii)=expfac
5707           enddo ! j
5708
5709         enddo ! iii
5710
5711         x(3)=x3
5712 C As in the case of ebend, we want to avoid underflows in exponentiation and
5713 C subsequent NaNs and INFs in energy calculation.
5714 C Find the largest exponent
5715         emin=contr(1,-1)
5716         do iii=-1,1
5717           do j=1,nlobit
5718             if (emin.gt.contr(j,iii)) emin=contr(j,iii)
5719           enddo
5720         enddo
5721         emin=0.5D0*emin
5722 cd      print *,'it=',it,' emin=',emin
5723
5724 C Compute the contribution to SC energy and derivatives
5725         do iii=-1,1
5726
5727           do j=1,nlobit
5728 #ifdef OSF
5729             adexp=bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin
5730             if(adexp.ne.adexp) adexp=1.0
5731             expfac=dexp(adexp)
5732 #else
5733             expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin)
5734 #endif
5735 cd          print *,'j=',j,' expfac=',expfac
5736             escloc_i=escloc_i+expfac
5737             do k=1,3
5738               dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
5739             enddo
5740             if (mixed) then
5741               do k=1,3,2
5742                 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii)
5743      &            +gaussc(k,2,j,it))*expfac
5744               enddo
5745             endif
5746           enddo
5747
5748         enddo ! iii
5749
5750         dersc(1)=dersc(1)/cos(theti)**2
5751         ddersc(1)=ddersc(1)/cos(theti)**2
5752         ddersc(3)=ddersc(3)
5753
5754         escloci=-(dlog(escloc_i)-emin)
5755         do j=1,3
5756           dersc(j)=dersc(j)/escloc_i
5757         enddo
5758         if (mixed) then
5759           do j=1,3,2
5760             ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
5761           enddo
5762         endif
5763       return
5764       end
5765 C------------------------------------------------------------------------------
5766       subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
5767       implicit real*8 (a-h,o-z)
5768       include 'DIMENSIONS'
5769       include 'COMMON.GEO'
5770       include 'COMMON.LOCAL'
5771       include 'COMMON.IOUNITS'
5772       common /sccalc/ time11,time12,time112,theti,it,nlobit
5773       double precision x(3),z(3),Ax(3,maxlob),dersc(3)
5774       double precision contr(maxlob)
5775       logical mixed
5776
5777       escloc_i=0.0D0
5778
5779       do j=1,3
5780         dersc(j)=0.0D0
5781       enddo
5782
5783       do j=1,nlobit
5784         do k=1,2
5785           z(k)=x(k)-censc(k,j,it)
5786         enddo
5787         z(3)=dwapi
5788         do k=1,3
5789           Axk=0.0D0
5790           do l=1,3
5791             Axk=Axk+gaussc(l,k,j,it)*z(l)
5792           enddo
5793           Ax(k,j)=Axk
5794         enddo
5795         expfac=0.0D0
5796         do k=1,3
5797           expfac=expfac+Ax(k,j)*z(k)
5798         enddo
5799         contr(j)=expfac
5800       enddo ! j
5801
5802 C As in the case of ebend, we want to avoid underflows in exponentiation and
5803 C subsequent NaNs and INFs in energy calculation.
5804 C Find the largest exponent
5805       emin=contr(1)
5806       do j=1,nlobit
5807         if (emin.gt.contr(j)) emin=contr(j)
5808       enddo
5809       emin=0.5D0*emin
5810
5811 C Compute the contribution to SC energy and derivatives
5812
5813       dersc12=0.0d0
5814       do j=1,nlobit
5815         expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j)+emin)
5816         escloc_i=escloc_i+expfac
5817         do k=1,2
5818           dersc(k)=dersc(k)+Ax(k,j)*expfac
5819         enddo
5820         if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j)
5821      &            +gaussc(1,2,j,it))*expfac
5822         dersc(3)=0.0d0
5823       enddo
5824
5825       dersc(1)=dersc(1)/cos(theti)**2
5826       dersc12=dersc12/cos(theti)**2
5827       escloci=-(dlog(escloc_i)-emin)
5828       do j=1,2
5829         dersc(j)=dersc(j)/escloc_i
5830       enddo
5831       if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
5832       return
5833       end
5834 #else
5835 c----------------------------------------------------------------------------------
5836       subroutine esc(escloc)
5837 C Calculate the local energy of a side chain and its derivatives in the
5838 C corresponding virtual-bond valence angles THETA and the spherical angles
5839 C ALPHA and OMEGA derived from AM1 all-atom calculations.
5840 C added by Urszula Kozlowska. 07/11/2007
5841 C
5842       implicit real*8 (a-h,o-z)
5843       include 'DIMENSIONS'
5844       include 'COMMON.GEO'
5845       include 'COMMON.LOCAL'
5846       include 'COMMON.VAR'
5847       include 'COMMON.SCROT'
5848       include 'COMMON.INTERACT'
5849       include 'COMMON.DERIV'
5850       include 'COMMON.CHAIN'
5851       include 'COMMON.IOUNITS'
5852       include 'COMMON.NAMES'
5853       include 'COMMON.FFIELD'
5854       include 'COMMON.CONTROL'
5855       include 'COMMON.VECTORS'
5856       double precision x_prime(3),y_prime(3),z_prime(3)
5857      &    , sumene,dsc_i,dp2_i,x(65),
5858      &     xx,yy,zz,sumene1,sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6,
5859      &    de_dxx,de_dyy,de_dzz,de_dt
5860       double precision s1_t,s1_6_t,s2_t,s2_6_t
5861       double precision
5862      & dXX_Ci1(3),dYY_Ci1(3),dZZ_Ci1(3),dXX_Ci(3),
5863      & dYY_Ci(3),dZZ_Ci(3),dXX_XYZ(3),dYY_XYZ(3),dZZ_XYZ(3),
5864      & dt_dCi(3),dt_dCi1(3)
5865       common /sccalc/ time11,time12,time112,theti,it,nlobit
5866       delta=0.02d0*pi
5867       escloc=0.0D0
5868       do i=loc_start,loc_end
5869         if (itype(i).eq.ntyp1) cycle
5870         costtab(i+1) =dcos(theta(i+1))
5871         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
5872         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
5873         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
5874         cosfac2=0.5d0/(1.0d0+costtab(i+1))
5875         cosfac=dsqrt(cosfac2)
5876         sinfac2=0.5d0/(1.0d0-costtab(i+1))
5877         sinfac=dsqrt(sinfac2)
5878         it=iabs(itype(i))
5879         if (it.eq.10) goto 1
5880 c
5881 C  Compute the axes of tghe local cartesian coordinates system; store in
5882 c   x_prime, y_prime and z_prime
5883 c
5884         do j=1,3
5885           x_prime(j) = 0.00
5886           y_prime(j) = 0.00
5887           z_prime(j) = 0.00
5888         enddo
5889 C        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
5890 C     &   dc_norm(3,i+nres)
5891         do j = 1,3
5892           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
5893           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
5894         enddo
5895         do j = 1,3
5896           z_prime(j) = -uz(j,i-1)*dsign(1.0d0,dfloat(itype(i)))
5897         enddo
5898 c       write (2,*) "i",i
5899 c       write (2,*) "x_prime",(x_prime(j),j=1,3)
5900 c       write (2,*) "y_prime",(y_prime(j),j=1,3)
5901 c       write (2,*) "z_prime",(z_prime(j),j=1,3)
5902 c       write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
5903 c      & " xy",scalar(x_prime(1),y_prime(1)),
5904 c      & " xz",scalar(x_prime(1),z_prime(1)),
5905 c      & " yy",scalar(y_prime(1),y_prime(1)),
5906 c      & " yz",scalar(y_prime(1),z_prime(1)),
5907 c      & " zz",scalar(z_prime(1),z_prime(1))
5908 c
5909 C Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
5910 C to local coordinate system. Store in xx, yy, zz.
5911 c
5912         xx=0.0d0
5913         yy=0.0d0
5914         zz=0.0d0
5915         do j = 1,3
5916           xx = xx + x_prime(j)*dc_norm(j,i+nres)
5917           yy = yy + y_prime(j)*dc_norm(j,i+nres)
5918           zz = zz + z_prime(j)*dc_norm(j,i+nres)
5919         enddo
5920
5921         xxtab(i)=xx
5922         yytab(i)=yy
5923         zztab(i)=zz
5924 C
5925 C Compute the energy of the ith side cbain
5926 C
5927 c        write (2,*) "xx",xx," yy",yy," zz",zz
5928         it=iabs(itype(i))
5929         do j = 1,65
5930           x(j) = sc_parmin(j,it)
5931         enddo
5932 #ifdef CHECK_COORD
5933 Cc diagnostics - remove later
5934         xx1 = dcos(alph(2))
5935         yy1 = dsin(alph(2))*dcos(omeg(2))
5936         zz1 = -dsign(1.0,dfloat(itype(i)))*dsin(alph(2))*dsin(omeg(2))
5937         write(2,'(3f8.1,3f9.3,1x,3f9.3)')
5938      &    alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,
5939      &    xx1,yy1,zz1
5940 C,"  --- ", xx_w,yy_w,zz_w
5941 c end diagnostics
5942 #endif
5943         sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
5944      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
5945      &   + x(10)*yy*zz
5946         sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
5947      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
5948      & + x(20)*yy*zz
5949         sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
5950      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
5951      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
5952      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
5953      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
5954      &  +x(40)*xx*yy*zz
5955         sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
5956      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
5957      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
5958      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
5959      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
5960      &  +x(60)*xx*yy*zz
5961         dsc_i   = 0.743d0+x(61)
5962         dp2_i   = 1.9d0+x(62)
5963         dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5964      &          *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
5965         dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5966      &          *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
5967         s1=(1+x(63))/(0.1d0 + dscp1)
5968         s1_6=(1+x(64))/(0.1d0 + dscp1**6)
5969         s2=(1+x(65))/(0.1d0 + dscp2)
5970         s2_6=(1+x(65))/(0.1d0 + dscp2**6)
5971         sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6)
5972      & + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
5973 c        write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
5974 c     &   sumene4,
5975 c     &   dscp1,dscp2,sumene
5976 c        sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5977         escloc = escloc + sumene
5978 c        write (2,*) "i",i," escloc",sumene,escloc,it,itype(i)
5979 c     & ,zz,xx,yy
5980 c#define DEBUG
5981 #ifdef DEBUG
5982 C
5983 C This section to check the numerical derivatives of the energy of ith side
5984 C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
5985 C #define DEBUG in the code to turn it on.
5986 C
5987         write (2,*) "sumene               =",sumene
5988         aincr=1.0d-7
5989         xxsave=xx
5990         xx=xx+aincr
5991         write (2,*) xx,yy,zz
5992         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5993         de_dxx_num=(sumenep-sumene)/aincr
5994         xx=xxsave
5995         write (2,*) "xx+ sumene from enesc=",sumenep
5996         yysave=yy
5997         yy=yy+aincr
5998         write (2,*) xx,yy,zz
5999         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6000         de_dyy_num=(sumenep-sumene)/aincr
6001         yy=yysave
6002         write (2,*) "yy+ sumene from enesc=",sumenep
6003         zzsave=zz
6004         zz=zz+aincr
6005         write (2,*) xx,yy,zz
6006         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6007         de_dzz_num=(sumenep-sumene)/aincr
6008         zz=zzsave
6009         write (2,*) "zz+ sumene from enesc=",sumenep
6010         costsave=cost2tab(i+1)
6011         sintsave=sint2tab(i+1)
6012         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
6013         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
6014         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6015         de_dt_num=(sumenep-sumene)/aincr
6016         write (2,*) " t+ sumene from enesc=",sumenep
6017         cost2tab(i+1)=costsave
6018         sint2tab(i+1)=sintsave
6019 C End of diagnostics section.
6020 #endif
6021 C
6022 C Compute the gradient of esc
6023 C
6024 c        zz=zz*dsign(1.0,dfloat(itype(i)))
6025         pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
6026         pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
6027         pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
6028         pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
6029         pom_dx=dsc_i*dp2_i*cost2tab(i+1)
6030         pom_dy=dsc_i*dp2_i*sint2tab(i+1)
6031         pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
6032         pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
6033         pom1=(sumene3*sint2tab(i+1)+sumene1)
6034      &     *(pom_s1/dscp1+pom_s16*dscp1**4)
6035         pom2=(sumene4*cost2tab(i+1)+sumene2)
6036      &     *(pom_s2/dscp2+pom_s26*dscp2**4)
6037         sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
6038         sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2
6039      &  +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2)
6040      &  +x(40)*yy*zz
6041         sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
6042         sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2
6043      &  +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2)
6044      &  +x(60)*yy*zz
6045         de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6)
6046      &        +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6)
6047      &        +(pom1+pom2)*pom_dx
6048 #ifdef DEBUG
6049         write(2,*), "de_dxx = ", de_dxx,de_dxx_num,itype(i)
6050 #endif
6051 C
6052         sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
6053         sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2
6054      &  +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2)
6055      &  +x(40)*xx*zz
6056         sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
6057         sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz
6058      &  +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz
6059      &  +x(59)*zz**2 +x(60)*xx*zz
6060         de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6)
6061      &        +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6)
6062      &        +(pom1-pom2)*pom_dy
6063 #ifdef DEBUG
6064         write(2,*), "de_dyy = ", de_dyy,de_dyy_num,itype(i)
6065 #endif
6066 C
6067         de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy
6068      &  +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx
6069      &  +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6)
6070      &  +(x(4) + 2*x(7)*zz+  x(8)*xx + x(10)*yy)*(s1+s1_6)
6071      &  +(x(44)+2*x(47)*zz +x(48)*xx   +x(50)*yy  +3*x(53)*zz**2
6072      &  +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy
6073      &  +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6)
6074      &  + ( x(14) + 2*x(17)*zz+  x(18)*xx + x(20)*yy)*(s2+s2_6)
6075 #ifdef DEBUG
6076         write(2,*), "de_dzz = ", de_dzz,de_dzz_num,itype(i)
6077 #endif
6078 C
6079         de_dt =  0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6)
6080      &  -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6)
6081      &  +pom1*pom_dt1+pom2*pom_dt2
6082 #ifdef DEBUG
6083         write(2,*), "de_dt = ", de_dt,de_dt_num,itype(i)
6084 #endif
6085 c#undef DEBUG
6086 c
6087 C
6088        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
6089        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
6090        cosfac2xx=cosfac2*xx
6091        sinfac2yy=sinfac2*yy
6092        do k = 1,3
6093          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))*
6094      &      vbld_inv(i+1)
6095          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))*
6096      &      vbld_inv(i)
6097          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
6098          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
6099 c         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
6100 c     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
6101 c         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
6102 c     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
6103          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
6104          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
6105          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
6106          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
6107          dZZ_Ci1(k)=0.0d0
6108          dZZ_Ci(k)=0.0d0
6109          do j=1,3
6110            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)
6111      &     *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
6112            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)
6113      &     *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
6114          enddo
6115
6116          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
6117          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
6118          dZZ_XYZ(k)=vbld_inv(i+nres)*
6119      &   (z_prime(k)-zz*dC_norm(k,i+nres))
6120 c
6121          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
6122          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
6123        enddo
6124
6125        do k=1,3
6126          dXX_Ctab(k,i)=dXX_Ci(k)
6127          dXX_C1tab(k,i)=dXX_Ci1(k)
6128          dYY_Ctab(k,i)=dYY_Ci(k)
6129          dYY_C1tab(k,i)=dYY_Ci1(k)
6130          dZZ_Ctab(k,i)=dZZ_Ci(k)
6131          dZZ_C1tab(k,i)=dZZ_Ci1(k)
6132          dXX_XYZtab(k,i)=dXX_XYZ(k)
6133          dYY_XYZtab(k,i)=dYY_XYZ(k)
6134          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
6135        enddo
6136
6137        do k = 1,3
6138 c         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
6139 c     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
6140 c         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
6141 c     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
6142 c         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
6143 c     &    dt_dci(k)
6144 c         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
6145 c     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
6146          gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k)
6147      &    +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
6148          gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k)
6149      &    +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
6150          gsclocx(k,i)=                 de_dxx*dxx_XYZ(k)
6151      &    +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
6152        enddo
6153 c       write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
6154 c     &  (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
6155
6156 C to check gradient call subroutine check_grad
6157
6158     1 continue
6159       enddo
6160       return
6161       end
6162 c------------------------------------------------------------------------------
6163       double precision function enesc(x,xx,yy,zz,cost2,sint2)
6164       implicit none
6165       double precision x(65),xx,yy,zz,cost2,sint2,sumene1,sumene2,
6166      & sumene3,sumene4,sumene,dsc_i,dp2_i,dscp1,dscp2,s1,s1_6,s2,s2_6
6167       sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
6168      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
6169      &   + x(10)*yy*zz
6170       sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
6171      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
6172      & + x(20)*yy*zz
6173       sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
6174      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
6175      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
6176      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
6177      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
6178      &  +x(40)*xx*yy*zz
6179       sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
6180      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
6181      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
6182      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
6183      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
6184      &  +x(60)*xx*yy*zz
6185       dsc_i   = 0.743d0+x(61)
6186       dp2_i   = 1.9d0+x(62)
6187       dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
6188      &          *(xx*cost2+yy*sint2))
6189       dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
6190      &          *(xx*cost2-yy*sint2))
6191       s1=(1+x(63))/(0.1d0 + dscp1)
6192       s1_6=(1+x(64))/(0.1d0 + dscp1**6)
6193       s2=(1+x(65))/(0.1d0 + dscp2)
6194       s2_6=(1+x(65))/(0.1d0 + dscp2**6)
6195       sumene = ( sumene3*sint2 + sumene1)*(s1+s1_6)
6196      & + (sumene4*cost2 +sumene2)*(s2+s2_6)
6197       enesc=sumene
6198       return
6199       end
6200 #endif
6201 c------------------------------------------------------------------------------
6202       subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
6203 C
6204 C This procedure calculates two-body contact function g(rij) and its derivative:
6205 C
6206 C           eps0ij                                     !       x < -1
6207 C g(rij) =  esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5)  ! -1 =< x =< 1
6208 C            0                                         !       x > 1
6209 C
6210 C where x=(rij-r0ij)/delta
6211 C
6212 C rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
6213 C
6214       implicit none
6215       double precision rij,r0ij,eps0ij,fcont,fprimcont
6216       double precision x,x2,x4,delta
6217 c     delta=0.02D0*r0ij
6218 c      delta=0.2D0*r0ij
6219       x=(rij-r0ij)/delta
6220       if (x.lt.-1.0D0) then
6221         fcont=eps0ij
6222         fprimcont=0.0D0
6223       else if (x.le.1.0D0) then
6224         x2=x*x
6225         x4=x2*x2
6226         fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
6227         fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
6228       else
6229         fcont=0.0D0
6230         fprimcont=0.0D0
6231       endif
6232       return
6233       end
6234 c------------------------------------------------------------------------------
6235       subroutine splinthet(theti,delta,ss,ssder)
6236       implicit real*8 (a-h,o-z)
6237       include 'DIMENSIONS'
6238       include 'COMMON.VAR'
6239       include 'COMMON.GEO'
6240       thetup=pi-delta
6241       thetlow=delta
6242       if (theti.gt.pipol) then
6243         call gcont(theti,thetup,1.0d0,delta,ss,ssder)
6244       else
6245         call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
6246         ssder=-ssder
6247       endif
6248       return
6249       end
6250 c------------------------------------------------------------------------------
6251       subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
6252       implicit none
6253       double precision x,x0,delta,f0,f1,fprim0,f,fprim
6254       double precision ksi,ksi2,ksi3,a1,a2,a3
6255       a1=fprim0*delta/(f1-f0)
6256       a2=3.0d0-2.0d0*a1
6257       a3=a1-2.0d0
6258       ksi=(x-x0)/delta
6259       ksi2=ksi*ksi
6260       ksi3=ksi2*ksi
6261       f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
6262       fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
6263       return
6264       end
6265 c------------------------------------------------------------------------------
6266       subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
6267       implicit none
6268       double precision x,x0,delta,f0x,f1x,fprim0x,fx
6269       double precision ksi,ksi2,ksi3,a1,a2,a3
6270       ksi=(x-x0)/delta
6271       ksi2=ksi*ksi
6272       ksi3=ksi2*ksi
6273       a1=fprim0x*delta
6274       a2=3*(f1x-f0x)-2*fprim0x*delta
6275       a3=fprim0x*delta-2*(f1x-f0x)
6276       fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
6277       return
6278       end
6279 C-----------------------------------------------------------------------------
6280 #ifdef CRYST_TOR
6281 C-----------------------------------------------------------------------------
6282       subroutine etor(etors,edihcnstr)
6283       implicit real*8 (a-h,o-z)
6284       include 'DIMENSIONS'
6285       include 'COMMON.VAR'
6286       include 'COMMON.GEO'
6287       include 'COMMON.LOCAL'
6288       include 'COMMON.TORSION'
6289       include 'COMMON.INTERACT'
6290       include 'COMMON.DERIV'
6291       include 'COMMON.CHAIN'
6292       include 'COMMON.NAMES'
6293       include 'COMMON.IOUNITS'
6294       include 'COMMON.FFIELD'
6295       include 'COMMON.TORCNSTR'
6296       include 'COMMON.CONTROL'
6297       logical lprn
6298 C Set lprn=.true. for debugging
6299       lprn=.false.
6300 c      lprn=.true.
6301       etors=0.0D0
6302       do i=iphi_start,iphi_end
6303       etors_ii=0.0D0
6304         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
6305      &      .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
6306         itori=itortyp(itype(i-2))
6307         itori1=itortyp(itype(i-1))
6308         phii=phi(i)
6309         gloci=0.0D0
6310 C Proline-Proline pair is a special case...
6311         if (itori.eq.3 .and. itori1.eq.3) then
6312           if (phii.gt.-dwapi3) then
6313             cosphi=dcos(3*phii)
6314             fac=1.0D0/(1.0D0-cosphi)
6315             etorsi=v1(1,3,3)*fac
6316             etorsi=etorsi+etorsi
6317             etors=etors+etorsi-v1(1,3,3)
6318             if (energy_dec) etors_ii=etors_ii+etorsi-v1(1,3,3)
6319             gloci=gloci-3*fac*etorsi*dsin(3*phii)
6320           endif
6321           do j=1,3
6322             v1ij=v1(j+1,itori,itori1)
6323             v2ij=v2(j+1,itori,itori1)
6324             cosphi=dcos(j*phii)
6325             sinphi=dsin(j*phii)
6326             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
6327             if (energy_dec) etors_ii=etors_ii+
6328      &                              v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
6329             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
6330           enddo
6331         else
6332           do j=1,nterm_old
6333             v1ij=v1(j,itori,itori1)
6334             v2ij=v2(j,itori,itori1)
6335             cosphi=dcos(j*phii)
6336             sinphi=dsin(j*phii)
6337             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
6338             if (energy_dec) etors_ii=etors_ii+
6339      &                  v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
6340             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
6341           enddo
6342         endif
6343         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
6344              'etor',i,etors_ii
6345         if (lprn)
6346      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
6347      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
6348      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
6349         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
6350 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
6351       enddo
6352 ! 6/20/98 - dihedral angle constraints
6353       edihcnstr=0.0d0
6354       do i=1,ndih_constr
6355         itori=idih_constr(i)
6356         phii=phi(itori)
6357         difi=phii-phi0(i)
6358         if (difi.gt.drange(i)) then
6359           difi=difi-drange(i)
6360           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
6361           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
6362         else if (difi.lt.-drange(i)) then
6363           difi=difi+drange(i)
6364           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
6365           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
6366         endif
6367 !        write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii,
6368 !     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
6369       enddo
6370 !      write (iout,*) 'edihcnstr',edihcnstr
6371       return
6372       end
6373 c------------------------------------------------------------------------------
6374       subroutine etor_d(etors_d)
6375       etors_d=0.0d0
6376       return
6377       end
6378 c----------------------------------------------------------------------------
6379 #else
6380       subroutine etor(etors,edihcnstr)
6381       implicit real*8 (a-h,o-z)
6382       include 'DIMENSIONS'
6383       include 'COMMON.VAR'
6384       include 'COMMON.GEO'
6385       include 'COMMON.LOCAL'
6386       include 'COMMON.TORSION'
6387       include 'COMMON.INTERACT'
6388       include 'COMMON.DERIV'
6389       include 'COMMON.CHAIN'
6390       include 'COMMON.NAMES'
6391       include 'COMMON.IOUNITS'
6392       include 'COMMON.FFIELD'
6393       include 'COMMON.TORCNSTR'
6394       include 'COMMON.CONTROL'
6395       logical lprn
6396 C Set lprn=.true. for debugging
6397       lprn=.false.
6398 c     lprn=.true.
6399       etors=0.0D0
6400       do i=iphi_start,iphi_end
6401 C ANY TWO ARE DUMMY ATOMS in row CYCLE
6402 c        if (((itype(i-3).eq.ntyp1).and.(itype(i-2).eq.ntyp1)).or.
6403 c     &      ((itype(i-2).eq.ntyp1).and.(itype(i-1).eq.ntyp1))  .or.
6404 c     &      ((itype(i-1).eq.ntyp1).and.(itype(i).eq.ntyp1))) cycle
6405         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
6406      &      .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
6407 C In current verion the ALL DUMMY ATOM POTENTIALS ARE OFF
6408 C For introducing the NH3+ and COO- group please check the etor_d for reference
6409 C and guidance
6410         etors_ii=0.0D0
6411          if (iabs(itype(i)).eq.20) then
6412          iblock=2
6413          else
6414          iblock=1
6415          endif
6416         itori=itortyp(itype(i-2))
6417         itori1=itortyp(itype(i-1))
6418         phii=phi(i)
6419         gloci=0.0D0
6420 C Regular cosine and sine terms
6421         do j=1,nterm(itori,itori1,iblock)
6422           v1ij=v1(j,itori,itori1,iblock)
6423           v2ij=v2(j,itori,itori1,iblock)
6424           cosphi=dcos(j*phii)
6425           sinphi=dsin(j*phii)
6426           etors=etors+v1ij*cosphi+v2ij*sinphi
6427           if (energy_dec) etors_ii=etors_ii+
6428      &                v1ij*cosphi+v2ij*sinphi
6429           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
6430         enddo
6431 C Lorentz terms
6432 C                         v1
6433 C  E = SUM ----------------------------------- - v1
6434 C          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
6435 C
6436         cosphi=dcos(0.5d0*phii)
6437         sinphi=dsin(0.5d0*phii)
6438         do j=1,nlor(itori,itori1,iblock)
6439           vl1ij=vlor1(j,itori,itori1)
6440           vl2ij=vlor2(j,itori,itori1)
6441           vl3ij=vlor3(j,itori,itori1)
6442           pom=vl2ij*cosphi+vl3ij*sinphi
6443           pom1=1.0d0/(pom*pom+1.0d0)
6444           etors=etors+vl1ij*pom1
6445           if (energy_dec) etors_ii=etors_ii+
6446      &                vl1ij*pom1
6447           pom=-pom*pom1*pom1
6448           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
6449         enddo
6450 C Subtract the constant term
6451         etors=etors-v0(itori,itori1,iblock)
6452           if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
6453      &         'etor',i,etors_ii-v0(itori,itori1,iblock)
6454         if (lprn)
6455      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
6456      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
6457      &  (v1(j,itori,itori1,iblock),j=1,6),
6458      &  (v2(j,itori,itori1,iblock),j=1,6)
6459         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
6460 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
6461       enddo
6462 ! 6/20/98 - dihedral angle constraints
6463       edihcnstr=0.0d0
6464 c      do i=1,ndih_constr
6465       do i=idihconstr_start,idihconstr_end
6466         itori=idih_constr(i)
6467         phii=phi(itori)
6468         difi=pinorm(phii-phi0(i))
6469         if (difi.gt.drange(i)) then
6470           difi=difi-drange(i)
6471           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
6472           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
6473         else if (difi.lt.-drange(i)) then
6474           difi=difi+drange(i)
6475           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
6476           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
6477         else
6478           difi=0.0
6479         endif
6480 cd        write (iout,'(2i5,4f8.3,2e14.5)') i,itori,rad2deg*phii,
6481 cd     &    rad2deg*phi0(i),  rad2deg*drange(i),
6482 cd     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
6483       enddo
6484 cd       write (iout,*) 'edihcnstr',edihcnstr
6485       return
6486       end
6487 c----------------------------------------------------------------------------
6488       subroutine etor_d(etors_d)
6489 C 6/23/01 Compute double torsional energy
6490       implicit real*8 (a-h,o-z)
6491       include 'DIMENSIONS'
6492       include 'COMMON.VAR'
6493       include 'COMMON.GEO'
6494       include 'COMMON.LOCAL'
6495       include 'COMMON.TORSION'
6496       include 'COMMON.INTERACT'
6497       include 'COMMON.DERIV'
6498       include 'COMMON.CHAIN'
6499       include 'COMMON.NAMES'
6500       include 'COMMON.IOUNITS'
6501       include 'COMMON.FFIELD'
6502       include 'COMMON.TORCNSTR'
6503       logical lprn
6504 C Set lprn=.true. for debugging
6505       lprn=.false.
6506 c     lprn=.true.
6507       etors_d=0.0D0
6508 c      write(iout,*) "a tu??"
6509       do i=iphid_start,iphid_end
6510 C ANY TWO ARE DUMMY ATOMS in row CYCLE
6511 C        if (((itype(i-3).eq.ntyp1).and.(itype(i-2).eq.ntyp1)).or.
6512 C     &      ((itype(i-2).eq.ntyp1).and.(itype(i-1).eq.ntyp1)).or.
6513 C     &      ((itype(i-1).eq.ntyp1).and.(itype(i).eq.ntyp1))  .or.
6514 C     &      ((itype(i).eq.ntyp1).and.(itype(i+1).eq.ntyp1))) cycle
6515          if ((itype(i-2).eq.ntyp1).or.itype(i-3).eq.ntyp1.or.
6516      &  (itype(i-1).eq.ntyp1).or.(itype(i).eq.ntyp1).or.
6517      &  (itype(i+1).eq.ntyp1)) cycle
6518 C In current verion the ALL DUMMY ATOM POTENTIALS ARE OFF
6519         itori=itortyp(itype(i-2))
6520         itori1=itortyp(itype(i-1))
6521         itori2=itortyp(itype(i))
6522         phii=phi(i)
6523         phii1=phi(i+1)
6524         gloci1=0.0D0
6525         gloci2=0.0D0
6526         iblock=1
6527         if (iabs(itype(i+1)).eq.20) iblock=2
6528 C Iblock=2 Proline type
6529 C ADASKO: WHEN PARAMETERS FOR THIS TYPE OF BLOCKING GROUP IS READY UNCOMMENT
6530 C CHECK WEATHER THERE IS NECCESITY FOR iblock=3 for COO-
6531 C        if (itype(i+1).eq.ntyp1) iblock=3
6532 C The problem of NH3+ group can be resolved by adding new parameters please note if there
6533 C IS or IS NOT need for this
6534 C IF Yes uncomment below and add to parmread.F appropriate changes and to v1cij and so on
6535 C        is (itype(i-3).eq.ntyp1) ntblock=2
6536 C        ntblock is N-terminal blocking group
6537
6538 C Regular cosine and sine terms
6539         do j=1,ntermd_1(itori,itori1,itori2,iblock)
6540 C Example of changes for NH3+ blocking group
6541 C       do j=1,ntermd_1(itori,itori1,itori2,iblock,ntblock)
6542 C          v1cij=v1c(1,j,itori,itori1,itori2,iblock,ntblock)
6543           v1cij=v1c(1,j,itori,itori1,itori2,iblock)
6544           v1sij=v1s(1,j,itori,itori1,itori2,iblock)
6545           v2cij=v1c(2,j,itori,itori1,itori2,iblock)
6546           v2sij=v1s(2,j,itori,itori1,itori2,iblock)
6547           cosphi1=dcos(j*phii)
6548           sinphi1=dsin(j*phii)
6549           cosphi2=dcos(j*phii1)
6550           sinphi2=dsin(j*phii1)
6551           etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+
6552      &     v2cij*cosphi2+v2sij*sinphi2
6553           gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
6554           gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
6555         enddo
6556         do k=2,ntermd_2(itori,itori1,itori2,iblock)
6557           do l=1,k-1
6558             v1cdij = v2c(k,l,itori,itori1,itori2,iblock)
6559             v2cdij = v2c(l,k,itori,itori1,itori2,iblock)
6560             v1sdij = v2s(k,l,itori,itori1,itori2,iblock)
6561             v2sdij = v2s(l,k,itori,itori1,itori2,iblock)
6562             cosphi1p2=dcos(l*phii+(k-l)*phii1)
6563             cosphi1m2=dcos(l*phii-(k-l)*phii1)
6564             sinphi1p2=dsin(l*phii+(k-l)*phii1)
6565             sinphi1m2=dsin(l*phii-(k-l)*phii1)
6566             etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+
6567      &        v1sdij*sinphi1p2+v2sdij*sinphi1m2
6568             gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2
6569      &        -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
6570             gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2
6571      &        -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
6572           enddo
6573         enddo
6574         gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*gloci1
6575         gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*gloci2
6576       enddo
6577       return
6578       end
6579 #endif
6580 c------------------------------------------------------------------------------
6581       subroutine eback_sc_corr(esccor)
6582 c 7/21/2007 Correlations between the backbone-local and side-chain-local
6583 c        conformational states; temporarily implemented as differences
6584 c        between UNRES torsional potentials (dependent on three types of
6585 c        residues) and the torsional potentials dependent on all 20 types
6586 c        of residues computed from AM1  energy surfaces of terminally-blocked
6587 c        amino-acid residues.
6588       implicit real*8 (a-h,o-z)
6589       include 'DIMENSIONS'
6590       include 'COMMON.VAR'
6591       include 'COMMON.GEO'
6592       include 'COMMON.LOCAL'
6593       include 'COMMON.TORSION'
6594       include 'COMMON.SCCOR'
6595       include 'COMMON.INTERACT'
6596       include 'COMMON.DERIV'
6597       include 'COMMON.CHAIN'
6598       include 'COMMON.NAMES'
6599       include 'COMMON.IOUNITS'
6600       include 'COMMON.FFIELD'
6601       include 'COMMON.CONTROL'
6602       logical lprn
6603 C Set lprn=.true. for debugging
6604       lprn=.false.
6605 c      lprn=.true.
6606 c      write (iout,*) "EBACK_SC_COR",itau_start,itau_end
6607       esccor=0.0D0
6608       do i=itau_start,itau_end
6609         if ((itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)) cycle
6610         esccor_ii=0.0D0
6611         isccori=isccortyp(itype(i-2))
6612         isccori1=isccortyp(itype(i-1))
6613 c      write (iout,*) "EBACK_SC_COR",i,nterm_sccor(isccori,isccori1)
6614         phii=phi(i)
6615         do intertyp=1,3 !intertyp
6616 cc Added 09 May 2012 (Adasko)
6617 cc  Intertyp means interaction type of backbone mainchain correlation:
6618 c   1 = SC...Ca...Ca...Ca
6619 c   2 = Ca...Ca...Ca...SC
6620 c   3 = SC...Ca...Ca...SCi
6621         gloci=0.0D0
6622         if (((intertyp.eq.3).and.((itype(i-2).eq.10).or.
6623      &      (itype(i-1).eq.10).or.(itype(i-2).eq.ntyp1).or.
6624      &      (itype(i-1).eq.ntyp1)))
6625      &    .or. ((intertyp.eq.1).and.((itype(i-2).eq.10)
6626      &     .or.(itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)
6627      &     .or.(itype(i).eq.ntyp1)))
6628      &    .or.((intertyp.eq.2).and.((itype(i-1).eq.10).or.
6629      &      (itype(i-1).eq.ntyp1).or.(itype(i-2).eq.ntyp1).or.
6630      &      (itype(i-3).eq.ntyp1)))) cycle
6631         if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1).eq.ntyp1)) cycle
6632         if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres).eq.ntyp1))
6633      & cycle
6634        do j=1,nterm_sccor(isccori,isccori1)
6635           v1ij=v1sccor(j,intertyp,isccori,isccori1)
6636           v2ij=v2sccor(j,intertyp,isccori,isccori1)
6637           cosphi=dcos(j*tauangle(intertyp,i))
6638           sinphi=dsin(j*tauangle(intertyp,i))
6639           esccor=esccor+v1ij*cosphi+v2ij*sinphi
6640           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
6641         enddo
6642 c      write (iout,*) "EBACK_SC_COR",i,v1ij*cosphi+v2ij*sinphi,intertyp
6643         gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci
6644         if (lprn)
6645      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
6646      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,isccori,isccori1,
6647      &  (v1sccor(j,intertyp,isccori,isccori1),j=1,6)
6648      & ,(v2sccor(j,intertyp,isccori,isccori1),j=1,6)
6649         gsccor_loc(i-3)=gsccor_loc(i-3)+gloci
6650        enddo !intertyp
6651       enddo
6652
6653       return
6654       end
6655 c----------------------------------------------------------------------------
6656       subroutine multibody(ecorr)
6657 C This subroutine calculates multi-body contributions to energy following
6658 C the idea of Skolnick et al. If side chains I and J make a contact and
6659 C at the same time side chains I+1 and J+1 make a contact, an extra
6660 C contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
6661       implicit real*8 (a-h,o-z)
6662       include 'DIMENSIONS'
6663       include 'COMMON.IOUNITS'
6664       include 'COMMON.DERIV'
6665       include 'COMMON.INTERACT'
6666       include 'COMMON.CONTACTS'
6667       double precision gx(3),gx1(3)
6668       logical lprn
6669
6670 C Set lprn=.true. for debugging
6671       lprn=.false.
6672
6673       if (lprn) then
6674         write (iout,'(a)') 'Contact function values:'
6675         do i=nnt,nct-2
6676           write (iout,'(i2,20(1x,i2,f10.5))')
6677      &        i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
6678         enddo
6679       endif
6680       ecorr=0.0D0
6681       do i=nnt,nct
6682         do j=1,3
6683           gradcorr(j,i)=0.0D0
6684           gradxorr(j,i)=0.0D0
6685         enddo
6686       enddo
6687       do i=nnt,nct-2
6688
6689         DO ISHIFT = 3,4
6690
6691         i1=i+ishift
6692         num_conti=num_cont(i)
6693         num_conti1=num_cont(i1)
6694         do jj=1,num_conti
6695           j=jcont(jj,i)
6696           do kk=1,num_conti1
6697             j1=jcont(kk,i1)
6698             if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
6699 cd          write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6700 cd   &                   ' ishift=',ishift
6701 C Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
6702 C The system gains extra energy.
6703               ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
6704             endif   ! j1==j+-ishift
6705           enddo     ! kk
6706         enddo       ! jj
6707
6708         ENDDO ! ISHIFT
6709
6710       enddo         ! i
6711       return
6712       end
6713 c------------------------------------------------------------------------------
6714       double precision function esccorr(i,j,k,l,jj,kk)
6715       implicit real*8 (a-h,o-z)
6716       include 'DIMENSIONS'
6717       include 'COMMON.IOUNITS'
6718       include 'COMMON.DERIV'
6719       include 'COMMON.INTERACT'
6720       include 'COMMON.CONTACTS'
6721       double precision gx(3),gx1(3)
6722       logical lprn
6723       lprn=.false.
6724       eij=facont(jj,i)
6725       ekl=facont(kk,k)
6726 cd    write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
6727 C Calculate the multi-body contribution to energy.
6728 C Calculate multi-body contributions to the gradient.
6729 cd    write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
6730 cd   & k,l,(gacont(m,kk,k),m=1,3)
6731       do m=1,3
6732         gx(m) =ekl*gacont(m,jj,i)
6733         gx1(m)=eij*gacont(m,kk,k)
6734         gradxorr(m,i)=gradxorr(m,i)-gx(m)
6735         gradxorr(m,j)=gradxorr(m,j)+gx(m)
6736         gradxorr(m,k)=gradxorr(m,k)-gx1(m)
6737         gradxorr(m,l)=gradxorr(m,l)+gx1(m)
6738       enddo
6739       do m=i,j-1
6740         do ll=1,3
6741           gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
6742         enddo
6743       enddo
6744       do m=k,l-1
6745         do ll=1,3
6746           gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
6747         enddo
6748       enddo
6749       esccorr=-eij*ekl
6750       return
6751       end
6752 c------------------------------------------------------------------------------
6753       subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
6754 C This subroutine calculates multi-body contributions to hydrogen-bonding
6755       implicit real*8 (a-h,o-z)
6756       include 'DIMENSIONS'
6757       include 'COMMON.IOUNITS'
6758 #ifdef MPI
6759       include "mpif.h"
6760       parameter (max_cont=maxconts)
6761       parameter (max_dim=26)
6762       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
6763       double precision zapas(max_dim,maxconts,max_fg_procs),
6764      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6765       common /przechowalnia/ zapas
6766       integer status(MPI_STATUS_SIZE),req(maxconts*2),
6767      &  status_array(MPI_STATUS_SIZE,maxconts*2)
6768 #endif
6769       include 'COMMON.SETUP'
6770       include 'COMMON.FFIELD'
6771       include 'COMMON.DERIV'
6772       include 'COMMON.INTERACT'
6773       include 'COMMON.CONTACTS'
6774       include 'COMMON.CONTROL'
6775       include 'COMMON.LOCAL'
6776       double precision gx(3),gx1(3),time00
6777       logical lprn,ldone
6778
6779 C Set lprn=.true. for debugging
6780       lprn=.false.
6781 #ifdef MPI
6782       n_corr=0
6783       n_corr1=0
6784       if (nfgtasks.le.1) goto 30
6785       if (lprn) then
6786         write (iout,'(a)') 'Contact function values before RECEIVE:'
6787         do i=nnt,nct-2
6788           write (iout,'(2i3,50(1x,i2,f5.2))')
6789      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6790      &    j=1,num_cont_hb(i))
6791         enddo
6792       endif
6793       call flush(iout)
6794       do i=1,ntask_cont_from
6795         ncont_recv(i)=0
6796       enddo
6797       do i=1,ntask_cont_to
6798         ncont_sent(i)=0
6799       enddo
6800 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
6801 c     & ntask_cont_to
6802 C Make the list of contacts to send to send to other procesors
6803 c      write (iout,*) "limits",max0(iturn4_end-1,iatel_s),iturn3_end
6804 c      call flush(iout)
6805       do i=iturn3_start,iturn3_end
6806 c        write (iout,*) "make contact list turn3",i," num_cont",
6807 c     &    num_cont_hb(i)
6808         call add_hb_contact(i,i+2,iturn3_sent_local(1,i))
6809       enddo
6810       do i=iturn4_start,iturn4_end
6811 c        write (iout,*) "make contact list turn4",i," num_cont",
6812 c     &   num_cont_hb(i)
6813         call add_hb_contact(i,i+3,iturn4_sent_local(1,i))
6814       enddo
6815       do ii=1,nat_sent
6816         i=iat_sent(ii)
6817 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
6818 c     &    num_cont_hb(i)
6819         do j=1,num_cont_hb(i)
6820         do k=1,4
6821           jjc=jcont_hb(j,i)
6822           iproc=iint_sent_local(k,jjc,ii)
6823 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
6824           if (iproc.gt.0) then
6825             ncont_sent(iproc)=ncont_sent(iproc)+1
6826             nn=ncont_sent(iproc)
6827             zapas(1,nn,iproc)=i
6828             zapas(2,nn,iproc)=jjc
6829             zapas(3,nn,iproc)=facont_hb(j,i)
6830             zapas(4,nn,iproc)=ees0p(j,i)
6831             zapas(5,nn,iproc)=ees0m(j,i)
6832             zapas(6,nn,iproc)=gacont_hbr(1,j,i)
6833             zapas(7,nn,iproc)=gacont_hbr(2,j,i)
6834             zapas(8,nn,iproc)=gacont_hbr(3,j,i)
6835             zapas(9,nn,iproc)=gacontm_hb1(1,j,i)
6836             zapas(10,nn,iproc)=gacontm_hb1(2,j,i)
6837             zapas(11,nn,iproc)=gacontm_hb1(3,j,i)
6838             zapas(12,nn,iproc)=gacontp_hb1(1,j,i)
6839             zapas(13,nn,iproc)=gacontp_hb1(2,j,i)
6840             zapas(14,nn,iproc)=gacontp_hb1(3,j,i)
6841             zapas(15,nn,iproc)=gacontm_hb2(1,j,i)
6842             zapas(16,nn,iproc)=gacontm_hb2(2,j,i)
6843             zapas(17,nn,iproc)=gacontm_hb2(3,j,i)
6844             zapas(18,nn,iproc)=gacontp_hb2(1,j,i)
6845             zapas(19,nn,iproc)=gacontp_hb2(2,j,i)
6846             zapas(20,nn,iproc)=gacontp_hb2(3,j,i)
6847             zapas(21,nn,iproc)=gacontm_hb3(1,j,i)
6848             zapas(22,nn,iproc)=gacontm_hb3(2,j,i)
6849             zapas(23,nn,iproc)=gacontm_hb3(3,j,i)
6850             zapas(24,nn,iproc)=gacontp_hb3(1,j,i)
6851             zapas(25,nn,iproc)=gacontp_hb3(2,j,i)
6852             zapas(26,nn,iproc)=gacontp_hb3(3,j,i)
6853           endif
6854         enddo
6855         enddo
6856       enddo
6857       if (lprn) then
6858       write (iout,*)
6859      &  "Numbers of contacts to be sent to other processors",
6860      &  (ncont_sent(i),i=1,ntask_cont_to)
6861       write (iout,*) "Contacts sent"
6862       do ii=1,ntask_cont_to
6863         nn=ncont_sent(ii)
6864         iproc=itask_cont_to(ii)
6865         write (iout,*) nn," contacts to processor",iproc,
6866      &   " of CONT_TO_COMM group"
6867         do i=1,nn
6868           write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
6869         enddo
6870       enddo
6871       call flush(iout)
6872       endif
6873       CorrelType=477
6874       CorrelID=fg_rank+1
6875       CorrelType1=478
6876       CorrelID1=nfgtasks+fg_rank+1
6877       ireq=0
6878 C Receive the numbers of needed contacts from other processors
6879       do ii=1,ntask_cont_from
6880         iproc=itask_cont_from(ii)
6881         ireq=ireq+1
6882         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
6883      &    FG_COMM,req(ireq),IERR)
6884       enddo
6885 c      write (iout,*) "IRECV ended"
6886 c      call flush(iout)
6887 C Send the number of contacts needed by other processors
6888       do ii=1,ntask_cont_to
6889         iproc=itask_cont_to(ii)
6890         ireq=ireq+1
6891         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
6892      &    FG_COMM,req(ireq),IERR)
6893       enddo
6894 c      write (iout,*) "ISEND ended"
6895 c      write (iout,*) "number of requests (nn)",ireq
6896       call flush(iout)
6897       if (ireq.gt.0)
6898      &  call MPI_Waitall(ireq,req,status_array,ierr)
6899 c      write (iout,*)
6900 c     &  "Numbers of contacts to be received from other processors",
6901 c     &  (ncont_recv(i),i=1,ntask_cont_from)
6902 c      call flush(iout)
6903 C Receive contacts
6904       ireq=0
6905       do ii=1,ntask_cont_from
6906         iproc=itask_cont_from(ii)
6907         nn=ncont_recv(ii)
6908 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
6909 c     &   " of CONT_TO_COMM group"
6910         call flush(iout)
6911         if (nn.gt.0) then
6912           ireq=ireq+1
6913           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
6914      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6915 c          write (iout,*) "ireq,req",ireq,req(ireq)
6916         endif
6917       enddo
6918 C Send the contacts to processors that need them
6919       do ii=1,ntask_cont_to
6920         iproc=itask_cont_to(ii)
6921         nn=ncont_sent(ii)
6922 c        write (iout,*) nn," contacts to processor",iproc,
6923 c     &   " of CONT_TO_COMM group"
6924         if (nn.gt.0) then
6925           ireq=ireq+1
6926           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
6927      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6928 c          write (iout,*) "ireq,req",ireq,req(ireq)
6929 c          do i=1,nn
6930 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
6931 c          enddo
6932         endif
6933       enddo
6934 c      write (iout,*) "number of requests (contacts)",ireq
6935 c      write (iout,*) "req",(req(i),i=1,4)
6936 c      call flush(iout)
6937       if (ireq.gt.0)
6938      & call MPI_Waitall(ireq,req,status_array,ierr)
6939       do iii=1,ntask_cont_from
6940         iproc=itask_cont_from(iii)
6941         nn=ncont_recv(iii)
6942         if (lprn) then
6943         write (iout,*) "Received",nn," contacts from processor",iproc,
6944      &   " of CONT_FROM_COMM group"
6945         call flush(iout)
6946         do i=1,nn
6947           write(iout,'(2f5.0,4f10.5)')(zapas_recv(j,i,iii),j=1,5)
6948         enddo
6949         call flush(iout)
6950         endif
6951         do i=1,nn
6952           ii=zapas_recv(1,i,iii)
6953 c Flag the received contacts to prevent double-counting
6954           jj=-zapas_recv(2,i,iii)
6955 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
6956 c          call flush(iout)
6957           nnn=num_cont_hb(ii)+1
6958           num_cont_hb(ii)=nnn
6959           jcont_hb(nnn,ii)=jj
6960           facont_hb(nnn,ii)=zapas_recv(3,i,iii)
6961           ees0p(nnn,ii)=zapas_recv(4,i,iii)
6962           ees0m(nnn,ii)=zapas_recv(5,i,iii)
6963           gacont_hbr(1,nnn,ii)=zapas_recv(6,i,iii)
6964           gacont_hbr(2,nnn,ii)=zapas_recv(7,i,iii)
6965           gacont_hbr(3,nnn,ii)=zapas_recv(8,i,iii)
6966           gacontm_hb1(1,nnn,ii)=zapas_recv(9,i,iii)
6967           gacontm_hb1(2,nnn,ii)=zapas_recv(10,i,iii)
6968           gacontm_hb1(3,nnn,ii)=zapas_recv(11,i,iii)
6969           gacontp_hb1(1,nnn,ii)=zapas_recv(12,i,iii)
6970           gacontp_hb1(2,nnn,ii)=zapas_recv(13,i,iii)
6971           gacontp_hb1(3,nnn,ii)=zapas_recv(14,i,iii)
6972           gacontm_hb2(1,nnn,ii)=zapas_recv(15,i,iii)
6973           gacontm_hb2(2,nnn,ii)=zapas_recv(16,i,iii)
6974           gacontm_hb2(3,nnn,ii)=zapas_recv(17,i,iii)
6975           gacontp_hb2(1,nnn,ii)=zapas_recv(18,i,iii)
6976           gacontp_hb2(2,nnn,ii)=zapas_recv(19,i,iii)
6977           gacontp_hb2(3,nnn,ii)=zapas_recv(20,i,iii)
6978           gacontm_hb3(1,nnn,ii)=zapas_recv(21,i,iii)
6979           gacontm_hb3(2,nnn,ii)=zapas_recv(22,i,iii)
6980           gacontm_hb3(3,nnn,ii)=zapas_recv(23,i,iii)
6981           gacontp_hb3(1,nnn,ii)=zapas_recv(24,i,iii)
6982           gacontp_hb3(2,nnn,ii)=zapas_recv(25,i,iii)
6983           gacontp_hb3(3,nnn,ii)=zapas_recv(26,i,iii)
6984         enddo
6985       enddo
6986       call flush(iout)
6987       if (lprn) then
6988         write (iout,'(a)') 'Contact function values after receive:'
6989         do i=nnt,nct-2
6990           write (iout,'(2i3,50(1x,i3,f5.2))')
6991      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6992      &    j=1,num_cont_hb(i))
6993         enddo
6994         call flush(iout)
6995       endif
6996    30 continue
6997 #endif
6998       if (lprn) then
6999         write (iout,'(a)') 'Contact function values:'
7000         do i=nnt,nct-2
7001           write (iout,'(2i3,50(1x,i3,f5.2))')
7002      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
7003      &    j=1,num_cont_hb(i))
7004         enddo
7005       endif
7006       ecorr=0.0D0
7007 C Remove the loop below after debugging !!!
7008       do i=nnt,nct
7009         do j=1,3
7010           gradcorr(j,i)=0.0D0
7011           gradxorr(j,i)=0.0D0
7012         enddo
7013       enddo
7014 C Calculate the local-electrostatic correlation terms
7015       do i=min0(iatel_s,iturn4_start),max0(iatel_e,iturn3_end)
7016         i1=i+1
7017         num_conti=num_cont_hb(i)
7018         num_conti1=num_cont_hb(i+1)
7019         do jj=1,num_conti
7020           j=jcont_hb(jj,i)
7021           jp=iabs(j)
7022           do kk=1,num_conti1
7023             j1=jcont_hb(kk,i1)
7024             jp1=iabs(j1)
7025 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
7026 c     &         ' jj=',jj,' kk=',kk
7027             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
7028      &          .or. j.lt.0 .and. j1.gt.0) .and.
7029      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
7030 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
7031 C The system gains extra energy.
7032               ecorr=ecorr+ehbcorr(i,jp,i+1,jp1,jj,kk,0.72D0,0.32D0)
7033               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
7034      &            'ecorrh',i,j,ehbcorr(i,j,i+1,j1,jj,kk,0.72D0,0.32D0)
7035               n_corr=n_corr+1
7036             else if (j1.eq.j) then
7037 C Contacts I-J and I-(J+1) occur simultaneously.
7038 C The system loses extra energy.
7039 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
7040             endif
7041           enddo ! kk
7042           do kk=1,num_conti
7043             j1=jcont_hb(kk,i)
7044 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
7045 c    &         ' jj=',jj,' kk=',kk
7046             if (j1.eq.j+1) then
7047 C Contacts I-J and (I+1)-J occur simultaneously.
7048 C The system loses extra energy.
7049 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
7050             endif ! j1==j+1
7051           enddo ! kk
7052         enddo ! jj
7053       enddo ! i
7054       return
7055       end
7056 c------------------------------------------------------------------------------
7057       subroutine add_hb_contact(ii,jj,itask)
7058       implicit real*8 (a-h,o-z)
7059       include "DIMENSIONS"
7060       include "COMMON.IOUNITS"
7061       integer max_cont
7062       integer max_dim
7063       parameter (max_cont=maxconts)
7064       parameter (max_dim=26)
7065       include "COMMON.CONTACTS"
7066       double precision zapas(max_dim,maxconts,max_fg_procs),
7067      &  zapas_recv(max_dim,maxconts,max_fg_procs)
7068       common /przechowalnia/ zapas
7069       integer i,j,ii,jj,iproc,itask(4),nn
7070 c      write (iout,*) "itask",itask
7071       do i=1,2
7072         iproc=itask(i)
7073         if (iproc.gt.0) then
7074           do j=1,num_cont_hb(ii)
7075             jjc=jcont_hb(j,ii)
7076 c            write (iout,*) "i",ii," j",jj," jjc",jjc
7077             if (jjc.eq.jj) then
7078               ncont_sent(iproc)=ncont_sent(iproc)+1
7079               nn=ncont_sent(iproc)
7080               zapas(1,nn,iproc)=ii
7081               zapas(2,nn,iproc)=jjc
7082               zapas(3,nn,iproc)=facont_hb(j,ii)
7083               zapas(4,nn,iproc)=ees0p(j,ii)
7084               zapas(5,nn,iproc)=ees0m(j,ii)
7085               zapas(6,nn,iproc)=gacont_hbr(1,j,ii)
7086               zapas(7,nn,iproc)=gacont_hbr(2,j,ii)
7087               zapas(8,nn,iproc)=gacont_hbr(3,j,ii)
7088               zapas(9,nn,iproc)=gacontm_hb1(1,j,ii)
7089               zapas(10,nn,iproc)=gacontm_hb1(2,j,ii)
7090               zapas(11,nn,iproc)=gacontm_hb1(3,j,ii)
7091               zapas(12,nn,iproc)=gacontp_hb1(1,j,ii)
7092               zapas(13,nn,iproc)=gacontp_hb1(2,j,ii)
7093               zapas(14,nn,iproc)=gacontp_hb1(3,j,ii)
7094               zapas(15,nn,iproc)=gacontm_hb2(1,j,ii)
7095               zapas(16,nn,iproc)=gacontm_hb2(2,j,ii)
7096               zapas(17,nn,iproc)=gacontm_hb2(3,j,ii)
7097               zapas(18,nn,iproc)=gacontp_hb2(1,j,ii)
7098               zapas(19,nn,iproc)=gacontp_hb2(2,j,ii)
7099               zapas(20,nn,iproc)=gacontp_hb2(3,j,ii)
7100               zapas(21,nn,iproc)=gacontm_hb3(1,j,ii)
7101               zapas(22,nn,iproc)=gacontm_hb3(2,j,ii)
7102               zapas(23,nn,iproc)=gacontm_hb3(3,j,ii)
7103               zapas(24,nn,iproc)=gacontp_hb3(1,j,ii)
7104               zapas(25,nn,iproc)=gacontp_hb3(2,j,ii)
7105               zapas(26,nn,iproc)=gacontp_hb3(3,j,ii)
7106               exit
7107             endif
7108           enddo
7109         endif
7110       enddo
7111       return
7112       end
7113 c------------------------------------------------------------------------------
7114       subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,
7115      &  n_corr1)
7116 C This subroutine calculates multi-body contributions to hydrogen-bonding
7117       implicit real*8 (a-h,o-z)
7118       include 'DIMENSIONS'
7119       include 'COMMON.IOUNITS'
7120 #ifdef MPI
7121       include "mpif.h"
7122       parameter (max_cont=maxconts)
7123       parameter (max_dim=70)
7124       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
7125       double precision zapas(max_dim,maxconts,max_fg_procs),
7126      &  zapas_recv(max_dim,maxconts,max_fg_procs)
7127       common /przechowalnia/ zapas
7128       integer status(MPI_STATUS_SIZE),req(maxconts*2),
7129      &  status_array(MPI_STATUS_SIZE,maxconts*2)
7130 #endif
7131       include 'COMMON.SETUP'
7132       include 'COMMON.FFIELD'
7133       include 'COMMON.DERIV'
7134       include 'COMMON.LOCAL'
7135       include 'COMMON.INTERACT'
7136       include 'COMMON.CONTACTS'
7137       include 'COMMON.CHAIN'
7138       include 'COMMON.CONTROL'
7139       double precision gx(3),gx1(3)
7140       integer num_cont_hb_old(maxres)
7141       logical lprn,ldone
7142       double precision eello4,eello5,eelo6,eello_turn6
7143       external eello4,eello5,eello6,eello_turn6
7144 C Set lprn=.true. for debugging
7145       lprn=.false.
7146       eturn6=0.0d0
7147 #ifdef MPI
7148       do i=1,nres
7149         num_cont_hb_old(i)=num_cont_hb(i)
7150       enddo
7151       n_corr=0
7152       n_corr1=0
7153       if (nfgtasks.le.1) goto 30
7154       if (lprn) then
7155         write (iout,'(a)') 'Contact function values before RECEIVE:'
7156         do i=nnt,nct-2
7157           write (iout,'(2i3,50(1x,i2,f5.2))')
7158      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
7159      &    j=1,num_cont_hb(i))
7160         enddo
7161       endif
7162       call flush(iout)
7163       do i=1,ntask_cont_from
7164         ncont_recv(i)=0
7165       enddo
7166       do i=1,ntask_cont_to
7167         ncont_sent(i)=0
7168       enddo
7169 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
7170 c     & ntask_cont_to
7171 C Make the list of contacts to send to send to other procesors
7172       do i=iturn3_start,iturn3_end
7173 c        write (iout,*) "make contact list turn3",i," num_cont",
7174 c     &    num_cont_hb(i)
7175         call add_hb_contact_eello(i,i+2,iturn3_sent_local(1,i))
7176       enddo
7177       do i=iturn4_start,iturn4_end
7178 c        write (iout,*) "make contact list turn4",i," num_cont",
7179 c     &   num_cont_hb(i)
7180         call add_hb_contact_eello(i,i+3,iturn4_sent_local(1,i))
7181       enddo
7182       do ii=1,nat_sent
7183         i=iat_sent(ii)
7184 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
7185 c     &    num_cont_hb(i)
7186         do j=1,num_cont_hb(i)
7187         do k=1,4
7188           jjc=jcont_hb(j,i)
7189           iproc=iint_sent_local(k,jjc,ii)
7190 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
7191           if (iproc.ne.0) then
7192             ncont_sent(iproc)=ncont_sent(iproc)+1
7193             nn=ncont_sent(iproc)
7194             zapas(1,nn,iproc)=i
7195             zapas(2,nn,iproc)=jjc
7196             zapas(3,nn,iproc)=d_cont(j,i)
7197             ind=3
7198             do kk=1,3
7199               ind=ind+1
7200               zapas(ind,nn,iproc)=grij_hb_cont(kk,j,i)
7201             enddo
7202             do kk=1,2
7203               do ll=1,2
7204                 ind=ind+1
7205                 zapas(ind,nn,iproc)=a_chuj(ll,kk,j,i)
7206               enddo
7207             enddo
7208             do jj=1,5
7209               do kk=1,3
7210                 do ll=1,2
7211                   do mm=1,2
7212                     ind=ind+1
7213                     zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,i)
7214                   enddo
7215                 enddo
7216               enddo
7217             enddo
7218           endif
7219         enddo
7220         enddo
7221       enddo
7222       if (lprn) then
7223       write (iout,*)
7224      &  "Numbers of contacts to be sent to other processors",
7225      &  (ncont_sent(i),i=1,ntask_cont_to)
7226       write (iout,*) "Contacts sent"
7227       do ii=1,ntask_cont_to
7228         nn=ncont_sent(ii)
7229         iproc=itask_cont_to(ii)
7230         write (iout,*) nn," contacts to processor",iproc,
7231      &   " of CONT_TO_COMM group"
7232         do i=1,nn
7233           write(iout,'(2f5.0,10f10.5)')(zapas(j,i,ii),j=1,10)
7234         enddo
7235       enddo
7236       call flush(iout)
7237       endif
7238       CorrelType=477
7239       CorrelID=fg_rank+1
7240       CorrelType1=478
7241       CorrelID1=nfgtasks+fg_rank+1
7242       ireq=0
7243 C Receive the numbers of needed contacts from other processors
7244       do ii=1,ntask_cont_from
7245         iproc=itask_cont_from(ii)
7246         ireq=ireq+1
7247         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
7248      &    FG_COMM,req(ireq),IERR)
7249       enddo
7250 c      write (iout,*) "IRECV ended"
7251 c      call flush(iout)
7252 C Send the number of contacts needed by other processors
7253       do ii=1,ntask_cont_to
7254         iproc=itask_cont_to(ii)
7255         ireq=ireq+1
7256         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
7257      &    FG_COMM,req(ireq),IERR)
7258       enddo
7259 c      write (iout,*) "ISEND ended"
7260 c      write (iout,*) "number of requests (nn)",ireq
7261       call flush(iout)
7262       if (ireq.gt.0)
7263      &  call MPI_Waitall(ireq,req,status_array,ierr)
7264 c      write (iout,*)
7265 c     &  "Numbers of contacts to be received from other processors",
7266 c     &  (ncont_recv(i),i=1,ntask_cont_from)
7267 c      call flush(iout)
7268 C Receive contacts
7269       ireq=0
7270       do ii=1,ntask_cont_from
7271         iproc=itask_cont_from(ii)
7272         nn=ncont_recv(ii)
7273 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
7274 c     &   " of CONT_TO_COMM group"
7275         call flush(iout)
7276         if (nn.gt.0) then
7277           ireq=ireq+1
7278           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
7279      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
7280 c          write (iout,*) "ireq,req",ireq,req(ireq)
7281         endif
7282       enddo
7283 C Send the contacts to processors that need them
7284       do ii=1,ntask_cont_to
7285         iproc=itask_cont_to(ii)
7286         nn=ncont_sent(ii)
7287 c        write (iout,*) nn," contacts to processor",iproc,
7288 c     &   " of CONT_TO_COMM group"
7289         if (nn.gt.0) then
7290           ireq=ireq+1
7291           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
7292      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
7293 c          write (iout,*) "ireq,req",ireq,req(ireq)
7294 c          do i=1,nn
7295 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
7296 c          enddo
7297         endif
7298       enddo
7299 c      write (iout,*) "number of requests (contacts)",ireq
7300 c      write (iout,*) "req",(req(i),i=1,4)
7301 c      call flush(iout)
7302       if (ireq.gt.0)
7303      & call MPI_Waitall(ireq,req,status_array,ierr)
7304       do iii=1,ntask_cont_from
7305         iproc=itask_cont_from(iii)
7306         nn=ncont_recv(iii)
7307         if (lprn) then
7308         write (iout,*) "Received",nn," contacts from processor",iproc,
7309      &   " of CONT_FROM_COMM group"
7310         call flush(iout)
7311         do i=1,nn
7312           write(iout,'(2f5.0,10f10.5)')(zapas_recv(j,i,iii),j=1,10)
7313         enddo
7314         call flush(iout)
7315         endif
7316         do i=1,nn
7317           ii=zapas_recv(1,i,iii)
7318 c Flag the received contacts to prevent double-counting
7319           jj=-zapas_recv(2,i,iii)
7320 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
7321 c          call flush(iout)
7322           nnn=num_cont_hb(ii)+1
7323           num_cont_hb(ii)=nnn
7324           jcont_hb(nnn,ii)=jj
7325           d_cont(nnn,ii)=zapas_recv(3,i,iii)
7326           ind=3
7327           do kk=1,3
7328             ind=ind+1
7329             grij_hb_cont(kk,nnn,ii)=zapas_recv(ind,i,iii)
7330           enddo
7331           do kk=1,2
7332             do ll=1,2
7333               ind=ind+1
7334               a_chuj(ll,kk,nnn,ii)=zapas_recv(ind,i,iii)
7335             enddo
7336           enddo
7337           do jj=1,5
7338             do kk=1,3
7339               do ll=1,2
7340                 do mm=1,2
7341                   ind=ind+1
7342                   a_chuj_der(mm,ll,kk,jj,nnn,ii)=zapas_recv(ind,i,iii)
7343                 enddo
7344               enddo
7345             enddo
7346           enddo
7347         enddo
7348       enddo
7349       call flush(iout)
7350       if (lprn) then
7351         write (iout,'(a)') 'Contact function values after receive:'
7352         do i=nnt,nct-2
7353           write (iout,'(2i3,50(1x,i3,5f6.3))')
7354      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
7355      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
7356         enddo
7357         call flush(iout)
7358       endif
7359    30 continue
7360 #endif
7361       if (lprn) then
7362         write (iout,'(a)') 'Contact function values:'
7363         do i=nnt,nct-2
7364           write (iout,'(2i3,50(1x,i2,5f6.3))')
7365      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
7366      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
7367         enddo
7368       endif
7369       ecorr=0.0D0
7370       ecorr5=0.0d0
7371       ecorr6=0.0d0
7372 C Remove the loop below after debugging !!!
7373       do i=nnt,nct
7374         do j=1,3
7375           gradcorr(j,i)=0.0D0
7376           gradxorr(j,i)=0.0D0
7377         enddo
7378       enddo
7379 C Calculate the dipole-dipole interaction energies
7380       if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
7381       do i=iatel_s,iatel_e+1
7382         num_conti=num_cont_hb(i)
7383         do jj=1,num_conti
7384           j=jcont_hb(jj,i)
7385 #ifdef MOMENT
7386           call dipole(i,j,jj)
7387 #endif
7388         enddo
7389       enddo
7390       endif
7391 C Calculate the local-electrostatic correlation terms
7392 c                write (iout,*) "gradcorr5 in eello5 before loop"
7393 c                do iii=1,nres
7394 c                  write (iout,'(i5,3f10.5)')
7395 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
7396 c                enddo
7397       do i=min0(iatel_s,iturn4_start),max0(iatel_e+1,iturn3_end+1)
7398 c        write (iout,*) "corr loop i",i
7399         i1=i+1
7400         num_conti=num_cont_hb(i)
7401         num_conti1=num_cont_hb(i+1)
7402         do jj=1,num_conti
7403           j=jcont_hb(jj,i)
7404           jp=iabs(j)
7405           do kk=1,num_conti1
7406             j1=jcont_hb(kk,i1)
7407             jp1=iabs(j1)
7408 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
7409 c     &         ' jj=',jj,' kk=',kk
7410 c            if (j1.eq.j+1 .or. j1.eq.j-1) then
7411             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
7412      &          .or. j.lt.0 .and. j1.gt.0) .and.
7413      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
7414 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
7415 C The system gains extra energy.
7416               n_corr=n_corr+1
7417               sqd1=dsqrt(d_cont(jj,i))
7418               sqd2=dsqrt(d_cont(kk,i1))
7419               sred_geom = sqd1*sqd2
7420               IF (sred_geom.lt.cutoff_corr) THEN
7421                 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,
7422      &            ekont,fprimcont)
7423 cd               write (iout,*) 'i=',i,' j=',jp,' i1=',i1,' j1=',jp1,
7424 cd     &         ' jj=',jj,' kk=',kk
7425                 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
7426                 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
7427                 do l=1,3
7428                   g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
7429                   g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
7430                 enddo
7431                 n_corr1=n_corr1+1
7432 cd               write (iout,*) 'sred_geom=',sred_geom,
7433 cd     &          ' ekont=',ekont,' fprim=',fprimcont,
7434 cd     &          ' fac_prim1',fac_prim1,' fac_prim2',fac_prim2
7435 cd               write (iout,*) "g_contij",g_contij
7436 cd               write (iout,*) "grij_hb_cont i",grij_hb_cont(:,jj,i)
7437 cd               write (iout,*) "grij_hb_cont i1",grij_hb_cont(:,jj,i1)
7438                 call calc_eello(i,jp,i+1,jp1,jj,kk)
7439                 if (wcorr4.gt.0.0d0)
7440      &            ecorr=ecorr+eello4(i,jp,i+1,jp1,jj,kk)
7441                   if (energy_dec.and.wcorr4.gt.0.0d0)
7442      1                 write (iout,'(a6,4i5,0pf7.3)')
7443      2                'ecorr4',i,j,i+1,j1,eello4(i,jp,i+1,jp1,jj,kk)
7444 c                write (iout,*) "gradcorr5 before eello5"
7445 c                do iii=1,nres
7446 c                  write (iout,'(i5,3f10.5)')
7447 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
7448 c                enddo
7449                 if (wcorr5.gt.0.0d0)
7450      &            ecorr5=ecorr5+eello5(i,jp,i+1,jp1,jj,kk)
7451 c                write (iout,*) "gradcorr5 after eello5"
7452 c                do iii=1,nres
7453 c                  write (iout,'(i5,3f10.5)')
7454 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
7455 c                enddo
7456                   if (energy_dec.and.wcorr5.gt.0.0d0)
7457      1                 write (iout,'(a6,4i5,0pf7.3)')
7458      2                'ecorr5',i,j,i+1,j1,eello5(i,jp,i+1,jp1,jj,kk)
7459 cd                write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
7460 cd                write(2,*)'ijkl',i,jp,i+1,jp1
7461                 if (wcorr6.gt.0.0d0 .and. (jp.ne.i+4 .or. jp1.ne.i+3
7462      &               .or. wturn6.eq.0.0d0))then
7463 cd                  write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
7464                   ecorr6=ecorr6+eello6(i,jp,i+1,jp1,jj,kk)
7465                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
7466      1                'ecorr6',i,j,i+1,j1,eello6(i,jp,i+1,jp1,jj,kk)
7467 cd                write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
7468 cd     &            'ecorr6=',ecorr6
7469 cd                write (iout,'(4e15.5)') sred_geom,
7470 cd     &          dabs(eello4(i,jp,i+1,jp1,jj,kk)),
7471 cd     &          dabs(eello5(i,jp,i+1,jp1,jj,kk)),
7472 cd     &          dabs(eello6(i,jp,i+1,jp1,jj,kk))
7473                 else if (wturn6.gt.0.0d0
7474      &            .and. (jp.eq.i+4 .and. jp1.eq.i+3)) then
7475 cd                  write (iout,*) '******eturn6: i,j,i+1,j1',i,jip,i+1,jp1
7476                   eturn6=eturn6+eello_turn6(i,jj,kk)
7477                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
7478      1                 'eturn6',i,j,i+1,j1,eello_turn6(i,jj,kk)
7479 cd                  write (2,*) 'multibody_eello:eturn6',eturn6
7480                 endif
7481               ENDIF
7482 1111          continue
7483             endif
7484           enddo ! kk
7485         enddo ! jj
7486       enddo ! i
7487       do i=1,nres
7488         num_cont_hb(i)=num_cont_hb_old(i)
7489       enddo
7490 c                write (iout,*) "gradcorr5 in eello5"
7491 c                do iii=1,nres
7492 c                  write (iout,'(i5,3f10.5)')
7493 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
7494 c                enddo
7495       return
7496       end
7497 c------------------------------------------------------------------------------
7498       subroutine add_hb_contact_eello(ii,jj,itask)
7499       implicit real*8 (a-h,o-z)
7500       include "DIMENSIONS"
7501       include "COMMON.IOUNITS"
7502       integer max_cont
7503       integer max_dim
7504       parameter (max_cont=maxconts)
7505       parameter (max_dim=70)
7506       include "COMMON.CONTACTS"
7507       double precision zapas(max_dim,maxconts,max_fg_procs),
7508      &  zapas_recv(max_dim,maxconts,max_fg_procs)
7509       common /przechowalnia/ zapas
7510       integer i,j,ii,jj,iproc,itask(4),nn
7511 c      write (iout,*) "itask",itask
7512       do i=1,2
7513         iproc=itask(i)
7514         if (iproc.gt.0) then
7515           do j=1,num_cont_hb(ii)
7516             jjc=jcont_hb(j,ii)
7517 c            write (iout,*) "send turns i",ii," j",jj," jjc",jjc
7518             if (jjc.eq.jj) then
7519               ncont_sent(iproc)=ncont_sent(iproc)+1
7520               nn=ncont_sent(iproc)
7521               zapas(1,nn,iproc)=ii
7522               zapas(2,nn,iproc)=jjc
7523               zapas(3,nn,iproc)=d_cont(j,ii)
7524               ind=3
7525               do kk=1,3
7526                 ind=ind+1
7527                 zapas(ind,nn,iproc)=grij_hb_cont(kk,j,ii)
7528               enddo
7529               do kk=1,2
7530                 do ll=1,2
7531                   ind=ind+1
7532                   zapas(ind,nn,iproc)=a_chuj(ll,kk,j,ii)
7533                 enddo
7534               enddo
7535               do jj=1,5
7536                 do kk=1,3
7537                   do ll=1,2
7538                     do mm=1,2
7539                       ind=ind+1
7540                       zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,ii)
7541                     enddo
7542                   enddo
7543                 enddo
7544               enddo
7545               exit
7546             endif
7547           enddo
7548         endif
7549       enddo
7550       return
7551       end
7552 c------------------------------------------------------------------------------
7553       double precision function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
7554       implicit real*8 (a-h,o-z)
7555       include 'DIMENSIONS'
7556       include 'COMMON.IOUNITS'
7557       include 'COMMON.DERIV'
7558       include 'COMMON.INTERACT'
7559       include 'COMMON.CONTACTS'
7560       double precision gx(3),gx1(3)
7561       logical lprn
7562       lprn=.false.
7563       eij=facont_hb(jj,i)
7564       ekl=facont_hb(kk,k)
7565       ees0pij=ees0p(jj,i)
7566       ees0pkl=ees0p(kk,k)
7567       ees0mij=ees0m(jj,i)
7568       ees0mkl=ees0m(kk,k)
7569       ekont=eij*ekl
7570       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
7571 cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
7572 C Following 4 lines for diagnostics.
7573 cd    ees0pkl=0.0D0
7574 cd    ees0pij=1.0D0
7575 cd    ees0mkl=0.0D0
7576 cd    ees0mij=1.0D0
7577 c      write (iout,'(2(a,2i3,a,f10.5,a,2f10.5),a,f10.5,a,$)')
7578 c     & 'Contacts ',i,j,
7579 c     & ' eij',eij,' eesij',ees0pij,ees0mij,' and ',k,l
7580 c     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' energy=',ekont*ees,
7581 c     & 'gradcorr_long'
7582 C Calculate the multi-body contribution to energy.
7583 c      ecorr=ecorr+ekont*ees
7584 C Calculate multi-body contributions to the gradient.
7585       coeffpees0pij=coeffp*ees0pij
7586       coeffmees0mij=coeffm*ees0mij
7587       coeffpees0pkl=coeffp*ees0pkl
7588       coeffmees0mkl=coeffm*ees0mkl
7589       do ll=1,3
7590 cgrad        ghalfi=ees*ekl*gacont_hbr(ll,jj,i)
7591         gradcorr(ll,i)=gradcorr(ll,i)!+0.5d0*ghalfi
7592      &  -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+
7593      &  coeffmees0mkl*gacontm_hb1(ll,jj,i))
7594         gradcorr(ll,j)=gradcorr(ll,j)!+0.5d0*ghalfi
7595      &  -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+
7596      &  coeffmees0mkl*gacontm_hb2(ll,jj,i))
7597 cgrad        ghalfk=ees*eij*gacont_hbr(ll,kk,k)
7598         gradcorr(ll,k)=gradcorr(ll,k)!+0.5d0*ghalfk
7599      &  -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+
7600      &  coeffmees0mij*gacontm_hb1(ll,kk,k))
7601         gradcorr(ll,l)=gradcorr(ll,l)!+0.5d0*ghalfk
7602      &  -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+
7603      &  coeffmees0mij*gacontm_hb2(ll,kk,k))
7604         gradlongij=ees*ekl*gacont_hbr(ll,jj,i)-
7605      &     ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+
7606      &     coeffmees0mkl*gacontm_hb3(ll,jj,i))
7607         gradcorr_long(ll,j)=gradcorr_long(ll,j)+gradlongij
7608         gradcorr_long(ll,i)=gradcorr_long(ll,i)-gradlongij
7609         gradlongkl=ees*eij*gacont_hbr(ll,kk,k)-
7610      &     ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+
7611      &     coeffmees0mij*gacontm_hb3(ll,kk,k))
7612         gradcorr_long(ll,l)=gradcorr_long(ll,l)+gradlongkl
7613         gradcorr_long(ll,k)=gradcorr_long(ll,k)-gradlongkl
7614 c        write (iout,'(2f10.5,2x,$)') gradlongij,gradlongkl
7615       enddo
7616 c      write (iout,*)
7617 cgrad      do m=i+1,j-1
7618 cgrad        do ll=1,3
7619 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
7620 cgrad     &     ees*ekl*gacont_hbr(ll,jj,i)-
7621 cgrad     &     ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
7622 cgrad     &     coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
7623 cgrad        enddo
7624 cgrad      enddo
7625 cgrad      do m=k+1,l-1
7626 cgrad        do ll=1,3
7627 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
7628 cgrad     &     ees*eij*gacont_hbr(ll,kk,k)-
7629 cgrad     &     ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
7630 cgrad     &     coeffm*ees0mij*gacontm_hb3(ll,kk,k))
7631 cgrad        enddo
7632 cgrad      enddo
7633 c      write (iout,*) "ehbcorr",ekont*ees
7634       ehbcorr=ekont*ees
7635       return
7636       end
7637 #ifdef MOMENT
7638 C---------------------------------------------------------------------------
7639       subroutine dipole(i,j,jj)
7640       implicit real*8 (a-h,o-z)
7641       include 'DIMENSIONS'
7642       include 'COMMON.IOUNITS'
7643       include 'COMMON.CHAIN'
7644       include 'COMMON.FFIELD'
7645       include 'COMMON.DERIV'
7646       include 'COMMON.INTERACT'
7647       include 'COMMON.CONTACTS'
7648       include 'COMMON.TORSION'
7649       include 'COMMON.VAR'
7650       include 'COMMON.GEO'
7651       dimension dipi(2,2),dipj(2,2),dipderi(2),dipderj(2),auxvec(2),
7652      &  auxmat(2,2)
7653       iti1 = itortyp(itype(i+1))
7654       if (j.lt.nres-1) then
7655         itj1 = itortyp(itype(j+1))
7656       else
7657         itj1=ntortyp
7658       endif
7659       do iii=1,2
7660         dipi(iii,1)=Ub2(iii,i)
7661         dipderi(iii)=Ub2der(iii,i)
7662         dipi(iii,2)=b1(iii,iti1)
7663         dipj(iii,1)=Ub2(iii,j)
7664         dipderj(iii)=Ub2der(iii,j)
7665         dipj(iii,2)=b1(iii,itj1)
7666       enddo
7667       kkk=0
7668       do iii=1,2
7669         call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
7670         do jjj=1,2
7671           kkk=kkk+1
7672           dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
7673         enddo
7674       enddo
7675       do kkk=1,5
7676         do lll=1,3
7677           mmm=0
7678           do iii=1,2
7679             call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),
7680      &        auxvec(1))
7681             do jjj=1,2
7682               mmm=mmm+1
7683               dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
7684             enddo
7685           enddo
7686         enddo
7687       enddo
7688       call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
7689       call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
7690       do iii=1,2
7691         dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
7692       enddo
7693       call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
7694       do iii=1,2
7695         dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
7696       enddo
7697       return
7698       end
7699 #endif
7700 C---------------------------------------------------------------------------
7701       subroutine calc_eello(i,j,k,l,jj,kk)
7702 C
7703 C This subroutine computes matrices and vectors needed to calculate
7704 C the fourth-, fifth-, and sixth-order local-electrostatic terms.
7705 C
7706       implicit real*8 (a-h,o-z)
7707       include 'DIMENSIONS'
7708       include 'COMMON.IOUNITS'
7709       include 'COMMON.CHAIN'
7710       include 'COMMON.DERIV'
7711       include 'COMMON.INTERACT'
7712       include 'COMMON.CONTACTS'
7713       include 'COMMON.TORSION'
7714       include 'COMMON.VAR'
7715       include 'COMMON.GEO'
7716       include 'COMMON.FFIELD'
7717       double precision aa1(2,2),aa2(2,2),aa1t(2,2),aa2t(2,2),
7718      &  aa1tder(2,2,3,5),aa2tder(2,2,3,5),auxmat(2,2)
7719       logical lprn
7720       common /kutas/ lprn
7721 cd      write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
7722 cd     & ' jj=',jj,' kk=',kk
7723 cd      if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
7724 cd      write (iout,*) "a_chujij",((a_chuj(iii,jjj,jj,i),iii=1,2),jjj=1,2)
7725 cd      write (iout,*) "a_chujkl",((a_chuj(iii,jjj,kk,k),iii=1,2),jjj=1,2)
7726       do iii=1,2
7727         do jjj=1,2
7728           aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
7729           aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
7730         enddo
7731       enddo
7732       call transpose2(aa1(1,1),aa1t(1,1))
7733       call transpose2(aa2(1,1),aa2t(1,1))
7734       do kkk=1,5
7735         do lll=1,3
7736           call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),
7737      &      aa1tder(1,1,lll,kkk))
7738           call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),
7739      &      aa2tder(1,1,lll,kkk))
7740         enddo
7741       enddo
7742       if (l.eq.j+1) then
7743 C parallel orientation of the two CA-CA-CA frames.
7744         if (i.gt.1) then
7745           iti=itortyp(itype(i))
7746         else
7747           iti=ntortyp
7748         endif
7749         itk1=itortyp(itype(k+1))
7750         itj=itortyp(itype(j))
7751         if (l.lt.nres-1) then
7752           itl1=itortyp(itype(l+1))
7753         else
7754           itl1=ntortyp
7755         endif
7756 C A1 kernel(j+1) A2T
7757 cd        do iii=1,2
7758 cd          write (iout,'(3f10.5,5x,3f10.5)')
7759 cd     &     (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
7760 cd        enddo
7761         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7762      &   aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),
7763      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
7764 C Following matrices are needed only for 6-th order cumulants
7765         IF (wcorr6.gt.0.0d0) THEN
7766         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7767      &   aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),
7768      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
7769         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7770      &   aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),
7771      &   Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
7772      &   ADtEAderx(1,1,1,1,1,1))
7773         lprn=.false.
7774         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7775      &   aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),
7776      &   DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
7777      &   ADtEA1derx(1,1,1,1,1,1))
7778         ENDIF
7779 C End 6-th order cumulants
7780 cd        lprn=.false.
7781 cd        if (lprn) then
7782 cd        write (2,*) 'In calc_eello6'
7783 cd        do iii=1,2
7784 cd          write (2,*) 'iii=',iii
7785 cd          do kkk=1,5
7786 cd            write (2,*) 'kkk=',kkk
7787 cd            do jjj=1,2
7788 cd              write (2,'(3(2f10.5),5x)')
7789 cd     &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
7790 cd            enddo
7791 cd          enddo
7792 cd        enddo
7793 cd        endif
7794         call transpose2(EUgder(1,1,k),auxmat(1,1))
7795         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
7796         call transpose2(EUg(1,1,k),auxmat(1,1))
7797         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
7798         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
7799         do iii=1,2
7800           do kkk=1,5
7801             do lll=1,3
7802               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7803      &          EAEAderx(1,1,lll,kkk,iii,1))
7804             enddo
7805           enddo
7806         enddo
7807 C A1T kernel(i+1) A2
7808         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7809      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),
7810      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
7811 C Following matrices are needed only for 6-th order cumulants
7812         IF (wcorr6.gt.0.0d0) THEN
7813         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7814      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),
7815      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
7816         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7817      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),
7818      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
7819      &   ADtEAderx(1,1,1,1,1,2))
7820         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7821      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),
7822      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
7823      &   ADtEA1derx(1,1,1,1,1,2))
7824         ENDIF
7825 C End 6-th order cumulants
7826         call transpose2(EUgder(1,1,l),auxmat(1,1))
7827         call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
7828         call transpose2(EUg(1,1,l),auxmat(1,1))
7829         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
7830         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
7831         do iii=1,2
7832           do kkk=1,5
7833             do lll=1,3
7834               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7835      &          EAEAderx(1,1,lll,kkk,iii,2))
7836             enddo
7837           enddo
7838         enddo
7839 C AEAb1 and AEAb2
7840 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
7841 C They are needed only when the fifth- or the sixth-order cumulants are
7842 C indluded.
7843         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
7844         call transpose2(AEA(1,1,1),auxmat(1,1))
7845         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
7846         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
7847         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
7848         call transpose2(AEAderg(1,1,1),auxmat(1,1))
7849         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
7850         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
7851         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
7852         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
7853         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
7854         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
7855         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
7856         call transpose2(AEA(1,1,2),auxmat(1,1))
7857         call matvec2(auxmat(1,1),b1(1,itj),AEAb1(1,1,2))
7858         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
7859         call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
7860         call transpose2(AEAderg(1,1,2),auxmat(1,1))
7861         call matvec2(auxmat(1,1),b1(1,itj),AEAb1derg(1,1,2))
7862         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
7863         call matvec2(AEA(1,1,2),b1(1,itl1),AEAb1(1,2,2))
7864         call matvec2(AEAderg(1,1,2),b1(1,itl1),AEAb1derg(1,2,2))
7865         call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
7866         call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
7867         call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
7868 C Calculate the Cartesian derivatives of the vectors.
7869         do iii=1,2
7870           do kkk=1,5
7871             do lll=1,3
7872               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
7873               call matvec2(auxmat(1,1),b1(1,iti),
7874      &          AEAb1derx(1,lll,kkk,iii,1,1))
7875               call matvec2(auxmat(1,1),Ub2(1,i),
7876      &          AEAb2derx(1,lll,kkk,iii,1,1))
7877               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
7878      &          AEAb1derx(1,lll,kkk,iii,2,1))
7879               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
7880      &          AEAb2derx(1,lll,kkk,iii,2,1))
7881               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
7882               call matvec2(auxmat(1,1),b1(1,itj),
7883      &          AEAb1derx(1,lll,kkk,iii,1,2))
7884               call matvec2(auxmat(1,1),Ub2(1,j),
7885      &          AEAb2derx(1,lll,kkk,iii,1,2))
7886               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itl1),
7887      &          AEAb1derx(1,lll,kkk,iii,2,2))
7888               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),
7889      &          AEAb2derx(1,lll,kkk,iii,2,2))
7890             enddo
7891           enddo
7892         enddo
7893         ENDIF
7894 C End vectors
7895       else
7896 C Antiparallel orientation of the two CA-CA-CA frames.
7897         if (i.gt.1) then
7898           iti=itortyp(itype(i))
7899         else
7900           iti=ntortyp
7901         endif
7902         itk1=itortyp(itype(k+1))
7903         itl=itortyp(itype(l))
7904         itj=itortyp(itype(j))
7905         if (j.lt.nres-1) then
7906           itj1=itortyp(itype(j+1))
7907         else
7908           itj1=ntortyp
7909         endif
7910 C A2 kernel(j-1)T A1T
7911         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7912      &   aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),
7913      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
7914 C Following matrices are needed only for 6-th order cumulants
7915         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
7916      &     j.eq.i+4 .and. l.eq.i+3)) THEN
7917         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7918      &   aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),
7919      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
7920         call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7921      &   aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),
7922      &   Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
7923      &   ADtEAderx(1,1,1,1,1,1))
7924         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7925      &   aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),
7926      &   DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
7927      &   ADtEA1derx(1,1,1,1,1,1))
7928         ENDIF
7929 C End 6-th order cumulants
7930         call transpose2(EUgder(1,1,k),auxmat(1,1))
7931         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
7932         call transpose2(EUg(1,1,k),auxmat(1,1))
7933         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
7934         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
7935         do iii=1,2
7936           do kkk=1,5
7937             do lll=1,3
7938               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7939      &          EAEAderx(1,1,lll,kkk,iii,1))
7940             enddo
7941           enddo
7942         enddo
7943 C A2T kernel(i+1)T A1
7944         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7945      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),
7946      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
7947 C Following matrices are needed only for 6-th order cumulants
7948         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
7949      &     j.eq.i+4 .and. l.eq.i+3)) THEN
7950         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7951      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),
7952      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
7953         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7954      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),
7955      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
7956      &   ADtEAderx(1,1,1,1,1,2))
7957         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7958      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),
7959      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
7960      &   ADtEA1derx(1,1,1,1,1,2))
7961         ENDIF
7962 C End 6-th order cumulants
7963         call transpose2(EUgder(1,1,j),auxmat(1,1))
7964         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
7965         call transpose2(EUg(1,1,j),auxmat(1,1))
7966         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
7967         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
7968         do iii=1,2
7969           do kkk=1,5
7970             do lll=1,3
7971               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7972      &          EAEAderx(1,1,lll,kkk,iii,2))
7973             enddo
7974           enddo
7975         enddo
7976 C AEAb1 and AEAb2
7977 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
7978 C They are needed only when the fifth- or the sixth-order cumulants are
7979 C indluded.
7980         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or.
7981      &    (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
7982         call transpose2(AEA(1,1,1),auxmat(1,1))
7983         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
7984         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
7985         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
7986         call transpose2(AEAderg(1,1,1),auxmat(1,1))
7987         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
7988         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
7989         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
7990         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
7991         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
7992         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
7993         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
7994         call transpose2(AEA(1,1,2),auxmat(1,1))
7995         call matvec2(auxmat(1,1),b1(1,itj1),AEAb1(1,1,2))
7996         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
7997         call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
7998         call transpose2(AEAderg(1,1,2),auxmat(1,1))
7999         call matvec2(auxmat(1,1),b1(1,itl),AEAb1(1,1,2))
8000         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
8001         call matvec2(AEA(1,1,2),b1(1,itj1),AEAb1(1,2,2))
8002         call matvec2(AEAderg(1,1,2),b1(1,itj1),AEAb1derg(1,2,2))
8003         call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
8004         call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
8005         call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
8006 C Calculate the Cartesian derivatives of the vectors.
8007         do iii=1,2
8008           do kkk=1,5
8009             do lll=1,3
8010               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
8011               call matvec2(auxmat(1,1),b1(1,iti),
8012      &          AEAb1derx(1,lll,kkk,iii,1,1))
8013               call matvec2(auxmat(1,1),Ub2(1,i),
8014      &          AEAb2derx(1,lll,kkk,iii,1,1))
8015               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
8016      &          AEAb1derx(1,lll,kkk,iii,2,1))
8017               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
8018      &          AEAb2derx(1,lll,kkk,iii,2,1))
8019               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
8020               call matvec2(auxmat(1,1),b1(1,itl),
8021      &          AEAb1derx(1,lll,kkk,iii,1,2))
8022               call matvec2(auxmat(1,1),Ub2(1,l),
8023      &          AEAb2derx(1,lll,kkk,iii,1,2))
8024               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itj1),
8025      &          AEAb1derx(1,lll,kkk,iii,2,2))
8026               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),
8027      &          AEAb2derx(1,lll,kkk,iii,2,2))
8028             enddo
8029           enddo
8030         enddo
8031         ENDIF
8032 C End vectors
8033       endif
8034       return
8035       end
8036 C---------------------------------------------------------------------------
8037       subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,
8038      &  KK,KKderg,AKA,AKAderg,AKAderx)
8039       implicit none
8040       integer nderg
8041       logical transp
8042       double precision aa1(2,2),aa2t(2,2),aa1derx(2,2,3,5),
8043      &  aa2tderx(2,2,3,5),KK(2,2),KKderg(2,2,nderg),AKA(2,2),
8044      &  AKAderg(2,2,nderg),AKAderx(2,2,3,5,2)
8045       integer iii,kkk,lll
8046       integer jjj,mmm
8047       logical lprn
8048       common /kutas/ lprn
8049       call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
8050       do iii=1,nderg
8051         call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,
8052      &    AKAderg(1,1,iii))
8053       enddo
8054 cd      if (lprn) write (2,*) 'In kernel'
8055       do kkk=1,5
8056 cd        if (lprn) write (2,*) 'kkk=',kkk
8057         do lll=1,3
8058           call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),
8059      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
8060 cd          if (lprn) then
8061 cd            write (2,*) 'lll=',lll
8062 cd            write (2,*) 'iii=1'
8063 cd            do jjj=1,2
8064 cd              write (2,'(3(2f10.5),5x)')
8065 cd     &        (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
8066 cd            enddo
8067 cd          endif
8068           call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),
8069      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
8070 cd          if (lprn) then
8071 cd            write (2,*) 'lll=',lll
8072 cd            write (2,*) 'iii=2'
8073 cd            do jjj=1,2
8074 cd              write (2,'(3(2f10.5),5x)')
8075 cd     &        (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
8076 cd            enddo
8077 cd          endif
8078         enddo
8079       enddo
8080       return
8081       end
8082 C---------------------------------------------------------------------------
8083       double precision function eello4(i,j,k,l,jj,kk)
8084       implicit real*8 (a-h,o-z)
8085       include 'DIMENSIONS'
8086       include 'COMMON.IOUNITS'
8087       include 'COMMON.CHAIN'
8088       include 'COMMON.DERIV'
8089       include 'COMMON.INTERACT'
8090       include 'COMMON.CONTACTS'
8091       include 'COMMON.TORSION'
8092       include 'COMMON.VAR'
8093       include 'COMMON.GEO'
8094       double precision pizda(2,2),ggg1(3),ggg2(3)
8095 cd      if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
8096 cd        eello4=0.0d0
8097 cd        return
8098 cd      endif
8099 cd      print *,'eello4:',i,j,k,l,jj,kk
8100 cd      write (2,*) 'i',i,' j',j,' k',k,' l',l
8101 cd      call checkint4(i,j,k,l,jj,kk,eel4_num)
8102 cold      eij=facont_hb(jj,i)
8103 cold      ekl=facont_hb(kk,k)
8104 cold      ekont=eij*ekl
8105       eel4=-EAEA(1,1,1)-EAEA(2,2,1)
8106 cd      eel41=-EAEA(1,1,2)-EAEA(2,2,2)
8107       gcorr_loc(k-1)=gcorr_loc(k-1)
8108      &   -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
8109       if (l.eq.j+1) then
8110         gcorr_loc(l-1)=gcorr_loc(l-1)
8111      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
8112       else
8113         gcorr_loc(j-1)=gcorr_loc(j-1)
8114      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
8115       endif
8116       do iii=1,2
8117         do kkk=1,5
8118           do lll=1,3
8119             derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1)
8120      &                        -EAEAderx(2,2,lll,kkk,iii,1)
8121 cd            derx(lll,kkk,iii)=0.0d0
8122           enddo
8123         enddo
8124       enddo
8125 cd      gcorr_loc(l-1)=0.0d0
8126 cd      gcorr_loc(j-1)=0.0d0
8127 cd      gcorr_loc(k-1)=0.0d0
8128 cd      eel4=1.0d0
8129 cd      write (iout,*)'Contacts have occurred for peptide groups',
8130 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l,
8131 cd     &  ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
8132       if (j.lt.nres-1) then
8133         j1=j+1
8134         j2=j-1
8135       else
8136         j1=j-1
8137         j2=j-2
8138       endif
8139       if (l.lt.nres-1) then
8140         l1=l+1
8141         l2=l-1
8142       else
8143         l1=l-1
8144         l2=l-2
8145       endif
8146       do ll=1,3
8147 cgrad        ggg1(ll)=eel4*g_contij(ll,1)
8148 cgrad        ggg2(ll)=eel4*g_contij(ll,2)
8149         glongij=eel4*g_contij(ll,1)+ekont*derx(ll,1,1)
8150         glongkl=eel4*g_contij(ll,2)+ekont*derx(ll,1,2)
8151 cgrad        ghalf=0.5d0*ggg1(ll)
8152         gradcorr(ll,i)=gradcorr(ll,i)+ekont*derx(ll,2,1)
8153         gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
8154         gradcorr(ll,j)=gradcorr(ll,j)+ekont*derx(ll,4,1)
8155         gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
8156         gradcorr_long(ll,j)=gradcorr_long(ll,j)+glongij
8157         gradcorr_long(ll,i)=gradcorr_long(ll,i)-glongij
8158 cgrad        ghalf=0.5d0*ggg2(ll)
8159         gradcorr(ll,k)=gradcorr(ll,k)+ekont*derx(ll,2,2)
8160         gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
8161         gradcorr(ll,l)=gradcorr(ll,l)+ekont*derx(ll,4,2)
8162         gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
8163         gradcorr_long(ll,l)=gradcorr_long(ll,l)+glongkl
8164         gradcorr_long(ll,k)=gradcorr_long(ll,k)-glongkl
8165       enddo
8166 cgrad      do m=i+1,j-1
8167 cgrad        do ll=1,3
8168 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
8169 cgrad        enddo
8170 cgrad      enddo
8171 cgrad      do m=k+1,l-1
8172 cgrad        do ll=1,3
8173 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
8174 cgrad        enddo
8175 cgrad      enddo
8176 cgrad      do m=i+2,j2
8177 cgrad        do ll=1,3
8178 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
8179 cgrad        enddo
8180 cgrad      enddo
8181 cgrad      do m=k+2,l2
8182 cgrad        do ll=1,3
8183 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
8184 cgrad        enddo
8185 cgrad      enddo
8186 cd      do iii=1,nres-3
8187 cd        write (2,*) iii,gcorr_loc(iii)
8188 cd      enddo
8189       eello4=ekont*eel4
8190 cd      write (2,*) 'ekont',ekont
8191 cd      write (iout,*) 'eello4',ekont*eel4
8192       return
8193       end
8194 C---------------------------------------------------------------------------
8195       double precision function eello5(i,j,k,l,jj,kk)
8196       implicit real*8 (a-h,o-z)
8197       include 'DIMENSIONS'
8198       include 'COMMON.IOUNITS'
8199       include 'COMMON.CHAIN'
8200       include 'COMMON.DERIV'
8201       include 'COMMON.INTERACT'
8202       include 'COMMON.CONTACTS'
8203       include 'COMMON.TORSION'
8204       include 'COMMON.VAR'
8205       include 'COMMON.GEO'
8206       double precision pizda(2,2),auxmat(2,2),auxmat1(2,2),vv(2)
8207       double precision ggg1(3),ggg2(3)
8208 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8209 C                                                                              C
8210 C                            Parallel chains                                   C
8211 C                                                                              C
8212 C          o             o                   o             o                   C
8213 C         /l\           / \             \   / \           / \   /              C
8214 C        /   \         /   \             \ /   \         /   \ /               C
8215 C       j| o |l1       | o |              o| o |         | o |o                C
8216 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
8217 C      \i/   \         /   \ /             /   \         /   \                 C
8218 C       o    k1             o                                                  C
8219 C         (I)          (II)                (III)          (IV)                 C
8220 C                                                                              C
8221 C      eello5_1        eello5_2            eello5_3       eello5_4             C
8222 C                                                                              C
8223 C                            Antiparallel chains                               C
8224 C                                                                              C
8225 C          o             o                   o             o                   C
8226 C         /j\           / \             \   / \           / \   /              C
8227 C        /   \         /   \             \ /   \         /   \ /               C
8228 C      j1| o |l        | o |              o| o |         | o |o                C
8229 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
8230 C      \i/   \         /   \ /             /   \         /   \                 C
8231 C       o     k1            o                                                  C
8232 C         (I)          (II)                (III)          (IV)                 C
8233 C                                                                              C
8234 C      eello5_1        eello5_2            eello5_3       eello5_4             C
8235 C                                                                              C
8236 C o denotes a local interaction, vertical lines an electrostatic interaction.  C
8237 C                                                                              C
8238 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8239 cd      if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
8240 cd        eello5=0.0d0
8241 cd        return
8242 cd      endif
8243 cd      write (iout,*)
8244 cd     &   'EELLO5: Contacts have occurred for peptide groups',i,j,
8245 cd     &   ' and',k,l
8246       itk=itortyp(itype(k))
8247       itl=itortyp(itype(l))
8248       itj=itortyp(itype(j))
8249       eello5_1=0.0d0
8250       eello5_2=0.0d0
8251       eello5_3=0.0d0
8252       eello5_4=0.0d0
8253 cd      call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
8254 cd     &   eel5_3_num,eel5_4_num)
8255       do iii=1,2
8256         do kkk=1,5
8257           do lll=1,3
8258             derx(lll,kkk,iii)=0.0d0
8259           enddo
8260         enddo
8261       enddo
8262 cd      eij=facont_hb(jj,i)
8263 cd      ekl=facont_hb(kk,k)
8264 cd      ekont=eij*ekl
8265 cd      write (iout,*)'Contacts have occurred for peptide groups',
8266 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l
8267 cd      goto 1111
8268 C Contribution from the graph I.
8269 cd      write (2,*) 'AEA  ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
8270 cd      write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
8271       call transpose2(EUg(1,1,k),auxmat(1,1))
8272       call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
8273       vv(1)=pizda(1,1)-pizda(2,2)
8274       vv(2)=pizda(1,2)+pizda(2,1)
8275       eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k))
8276      & +0.5d0*scalar2(vv(1),Dtobr2(1,i))
8277 C Explicit gradient in virtual-dihedral angles.
8278       if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1)
8279      & +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k))
8280      & +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
8281       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8282       call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
8283       vv(1)=pizda(1,1)-pizda(2,2)
8284       vv(2)=pizda(1,2)+pizda(2,1)
8285       g_corr5_loc(k-1)=g_corr5_loc(k-1)
8286      & +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k))
8287      & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
8288       call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
8289       vv(1)=pizda(1,1)-pizda(2,2)
8290       vv(2)=pizda(1,2)+pizda(2,1)
8291       if (l.eq.j+1) then
8292         if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1)
8293      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
8294      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
8295       else
8296         if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1)
8297      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
8298      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
8299       endif
8300 C Cartesian gradient
8301       do iii=1,2
8302         do kkk=1,5
8303           do lll=1,3
8304             call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),
8305      &        pizda(1,1))
8306             vv(1)=pizda(1,1)-pizda(2,2)
8307             vv(2)=pizda(1,2)+pizda(2,1)
8308             derx(lll,kkk,iii)=derx(lll,kkk,iii)
8309      &       +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k))
8310      &       +0.5d0*scalar2(vv(1),Dtobr2(1,i))
8311           enddo
8312         enddo
8313       enddo
8314 c      goto 1112
8315 c1111  continue
8316 C Contribution from graph II
8317       call transpose2(EE(1,1,itk),auxmat(1,1))
8318       call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
8319       vv(1)=pizda(1,1)+pizda(2,2)
8320       vv(2)=pizda(2,1)-pizda(1,2)
8321       eello5_2=scalar2(AEAb1(1,2,1),b1(1,itk))
8322      & -0.5d0*scalar2(vv(1),Ctobr(1,k))
8323 C Explicit gradient in virtual-dihedral angles.
8324       g_corr5_loc(k-1)=g_corr5_loc(k-1)
8325      & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
8326       call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
8327       vv(1)=pizda(1,1)+pizda(2,2)
8328       vv(2)=pizda(2,1)-pizda(1,2)
8329       if (l.eq.j+1) then
8330         g_corr5_loc(l-1)=g_corr5_loc(l-1)
8331      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk))
8332      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
8333       else
8334         g_corr5_loc(j-1)=g_corr5_loc(j-1)
8335      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk))
8336      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
8337       endif
8338 C Cartesian gradient
8339       do iii=1,2
8340         do kkk=1,5
8341           do lll=1,3
8342             call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
8343      &        pizda(1,1))
8344             vv(1)=pizda(1,1)+pizda(2,2)
8345             vv(2)=pizda(2,1)-pizda(1,2)
8346             derx(lll,kkk,iii)=derx(lll,kkk,iii)
8347      &       +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,itk))
8348      &       -0.5d0*scalar2(vv(1),Ctobr(1,k))
8349           enddo
8350         enddo
8351       enddo
8352 cd      goto 1112
8353 cd1111  continue
8354       if (l.eq.j+1) then
8355 cd        goto 1110
8356 C Parallel orientation
8357 C Contribution from graph III
8358         call transpose2(EUg(1,1,l),auxmat(1,1))
8359         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
8360         vv(1)=pizda(1,1)-pizda(2,2)
8361         vv(2)=pizda(1,2)+pizda(2,1)
8362         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l))
8363      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j))
8364 C Explicit gradient in virtual-dihedral angles.
8365         g_corr5_loc(j-1)=g_corr5_loc(j-1)
8366      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l))
8367      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
8368         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
8369         vv(1)=pizda(1,1)-pizda(2,2)
8370         vv(2)=pizda(1,2)+pizda(2,1)
8371         g_corr5_loc(k-1)=g_corr5_loc(k-1)
8372      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l))
8373      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
8374         call transpose2(EUgder(1,1,l),auxmat1(1,1))
8375         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
8376         vv(1)=pizda(1,1)-pizda(2,2)
8377         vv(2)=pizda(1,2)+pizda(2,1)
8378         g_corr5_loc(l-1)=g_corr5_loc(l-1)
8379      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l))
8380      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
8381 C Cartesian gradient
8382         do iii=1,2
8383           do kkk=1,5
8384             do lll=1,3
8385               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
8386      &          pizda(1,1))
8387               vv(1)=pizda(1,1)-pizda(2,2)
8388               vv(2)=pizda(1,2)+pizda(2,1)
8389               derx(lll,kkk,iii)=derx(lll,kkk,iii)
8390      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l))
8391      &         +0.5d0*scalar2(vv(1),Dtobr2(1,j))
8392             enddo
8393           enddo
8394         enddo
8395 cd        goto 1112
8396 C Contribution from graph IV
8397 cd1110    continue
8398         call transpose2(EE(1,1,itl),auxmat(1,1))
8399         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
8400         vv(1)=pizda(1,1)+pizda(2,2)
8401         vv(2)=pizda(2,1)-pizda(1,2)
8402         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itl))
8403      &   -0.5d0*scalar2(vv(1),Ctobr(1,l))
8404 C Explicit gradient in virtual-dihedral angles.
8405         g_corr5_loc(l-1)=g_corr5_loc(l-1)
8406      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
8407         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
8408         vv(1)=pizda(1,1)+pizda(2,2)
8409         vv(2)=pizda(2,1)-pizda(1,2)
8410         g_corr5_loc(k-1)=g_corr5_loc(k-1)
8411      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itl))
8412      &   -0.5d0*scalar2(vv(1),Ctobr(1,l)))
8413 C Cartesian gradient
8414         do iii=1,2
8415           do kkk=1,5
8416             do lll=1,3
8417               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
8418      &          pizda(1,1))
8419               vv(1)=pizda(1,1)+pizda(2,2)
8420               vv(2)=pizda(2,1)-pizda(1,2)
8421               derx(lll,kkk,iii)=derx(lll,kkk,iii)
8422      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itl))
8423      &         -0.5d0*scalar2(vv(1),Ctobr(1,l))
8424             enddo
8425           enddo
8426         enddo
8427       else
8428 C Antiparallel orientation
8429 C Contribution from graph III
8430 c        goto 1110
8431         call transpose2(EUg(1,1,j),auxmat(1,1))
8432         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
8433         vv(1)=pizda(1,1)-pizda(2,2)
8434         vv(2)=pizda(1,2)+pizda(2,1)
8435         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j))
8436      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l))
8437 C Explicit gradient in virtual-dihedral angles.
8438         g_corr5_loc(l-1)=g_corr5_loc(l-1)
8439      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j))
8440      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
8441         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
8442         vv(1)=pizda(1,1)-pizda(2,2)
8443         vv(2)=pizda(1,2)+pizda(2,1)
8444         g_corr5_loc(k-1)=g_corr5_loc(k-1)
8445      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j))
8446      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
8447         call transpose2(EUgder(1,1,j),auxmat1(1,1))
8448         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
8449         vv(1)=pizda(1,1)-pizda(2,2)
8450         vv(2)=pizda(1,2)+pizda(2,1)
8451         g_corr5_loc(j-1)=g_corr5_loc(j-1)
8452      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j))
8453      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
8454 C Cartesian gradient
8455         do iii=1,2
8456           do kkk=1,5
8457             do lll=1,3
8458               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
8459      &          pizda(1,1))
8460               vv(1)=pizda(1,1)-pizda(2,2)
8461               vv(2)=pizda(1,2)+pizda(2,1)
8462               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
8463      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j))
8464      &         +0.5d0*scalar2(vv(1),Dtobr2(1,l))
8465             enddo
8466           enddo
8467         enddo
8468 cd        goto 1112
8469 C Contribution from graph IV
8470 1110    continue
8471         call transpose2(EE(1,1,itj),auxmat(1,1))
8472         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
8473         vv(1)=pizda(1,1)+pizda(2,2)
8474         vv(2)=pizda(2,1)-pizda(1,2)
8475         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itj))
8476      &   -0.5d0*scalar2(vv(1),Ctobr(1,j))
8477 C Explicit gradient in virtual-dihedral angles.
8478         g_corr5_loc(j-1)=g_corr5_loc(j-1)
8479      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
8480         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
8481         vv(1)=pizda(1,1)+pizda(2,2)
8482         vv(2)=pizda(2,1)-pizda(1,2)
8483         g_corr5_loc(k-1)=g_corr5_loc(k-1)
8484      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itj))
8485      &   -0.5d0*scalar2(vv(1),Ctobr(1,j)))
8486 C Cartesian gradient
8487         do iii=1,2
8488           do kkk=1,5
8489             do lll=1,3
8490               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
8491      &          pizda(1,1))
8492               vv(1)=pizda(1,1)+pizda(2,2)
8493               vv(2)=pizda(2,1)-pizda(1,2)
8494               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
8495      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itj))
8496      &         -0.5d0*scalar2(vv(1),Ctobr(1,j))
8497             enddo
8498           enddo
8499         enddo
8500       endif
8501 1112  continue
8502       eel5=eello5_1+eello5_2+eello5_3+eello5_4
8503 cd      if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
8504 cd        write (2,*) 'ijkl',i,j,k,l
8505 cd        write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
8506 cd     &     ' eello5_3',eello5_3,' eello5_4',eello5_4
8507 cd      endif
8508 cd      write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
8509 cd      write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
8510 cd      write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
8511 cd      write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
8512       if (j.lt.nres-1) then
8513         j1=j+1
8514         j2=j-1
8515       else
8516         j1=j-1
8517         j2=j-2
8518       endif
8519       if (l.lt.nres-1) then
8520         l1=l+1
8521         l2=l-1
8522       else
8523         l1=l-1
8524         l2=l-2
8525       endif
8526 cd      eij=1.0d0
8527 cd      ekl=1.0d0
8528 cd      ekont=1.0d0
8529 cd      write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
8530 C 2/11/08 AL Gradients over DC's connecting interacting sites will be
8531 C        summed up outside the subrouine as for the other subroutines
8532 C        handling long-range interactions. The old code is commented out
8533 C        with "cgrad" to keep track of changes.
8534       do ll=1,3
8535 cgrad        ggg1(ll)=eel5*g_contij(ll,1)
8536 cgrad        ggg2(ll)=eel5*g_contij(ll,2)
8537         gradcorr5ij=eel5*g_contij(ll,1)+ekont*derx(ll,1,1)
8538         gradcorr5kl=eel5*g_contij(ll,2)+ekont*derx(ll,1,2)
8539 c        write (iout,'(a,3i3,a,5f8.3,2i3,a,5f8.3,a,f8.3)')
8540 c     &   "ecorr5",ll,i,j," derx",derx(ll,2,1),derx(ll,3,1),derx(ll,4,1),
8541 c     &   derx(ll,5,1),k,l," derx",derx(ll,2,2),derx(ll,3,2),
8542 c     &   derx(ll,4,2),derx(ll,5,2)," ekont",ekont
8543 c        write (iout,'(a,3i3,a,3f8.3,2i3,a,3f8.3)')
8544 c     &   "ecorr5",ll,i,j," gradcorr5",g_contij(ll,1),derx(ll,1,1),
8545 c     &   gradcorr5ij,
8546 c     &   k,l," gradcorr5",g_contij(ll,2),derx(ll,1,2),gradcorr5kl
8547 cold        ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
8548 cgrad        ghalf=0.5d0*ggg1(ll)
8549 cd        ghalf=0.0d0
8550         gradcorr5(ll,i)=gradcorr5(ll,i)+ekont*derx(ll,2,1)
8551         gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
8552         gradcorr5(ll,j)=gradcorr5(ll,j)+ekont*derx(ll,4,1)
8553         gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
8554         gradcorr5_long(ll,j)=gradcorr5_long(ll,j)+gradcorr5ij
8555         gradcorr5_long(ll,i)=gradcorr5_long(ll,i)-gradcorr5ij
8556 cold        ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
8557 cgrad        ghalf=0.5d0*ggg2(ll)
8558 cd        ghalf=0.0d0
8559         gradcorr5(ll,k)=gradcorr5(ll,k)+ghalf+ekont*derx(ll,2,2)
8560         gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
8561         gradcorr5(ll,l)=gradcorr5(ll,l)+ghalf+ekont*derx(ll,4,2)
8562         gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
8563         gradcorr5_long(ll,l)=gradcorr5_long(ll,l)+gradcorr5kl
8564         gradcorr5_long(ll,k)=gradcorr5_long(ll,k)-gradcorr5kl
8565       enddo
8566 cd      goto 1112
8567 cgrad      do m=i+1,j-1
8568 cgrad        do ll=1,3
8569 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
8570 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
8571 cgrad        enddo
8572 cgrad      enddo
8573 cgrad      do m=k+1,l-1
8574 cgrad        do ll=1,3
8575 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
8576 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
8577 cgrad        enddo
8578 cgrad      enddo
8579 c1112  continue
8580 cgrad      do m=i+2,j2
8581 cgrad        do ll=1,3
8582 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
8583 cgrad        enddo
8584 cgrad      enddo
8585 cgrad      do m=k+2,l2
8586 cgrad        do ll=1,3
8587 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
8588 cgrad        enddo
8589 cgrad      enddo
8590 cd      do iii=1,nres-3
8591 cd        write (2,*) iii,g_corr5_loc(iii)
8592 cd      enddo
8593       eello5=ekont*eel5
8594 cd      write (2,*) 'ekont',ekont
8595 cd      write (iout,*) 'eello5',ekont*eel5
8596       return
8597       end
8598 c--------------------------------------------------------------------------
8599       double precision function eello6(i,j,k,l,jj,kk)
8600       implicit real*8 (a-h,o-z)
8601       include 'DIMENSIONS'
8602       include 'COMMON.IOUNITS'
8603       include 'COMMON.CHAIN'
8604       include 'COMMON.DERIV'
8605       include 'COMMON.INTERACT'
8606       include 'COMMON.CONTACTS'
8607       include 'COMMON.TORSION'
8608       include 'COMMON.VAR'
8609       include 'COMMON.GEO'
8610       include 'COMMON.FFIELD'
8611       double precision ggg1(3),ggg2(3)
8612 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
8613 cd        eello6=0.0d0
8614 cd        return
8615 cd      endif
8616 cd      write (iout,*)
8617 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
8618 cd     &   ' and',k,l
8619       eello6_1=0.0d0
8620       eello6_2=0.0d0
8621       eello6_3=0.0d0
8622       eello6_4=0.0d0
8623       eello6_5=0.0d0
8624       eello6_6=0.0d0
8625 cd      call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
8626 cd     &   eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
8627       do iii=1,2
8628         do kkk=1,5
8629           do lll=1,3
8630             derx(lll,kkk,iii)=0.0d0
8631           enddo
8632         enddo
8633       enddo
8634 cd      eij=facont_hb(jj,i)
8635 cd      ekl=facont_hb(kk,k)
8636 cd      ekont=eij*ekl
8637 cd      eij=1.0d0
8638 cd      ekl=1.0d0
8639 cd      ekont=1.0d0
8640       if (l.eq.j+1) then
8641         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
8642         eello6_2=eello6_graph1(j,i,l,k,2,.false.)
8643         eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
8644         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
8645         eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
8646         eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
8647       else
8648         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
8649         eello6_2=eello6_graph1(l,k,j,i,2,.true.)
8650         eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
8651         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
8652         if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
8653           eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
8654         else
8655           eello6_5=0.0d0
8656         endif
8657         eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
8658       endif
8659 C If turn contributions are considered, they will be handled separately.
8660       eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
8661 cd      write(iout,*) 'eello6_1',eello6_1!,' eel6_1_num',16*eel6_1_num
8662 cd      write(iout,*) 'eello6_2',eello6_2!,' eel6_2_num',16*eel6_2_num
8663 cd      write(iout,*) 'eello6_3',eello6_3!,' eel6_3_num',16*eel6_3_num
8664 cd      write(iout,*) 'eello6_4',eello6_4!,' eel6_4_num',16*eel6_4_num
8665 cd      write(iout,*) 'eello6_5',eello6_5!,' eel6_5_num',16*eel6_5_num
8666 cd      write(iout,*) 'eello6_6',eello6_6!,' eel6_6_num',16*eel6_6_num
8667 cd      goto 1112
8668       if (j.lt.nres-1) then
8669         j1=j+1
8670         j2=j-1
8671       else
8672         j1=j-1
8673         j2=j-2
8674       endif
8675       if (l.lt.nres-1) then
8676         l1=l+1
8677         l2=l-1
8678       else
8679         l1=l-1
8680         l2=l-2
8681       endif
8682       do ll=1,3
8683 cgrad        ggg1(ll)=eel6*g_contij(ll,1)
8684 cgrad        ggg2(ll)=eel6*g_contij(ll,2)
8685 cold        ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
8686 cgrad        ghalf=0.5d0*ggg1(ll)
8687 cd        ghalf=0.0d0
8688         gradcorr6ij=eel6*g_contij(ll,1)+ekont*derx(ll,1,1)
8689         gradcorr6kl=eel6*g_contij(ll,2)+ekont*derx(ll,1,2)
8690         gradcorr6(ll,i)=gradcorr6(ll,i)+ekont*derx(ll,2,1)
8691         gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
8692         gradcorr6(ll,j)=gradcorr6(ll,j)+ekont*derx(ll,4,1)
8693         gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
8694         gradcorr6_long(ll,j)=gradcorr6_long(ll,j)+gradcorr6ij
8695         gradcorr6_long(ll,i)=gradcorr6_long(ll,i)-gradcorr6ij
8696 cgrad        ghalf=0.5d0*ggg2(ll)
8697 cold        ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
8698 cd        ghalf=0.0d0
8699         gradcorr6(ll,k)=gradcorr6(ll,k)+ekont*derx(ll,2,2)
8700         gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
8701         gradcorr6(ll,l)=gradcorr6(ll,l)+ekont*derx(ll,4,2)
8702         gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
8703         gradcorr6_long(ll,l)=gradcorr6_long(ll,l)+gradcorr6kl
8704         gradcorr6_long(ll,k)=gradcorr6_long(ll,k)-gradcorr6kl
8705       enddo
8706 cd      goto 1112
8707 cgrad      do m=i+1,j-1
8708 cgrad        do ll=1,3
8709 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
8710 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
8711 cgrad        enddo
8712 cgrad      enddo
8713 cgrad      do m=k+1,l-1
8714 cgrad        do ll=1,3
8715 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
8716 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
8717 cgrad        enddo
8718 cgrad      enddo
8719 cgrad1112  continue
8720 cgrad      do m=i+2,j2
8721 cgrad        do ll=1,3
8722 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
8723 cgrad        enddo
8724 cgrad      enddo
8725 cgrad      do m=k+2,l2
8726 cgrad        do ll=1,3
8727 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
8728 cgrad        enddo
8729 cgrad      enddo
8730 cd      do iii=1,nres-3
8731 cd        write (2,*) iii,g_corr6_loc(iii)
8732 cd      enddo
8733       eello6=ekont*eel6
8734 cd      write (2,*) 'ekont',ekont
8735 cd      write (iout,*) 'eello6',ekont*eel6
8736       return
8737       end
8738 c--------------------------------------------------------------------------
8739       double precision function eello6_graph1(i,j,k,l,imat,swap)
8740       implicit real*8 (a-h,o-z)
8741       include 'DIMENSIONS'
8742       include 'COMMON.IOUNITS'
8743       include 'COMMON.CHAIN'
8744       include 'COMMON.DERIV'
8745       include 'COMMON.INTERACT'
8746       include 'COMMON.CONTACTS'
8747       include 'COMMON.TORSION'
8748       include 'COMMON.VAR'
8749       include 'COMMON.GEO'
8750       double precision vv(2),vv1(2),pizda(2,2),auxmat(2,2),pizda1(2,2)
8751       logical swap
8752       logical lprn
8753       common /kutas/ lprn
8754 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8755 C                                                                              C
8756 C      Parallel       Antiparallel                                             C
8757 C                                                                              C
8758 C          o             o                                                     C
8759 C         /l\           /j\                                                    C
8760 C        /   \         /   \                                                   C
8761 C       /| o |         | o |\                                                  C
8762 C     \ j|/k\|  /   \  |/k\|l /                                                C
8763 C      \ /   \ /     \ /   \ /                                                 C
8764 C       o     o       o     o                                                  C
8765 C       i             i                                                        C
8766 C                                                                              C
8767 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8768       itk=itortyp(itype(k))
8769       s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
8770       s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
8771       s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
8772       call transpose2(EUgC(1,1,k),auxmat(1,1))
8773       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
8774       vv1(1)=pizda1(1,1)-pizda1(2,2)
8775       vv1(2)=pizda1(1,2)+pizda1(2,1)
8776       s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
8777       vv(1)=AEAb1(1,2,imat)*b1(1,itk)-AEAb1(2,2,imat)*b1(2,itk)
8778       vv(2)=AEAb1(1,2,imat)*b1(2,itk)+AEAb1(2,2,imat)*b1(1,itk)
8779       s5=scalar2(vv(1),Dtobr2(1,i))
8780 cd      write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
8781       eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
8782       if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1)
8783      & -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i))
8784      & -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k))
8785      & +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k))
8786      & +0.5d0*scalar2(vv1(1),Dtobr2der(1,i))
8787      & +scalar2(vv(1),Dtobr2der(1,i)))
8788       call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
8789       vv1(1)=pizda1(1,1)-pizda1(2,2)
8790       vv1(2)=pizda1(1,2)+pizda1(2,1)
8791       vv(1)=AEAb1derg(1,2,imat)*b1(1,itk)-AEAb1derg(2,2,imat)*b1(2,itk)
8792       vv(2)=AEAb1derg(1,2,imat)*b1(2,itk)+AEAb1derg(2,2,imat)*b1(1,itk)
8793       if (l.eq.j+1) then
8794         g_corr6_loc(l-1)=g_corr6_loc(l-1)
8795      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
8796      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
8797      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
8798      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
8799       else
8800         g_corr6_loc(j-1)=g_corr6_loc(j-1)
8801      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
8802      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
8803      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
8804      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
8805       endif
8806       call transpose2(EUgCder(1,1,k),auxmat(1,1))
8807       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
8808       vv1(1)=pizda1(1,1)-pizda1(2,2)
8809       vv1(2)=pizda1(1,2)+pizda1(2,1)
8810       if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1)
8811      & +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k))
8812      & +scalar2(AEAb2(1,1,imat),CUgb2der(1,k))
8813      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
8814       do iii=1,2
8815         if (swap) then
8816           ind=3-iii
8817         else
8818           ind=iii
8819         endif
8820         do kkk=1,5
8821           do lll=1,3
8822             s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
8823             s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
8824             s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
8825             call transpose2(EUgC(1,1,k),auxmat(1,1))
8826             call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
8827      &        pizda1(1,1))
8828             vv1(1)=pizda1(1,1)-pizda1(2,2)
8829             vv1(2)=pizda1(1,2)+pizda1(2,1)
8830             s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
8831             vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,itk)
8832      &       -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,itk)
8833             vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,itk)
8834      &       +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,itk)
8835             s5=scalar2(vv(1),Dtobr2(1,i))
8836             derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
8837           enddo
8838         enddo
8839       enddo
8840       return
8841       end
8842 c----------------------------------------------------------------------------
8843       double precision function eello6_graph2(i,j,k,l,jj,kk,swap)
8844       implicit real*8 (a-h,o-z)
8845       include 'DIMENSIONS'
8846       include 'COMMON.IOUNITS'
8847       include 'COMMON.CHAIN'
8848       include 'COMMON.DERIV'
8849       include 'COMMON.INTERACT'
8850       include 'COMMON.CONTACTS'
8851       include 'COMMON.TORSION'
8852       include 'COMMON.VAR'
8853       include 'COMMON.GEO'
8854       logical swap
8855       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
8856      & auxvec1(2),auxvec2(2),auxmat1(2,2)
8857       logical lprn
8858       common /kutas/ lprn
8859 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8860 C                                                                              C
8861 C      Parallel       Antiparallel                                             C
8862 C                                                                              C
8863 C          o             o                                                     C
8864 C     \   /l\           /j\   /                                                C
8865 C      \ /   \         /   \ /                                                 C
8866 C       o| o |         | o |o                                                  C
8867 C     \ j|/k\|      \  |/k\|l                                                  C
8868 C      \ /   \       \ /   \                                                   C
8869 C       o             o                                                        C
8870 C       i             i                                                        C
8871 C                                                                              C
8872 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8873 cd      write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
8874 C AL 7/4/01 s1 would occur in the sixth-order moment,
8875 C           but not in a cluster cumulant
8876 #ifdef MOMENT
8877       s1=dip(1,jj,i)*dip(1,kk,k)
8878 #endif
8879       call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
8880       s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
8881       call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
8882       s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
8883       call transpose2(EUg(1,1,k),auxmat(1,1))
8884       call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
8885       vv(1)=pizda(1,1)-pizda(2,2)
8886       vv(2)=pizda(1,2)+pizda(2,1)
8887       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8888 cd      write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
8889 #ifdef MOMENT
8890       eello6_graph2=-(s1+s2+s3+s4)
8891 #else
8892       eello6_graph2=-(s2+s3+s4)
8893 #endif
8894 c      eello6_graph2=-s3
8895 C Derivatives in gamma(i-1)
8896       if (i.gt.1) then
8897 #ifdef MOMENT
8898         s1=dipderg(1,jj,i)*dip(1,kk,k)
8899 #endif
8900         s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
8901         call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
8902         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8903         s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
8904 #ifdef MOMENT
8905         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
8906 #else
8907         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
8908 #endif
8909 c        g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
8910       endif
8911 C Derivatives in gamma(k-1)
8912 #ifdef MOMENT
8913       s1=dip(1,jj,i)*dipderg(1,kk,k)
8914 #endif
8915       call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
8916       s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8917       call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
8918       s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8919       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8920       call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
8921       vv(1)=pizda(1,1)-pizda(2,2)
8922       vv(2)=pizda(1,2)+pizda(2,1)
8923       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8924 #ifdef MOMENT
8925       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
8926 #else
8927       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
8928 #endif
8929 c      g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
8930 C Derivatives in gamma(j-1) or gamma(l-1)
8931       if (j.gt.1) then
8932 #ifdef MOMENT
8933         s1=dipderg(3,jj,i)*dip(1,kk,k)
8934 #endif
8935         call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
8936         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8937         s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
8938         call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
8939         vv(1)=pizda(1,1)-pizda(2,2)
8940         vv(2)=pizda(1,2)+pizda(2,1)
8941         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8942 #ifdef MOMENT
8943         if (swap) then
8944           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
8945         else
8946           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
8947         endif
8948 #endif
8949         g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
8950 c        g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
8951       endif
8952 C Derivatives in gamma(l-1) or gamma(j-1)
8953       if (l.gt.1) then
8954 #ifdef MOMENT
8955         s1=dip(1,jj,i)*dipderg(3,kk,k)
8956 #endif
8957         call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
8958         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8959         call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
8960         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8961         call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
8962         vv(1)=pizda(1,1)-pizda(2,2)
8963         vv(2)=pizda(1,2)+pizda(2,1)
8964         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8965 #ifdef MOMENT
8966         if (swap) then
8967           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
8968         else
8969           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
8970         endif
8971 #endif
8972         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
8973 c        g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
8974       endif
8975 C Cartesian derivatives.
8976       if (lprn) then
8977         write (2,*) 'In eello6_graph2'
8978         do iii=1,2
8979           write (2,*) 'iii=',iii
8980           do kkk=1,5
8981             write (2,*) 'kkk=',kkk
8982             do jjj=1,2
8983               write (2,'(3(2f10.5),5x)')
8984      &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
8985             enddo
8986           enddo
8987         enddo
8988       endif
8989       do iii=1,2
8990         do kkk=1,5
8991           do lll=1,3
8992 #ifdef MOMENT
8993             if (iii.eq.1) then
8994               s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
8995             else
8996               s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
8997             endif
8998 #endif
8999             call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),
9000      &        auxvec(1))
9001             s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
9002             call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),
9003      &        auxvec(1))
9004             s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
9005             call transpose2(EUg(1,1,k),auxmat(1,1))
9006             call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),
9007      &        pizda(1,1))
9008             vv(1)=pizda(1,1)-pizda(2,2)
9009             vv(2)=pizda(1,2)+pizda(2,1)
9010             s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
9011 cd            write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
9012 #ifdef MOMENT
9013             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
9014 #else
9015             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
9016 #endif
9017             if (swap) then
9018               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
9019             else
9020               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
9021             endif
9022           enddo
9023         enddo
9024       enddo
9025       return
9026       end
9027 c----------------------------------------------------------------------------
9028       double precision function eello6_graph3(i,j,k,l,jj,kk,swap)
9029       implicit real*8 (a-h,o-z)
9030       include 'DIMENSIONS'
9031       include 'COMMON.IOUNITS'
9032       include 'COMMON.CHAIN'
9033       include 'COMMON.DERIV'
9034       include 'COMMON.INTERACT'
9035       include 'COMMON.CONTACTS'
9036       include 'COMMON.TORSION'
9037       include 'COMMON.VAR'
9038       include 'COMMON.GEO'
9039       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2)
9040       logical swap
9041 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9042 C                                                                              C
9043 C      Parallel       Antiparallel                                             C
9044 C                                                                              C
9045 C          o             o                                                     C
9046 C         /l\   /   \   /j\                                                    C
9047 C        /   \ /     \ /   \                                                   C
9048 C       /| o |o       o| o |\                                                  C
9049 C       j|/k\|  /      |/k\|l /                                                C
9050 C        /   \ /       /   \ /                                                 C
9051 C       /     o       /     o                                                  C
9052 C       i             i                                                        C
9053 C                                                                              C
9054 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9055 C
9056 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
9057 C           energy moment and not to the cluster cumulant.
9058       iti=itortyp(itype(i))
9059       if (j.lt.nres-1) then
9060         itj1=itortyp(itype(j+1))
9061       else
9062         itj1=ntortyp
9063       endif
9064       itk=itortyp(itype(k))
9065       itk1=itortyp(itype(k+1))
9066       if (l.lt.nres-1) then
9067         itl1=itortyp(itype(l+1))
9068       else
9069         itl1=ntortyp
9070       endif
9071 #ifdef MOMENT
9072       s1=dip(4,jj,i)*dip(4,kk,k)
9073 #endif
9074       call matvec2(AECA(1,1,1),b1(1,itk1),auxvec(1))
9075       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
9076       call matvec2(AECA(1,1,2),b1(1,itl1),auxvec(1))
9077       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
9078       call transpose2(EE(1,1,itk),auxmat(1,1))
9079       call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
9080       vv(1)=pizda(1,1)+pizda(2,2)
9081       vv(2)=pizda(2,1)-pizda(1,2)
9082       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
9083 cd      write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4,
9084 cd     & "sum",-(s2+s3+s4)
9085 #ifdef MOMENT
9086       eello6_graph3=-(s1+s2+s3+s4)
9087 #else
9088       eello6_graph3=-(s2+s3+s4)
9089 #endif
9090 c      eello6_graph3=-s4
9091 C Derivatives in gamma(k-1)
9092       call matvec2(AECAderg(1,1,2),b1(1,itl1),auxvec(1))
9093       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
9094       s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
9095       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
9096 C Derivatives in gamma(l-1)
9097       call matvec2(AECAderg(1,1,1),b1(1,itk1),auxvec(1))
9098       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
9099       call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
9100       vv(1)=pizda(1,1)+pizda(2,2)
9101       vv(2)=pizda(2,1)-pizda(1,2)
9102       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
9103       g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
9104 C Cartesian derivatives.
9105       do iii=1,2
9106         do kkk=1,5
9107           do lll=1,3
9108 #ifdef MOMENT
9109             if (iii.eq.1) then
9110               s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
9111             else
9112               s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
9113             endif
9114 #endif
9115             call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
9116      &        auxvec(1))
9117             s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
9118             call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,itl1),
9119      &        auxvec(1))
9120             s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
9121             call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),
9122      &        pizda(1,1))
9123             vv(1)=pizda(1,1)+pizda(2,2)
9124             vv(2)=pizda(2,1)-pizda(1,2)
9125             s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
9126 #ifdef MOMENT
9127             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
9128 #else
9129             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
9130 #endif
9131             if (swap) then
9132               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
9133             else
9134               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
9135             endif
9136 c            derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
9137           enddo
9138         enddo
9139       enddo
9140       return
9141       end
9142 c----------------------------------------------------------------------------
9143       double precision function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
9144       implicit real*8 (a-h,o-z)
9145       include 'DIMENSIONS'
9146       include 'COMMON.IOUNITS'
9147       include 'COMMON.CHAIN'
9148       include 'COMMON.DERIV'
9149       include 'COMMON.INTERACT'
9150       include 'COMMON.CONTACTS'
9151       include 'COMMON.TORSION'
9152       include 'COMMON.VAR'
9153       include 'COMMON.GEO'
9154       include 'COMMON.FFIELD'
9155       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
9156      & auxvec1(2),auxmat1(2,2)
9157       logical swap
9158 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9159 C                                                                              C
9160 C      Parallel       Antiparallel                                             C
9161 C                                                                              C
9162 C          o             o                                                     C
9163 C         /l\   /   \   /j\                                                    C
9164 C        /   \ /     \ /   \                                                   C
9165 C       /| o |o       o| o |\                                                  C
9166 C     \ j|/k\|      \  |/k\|l                                                  C
9167 C      \ /   \       \ /   \                                                   C
9168 C       o     \       o     \                                                  C
9169 C       i             i                                                        C
9170 C                                                                              C
9171 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9172 C
9173 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
9174 C           energy moment and not to the cluster cumulant.
9175 cd      write (2,*) 'eello_graph4: wturn6',wturn6
9176       iti=itortyp(itype(i))
9177       itj=itortyp(itype(j))
9178       if (j.lt.nres-1) then
9179         itj1=itortyp(itype(j+1))
9180       else
9181         itj1=ntortyp
9182       endif
9183       itk=itortyp(itype(k))
9184       if (k.lt.nres-1) then
9185         itk1=itortyp(itype(k+1))
9186       else
9187         itk1=ntortyp
9188       endif
9189       itl=itortyp(itype(l))
9190       if (l.lt.nres-1) then
9191         itl1=itortyp(itype(l+1))
9192       else
9193         itl1=ntortyp
9194       endif
9195 cd      write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
9196 cd      write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
9197 cd     & ' itl',itl,' itl1',itl1
9198 #ifdef MOMENT
9199       if (imat.eq.1) then
9200         s1=dip(3,jj,i)*dip(3,kk,k)
9201       else
9202         s1=dip(2,jj,j)*dip(2,kk,l)
9203       endif
9204 #endif
9205       call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
9206       s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
9207       if (j.eq.l+1) then
9208         call matvec2(ADtEA1(1,1,3-imat),b1(1,itj1),auxvec1(1))
9209         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
9210       else
9211         call matvec2(ADtEA1(1,1,3-imat),b1(1,itl1),auxvec1(1))
9212         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
9213       endif
9214       call transpose2(EUg(1,1,k),auxmat(1,1))
9215       call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
9216       vv(1)=pizda(1,1)-pizda(2,2)
9217       vv(2)=pizda(2,1)+pizda(1,2)
9218       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9219 cd      write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
9220 #ifdef MOMENT
9221       eello6_graph4=-(s1+s2+s3+s4)
9222 #else
9223       eello6_graph4=-(s2+s3+s4)
9224 #endif
9225 C Derivatives in gamma(i-1)
9226       if (i.gt.1) then
9227 #ifdef MOMENT
9228         if (imat.eq.1) then
9229           s1=dipderg(2,jj,i)*dip(3,kk,k)
9230         else
9231           s1=dipderg(4,jj,j)*dip(2,kk,l)
9232         endif
9233 #endif
9234         s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
9235         if (j.eq.l+1) then
9236           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itj1),auxvec1(1))
9237           s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
9238         else
9239           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itl1),auxvec1(1))
9240           s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
9241         endif
9242         s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
9243         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
9244 cd          write (2,*) 'turn6 derivatives'
9245 #ifdef MOMENT
9246           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
9247 #else
9248           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
9249 #endif
9250         else
9251 #ifdef MOMENT
9252           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
9253 #else
9254           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
9255 #endif
9256         endif
9257       endif
9258 C Derivatives in gamma(k-1)
9259 #ifdef MOMENT
9260       if (imat.eq.1) then
9261         s1=dip(3,jj,i)*dipderg(2,kk,k)
9262       else
9263         s1=dip(2,jj,j)*dipderg(4,kk,l)
9264       endif
9265 #endif
9266       call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
9267       s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
9268       if (j.eq.l+1) then
9269         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itj1),auxvec1(1))
9270         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
9271       else
9272         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itl1),auxvec1(1))
9273         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
9274       endif
9275       call transpose2(EUgder(1,1,k),auxmat1(1,1))
9276       call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
9277       vv(1)=pizda(1,1)-pizda(2,2)
9278       vv(2)=pizda(2,1)+pizda(1,2)
9279       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9280       if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
9281 #ifdef MOMENT
9282         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
9283 #else
9284         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
9285 #endif
9286       else
9287 #ifdef MOMENT
9288         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
9289 #else
9290         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
9291 #endif
9292       endif
9293 C Derivatives in gamma(j-1) or gamma(l-1)
9294       if (l.eq.j+1 .and. l.gt.1) then
9295         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
9296         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
9297         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
9298         vv(1)=pizda(1,1)-pizda(2,2)
9299         vv(2)=pizda(2,1)+pizda(1,2)
9300         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9301         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
9302       else if (j.gt.1) then
9303         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
9304         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
9305         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
9306         vv(1)=pizda(1,1)-pizda(2,2)
9307         vv(2)=pizda(2,1)+pizda(1,2)
9308         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9309         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
9310           gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
9311         else
9312           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
9313         endif
9314       endif
9315 C Cartesian derivatives.
9316       do iii=1,2
9317         do kkk=1,5
9318           do lll=1,3
9319 #ifdef MOMENT
9320             if (iii.eq.1) then
9321               if (imat.eq.1) then
9322                 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
9323               else
9324                 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
9325               endif
9326             else
9327               if (imat.eq.1) then
9328                 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
9329               else
9330                 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
9331               endif
9332             endif
9333 #endif
9334             call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),
9335      &        auxvec(1))
9336             s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
9337             if (j.eq.l+1) then
9338               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
9339      &          b1(1,itj1),auxvec(1))
9340               s3=-0.5d0*scalar2(b1(1,itj),auxvec(1))
9341             else
9342               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
9343      &          b1(1,itl1),auxvec(1))
9344               s3=-0.5d0*scalar2(b1(1,itl),auxvec(1))
9345             endif
9346             call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
9347      &        pizda(1,1))
9348             vv(1)=pizda(1,1)-pizda(2,2)
9349             vv(2)=pizda(2,1)+pizda(1,2)
9350             s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9351             if (swap) then
9352               if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
9353 #ifdef MOMENT
9354                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
9355      &             -(s1+s2+s4)
9356 #else
9357                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
9358      &             -(s2+s4)
9359 #endif
9360                 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
9361               else
9362 #ifdef MOMENT
9363                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
9364 #else
9365                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
9366 #endif
9367                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
9368               endif
9369             else
9370 #ifdef MOMENT
9371               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
9372 #else
9373               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
9374 #endif
9375               if (l.eq.j+1) then
9376                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
9377               else
9378                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
9379               endif
9380             endif
9381           enddo
9382         enddo
9383       enddo
9384       return
9385       end
9386 c----------------------------------------------------------------------------
9387       double precision function eello_turn6(i,jj,kk)
9388       implicit real*8 (a-h,o-z)
9389       include 'DIMENSIONS'
9390       include 'COMMON.IOUNITS'
9391       include 'COMMON.CHAIN'
9392       include 'COMMON.DERIV'
9393       include 'COMMON.INTERACT'
9394       include 'COMMON.CONTACTS'
9395       include 'COMMON.TORSION'
9396       include 'COMMON.VAR'
9397       include 'COMMON.GEO'
9398       double precision vtemp1(2),vtemp2(2),vtemp3(2),vtemp4(2),
9399      &  atemp(2,2),auxmat(2,2),achuj_temp(2,2),gtemp(2,2),gvec(2),
9400      &  ggg1(3),ggg2(3)
9401       double precision vtemp1d(2),vtemp2d(2),vtemp3d(2),vtemp4d(2),
9402      &  atempd(2,2),auxmatd(2,2),achuj_tempd(2,2),gtempd(2,2),gvecd(2)
9403 C 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
9404 C           the respective energy moment and not to the cluster cumulant.
9405       s1=0.0d0
9406       s8=0.0d0
9407       s13=0.0d0
9408 c
9409       eello_turn6=0.0d0
9410       j=i+4
9411       k=i+1
9412       l=i+3
9413       iti=itortyp(itype(i))
9414       itk=itortyp(itype(k))
9415       itk1=itortyp(itype(k+1))
9416       itl=itortyp(itype(l))
9417       itj=itortyp(itype(j))
9418 cd      write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
9419 cd      write (2,*) 'i',i,' k',k,' j',j,' l',l
9420 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
9421 cd        eello6=0.0d0
9422 cd        return
9423 cd      endif
9424 cd      write (iout,*)
9425 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
9426 cd     &   ' and',k,l
9427 cd      call checkint_turn6(i,jj,kk,eel_turn6_num)
9428       do iii=1,2
9429         do kkk=1,5
9430           do lll=1,3
9431             derx_turn(lll,kkk,iii)=0.0d0
9432           enddo
9433         enddo
9434       enddo
9435 cd      eij=1.0d0
9436 cd      ekl=1.0d0
9437 cd      ekont=1.0d0
9438       eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
9439 cd      eello6_5=0.0d0
9440 cd      write (2,*) 'eello6_5',eello6_5
9441 #ifdef MOMENT
9442       call transpose2(AEA(1,1,1),auxmat(1,1))
9443       call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
9444       ss1=scalar2(Ub2(1,i+2),b1(1,itl))
9445       s1 = (auxmat(1,1)+auxmat(2,2))*ss1
9446 #endif
9447       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
9448       call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
9449       s2 = scalar2(b1(1,itk),vtemp1(1))
9450 #ifdef MOMENT
9451       call transpose2(AEA(1,1,2),atemp(1,1))
9452       call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
9453       call matvec2(Ug2(1,1,i+2),dd(1,1,itk1),vtemp2(1))
9454       s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
9455 #endif
9456       call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
9457       call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
9458       s12 = scalar2(Ub2(1,i+2),vtemp3(1))
9459 #ifdef MOMENT
9460       call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
9461       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
9462       call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
9463       call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
9464       ss13 = scalar2(b1(1,itk),vtemp4(1))
9465       s13 = (gtemp(1,1)+gtemp(2,2))*ss13
9466 #endif
9467 c      write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
9468 c      s1=0.0d0
9469 c      s2=0.0d0
9470 c      s8=0.0d0
9471 c      s12=0.0d0
9472 c      s13=0.0d0
9473       eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
9474 C Derivatives in gamma(i+2)
9475       s1d =0.0d0
9476       s8d =0.0d0
9477 #ifdef MOMENT
9478       call transpose2(AEA(1,1,1),auxmatd(1,1))
9479       call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
9480       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
9481       call transpose2(AEAderg(1,1,2),atempd(1,1))
9482       call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
9483       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
9484 #endif
9485       call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
9486       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
9487       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
9488 c      s1d=0.0d0
9489 c      s2d=0.0d0
9490 c      s8d=0.0d0
9491 c      s12d=0.0d0
9492 c      s13d=0.0d0
9493       gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
9494 C Derivatives in gamma(i+3)
9495 #ifdef MOMENT
9496       call transpose2(AEA(1,1,1),auxmatd(1,1))
9497       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
9498       ss1d=scalar2(Ub2der(1,i+2),b1(1,itl))
9499       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
9500 #endif
9501       call matvec2(EUgder(1,1,i+2),b1(1,itl),vtemp1d(1))
9502       call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
9503       s2d = scalar2(b1(1,itk),vtemp1d(1))
9504 #ifdef MOMENT
9505       call matvec2(Ug2der(1,1,i+2),dd(1,1,itk1),vtemp2d(1))
9506       s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2d(1))
9507 #endif
9508       s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
9509 #ifdef MOMENT
9510       call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
9511       call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
9512       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
9513 #endif
9514 c      s1d=0.0d0
9515 c      s2d=0.0d0
9516 c      s8d=0.0d0
9517 c      s12d=0.0d0
9518 c      s13d=0.0d0
9519 #ifdef MOMENT
9520       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
9521      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
9522 #else
9523       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
9524      &               -0.5d0*ekont*(s2d+s12d)
9525 #endif
9526 C Derivatives in gamma(i+4)
9527       call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
9528       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
9529       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
9530 #ifdef MOMENT
9531       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
9532       call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
9533       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
9534 #endif
9535 c      s1d=0.0d0
9536 c      s2d=0.0d0
9537 c      s8d=0.0d0
9538 C      s12d=0.0d0
9539 c      s13d=0.0d0
9540 #ifdef MOMENT
9541       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
9542 #else
9543       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
9544 #endif
9545 C Derivatives in gamma(i+5)
9546 #ifdef MOMENT
9547       call transpose2(AEAderg(1,1,1),auxmatd(1,1))
9548       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
9549       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
9550 #endif
9551       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1d(1))
9552       call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
9553       s2d = scalar2(b1(1,itk),vtemp1d(1))
9554 #ifdef MOMENT
9555       call transpose2(AEA(1,1,2),atempd(1,1))
9556       call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
9557       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
9558 #endif
9559       call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
9560       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
9561 #ifdef MOMENT
9562       call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
9563       ss13d = scalar2(b1(1,itk),vtemp4d(1))
9564       s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
9565 #endif
9566 c      s1d=0.0d0
9567 c      s2d=0.0d0
9568 c      s8d=0.0d0
9569 c      s12d=0.0d0
9570 c      s13d=0.0d0
9571 #ifdef MOMENT
9572       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
9573      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
9574 #else
9575       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
9576      &               -0.5d0*ekont*(s2d+s12d)
9577 #endif
9578 C Cartesian derivatives
9579       do iii=1,2
9580         do kkk=1,5
9581           do lll=1,3
9582 #ifdef MOMENT
9583             call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
9584             call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
9585             s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
9586 #endif
9587             call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
9588             call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),
9589      &          vtemp1d(1))
9590             s2d = scalar2(b1(1,itk),vtemp1d(1))
9591 #ifdef MOMENT
9592             call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
9593             call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
9594             s8d = -(atempd(1,1)+atempd(2,2))*
9595      &           scalar2(cc(1,1,itl),vtemp2(1))
9596 #endif
9597             call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),
9598      &           auxmatd(1,1))
9599             call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
9600             s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
9601 c      s1d=0.0d0
9602 c      s2d=0.0d0
9603 c      s8d=0.0d0
9604 c      s12d=0.0d0
9605 c      s13d=0.0d0
9606 #ifdef MOMENT
9607             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
9608      &        - 0.5d0*(s1d+s2d)
9609 #else
9610             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
9611      &        - 0.5d0*s2d
9612 #endif
9613 #ifdef MOMENT
9614             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
9615      &        - 0.5d0*(s8d+s12d)
9616 #else
9617             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
9618      &        - 0.5d0*s12d
9619 #endif
9620           enddo
9621         enddo
9622       enddo
9623 #ifdef MOMENT
9624       do kkk=1,5
9625         do lll=1,3
9626           call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),
9627      &      achuj_tempd(1,1))
9628           call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
9629           call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
9630           s13d=(gtempd(1,1)+gtempd(2,2))*ss13
9631           derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
9632           call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),
9633      &      vtemp4d(1))
9634           ss13d = scalar2(b1(1,itk),vtemp4d(1))
9635           s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
9636           derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
9637         enddo
9638       enddo
9639 #endif
9640 cd      write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
9641 cd     &  16*eel_turn6_num
9642 cd      goto 1112
9643       if (j.lt.nres-1) then
9644         j1=j+1
9645         j2=j-1
9646       else
9647         j1=j-1
9648         j2=j-2
9649       endif
9650       if (l.lt.nres-1) then
9651         l1=l+1
9652         l2=l-1
9653       else
9654         l1=l-1
9655         l2=l-2
9656       endif
9657       do ll=1,3
9658 cgrad        ggg1(ll)=eel_turn6*g_contij(ll,1)
9659 cgrad        ggg2(ll)=eel_turn6*g_contij(ll,2)
9660 cgrad        ghalf=0.5d0*ggg1(ll)
9661 cd        ghalf=0.0d0
9662         gturn6ij=eel_turn6*g_contij(ll,1)+ekont*derx_turn(ll,1,1)
9663         gturn6kl=eel_turn6*g_contij(ll,2)+ekont*derx_turn(ll,1,2)
9664         gcorr6_turn(ll,i)=gcorr6_turn(ll,i)!+ghalf
9665      &    +ekont*derx_turn(ll,2,1)
9666         gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
9667         gcorr6_turn(ll,j)=gcorr6_turn(ll,j)!+ghalf
9668      &    +ekont*derx_turn(ll,4,1)
9669         gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
9670         gcorr6_turn_long(ll,j)=gcorr6_turn_long(ll,j)+gturn6ij
9671         gcorr6_turn_long(ll,i)=gcorr6_turn_long(ll,i)-gturn6ij
9672 cgrad        ghalf=0.5d0*ggg2(ll)
9673 cd        ghalf=0.0d0
9674         gcorr6_turn(ll,k)=gcorr6_turn(ll,k)!+ghalf
9675      &    +ekont*derx_turn(ll,2,2)
9676         gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
9677         gcorr6_turn(ll,l)=gcorr6_turn(ll,l)!+ghalf
9678      &    +ekont*derx_turn(ll,4,2)
9679         gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
9680         gcorr6_turn_long(ll,l)=gcorr6_turn_long(ll,l)+gturn6kl
9681         gcorr6_turn_long(ll,k)=gcorr6_turn_long(ll,k)-gturn6kl
9682       enddo
9683 cd      goto 1112
9684 cgrad      do m=i+1,j-1
9685 cgrad        do ll=1,3
9686 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
9687 cgrad        enddo
9688 cgrad      enddo
9689 cgrad      do m=k+1,l-1
9690 cgrad        do ll=1,3
9691 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
9692 cgrad        enddo
9693 cgrad      enddo
9694 cgrad1112  continue
9695 cgrad      do m=i+2,j2
9696 cgrad        do ll=1,3
9697 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
9698 cgrad        enddo
9699 cgrad      enddo
9700 cgrad      do m=k+2,l2
9701 cgrad        do ll=1,3
9702 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
9703 cgrad        enddo
9704 cgrad      enddo
9705 cd      do iii=1,nres-3
9706 cd        write (2,*) iii,g_corr6_loc(iii)
9707 cd      enddo
9708       eello_turn6=ekont*eel_turn6
9709 cd      write (2,*) 'ekont',ekont
9710 cd      write (2,*) 'eel_turn6',ekont*eel_turn6
9711       return
9712       end
9713
9714 C-----------------------------------------------------------------------------
9715       double precision function scalar(u,v)
9716 !DIR$ INLINEALWAYS scalar
9717 #ifndef OSF
9718 cDEC$ ATTRIBUTES FORCEINLINE::scalar
9719 #endif
9720       implicit none
9721       double precision u(3),v(3)
9722 cd      double precision sc
9723 cd      integer i
9724 cd      sc=0.0d0
9725 cd      do i=1,3
9726 cd        sc=sc+u(i)*v(i)
9727 cd      enddo
9728 cd      scalar=sc
9729
9730       scalar=u(1)*v(1)+u(2)*v(2)+u(3)*v(3)
9731       return
9732       end
9733 crc-------------------------------------------------
9734       SUBROUTINE MATVEC2(A1,V1,V2)
9735 !DIR$ INLINEALWAYS MATVEC2
9736 #ifndef OSF
9737 cDEC$ ATTRIBUTES FORCEINLINE::MATVEC2
9738 #endif
9739       implicit real*8 (a-h,o-z)
9740       include 'DIMENSIONS'
9741       DIMENSION A1(2,2),V1(2),V2(2)
9742 c      DO 1 I=1,2
9743 c        VI=0.0
9744 c        DO 3 K=1,2
9745 c    3     VI=VI+A1(I,K)*V1(K)
9746 c        Vaux(I)=VI
9747 c    1 CONTINUE
9748
9749       vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
9750       vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
9751
9752       v2(1)=vaux1
9753       v2(2)=vaux2
9754       END
9755 C---------------------------------------
9756       SUBROUTINE MATMAT2(A1,A2,A3)
9757 #ifndef OSF
9758 cDEC$ ATTRIBUTES FORCEINLINE::MATMAT2
9759 #endif
9760       implicit real*8 (a-h,o-z)
9761       include 'DIMENSIONS'
9762       DIMENSION A1(2,2),A2(2,2),A3(2,2)
9763 c      DIMENSION AI3(2,2)
9764 c        DO  J=1,2
9765 c          A3IJ=0.0
9766 c          DO K=1,2
9767 c           A3IJ=A3IJ+A1(I,K)*A2(K,J)
9768 c          enddo
9769 c          A3(I,J)=A3IJ
9770 c       enddo
9771 c      enddo
9772
9773       ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
9774       ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
9775       ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
9776       ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
9777
9778       A3(1,1)=AI3_11
9779       A3(2,1)=AI3_21
9780       A3(1,2)=AI3_12
9781       A3(2,2)=AI3_22
9782       END
9783
9784 c-------------------------------------------------------------------------
9785       double precision function scalar2(u,v)
9786 !DIR$ INLINEALWAYS scalar2
9787       implicit none
9788       double precision u(2),v(2)
9789       double precision sc
9790       integer i
9791       scalar2=u(1)*v(1)+u(2)*v(2)
9792       return
9793       end
9794
9795 C-----------------------------------------------------------------------------
9796
9797       subroutine transpose2(a,at)
9798 !DIR$ INLINEALWAYS transpose2
9799 #ifndef OSF
9800 cDEC$ ATTRIBUTES FORCEINLINE::transpose2
9801 #endif
9802       implicit none
9803       double precision a(2,2),at(2,2)
9804       at(1,1)=a(1,1)
9805       at(1,2)=a(2,1)
9806       at(2,1)=a(1,2)
9807       at(2,2)=a(2,2)
9808       return
9809       end
9810 c--------------------------------------------------------------------------
9811       subroutine transpose(n,a,at)
9812       implicit none
9813       integer n,i,j
9814       double precision a(n,n),at(n,n)
9815       do i=1,n
9816         do j=1,n
9817           at(j,i)=a(i,j)
9818         enddo
9819       enddo
9820       return
9821       end
9822 C---------------------------------------------------------------------------
9823       subroutine prodmat3(a1,a2,kk,transp,prod)
9824 !DIR$ INLINEALWAYS prodmat3
9825 #ifndef OSF
9826 cDEC$ ATTRIBUTES FORCEINLINE::prodmat3
9827 #endif
9828       implicit none
9829       integer i,j
9830       double precision a1(2,2),a2(2,2),a2t(2,2),kk(2,2),prod(2,2)
9831       logical transp
9832 crc      double precision auxmat(2,2),prod_(2,2)
9833
9834       if (transp) then
9835 crc        call transpose2(kk(1,1),auxmat(1,1))
9836 crc        call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
9837 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
9838
9839            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1)
9840      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
9841            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2)
9842      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
9843            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1)
9844      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
9845            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2)
9846      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
9847
9848       else
9849 crc        call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
9850 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
9851
9852            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1)
9853      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
9854            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2)
9855      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
9856            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1)
9857      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
9858            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2)
9859      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
9860
9861       endif
9862 c      call transpose2(a2(1,1),a2t(1,1))
9863
9864 crc      print *,transp
9865 crc      print *,((prod_(i,j),i=1,2),j=1,2)
9866 crc      print *,((prod(i,j),i=1,2),j=1,2)
9867
9868       return
9869       end
9870 CCC----------------------------------------------
9871       subroutine Eliptransfer(eliptran)
9872       implicit real*8 (a-h,o-z)
9873       include 'DIMENSIONS'
9874       include 'COMMON.GEO'
9875       include 'COMMON.VAR'
9876       include 'COMMON.LOCAL'
9877       include 'COMMON.CHAIN'
9878       include 'COMMON.DERIV'
9879       include 'COMMON.NAMES'
9880       include 'COMMON.INTERACT'
9881       include 'COMMON.IOUNITS'
9882       include 'COMMON.CALC'
9883       include 'COMMON.CONTROL'
9884       include 'COMMON.SPLITELE'
9885       include 'COMMON.SBRIDGE'
9886 C this is done by Adasko
9887 C      print *,"wchodze"
9888 C structure of box:
9889 C      water
9890 C--bordliptop-- buffore starts
9891 C--bufliptop--- here true lipid starts
9892 C      lipid
9893 C--buflipbot--- lipid ends buffore starts
9894 C--bordlipbot--buffore ends
9895       eliptran=0.0
9896       do i=ilip_start,ilip_end
9897 C       do i=1,1
9898         if (itype(i).eq.ntyp1) cycle
9899
9900         positi=(mod(((c(3,i)+c(3,i+1))/2.0d0),boxzsize))
9901         if (positi.le.0) positi=positi+boxzsize
9902 C        print *,i
9903 C first for peptide groups
9904 c for each residue check if it is in lipid or lipid water border area
9905        if ((positi.gt.bordlipbot)
9906      &.and.(positi.lt.bordliptop)) then
9907 C the energy transfer exist
9908         if (positi.lt.buflipbot) then
9909 C what fraction I am in
9910          fracinbuf=1.0d0-
9911      &        ((positi-bordlipbot)/lipbufthick)
9912 C lipbufthick is thickenes of lipid buffore
9913          sslip=sscalelip(fracinbuf)
9914          ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
9915          eliptran=eliptran+sslip*pepliptran
9916          gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
9917          gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
9918 C         gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
9919
9920 C         print *,"doing sccale for lower part"
9921         elseif (positi.gt.bufliptop) then
9922          fracinbuf=1.0d0-((bordliptop-positi)/lipbufthick)
9923          sslip=sscalelip(fracinbuf)
9924          ssgradlip=sscagradlip(fracinbuf)/lipbufthick
9925          eliptran=eliptran+sslip*pepliptran
9926          gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
9927          gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
9928 C         gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
9929 C          print *, "doing sscalefor top part"
9930         else
9931          eliptran=eliptran+pepliptran
9932 C         print *,"I am in true lipid"
9933         endif
9934 C       else
9935 C       eliptran=elpitran+0.0 ! I am in water
9936        endif
9937        enddo
9938 C       print *, "nic nie bylo w lipidzie?"
9939 C now multiply all by the peptide group transfer factor
9940 C       eliptran=eliptran*pepliptran
9941 C now the same for side chains
9942 C       do i=1,1
9943        do i=ilip_start,ilip_end
9944         if (itype(i).eq.ntyp1) cycle
9945         positi=(mod(c(3,i+nres),boxzsize))
9946         if (positi.le.0) positi=positi+boxzsize
9947 C       print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop
9948 c for each residue check if it is in lipid or lipid water border area
9949 C       respos=mod(c(3,i+nres),boxzsize)
9950 C       print *,positi,bordlipbot,buflipbot
9951        if ((positi.gt.bordlipbot)
9952      & .and.(positi.lt.bordliptop)) then
9953 C the energy transfer exist
9954         if (positi.lt.buflipbot) then
9955          fracinbuf=1.0d0-
9956      &     ((positi-bordlipbot)/lipbufthick)
9957 C lipbufthick is thickenes of lipid buffore
9958          sslip=sscalelip(fracinbuf)
9959          ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
9960          eliptran=eliptran+sslip*liptranene(itype(i))
9961          gliptranx(3,i)=gliptranx(3,i)
9962      &+ssgradlip*liptranene(itype(i))/2.0d0
9963          gliptranc(3,i-1)= gliptranc(3,i-1)
9964      &+ssgradlip*liptranene(itype(i))/2.0d0
9965 C         print *,"doing sccale for lower part"
9966         elseif (positi.gt.bufliptop) then
9967          fracinbuf=1.0d0-
9968      &((bordliptop-positi)/lipbufthick)
9969          sslip=sscalelip(fracinbuf)
9970          ssgradlip=sscagradlip(fracinbuf)/lipbufthick
9971          eliptran=eliptran+sslip*liptranene(itype(i))
9972          gliptranx(3,i)=gliptranx(3,i)
9973      &+ssgradlip*liptranene(itype(i))/2.0d0
9974          gliptranc(3,i-1)= gliptranc(3,i-1)
9975      &+ssgradlip*liptranene(itype(i))/2.0d0
9976 C          print *, "doing sscalefor top part",sslip,fracinbuf
9977         else
9978          eliptran=eliptran+liptranene(itype(i))
9979 C         print *,"I am in true lipid"
9980         endif
9981         endif ! if in lipid or buffor
9982 C       else
9983 C       eliptran=elpitran+0.0 ! I am in water
9984        enddo
9985        return
9986        end