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