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