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       if (AFMlog.gt.0) then
 277         call AFMforce(Eafmforce)
 278       endif
 279 #ifdef TIMING
 280       time_enecalc=time_enecalc+MPI_Wtime()-time00
 281 #endif
 282 c      print *,"Processor",myrank," computed Uconstr"
 283 #ifdef TIMING
 284       time00=MPI_Wtime()
 285 #endif
 286 c
 287 C Sum the energies
 288 C
 289       energia(1)=evdw
 290 #ifdef SCP14
 291       energia(2)=evdw2-evdw2_14
 292       energia(18)=evdw2_14
 293 #else
 294       energia(2)=evdw2
 295       energia(18)=0.0d0
 296 #endif
 297 #ifdef SPLITELE
 298       energia(3)=ees
 299       energia(16)=evdw1
 300 #else
 301       energia(3)=ees+evdw1
 302       energia(16)=0.0d0
 303 #endif
 304       energia(4)=ecorr
 305       energia(5)=ecorr5
 306       energia(6)=ecorr6
 307       energia(7)=eel_loc
 308       energia(8)=eello_turn3
 309       energia(9)=eello_turn4
 310       energia(10)=eturn6
 311       energia(11)=ebe
 312       energia(12)=escloc
 313       energia(13)=etors
 314       energia(14)=etors_d
 315       energia(15)=ehpb
 316       energia(19)=edihcnstr
 317       energia(17)=estr
 318       energia(20)=Uconst+Uconst_back
 319       energia(21)=esccor
 320       energia(22)=eliptran
 321       energia(23)=Eafmforce
 322 c    Here are the energies showed per procesor if the are more processors
 323 c    per molecule then we sum it up in sum_energy subroutine
 324 c      print *," Processor",myrank," calls SUM_ENERGY"
 325       call sum_energy(energia,.true.)
 326       if (dyn_ss) call dyn_set_nss
 327 c      print *," Processor",myrank," left SUM_ENERGY"
 328 #ifdef TIMING
 329       time_sumene=time_sumene+MPI_Wtime()-time00
 330 #endif
 331       return
 332       end
 333 c-------------------------------------------------------------------------------
 334       subroutine sum_energy(energia,reduce)
 335       implicit real*8 (a-h,o-z)
 336       include 'DIMENSIONS'
 337 #ifndef ISNAN
 338       external proc_proc
 339 #ifdef WINPGI
 340 cMS$ATTRIBUTES C ::  proc_proc
 341 #endif
 342 #endif
 343 #ifdef MPI
 344       include "mpif.h"
 345 #endif
 346       include 'COMMON.SETUP'
 347       include 'COMMON.IOUNITS'
 348       double precision energia(0:n_ene),enebuff(0:n_ene+1)
 349       include 'COMMON.FFIELD'
 350       include 'COMMON.DERIV'
 351       include 'COMMON.INTERACT'
 352       include 'COMMON.SBRIDGE'
 353       include 'COMMON.CHAIN'
 354       include 'COMMON.VAR'
 355       include 'COMMON.CONTROL'
 356       include 'COMMON.TIME1'
 357       logical reduce
 358 #ifdef MPI
 359       if (nfgtasks.gt.1 .and. reduce) then
 360 #ifdef DEBUG
 361         write (iout,*) "energies before REDUCE"
 362         call enerprint(energia)
 363         call flush(iout)
 364 #endif
 365         do i=0,n_ene
 366           enebuff(i)=energia(i)
 367         enddo
 368         time00=MPI_Wtime()
 369         call MPI_Barrier(FG_COMM,IERR)
 370         time_barrier_e=time_barrier_e+MPI_Wtime()-time00
 371         time00=MPI_Wtime()
 372         call MPI_Reduce(enebuff(0),energia(0),n_ene+1,
 373      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 374 #ifdef DEBUG
 375         write (iout,*) "energies after REDUCE"
 376         call enerprint(energia)
 377         call flush(iout)
 378 #endif
 379         time_Reduce=time_Reduce+MPI_Wtime()-time00
 380       endif
 381       if (fg_rank.eq.0) then
 382 #endif
 383       evdw=energia(1)
 384 #ifdef SCP14
 385       evdw2=energia(2)+energia(18)
 386       evdw2_14=energia(18)
 387 #else
 388       evdw2=energia(2)
 389 #endif
 390 #ifdef SPLITELE
 391       ees=energia(3)
 392       evdw1=energia(16)
 393 #else
 394       ees=energia(3)
 395       evdw1=0.0d0
 396 #endif
 397       ecorr=energia(4)
 398       ecorr5=energia(5)
 399       ecorr6=energia(6)
 400       eel_loc=energia(7)
 401       eello_turn3=energia(8)
 402       eello_turn4=energia(9)
 403       eturn6=energia(10)
 404       ebe=energia(11)
 405       escloc=energia(12)
 406       etors=energia(13)
 407       etors_d=energia(14)
 408       ehpb=energia(15)
 409       edihcnstr=energia(19)
 410       estr=energia(17)
 411       Uconst=energia(20)
 412       esccor=energia(21)
 413       eliptran=energia(22)
 414       Eafmforce=energia(23)
 415 #ifdef SPLITELE
 416       etot=wsc*evdw+wscp*evdw2+welec*ees+wvdwpp*evdw1
 417      & +wang*ebe+wtor*etors+wscloc*escloc
 418      & +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5
 419      & +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3
 420      & +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d
 421      & +wbond*estr+Uconst+wsccor*esccor+wliptran*eliptran+Eafmforce
 422 #else
 423       etot=wsc*evdw+wscp*evdw2+welec*(ees+evdw1)
 424      & +wang*ebe+wtor*etors+wscloc*escloc
 425      & +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5
 426      & +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3
 427      & +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d
 428      & +wbond*estr+Uconst+wsccor*esccor+wliptran*eliptran
 429      & +Eafmforce
 430 #endif
 431       energia(0)=etot
 432 c detecting NaNQ
 433 #ifdef ISNAN
 434 #ifdef AIX
 435       if (isnan(etot).ne.0) energia(0)=1.0d+99
 436 #else
 437       if (isnan(etot)) energia(0)=1.0d+99
 438 #endif
 439 #else
 440       i=0
 441 #ifdef WINPGI
 442       idumm=proc_proc(etot,i)
 443 #else
 444       call proc_proc(etot,i)
 445 #endif
 446       if(i.eq.1)energia(0)=1.0d+99
 447 #endif
 448 #ifdef MPI
 449       endif
 450 #endif
 451       return
 452       end
 453 c-------------------------------------------------------------------------------
 454       subroutine sum_gradient
 455       implicit real*8 (a-h,o-z)
 456       include 'DIMENSIONS'
 457 #ifndef ISNAN
 458       external proc_proc
 459 #ifdef WINPGI
 460 cMS$ATTRIBUTES C ::  proc_proc
 461 #endif
 462 #endif
 463 #ifdef MPI
 464       include 'mpif.h'
 465 #endif
 466       double precision gradbufc(3,-1:maxres),gradbufx(3,-1:maxres),
 467      & glocbuf(4*maxres),gradbufc_sum(3,-1:maxres)
 468      & ,gloc_scbuf(3,-1:maxres)
 469       include 'COMMON.SETUP'
 470       include 'COMMON.IOUNITS'
 471       include 'COMMON.FFIELD'
 472       include 'COMMON.DERIV'
 473       include 'COMMON.INTERACT'
 474       include 'COMMON.SBRIDGE'
 475       include 'COMMON.CHAIN'
 476       include 'COMMON.VAR'
 477       include 'COMMON.CONTROL'
 478       include 'COMMON.TIME1'
 479       include 'COMMON.MAXGRAD'
 480       include 'COMMON.SCCOR'
 481 #ifdef TIMING
 482       time01=MPI_Wtime()
 483 #endif
 484 #ifdef DEBUG
 485       write (iout,*) "sum_gradient gvdwc, gvdwx"
 486       do i=1,nres
 487         write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)')
 488      &   i,(gvdwx(j,i),j=1,3),(gvdwc(j,i),j=1,3)
 489       enddo
 490       call flush(iout)
 491 #endif
 492 #ifdef MPI
 493 C FG slaves call the following matching MPI_Bcast in ERGASTULUM
 494         if (nfgtasks.gt.1 .and. fg_rank.eq.0)
 495      &    call MPI_Bcast(1,1,MPI_INTEGER,king,FG_COMM,IERROR)
 496 #endif
 497 C
 498 C 9/29/08 AL Transform parts of gradients in site coordinates to the gradient
 499 C            in virtual-bond-vector coordinates
 500 C
 501 #ifdef DEBUG
 502 c      write (iout,*) "gel_loc gel_loc_long and gel_loc_loc"
 503 c      do i=1,nres-1
 504 c        write (iout,'(i5,3f10.5,2x,3f10.5,2x,f10.5)')
 505 c     &   i,(gel_loc(j,i),j=1,3),(gel_loc_long(j,i),j=1,3),gel_loc_loc(i)
 506 c      enddo
 507 c      write (iout,*) "gel_loc_tur3 gel_loc_turn4"
 508 c      do i=1,nres-1
 509 c        write (iout,'(i5,3f10.5,2x,f10.5)')
 510 c     &  i,(gcorr4_turn(j,i),j=1,3),gel_loc_turn4(i)
 511 c      enddo
 512       write (iout,*) "gradcorr5 gradcorr5_long gradcorr5_loc"
 513       do i=1,nres
 514         write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)')
 515      &   i,(gradcorr5(j,i),j=1,3),(gradcorr5_long(j,i),j=1,3),
 516      &   g_corr5_loc(i)
 517       enddo
 518       call flush(iout)
 519 #endif
 520 #ifdef SPLITELE
 521       do i=0,nct
 522         do j=1,3
 523           gradbufc(j,i)=wsc*gvdwc(j,i)+
 524      &                wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+
 525      &                welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+
 526      &                wel_loc*gel_loc_long(j,i)+
 527      &                wcorr*gradcorr_long(j,i)+
 528      &                wcorr5*gradcorr5_long(j,i)+
 529      &                wcorr6*gradcorr6_long(j,i)+
 530      &                wturn6*gcorr6_turn_long(j,i)+
 531      &                wstrain*ghpbc(j,i)
 532      &                +wliptran*gliptranc(j,i)
 533      &                +gradafm(j,i)
 534
 535         enddo
 536       enddo
 537 #else
 538       do i=0,nct
 539         do j=1,3
 540           gradbufc(j,i)=wsc*gvdwc(j,i)+
 541      &                wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+
 542      &                welec*gelc_long(j,i)+
 543      &                wbond*gradb(j,i)+
 544      &                wel_loc*gel_loc_long(j,i)+
 545      &                wcorr*gradcorr_long(j,i)+
 546      &                wcorr5*gradcorr5_long(j,i)+
 547      &                wcorr6*gradcorr6_long(j,i)+
 548      &                wturn6*gcorr6_turn_long(j,i)+
 549      &                wstrain*ghpbc(j,i)
 550      &                +wliptran*gliptranc(j,i)
 551      &                +gradafm(j,i)
 552
 553         enddo
 554       enddo
 555 #endif
 556 #ifdef MPI
 557       if (nfgtasks.gt.1) then
 558       time00=MPI_Wtime()
 559 #ifdef DEBUG
 560       write (iout,*) "gradbufc before allreduce"
 561       do i=1,nres
 562         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 563       enddo
 564       call flush(iout)
 565 #endif
 566       do i=0,nres
 567         do j=1,3
 568           gradbufc_sum(j,i)=gradbufc(j,i)
 569         enddo
 570       enddo
 571 c      call MPI_AllReduce(gradbufc(1,1),gradbufc_sum(1,1),3*nres,
 572 c     &    MPI_DOUBLE_PRECISION,MPI_SUM,FG_COMM,IERR)
 573 c      time_reduce=time_reduce+MPI_Wtime()-time00
 574 #ifdef DEBUG
 575 c      write (iout,*) "gradbufc_sum after allreduce"
 576 c      do i=1,nres
 577 c        write (iout,'(i3,3f10.5)') i,(gradbufc_sum(j,i),j=1,3)
 578 c      enddo
 579 c      call flush(iout)
 580 #endif
 581 #ifdef TIMING
 582 c      time_allreduce=time_allreduce+MPI_Wtime()-time00
 583 #endif
 584       do i=nnt,nres
 585         do k=1,3
 586           gradbufc(k,i)=0.0d0
 587         enddo
 588       enddo
 589 #ifdef DEBUG
 590       write (iout,*) "igrad_start",igrad_start," igrad_end",igrad_end
 591       write (iout,*) (i," jgrad_start",jgrad_start(i),
 592      &                  " jgrad_end  ",jgrad_end(i),
 593      &                  i=igrad_start,igrad_end)
 594 #endif
 595 c
 596 c Obsolete and inefficient code; we can make the effort O(n) and, therefore,
 597 c do not parallelize this part.
 598 c
 599 c      do i=igrad_start,igrad_end
 600 c        do j=jgrad_start(i),jgrad_end(i)
 601 c          do k=1,3
 602 c            gradbufc(k,i)=gradbufc(k,i)+gradbufc_sum(k,j)
 603 c          enddo
 604 c        enddo
 605 c      enddo
 606       do j=1,3
 607         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
 608       enddo
 609       do i=nres-2,-1,-1
 610         do j=1,3
 611           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
 612         enddo
 613       enddo
 614 #ifdef DEBUG
 615       write (iout,*) "gradbufc after summing"
 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       else
 622 #endif
 623 #ifdef DEBUG
 624       write (iout,*) "gradbufc"
 625       do i=1,nres
 626         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 627       enddo
 628       call flush(iout)
 629 #endif
 630       do i=-1,nres
 631         do j=1,3
 632           gradbufc_sum(j,i)=gradbufc(j,i)
 633           gradbufc(j,i)=0.0d0
 634         enddo
 635       enddo
 636       do j=1,3
 637         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
 638       enddo
 639       do i=nres-2,-1,-1
 640         do j=1,3
 641           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
 642         enddo
 643       enddo
 644 c      do i=nnt,nres-1
 645 c        do k=1,3
 646 c          gradbufc(k,i)=0.0d0
 647 c        enddo
 648 c        do j=i+1,nres
 649 c          do k=1,3
 650 c            gradbufc(k,i)=gradbufc(k,i)+gradbufc(k,j)
 651 c          enddo
 652 c        enddo
 653 c      enddo
 654 #ifdef DEBUG
 655       write (iout,*) "gradbufc after summing"
 656       do i=1,nres
 657         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 658       enddo
 659       call flush(iout)
 660 #endif
 661 #ifdef MPI
 662       endif
 663 #endif
 664       do k=1,3
 665         gradbufc(k,nres)=0.0d0
 666       enddo
 667       do i=-1,nct
 668         do j=1,3
 669 #ifdef SPLITELE
 670           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+
 671      &                wel_loc*gel_loc(j,i)+
 672      &                0.5d0*(wscp*gvdwc_scpp(j,i)+
 673      &                welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+
 674      &                wel_loc*gel_loc_long(j,i)+
 675      &                wcorr*gradcorr_long(j,i)+
 676      &                wcorr5*gradcorr5_long(j,i)+
 677      &                wcorr6*gradcorr6_long(j,i)+
 678      &                wturn6*gcorr6_turn_long(j,i))+
 679      &                wbond*gradb(j,i)+
 680      &                wcorr*gradcorr(j,i)+
 681      &                wturn3*gcorr3_turn(j,i)+
 682      &                wturn4*gcorr4_turn(j,i)+
 683      &                wcorr5*gradcorr5(j,i)+
 684      &                wcorr6*gradcorr6(j,i)+
 685      &                wturn6*gcorr6_turn(j,i)+
 686      &                wsccor*gsccorc(j,i)
 687      &               +wscloc*gscloc(j,i)
 688      &               +wliptran*gliptranc(j,i)
 689      &                +gradafm(j,i)
 690 #else
 691           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+
 692      &                wel_loc*gel_loc(j,i)+
 693      &                0.5d0*(wscp*gvdwc_scpp(j,i)+
 694      &                welec*gelc_long(j,i)
 695      &                wel_loc*gel_loc_long(j,i)+
 696      &                wcorr*gcorr_long(j,i)+
 697      &                wcorr5*gradcorr5_long(j,i)+
 698      &                wcorr6*gradcorr6_long(j,i)+
 699      &                wturn6*gcorr6_turn_long(j,i))+
 700      &                wbond*gradb(j,i)+
 701      &                wcorr*gradcorr(j,i)+
 702      &                wturn3*gcorr3_turn(j,i)+
 703      &                wturn4*gcorr4_turn(j,i)+
 704      &                wcorr5*gradcorr5(j,i)+
 705      &                wcorr6*gradcorr6(j,i)+
 706      &                wturn6*gcorr6_turn(j,i)+
 707      &                wsccor*gsccorc(j,i)
 708      &               +wscloc*gscloc(j,i)
 709      &               +wliptran*gliptranc(j,i)
 710      &                +gradafm(j,i)
 711
 712 #endif
 713           gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+
 714      &                  wbond*gradbx(j,i)+
 715      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
 716      &                  wsccor*gsccorx(j,i)
 717      &                 +wscloc*gsclocx(j,i)
 718      &                 +wliptran*gliptranx(j,i)
 719         enddo
 720       enddo
 721 #ifdef DEBUG
 722       write (iout,*) "gloc before adding corr"
 723       do i=1,4*nres
 724         write (iout,*) i,gloc(i,icg)
 725       enddo
 726 #endif
 727       do i=1,nres-3
 728         gloc(i,icg)=gloc(i,icg)+wcorr*gcorr_loc(i)
 729      &   +wcorr5*g_corr5_loc(i)
 730      &   +wcorr6*g_corr6_loc(i)
 731      &   +wturn4*gel_loc_turn4(i)
 732      &   +wturn3*gel_loc_turn3(i)
 733      &   +wturn6*gel_loc_turn6(i)
 734      &   +wel_loc*gel_loc_loc(i)
 735       enddo
 736 #ifdef DEBUG
 737       write (iout,*) "gloc after adding corr"
 738       do i=1,4*nres
 739         write (iout,*) i,gloc(i,icg)
 740       enddo
 741 #endif
 742 #ifdef MPI
 743       if (nfgtasks.gt.1) then
 744         do j=1,3
 745           do i=1,nres
 746             gradbufc(j,i)=gradc(j,i,icg)
 747             gradbufx(j,i)=gradx(j,i,icg)
 748           enddo
 749         enddo
 750         do i=1,4*nres
 751           glocbuf(i)=gloc(i,icg)
 752         enddo
 753 c#define DEBUG
 754 #ifdef DEBUG
 755       write (iout,*) "gloc_sc before reduce"
 756       do i=1,nres
 757        do j=1,1
 758         write (iout,*) i,j,gloc_sc(j,i,icg)
 759        enddo
 760       enddo
 761 #endif
 762 c#undef DEBUG
 763         do i=1,nres
 764          do j=1,3
 765           gloc_scbuf(j,i)=gloc_sc(j,i,icg)
 766          enddo
 767         enddo
 768         time00=MPI_Wtime()
 769         call MPI_Barrier(FG_COMM,IERR)
 770         time_barrier_g=time_barrier_g+MPI_Wtime()-time00
 771         time00=MPI_Wtime()
 772         call MPI_Reduce(gradbufc(1,1),gradc(1,1,icg),3*nres,
 773      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 774         call MPI_Reduce(gradbufx(1,1),gradx(1,1,icg),3*nres,
 775      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 776         call MPI_Reduce(glocbuf(1),gloc(1,icg),4*nres,
 777      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 778         time_reduce=time_reduce+MPI_Wtime()-time00
 779         call MPI_Reduce(gloc_scbuf(1,1),gloc_sc(1,1,icg),3*nres,
 780      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 781         time_reduce=time_reduce+MPI_Wtime()-time00
 782 c#define DEBUG
 783 #ifdef DEBUG
 784       write (iout,*) "gloc_sc after reduce"
 785       do i=1,nres
 786        do j=1,1
 787         write (iout,*) i,j,gloc_sc(j,i,icg)
 788        enddo
 789       enddo
 790 #endif
 791 c#undef DEBUG
 792 #ifdef DEBUG
 793       write (iout,*) "gloc after reduce"
 794       do i=1,4*nres
 795         write (iout,*) i,gloc(i,icg)
 796       enddo
 797 #endif
 798       endif
 799 #endif
 800       if (gnorm_check) then
 801 c
 802 c Compute the maximum elements of the gradient
 803 c
 804       gvdwc_max=0.0d0
 805       gvdwc_scp_max=0.0d0
 806       gelc_max=0.0d0
 807       gvdwpp_max=0.0d0
 808       gradb_max=0.0d0
 809       ghpbc_max=0.0d0
 810       gradcorr_max=0.0d0
 811       gel_loc_max=0.0d0
 812       gcorr3_turn_max=0.0d0
 813       gcorr4_turn_max=0.0d0
 814       gradcorr5_max=0.0d0
 815       gradcorr6_max=0.0d0
 816       gcorr6_turn_max=0.0d0
 817       gsccorc_max=0.0d0
 818       gscloc_max=0.0d0
 819       gvdwx_max=0.0d0
 820       gradx_scp_max=0.0d0
 821       ghpbx_max=0.0d0
 822       gradxorr_max=0.0d0
 823       gsccorx_max=0.0d0
 824       gsclocx_max=0.0d0
 825       do i=1,nct
 826         gvdwc_norm=dsqrt(scalar(gvdwc(1,i),gvdwc(1,i)))
 827         if (gvdwc_norm.gt.gvdwc_max) gvdwc_max=gvdwc_norm
 828         gvdwc_scp_norm=dsqrt(scalar(gvdwc_scp(1,i),gvdwc_scp(1,i)))
 829         if (gvdwc_scp_norm.gt.gvdwc_scp_max)
 830      &   gvdwc_scp_max=gvdwc_scp_norm
 831         gelc_norm=dsqrt(scalar(gelc(1,i),gelc(1,i)))
 832         if (gelc_norm.gt.gelc_max) gelc_max=gelc_norm
 833         gvdwpp_norm=dsqrt(scalar(gvdwpp(1,i),gvdwpp(1,i)))
 834         if (gvdwpp_norm.gt.gvdwpp_max) gvdwpp_max=gvdwpp_norm
 835         gradb_norm=dsqrt(scalar(gradb(1,i),gradb(1,i)))
 836         if (gradb_norm.gt.gradb_max) gradb_max=gradb_norm
 837         ghpbc_norm=dsqrt(scalar(ghpbc(1,i),ghpbc(1,i)))
 838         if (ghpbc_norm.gt.ghpbc_max) ghpbc_max=ghpbc_norm
 839         gradcorr_norm=dsqrt(scalar(gradcorr(1,i),gradcorr(1,i)))
 840         if (gradcorr_norm.gt.gradcorr_max) gradcorr_max=gradcorr_norm
 841         gel_loc_norm=dsqrt(scalar(gel_loc(1,i),gel_loc(1,i)))
 842         if (gel_loc_norm.gt.gel_loc_max) gel_loc_max=gel_loc_norm
 843         gcorr3_turn_norm=dsqrt(scalar(gcorr3_turn(1,i),
 844      &    gcorr3_turn(1,i)))
 845         if (gcorr3_turn_norm.gt.gcorr3_turn_max)
 846      &    gcorr3_turn_max=gcorr3_turn_norm
 847         gcorr4_turn_norm=dsqrt(scalar(gcorr4_turn(1,i),
 848      &    gcorr4_turn(1,i)))
 849         if (gcorr4_turn_norm.gt.gcorr4_turn_max)
 850      &    gcorr4_turn_max=gcorr4_turn_norm
 851         gradcorr5_norm=dsqrt(scalar(gradcorr5(1,i),gradcorr5(1,i)))
 852         if (gradcorr5_norm.gt.gradcorr5_max)
 853      &    gradcorr5_max=gradcorr5_norm
 854         gradcorr6_norm=dsqrt(scalar(gradcorr6(1,i),gradcorr6(1,i)))
 855         if (gradcorr6_norm.gt.gradcorr6_max) gcorr6_max=gradcorr6_norm
 856         gcorr6_turn_norm=dsqrt(scalar(gcorr6_turn(1,i),
 857      &    gcorr6_turn(1,i)))
 858         if (gcorr6_turn_norm.gt.gcorr6_turn_max)
 859      &    gcorr6_turn_max=gcorr6_turn_norm
 860         gsccorr_norm=dsqrt(scalar(gsccorc(1,i),gsccorc(1,i)))
 861         if (gsccorr_norm.gt.gsccorr_max) gsccorr_max=gsccorr_norm
 862         gscloc_norm=dsqrt(scalar(gscloc(1,i),gscloc(1,i)))
 863         if (gscloc_norm.gt.gscloc_max) gscloc_max=gscloc_norm
 864         gvdwx_norm=dsqrt(scalar(gvdwx(1,i),gvdwx(1,i)))
 865         if (gvdwx_norm.gt.gvdwx_max) gvdwx_max=gvdwx_norm
 866         gradx_scp_norm=dsqrt(scalar(gradx_scp(1,i),gradx_scp(1,i)))
 867         if (gradx_scp_norm.gt.gradx_scp_max)
 868      &    gradx_scp_max=gradx_scp_norm
 869         ghpbx_norm=dsqrt(scalar(ghpbx(1,i),ghpbx(1,i)))
 870         if (ghpbx_norm.gt.ghpbx_max) ghpbx_max=ghpbx_norm
 871         gradxorr_norm=dsqrt(scalar(gradxorr(1,i),gradxorr(1,i)))
 872         if (gradxorr_norm.gt.gradxorr_max) gradxorr_max=gradxorr_norm
 873         gsccorrx_norm=dsqrt(scalar(gsccorx(1,i),gsccorx(1,i)))
 874         if (gsccorrx_norm.gt.gsccorrx_max) gsccorrx_max=gsccorrx_norm
 875         gsclocx_norm=dsqrt(scalar(gsclocx(1,i),gsclocx(1,i)))
 876         if (gsclocx_norm.gt.gsclocx_max) gsclocx_max=gsclocx_norm
 877       enddo
 878       if (gradout) then
 879 #ifdef AIX
 880         open(istat,file=statname,position="append")
 881 #else
 882         open(istat,file=statname,access="append")
 883 #endif
 884         write (istat,'(1h#,21f10.2)') gvdwc_max,gvdwc_scp_max,
 885      &     gelc_max,gvdwpp_max,gradb_max,ghpbc_max,
 886      &     gradcorr_max,gel_loc_max,gcorr3_turn_max,gcorr4_turn_max,
 887      &     gradcorr5_max,gradcorr6_max,gcorr6_turn_max,gsccorc_max,
 888      &     gscloc_max,gvdwx_max,gradx_scp_max,ghpbx_max,gradxorr_max,
 889      &     gsccorx_max,gsclocx_max
 890         close(istat)
 891         if (gvdwc_max.gt.1.0d4) then
 892           write (iout,*) "gvdwc gvdwx gradb gradbx"
 893           do i=nnt,nct
 894             write(iout,'(i5,4(3f10.2,5x))') i,(gvdwc(j,i),gvdwx(j,i),
 895      &        gradb(j,i),gradbx(j,i),j=1,3)
 896           enddo
 897           call pdbout(0.0d0,'cipiszcze',iout)
 898           call flush(iout)
 899         endif
 900       endif
 901       endif
 902 #ifdef DEBUG
 903       write (iout,*) "gradc gradx gloc"
 904       do i=1,nres
 905         write (iout,'(i5,3f10.5,5x,3f10.5,5x,f10.5)')
 906      &   i,(gradc(j,i,icg),j=1,3),(gradx(j,i,icg),j=1,3),gloc(i,icg)
 907       enddo
 908 #endif
 909 #ifdef TIMING
 910       time_sumgradient=time_sumgradient+MPI_Wtime()-time01
 911 #endif
 912       return
 913       end
 914 c-------------------------------------------------------------------------------
 915       subroutine rescale_weights(t_bath)
 916       implicit real*8 (a-h,o-z)
 917       include 'DIMENSIONS'
 918       include 'COMMON.IOUNITS'
 919       include 'COMMON.FFIELD'
 920       include 'COMMON.SBRIDGE'
 921       double precision kfac /2.4d0/
 922       double precision x,x2,x3,x4,x5,licznik /1.12692801104297249644/
 923 c      facT=temp0/t_bath
 924 c      facT=2*temp0/(t_bath+temp0)
 925       if (rescale_mode.eq.0) then
 926         facT=1.0d0
 927         facT2=1.0d0
 928         facT3=1.0d0
 929         facT4=1.0d0
 930         facT5=1.0d0
 931       else if (rescale_mode.eq.1) then
 932         facT=kfac/(kfac-1.0d0+t_bath/temp0)
 933         facT2=kfac**2/(kfac**2-1.0d0+(t_bath/temp0)**2)
 934         facT3=kfac**3/(kfac**3-1.0d0+(t_bath/temp0)**3)
 935         facT4=kfac**4/(kfac**4-1.0d0+(t_bath/temp0)**4)
 936         facT5=kfac**5/(kfac**5-1.0d0+(t_bath/temp0)**5)
 937       else if (rescale_mode.eq.2) then
 938         x=t_bath/temp0
 939         x2=x*x
 940         x3=x2*x
 941         x4=x3*x
 942         x5=x4*x
 943         facT=licznik/dlog(dexp(x)+dexp(-x))
 944         facT2=licznik/dlog(dexp(x2)+dexp(-x2))
 945         facT3=licznik/dlog(dexp(x3)+dexp(-x3))
 946         facT4=licznik/dlog(dexp(x4)+dexp(-x4))
 947         facT5=licznik/dlog(dexp(x5)+dexp(-x5))
 948       else
 949         write (iout,*) "Wrong RESCALE_MODE",rescale_mode
 950         write (*,*) "Wrong RESCALE_MODE",rescale_mode
 951 #ifdef MPI
 952        call MPI_Finalize(MPI_COMM_WORLD,IERROR)
 953 #endif
 954        stop 555
 955       endif
 956       welec=weights(3)*fact
 957       wcorr=weights(4)*fact3
 958       wcorr5=weights(5)*fact4
 959       wcorr6=weights(6)*fact5
 960       wel_loc=weights(7)*fact2
 961       wturn3=weights(8)*fact2
 962       wturn4=weights(9)*fact3
 963       wturn6=weights(10)*fact5
 964       wtor=weights(13)*fact
 965       wtor_d=weights(14)*fact2
 966       wsccor=weights(21)*fact
 967
 968       return
 969       end
 970 C------------------------------------------------------------------------
 971       subroutine enerprint(energia)
 972       implicit real*8 (a-h,o-z)
 973       include 'DIMENSIONS'
 974       include 'COMMON.IOUNITS'
 975       include 'COMMON.FFIELD'
 976       include 'COMMON.SBRIDGE'
 977       include 'COMMON.MD'
 978       double precision energia(0:n_ene)
 979       etot=energia(0)
 980       evdw=energia(1)
 981       evdw2=energia(2)
 982 #ifdef SCP14
 983       evdw2=energia(2)+energia(18)
 984 #else
 985       evdw2=energia(2)
 986 #endif
 987       ees=energia(3)
 988 #ifdef SPLITELE
 989       evdw1=energia(16)
 990 #endif
 991       ecorr=energia(4)
 992       ecorr5=energia(5)
 993       ecorr6=energia(6)
 994       eel_loc=energia(7)
 995       eello_turn3=energia(8)
 996       eello_turn4=energia(9)
 997       eello_turn6=energia(10)
 998       ebe=energia(11)
 999       escloc=energia(12)
1000       etors=energia(13)
1001       etors_d=energia(14)
1002       ehpb=energia(15)
1003       edihcnstr=energia(19)
1004       estr=energia(17)
1005       Uconst=energia(20)
1006       esccor=energia(21)
1007       eliptran=energia(22)
1008       Eafmforce=energia(23)
1009 #ifdef SPLITELE
1010       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,evdw1,wvdwpp,
1011      &  estr,wbond,ebe,wang,
1012      &  escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,
1013      &  ecorr,wcorr,
1014      &  ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,
1015      &  eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccor,
1016      &  edihcnstr,ebr*nss,
1017      &  Uconst,eliptran,wliptran,Eafmforce,etot
1018    10 format (/'Virtual-chain energies:'//
1019      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
1020      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
1021      & 'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/
1022      & 'EVDWPP=',1pE16.6,' WEIGHT=',1pD16.6,' (p-p VDW)'/
1023      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
1024      & 'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
1025      & 'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
1026      & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
1027      & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
1028      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6,
1029      & ' (SS bridges & dist. cnstr.)'/
1030      & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1031      & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1032      & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1033      & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
1034      & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
1035      & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
1036      & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
1037      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
1038      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
1039      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
1040      & 'UCONST= ',1pE16.6,' (Constraint energy)'/
1041      & 'ELT=',1pE16.6, ' WEIGHT=',1pD16.6,' (Lipid transfer energy)'/
1042      & 'EAFM=  ',1pE16.6,' (atomic-force microscopy)'/
1043      & 'ETOT=  ',1pE16.6,' (total)')
1044
1045 #else
1046       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,
1047      &  estr,wbond,ebe,wang,
1048      &  escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,
1049      &  ecorr,wcorr,
1050      &  ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,
1051      &  eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccro,edihcnstr,
1052      &  ebr*nss,Uconst,eliptran,wliptran,Eafmforc,etot
1053    10 format (/'Virtual-chain energies:'//
1054      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
1055      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
1056      & 'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/
1057      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
1058      & 'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
1059      & 'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
1060      & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
1061      & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
1062      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6,
1063      & ' (SS bridges & dist. cnstr.)'/
1064      & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1065      & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1066      & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1067      & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
1068      & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
1069      & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
1070      & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
1071      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
1072      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
1073      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
1074      & 'UCONST=',1pE16.6,' (Constraint energy)'/
1075      & 'ELT=',1pE16.6, ' WEIGHT=',1pD16.6,' (Lipid transfer energy)'/
1076      & 'EAFM=  ',1pE16.6,' (atomic-force microscopy)'/
1077      & 'ETOT=  ',1pE16.6,' (total)')
1078 #endif
1079       return
1080       end
1081 C-----------------------------------------------------------------------
1082       subroutine elj(evdw)
1083 C
1084 C This subroutine calculates the interaction energy of nonbonded side chains
1085 C assuming the LJ potential of interaction.
1086 C
1087       implicit real*8 (a-h,o-z)
1088       include 'DIMENSIONS'
1089       parameter (accur=1.0d-10)
1090       include 'COMMON.GEO'
1091       include 'COMMON.VAR'
1092       include 'COMMON.LOCAL'
1093       include 'COMMON.CHAIN'
1094       include 'COMMON.DERIV'
1095       include 'COMMON.INTERACT'
1096       include 'COMMON.TORSION'
1097       include 'COMMON.SBRIDGE'
1098       include 'COMMON.NAMES'
1099       include 'COMMON.IOUNITS'
1100       include 'COMMON.CONTACTS'
1101       dimension gg(3)
1102 c      write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
1103       evdw=0.0D0
1104       do i=iatsc_s,iatsc_e
1105         itypi=iabs(itype(i))
1106         if (itypi.eq.ntyp1) cycle
1107         itypi1=iabs(itype(i+1))
1108         xi=c(1,nres+i)
1109         yi=c(2,nres+i)
1110         zi=c(3,nres+i)
1111 C Change 12/1/95
1112         num_conti=0
1113 C
1114 C Calculate SC interaction energy.
1115 C
1116         do iint=1,nint_gr(i)
1117 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
1118 cd   &                  'iend=',iend(i,iint)
1119           do j=istart(i,iint),iend(i,iint)
1120             itypj=iabs(itype(j))
1121             if (itypj.eq.ntyp1) cycle
1122             xj=c(1,nres+j)-xi
1123             yj=c(2,nres+j)-yi
1124             zj=c(3,nres+j)-zi
1125 C Change 12/1/95 to calculate four-body interactions
1126             rij=xj*xj+yj*yj+zj*zj
1127             rrij=1.0D0/rij
1128 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
1129             eps0ij=eps(itypi,itypj)
1130             fac=rrij**expon2
1131 C have you changed here?
1132             e1=fac*fac*aa
1133             e2=fac*bb
1134             evdwij=e1+e2
1135 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1136 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1137 cd          write (iout,'(2(a3,i3,2x),6(1pd12.4)/2(3(1pd12.4),5x)/)')
1138 cd   &        restyp(itypi),i,restyp(itypj),j,a(itypi,itypj),
1139 cd   &        bb(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,epsi,sigm,
1140 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1141             evdw=evdw+evdwij
1142 C
1143 C Calculate the components of the gradient in DC and X
1144 C
1145             fac=-rrij*(e1+evdwij)
1146             gg(1)=xj*fac
1147             gg(2)=yj*fac
1148             gg(3)=zj*fac
1149             do k=1,3
1150               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1151               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1152               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1153               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1154             enddo
1155 cgrad            do k=i,j-1
1156 cgrad              do l=1,3
1157 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1158 cgrad              enddo
1159 cgrad            enddo
1160 C
1161 C 12/1/95, revised on 5/20/97
1162 C
1163 C Calculate the contact function. The ith column of the array JCONT will
1164 C contain the numbers of atoms that make contacts with the atom I (of numbers
1165 C greater than I). The arrays FACONT and GACONT will contain the values of
1166 C the contact function and its derivative.
1167 C
1168 C Uncomment next line, if the correlation interactions include EVDW explicitly.
1169 c           if (j.gt.i+1 .and. evdwij.le.0.0D0) then
1170 C Uncomment next line, if the correlation interactions are contact function only
1171             if (j.gt.i+1.and. eps0ij.gt.0.0D0) then
1172               rij=dsqrt(rij)
1173               sigij=sigma(itypi,itypj)
1174               r0ij=rs0(itypi,itypj)
1175 C
1176 C Check whether the SC's are not too far to make a contact.
1177 C
1178               rcut=1.5d0*r0ij
1179               call gcont(rij,rcut,1.0d0,0.2d0*rcut,fcont,fprimcont)
1180 C Add a new contact, if the SC's are close enough, but not too close (r<sigma).
1181 C
1182               if (fcont.gt.0.0D0) then
1183 C If the SC-SC distance if close to sigma, apply spline.
1184 cAdam           call gcont(-rij,-1.03d0*sigij,2.0d0*sigij,1.0d0,
1185 cAdam &             fcont1,fprimcont1)
1186 cAdam           fcont1=1.0d0-fcont1
1187 cAdam           if (fcont1.gt.0.0d0) then
1188 cAdam             fprimcont=fprimcont*fcont1+fcont*fprimcont1
1189 cAdam             fcont=fcont*fcont1
1190 cAdam           endif
1191 C Uncomment following 4 lines to have the geometric average of the epsilon0's
1192 cga             eps0ij=1.0d0/dsqrt(eps0ij)
1193 cga             do k=1,3
1194 cga               gg(k)=gg(k)*eps0ij
1195 cga             enddo
1196 cga             eps0ij=-evdwij*eps0ij
1197 C Uncomment for AL's type of SC correlation interactions.
1198 cadam           eps0ij=-evdwij
1199                 num_conti=num_conti+1
1200                 jcont(num_conti,i)=j
1201                 facont(num_conti,i)=fcont*eps0ij
1202                 fprimcont=eps0ij*fprimcont/rij
1203                 fcont=expon*fcont
1204 cAdam           gacont(1,num_conti,i)=-fprimcont*xj+fcont*gg(1)
1205 cAdam           gacont(2,num_conti,i)=-fprimcont*yj+fcont*gg(2)
1206 cAdam           gacont(3,num_conti,i)=-fprimcont*zj+fcont*gg(3)
1207 C Uncomment following 3 lines for Skolnick's type of SC correlation.
1208                 gacont(1,num_conti,i)=-fprimcont*xj
1209                 gacont(2,num_conti,i)=-fprimcont*yj
1210                 gacont(3,num_conti,i)=-fprimcont*zj
1211 cd              write (iout,'(2i5,2f10.5)') i,j,rij,facont(num_conti,i)
1212 cd              write (iout,'(2i3,3f10.5)')
1213 cd   &           i,j,(gacont(kk,num_conti,i),kk=1,3)
1214               endif
1215             endif
1216           enddo      ! j
1217         enddo        ! iint
1218 C Change 12/1/95
1219         num_cont(i)=num_conti
1220       enddo          ! i
1221       do i=1,nct
1222         do j=1,3
1223           gvdwc(j,i)=expon*gvdwc(j,i)
1224           gvdwx(j,i)=expon*gvdwx(j,i)
1225         enddo
1226       enddo
1227 C******************************************************************************
1228 C
1229 C                              N O T E !!!
1230 C
1231 C To save time, the factor of EXPON has been extracted from ALL components
1232 C of GVDWC and GRADX. Remember to multiply them by this factor before further
1233 C use!
1234 C
1235 C******************************************************************************
1236       return
1237       end
1238 C-----------------------------------------------------------------------------
1239       subroutine eljk(evdw)
1240 C
1241 C This subroutine calculates the interaction energy of nonbonded side chains
1242 C assuming the LJK potential of interaction.
1243 C
1244       implicit real*8 (a-h,o-z)
1245       include 'DIMENSIONS'
1246       include 'COMMON.GEO'
1247       include 'COMMON.VAR'
1248       include 'COMMON.LOCAL'
1249       include 'COMMON.CHAIN'
1250       include 'COMMON.DERIV'
1251       include 'COMMON.INTERACT'
1252       include 'COMMON.IOUNITS'
1253       include 'COMMON.NAMES'
1254       dimension gg(3)
1255       logical scheck
1256 c     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
1257       evdw=0.0D0
1258       do i=iatsc_s,iatsc_e
1259         itypi=iabs(itype(i))
1260         if (itypi.eq.ntyp1) cycle
1261         itypi1=iabs(itype(i+1))
1262         xi=c(1,nres+i)
1263         yi=c(2,nres+i)
1264         zi=c(3,nres+i)
1265 C
1266 C Calculate SC interaction energy.
1267 C
1268         do iint=1,nint_gr(i)
1269           do j=istart(i,iint),iend(i,iint)
1270             itypj=iabs(itype(j))
1271             if (itypj.eq.ntyp1) cycle
1272             xj=c(1,nres+j)-xi
1273             yj=c(2,nres+j)-yi
1274             zj=c(3,nres+j)-zi
1275             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1276             fac_augm=rrij**expon
1277             e_augm=augm(itypi,itypj)*fac_augm
1278             r_inv_ij=dsqrt(rrij)
1279             rij=1.0D0/r_inv_ij
1280             r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
1281             fac=r_shift_inv**expon
1282 C have you changed here?
1283             e1=fac*fac*aa
1284             e2=fac*bb
1285             evdwij=e_augm+e1+e2
1286 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1287 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1288 cd          write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
1289 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
1290 cd   &        bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
1291 cd   &        sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
1292 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1293             evdw=evdw+evdwij
1294 C
1295 C Calculate the components of the gradient in DC and X
1296 C
1297             fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
1298             gg(1)=xj*fac
1299             gg(2)=yj*fac
1300             gg(3)=zj*fac
1301             do k=1,3
1302               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1303               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1304               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1305               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1306             enddo
1307 cgrad            do k=i,j-1
1308 cgrad              do l=1,3
1309 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1310 cgrad              enddo
1311 cgrad            enddo
1312           enddo      ! j
1313         enddo        ! iint
1314       enddo          ! i
1315       do i=1,nct
1316         do j=1,3
1317           gvdwc(j,i)=expon*gvdwc(j,i)
1318           gvdwx(j,i)=expon*gvdwx(j,i)
1319         enddo
1320       enddo
1321       return
1322       end
1323 C-----------------------------------------------------------------------------
1324       subroutine ebp(evdw)
1325 C
1326 C This subroutine calculates the interaction energy of nonbonded side chains
1327 C assuming the Berne-Pechukas potential of interaction.
1328 C
1329       implicit real*8 (a-h,o-z)
1330       include 'DIMENSIONS'
1331       include 'COMMON.GEO'
1332       include 'COMMON.VAR'
1333       include 'COMMON.LOCAL'
1334       include 'COMMON.CHAIN'
1335       include 'COMMON.DERIV'
1336       include 'COMMON.NAMES'
1337       include 'COMMON.INTERACT'
1338       include 'COMMON.IOUNITS'
1339       include 'COMMON.CALC'
1340       common /srutu/ icall
1341 c     double precision rrsave(maxdim)
1342       logical lprn
1343       evdw=0.0D0
1344 c     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
1345       evdw=0.0D0
1346 c     if (icall.eq.0) then
1347 c       lprn=.true.
1348 c     else
1349         lprn=.false.
1350 c     endif
1351       ind=0
1352       do i=iatsc_s,iatsc_e
1353         itypi=iabs(itype(i))
1354         if (itypi.eq.ntyp1) cycle
1355         itypi1=iabs(itype(i+1))
1356         xi=c(1,nres+i)
1357         yi=c(2,nres+i)
1358         zi=c(3,nres+i)
1359         dxi=dc_norm(1,nres+i)
1360         dyi=dc_norm(2,nres+i)
1361         dzi=dc_norm(3,nres+i)
1362 c        dsci_inv=dsc_inv(itypi)
1363         dsci_inv=vbld_inv(i+nres)
1364 C
1365 C Calculate SC interaction energy.
1366 C
1367         do iint=1,nint_gr(i)
1368           do j=istart(i,iint),iend(i,iint)
1369             ind=ind+1
1370             itypj=iabs(itype(j))
1371             if (itypj.eq.ntyp1) cycle
1372 c            dscj_inv=dsc_inv(itypj)
1373             dscj_inv=vbld_inv(j+nres)
1374             chi1=chi(itypi,itypj)
1375             chi2=chi(itypj,itypi)
1376             chi12=chi1*chi2
1377             chip1=chip(itypi)
1378             chip2=chip(itypj)
1379             chip12=chip1*chip2
1380             alf1=alp(itypi)
1381             alf2=alp(itypj)
1382             alf12=0.5D0*(alf1+alf2)
1383 C For diagnostics only!!!
1384 c           chi1=0.0D0
1385 c           chi2=0.0D0
1386 c           chi12=0.0D0
1387 c           chip1=0.0D0
1388 c           chip2=0.0D0
1389 c           chip12=0.0D0
1390 c           alf1=0.0D0
1391 c           alf2=0.0D0
1392 c           alf12=0.0D0
1393             xj=c(1,nres+j)-xi
1394             yj=c(2,nres+j)-yi
1395             zj=c(3,nres+j)-zi
1396             dxj=dc_norm(1,nres+j)
1397             dyj=dc_norm(2,nres+j)
1398             dzj=dc_norm(3,nres+j)
1399             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1400 cd          if (icall.eq.0) then
1401 cd            rrsave(ind)=rrij
1402 cd          else
1403 cd            rrij=rrsave(ind)
1404 cd          endif
1405             rij=dsqrt(rrij)
1406 C Calculate the angle-dependent terms of energy & contributions to derivatives.
1407             call sc_angular
1408 C Calculate whole angle-dependent part of epsilon and contributions
1409 C to its derivatives
1410 C have you changed here?
1411             fac=(rrij*sigsq)**expon2
1412             e1=fac*fac*aa
1413             e2=fac*bb
1414             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1415             eps2der=evdwij*eps3rt
1416             eps3der=evdwij*eps2rt
1417             evdwij=evdwij*eps2rt*eps3rt
1418             evdw=evdw+evdwij
1419             if (lprn) then
1420             sigm=dabs(aa/bb)**(1.0D0/6.0D0)
1421             epsi=bb**2/aa
1422 cd            write (iout,'(2(a3,i3,2x),15(0pf7.3))')
1423 cd     &        restyp(itypi),i,restyp(itypj),j,
1424 cd     &        epsi,sigm,chi1,chi2,chip1,chip2,
1425 cd     &        eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
1426 cd     &        om1,om2,om12,1.0D0/dsqrt(rrij),
1427 cd     &        evdwij
1428             endif
1429 C Calculate gradient components.
1430             e1=e1*eps1*eps2rt**2*eps3rt**2
1431             fac=-expon*(e1+evdwij)
1432             sigder=fac/sigsq
1433             fac=rrij*fac
1434 C Calculate radial part of the gradient
1435             gg(1)=xj*fac
1436             gg(2)=yj*fac
1437             gg(3)=zj*fac
1438 C Calculate the angular part of the gradient and sum add the contributions
1439 C to the appropriate components of the Cartesian gradient.
1440             call sc_grad
1441           enddo      ! j
1442         enddo        ! iint
1443       enddo          ! i
1444 c     stop
1445       return
1446       end
1447 C-----------------------------------------------------------------------------
1448       subroutine egb(evdw)
1449 C
1450 C This subroutine calculates the interaction energy of nonbonded side chains
1451 C assuming the Gay-Berne potential of interaction.
1452 C
1453       implicit real*8 (a-h,o-z)
1454       include 'DIMENSIONS'
1455       include 'COMMON.GEO'
1456       include 'COMMON.VAR'
1457       include 'COMMON.LOCAL'
1458       include 'COMMON.CHAIN'
1459       include 'COMMON.DERIV'
1460       include 'COMMON.NAMES'
1461       include 'COMMON.INTERACT'
1462       include 'COMMON.IOUNITS'
1463       include 'COMMON.CALC'
1464       include 'COMMON.CONTROL'
1465       include 'COMMON.SPLITELE'
1466       include 'COMMON.SBRIDGE'
1467       logical lprn
1468       integer xshift,yshift,zshift
1469       evdw=0.0D0
1470 ccccc      energy_dec=.false.
1471 C      print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1472       evdw=0.0D0
1473       lprn=.false.
1474 c     if (icall.eq.0) lprn=.false.
1475       ind=0
1476 C the loop over all 27 posible neigbours (for xshift=0,yshift=0,zshift=0
1477 C we have the original box)
1478 C      do xshift=-1,1
1479 C      do yshift=-1,1
1480 C      do zshift=-1,1
1481       do i=iatsc_s,iatsc_e
1482         itypi=iabs(itype(i))
1483         if (itypi.eq.ntyp1) cycle
1484         itypi1=iabs(itype(i+1))
1485         xi=c(1,nres+i)
1486         yi=c(2,nres+i)
1487         zi=c(3,nres+i)
1488 C Return atom into box, boxxsize is size of box in x dimension
1489 c  134   continue
1490 c        if (xi.gt.((xshift+0.5d0)*boxxsize)) xi=xi-boxxsize
1491 c        if (xi.lt.((xshift-0.5d0)*boxxsize)) xi=xi+boxxsize
1492 C Condition for being inside the proper box
1493 c        if ((xi.gt.((xshift+0.5d0)*boxxsize)).or.
1494 c     &       (xi.lt.((xshift-0.5d0)*boxxsize))) then
1495 c        go to 134
1496 c        endif
1497 c  135   continue
1498 c        if (yi.gt.((yshift+0.5d0)*boxysize)) yi=yi-boxysize
1499 c        if (yi.lt.((yshift-0.5d0)*boxysize)) yi=yi+boxysize
1500 C Condition for being inside the proper box
1501 c        if ((yi.gt.((yshift+0.5d0)*boxysize)).or.
1502 c     &       (yi.lt.((yshift-0.5d0)*boxysize))) then
1503 c        go to 135
1504 c        endif
1505 c  136   continue
1506 c        if (zi.gt.((zshift+0.5d0)*boxzsize)) zi=zi-boxzsize
1507 c        if (zi.lt.((zshift-0.5d0)*boxzsize)) zi=zi+boxzsize
1508 C Condition for being inside the proper box
1509 c        if ((zi.gt.((zshift+0.5d0)*boxzsize)).or.
1510 c     &       (zi.lt.((zshift-0.5d0)*boxzsize))) then
1511 c        go to 136
1512 c        endif
1513           xi=mod(xi,boxxsize)
1514           if (xi.lt.0) xi=xi+boxxsize
1515           yi=mod(yi,boxysize)
1516           if (yi.lt.0) yi=yi+boxysize
1517           zi=mod(zi,boxzsize)
1518           if (zi.lt.0) zi=zi+boxzsize
1519 C define scaling factor for lipids
1520
1521 C        if (positi.le.0) positi=positi+boxzsize
1522 C        print *,i
1523 C first for peptide groups
1524 c for each residue check if it is in lipid or lipid water border area
1525        if ((zi.gt.bordlipbot)
1526      &.and.(zi.lt.bordliptop)) then
1527 C the energy transfer exist
1528         if (zi.lt.buflipbot) then
1529 C what fraction I am in
1530          fracinbuf=1.0d0-
1531      &        ((zi-bordlipbot)/lipbufthick)
1532 C lipbufthick is thickenes of lipid buffore
1533          sslipi=sscalelip(fracinbuf)
1534          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
1535         elseif (zi.gt.bufliptop) then
1536          fracinbuf=1.0d0-((bordliptop-zi)/lipbufthick)
1537          sslipi=sscalelip(fracinbuf)
1538          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
1539         else
1540          sslipi=1.0d0
1541          ssgradlipi=0.0
1542         endif
1543        else
1544          sslipi=0.0d0
1545          ssgradlipi=0.0
1546        endif
1547
1548 C          xi=xi+xshift*boxxsize
1549 C          yi=yi+yshift*boxysize
1550 C          zi=zi+zshift*boxzsize
1551
1552         dxi=dc_norm(1,nres+i)
1553         dyi=dc_norm(2,nres+i)
1554         dzi=dc_norm(3,nres+i)
1555 c        dsci_inv=dsc_inv(itypi)
1556         dsci_inv=vbld_inv(i+nres)
1557 c        write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)
1558 c        write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi
1559 C
1560 C Calculate SC interaction energy.
1561 C
1562         do iint=1,nint_gr(i)
1563           do j=istart(i,iint),iend(i,iint)
1564             IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN
1565               call dyn_ssbond_ene(i,j,evdwij)
1566               evdw=evdw+evdwij
1567               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)')
1568      &                        'evdw',i,j,evdwij,' ss'
1569             ELSE
1570             ind=ind+1
1571             itypj=iabs(itype(j))
1572             if (itypj.eq.ntyp1) cycle
1573 c            dscj_inv=dsc_inv(itypj)
1574             dscj_inv=vbld_inv(j+nres)
1575 c            write (iout,*) "j",j,dsc_inv(itypj),dscj_inv,
1576 c     &       1.0d0/vbld(j+nres)
1577 c            write (iout,*) "i",i," j", j," itype",itype(i),itype(j)
1578             sig0ij=sigma(itypi,itypj)
1579             chi1=chi(itypi,itypj)
1580             chi2=chi(itypj,itypi)
1581             chi12=chi1*chi2
1582             chip1=chip(itypi)
1583             chip2=chip(itypj)
1584             chip12=chip1*chip2
1585             alf1=alp(itypi)
1586             alf2=alp(itypj)
1587             alf12=0.5D0*(alf1+alf2)
1588 C For diagnostics only!!!
1589 c           chi1=0.0D0
1590 c           chi2=0.0D0
1591 c           chi12=0.0D0
1592 c           chip1=0.0D0
1593 c           chip2=0.0D0
1594 c           chip12=0.0D0
1595 c           alf1=0.0D0
1596 c           alf2=0.0D0
1597 c           alf12=0.0D0
1598             xj=c(1,nres+j)
1599             yj=c(2,nres+j)
1600             zj=c(3,nres+j)
1601 C Return atom J into box the original box
1602 c  137   continue
1603 c        if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
1604 c        if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
1605 C Condition for being inside the proper box
1606 c        if ((xj.gt.((0.5d0)*boxxsize)).or.
1607 c     &       (xj.lt.((-0.5d0)*boxxsize))) then
1608 c        go to 137
1609 c        endif
1610 c  138   continue
1611 c        if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
1612 c        if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
1613 C Condition for being inside the proper box
1614 c        if ((yj.gt.((0.5d0)*boxysize)).or.
1615 c     &       (yj.lt.((-0.5d0)*boxysize))) then
1616 c        go to 138
1617 c        endif
1618 c  139   continue
1619 c        if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
1620 c        if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
1621 C Condition for being inside the proper box
1622 c        if ((zj.gt.((0.5d0)*boxzsize)).or.
1623 c     &       (zj.lt.((-0.5d0)*boxzsize))) then
1624 c        go to 139
1625 c        endif
1626           xj=mod(xj,boxxsize)
1627           if (xj.lt.0) xj=xj+boxxsize
1628           yj=mod(yj,boxysize)
1629           if (yj.lt.0) yj=yj+boxysize
1630           zj=mod(zj,boxzsize)
1631           if (zj.lt.0) zj=zj+boxzsize
1632        if ((zj.gt.bordlipbot)
1633      &.and.(zj.lt.bordliptop)) then
1634 C the energy transfer exist
1635         if (zj.lt.buflipbot) then
1636 C what fraction I am in
1637          fracinbuf=1.0d0-
1638      &        ((zj-bordlipbot)/lipbufthick)
1639 C lipbufthick is thickenes of lipid buffore
1640          sslipj=sscalelip(fracinbuf)
1641          ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
1642         elseif (zj.gt.bufliptop) then
1643          fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
1644          sslipj=sscalelip(fracinbuf)
1645          ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
1646         else
1647          sslipj=1.0d0
1648          ssgradlipj=0.0
1649         endif
1650        else
1651          sslipj=0.0d0
1652          ssgradlipj=0.0
1653        endif
1654       aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
1655      &  +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1656       bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
1657      &  +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1658 C      if (aa.ne.aa_aq(itypi,itypj)) write(63,'(2e10.5)')
1659 C     &(aa-aa_aq(itypi,itypj)),(bb-bb_aq(itypi,itypj))
1660 C      if (ssgradlipj.gt.0.0d0) print *,"??WTF??"
1661 C      print *,sslipi,sslipj,bordlipbot,zi,zj
1662       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
1663       xj_safe=xj
1664       yj_safe=yj
1665       zj_safe=zj
1666       subchap=0
1667       do xshift=-1,1
1668       do yshift=-1,1
1669       do zshift=-1,1
1670           xj=xj_safe+xshift*boxxsize
1671           yj=yj_safe+yshift*boxysize
1672           zj=zj_safe+zshift*boxzsize
1673           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
1674           if(dist_temp.lt.dist_init) then
1675             dist_init=dist_temp
1676             xj_temp=xj
1677             yj_temp=yj
1678             zj_temp=zj
1679             subchap=1
1680           endif
1681        enddo
1682        enddo
1683        enddo
1684        if (subchap.eq.1) then
1685           xj=xj_temp-xi
1686           yj=yj_temp-yi
1687           zj=zj_temp-zi
1688        else
1689           xj=xj_safe-xi
1690           yj=yj_safe-yi
1691           zj=zj_safe-zi
1692        endif
1693             dxj=dc_norm(1,nres+j)
1694             dyj=dc_norm(2,nres+j)
1695             dzj=dc_norm(3,nres+j)
1696 C            xj=xj-xi
1697 C            yj=yj-yi
1698 C            zj=zj-zi
1699 c            write (iout,*) "dcnorj",dxi*dxi+dyi*dyi+dzi*dzi
1700 c            write (iout,*) "j",j," dc_norm",
1701 c     &       dc_norm(1,nres+j),dc_norm(2,nres+j),dc_norm(3,nres+j)
1702             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1703             rij=dsqrt(rrij)
1704             sss=sscale((1.0d0/rij)/sigma(itypi,itypj))
1705             sssgrad=sscagrad((1.0d0/rij)/sigma(itypi,itypj))
1706
1707 c            write (iout,'(a7,4f8.3)')
1708 c    &      "ssscale",sss,((1.0d0/rij)/sigma(itypi,itypj)),r_cut,rlamb
1709             if (sss.gt.0.0d0) then
1710 C Calculate angle-dependent terms of energy and contributions to their
1711 C derivatives.
1712             call sc_angular
1713             sigsq=1.0D0/sigsq
1714             sig=sig0ij*dsqrt(sigsq)
1715             rij_shift=1.0D0/rij-sig+sig0ij
1716 c for diagnostics; uncomment
1717 c            rij_shift=1.2*sig0ij
1718 C I hate to put IF's in the loops, but here don't have another choice!!!!
1719             if (rij_shift.le.0.0D0) then
1720               evdw=1.0D20
1721 cd              write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1722 cd     &        restyp(itypi),i,restyp(itypj),j,
1723 cd     &        rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq)
1724               return
1725             endif
1726             sigder=-sig*sigsq
1727 c---------------------------------------------------------------
1728             rij_shift=1.0D0/rij_shift
1729             fac=rij_shift**expon
1730 C here to start with
1731 C            if (c(i,3).gt.
1732             faclip=fac
1733             e1=fac*fac*aa
1734             e2=fac*bb
1735             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1736             eps2der=evdwij*eps3rt
1737             eps3der=evdwij*eps2rt
1738 C       write(63,'(2i3,2e10.3,2f10.5)') i,j,aa,bb, evdwij,
1739 C     &((sslipi+sslipj)/2.0d0+
1740 C     &(2.0d0-sslipi-sslipj)/2.0d0)
1741 c            write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt,
1742 c     &        " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2
1743             evdwij=evdwij*eps2rt*eps3rt
1744             evdw=evdw+evdwij*sss
1745             if (lprn) then
1746             sigm=dabs(aa/bb)**(1.0D0/6.0D0)
1747             epsi=bb**2/aa
1748             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1749      &        restyp(itypi),i,restyp(itypj),j,
1750      &        epsi,sigm,chi1,chi2,chip1,chip2,
1751      &        eps1,eps2rt**2,eps3rt**2,sig,sig0ij,
1752      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1753      &        evdwij
1754             endif
1755
1756             if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
1757      &                        'evdw',i,j,evdwij
1758
1759 C Calculate gradient components.
1760             e1=e1*eps1*eps2rt**2*eps3rt**2
1761             fac=-expon*(e1+evdwij)*rij_shift
1762             sigder=fac*sigder
1763             fac=rij*fac
1764 c            print '(2i4,6f8.4)',i,j,sss,sssgrad*
1765 c     &      evdwij,fac,sigma(itypi,itypj),expon
1766             fac=fac+evdwij/sss*sssgrad/sigma(itypi,itypj)*rij
1767 c            fac=0.0d0
1768 C Calculate the radial part of the gradient
1769             gg_lipi(3)=eps1*(eps2rt*eps2rt)
1770      &*(eps3rt*eps3rt)*sss/2.0d0*(faclip*faclip*
1771      & (aa_lip(itypi,itypj)-aa_aq(itypi,itypj))
1772      &+faclip*(bb_lip(itypi,itypj)-bb_aq(itypi,itypj)))
1773             gg_lipj(3)=ssgradlipj*gg_lipi(3)
1774             gg_lipi(3)=gg_lipi(3)*ssgradlipi
1775 C            gg_lipi(3)=0.0d0
1776 C            gg_lipj(3)=0.0d0
1777             gg(1)=xj*fac
1778             gg(2)=yj*fac
1779             gg(3)=zj*fac
1780 C Calculate angular part of the gradient.
1781             call sc_grad
1782             endif
1783             ENDIF    ! dyn_ss
1784           enddo      ! j
1785         enddo        ! iint
1786       enddo          ! i
1787 C      enddo          ! zshift
1788 C      enddo          ! yshift
1789 C      enddo          ! xshift
1790 c      write (iout,*) "Number of loop steps in EGB:",ind
1791 cccc      energy_dec=.false.
1792       return
1793       end
1794 C-----------------------------------------------------------------------------
1795       subroutine egbv(evdw)
1796 C
1797 C This subroutine calculates the interaction energy of nonbonded side chains
1798 C assuming the Gay-Berne-Vorobjev potential of interaction.
1799 C
1800       implicit real*8 (a-h,o-z)
1801       include 'DIMENSIONS'
1802       include 'COMMON.GEO'
1803       include 'COMMON.VAR'
1804       include 'COMMON.LOCAL'
1805       include 'COMMON.CHAIN'
1806       include 'COMMON.DERIV'
1807       include 'COMMON.NAMES'
1808       include 'COMMON.INTERACT'
1809       include 'COMMON.IOUNITS'
1810       include 'COMMON.CALC'
1811       common /srutu/ icall
1812       logical lprn
1813       evdw=0.0D0
1814 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1815       evdw=0.0D0
1816       lprn=.false.
1817 c     if (icall.eq.0) lprn=.true.
1818       ind=0
1819       do i=iatsc_s,iatsc_e
1820         itypi=iabs(itype(i))
1821         if (itypi.eq.ntyp1) cycle
1822         itypi1=iabs(itype(i+1))
1823         xi=c(1,nres+i)
1824         yi=c(2,nres+i)
1825         zi=c(3,nres+i)
1826           xi=mod(xi,boxxsize)
1827           if (xi.lt.0) xi=xi+boxxsize
1828           yi=mod(yi,boxysize)
1829           if (yi.lt.0) yi=yi+boxysize
1830           zi=mod(zi,boxzsize)
1831           if (zi.lt.0) zi=zi+boxzsize
1832 C define scaling factor for lipids
1833
1834 C        if (positi.le.0) positi=positi+boxzsize
1835 C        print *,i
1836 C first for peptide groups
1837 c for each residue check if it is in lipid or lipid water border area
1838        if ((zi.gt.bordlipbot)
1839      &.and.(zi.lt.bordliptop)) then
1840 C the energy transfer exist
1841         if (zi.lt.buflipbot) then
1842 C what fraction I am in
1843          fracinbuf=1.0d0-
1844      &        ((zi-bordlipbot)/lipbufthick)
1845 C lipbufthick is thickenes of lipid buffore
1846          sslipi=sscalelip(fracinbuf)
1847          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
1848         elseif (zi.gt.bufliptop) then
1849          fracinbuf=1.0d0-((bordliptop-zi)/lipbufthick)
1850          sslipi=sscalelip(fracinbuf)
1851          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
1852         else
1853          sslipi=1.0d0
1854          ssgradlipi=0.0
1855         endif
1856        else
1857          sslipi=0.0d0
1858          ssgradlipi=0.0
1859        endif
1860
1861         dxi=dc_norm(1,nres+i)
1862         dyi=dc_norm(2,nres+i)
1863         dzi=dc_norm(3,nres+i)
1864 c        dsci_inv=dsc_inv(itypi)
1865         dsci_inv=vbld_inv(i+nres)
1866 C
1867 C Calculate SC interaction energy.
1868 C
1869         do iint=1,nint_gr(i)
1870           do j=istart(i,iint),iend(i,iint)
1871             ind=ind+1
1872             itypj=iabs(itype(j))
1873             if (itypj.eq.ntyp1) cycle
1874 c            dscj_inv=dsc_inv(itypj)
1875             dscj_inv=vbld_inv(j+nres)
1876             sig0ij=sigma(itypi,itypj)
1877             r0ij=r0(itypi,itypj)
1878             chi1=chi(itypi,itypj)
1879             chi2=chi(itypj,itypi)
1880             chi12=chi1*chi2
1881             chip1=chip(itypi)
1882             chip2=chip(itypj)
1883             chip12=chip1*chip2
1884             alf1=alp(itypi)
1885             alf2=alp(itypj)
1886             alf12=0.5D0*(alf1+alf2)
1887 C For diagnostics only!!!
1888 c           chi1=0.0D0
1889 c           chi2=0.0D0
1890 c           chi12=0.0D0
1891 c           chip1=0.0D0
1892 c           chip2=0.0D0
1893 c           chip12=0.0D0
1894 c           alf1=0.0D0
1895 c           alf2=0.0D0
1896 c           alf12=0.0D0
1897 C            xj=c(1,nres+j)-xi
1898 C            yj=c(2,nres+j)-yi
1899 C            zj=c(3,nres+j)-zi
1900           xj=mod(xj,boxxsize)
1901           if (xj.lt.0) xj=xj+boxxsize
1902           yj=mod(yj,boxysize)
1903           if (yj.lt.0) yj=yj+boxysize
1904           zj=mod(zj,boxzsize)
1905           if (zj.lt.0) zj=zj+boxzsize
1906        if ((zj.gt.bordlipbot)
1907      &.and.(zj.lt.bordliptop)) then
1908 C the energy transfer exist
1909         if (zj.lt.buflipbot) then
1910 C what fraction I am in
1911          fracinbuf=1.0d0-
1912      &        ((zj-bordlipbot)/lipbufthick)
1913 C lipbufthick is thickenes of lipid buffore
1914          sslipj=sscalelip(fracinbuf)
1915          ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
1916         elseif (zj.gt.bufliptop) then
1917          fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
1918          sslipj=sscalelip(fracinbuf)
1919          ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
1920         else
1921          sslipj=1.0d0
1922          ssgradlipj=0.0
1923         endif
1924        else
1925          sslipj=0.0d0
1926          ssgradlipj=0.0
1927        endif
1928       aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
1929      &  +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1930       bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
1931      &  +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1932 C      if (aa.ne.aa_aq(itypi,itypj)) write(63,'2e10.5')
1933 C     &(aa-aa_aq(itypi,itypj)),(bb-bb_aq(itypi,itypj))
1934       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
1935       xj_safe=xj
1936       yj_safe=yj
1937       zj_safe=zj
1938       subchap=0
1939       do xshift=-1,1
1940       do yshift=-1,1
1941       do zshift=-1,1
1942           xj=xj_safe+xshift*boxxsize
1943           yj=yj_safe+yshift*boxysize
1944           zj=zj_safe+zshift*boxzsize
1945           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
1946           if(dist_temp.lt.dist_init) then
1947             dist_init=dist_temp
1948             xj_temp=xj
1949             yj_temp=yj
1950             zj_temp=zj
1951             subchap=1
1952           endif
1953        enddo
1954        enddo
1955        enddo
1956        if (subchap.eq.1) then
1957           xj=xj_temp-xi
1958           yj=yj_temp-yi
1959           zj=zj_temp-zi
1960        else
1961           xj=xj_safe-xi
1962           yj=yj_safe-yi
1963           zj=zj_safe-zi
1964        endif
1965             dxj=dc_norm(1,nres+j)
1966             dyj=dc_norm(2,nres+j)
1967             dzj=dc_norm(3,nres+j)
1968             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1969             rij=dsqrt(rrij)
1970 C Calculate angle-dependent terms of energy and contributions to their
1971 C derivatives.
1972             call sc_angular
1973             sigsq=1.0D0/sigsq
1974             sig=sig0ij*dsqrt(sigsq)
1975             rij_shift=1.0D0/rij-sig+r0ij
1976 C I hate to put IF's in the loops, but here don't have another choice!!!!
1977             if (rij_shift.le.0.0D0) then
1978               evdw=1.0D20
1979               return
1980             endif
1981             sigder=-sig*sigsq
1982 c---------------------------------------------------------------
1983             rij_shift=1.0D0/rij_shift
1984             fac=rij_shift**expon
1985             e1=fac*fac*aa
1986             e2=fac*bb
1987             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1988             eps2der=evdwij*eps3rt
1989             eps3der=evdwij*eps2rt
1990             fac_augm=rrij**expon
1991             e_augm=augm(itypi,itypj)*fac_augm
1992             evdwij=evdwij*eps2rt*eps3rt
1993             evdw=evdw+evdwij+e_augm
1994             if (lprn) then
1995             sigm=dabs(aa/bb)**(1.0D0/6.0D0)
1996             epsi=bb**2/aa
1997             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1998      &        restyp(itypi),i,restyp(itypj),j,
1999      &        epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),
2000      &        chi1,chi2,chip1,chip2,
2001      &        eps1,eps2rt**2,eps3rt**2,
2002      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
2003      &        evdwij+e_augm
2004             endif
2005 C Calculate gradient components.
2006             e1=e1*eps1*eps2rt**2*eps3rt**2
2007             fac=-expon*(e1+evdwij)*rij_shift
2008             sigder=fac*sigder
2009             fac=rij*fac-2*expon*rrij*e_augm
2010             fac=fac+evdwij/sss*sssgrad/sigma(itypi,itypj)*rij
2011 C Calculate the radial part of the gradient
2012             gg(1)=xj*fac
2013             gg(2)=yj*fac
2014             gg(3)=zj*fac
2015 C Calculate angular part of the gradient.
2016             call sc_grad
2017           enddo      ! j
2018         enddo        ! iint
2019       enddo          ! i
2020       end
2021 C-----------------------------------------------------------------------------
2022       subroutine sc_angular
2023 C Calculate eps1,eps2,eps3,sigma, and parts of their derivatives in om1,om2,
2024 C om12. Called by ebp, egb, and egbv.
2025       implicit none
2026       include 'COMMON.CALC'
2027       include 'COMMON.IOUNITS'
2028       erij(1)=xj*rij
2029       erij(2)=yj*rij
2030       erij(3)=zj*rij
2031       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
2032       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
2033       om12=dxi*dxj+dyi*dyj+dzi*dzj
2034       chiom12=chi12*om12
2035 C Calculate eps1(om12) and its derivative in om12
2036       faceps1=1.0D0-om12*chiom12
2037       faceps1_inv=1.0D0/faceps1
2038       eps1=dsqrt(faceps1_inv)
2039 C Following variable is eps1*deps1/dom12
2040       eps1_om12=faceps1_inv*chiom12
2041 c diagnostics only
2042 c      faceps1_inv=om12
2043 c      eps1=om12
2044 c      eps1_om12=1.0d0
2045 c      write (iout,*) "om12",om12," eps1",eps1
2046 C Calculate sigma(om1,om2,om12) and the derivatives of sigma**2 in om1,om2,
2047 C and om12.
2048       om1om2=om1*om2
2049       chiom1=chi1*om1
2050       chiom2=chi2*om2
2051       facsig=om1*chiom1+om2*chiom2-2.0D0*om1om2*chiom12
2052       sigsq=1.0D0-facsig*faceps1_inv
2053       sigsq_om1=(chiom1-chiom12*om2)*faceps1_inv
2054       sigsq_om2=(chiom2-chiom12*om1)*faceps1_inv
2055       sigsq_om12=-chi12*(om1om2*faceps1-om12*facsig)*faceps1_inv**2
2056 c diagnostics only
2057 c      sigsq=1.0d0
2058 c      sigsq_om1=0.0d0
2059 c      sigsq_om2=0.0d0
2060 c      sigsq_om12=0.0d0
2061 c      write (iout,*) "chiom1",chiom1," chiom2",chiom2," chiom12",chiom12
2062 c      write (iout,*) "faceps1",faceps1," faceps1_inv",faceps1_inv,
2063 c     &    " eps1",eps1
2064 C Calculate eps2 and its derivatives in om1, om2, and om12.
2065       chipom1=chip1*om1
2066       chipom2=chip2*om2
2067       chipom12=chip12*om12
2068       facp=1.0D0-om12*chipom12
2069       facp_inv=1.0D0/facp
2070       facp1=om1*chipom1+om2*chipom2-2.0D0*om1om2*chipom12
2071 c      write (iout,*) "chipom1",chipom1," chipom2",chipom2,
2072 c     &  " chipom12",chipom12," facp",facp," facp_inv",facp_inv
2073 C Following variable is the square root of eps2
2074       eps2rt=1.0D0-facp1*facp_inv
2075 C Following three variables are the derivatives of the square root of eps
2076 C in om1, om2, and om12.
2077       eps2rt_om1=-4.0D0*(chipom1-chipom12*om2)*facp_inv
2078       eps2rt_om2=-4.0D0*(chipom2-chipom12*om1)*facp_inv
2079       eps2rt_om12=4.0D0*chip12*(om1om2*facp-om12*facp1)*facp_inv**2
2080 C Evaluate the "asymmetric" factor in the VDW constant, eps3
2081       eps3rt=1.0D0-alf1*om1+alf2*om2-alf12*om12
2082 c      write (iout,*) "eps2rt",eps2rt," eps3rt",eps3rt
2083 c      write (iout,*) "eps2rt_om1",eps2rt_om1," eps2rt_om2",eps2rt_om2,
2084 c     &  " eps2rt_om12",eps2rt_om12
2085 C Calculate whole angle-dependent part of epsilon and contributions
2086 C to its derivatives
2087       return
2088       end
2089 C----------------------------------------------------------------------------
2090       subroutine sc_grad
2091       implicit real*8 (a-h,o-z)
2092       include 'DIMENSIONS'
2093       include 'COMMON.CHAIN'
2094       include 'COMMON.DERIV'
2095       include 'COMMON.CALC'
2096       include 'COMMON.IOUNITS'
2097       double precision dcosom1(3),dcosom2(3)
2098 cc      print *,'sss=',sss
2099       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
2100       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
2101       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12
2102      &     -2.0D0*alf12*eps3der+sigder*sigsq_om12
2103 c diagnostics only
2104 c      eom1=0.0d0
2105 c      eom2=0.0d0
2106 c      eom12=evdwij*eps1_om12
2107 c end diagnostics
2108 c      write (iout,*) "eps2der",eps2der," eps3der",eps3der,
2109 c     &  " sigder",sigder
2110 c      write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12
2111 c      write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12
2112       do k=1,3
2113         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
2114         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
2115       enddo
2116       do k=1,3
2117         gg(k)=(gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k))*sss
2118       enddo
2119 c      write (iout,*) "gg",(gg(k),k=1,3)
2120       do k=1,3
2121         gvdwx(k,i)=gvdwx(k,i)-gg(k)+gg_lipi(k)
2122      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
2123      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv*sss
2124         gvdwx(k,j)=gvdwx(k,j)+gg(k)+gg_lipj(k)
2125      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
2126      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv*sss
2127 c        write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
2128 c     &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
2129 c        write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
2130 c     &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
2131       enddo
2132 C
2133 C Calculate the components of the gradient in DC and X
2134 C
2135 cgrad      do k=i,j-1
2136 cgrad        do l=1,3
2137 cgrad          gvdwc(l,k)=gvdwc(l,k)+gg(l)
2138 cgrad        enddo
2139 cgrad      enddo
2140       do l=1,3
2141         gvdwc(l,i)=gvdwc(l,i)-gg(l)+gg_lipi(l)
2142         gvdwc(l,j)=gvdwc(l,j)+gg(l)+gg_lipj(l)
2143       enddo
2144       return
2145       end
2146 C-----------------------------------------------------------------------
2147       subroutine e_softsphere(evdw)
2148 C
2149 C This subroutine calculates the interaction energy of nonbonded side chains
2150 C assuming the LJ potential of interaction.
2151 C
2152       implicit real*8 (a-h,o-z)
2153       include 'DIMENSIONS'
2154       parameter (accur=1.0d-10)
2155       include 'COMMON.GEO'
2156       include 'COMMON.VAR'
2157       include 'COMMON.LOCAL'
2158       include 'COMMON.CHAIN'
2159       include 'COMMON.DERIV'
2160       include 'COMMON.INTERACT'
2161       include 'COMMON.TORSION'
2162       include 'COMMON.SBRIDGE'
2163       include 'COMMON.NAMES'
2164       include 'COMMON.IOUNITS'
2165       include 'COMMON.CONTACTS'
2166       dimension gg(3)
2167 cd    print *,'Entering Esoft_sphere nnt=',nnt,' nct=',nct
2168       evdw=0.0D0
2169       do i=iatsc_s,iatsc_e
2170         itypi=iabs(itype(i))
2171         if (itypi.eq.ntyp1) cycle
2172         itypi1=iabs(itype(i+1))
2173         xi=c(1,nres+i)
2174         yi=c(2,nres+i)
2175         zi=c(3,nres+i)
2176 C
2177 C Calculate SC interaction energy.
2178 C
2179         do iint=1,nint_gr(i)
2180 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
2181 cd   &                  'iend=',iend(i,iint)
2182           do j=istart(i,iint),iend(i,iint)
2183             itypj=iabs(itype(j))
2184             if (itypj.eq.ntyp1) cycle
2185             xj=c(1,nres+j)-xi
2186             yj=c(2,nres+j)-yi
2187             zj=c(3,nres+j)-zi
2188             rij=xj*xj+yj*yj+zj*zj
2189 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
2190             r0ij=r0(itypi,itypj)
2191             r0ijsq=r0ij*r0ij
2192 c            print *,i,j,r0ij,dsqrt(rij)
2193             if (rij.lt.r0ijsq) then
2194               evdwij=0.25d0*(rij-r0ijsq)**2
2195               fac=rij-r0ijsq
2196             else
2197               evdwij=0.0d0
2198               fac=0.0d0
2199             endif
2200             evdw=evdw+evdwij
2201 C
2202 C Calculate the components of the gradient in DC and X
2203 C
2204             gg(1)=xj*fac
2205             gg(2)=yj*fac
2206             gg(3)=zj*fac
2207             do k=1,3
2208               gvdwx(k,i)=gvdwx(k,i)-gg(k)
2209               gvdwx(k,j)=gvdwx(k,j)+gg(k)
2210               gvdwc(k,i)=gvdwc(k,i)-gg(k)
2211               gvdwc(k,j)=gvdwc(k,j)+gg(k)
2212             enddo
2213 cgrad            do k=i,j-1
2214 cgrad              do l=1,3
2215 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
2216 cgrad              enddo
2217 cgrad            enddo
2218           enddo ! j
2219         enddo ! iint
2220       enddo ! i
2221       return
2222       end
2223 C--------------------------------------------------------------------------
2224       subroutine eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,
2225      &              eello_turn4)
2226 C
2227 C Soft-sphere potential of p-p interaction
2228 C
2229       implicit real*8 (a-h,o-z)
2230       include 'DIMENSIONS'
2231       include 'COMMON.CONTROL'
2232       include 'COMMON.IOUNITS'
2233       include 'COMMON.GEO'
2234       include 'COMMON.VAR'
2235       include 'COMMON.LOCAL'
2236       include 'COMMON.CHAIN'
2237       include 'COMMON.DERIV'
2238       include 'COMMON.INTERACT'
2239       include 'COMMON.CONTACTS'
2240       include 'COMMON.TORSION'
2241       include 'COMMON.VECTORS'
2242       include 'COMMON.FFIELD'
2243       dimension ggg(3)
2244 C      write(iout,*) 'In EELEC_soft_sphere'
2245       ees=0.0D0
2246       evdw1=0.0D0
2247       eel_loc=0.0d0
2248       eello_turn3=0.0d0
2249       eello_turn4=0.0d0
2250       ind=0
2251       do i=iatel_s,iatel_e
2252         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
2253         dxi=dc(1,i)
2254         dyi=dc(2,i)
2255         dzi=dc(3,i)
2256         xmedi=c(1,i)+0.5d0*dxi
2257         ymedi=c(2,i)+0.5d0*dyi
2258         zmedi=c(3,i)+0.5d0*dzi
2259           xmedi=mod(xmedi,boxxsize)
2260           if (xmedi.lt.0) xmedi=xmedi+boxxsize
2261           ymedi=mod(ymedi,boxysize)
2262           if (ymedi.lt.0) ymedi=ymedi+boxysize
2263           zmedi=mod(zmedi,boxzsize)
2264           if (zmedi.lt.0) zmedi=zmedi+boxzsize
2265         num_conti=0
2266 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
2267         do j=ielstart(i),ielend(i)
2268           if (itype(j).eq.ntyp1 .or. itype(j+1).eq.ntyp1) cycle
2269           ind=ind+1
2270           iteli=itel(i)
2271           itelj=itel(j)
2272           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
2273           r0ij=rpp(iteli,itelj)
2274           r0ijsq=r0ij*r0ij
2275           dxj=dc(1,j)
2276           dyj=dc(2,j)
2277           dzj=dc(3,j)
2278           xj=c(1,j)+0.5D0*dxj
2279           yj=c(2,j)+0.5D0*dyj
2280           zj=c(3,j)+0.5D0*dzj
2281           xj=mod(xj,boxxsize)
2282           if (xj.lt.0) xj=xj+boxxsize
2283           yj=mod(yj,boxysize)
2284           if (yj.lt.0) yj=yj+boxysize
2285           zj=mod(zj,boxzsize)
2286           if (zj.lt.0) zj=zj+boxzsize
2287       dist_init=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
2288       xj_safe=xj
2289       yj_safe=yj
2290       zj_safe=zj
2291       isubchap=0
2292       do xshift=-1,1
2293       do yshift=-1,1
2294       do zshift=-1,1
2295           xj=xj_safe+xshift*boxxsize
2296           yj=yj_safe+yshift*boxysize
2297           zj=zj_safe+zshift*boxzsize
2298           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
2299           if(dist_temp.lt.dist_init) then
2300             dist_init=dist_temp
2301             xj_temp=xj
2302             yj_temp=yj
2303             zj_temp=zj
2304             isubchap=1
2305           endif
2306        enddo
2307        enddo
2308        enddo
2309        if (isubchap.eq.1) then
2310           xj=xj_temp-xmedi
2311           yj=yj_temp-ymedi
2312           zj=zj_temp-zmedi
2313        else
2314           xj=xj_safe-xmedi
2315           yj=yj_safe-ymedi
2316           zj=zj_safe-zmedi
2317        endif
2318           rij=xj*xj+yj*yj+zj*zj
2319             sss=sscale(sqrt(rij))
2320             sssgrad=sscagrad(sqrt(rij))
2321           if (rij.lt.r0ijsq) then
2322             evdw1ij=0.25d0*(rij-r0ijsq)**2
2323             fac=rij-r0ijsq
2324           else
2325             evdw1ij=0.0d0
2326             fac=0.0d0
2327           endif
2328           evdw1=evdw1+evdw1ij*sss
2329 C
2330 C Calculate contributions to the Cartesian gradient.
2331 C
2332           ggg(1)=fac*xj*sssgrad
2333           ggg(2)=fac*yj*sssgrad
2334           ggg(3)=fac*zj*sssgrad
2335           do k=1,3
2336             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
2337             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
2338           enddo
2339 *
2340 * Loop over residues i+1 thru j-1.
2341 *
2342 cgrad          do k=i+1,j-1
2343 cgrad            do l=1,3
2344 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
2345 cgrad            enddo
2346 cgrad          enddo
2347         enddo ! j
2348       enddo   ! i
2349 cgrad      do i=nnt,nct-1
2350 cgrad        do k=1,3
2351 cgrad          gelc(k,i)=gelc(k,i)+0.5d0*gelc(k,i)
2352 cgrad        enddo
2353 cgrad        do j=i+1,nct-1
2354 cgrad          do k=1,3
2355 cgrad            gelc(k,i)=gelc(k,i)+gelc(k,j)
2356 cgrad          enddo
2357 cgrad        enddo
2358 cgrad      enddo
2359       return
2360       end
2361 c------------------------------------------------------------------------------
2362       subroutine vec_and_deriv
2363       implicit real*8 (a-h,o-z)
2364       include 'DIMENSIONS'
2365 #ifdef MPI
2366       include 'mpif.h'
2367 #endif
2368       include 'COMMON.IOUNITS'
2369       include 'COMMON.GEO'
2370       include 'COMMON.VAR'
2371       include 'COMMON.LOCAL'
2372       include 'COMMON.CHAIN'
2373       include 'COMMON.VECTORS'
2374       include 'COMMON.SETUP'
2375       include 'COMMON.TIME1'
2376       dimension uyder(3,3,2),uzder(3,3,2),vbld_inv_temp(2)
2377 C Compute the local reference systems. For reference system (i), the
2378 C X-axis points from CA(i) to CA(i+1), the Y axis is in the
2379 C CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
2380 #ifdef PARVEC
2381       do i=ivec_start,ivec_end
2382 #else
2383       do i=1,nres-1
2384 #endif
2385           if (i.eq.nres-1) then
2386 C Case of the last full residue
2387 C Compute the Z-axis
2388             call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
2389             costh=dcos(pi-theta(nres))
2390             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2391             do k=1,3
2392               uz(k,i)=fac*uz(k,i)
2393             enddo
2394 C Compute the derivatives of uz
2395             uzder(1,1,1)= 0.0d0
2396             uzder(2,1,1)=-dc_norm(3,i-1)
2397             uzder(3,1,1)= dc_norm(2,i-1)
2398             uzder(1,2,1)= dc_norm(3,i-1)
2399             uzder(2,2,1)= 0.0d0
2400             uzder(3,2,1)=-dc_norm(1,i-1)
2401             uzder(1,3,1)=-dc_norm(2,i-1)
2402             uzder(2,3,1)= dc_norm(1,i-1)
2403             uzder(3,3,1)= 0.0d0
2404             uzder(1,1,2)= 0.0d0
2405             uzder(2,1,2)= dc_norm(3,i)
2406             uzder(3,1,2)=-dc_norm(2,i)
2407             uzder(1,2,2)=-dc_norm(3,i)
2408             uzder(2,2,2)= 0.0d0
2409             uzder(3,2,2)= dc_norm(1,i)
2410             uzder(1,3,2)= dc_norm(2,i)
2411             uzder(2,3,2)=-dc_norm(1,i)
2412             uzder(3,3,2)= 0.0d0
2413 C Compute the Y-axis
2414             facy=fac
2415             do k=1,3
2416               uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
2417             enddo
2418 C Compute the derivatives of uy
2419             do j=1,3
2420               do k=1,3
2421                 uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i)
2422      &                        -dc_norm(k,i)*dc_norm(j,i-1)
2423                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2424               enddo
2425               uyder(j,j,1)=uyder(j,j,1)-costh
2426               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2427             enddo
2428             do j=1,2
2429               do k=1,3
2430                 do l=1,3
2431                   uygrad(l,k,j,i)=uyder(l,k,j)
2432                   uzgrad(l,k,j,i)=uzder(l,k,j)
2433                 enddo
2434               enddo
2435             enddo
2436             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2437             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2438             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2439             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2440           else
2441 C Other residues
2442 C Compute the Z-axis
2443             call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
2444             costh=dcos(pi-theta(i+2))
2445             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2446             do k=1,3
2447               uz(k,i)=fac*uz(k,i)
2448             enddo
2449 C Compute the derivatives of uz
2450             uzder(1,1,1)= 0.0d0
2451             uzder(2,1,1)=-dc_norm(3,i+1)
2452             uzder(3,1,1)= dc_norm(2,i+1)
2453             uzder(1,2,1)= dc_norm(3,i+1)
2454             uzder(2,2,1)= 0.0d0
2455             uzder(3,2,1)=-dc_norm(1,i+1)
2456             uzder(1,3,1)=-dc_norm(2,i+1)
2457             uzder(2,3,1)= dc_norm(1,i+1)
2458             uzder(3,3,1)= 0.0d0
2459             uzder(1,1,2)= 0.0d0
2460             uzder(2,1,2)= dc_norm(3,i)
2461             uzder(3,1,2)=-dc_norm(2,i)
2462             uzder(1,2,2)=-dc_norm(3,i)
2463             uzder(2,2,2)= 0.0d0
2464             uzder(3,2,2)= dc_norm(1,i)
2465             uzder(1,3,2)= dc_norm(2,i)
2466             uzder(2,3,2)=-dc_norm(1,i)
2467             uzder(3,3,2)= 0.0d0
2468 C Compute the Y-axis
2469             facy=fac
2470             do k=1,3
2471               uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
2472             enddo
2473 C Compute the derivatives of uy
2474             do j=1,3
2475               do k=1,3
2476                 uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i)
2477      &                        -dc_norm(k,i)*dc_norm(j,i+1)
2478                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2479               enddo
2480               uyder(j,j,1)=uyder(j,j,1)-costh
2481               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2482             enddo
2483             do j=1,2
2484               do k=1,3
2485                 do l=1,3
2486                   uygrad(l,k,j,i)=uyder(l,k,j)
2487                   uzgrad(l,k,j,i)=uzder(l,k,j)
2488                 enddo
2489               enddo
2490             enddo
2491             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2492             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2493             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2494             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2495           endif
2496       enddo
2497       do i=1,nres-1
2498         vbld_inv_temp(1)=vbld_inv(i+1)
2499         if (i.lt.nres-1) then
2500           vbld_inv_temp(2)=vbld_inv(i+2)
2501           else
2502           vbld_inv_temp(2)=vbld_inv(i)
2503           endif
2504         do j=1,2
2505           do k=1,3
2506             do l=1,3
2507               uygrad(l,k,j,i)=vbld_inv_temp(j)*uygrad(l,k,j,i)
2508               uzgrad(l,k,j,i)=vbld_inv_temp(j)*uzgrad(l,k,j,i)
2509             enddo
2510           enddo
2511         enddo
2512       enddo
2513 #if defined(PARVEC) && defined(MPI)
2514       if (nfgtasks1.gt.1) then
2515         time00=MPI_Wtime()
2516 c        print *,"Processor",fg_rank1,kolor1," ivec_start",ivec_start,
2517 c     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks1-1),
2518 c     &   " ivec_count",(ivec_count(i),i=0,nfgtasks1-1)
2519         call MPI_Allgatherv(uy(1,ivec_start),ivec_count(fg_rank1),
2520      &   MPI_UYZ,uy(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
2521      &   FG_COMM1,IERR)
2522         call MPI_Allgatherv(uz(1,ivec_start),ivec_count(fg_rank1),
2523      &   MPI_UYZ,uz(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
2524      &   FG_COMM1,IERR)
2525         call MPI_Allgatherv(uygrad(1,1,1,ivec_start),
2526      &   ivec_count(fg_rank1),MPI_UYZGRAD,uygrad(1,1,1,1),ivec_count(0),
2527      &   ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2528         call MPI_Allgatherv(uzgrad(1,1,1,ivec_start),
2529      &   ivec_count(fg_rank1),MPI_UYZGRAD,uzgrad(1,1,1,1),ivec_count(0),
2530      &   ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2531         time_gather=time_gather+MPI_Wtime()-time00
2532       endif
2533 c      if (fg_rank.eq.0) then
2534 c        write (iout,*) "Arrays UY and UZ"
2535 c        do i=1,nres-1
2536 c          write (iout,'(i5,3f10.5,5x,3f10.5)') i,(uy(k,i),k=1,3),
2537 c     &     (uz(k,i),k=1,3)
2538 c        enddo
2539 c      endif
2540 #endif
2541       return
2542       end
2543 C-----------------------------------------------------------------------------
2544       subroutine check_vecgrad
2545       implicit real*8 (a-h,o-z)
2546       include 'DIMENSIONS'
2547       include 'COMMON.IOUNITS'
2548       include 'COMMON.GEO'
2549       include 'COMMON.VAR'
2550       include 'COMMON.LOCAL'
2551       include 'COMMON.CHAIN'
2552       include 'COMMON.VECTORS'
2553       dimension uygradt(3,3,2,maxres),uzgradt(3,3,2,maxres)
2554       dimension uyt(3,maxres),uzt(3,maxres)
2555       dimension uygradn(3,3,2),uzgradn(3,3,2),erij(3)
2556       double precision delta /1.0d-7/
2557       call vec_and_deriv
2558 cd      do i=1,nres
2559 crc          write(iout,'(2i5,2(3f10.5,5x))') i,1,dc_norm(:,i)
2560 crc          write(iout,'(2i5,2(3f10.5,5x))') i,2,uy(:,i)
2561 crc          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,uz(:,i)
2562 cd          write(iout,'(2i5,2(3f10.5,5x))') i,1,
2563 cd     &     (dc_norm(if90,i),if90=1,3)
2564 cd          write(iout,'(2i5,2(3f10.5,5x))') i,2,(uy(if90,i),if90=1,3)
2565 cd          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,(uz(if90,i),if90=1,3)
2566 cd          write(iout,'(a)')
2567 cd      enddo
2568       do i=1,nres
2569         do j=1,2
2570           do k=1,3
2571             do l=1,3
2572               uygradt(l,k,j,i)=uygrad(l,k,j,i)
2573               uzgradt(l,k,j,i)=uzgrad(l,k,j,i)
2574             enddo
2575           enddo
2576         enddo
2577       enddo
2578       call vec_and_deriv
2579       do i=1,nres
2580         do j=1,3
2581           uyt(j,i)=uy(j,i)
2582           uzt(j,i)=uz(j,i)
2583         enddo
2584       enddo
2585       do i=1,nres
2586 cd        write (iout,*) 'i=',i
2587         do k=1,3
2588           erij(k)=dc_norm(k,i)
2589         enddo
2590         do j=1,3
2591           do k=1,3
2592             dc_norm(k,i)=erij(k)
2593           enddo
2594           dc_norm(j,i)=dc_norm(j,i)+delta
2595 c          fac=dsqrt(scalar(dc_norm(1,i),dc_norm(1,i)))
2596 c          do k=1,3
2597 c            dc_norm(k,i)=dc_norm(k,i)/fac
2598 c          enddo
2599 c          write (iout,*) (dc_norm(k,i),k=1,3)
2600 c          write (iout,*) (erij(k),k=1,3)
2601           call vec_and_deriv
2602           do k=1,3
2603             uygradn(k,j,1)=(uy(k,i)-uyt(k,i))/delta
2604             uygradn(k,j,2)=(uy(k,i-1)-uyt(k,i-1))/delta
2605             uzgradn(k,j,1)=(uz(k,i)-uzt(k,i))/delta
2606             uzgradn(k,j,2)=(uz(k,i-1)-uzt(k,i-1))/delta
2607           enddo
2608 c          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2609 c     &      j,(uzgradt(k,j,1,i),k=1,3),(uzgradn(k,j,1),k=1,3),
2610 c     &      (uzgradt(k,j,2,i-1),k=1,3),(uzgradn(k,j,2),k=1,3)
2611         enddo
2612         do k=1,3
2613           dc_norm(k,i)=erij(k)
2614         enddo
2615 cd        do k=1,3
2616 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2617 cd     &      k,(uygradt(k,l,1,i),l=1,3),(uygradn(k,l,1),l=1,3),
2618 cd     &      (uygradt(k,l,2,i-1),l=1,3),(uygradn(k,l,2),l=1,3)
2619 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2620 cd     &      k,(uzgradt(k,l,1,i),l=1,3),(uzgradn(k,l,1),l=1,3),
2621 cd     &      (uzgradt(k,l,2,i-1),l=1,3),(uzgradn(k,l,2),l=1,3)
2622 cd          write (iout,'(a)')
2623 cd        enddo
2624       enddo
2625       return
2626       end
2627 C--------------------------------------------------------------------------
2628       subroutine set_matrices
2629       implicit real*8 (a-h,o-z)
2630       include 'DIMENSIONS'
2631 #ifdef MPI
2632       include "mpif.h"
2633       include "COMMON.SETUP"
2634       integer IERR
2635       integer status(MPI_STATUS_SIZE)
2636 #endif
2637       include 'COMMON.IOUNITS'
2638       include 'COMMON.GEO'
2639       include 'COMMON.VAR'
2640       include 'COMMON.LOCAL'
2641       include 'COMMON.CHAIN'
2642       include 'COMMON.DERIV'
2643       include 'COMMON.INTERACT'
2644       include 'COMMON.CONTACTS'
2645       include 'COMMON.TORSION'
2646       include 'COMMON.VECTORS'
2647       include 'COMMON.FFIELD'
2648       double precision auxvec(2),auxmat(2,2)
2649 C
2650 C Compute the virtual-bond-torsional-angle dependent quantities needed
2651 C to calculate the el-loc multibody terms of various order.
2652 C
2653 c      write(iout,*) 'nphi=',nphi,nres
2654 #ifdef PARMAT
2655       do i=ivec_start+2,ivec_end+2
2656 #else
2657       do i=3,nres+1
2658 #endif
2659 #ifdef NEWCORR
2660         if (i.gt. nnt+2 .and. i.lt.nct+2) then
2661           iti = itortyp(itype(i-2))
2662         else
2663           iti=ntortyp+1
2664         endif
2665 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2666         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2667           iti1 = itortyp(itype(i-1))
2668         else
2669           iti1=ntortyp+1
2670         endif
2671 c        write(iout,*),i
2672         b1(1,i-2)=bnew1(1,1,iti)*dsin(theta(i-1)/2.0)
2673      &           +bnew1(2,1,iti)*dsin(theta(i-1))
2674      &           +bnew1(3,1,iti)*dcos(theta(i-1)/2.0)
2675         gtb1(1,i-2)=bnew1(1,1,iti)*dcos(theta(i-1)/2.0d0)/2.0d0
2676      &             +bnew1(2,1,iti)*dcos(theta(i-1))
2677      &             -bnew1(3,1,iti)*dsin(theta(i-1)/2.0d0)/2.0d0
2678 c     &           +bnew1(3,1,iti)*sin(alpha(i))*cos(beta(i))
2679 c     &*(cos(theta(i)/2.0)
2680         b2(1,i-2)=bnew2(1,1,iti)*dsin(theta(i-1)/2.0)
2681      &           +bnew2(2,1,iti)*dsin(theta(i-1))
2682      &           +bnew2(3,1,iti)*dcos(theta(i-1)/2.0)
2683 c     &           +bnew2(3,1,iti)*sin(alpha(i))*cos(beta(i))
2684 c     &*(cos(theta(i)/2.0)
2685         gtb2(1,i-2)=bnew2(1,1,iti)*dcos(theta(i-1)/2.0d0)/2.0d0
2686      &             +bnew2(2,1,iti)*dcos(theta(i-1))
2687      &             -bnew2(3,1,iti)*dsin(theta(i-1)/2.0d0)/2.0d0
2688 c        if (ggb1(1,i).eq.0.0d0) then
2689 c        write(iout,*) 'i=',i,ggb1(1,i),
2690 c     &bnew1(1,1,iti)*cos(theta(i)/2.0)/2.0,
2691 c     &bnew1(2,1,iti)*cos(theta(i)),
2692 c     &bnew1(3,1,iti)*sin(theta(i)/2.0)/2.0
2693 c        endif
2694         b1(2,i-2)=bnew1(1,2,iti)
2695         gtb1(2,i-2)=0.0
2696         b2(2,i-2)=bnew2(1,2,iti)
2697         gtb2(2,i-2)=0.0
2698         EE(1,1,i-2)=eenew(1,iti)*dcos(theta(i-1))
2699         EE(1,2,i-2)=eeold(1,2,iti)
2700         EE(2,1,i-2)=eeold(2,1,iti)
2701         EE(2,2,i-2)=eeold(2,2,iti)
2702         gtEE(1,1,i-2)=-eenew(1,iti)*dsin(theta(i-1))
2703         gtEE(1,2,i-2)=0.0d0
2704         gtEE(2,2,i-2)=0.0d0
2705         gtEE(2,1,i-2)=0.0d0
2706 c        EE(2,2,iti)=0.0d0
2707 c        EE(1,2,iti)=0.5d0*eenew(1,iti)
2708 c        EE(2,1,iti)=0.5d0*eenew(1,iti)
2709 c        b1(2,iti)=bnew1(1,2,iti)*sin(alpha(i))*sin(beta(i))
2710 c        b2(2,iti)=bnew2(1,2,iti)*sin(alpha(i))*sin(beta(i))
2711        b1tilde(1,i-2)=b1(1,i-2)
2712        b1tilde(2,i-2)=-b1(2,i-2)
2713        b2tilde(1,i-2)=b2(1,i-2)
2714        b2tilde(2,i-2)=-b2(2,i-2)
2715 c       write (iout,*) 'i=',i-2,gtb1(2,i-2),gtb1(1,i-2)
2716 c       write(iout,*)  'b1=',b1(1,i-2)
2717 c       write (iout,*) 'theta=', theta(i-1)
2718        enddo
2719 #else
2720         b1(1,i-2)=b(3,iti)
2721         b1(2,i-2)=b(5,iti)
2722         b2(1,i-2)=b(2,iti)
2723         b2(2,i-2)=b(4,iti)
2724        b1tilde(1,i-2)=b1(1,i-2)
2725        b1tilde(2,i-2)=-b1(2,i-2)
2726        b2tilde(1,i-2)=b2(1,i-2)
2727        b2tilde(2,i-2)=-b2(2,i-2)
2728         EE(1,2,i-2)=eeold(1,2,iti)
2729         EE(2,1,i-2)=eeold(2,1,iti)
2730         EE(2,2,i-2)=eeold(2,2,iti)
2731         EE(1,1,i-2)=eeold(1,1,iti)
2732       enddo
2733 #endif
2734 #ifdef PARMAT
2735       do i=ivec_start+2,ivec_end+2
2736 #else
2737       do i=3,nres+1
2738 #endif
2739         if (i .lt. nres+1) then
2740           sin1=dsin(phi(i))
2741           cos1=dcos(phi(i))
2742           sintab(i-2)=sin1
2743           costab(i-2)=cos1
2744           obrot(1,i-2)=cos1
2745           obrot(2,i-2)=sin1
2746           sin2=dsin(2*phi(i))
2747           cos2=dcos(2*phi(i))
2748           sintab2(i-2)=sin2
2749           costab2(i-2)=cos2
2750           obrot2(1,i-2)=cos2
2751           obrot2(2,i-2)=sin2
2752           Ug(1,1,i-2)=-cos1
2753           Ug(1,2,i-2)=-sin1
2754           Ug(2,1,i-2)=-sin1
2755           Ug(2,2,i-2)= cos1
2756           Ug2(1,1,i-2)=-cos2
2757           Ug2(1,2,i-2)=-sin2
2758           Ug2(2,1,i-2)=-sin2
2759           Ug2(2,2,i-2)= cos2
2760         else
2761           costab(i-2)=1.0d0
2762           sintab(i-2)=0.0d0
2763           obrot(1,i-2)=1.0d0
2764           obrot(2,i-2)=0.0d0
2765           obrot2(1,i-2)=0.0d0
2766           obrot2(2,i-2)=0.0d0
2767           Ug(1,1,i-2)=1.0d0
2768           Ug(1,2,i-2)=0.0d0
2769           Ug(2,1,i-2)=0.0d0
2770           Ug(2,2,i-2)=1.0d0
2771           Ug2(1,1,i-2)=0.0d0
2772           Ug2(1,2,i-2)=0.0d0
2773           Ug2(2,1,i-2)=0.0d0
2774           Ug2(2,2,i-2)=0.0d0
2775         endif
2776         if (i .gt. 3 .and. i .lt. nres+1) then
2777           obrot_der(1,i-2)=-sin1
2778           obrot_der(2,i-2)= cos1
2779           Ugder(1,1,i-2)= sin1
2780           Ugder(1,2,i-2)=-cos1
2781           Ugder(2,1,i-2)=-cos1
2782           Ugder(2,2,i-2)=-sin1
2783           dwacos2=cos2+cos2
2784           dwasin2=sin2+sin2
2785           obrot2_der(1,i-2)=-dwasin2
2786           obrot2_der(2,i-2)= dwacos2
2787           Ug2der(1,1,i-2)= dwasin2
2788           Ug2der(1,2,i-2)=-dwacos2
2789           Ug2der(2,1,i-2)=-dwacos2
2790           Ug2der(2,2,i-2)=-dwasin2
2791         else
2792           obrot_der(1,i-2)=0.0d0
2793           obrot_der(2,i-2)=0.0d0
2794           Ugder(1,1,i-2)=0.0d0
2795           Ugder(1,2,i-2)=0.0d0
2796           Ugder(2,1,i-2)=0.0d0
2797           Ugder(2,2,i-2)=0.0d0
2798           obrot2_der(1,i-2)=0.0d0
2799           obrot2_der(2,i-2)=0.0d0
2800           Ug2der(1,1,i-2)=0.0d0
2801           Ug2der(1,2,i-2)=0.0d0
2802           Ug2der(2,1,i-2)=0.0d0
2803           Ug2der(2,2,i-2)=0.0d0
2804         endif
2805 c        if (i.gt. iatel_s+2 .and. i.lt.iatel_e+5) then
2806         if (i.gt. nnt+2 .and. i.lt.nct+2) then
2807           iti = itortyp(itype(i-2))
2808         else
2809           iti=ntortyp
2810         endif
2811 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2812         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2813           iti1 = itortyp(itype(i-1))
2814         else
2815           iti1=ntortyp
2816         endif
2817 cd        write (iout,*) '*******i',i,' iti1',iti
2818 cd        write (iout,*) 'b1',b1(:,iti)
2819 cd        write (iout,*) 'b2',b2(:,iti)
2820 cd        write (iout,*) 'Ug',Ug(:,:,i-2)
2821 c        if (i .gt. iatel_s+2) then
2822         if (i .gt. nnt+2) then
2823           call matvec2(Ug(1,1,i-2),b2(1,i-2),Ub2(1,i-2))
2824 #ifdef NEWCORR
2825           call matvec2(Ug(1,1,i-2),gtb2(1,i-2),gUb2(1,i-2))
2826 c          write (iout,*) Ug(1,1,i-2),gtb2(1,i-2),gUb2(1,i-2),"chuj"
2827 #endif
2828 c          write(iout,*) "co jest kurwa", iti, EE(1,1,iti),EE(2,1,iti),
2829 c     &    EE(1,2,iti),EE(2,2,iti)
2830           call matmat2(EE(1,1,i-2),Ug(1,1,i-2),EUg(1,1,i-2))
2831           call matmat2(gtEE(1,1,i-2),Ug(1,1,i-2),gtEUg(1,1,i-2))
2832 c          write(iout,*) "Macierz EUG",
2833 c     &    eug(1,1,i-2),eug(1,2,i-2),eug(2,1,i-2),
2834 c     &    eug(2,2,i-2)
2835           if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2836      &    then
2837           call matmat2(CC(1,1,iti),Ug(1,1,i-2),CUg(1,1,i-2))
2838           call matmat2(DD(1,1,iti),Ug(1,1,i-2),DUg(1,1,i-2))
2839           call matmat2(Dtilde(1,1,iti),Ug2(1,1,i-2),DtUg2(1,1,i-2))
2840           call matvec2(Ctilde(1,1,iti1),obrot(1,i-2),Ctobr(1,i-2))
2841           call matvec2(Dtilde(1,1,iti),obrot2(1,i-2),Dtobr2(1,i-2))
2842           endif
2843         else
2844           do k=1,2
2845             Ub2(k,i-2)=0.0d0
2846             Ctobr(k,i-2)=0.0d0
2847             Dtobr2(k,i-2)=0.0d0
2848             do l=1,2
2849               EUg(l,k,i-2)=0.0d0
2850               CUg(l,k,i-2)=0.0d0
2851               DUg(l,k,i-2)=0.0d0
2852               DtUg2(l,k,i-2)=0.0d0
2853             enddo
2854           enddo
2855         endif
2856         call matvec2(Ugder(1,1,i-2),b2(1,i-2),Ub2der(1,i-2))
2857         call matmat2(EE(1,1,i-2),Ugder(1,1,i-2),EUgder(1,1,i-2))
2858         do k=1,2
2859           muder(k,i-2)=Ub2der(k,i-2)
2860         enddo
2861 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2862         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2863           if (itype(i-1).le.ntyp) then
2864             iti1 = itortyp(itype(i-1))
2865           else
2866             iti1=ntortyp
2867           endif
2868         else
2869           iti1=ntortyp
2870         endif
2871         do k=1,2
2872           mu(k,i-2)=Ub2(k,i-2)+b1(k,i-1)
2873         enddo
2874 c        write (iout,*) 'mu ',mu(:,i-2),i-2
2875 cd        write (iout,*) 'mu1',mu1(:,i-2)
2876 cd        write (iout,*) 'mu2',mu2(:,i-2)
2877         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
2878      &  then
2879         call matmat2(CC(1,1,iti1),Ugder(1,1,i-2),CUgder(1,1,i-2))
2880         call matmat2(DD(1,1,iti),Ugder(1,1,i-2),DUgder(1,1,i-2))
2881         call matmat2(Dtilde(1,1,iti),Ug2der(1,1,i-2),DtUg2der(1,1,i-2))
2882         call matvec2(Ctilde(1,1,iti1),obrot_der(1,i-2),Ctobrder(1,i-2))
2883         call matvec2(Dtilde(1,1,iti),obrot2_der(1,i-2),Dtobr2der(1,i-2))
2884 C Vectors and matrices dependent on a single virtual-bond dihedral.
2885         call matvec2(DD(1,1,iti),b1tilde(1,i-1),auxvec(1))
2886         call matvec2(Ug2(1,1,i-2),auxvec(1),Ug2Db1t(1,i-2))
2887         call matvec2(Ug2der(1,1,i-2),auxvec(1),Ug2Db1tder(1,i-2))
2888         call matvec2(CC(1,1,iti1),Ub2(1,i-2),CUgb2(1,i-2))
2889         call matvec2(CC(1,1,iti1),Ub2der(1,i-2),CUgb2der(1,i-2))
2890         call matmat2(EUg(1,1,i-2),CC(1,1,iti1),EUgC(1,1,i-2))
2891         call matmat2(EUgder(1,1,i-2),CC(1,1,iti1),EUgCder(1,1,i-2))
2892         call matmat2(EUg(1,1,i-2),DD(1,1,iti1),EUgD(1,1,i-2))
2893         call matmat2(EUgder(1,1,i-2),DD(1,1,iti1),EUgDder(1,1,i-2))
2894         endif
2895       enddo
2896 C Matrices dependent on two consecutive virtual-bond dihedrals.
2897 C The order of matrices is from left to right.
2898       if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
2899      &then
2900 c      do i=max0(ivec_start,2),ivec_end
2901       do i=2,nres-1
2902         call matmat2(DtUg2(1,1,i-1),EUg(1,1,i),DtUg2EUg(1,1,i))
2903         call matmat2(DtUg2der(1,1,i-1),EUg(1,1,i),DtUg2EUgder(1,1,1,i))
2904         call matmat2(DtUg2(1,1,i-1),EUgder(1,1,i),DtUg2EUgder(1,1,2,i))
2905         call transpose2(DtUg2(1,1,i-1),auxmat(1,1))
2906         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUg(1,1,i))
2907         call matmat2(auxmat(1,1),EUgder(1,1,i),Ug2DtEUgder(1,1,2,i))
2908         call transpose2(DtUg2der(1,1,i-1),auxmat(1,1))
2909         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUgder(1,1,1,i))
2910       enddo
2911       endif
2912 #if defined(MPI) && defined(PARMAT)
2913 #ifdef DEBUG
2914 c      if (fg_rank.eq.0) then
2915         write (iout,*) "Arrays UG and UGDER before GATHER"
2916         do i=1,nres-1
2917           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2918      &     ((ug(l,k,i),l=1,2),k=1,2),
2919      &     ((ugder(l,k,i),l=1,2),k=1,2)
2920         enddo
2921         write (iout,*) "Arrays UG2 and UG2DER"
2922         do i=1,nres-1
2923           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2924      &     ((ug2(l,k,i),l=1,2),k=1,2),
2925      &     ((ug2der(l,k,i),l=1,2),k=1,2)
2926         enddo
2927         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
2928         do i=1,nres-1
2929           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2930      &     (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
2931      &     (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
2932         enddo
2933         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
2934         do i=1,nres-1
2935           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2936      &     costab(i),sintab(i),costab2(i),sintab2(i)
2937         enddo
2938         write (iout,*) "Array MUDER"
2939         do i=1,nres-1
2940           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
2941         enddo
2942 c      endif
2943 #endif
2944       if (nfgtasks.gt.1) then
2945         time00=MPI_Wtime()
2946 c        write(iout,*)"Processor",fg_rank,kolor," ivec_start",ivec_start,
2947 c     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks-1),
2948 c     &   " ivec_count",(ivec_count(i),i=0,nfgtasks-1)
2949 #ifdef MATGATHER
2950         call MPI_Allgatherv(Ub2(1,ivec_start),ivec_count(fg_rank1),
2951      &   MPI_MU,Ub2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2952      &   FG_COMM1,IERR)
2953         call MPI_Allgatherv(Ub2der(1,ivec_start),ivec_count(fg_rank1),
2954      &   MPI_MU,Ub2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2955      &   FG_COMM1,IERR)
2956         call MPI_Allgatherv(mu(1,ivec_start),ivec_count(fg_rank1),
2957      &   MPI_MU,mu(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2958      &   FG_COMM1,IERR)
2959         call MPI_Allgatherv(muder(1,ivec_start),ivec_count(fg_rank1),
2960      &   MPI_MU,muder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2961      &   FG_COMM1,IERR)
2962         call MPI_Allgatherv(Eug(1,1,ivec_start),ivec_count(fg_rank1),
2963      &   MPI_MAT1,Eug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2964      &   FG_COMM1,IERR)
2965         call MPI_Allgatherv(Eugder(1,1,ivec_start),ivec_count(fg_rank1),
2966      &   MPI_MAT1,Eugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2967      &   FG_COMM1,IERR)
2968         call MPI_Allgatherv(costab(ivec_start),ivec_count(fg_rank1),
2969      &   MPI_DOUBLE_PRECISION,costab(1),ivec_count(0),ivec_displ(0),
2970      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2971         call MPI_Allgatherv(sintab(ivec_start),ivec_count(fg_rank1),
2972      &   MPI_DOUBLE_PRECISION,sintab(1),ivec_count(0),ivec_displ(0),
2973      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2974         call MPI_Allgatherv(costab2(ivec_start),ivec_count(fg_rank1),
2975      &   MPI_DOUBLE_PRECISION,costab2(1),ivec_count(0),ivec_displ(0),
2976      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2977         call MPI_Allgatherv(sintab2(ivec_start),ivec_count(fg_rank1),
2978      &   MPI_DOUBLE_PRECISION,sintab2(1),ivec_count(0),ivec_displ(0),
2979      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2980         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2981      &  then
2982         call MPI_Allgatherv(Ctobr(1,ivec_start),ivec_count(fg_rank1),
2983      &   MPI_MU,Ctobr(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2984      &   FG_COMM1,IERR)
2985         call MPI_Allgatherv(Ctobrder(1,ivec_start),ivec_count(fg_rank1),
2986      &   MPI_MU,Ctobrder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2987      &   FG_COMM1,IERR)
2988         call MPI_Allgatherv(Dtobr2(1,ivec_start),ivec_count(fg_rank1),
2989      &   MPI_MU,Dtobr2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2990      &   FG_COMM1,IERR)
2991        call MPI_Allgatherv(Dtobr2der(1,ivec_start),ivec_count(fg_rank1),
2992      &   MPI_MU,Dtobr2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2993      &   FG_COMM1,IERR)
2994         call MPI_Allgatherv(Ug2Db1t(1,ivec_start),ivec_count(fg_rank1),
2995      &   MPI_MU,Ug2Db1t(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2996      &   FG_COMM1,IERR)
2997         call MPI_Allgatherv(Ug2Db1tder(1,ivec_start),
2998      &   ivec_count(fg_rank1),
2999      &   MPI_MU,Ug2Db1tder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3000      &   FG_COMM1,IERR)
3001         call MPI_Allgatherv(CUgb2(1,ivec_start),ivec_count(fg_rank1),
3002      &   MPI_MU,CUgb2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3003      &   FG_COMM1,IERR)
3004         call MPI_Allgatherv(CUgb2der(1,ivec_start),ivec_count(fg_rank1),
3005      &   MPI_MU,CUgb2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3006      &   FG_COMM1,IERR)
3007         call MPI_Allgatherv(Cug(1,1,ivec_start),ivec_count(fg_rank1),
3008      &   MPI_MAT1,Cug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3009      &   FG_COMM1,IERR)
3010         call MPI_Allgatherv(Cugder(1,1,ivec_start),ivec_count(fg_rank1),
3011      &   MPI_MAT1,Cugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3012      &   FG_COMM1,IERR)
3013         call MPI_Allgatherv(Dug(1,1,ivec_start),ivec_count(fg_rank1),
3014      &   MPI_MAT1,Dug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3015      &   FG_COMM1,IERR)
3016         call MPI_Allgatherv(Dugder(1,1,ivec_start),ivec_count(fg_rank1),
3017      &   MPI_MAT1,Dugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3018      &   FG_COMM1,IERR)
3019         call MPI_Allgatherv(Dtug2(1,1,ivec_start),ivec_count(fg_rank1),
3020      &   MPI_MAT1,Dtug2(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3021      &   FG_COMM1,IERR)
3022         call MPI_Allgatherv(Dtug2der(1,1,ivec_start),
3023      &   ivec_count(fg_rank1),
3024      &   MPI_MAT1,Dtug2der(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3025      &   FG_COMM1,IERR)
3026         call MPI_Allgatherv(EugC(1,1,ivec_start),ivec_count(fg_rank1),
3027      &   MPI_MAT1,EugC(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3028      &   FG_COMM1,IERR)
3029        call MPI_Allgatherv(EugCder(1,1,ivec_start),ivec_count(fg_rank1),
3030      &   MPI_MAT1,EugCder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3031      &   FG_COMM1,IERR)
3032         call MPI_Allgatherv(EugD(1,1,ivec_start),ivec_count(fg_rank1),
3033      &   MPI_MAT1,EugD(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3034      &   FG_COMM1,IERR)
3035        call MPI_Allgatherv(EugDder(1,1,ivec_start),ivec_count(fg_rank1),
3036      &   MPI_MAT1,EugDder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3037      &   FG_COMM1,IERR)
3038         call MPI_Allgatherv(DtUg2EUg(1,1,ivec_start),
3039      &   ivec_count(fg_rank1),
3040      &   MPI_MAT1,DtUg2EUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3041      &   FG_COMM1,IERR)
3042         call MPI_Allgatherv(Ug2DtEUg(1,1,ivec_start),
3043      &   ivec_count(fg_rank1),
3044      &   MPI_MAT1,Ug2DtEUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3045      &   FG_COMM1,IERR)
3046         call MPI_Allgatherv(DtUg2EUgder(1,1,1,ivec_start),
3047      &   ivec_count(fg_rank1),
3048      &   MPI_MAT2,DtUg2EUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
3049      &   MPI_MAT2,FG_COMM1,IERR)
3050         call MPI_Allgatherv(Ug2DtEUgder(1,1,1,ivec_start),
3051      &   ivec_count(fg_rank1),
3052      &   MPI_MAT2,Ug2DtEUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
3053      &   MPI_MAT2,FG_COMM1,IERR)
3054         endif
3055 #else
3056 c Passes matrix info through the ring
3057       isend=fg_rank1
3058       irecv=fg_rank1-1
3059       if (irecv.lt.0) irecv=nfgtasks1-1
3060       iprev=irecv
3061       inext=fg_rank1+1
3062       if (inext.ge.nfgtasks1) inext=0
3063       do i=1,nfgtasks1-1
3064 c        write (iout,*) "isend",isend," irecv",irecv
3065 c        call flush(iout)
3066         lensend=lentyp(isend)
3067         lenrecv=lentyp(irecv)
3068 c        write (iout,*) "lensend",lensend," lenrecv",lenrecv
3069 c        call MPI_SENDRECV(ug(1,1,ivec_displ(isend)+1),1,
3070 c     &   MPI_ROTAT1(lensend),inext,2200+isend,
3071 c     &   ug(1,1,ivec_displ(irecv)+1),1,MPI_ROTAT1(lenrecv),
3072 c     &   iprev,2200+irecv,FG_COMM,status,IERR)
3073 c        write (iout,*) "Gather ROTAT1"
3074 c        call flush(iout)
3075 c        call MPI_SENDRECV(obrot(1,ivec_displ(isend)+1),1,
3076 c     &   MPI_ROTAT2(lensend),inext,3300+isend,
3077 c     &   obrot(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
3078 c     &   iprev,3300+irecv,FG_COMM,status,IERR)
3079 c        write (iout,*) "Gather ROTAT2"
3080 c        call flush(iout)
3081         call MPI_SENDRECV(costab(ivec_displ(isend)+1),1,
3082      &   MPI_ROTAT_OLD(lensend),inext,4400+isend,
3083      &   costab(ivec_displ(irecv)+1),1,MPI_ROTAT_OLD(lenrecv),
3084      &   iprev,4400+irecv,FG_COMM,status,IERR)
3085 c        write (iout,*) "Gather ROTAT_OLD"
3086 c        call flush(iout)
3087         call MPI_SENDRECV(mu(1,ivec_displ(isend)+1),1,
3088      &   MPI_PRECOMP11(lensend),inext,5500+isend,
3089      &   mu(1,ivec_displ(irecv)+1),1,MPI_PRECOMP11(lenrecv),
3090      &   iprev,5500+irecv,FG_COMM,status,IERR)
3091 c        write (iout,*) "Gather PRECOMP11"
3092 c        call flush(iout)
3093         call MPI_SENDRECV(Eug(1,1,ivec_displ(isend)+1),1,
3094      &   MPI_PRECOMP12(lensend),inext,6600+isend,
3095      &   Eug(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP12(lenrecv),
3096      &   iprev,6600+irecv,FG_COMM,status,IERR)
3097 c        write (iout,*) "Gather PRECOMP12"
3098 c        call flush(iout)
3099         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
3100      &  then
3101         call MPI_SENDRECV(ug2db1t(1,ivec_displ(isend)+1),1,
3102      &   MPI_ROTAT2(lensend),inext,7700+isend,
3103      &   ug2db1t(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
3104      &   iprev,7700+irecv,FG_COMM,status,IERR)
3105 c        write (iout,*) "Gather PRECOMP21"
3106 c        call flush(iout)
3107         call MPI_SENDRECV(EUgC(1,1,ivec_displ(isend)+1),1,
3108      &   MPI_PRECOMP22(lensend),inext,8800+isend,
3109      &   EUgC(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP22(lenrecv),
3110      &   iprev,8800+irecv,FG_COMM,status,IERR)
3111 c        write (iout,*) "Gather PRECOMP22"
3112 c        call flush(iout)
3113         call MPI_SENDRECV(Ug2DtEUgder(1,1,1,ivec_displ(isend)+1),1,
3114      &   MPI_PRECOMP23(lensend),inext,9900+isend,
3115      &   Ug2DtEUgder(1,1,1,ivec_displ(irecv)+1),1,
3116      &   MPI_PRECOMP23(lenrecv),
3117      &   iprev,9900+irecv,FG_COMM,status,IERR)
3118 c        write (iout,*) "Gather PRECOMP23"
3119 c        call flush(iout)
3120         endif
3121         isend=irecv
3122         irecv=irecv-1
3123         if (irecv.lt.0) irecv=nfgtasks1-1
3124       enddo
3125 #endif
3126         time_gather=time_gather+MPI_Wtime()-time00
3127       endif
3128 #ifdef DEBUG
3129 c      if (fg_rank.eq.0) then
3130         write (iout,*) "Arrays UG and UGDER"
3131         do i=1,nres-1
3132           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3133      &     ((ug(l,k,i),l=1,2),k=1,2),
3134      &     ((ugder(l,k,i),l=1,2),k=1,2)
3135         enddo
3136         write (iout,*) "Arrays UG2 and UG2DER"
3137         do i=1,nres-1
3138           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3139      &     ((ug2(l,k,i),l=1,2),k=1,2),
3140      &     ((ug2der(l,k,i),l=1,2),k=1,2)
3141         enddo
3142         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
3143         do i=1,nres-1
3144           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3145      &     (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
3146      &     (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
3147         enddo
3148         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
3149         do i=1,nres-1
3150           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3151      &     costab(i),sintab(i),costab2(i),sintab2(i)
3152         enddo
3153         write (iout,*) "Array MUDER"
3154         do i=1,nres-1
3155           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
3156         enddo
3157 c      endif
3158 #endif
3159 #endif
3160 cd      do i=1,nres
3161 cd        iti = itortyp(itype(i))
3162 cd        write (iout,*) i
3163 cd        do j=1,2
3164 cd        write (iout,'(2f10.5,5x,2f10.5,5x,2f10.5)')
3165 cd     &  (EE(j,k,iti),k=1,2),(Ug(j,k,i),k=1,2),(EUg(j,k,i),k=1,2)
3166 cd        enddo
3167 cd      enddo
3168       return
3169       end
3170 C--------------------------------------------------------------------------
3171       subroutine eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
3172 C
3173 C This subroutine calculates the average interaction energy and its gradient
3174 C in the virtual-bond vectors between non-adjacent peptide groups, based on
3175 C the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
3176 C The potential depends both on the distance of peptide-group centers and on
3177 C the orientation of the CA-CA virtual bonds.
3178 C
3179       implicit real*8 (a-h,o-z)
3180 #ifdef MPI
3181       include 'mpif.h'
3182 #endif
3183       include 'DIMENSIONS'
3184       include 'COMMON.CONTROL'
3185       include 'COMMON.SETUP'
3186       include 'COMMON.IOUNITS'
3187       include 'COMMON.GEO'
3188       include 'COMMON.VAR'
3189       include 'COMMON.LOCAL'
3190       include 'COMMON.CHAIN'
3191       include 'COMMON.DERIV'
3192       include 'COMMON.INTERACT'
3193       include 'COMMON.CONTACTS'
3194       include 'COMMON.TORSION'
3195       include 'COMMON.VECTORS'
3196       include 'COMMON.FFIELD'
3197       include 'COMMON.TIME1'
3198       include 'COMMON.SPLITELE'
3199       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
3200      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
3201       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
3202      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4),gmuij(4)
3203       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3204      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3205      &    num_conti,j1,j2
3206 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
3207 #ifdef MOMENT
3208       double precision scal_el /1.0d0/
3209 #else
3210       double precision scal_el /0.5d0/
3211 #endif
3212 C 12/13/98
3213 C 13-go grudnia roku pamietnego...
3214       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
3215      &                   0.0d0,1.0d0,0.0d0,
3216      &                   0.0d0,0.0d0,1.0d0/
3217 cd      write(iout,*) 'In EELEC'
3218 cd      do i=1,nloctyp
3219 cd        write(iout,*) 'Type',i
3220 cd        write(iout,*) 'B1',B1(:,i)
3221 cd        write(iout,*) 'B2',B2(:,i)
3222 cd        write(iout,*) 'CC',CC(:,:,i)
3223 cd        write(iout,*) 'DD',DD(:,:,i)
3224 cd        write(iout,*) 'EE',EE(:,:,i)
3225 cd      enddo
3226 cd      call check_vecgrad
3227 cd      stop
3228       if (icheckgrad.eq.1) then
3229         do i=1,nres-1
3230           fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
3231           do k=1,3
3232             dc_norm(k,i)=dc(k,i)*fac
3233           enddo
3234 c          write (iout,*) 'i',i,' fac',fac
3235         enddo
3236       endif
3237       if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
3238      &    .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or.
3239      &    wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
3240 c        call vec_and_deriv
3241 #ifdef TIMING
3242         time01=MPI_Wtime()
3243 #endif
3244         call set_matrices
3245 #ifdef TIMING
3246         time_mat=time_mat+MPI_Wtime()-time01
3247 #endif
3248       endif
3249 cd      do i=1,nres-1
3250 cd        write (iout,*) 'i=',i
3251 cd        do k=1,3
3252 cd        write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
3253 cd        enddo
3254 cd        do k=1,3
3255 cd          write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
3256 cd     &     uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
3257 cd        enddo
3258 cd      enddo
3259       t_eelecij=0.0d0
3260       ees=0.0D0
3261       evdw1=0.0D0
3262       eel_loc=0.0d0
3263       eello_turn3=0.0d0
3264       eello_turn4=0.0d0
3265       ind=0
3266       do i=1,nres
3267         num_cont_hb(i)=0
3268       enddo
3269 cd      print '(a)','Enter EELEC'
3270 cd      write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
3271       do i=1,nres
3272         gel_loc_loc(i)=0.0d0
3273         gcorr_loc(i)=0.0d0
3274       enddo
3275 c
3276 c
3277 c 9/27/08 AL Split the interaction loop to ensure load balancing of turn terms
3278 C
3279 C Loop over i,i+2 and i,i+3 pairs of the peptide groups
3280 C
3281 C 14/01/2014 TURN3,TUNR4 does no go under periodic boundry condition
3282       do i=iturn3_start,iturn3_end
3283         if (i.le.1) cycle
3284 C        write(iout,*) "tu jest i",i
3285         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
3286      &  .or. itype(i+2).eq.ntyp1
3287      &  .or. itype(i+3).eq.ntyp1
3288      &  .or. itype(i-1).eq.ntyp1
3289      &  .or. itype(i+4).eq.ntyp1
3290      &  ) cycle
3291         dxi=dc(1,i)
3292         dyi=dc(2,i)
3293         dzi=dc(3,i)
3294         dx_normi=dc_norm(1,i)
3295         dy_normi=dc_norm(2,i)
3296         dz_normi=dc_norm(3,i)
3297         xmedi=c(1,i)+0.5d0*dxi
3298         ymedi=c(2,i)+0.5d0*dyi
3299         zmedi=c(3,i)+0.5d0*dzi
3300           xmedi=mod(xmedi,boxxsize)
3301           if (xmedi.lt.0) xmedi=xmedi+boxxsize
3302           ymedi=mod(ymedi,boxysize)
3303           if (ymedi.lt.0) ymedi=ymedi+boxysize
3304           zmedi=mod(zmedi,boxzsize)
3305           if (zmedi.lt.0) zmedi=zmedi+boxzsize
3306         num_conti=0
3307         call eelecij(i,i+2,ees,evdw1,eel_loc)
3308         if (wturn3.gt.0.0d0) call eturn3(i,eello_turn3)
3309         num_cont_hb(i)=num_conti
3310       enddo
3311       do i=iturn4_start,iturn4_end
3312         if (i.le.1) cycle
3313         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
3314      &    .or. itype(i+3).eq.ntyp1
3315      &    .or. itype(i+4).eq.ntyp1
3316      &    .or. itype(i+5).eq.ntyp1
3317      &    .or. itype(i).eq.ntyp1
3318      &    .or. itype(i-1).eq.ntyp1
3319      &                             ) cycle
3320         dxi=dc(1,i)
3321         dyi=dc(2,i)
3322         dzi=dc(3,i)
3323         dx_normi=dc_norm(1,i)
3324         dy_normi=dc_norm(2,i)
3325         dz_normi=dc_norm(3,i)
3326         xmedi=c(1,i)+0.5d0*dxi
3327         ymedi=c(2,i)+0.5d0*dyi
3328         zmedi=c(3,i)+0.5d0*dzi
3329 C Return atom into box, boxxsize is size of box in x dimension
3330 c  194   continue
3331 c        if (xmedi.gt.((0.5d0)*boxxsize)) xmedi=xmedi-boxxsize
3332 c        if (xmedi.lt.((-0.5d0)*boxxsize)) xmedi=xmedi+boxxsize
3333 C Condition for being inside the proper box
3334 c        if ((xmedi.gt.((0.5d0)*boxxsize)).or.
3335 c     &       (xmedi.lt.((-0.5d0)*boxxsize))) then
3336 c        go to 194
3337 c        endif
3338 c  195   continue
3339 c        if (ymedi.gt.((0.5d0)*boxysize)) ymedi=ymedi-boxysize
3340 c        if (ymedi.lt.((-0.5d0)*boxysize)) ymedi=ymedi+boxysize
3341 C Condition for being inside the proper box
3342 c        if ((ymedi.gt.((0.5d0)*boxysize)).or.
3343 c     &       (ymedi.lt.((-0.5d0)*boxysize))) then
3344 c        go to 195
3345 c        endif
3346 c  196   continue
3347 c        if (zmedi.gt.((0.5d0)*boxzsize)) zmedi=zmedi-boxzsize
3348 c        if (zmedi.lt.((-0.5d0)*boxzsize)) zmedi=zmedi+boxzsize
3349 C Condition for being inside the proper box
3350 c        if ((zmedi.gt.((0.5d0)*boxzsize)).or.
3351 c     &       (zmedi.lt.((-0.5d0)*boxzsize))) then
3352 c        go to 196
3353 c        endif
3354           xmedi=mod(xmedi,boxxsize)
3355           if (xmedi.lt.0) xmedi=xmedi+boxxsize
3356           ymedi=mod(ymedi,boxysize)
3357           if (ymedi.lt.0) ymedi=ymedi+boxysize
3358           zmedi=mod(zmedi,boxzsize)
3359           if (zmedi.lt.0) zmedi=zmedi+boxzsize
3360
3361         num_conti=num_cont_hb(i)
3362 c        write(iout,*) "JESTEM W PETLI"
3363         call eelecij(i,i+3,ees,evdw1,eel_loc)
3364         if (wturn4.gt.0.0d0 .and. itype(i+2).ne.ntyp1)
3365      &   call eturn4(i,eello_turn4)
3366         num_cont_hb(i)=num_conti
3367       enddo   ! i
3368 C Loop over all neighbouring boxes
3369 C      do xshift=-1,1
3370 C      do yshift=-1,1
3371 C      do zshift=-1,1
3372 c
3373 c Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
3374 c
3375       do i=iatel_s,iatel_e
3376         if (i.le.1) cycle
3377         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
3378      &  .or. itype(i+2).eq.ntyp1
3379      &  .or. itype(i-1).eq.ntyp1
3380      &                ) cycle
3381         dxi=dc(1,i)
3382         dyi=dc(2,i)
3383         dzi=dc(3,i)
3384         dx_normi=dc_norm(1,i)
3385         dy_normi=dc_norm(2,i)
3386         dz_normi=dc_norm(3,i)
3387         xmedi=c(1,i)+0.5d0*dxi
3388         ymedi=c(2,i)+0.5d0*dyi
3389         zmedi=c(3,i)+0.5d0*dzi
3390           xmedi=mod(xmedi,boxxsize)
3391           if (xmedi.lt.0) xmedi=xmedi+boxxsize
3392           ymedi=mod(ymedi,boxysize)
3393           if (ymedi.lt.0) ymedi=ymedi+boxysize
3394           zmedi=mod(zmedi,boxzsize)
3395           if (zmedi.lt.0) zmedi=zmedi+boxzsize
3396 C          xmedi=xmedi+xshift*boxxsize
3397 C          ymedi=ymedi+yshift*boxysize
3398 C          zmedi=zmedi+zshift*boxzsize
3399
3400 C Return tom into box, boxxsize is size of box in x dimension
3401 c  164   continue
3402 c        if (xmedi.gt.((xshift+0.5d0)*boxxsize)) xmedi=xmedi-boxxsize
3403 c        if (xmedi.lt.((xshift-0.5d0)*boxxsize)) xmedi=xmedi+boxxsize
3404 C Condition for being inside the proper box
3405 c        if ((xmedi.gt.((xshift+0.5d0)*boxxsize)).or.
3406 c     &       (xmedi.lt.((xshift-0.5d0)*boxxsize))) then
3407 c        go to 164
3408 c        endif
3409 c  165   continue
3410 c        if (ymedi.gt.((yshift+0.5d0)*boxysize)) ymedi=ymedi-boxysize
3411 c        if (ymedi.lt.((yshift-0.5d0)*boxysize)) ymedi=ymedi+boxysize
3412 C Condition for being inside the proper box
3413 c        if ((ymedi.gt.((yshift+0.5d0)*boxysize)).or.
3414 c     &       (ymedi.lt.((yshift-0.5d0)*boxysize))) then
3415 c        go to 165
3416 c        endif
3417 c  166   continue
3418 c        if (zmedi.gt.((zshift+0.5d0)*boxzsize)) zmedi=zmedi-boxzsize
3419 c        if (zmedi.lt.((zshift-0.5d0)*boxzsize)) zmedi=zmedi+boxzsize
3420 cC Condition for being inside the proper box
3421 c        if ((zmedi.gt.((zshift+0.5d0)*boxzsize)).or.
3422 c     &       (zmedi.lt.((zshift-0.5d0)*boxzsize))) then
3423 c        go to 166
3424 c        endif
3425
3426 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
3427         num_conti=num_cont_hb(i)
3428         do j=ielstart(i),ielend(i)
3429 C          write (iout,*) i,j
3430          if (j.le.1) cycle
3431           if (itype(j).eq.ntyp1.or. itype(j+1).eq.ntyp1
3432      & .or.itype(j+2).eq.ntyp1
3433      & .or.itype(j-1).eq.ntyp1
3434      &) cycle
3435           call eelecij(i,j,ees,evdw1,eel_loc)
3436         enddo ! j
3437         num_cont_hb(i)=num_conti
3438       enddo   ! i
3439 C     enddo   ! zshift
3440 C      enddo   ! yshift
3441 C      enddo   ! xshift
3442
3443 c      write (iout,*) "Number of loop steps in EELEC:",ind
3444 cd      do i=1,nres
3445 cd        write (iout,'(i3,3f10.5,5x,3f10.5)')
3446 cd     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
3447 cd      enddo
3448 c 12/7/99 Adam eello_turn3 will be considered as a separate energy term
3449 ccc      eel_loc=eel_loc+eello_turn3
3450 cd      print *,"Processor",fg_rank," t_eelecij",t_eelecij
3451       return
3452       end
3453 C-------------------------------------------------------------------------------
3454       subroutine eelecij(i,j,ees,evdw1,eel_loc)
3455       implicit real*8 (a-h,o-z)
3456       include 'DIMENSIONS'
3457 #ifdef MPI
3458       include "mpif.h"
3459 #endif
3460       include 'COMMON.CONTROL'
3461       include 'COMMON.IOUNITS'
3462       include 'COMMON.GEO'
3463       include 'COMMON.VAR'
3464       include 'COMMON.LOCAL'
3465       include 'COMMON.CHAIN'
3466       include 'COMMON.DERIV'
3467       include 'COMMON.INTERACT'
3468       include 'COMMON.CONTACTS'
3469       include 'COMMON.TORSION'
3470       include 'COMMON.VECTORS'
3471       include 'COMMON.FFIELD'
3472       include 'COMMON.TIME1'
3473       include 'COMMON.SPLITELE'
3474       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
3475      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
3476       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
3477      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4),gmuij1(4),gmuji1(4),
3478      &    gmuij2(4),gmuji2(4)
3479       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3480      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3481      &    num_conti,j1,j2
3482 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
3483 #ifdef MOMENT
3484       double precision scal_el /1.0d0/
3485 #else
3486       double precision scal_el /0.5d0/
3487 #endif
3488 C 12/13/98
3489 C 13-go grudnia roku pamietnego...
3490       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
3491      &                   0.0d0,1.0d0,0.0d0,
3492      &                   0.0d0,0.0d0,1.0d0/
3493 c          time00=MPI_Wtime()
3494 cd      write (iout,*) "eelecij",i,j
3495 c          ind=ind+1
3496           iteli=itel(i)
3497           itelj=itel(j)
3498           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
3499           aaa=app(iteli,itelj)
3500           bbb=bpp(iteli,itelj)
3501           ael6i=ael6(iteli,itelj)
3502           ael3i=ael3(iteli,itelj)
3503           dxj=dc(1,j)
3504           dyj=dc(2,j)
3505           dzj=dc(3,j)
3506           dx_normj=dc_norm(1,j)
3507           dy_normj=dc_norm(2,j)
3508           dz_normj=dc_norm(3,j)
3509 C          xj=c(1,j)+0.5D0*dxj-xmedi
3510 C          yj=c(2,j)+0.5D0*dyj-ymedi
3511 C          zj=c(3,j)+0.5D0*dzj-zmedi
3512           xj=c(1,j)+0.5D0*dxj
3513           yj=c(2,j)+0.5D0*dyj
3514           zj=c(3,j)+0.5D0*dzj
3515           xj=mod(xj,boxxsize)
3516           if (xj.lt.0) xj=xj+boxxsize
3517           yj=mod(yj,boxysize)
3518           if (yj.lt.0) yj=yj+boxysize
3519           zj=mod(zj,boxzsize)
3520           if (zj.lt.0) zj=zj+boxzsize
3521           if ((zj.lt.0).or.(xj.lt.0).or.(yj.lt.0)) write (*,*) "CHUJ"
3522       dist_init=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
3523       xj_safe=xj
3524       yj_safe=yj
3525       zj_safe=zj
3526       isubchap=0
3527       do xshift=-1,1
3528       do yshift=-1,1
3529       do zshift=-1,1
3530           xj=xj_safe+xshift*boxxsize
3531           yj=yj_safe+yshift*boxysize
3532           zj=zj_safe+zshift*boxzsize
3533           dist_temp=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
3534           if(dist_temp.lt.dist_init) then
3535             dist_init=dist_temp
3536             xj_temp=xj
3537             yj_temp=yj
3538             zj_temp=zj
3539             isubchap=1
3540           endif
3541        enddo
3542        enddo
3543        enddo
3544        if (isubchap.eq.1) then
3545           xj=xj_temp-xmedi
3546           yj=yj_temp-ymedi
3547           zj=zj_temp-zmedi
3548        else
3549           xj=xj_safe-xmedi
3550           yj=yj_safe-ymedi
3551           zj=zj_safe-zmedi
3552        endif
3553 C        if ((i+3).lt.j) then !this condition keeps for turn3 and turn4 not subject to PBC
3554 c  174   continue
3555 c        if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
3556 c        if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
3557 C Condition for being inside the proper box
3558 c        if ((xj.gt.((0.5d0)*boxxsize)).or.
3559 c     &       (xj.lt.((-0.5d0)*boxxsize))) then
3560 c        go to 174
3561 c        endif
3562 c  175   continue
3563 c        if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
3564 c        if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
3565 C Condition for being inside the proper box
3566 c        if ((yj.gt.((0.5d0)*boxysize)).or.
3567 c     &       (yj.lt.((-0.5d0)*boxysize))) then
3568 c        go to 175
3569 c        endif
3570 c  176   continue
3571 c        if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
3572 c        if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
3573 C Condition for being inside the proper box
3574 c        if ((zj.gt.((0.5d0)*boxzsize)).or.
3575 c     &       (zj.lt.((-0.5d0)*boxzsize))) then
3576 c        go to 176
3577 c        endif
3578 C        endif !endPBC condintion
3579 C        xj=xj-xmedi
3580 C        yj=yj-ymedi
3581 C        zj=zj-zmedi
3582           rij=xj*xj+yj*yj+zj*zj
3583
3584             sss=sscale(sqrt(rij))
3585             sssgrad=sscagrad(sqrt(rij))
3586 c            if (sss.gt.0.0d0) then
3587           rrmij=1.0D0/rij
3588           rij=dsqrt(rij)
3589           rmij=1.0D0/rij
3590           r3ij=rrmij*rmij
3591           r6ij=r3ij*r3ij
3592           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
3593           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
3594           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
3595           fac=cosa-3.0D0*cosb*cosg
3596           ev1=aaa*r6ij*r6ij
3597 c 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
3598           if (j.eq.i+2) ev1=scal_el*ev1
3599           ev2=bbb*r6ij
3600           fac3=ael6i*r6ij
3601           fac4=ael3i*r3ij
3602           evdwij=(ev1+ev2)
3603           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
3604           el2=fac4*fac
3605 C MARYSIA
3606           eesij=(el1+el2)
3607 C 12/26/95 - for the evaluation of multi-body H-bonding interactions
3608           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
3609           ees=ees+eesij
3610           evdw1=evdw1+evdwij*sss
3611 cd          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
3612 cd     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
3613 cd     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
3614 cd     &      xmedi,ymedi,zmedi,xj,yj,zj
3615
3616           if (energy_dec) then
3617               write (iout,'(a6,2i5,0pf7.3,2i5,2e11.3)')
3618      &'evdw1',i,j,evdwij
3619      &,iteli,itelj,aaa,evdw1
3620               write (iout,'(a6,2i5,0pf7.3)') 'ees',i,j,eesij
3621           endif
3622
3623 C
3624 C Calculate contributions to the Cartesian gradient.
3625 C
3626 #ifdef SPLITELE
3627           facvdw=-6*rrmij*(ev1+evdwij)*sss
3628           facel=-3*rrmij*(el1+eesij)
3629           fac1=fac
3630           erij(1)=xj*rmij
3631           erij(2)=yj*rmij
3632           erij(3)=zj*rmij
3633 *
3634 * Radial derivatives. First process both termini of the fragment (i,j)
3635 *
3636           ggg(1)=facel*xj
3637           ggg(2)=facel*yj
3638           ggg(3)=facel*zj
3639 c          do k=1,3
3640 c            ghalf=0.5D0*ggg(k)
3641 c            gelc(k,i)=gelc(k,i)+ghalf
3642 c            gelc(k,j)=gelc(k,j)+ghalf
3643 c          enddo
3644 c 9/28/08 AL Gradient compotents will be summed only at the end
3645           do k=1,3
3646             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
3647             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
3648           enddo
3649 *
3650 * Loop over residues i+1 thru j-1.
3651 *
3652 cgrad          do k=i+1,j-1
3653 cgrad            do l=1,3
3654 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3655 cgrad            enddo
3656 cgrad          enddo
3657           if (sss.gt.0.0) then
3658           ggg(1)=facvdw*xj+sssgrad*rmij*evdwij*xj
3659           ggg(2)=facvdw*yj+sssgrad*rmij*evdwij*yj
3660           ggg(3)=facvdw*zj+sssgrad*rmij*evdwij*zj
3661           else
3662           ggg(1)=0.0
3663           ggg(2)=0.0
3664           ggg(3)=0.0
3665           endif
3666 c          do k=1,3
3667 c            ghalf=0.5D0*ggg(k)
3668 c            gvdwpp(k,i)=gvdwpp(k,i)+ghalf
3669 c            gvdwpp(k,j)=gvdwpp(k,j)+ghalf
3670 c          enddo
3671 c 9/28/08 AL Gradient compotents will be summed only at the end
3672           do k=1,3
3673             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
3674             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
3675           enddo
3676 *
3677 * Loop over residues i+1 thru j-1.
3678 *
3679 cgrad          do k=i+1,j-1
3680 cgrad            do l=1,3
3681 cgrad              gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
3682 cgrad            enddo
3683 cgrad          enddo
3684 #else
3685 C MARYSIA
3686           facvdw=(ev1+evdwij)*sss
3687           facel=(el1+eesij)
3688           fac1=fac
3689           fac=-3*rrmij*(facvdw+facvdw+facel)
3690           erij(1)=xj*rmij
3691           erij(2)=yj*rmij
3692           erij(3)=zj*rmij
3693 *
3694 * Radial derivatives. First process both termini of the fragment (i,j)
3695 *
3696           ggg(1)=fac*xj
3697           ggg(2)=fac*yj
3698           ggg(3)=fac*zj
3699 c          do k=1,3
3700 c            ghalf=0.5D0*ggg(k)
3701 c            gelc(k,i)=gelc(k,i)+ghalf
3702 c            gelc(k,j)=gelc(k,j)+ghalf
3703 c          enddo
3704 c 9/28/08 AL Gradient compotents will be summed only at the end
3705           do k=1,3
3706             gelc_long(k,j)=gelc(k,j)+ggg(k)
3707             gelc_long(k,i)=gelc(k,i)-ggg(k)
3708           enddo
3709 *
3710 * Loop over residues i+1 thru j-1.
3711 *
3712 cgrad          do k=i+1,j-1
3713 cgrad            do l=1,3
3714 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3715 cgrad            enddo
3716 cgrad          enddo
3717 c 9/28/08 AL Gradient compotents will be summed only at the end
3718           ggg(1)=facvdw*xj+sssgrad*rmij*evdwij*xj
3719           ggg(2)=facvdw*yj+sssgrad*rmij*evdwij*yj
3720           ggg(3)=facvdw*zj+sssgrad*rmij*evdwij*zj
3721           do k=1,3
3722             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
3723             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
3724           enddo
3725 #endif
3726 *
3727 * Angular part
3728 *
3729           ecosa=2.0D0*fac3*fac1+fac4
3730           fac4=-3.0D0*fac4
3731           fac3=-6.0D0*fac3
3732           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
3733           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
3734           do k=1,3
3735             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
3736             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
3737           enddo
3738 cd        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
3739 cd   &          (dcosg(k),k=1,3)
3740           do k=1,3
3741             ggg(k)=ecosb*dcosb(k)+ecosg*dcosg(k)
3742           enddo
3743 c          do k=1,3
3744 c            ghalf=0.5D0*ggg(k)
3745 c            gelc(k,i)=gelc(k,i)+ghalf
3746 c     &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
3747 c     &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3748 c            gelc(k,j)=gelc(k,j)+ghalf
3749 c     &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
3750 c     &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3751 c          enddo
3752 cgrad          do k=i+1,j-1
3753 cgrad            do l=1,3
3754 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3755 cgrad            enddo
3756 cgrad          enddo
3757           do k=1,3
3758             gelc(k,i)=gelc(k,i)
3759      &           +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
3760      &           + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3761             gelc(k,j)=gelc(k,j)
3762      &           +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
3763      &           + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3764             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
3765             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
3766           enddo
3767 C MARYSIA
3768 c          endif !sscale
3769           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
3770      &        .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0
3771      &        .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
3772 C
3773 C 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
3774 C   energy of a peptide unit is assumed in the form of a second-order
3775 C   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
3776 C   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
3777 C   are computed for EVERY pair of non-contiguous peptide groups.
3778 C
3779
3780           if (j.lt.nres-1) then
3781             j1=j+1
3782             j2=j-1
3783           else
3784             j1=j-1
3785             j2=j-2
3786           endif
3787           kkk=0
3788           lll=0
3789           do k=1,2
3790             do l=1,2
3791               kkk=kkk+1
3792               muij(kkk)=mu(k,i)*mu(l,j)
3793 c              write(iout,*) 'mumu=', mu(k,i),mu(l,j),i,j,k,l
3794 #ifdef NEWCORR
3795              gmuij1(kkk)=gtb1(k,i+1)*mu(l,j)
3796 c             write(iout,*) 'k=',k,i,gtb1(k,i+1),gtb1(k,i+1)*mu(l,j)
3797              gmuij2(kkk)=gUb2(k,i)*mu(l,j)
3798              gmuji1(kkk)=mu(k,i)*gtb1(l,j+1)
3799 c             write(iout,*) 'l=',l,j,gtb1(l,j+1),gtb1(l,j+1)*mu(k,i)
3800              gmuji2(kkk)=mu(k,i)*gUb2(l,j)
3801 #endif
3802             enddo
3803           enddo
3804 cd         write (iout,*) 'EELEC: i',i,' j',j
3805 cd          write (iout,*) 'j',j,' j1',j1,' j2',j2
3806 cd          write(iout,*) 'muij',muij
3807           ury=scalar(uy(1,i),erij)
3808           urz=scalar(uz(1,i),erij)
3809           vry=scalar(uy(1,j),erij)
3810           vrz=scalar(uz(1,j),erij)
3811           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
3812           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
3813           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
3814           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
3815           fac=dsqrt(-ael6i)*r3ij
3816           a22=a22*fac
3817           a23=a23*fac
3818           a32=a32*fac
3819           a33=a33*fac
3820 cd          write (iout,'(4i5,4f10.5)')
3821 cd     &     i,itortyp(itype(i)),j,itortyp(itype(j)),a22,a23,a32,a33
3822 cd          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
3823 cd          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') uy(:,i),uz(:,i),
3824 cd     &      uy(:,j),uz(:,j)
3825 cd          write (iout,'(4f10.5)')
3826 cd     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
3827 cd     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
3828 cd          write (iout,'(4f10.5)') ury,urz,vry,vrz
3829 cd           write (iout,'(9f10.5/)')
3830 cd     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
3831 C Derivatives of the elements of A in virtual-bond vectors
3832           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
3833           do k=1,3
3834             uryg(k,1)=scalar(erder(1,k),uy(1,i))
3835             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
3836             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
3837             urzg(k,1)=scalar(erder(1,k),uz(1,i))
3838             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
3839             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
3840             vryg(k,1)=scalar(erder(1,k),uy(1,j))
3841             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
3842             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
3843             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
3844             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
3845             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
3846           enddo
3847 C Compute radial contributions to the gradient
3848           facr=-3.0d0*rrmij
3849           a22der=a22*facr
3850           a23der=a23*facr
3851           a32der=a32*facr
3852           a33der=a33*facr
3853           agg(1,1)=a22der*xj
3854           agg(2,1)=a22der*yj
3855           agg(3,1)=a22der*zj
3856           agg(1,2)=a23der*xj
3857           agg(2,2)=a23der*yj
3858           agg(3,2)=a23der*zj
3859           agg(1,3)=a32der*xj
3860           agg(2,3)=a32der*yj
3861           agg(3,3)=a32der*zj
3862           agg(1,4)=a33der*xj
3863           agg(2,4)=a33der*yj
3864           agg(3,4)=a33der*zj
3865 C Add the contributions coming from er
3866           fac3=-3.0d0*fac
3867           do k=1,3
3868             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
3869             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
3870             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
3871             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
3872           enddo
3873           do k=1,3
3874 C Derivatives in DC(i)
3875 cgrad            ghalf1=0.5d0*agg(k,1)
3876 cgrad            ghalf2=0.5d0*agg(k,2)
3877 cgrad            ghalf3=0.5d0*agg(k,3)
3878 cgrad            ghalf4=0.5d0*agg(k,4)
3879             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j))
3880      &      -3.0d0*uryg(k,2)*vry)!+ghalf1
3881             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j))
3882      &      -3.0d0*uryg(k,2)*vrz)!+ghalf2
3883             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j))
3884      &      -3.0d0*urzg(k,2)*vry)!+ghalf3
3885             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j))
3886      &      -3.0d0*urzg(k,2)*vrz)!+ghalf4
3887 C Derivatives in DC(i+1)
3888             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j))
3889      &      -3.0d0*uryg(k,3)*vry)!+agg(k,1)
3890             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j))
3891      &      -3.0d0*uryg(k,3)*vrz)!+agg(k,2)
3892             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j))
3893      &      -3.0d0*urzg(k,3)*vry)!+agg(k,3)
3894             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j))
3895      &      -3.0d0*urzg(k,3)*vrz)!+agg(k,4)
3896 C Derivatives in DC(j)
3897             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i))
3898      &      -3.0d0*vryg(k,2)*ury)!+ghalf1
3899             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i))
3900      &      -3.0d0*vrzg(k,2)*ury)!+ghalf2
3901             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i))
3902      &      -3.0d0*vryg(k,2)*urz)!+ghalf3
3903             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i))
3904      &      -3.0d0*vrzg(k,2)*urz)!+ghalf4
3905 C Derivatives in DC(j+1) or DC(nres-1)
3906             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i))
3907      &      -3.0d0*vryg(k,3)*ury)
3908             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i))
3909      &      -3.0d0*vrzg(k,3)*ury)
3910             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i))
3911      &      -3.0d0*vryg(k,3)*urz)
3912             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i))
3913      &      -3.0d0*vrzg(k,3)*urz)
3914 cgrad            if (j.eq.nres-1 .and. i.lt.j-2) then
3915 cgrad              do l=1,4
3916 cgrad                aggj1(k,l)=aggj1(k,l)+agg(k,l)
3917 cgrad              enddo
3918 cgrad            endif
3919           enddo
3920           acipa(1,1)=a22
3921           acipa(1,2)=a23
3922           acipa(2,1)=a32
3923           acipa(2,2)=a33
3924           a22=-a22
3925           a23=-a23
3926           do l=1,2
3927             do k=1,3
3928               agg(k,l)=-agg(k,l)
3929               aggi(k,l)=-aggi(k,l)
3930               aggi1(k,l)=-aggi1(k,l)
3931               aggj(k,l)=-aggj(k,l)
3932               aggj1(k,l)=-aggj1(k,l)
3933             enddo
3934           enddo
3935           if (j.lt.nres-1) then
3936             a22=-a22
3937             a32=-a32
3938             do l=1,3,2
3939               do k=1,3
3940                 agg(k,l)=-agg(k,l)
3941                 aggi(k,l)=-aggi(k,l)
3942                 aggi1(k,l)=-aggi1(k,l)
3943                 aggj(k,l)=-aggj(k,l)
3944                 aggj1(k,l)=-aggj1(k,l)
3945               enddo
3946             enddo
3947           else
3948             a22=-a22
3949             a23=-a23
3950             a32=-a32
3951             a33=-a33
3952             do l=1,4
3953               do k=1,3
3954                 agg(k,l)=-agg(k,l)
3955                 aggi(k,l)=-aggi(k,l)
3956                 aggi1(k,l)=-aggi1(k,l)
3957                 aggj(k,l)=-aggj(k,l)
3958                 aggj1(k,l)=-aggj1(k,l)
3959               enddo
3960             enddo
3961           endif
3962           ENDIF ! WCORR
3963           IF (wel_loc.gt.0.0d0) THEN
3964 C Contribution to the local-electrostatic energy coming from the i-j pair
3965           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3)
3966      &     +a33*muij(4)
3967 c          write (iout,*) 'i',i,' j',j,itype(i),itype(j),
3968 c     &                     ' eel_loc_ij',eel_loc_ij
3969 c          write(iout,*) 'muije=',muij(1),muij(2),muij(3),muij(4)
3970 C Calculate patrial derivative for theta angle
3971 #ifdef NEWCORR
3972          geel_loc_ij=a22*gmuij1(1)
3973      &     +a23*gmuij1(2)
3974      &     +a32*gmuij1(3)
3975      &     +a33*gmuij1(4)
3976 c         write(iout,*) "derivative over thatai"
3977 c         write(iout,*) a22*gmuij1(1), a23*gmuij1(2) ,a32*gmuij1(3),
3978 c     &   a33*gmuij1(4)
3979          gloc(nphi+i,icg)=gloc(nphi+i,icg)+
3980      &      geel_loc_ij*wel_loc
3981 c         write(iout,*) "derivative over thatai-1"
3982 c         write(iout,*) a22*gmuij2(1), a23*gmuij2(2) ,a32*gmuij2(3),
3983 c     &   a33*gmuij2(4)
3984          geel_loc_ij=
3985      &     a22*gmuij2(1)
3986      &     +a23*gmuij2(2)
3987      &     +a32*gmuij2(3)
3988      &     +a33*gmuij2(4)
3989          gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
3990      &      geel_loc_ij*wel_loc
3991 c  Derivative over j residue
3992          geel_loc_ji=a22*gmuji1(1)
3993      &     +a23*gmuji1(2)
3994      &     +a32*gmuji1(3)
3995      &     +a33*gmuji1(4)
3996 c         write(iout,*) "derivative over thataj"
3997 c         write(iout,*) a22*gmuji1(1), a23*gmuji1(2) ,a32*gmuji1(3),
3998 c     &   a33*gmuji1(4)
3999
4000         gloc(nphi+j,icg)=gloc(nphi+j,icg)+
4001      &      geel_loc_ji*wel_loc
4002          geel_loc_ji=
4003      &     +a22*gmuji2(1)
4004      &     +a23*gmuji2(2)
4005      &     +a32*gmuji2(3)
4006      &     +a33*gmuji2(4)
4007 c         write(iout,*) "derivative over thataj-1"
4008 c         write(iout,*) a22*gmuji2(1), a23*gmuji2(2) ,a32*gmuji2(3),
4009 c     &   a33*gmuji2(4)
4010          gloc(nphi+j-1,icg)=gloc(nphi+j-1,icg)+
4011      &      geel_loc_ji*wel_loc
4012 #endif
4013 cd          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
4014
4015           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
4016      &            'eelloc',i,j,eel_loc_ij
4017 c           if (eel_loc_ij.ne.0)
4018 c     &      write (iout,'(a4,2i4,8f9.5)')'chuj',
4019 c     &     i,j,a22,muij(1),a23,muij(2),a32,muij(3),a33,muij(4)
4020
4021           eel_loc=eel_loc+eel_loc_ij
4022 C Partial derivatives in virtual-bond dihedral angles gamma
4023           if (i.gt.1)
4024      &    gel_loc_loc(i-1)=gel_loc_loc(i-1)+
4025      &            a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j)
4026      &           +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j)
4027           gel_loc_loc(j-1)=gel_loc_loc(j-1)+
4028      &            a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j)
4029      &           +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j)
4030 C Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
4031           do l=1,3
4032             ggg(l)=agg(l,1)*muij(1)+
4033      &          agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4)
4034             gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l)
4035             gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l)
4036 cgrad            ghalf=0.5d0*ggg(l)
4037 cgrad            gel_loc(l,i)=gel_loc(l,i)+ghalf
4038 cgrad            gel_loc(l,j)=gel_loc(l,j)+ghalf
4039           enddo
4040 cgrad          do k=i+1,j2
4041 cgrad            do l=1,3
4042 cgrad              gel_loc(l,k)=gel_loc(l,k)+ggg(l)
4043 cgrad            enddo
4044 cgrad          enddo
4045 C Remaining derivatives of eello
4046           do l=1,3
4047             gel_loc(l,i)=gel_loc(l,i)+(aggi(l,1)*muij(1)+
4048      &        aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4))
4049             gel_loc(l,i+1)=gel_loc(l,i+1)+(aggi1(l,1)*muij(1)+
4050      &     aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4))
4051             gel_loc(l,j)=gel_loc(l,j)+(aggj(l,1)*muij(1)+
4052      &       aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4))
4053             gel_loc(l,j1)=gel_loc(l,j1)+(aggj1(l,1)*muij(1)+
4054      &     aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4))
4055           enddo
4056           ENDIF
4057 C Change 12/26/95 to calculate four-body contributions to H-bonding energy
4058 c          if (j.gt.i+1 .and. num_conti.le.maxconts) then
4059           if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0
4060      &       .and. num_conti.le.maxconts) then
4061 c            write (iout,*) i,j," entered corr"
4062 C
4063 C Calculate the contact function. The ith column of the array JCONT will
4064 C contain the numbers of atoms that make contacts with the atom I (of numbers
4065 C greater than I). The arrays FACONT and GACONT will contain the values of
4066 C the contact function and its derivative.
4067 c           r0ij=1.02D0*rpp(iteli,itelj)
4068 c           r0ij=1.11D0*rpp(iteli,itelj)
4069             r0ij=2.20D0*rpp(iteli,itelj)
4070 c           r0ij=1.55D0*rpp(iteli,itelj)
4071             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
4072             if (fcont.gt.0.0D0) then
4073               num_conti=num_conti+1
4074               if (num_conti.gt.maxconts) then
4075                 write (iout,*) 'WARNING - max. # of contacts exceeded;',
4076      &                         ' will skip next contacts for this conf.'
4077               else
4078                 jcont_hb(num_conti,i)=j
4079 cd                write (iout,*) "i",i," j",j," num_conti",num_conti,
4080 cd     &           " jcont_hb",jcont_hb(num_conti,i)
4081                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.
4082      &          wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
4083 C 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
4084 C  terms.
4085                 d_cont(num_conti,i)=rij
4086 cd                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
4087 C     --- Electrostatic-interaction matrix ---
4088                 a_chuj(1,1,num_conti,i)=a22
4089                 a_chuj(1,2,num_conti,i)=a23
4090                 a_chuj(2,1,num_conti,i)=a32
4091                 a_chuj(2,2,num_conti,i)=a33
4092 C     --- Gradient of rij
4093                 do kkk=1,3
4094                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
4095                 enddo
4096                 kkll=0
4097                 do k=1,2
4098                   do l=1,2
4099                     kkll=kkll+1
4100                     do m=1,3
4101                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
4102                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
4103                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
4104                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
4105                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
4106                     enddo
4107                   enddo
4108                 enddo
4109                 ENDIF
4110                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
4111 C Calculate contact energies
4112                 cosa4=4.0D0*cosa
4113                 wij=cosa-3.0D0*cosb*cosg
4114                 cosbg1=cosb+cosg
4115                 cosbg2=cosb-cosg
4116 c               fac3=dsqrt(-ael6i)/r0ij**3
4117                 fac3=dsqrt(-ael6i)*r3ij
4118 c                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
4119                 ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
4120                 if (ees0tmp.gt.0) then
4121                   ees0pij=dsqrt(ees0tmp)
4122                 else
4123                   ees0pij=0
4124                 endif
4125 c                ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
4126                 ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
4127                 if (ees0tmp.gt.0) then
4128                   ees0mij=dsqrt(ees0tmp)
4129                 else
4130                   ees0mij=0
4131                 endif
4132 c               ees0mij=0.0D0
4133                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij)
4134                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij)
4135 C Diagnostics. Comment out or remove after debugging!
4136 c               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
4137 c               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
4138 c               ees0m(num_conti,i)=0.0D0
4139 C End diagnostics.
4140 c               write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
4141 c    & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
4142 C Angular derivatives of the contact function
4143                 ees0pij1=fac3/ees0pij
4144                 ees0mij1=fac3/ees0mij
4145                 fac3p=-3.0D0*fac3*rrmij
4146                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
4147                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
4148 c               ees0mij1=0.0D0
4149                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
4150                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
4151                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
4152                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
4153                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
4154                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
4155                 ecosap=ecosa1+ecosa2
4156                 ecosbp=ecosb1+ecosb2
4157                 ecosgp=ecosg1+ecosg2
4158                 ecosam=ecosa1-ecosa2
4159                 ecosbm=ecosb1-ecosb2
4160                 ecosgm=ecosg1-ecosg2
4161 C Diagnostics
4162 c               ecosap=ecosa1
4163 c               ecosbp=ecosb1
4164 c               ecosgp=ecosg1
4165 c               ecosam=0.0D0
4166 c               ecosbm=0.0D0
4167 c               ecosgm=0.0D0
4168 C End diagnostics
4169                 facont_hb(num_conti,i)=fcont
4170                 fprimcont=fprimcont/rij
4171 cd              facont_hb(num_conti,i)=1.0D0
4172 C Following line is for diagnostics.
4173 cd              fprimcont=0.0D0
4174                 do k=1,3
4175                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
4176                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
4177                 enddo
4178                 do k=1,3
4179                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
4180                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
4181                 enddo
4182                 gggp(1)=gggp(1)+ees0pijp*xj
4183                 gggp(2)=gggp(2)+ees0pijp*yj
4184                 gggp(3)=gggp(3)+ees0pijp*zj
4185                 gggm(1)=gggm(1)+ees0mijp*xj
4186                 gggm(2)=gggm(2)+ees0mijp*yj
4187                 gggm(3)=gggm(3)+ees0mijp*zj
4188 C Derivatives due to the contact function
4189                 gacont_hbr(1,num_conti,i)=fprimcont*xj
4190                 gacont_hbr(2,num_conti,i)=fprimcont*yj
4191                 gacont_hbr(3,num_conti,i)=fprimcont*zj
4192                 do k=1,3
4193 c
4194 c 10/24/08 cgrad and ! comments indicate the parts of the code removed
4195 c          following the change of gradient-summation algorithm.
4196 c
4197 cgrad                  ghalfp=0.5D0*gggp(k)
4198 cgrad                  ghalfm=0.5D0*gggm(k)
4199                   gacontp_hb1(k,num_conti,i)=!ghalfp
4200      &              +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i))
4201      &              + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
4202                   gacontp_hb2(k,num_conti,i)=!ghalfp
4203      &              +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j))
4204      &              + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
4205                   gacontp_hb3(k,num_conti,i)=gggp(k)
4206                   gacontm_hb1(k,num_conti,i)=!ghalfm
4207      &              +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i))
4208      &              + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
4209                   gacontm_hb2(k,num_conti,i)=!ghalfm
4210      &              +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j))
4211      &              + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
4212                   gacontm_hb3(k,num_conti,i)=gggm(k)
4213                 enddo
4214 C Diagnostics. Comment out or remove after debugging!
4215 cdiag           do k=1,3
4216 cdiag             gacontp_hb1(k,num_conti,i)=0.0D0
4217 cdiag             gacontp_hb2(k,num_conti,i)=0.0D0
4218 cdiag             gacontp_hb3(k,num_conti,i)=0.0D0
4219 cdiag             gacontm_hb1(k,num_conti,i)=0.0D0
4220 cdiag             gacontm_hb2(k,num_conti,i)=0.0D0
4221 cdiag             gacontm_hb3(k,num_conti,i)=0.0D0
4222 cdiag           enddo
4223               ENDIF ! wcorr
4224               endif  ! num_conti.le.maxconts
4225             endif  ! fcont.gt.0
4226           endif    ! j.gt.i+1
4227           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
4228             do k=1,4
4229               do l=1,3
4230                 ghalf=0.5d0*agg(l,k)
4231                 aggi(l,k)=aggi(l,k)+ghalf
4232                 aggi1(l,k)=aggi1(l,k)+agg(l,k)
4233                 aggj(l,k)=aggj(l,k)+ghalf
4234               enddo
4235             enddo
4236             if (j.eq.nres-1 .and. i.lt.j-2) then
4237               do k=1,4
4238                 do l=1,3
4239                   aggj1(l,k)=aggj1(l,k)+agg(l,k)
4240                 enddo
4241               enddo
4242             endif
4243           endif
4244 c          t_eelecij=t_eelecij+MPI_Wtime()-time00
4245       return
4246       end
4247 C-----------------------------------------------------------------------------
4248       subroutine eturn3(i,eello_turn3)
4249 C Third- and fourth-order contributions from turns
4250       implicit real*8 (a-h,o-z)
4251       include 'DIMENSIONS'
4252       include 'COMMON.IOUNITS'
4253       include 'COMMON.GEO'
4254       include 'COMMON.VAR'
4255       include 'COMMON.LOCAL'
4256       include 'COMMON.CHAIN'
4257       include 'COMMON.DERIV'
4258       include 'COMMON.INTERACT'
4259       include 'COMMON.CONTACTS'
4260       include 'COMMON.TORSION'
4261       include 'COMMON.VECTORS'
4262       include 'COMMON.FFIELD'
4263       include 'COMMON.CONTROL'
4264       dimension ggg(3)
4265       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
4266      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
4267      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2),gpizda1(2,2),
4268      &  gpizda2(2,2),auxgmat1(2,2),auxgmatt1(2,2),
4269      &  auxgmat2(2,2),auxgmatt2(2,2)
4270       double precision agg(3,4),aggi(3,4),aggi1(3,4),
4271      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
4272       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
4273      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
4274      &    num_conti,j1,j2
4275       j=i+2
4276 c      write (iout,*) "eturn3",i,j,j1,j2
4277       a_temp(1,1)=a22
4278       a_temp(1,2)=a23
4279       a_temp(2,1)=a32
4280       a_temp(2,2)=a33
4281 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4282 C
4283 C               Third-order contributions
4284 C
4285 C                 (i+2)o----(i+3)
4286 C                      | |
4287 C                      | |
4288 C                 (i+1)o----i
4289 C
4290 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4291 cd        call checkint_turn3(i,a_temp,eello_turn3_num)
4292         call matmat2(EUg(1,1,i+1),EUg(1,1,i+2),auxmat(1,1))
4293 c auxalary matices for theta gradient
4294 c auxalary matrix for i+1 and constant i+2
4295         call matmat2(gtEUg(1,1,i+1),EUg(1,1,i+2),auxgmat1(1,1))
4296 c auxalary matrix for i+2 and constant i+1
4297         call matmat2(EUg(1,1,i+1),gtEUg(1,1,i+2),auxgmat2(1,1))
4298         call transpose2(auxmat(1,1),auxmat1(1,1))
4299         call transpose2(auxgmat1(1,1),auxgmatt1(1,1))
4300         call transpose2(auxgmat2(1,1),auxgmatt2(1,1))
4301         call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4302         call matmat2(a_temp(1,1),auxgmatt1(1,1),gpizda1(1,1))
4303         call matmat2(a_temp(1,1),auxgmatt2(1,1),gpizda2(1,1))
4304         eello_turn3=eello_turn3+0.5d0*(pizda(1,1)+pizda(2,2))
4305 C Derivatives in theta
4306         gloc(nphi+i,icg)=gloc(nphi+i,icg)
4307      &  +0.5d0*(gpizda1(1,1)+gpizda1(2,2))*wturn3
4308         gloc(nphi+i+1,icg)=gloc(nphi+i+1,icg)
4309      &  +0.5d0*(gpizda2(1,1)+gpizda2(2,2))*wturn3
4310
4311         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
4312      &          'eturn3',i,j,0.5d0*(pizda(1,1)+pizda(2,2))
4313 cd        write (2,*) 'i,',i,' j',j,'eello_turn3',
4314 cd     &    0.5d0*(pizda(1,1)+pizda(2,2)),
4315 cd     &    ' eello_turn3_num',4*eello_turn3_num
4316 C Derivatives in gamma(i)
4317         call matmat2(EUgder(1,1,i+1),EUg(1,1,i+2),auxmat2(1,1))
4318         call transpose2(auxmat2(1,1),auxmat3(1,1))
4319         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
4320         gel_loc_turn3(i)=gel_loc_turn3(i)+0.5d0*(pizda(1,1)+pizda(2,2))
4321 C Derivatives in gamma(i+1)
4322         call matmat2(EUg(1,1,i+1),EUgder(1,1,i+2),auxmat2(1,1))
4323         call transpose2(auxmat2(1,1),auxmat3(1,1))
4324         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
4325         gel_loc_turn3(i+1)=gel_loc_turn3(i+1)
4326      &    +0.5d0*(pizda(1,1)+pizda(2,2))
4327 C Cartesian derivatives
4328         do l=1,3
4329 c            ghalf1=0.5d0*agg(l,1)
4330 c            ghalf2=0.5d0*agg(l,2)
4331 c            ghalf3=0.5d0*agg(l,3)
4332 c            ghalf4=0.5d0*agg(l,4)
4333           a_temp(1,1)=aggi(l,1)!+ghalf1
4334           a_temp(1,2)=aggi(l,2)!+ghalf2
4335           a_temp(2,1)=aggi(l,3)!+ghalf3
4336           a_temp(2,2)=aggi(l,4)!+ghalf4
4337           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4338           gcorr3_turn(l,i)=gcorr3_turn(l,i)
4339      &      +0.5d0*(pizda(1,1)+pizda(2,2))
4340           a_temp(1,1)=aggi1(l,1)!+agg(l,1)
4341           a_temp(1,2)=aggi1(l,2)!+agg(l,2)
4342           a_temp(2,1)=aggi1(l,3)!+agg(l,3)
4343           a_temp(2,2)=aggi1(l,4)!+agg(l,4)
4344           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4345           gcorr3_turn(l,i+1)=gcorr3_turn(l,i+1)
4346      &      +0.5d0*(pizda(1,1)+pizda(2,2))
4347           a_temp(1,1)=aggj(l,1)!+ghalf1
4348           a_temp(1,2)=aggj(l,2)!+ghalf2
4349           a_temp(2,1)=aggj(l,3)!+ghalf3
4350           a_temp(2,2)=aggj(l,4)!+ghalf4
4351           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4352           gcorr3_turn(l,j)=gcorr3_turn(l,j)
4353      &      +0.5d0*(pizda(1,1)+pizda(2,2))
4354           a_temp(1,1)=aggj1(l,1)
4355           a_temp(1,2)=aggj1(l,2)
4356           a_temp(2,1)=aggj1(l,3)
4357           a_temp(2,2)=aggj1(l,4)
4358           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4359           gcorr3_turn(l,j1)=gcorr3_turn(l,j1)
4360      &      +0.5d0*(pizda(1,1)+pizda(2,2))
4361         enddo
4362       return
4363       end
4364 C-------------------------------------------------------------------------------
4365       subroutine eturn4(i,eello_turn4)
4366 C Third- and fourth-order contributions from turns
4367       implicit real*8 (a-h,o-z)
4368       include 'DIMENSIONS'
4369       include 'COMMON.IOUNITS'
4370       include 'COMMON.GEO'
4371       include 'COMMON.VAR'
4372       include 'COMMON.LOCAL'
4373       include 'COMMON.CHAIN'
4374       include 'COMMON.DERIV'
4375       include 'COMMON.INTERACT'
4376       include 'COMMON.CONTACTS'
4377       include 'COMMON.TORSION'
4378       include 'COMMON.VECTORS'
4379       include 'COMMON.FFIELD'
4380       include 'COMMON.CONTROL'
4381       dimension ggg(3)
4382       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
4383      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
4384      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2),auxgvec(2),
4385      &  auxgEvec1(2),auxgEvec2(2),auxgEvec3(2),
4386      &  gte1t(2,2),gte2t(2,2),gte3t(2,2),
4387      &  gte1a(2,2),gtae3(2,2),gtae3e2(2,2), ae3gte2(2,2),
4388      &  gtEpizda1(2,2),gtEpizda2(2,2),gtEpizda3(2,2)
4389       double precision agg(3,4),aggi(3,4),aggi1(3,4),
4390      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
4391       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
4392      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
4393      &    num_conti,j1,j2
4394       j=i+3
4395 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4396 C
4397 C               Fourth-order contributions
4398 C
4399 C                 (i+3)o----(i+4)
4400 C                     /  |
4401 C               (i+2)o   |
4402 C                     \  |
4403 C                 (i+1)o----i
4404 C
4405 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4406 cd        call checkint_turn4(i,a_temp,eello_turn4_num)
4407 c        write (iout,*) "eturn4 i",i," j",j," j1",j1," j2",j2
4408 c        write(iout,*)"WCHODZE W PROGRAM"
4409         a_temp(1,1)=a22
4410         a_temp(1,2)=a23
4411         a_temp(2,1)=a32
4412         a_temp(2,2)=a33
4413         iti1=itortyp(itype(i+1))
4414         iti2=itortyp(itype(i+2))
4415         iti3=itortyp(itype(i+3))
4416 c        write(iout,*) "iti1",iti1," iti2",iti2," iti3",iti3
4417         call transpose2(EUg(1,1,i+1),e1t(1,1))
4418         call transpose2(Eug(1,1,i+2),e2t(1,1))
4419         call transpose2(Eug(1,1,i+3),e3t(1,1))
4420 C Ematrix derivative in theta
4421         call transpose2(gtEUg(1,1,i+1),gte1t(1,1))
4422         call transpose2(gtEug(1,1,i+2),gte2t(1,1))
4423         call transpose2(gtEug(1,1,i+3),gte3t(1,1))
4424         call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4425 c       eta1 in derivative theta
4426         call matmat2(gte1t(1,1),a_temp(1,1),gte1a(1,1))
4427         call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4428 c       auxgvec is derivative of Ub2 so i+3 theta
4429         call matvec2(e1a(1,1),gUb2(1,i+3),auxgvec(1))
4430 c       auxalary matrix of E i+1
4431         call matvec2(gte1a(1,1),Ub2(1,i+3),auxgEvec1(1))
4432 c        s1=0.0
4433 c        gs1=0.0
4434         s1=scalar2(b1(1,i+2),auxvec(1))
4435 c derivative of theta i+2 with constant i+3
4436         gs23=scalar2(gtb1(1,i+2),auxvec(1))
4437 c derivative of theta i+2 with constant i+2
4438         gs32=scalar2(b1(1,i+2),auxgvec(1))
4439 c derivative of E matix in theta of i+1
4440         gsE13=scalar2(b1(1,i+2),auxgEvec1(1))
4441
4442         call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4443 c       ea31 in derivative theta
4444         call matmat2(a_temp(1,1),gte3t(1,1),gtae3(1,1))
4445         call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4446 c auxilary matrix auxgvec of Ub2 with constant E matirx
4447         call matvec2(ae3(1,1),gUb2(1,i+2),auxgvec(1))
4448 c auxilary matrix auxgEvec1 of E matix with Ub2 constant
4449         call matvec2(gtae3(1,1),Ub2(1,i+2),auxgEvec3(1))
4450
4451 c        s2=0.0
4452 c        gs2=0.0
4453         s2=scalar2(b1(1,i+1),auxvec(1))
4454 c derivative of theta i+1 with constant i+3
4455         gs13=scalar2(gtb1(1,i+1),auxvec(1))
4456 c derivative of theta i+2 with constant i+1
4457         gs21=scalar2(b1(1,i+1),auxgvec(1))
4458 c derivative of theta i+3 with constant i+1
4459         gsE31=scalar2(b1(1,i+1),auxgEvec3(1))
4460 c        write(iout,*) gs1,gs2,'i=',i,auxgvec(1),gUb2(1,i+2),gtb1(1,i+2),
4461 c     &  gtb1(1,i+1)
4462         call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4463 c two derivatives over diffetent matrices
4464 c gtae3e2 is derivative over i+3
4465         call matmat2(gtae3(1,1),e2t(1,1),gtae3e2(1,1))
4466 c ae3gte2 is derivative over i+2
4467         call matmat2(ae3(1,1),gte2t(1,1),ae3gte2(1,1))
4468         call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4469 c three possible derivative over theta E matices
4470 c i+1
4471         call matmat2(ae3e2(1,1),gte1t(1,1),gtEpizda1(1,1))
4472 c i+2
4473         call matmat2(ae3gte2(1,1),e1t(1,1),gtEpizda2(1,1))
4474 c i+3
4475         call matmat2(gtae3e2(1,1),e1t(1,1),gtEpizda3(1,1))
4476         s3=0.5d0*(pizda(1,1)+pizda(2,2))
4477
4478         gsEE1=0.5d0*(gtEpizda1(1,1)+gtEpizda1(2,2))
4479         gsEE2=0.5d0*(gtEpizda2(1,1)+gtEpizda2(2,2))
4480         gsEE3=0.5d0*(gtEpizda3(1,1)+gtEpizda3(2,2))
4481
4482         eello_turn4=eello_turn4-(s1+s2+s3)
4483 c             write(iout,*)'chujOWO', auxvec(1),b1(1,iti2)
4484         if (energy_dec) write (iout,'(a6,2i5,0pf7.3,3f7.3)')
4485      &      'eturn4',i,j,-(s1+s2+s3),s1,s2,s3
4486 cd        write (2,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
4487 cd     &    ' eello_turn4_num',8*eello_turn4_num
4488 #ifdef NEWCORR
4489         gloc(nphi+i,icg)=gloc(nphi+i,icg)
4490      &                  -(gs13+gsE13+gsEE1)*wturn4
4491         gloc(nphi+i+1,icg)= gloc(nphi+i+1,icg)
4492      &                    -(gs23+gs21+gsEE2)*wturn4
4493         gloc(nphi+i+2,icg)= gloc(nphi+i+2,icg)
4494      &                    -(gs32+gsE31+gsEE3)*wturn4
4495 c         gloc(nphi+i+1,icg)=gloc(nphi+i+1,icg)-
4496 c     &   gs2
4497 #endif
4498         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
4499      &      'eturn4',i,j,-(s1+s2+s3)
4500 c        write (iout,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
4501 c     &    ' eello_turn4_num',8*eello_turn4_num
4502 C Derivatives in gamma(i)
4503         call transpose2(EUgder(1,1,i+1),e1tder(1,1))
4504         call matmat2(e1tder(1,1),a_temp(1,1),auxmat(1,1))
4505         call matvec2(auxmat(1,1),Ub2(1,i+3),auxvec(1))
4506         s1=scalar2(b1(1,i+2),auxvec(1))
4507         call matmat2(ae3e2(1,1),e1tder(1,1),pizda(1,1))
4508         s3=0.5d0*(pizda(1,1)+pizda(2,2))
4509         gel_loc_turn4(i)=gel_loc_turn4(i)-(s1+s3)
4510 C Derivatives in gamma(i+1)
4511         call transpose2(EUgder(1,1,i+2),e2tder(1,1))
4512         call matvec2(ae3(1,1),Ub2der(1,i+2),auxvec(1))
4513         s2=scalar2(b1(1,i+1),auxvec(1))
4514         call matmat2(ae3(1,1),e2tder(1,1),auxmat(1,1))
4515         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
4516         s3=0.5d0*(pizda(1,1)+pizda(2,2))
4517         gel_loc_turn4(i+1)=gel_loc_turn4(i+1)-(s2+s3)
4518 C Derivatives in gamma(i+2)
4519         call transpose2(EUgder(1,1,i+3),e3tder(1,1))
4520         call matvec2(e1a(1,1),Ub2der(1,i+3),auxvec(1))
4521         s1=scalar2(b1(1,i+2),auxvec(1))
4522         call matmat2(a_temp(1,1),e3tder(1,1),auxmat(1,1))
4523         call matvec2(auxmat(1,1),Ub2(1,i+2),auxvec(1))
4524         s2=scalar2(b1(1,i+1),auxvec(1))
4525         call matmat2(auxmat(1,1),e2t(1,1),auxmat3(1,1))
4526         call matmat2(auxmat3(1,1),e1t(1,1),pizda(1,1))
4527         s3=0.5d0*(pizda(1,1)+pizda(2,2))
4528         gel_loc_turn4(i+2)=gel_loc_turn4(i+2)-(s1+s2+s3)
4529 C Cartesian derivatives
4530 C Derivatives of this turn contributions in DC(i+2)
4531         if (j.lt.nres-1) then
4532           do l=1,3
4533             a_temp(1,1)=agg(l,1)
4534             a_temp(1,2)=agg(l,2)
4535             a_temp(2,1)=agg(l,3)
4536             a_temp(2,2)=agg(l,4)
4537             call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4538             call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4539             s1=scalar2(b1(1,i+2),auxvec(1))
4540             call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4541             call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4542             s2=scalar2(b1(1,i+1),auxvec(1))
4543             call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4544             call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4545             s3=0.5d0*(pizda(1,1)+pizda(2,2))
4546             ggg(l)=-(s1+s2+s3)
4547             gcorr4_turn(l,i+2)=gcorr4_turn(l,i+2)-(s1+s2+s3)
4548           enddo
4549         endif
4550 C Remaining derivatives of this turn contribution
4551         do l=1,3
4552           a_temp(1,1)=aggi(l,1)
4553           a_temp(1,2)=aggi(l,2)
4554           a_temp(2,1)=aggi(l,3)
4555           a_temp(2,2)=aggi(l,4)
4556           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4557           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4558           s1=scalar2(b1(1,i+2),auxvec(1))
4559           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4560           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4561           s2=scalar2(b1(1,i+1),auxvec(1))
4562           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4563           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4564           s3=0.5d0*(pizda(1,1)+pizda(2,2))
4565           gcorr4_turn(l,i)=gcorr4_turn(l,i)-(s1+s2+s3)
4566           a_temp(1,1)=aggi1(l,1)
4567           a_temp(1,2)=aggi1(l,2)
4568           a_temp(2,1)=aggi1(l,3)
4569           a_temp(2,2)=aggi1(l,4)
4570           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4571           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4572           s1=scalar2(b1(1,i+2),auxvec(1))
4573           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4574           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4575           s2=scalar2(b1(1,i+1),auxvec(1))
4576           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4577           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4578           s3=0.5d0*(pizda(1,1)+pizda(2,2))
4579           gcorr4_turn(l,i+1)=gcorr4_turn(l,i+1)-(s1+s2+s3)
4580           a_temp(1,1)=aggj(l,1)
4581           a_temp(1,2)=aggj(l,2)
4582           a_temp(2,1)=aggj(l,3)
4583           a_temp(2,2)=aggj(l,4)
4584           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4585           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4586           s1=scalar2(b1(1,i+2),auxvec(1))
4587           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4588           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4589           s2=scalar2(b1(1,i+1),auxvec(1))
4590           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4591           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4592           s3=0.5d0*(pizda(1,1)+pizda(2,2))
4593           gcorr4_turn(l,j)=gcorr4_turn(l,j)-(s1+s2+s3)
4594           a_temp(1,1)=aggj1(l,1)
4595           a_temp(1,2)=aggj1(l,2)
4596           a_temp(2,1)=aggj1(l,3)
4597           a_temp(2,2)=aggj1(l,4)
4598           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4599           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4600           s1=scalar2(b1(1,i+2),auxvec(1))
4601           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4602           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4603           s2=scalar2(b1(1,i+1),auxvec(1))
4604           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4605           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4606           s3=0.5d0*(pizda(1,1)+pizda(2,2))
4607 c          write (iout,*) "s1",s1," s2",s2," s3",s3," s1+s2+s3",s1+s2+s3
4608           gcorr4_turn(l,j1)=gcorr4_turn(l,j1)-(s1+s2+s3)
4609         enddo
4610       return
4611       end
4612 C-----------------------------------------------------------------------------
4613       subroutine vecpr(u,v,w)
4614       implicit real*8(a-h,o-z)
4615       dimension u(3),v(3),w(3)
4616       w(1)=u(2)*v(3)-u(3)*v(2)
4617       w(2)=-u(1)*v(3)+u(3)*v(1)
4618       w(3)=u(1)*v(2)-u(2)*v(1)
4619       return
4620       end
4621 C-----------------------------------------------------------------------------
4622       subroutine unormderiv(u,ugrad,unorm,ungrad)
4623 C This subroutine computes the derivatives of a normalized vector u, given
4624 C the derivatives computed without normalization conditions, ugrad. Returns
4625 C ungrad.
4626       implicit none
4627       double precision u(3),ugrad(3,3),unorm,ungrad(3,3)
4628       double precision vec(3)
4629       double precision scalar
4630       integer i,j
4631 c      write (2,*) 'ugrad',ugrad
4632 c      write (2,*) 'u',u
4633       do i=1,3
4634         vec(i)=scalar(ugrad(1,i),u(1))
4635       enddo
4636 c      write (2,*) 'vec',vec
4637       do i=1,3
4638         do j=1,3
4639           ungrad(j,i)=(ugrad(j,i)-u(j)*vec(i))*unorm
4640         enddo
4641       enddo
4642 c      write (2,*) 'ungrad',ungrad
4643       return
4644       end
4645 C-----------------------------------------------------------------------------
4646       subroutine escp_soft_sphere(evdw2,evdw2_14)
4647 C
4648 C This subroutine calculates the excluded-volume interaction energy between
4649 C peptide-group centers and side chains and its gradient in virtual-bond and
4650 C side-chain vectors.
4651 C
4652       implicit real*8 (a-h,o-z)
4653       include 'DIMENSIONS'
4654       include 'COMMON.GEO'
4655       include 'COMMON.VAR'
4656       include 'COMMON.LOCAL'
4657       include 'COMMON.CHAIN'
4658       include 'COMMON.DERIV'
4659       include 'COMMON.INTERACT'
4660       include 'COMMON.FFIELD'
4661       include 'COMMON.IOUNITS'
4662       include 'COMMON.CONTROL'
4663       dimension ggg(3)
4664       evdw2=0.0D0
4665       evdw2_14=0.0d0
4666       r0_scp=4.5d0
4667 cd    print '(a)','Enter ESCP'
4668 cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
4669 C      do xshift=-1,1
4670 C      do yshift=-1,1
4671 C      do zshift=-1,1
4672       do i=iatscp_s,iatscp_e
4673         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
4674         iteli=itel(i)
4675         xi=0.5D0*(c(1,i)+c(1,i+1))
4676         yi=0.5D0*(c(2,i)+c(2,i+1))
4677         zi=0.5D0*(c(3,i)+c(3,i+1))
4678 C Return atom into box, boxxsize is size of box in x dimension
4679 c  134   continue
4680 c        if (xi.gt.((xshift+0.5d0)*boxxsize)) xi=xi-boxxsize
4681 c        if (xi.lt.((xshift-0.5d0)*boxxsize)) xi=xi+boxxsize
4682 C Condition for being inside the proper box
4683 c        if ((xi.gt.((xshift+0.5d0)*boxxsize)).or.
4684 c     &       (xi.lt.((xshift-0.5d0)*boxxsize))) then
4685 c        go to 134
4686 c        endif
4687 c  135   continue
4688 c        if (yi.gt.((yshift+0.5d0)*boxysize)) yi=yi-boxysize
4689 c        if (yi.lt.((yshift-0.5d0)*boxysize)) yi=yi+boxysize
4690 C Condition for being inside the proper box
4691 c        if ((yi.gt.((yshift+0.5d0)*boxysize)).or.
4692 c     &       (yi.lt.((yshift-0.5d0)*boxysize))) then
4693 c        go to 135
4694 c c       endif
4695 c  136   continue
4696 c        if (zi.gt.((zshift+0.5d0)*boxzsize)) zi=zi-boxzsize
4697 c        if (zi.lt.((zshift-0.5d0)*boxzsize)) zi=zi+boxzsize
4698 cC Condition for being inside the proper box
4699 c        if ((zi.gt.((zshift+0.5d0)*boxzsize)).or.
4700 c     &       (zi.lt.((zshift-0.5d0)*boxzsize))) then
4701 c        go to 136
4702 c        endif
4703           xi=mod(xi,boxxsize)
4704           if (xi.lt.0) xi=xi+boxxsize
4705           yi=mod(yi,boxysize)
4706           if (yi.lt.0) yi=yi+boxysize
4707           zi=mod(zi,boxzsize)
4708           if (zi.lt.0) zi=zi+boxzsize
4709 C          xi=xi+xshift*boxxsize
4710 C          yi=yi+yshift*boxysize
4711 C          zi=zi+zshift*boxzsize
4712         do iint=1,nscp_gr(i)
4713
4714         do j=iscpstart(i,iint),iscpend(i,iint)
4715           if (itype(j).eq.ntyp1) cycle
4716           itypj=iabs(itype(j))
4717 C Uncomment following three lines for SC-p interactions
4718 c         xj=c(1,nres+j)-xi
4719 c         yj=c(2,nres+j)-yi
4720 c         zj=c(3,nres+j)-zi
4721 C Uncomment following three lines for Ca-p interactions
4722           xj=c(1,j)
4723           yj=c(2,j)
4724           zj=c(3,j)
4725 c  174   continue
4726 c        if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
4727 c        if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
4728 C Condition for being inside the proper box
4729 c        if ((xj.gt.((0.5d0)*boxxsize)).or.
4730 c     &       (xj.lt.((-0.5d0)*boxxsize))) then
4731 c        go to 174
4732 c        endif
4733 c  175   continue
4734 c        if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
4735 c        if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
4736 cC Condition for being inside the proper box
4737 c        if ((yj.gt.((0.5d0)*boxysize)).or.
4738 c     &       (yj.lt.((-0.5d0)*boxysize))) then
4739 c        go to 175
4740 c        endif
4741 c  176   continue
4742 c        if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
4743 c        if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
4744 C Condition for being inside the proper box
4745 c        if ((zj.gt.((0.5d0)*boxzsize)).or.
4746 c     &       (zj.lt.((-0.5d0)*boxzsize))) then
4747 c        go to 176
4748           xj=mod(xj,boxxsize)
4749           if (xj.lt.0) xj=xj+boxxsize
4750           yj=mod(yj,boxysize)
4751           if (yj.lt.0) yj=yj+boxysize
4752           zj=mod(zj,boxzsize)
4753           if (zj.lt.0) zj=zj+boxzsize
4754       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
4755       xj_safe=xj
4756       yj_safe=yj
4757       zj_safe=zj
4758       subchap=0
4759       do xshift=-1,1
4760       do yshift=-1,1
4761       do zshift=-1,1
4762           xj=xj_safe+xshift*boxxsize
4763           yj=yj_safe+yshift*boxysize
4764           zj=zj_safe+zshift*boxzsize
4765           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
4766           if(dist_temp.lt.dist_init) then
4767             dist_init=dist_temp
4768             xj_temp=xj
4769             yj_temp=yj
4770             zj_temp=zj
4771             subchap=1
4772           endif
4773        enddo
4774        enddo
4775        enddo
4776        if (subchap.eq.1) then
4777           xj=xj_temp-xi
4778           yj=yj_temp-yi
4779           zj=zj_temp-zi
4780        else
4781           xj=xj_safe-xi
4782           yj=yj_safe-yi
4783           zj=zj_safe-zi
4784        endif
4785 c c       endif
4786 C          xj=xj-xi
4787 C          yj=yj-yi
4788 C          zj=zj-zi
4789           rij=xj*xj+yj*yj+zj*zj
4790
4791           r0ij=r0_scp
4792           r0ijsq=r0ij*r0ij
4793           if (rij.lt.r0ijsq) then
4794             evdwij=0.25d0*(rij-r0ijsq)**2
4795             fac=rij-r0ijsq
4796           else
4797             evdwij=0.0d0
4798             fac=0.0d0
4799           endif
4800           evdw2=evdw2+evdwij
4801 C
4802 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
4803 C
4804           ggg(1)=xj*fac
4805           ggg(2)=yj*fac
4806           ggg(3)=zj*fac
4807 cgrad          if (j.lt.i) then
4808 cd          write (iout,*) 'j<i'
4809 C Uncomment following three lines for SC-p interactions
4810 c           do k=1,3
4811 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
4812 c           enddo
4813 cgrad          else
4814 cd          write (iout,*) 'j>i'
4815 cgrad            do k=1,3
4816 cgrad              ggg(k)=-ggg(k)
4817 C Uncomment following line for SC-p interactions
4818 c             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
4819 cgrad            enddo
4820 cgrad          endif
4821 cgrad          do k=1,3
4822 cgrad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
4823 cgrad          enddo
4824 cgrad          kstart=min0(i+1,j)
4825 cgrad          kend=max0(i-1,j-1)
4826 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
4827 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
4828 cgrad          do k=kstart,kend
4829 cgrad            do l=1,3
4830 cgrad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
4831 cgrad            enddo
4832 cgrad          enddo
4833           do k=1,3
4834             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
4835             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
4836           enddo
4837         enddo
4838
4839         enddo ! iint
4840       enddo ! i
4841 C      enddo !zshift
4842 C      enddo !yshift
4843 C      enddo !xshift
4844       return
4845       end
4846 C-----------------------------------------------------------------------------
4847       subroutine escp(evdw2,evdw2_14)
4848 C
4849 C This subroutine calculates the excluded-volume interaction energy between
4850 C peptide-group centers and side chains and its gradient in virtual-bond and
4851 C side-chain vectors.
4852 C
4853       implicit real*8 (a-h,o-z)
4854       include 'DIMENSIONS'
4855       include 'COMMON.GEO'
4856       include 'COMMON.VAR'
4857       include 'COMMON.LOCAL'
4858       include 'COMMON.CHAIN'
4859       include 'COMMON.DERIV'
4860       include 'COMMON.INTERACT'
4861       include 'COMMON.FFIELD'
4862       include 'COMMON.IOUNITS'
4863       include 'COMMON.CONTROL'
4864       include 'COMMON.SPLITELE'
4865       dimension ggg(3)
4866       evdw2=0.0D0
4867       evdw2_14=0.0d0
4868 c        print *,boxxsize,boxysize,boxzsize,'wymiary pudla'
4869 cd    print '(a)','Enter ESCP'
4870 cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
4871 C      do xshift=-1,1
4872 C      do yshift=-1,1
4873 C      do zshift=-1,1
4874       do i=iatscp_s,iatscp_e
4875         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
4876         iteli=itel(i)
4877         xi=0.5D0*(c(1,i)+c(1,i+1))
4878         yi=0.5D0*(c(2,i)+c(2,i+1))
4879         zi=0.5D0*(c(3,i)+c(3,i+1))
4880           xi=mod(xi,boxxsize)
4881           if (xi.lt.0) xi=xi+boxxsize
4882           yi=mod(yi,boxysize)
4883           if (yi.lt.0) yi=yi+boxysize
4884           zi=mod(zi,boxzsize)
4885           if (zi.lt.0) zi=zi+boxzsize
4886 c          xi=xi+xshift*boxxsize
4887 c          yi=yi+yshift*boxysize
4888 c          zi=zi+zshift*boxzsize
4889 c        print *,xi,yi,zi,'polozenie i'
4890 C Return atom into box, boxxsize is size of box in x dimension
4891 c  134   continue
4892 c        if (xi.gt.((xshift+0.5d0)*boxxsize)) xi=xi-boxxsize
4893 c        if (xi.lt.((xshift-0.5d0)*boxxsize)) xi=xi+boxxsize
4894 C Condition for being inside the proper box
4895 c        if ((xi.gt.((xshift+0.5d0)*boxxsize)).or.
4896 c     &       (xi.lt.((xshift-0.5d0)*boxxsize))) then
4897 c        go to 134
4898 c        endif
4899 c  135   continue
4900 c          print *,xi,boxxsize,"pierwszy"
4901
4902 c        if (yi.gt.((yshift+0.5d0)*boxysize)) yi=yi-boxysize
4903 c        if (yi.lt.((yshift-0.5d0)*boxysize)) yi=yi+boxysize
4904 C Condition for being inside the proper box
4905 c        if ((yi.gt.((yshift+0.5d0)*boxysize)).or.
4906 c     &       (yi.lt.((yshift-0.5d0)*boxysize))) then
4907 c        go to 135
4908 c        endif
4909 c  136   continue
4910 c        if (zi.gt.((zshift+0.5d0)*boxzsize)) zi=zi-boxzsize
4911 c        if (zi.lt.((zshift-0.5d0)*boxzsize)) zi=zi+boxzsize
4912 C Condition for being inside the proper box
4913 c        if ((zi.gt.((zshift+0.5d0)*boxzsize)).or.
4914 c     &       (zi.lt.((zshift-0.5d0)*boxzsize))) then
4915 c        go to 136
4916 c        endif
4917         do iint=1,nscp_gr(i)
4918
4919         do j=iscpstart(i,iint),iscpend(i,iint)
4920           itypj=iabs(itype(j))
4921           if (itypj.eq.ntyp1) cycle
4922 C Uncomment following three lines for SC-p interactions
4923 c         xj=c(1,nres+j)-xi
4924 c         yj=c(2,nres+j)-yi
4925 c         zj=c(3,nres+j)-zi
4926 C Uncomment following three lines for Ca-p interactions
4927           xj=c(1,j)
4928           yj=c(2,j)
4929           zj=c(3,j)
4930           xj=mod(xj,boxxsize)
4931           if (xj.lt.0) xj=xj+boxxsize
4932           yj=mod(yj,boxysize)
4933           if (yj.lt.0) yj=yj+boxysize
4934           zj=mod(zj,boxzsize)
4935           if (zj.lt.0) zj=zj+boxzsize
4936 c  174   continue
4937 c        if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
4938 c        if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
4939 C Condition for being inside the proper box
4940 c        if ((xj.gt.((0.5d0)*boxxsize)).or.
4941 c     &       (xj.lt.((-0.5d0)*boxxsize))) then
4942 c        go to 174
4943 c        endif
4944 c  175   continue
4945 c        if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
4946 c        if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
4947 cC Condition for being inside the proper box
4948 c        if ((yj.gt.((0.5d0)*boxysize)).or.
4949 c     &       (yj.lt.((-0.5d0)*boxysize))) then
4950 c        go to 175
4951 c        endif
4952 c  176   continue
4953 c        if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
4954 c        if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
4955 C Condition for being inside the proper box
4956 c        if ((zj.gt.((0.5d0)*boxzsize)).or.
4957 c     &       (zj.lt.((-0.5d0)*boxzsize))) then
4958 c        go to 176
4959 c        endif
4960 CHERE IS THE CALCULATION WHICH MIRROR IMAGE IS THE CLOSEST ONE
4961       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
4962       xj_safe=xj
4963       yj_safe=yj
4964       zj_safe=zj
4965       subchap=0
4966       do xshift=-1,1
4967       do yshift=-1,1
4968       do zshift=-1,1
4969           xj=xj_safe+xshift*boxxsize
4970           yj=yj_safe+yshift*boxysize
4971           zj=zj_safe+zshift*boxzsize
4972           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
4973           if(dist_temp.lt.dist_init) then
4974             dist_init=dist_temp
4975             xj_temp=xj
4976             yj_temp=yj
4977             zj_temp=zj
4978             subchap=1
4979           endif
4980        enddo
4981        enddo
4982        enddo
4983        if (subchap.eq.1) then
4984           xj=xj_temp-xi
4985           yj=yj_temp-yi
4986           zj=zj_temp-zi
4987        else
4988           xj=xj_safe-xi
4989           yj=yj_safe-yi
4990           zj=zj_safe-zi
4991        endif
4992 c          print *,xj,yj,zj,'polozenie j'
4993           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
4994 c          print *,rrij
4995           sss=sscale(1.0d0/(dsqrt(rrij)))
4996 c          print *,r_cut,1.0d0/dsqrt(rrij),sss,'tu patrz'
4997 c          if (sss.eq.0) print *,'czasem jest OK'
4998           if (sss.le.0.0d0) cycle
4999           sssgrad=sscagrad(1.0d0/(dsqrt(rrij)))
5000           fac=rrij**expon2
5001           e1=fac*fac*aad(itypj,iteli)
5002           e2=fac*bad(itypj,iteli)
5003           if (iabs(j-i) .le. 2) then
5004             e1=scal14*e1
5005             e2=scal14*e2
5006             evdw2_14=evdw2_14+(e1+e2)*sss
5007           endif
5008           evdwij=e1+e2
5009           evdw2=evdw2+evdwij*sss
5010           if (energy_dec) write (iout,'(a6,2i5,0pf7.3,2i3,3e11.3)')
5011      &        'evdw2',i,j,evdwij,iteli,itypj,fac,aad(itypj,iteli),
5012      &       bad(itypj,iteli)
5013 C
5014 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
5015 C
5016           fac=-(evdwij+e1)*rrij*sss
5017           fac=fac+(evdwij)*sssgrad*dsqrt(rrij)/expon
5018           ggg(1)=xj*fac
5019           ggg(2)=yj*fac
5020           ggg(3)=zj*fac
5021 cgrad          if (j.lt.i) then
5022 cd          write (iout,*) 'j<i'
5023 C Uncomment following three lines for SC-p interactions
5024 c           do k=1,3
5025 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
5026 c           enddo
5027 cgrad          else
5028 cd          write (iout,*) 'j>i'
5029 cgrad            do k=1,3
5030 cgrad              ggg(k)=-ggg(k)
5031 C Uncomment following line for SC-p interactions
5032 ccgrad             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
5033 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
5034 cgrad            enddo
5035 cgrad          endif
5036 cgrad          do k=1,3
5037 cgrad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
5038 cgrad          enddo
5039 cgrad          kstart=min0(i+1,j)
5040 cgrad          kend=max0(i-1,j-1)
5041 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
5042 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
5043 cgrad          do k=kstart,kend
5044 cgrad            do l=1,3
5045 cgrad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
5046 cgrad            enddo
5047 cgrad          enddo
5048           do k=1,3
5049             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
5050             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
5051           enddo
5052 c        endif !endif for sscale cutoff
5053         enddo ! j
5054
5055         enddo ! iint
5056       enddo ! i
5057 c      enddo !zshift
5058 c      enddo !yshift
5059 c      enddo !xshift
5060       do i=1,nct
5061         do j=1,3
5062           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
5063           gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
5064           gradx_scp(j,i)=expon*gradx_scp(j,i)
5065         enddo
5066       enddo
5067 C******************************************************************************
5068 C
5069 C                              N O T E !!!
5070 C
5071 C To save time the factor EXPON has been extracted from ALL components
5072 C of GVDWC and GRADX. Remember to multiply them by this factor before further
5073 C use!
5074 C
5075 C******************************************************************************
5076       return
5077       end
5078 C--------------------------------------------------------------------------
5079       subroutine edis(ehpb)
5080 C
5081 C Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors.
5082 C
5083       implicit real*8 (a-h,o-z)
5084       include 'DIMENSIONS'
5085       include 'COMMON.SBRIDGE'
5086       include 'COMMON.CHAIN'
5087       include 'COMMON.DERIV'
5088       include 'COMMON.VAR'
5089       include 'COMMON.INTERACT'
5090       include 'COMMON.IOUNITS'
5091       dimension ggg(3)
5092       ehpb=0.0D0
5093 cd      write(iout,*)'edis: nhpb=',nhpb,' fbr=',fbr
5094 cd      write(iout,*)'link_start=',link_start,' link_end=',link_end
5095       if (link_end.eq.0) return
5096       do i=link_start,link_end
5097 C If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a
5098 C CA-CA distance used in regularization of structure.
5099         ii=ihpb(i)
5100         jj=jhpb(i)
5101 C iii and jjj point to the residues for which the distance is assigned.
5102         if (ii.gt.nres) then
5103           iii=ii-nres
5104           jjj=jj-nres
5105         else
5106           iii=ii
5107           jjj=jj
5108         endif
5109 c        write (iout,*) "i",i," ii",ii," iii",iii," jj",jj," jjj",jjj,
5110 c     &    dhpb(i),dhpb1(i),forcon(i)
5111 C 24/11/03 AL: SS bridges handled separately because of introducing a specific
5112 C    distance and angle dependent SS bond potential.
5113 C        if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and.
5114 C     & iabs(itype(jjj)).eq.1) then
5115 cmc        if (ii.gt.nres .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then
5116 C 18/07/06 MC: Use the convention that the first nss pairs are SS bonds
5117         if (.not.dyn_ss .and. i.le.nss) then
5118 C 15/02/13 CC dynamic SSbond - additional check
5119          if (ii.gt.nres
5120      &       .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then
5121           call ssbond_ene(iii,jjj,eij)
5122           ehpb=ehpb+2*eij
5123          endif
5124 cd          write (iout,*) "eij",eij
5125         else
5126 C Calculate the distance between the two points and its difference from the
5127 C target distance.
5128           dd=dist(ii,jj)
5129             rdis=dd-dhpb(i)
5130 C Get the force constant corresponding to this distance.
5131             waga=forcon(i)
5132 C Calculate the contribution to energy.
5133             ehpb=ehpb+waga*rdis*rdis
5134 C
5135 C Evaluate gradient.
5136 C
5137             fac=waga*rdis/dd
5138 cd      print *,'i=',i,' ii=',ii,' jj=',jj,' dhpb=',dhpb(i),' dd=',dd,
5139 cd   &   ' waga=',waga,' fac=',fac
5140             do j=1,3
5141               ggg(j)=fac*(c(j,jj)-c(j,ii))
5142             enddo
5143 cd      print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
5144 C If this is a SC-SC distance, we need to calculate the contributions to the
5145 C Cartesian gradient in the SC vectors (ghpbx).
5146           if (iii.lt.ii) then
5147           do j=1,3
5148             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
5149             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
5150           enddo
5151           endif
5152 cgrad        do j=iii,jjj-1
5153 cgrad          do k=1,3
5154 cgrad            ghpbc(k,j)=ghpbc(k,j)+ggg(k)
5155 cgrad          enddo
5156 cgrad        enddo
5157           do k=1,3
5158             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
5159             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
5160           enddo
5161         endif
5162       enddo
5163       ehpb=0.5D0*ehpb
5164       return
5165       end
5166 C--------------------------------------------------------------------------
5167       subroutine ssbond_ene(i,j,eij)
5168 C
5169 C Calculate the distance and angle dependent SS-bond potential energy
5170 C using a free-energy function derived based on RHF/6-31G** ab initio
5171 C calculations of diethyl disulfide.
5172 C
5173 C A. Liwo and U. Kozlowska, 11/24/03
5174 C
5175       implicit real*8 (a-h,o-z)
5176       include 'DIMENSIONS'
5177       include 'COMMON.SBRIDGE'
5178       include 'COMMON.CHAIN'
5179       include 'COMMON.DERIV'
5180       include 'COMMON.LOCAL'
5181       include 'COMMON.INTERACT'
5182       include 'COMMON.VAR'
5183       include 'COMMON.IOUNITS'
5184       double precision erij(3),dcosom1(3),dcosom2(3),gg(3)
5185       itypi=iabs(itype(i))
5186       xi=c(1,nres+i)
5187       yi=c(2,nres+i)
5188       zi=c(3,nres+i)
5189       dxi=dc_norm(1,nres+i)
5190       dyi=dc_norm(2,nres+i)
5191       dzi=dc_norm(3,nres+i)
5192 c      dsci_inv=dsc_inv(itypi)
5193       dsci_inv=vbld_inv(nres+i)
5194       itypj=iabs(itype(j))
5195 c      dscj_inv=dsc_inv(itypj)
5196       dscj_inv=vbld_inv(nres+j)
5197       xj=c(1,nres+j)-xi
5198       yj=c(2,nres+j)-yi
5199       zj=c(3,nres+j)-zi
5200       dxj=dc_norm(1,nres+j)
5201       dyj=dc_norm(2,nres+j)
5202       dzj=dc_norm(3,nres+j)
5203       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
5204       rij=dsqrt(rrij)
5205       erij(1)=xj*rij
5206       erij(2)=yj*rij
5207       erij(3)=zj*rij
5208       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
5209       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
5210       om12=dxi*dxj+dyi*dyj+dzi*dzj
5211       do k=1,3
5212         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
5213         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
5214       enddo
5215       rij=1.0d0/rij
5216       deltad=rij-d0cm
5217       deltat1=1.0d0-om1
5218       deltat2=1.0d0+om2
5219       deltat12=om2-om1+2.0d0
5220       cosphi=om12-om1*om2
5221       eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2)
5222      &  +akct*deltad*deltat12
5223      &  +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi+ebr
5224 c      write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth,
5225 c     &  " akct",akct," deltad",deltad," deltat",deltat1,deltat2,
5226 c     &  " deltat12",deltat12," eij",eij
5227       ed=2*akcm*deltad+akct*deltat12
5228       pom1=akct*deltad
5229       pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
5230       eom1=-2*akth*deltat1-pom1-om2*pom2
5231       eom2= 2*akth*deltat2+pom1-om1*pom2
5232       eom12=pom2
5233       do k=1,3
5234         ggk=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
5235         ghpbx(k,i)=ghpbx(k,i)-ggk
5236      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
5237      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
5238         ghpbx(k,j)=ghpbx(k,j)+ggk
5239      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
5240      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
5241         ghpbc(k,i)=ghpbc(k,i)-ggk
5242         ghpbc(k,j)=ghpbc(k,j)+ggk
5243       enddo
5244 C
5245 C Calculate the components of the gradient in DC and X
5246 C
5247 cgrad      do k=i,j-1
5248 cgrad        do l=1,3
5249 cgrad          ghpbc(l,k)=ghpbc(l,k)+gg(l)
5250 cgrad        enddo
5251 cgrad      enddo
5252       return
5253       end
5254 C--------------------------------------------------------------------------
5255       subroutine ebond(estr)
5256 c
5257 c Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
5258 c
5259       implicit real*8 (a-h,o-z)
5260       include 'DIMENSIONS'
5261       include 'COMMON.LOCAL'
5262       include 'COMMON.GEO'
5263       include 'COMMON.INTERACT'
5264       include 'COMMON.DERIV'
5265       include 'COMMON.VAR'
5266       include 'COMMON.CHAIN'
5267       include 'COMMON.IOUNITS'
5268       include 'COMMON.NAMES'
5269       include 'COMMON.FFIELD'
5270       include 'COMMON.CONTROL'
5271       include 'COMMON.SETUP'
5272       double precision u(3),ud(3)
5273       estr=0.0d0
5274       estr1=0.0d0
5275       do i=ibondp_start,ibondp_end
5276         if (itype(i-1).eq.ntyp1 .and. itype(i).eq.ntyp1) cycle
5277 c          estr1=estr1+gnmr1(vbld(i),-1.0d0,distchainmax)
5278 c          do j=1,3
5279 c          gradb(j,i-1)=gnmr1prim(vbld(i),-1.0d0,distchainmax)
5280 c     &      *dc(j,i-1)/vbld(i)
5281 c          enddo
5282 c          if (energy_dec) write(iout,*)
5283 c     &       "estr1",i,gnmr1(vbld(i),-1.0d0,distchainmax)
5284 c        else
5285 C       Checking if it involves dummy (NH3+ or COO-) group
5286          if (itype(i-1).eq.ntyp1 .or. itype(i).eq.ntyp1) then
5287 C YES   vbldpDUM is the equlibrium length of spring for Dummy atom
5288         diff = vbld(i)-vbldpDUM
5289          else
5290 C NO    vbldp0 is the equlibrium lenght of spring for peptide group
5291         diff = vbld(i)-vbldp0
5292          endif
5293         if (energy_dec)    write (iout,'(a7,i5,4f7.3)')
5294      &     "estr bb",i,vbld(i),vbldp0,diff,AKP*diff*diff
5295         estr=estr+diff*diff
5296         do j=1,3
5297           gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)
5298         enddo
5299 c        write (iout,'(i5,3f10.5)') i,(gradb(j,i-1),j=1,3)
5300 c        endif
5301       enddo
5302       estr=0.5d0*AKP*estr+estr1
5303 c
5304 c 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included
5305 c
5306       do i=ibond_start,ibond_end
5307         iti=iabs(itype(i))
5308         if (iti.ne.10 .and. iti.ne.ntyp1) then
5309           nbi=nbondterm(iti)
5310           if (nbi.eq.1) then
5311             diff=vbld(i+nres)-vbldsc0(1,iti)
5312             if (energy_dec)  write (iout,*)
5313      &      "estr sc",i,iti,vbld(i+nres),vbldsc0(1,iti),diff,
5314      &      AKSC(1,iti),AKSC(1,iti)*diff*diff
5315             estr=estr+0.5d0*AKSC(1,iti)*diff*diff
5316             do j=1,3
5317               gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
5318             enddo
5319           else
5320             do j=1,nbi
5321               diff=vbld(i+nres)-vbldsc0(j,iti)
5322               ud(j)=aksc(j,iti)*diff
5323               u(j)=abond0(j,iti)+0.5d0*ud(j)*diff
5324             enddo
5325             uprod=u(1)
5326             do j=2,nbi
5327               uprod=uprod*u(j)
5328             enddo
5329             usum=0.0d0
5330             usumsqder=0.0d0
5331             do j=1,nbi
5332               uprod1=1.0d0
5333               uprod2=1.0d0
5334               do k=1,nbi
5335                 if (k.ne.j) then
5336                   uprod1=uprod1*u(k)
5337                   uprod2=uprod2*u(k)*u(k)
5338                 endif
5339               enddo
5340               usum=usum+uprod1
5341               usumsqder=usumsqder+ud(j)*uprod2
5342             enddo
5343             estr=estr+uprod/usum
5344             do j=1,3
5345              gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
5346             enddo
5347           endif
5348         endif
5349       enddo
5350       return
5351       end
5352 #ifdef CRYST_THETA
5353 C--------------------------------------------------------------------------
5354       subroutine ebend(etheta)
5355 C
5356 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
5357 C angles gamma and its derivatives in consecutive thetas and gammas.
5358 C
5359       implicit real*8 (a-h,o-z)
5360       include 'DIMENSIONS'
5361       include 'COMMON.LOCAL'
5362       include 'COMMON.GEO'
5363       include 'COMMON.INTERACT'
5364       include 'COMMON.DERIV'
5365       include 'COMMON.VAR'
5366       include 'COMMON.CHAIN'
5367       include 'COMMON.IOUNITS'
5368       include 'COMMON.NAMES'
5369       include 'COMMON.FFIELD'
5370       include 'COMMON.CONTROL'
5371       common /calcthet/ term1,term2,termm,diffak,ratak,
5372      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
5373      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
5374       double precision y(2),z(2)
5375       delta=0.02d0*pi
5376 c      time11=dexp(-2*time)
5377 c      time12=1.0d0
5378       etheta=0.0D0
5379 c     write (*,'(a,i2)') 'EBEND ICG=',icg
5380       do i=ithet_start,ithet_end
5381         if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
5382      &  .or.itype(i).eq.ntyp1) cycle
5383 C Zero the energy function and its derivative at 0 or pi.
5384         call splinthet(theta(i),0.5d0*delta,ss,ssd)
5385         it=itype(i-1)
5386         ichir1=isign(1,itype(i-2))
5387         ichir2=isign(1,itype(i))
5388          if (itype(i-2).eq.10) ichir1=isign(1,itype(i-1))
5389          if (itype(i).eq.10) ichir2=isign(1,itype(i-1))
5390          if (itype(i-1).eq.10) then
5391           itype1=isign(10,itype(i-2))
5392           ichir11=isign(1,itype(i-2))
5393           ichir12=isign(1,itype(i-2))
5394           itype2=isign(10,itype(i))
5395           ichir21=isign(1,itype(i))
5396           ichir22=isign(1,itype(i))
5397          endif
5398
5399         if (i.gt.3 .and. itype(i-3).ne.ntyp1) then
5400 #ifdef OSF
5401           phii=phi(i)
5402           if (phii.ne.phii) phii=150.0
5403 #else
5404           phii=phi(i)
5405 #endif
5406           y(1)=dcos(phii)
5407           y(2)=dsin(phii)
5408         else
5409           y(1)=0.0D0
5410           y(2)=0.0D0
5411         endif
5412         if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
5413 #ifdef OSF
5414           phii1=phi(i+1)
5415           if (phii1.ne.phii1) phii1=150.0
5416           phii1=pinorm(phii1)
5417           z(1)=cos(phii1)
5418 #else
5419           phii1=phi(i+1)
5420 #endif
5421           z(1)=dcos(phii1)
5422           z(2)=dsin(phii1)
5423         else
5424           z(1)=0.0D0
5425           z(2)=0.0D0
5426         endif
5427 C Calculate the "mean" value of theta from the part of the distribution
5428 C dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2).
5429 C In following comments this theta will be referred to as t_c.
5430         thet_pred_mean=0.0d0
5431         do k=1,2
5432             athetk=athet(k,it,ichir1,ichir2)
5433             bthetk=bthet(k,it,ichir1,ichir2)
5434           if (it.eq.10) then
5435              athetk=athet(k,itype1,ichir11,ichir12)
5436              bthetk=bthet(k,itype2,ichir21,ichir22)
5437           endif
5438          thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k)
5439 c         write(iout,*) 'chuj tu', y(k),z(k)
5440         enddo
5441         dthett=thet_pred_mean*ssd
5442         thet_pred_mean=thet_pred_mean*ss+a0thet(it)
5443 C Derivatives of the "mean" values in gamma1 and gamma2.
5444         dthetg1=(-athet(1,it,ichir1,ichir2)*y(2)
5445      &+athet(2,it,ichir1,ichir2)*y(1))*ss
5446          dthetg2=(-bthet(1,it,ichir1,ichir2)*z(2)
5447      &          +bthet(2,it,ichir1,ichir2)*z(1))*ss
5448          if (it.eq.10) then
5449       dthetg1=(-athet(1,itype1,ichir11,ichir12)*y(2)
5450      &+athet(2,itype1,ichir11,ichir12)*y(1))*ss
5451         dthetg2=(-bthet(1,itype2,ichir21,ichir22)*z(2)
5452      &         +bthet(2,itype2,ichir21,ichir22)*z(1))*ss
5453          endif
5454         if (theta(i).gt.pi-delta) then
5455           call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,
5456      &         E_tc0)
5457           call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0)
5458           call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
5459           call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,
5460      &        E_theta)
5461           call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,
5462      &        E_tc)
5463         else if (theta(i).lt.delta) then
5464           call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0)
5465           call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
5466           call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,
5467      &        E_theta)
5468           call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0)
5469           call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,
5470      &        E_tc)
5471         else
5472           call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,
5473      &        E_theta,E_tc)
5474         endif
5475         etheta=etheta+ethetai
5476         if (energy_dec) write (iout,'(a6,i5,0pf7.3,f7.3,i5)')
5477      &      'ebend',i,ethetai,theta(i),itype(i)
5478         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1
5479         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2
5480         gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)+gloc(nphi+i-2,icg)
5481       enddo
5482 C Ufff.... We've done all this!!!
5483       return
5484       end
5485 C---------------------------------------------------------------------------
5486       subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,
5487      &     E_tc)
5488       implicit real*8 (a-h,o-z)
5489       include 'DIMENSIONS'
5490       include 'COMMON.LOCAL'
5491       include 'COMMON.IOUNITS'
5492       common /calcthet/ term1,term2,termm,diffak,ratak,
5493      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
5494      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
5495 C Calculate the contributions to both Gaussian lobes.
5496 C 6/6/97 - Deform the Gaussians using the factor of 1/(1+time)
5497 C The "polynomial part" of the "standard deviation" of this part of
5498 C the distributioni.
5499 ccc        write (iout,*) thetai,thet_pred_mean
5500         sig=polthet(3,it)
5501         do j=2,0,-1
5502           sig=sig*thet_pred_mean+polthet(j,it)
5503         enddo
5504 C Derivative of the "interior part" of the "standard deviation of the"
5505 C gamma-dependent Gaussian lobe in t_c.
5506         sigtc=3*polthet(3,it)
5507         do j=2,1,-1
5508           sigtc=sigtc*thet_pred_mean+j*polthet(j,it)
5509         enddo
5510         sigtc=sig*sigtc
5511 C Set the parameters of both Gaussian lobes of the distribution.
5512 C "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc)
5513         fac=sig*sig+sigc0(it)
5514         sigcsq=fac+fac
5515         sigc=1.0D0/sigcsq
5516 C Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c
5517         sigsqtc=-4.0D0*sigcsq*sigtc
5518 c       print *,i,sig,sigtc,sigsqtc
5519 C Following variable (sigtc) is d[sigma(t_c)]/dt_c
5520         sigtc=-sigtc/(fac*fac)
5521 C Following variable is sigma(t_c)**(-2)
5522         sigcsq=sigcsq*sigcsq
5523         sig0i=sig0(it)
5524         sig0inv=1.0D0/sig0i**2
5525         delthec=thetai-thet_pred_mean
5526         delthe0=thetai-theta0i
5527         term1=-0.5D0*sigcsq*delthec*delthec
5528         term2=-0.5D0*sig0inv*delthe0*delthe0
5529 C        write (iout,*)'term1',term1,term2,sigcsq,delthec,sig0inv,delthe0
5530 C Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and
5531 C NaNs in taking the logarithm. We extract the largest exponent which is added
5532 C to the energy (this being the log of the distribution) at the end of energy
5533 C term evaluation for this virtual-bond angle.
5534         if (term1.gt.term2) then
5535           termm=term1
5536           term2=dexp(term2-termm)
5537           term1=1.0d0
5538         else
5539           termm=term2
5540           term1=dexp(term1-termm)
5541           term2=1.0d0
5542         endif
5543 C The ratio between the gamma-independent and gamma-dependent lobes of
5544 C the distribution is a Gaussian function of thet_pred_mean too.
5545         diffak=gthet(2,it)-thet_pred_mean
5546         ratak=diffak/gthet(3,it)**2
5547         ak=dexp(gthet(1,it)-0.5D0*diffak*ratak)
5548 C Let's differentiate it in thet_pred_mean NOW.
5549         aktc=ak*ratak
5550 C Now put together the distribution terms to make complete distribution.
5551         termexp=term1+ak*term2
5552         termpre=sigc+ak*sig0i
5553 C Contribution of the bending energy from this theta is just the -log of
5554 C the sum of the contributions from the two lobes and the pre-exponential
5555 C factor. Simple enough, isn't it?
5556         ethetai=(-dlog(termexp)-termm+dlog(termpre))
5557 C       write (iout,*) 'termexp',termexp,termm,termpre,i
5558 C NOW the derivatives!!!
5559 C 6/6/97 Take into account the deformation.
5560         E_theta=(delthec*sigcsq*term1
5561      &       +ak*delthe0*sig0inv*term2)/termexp
5562         E_tc=((sigtc+aktc*sig0i)/termpre
5563      &      -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+
5564      &       aktc*term2)/termexp)
5565       return
5566       end
5567 c-----------------------------------------------------------------------------
5568       subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)
5569       implicit real*8 (a-h,o-z)
5570       include 'DIMENSIONS'
5571       include 'COMMON.LOCAL'
5572       include 'COMMON.IOUNITS'
5573       common /calcthet/ term1,term2,termm,diffak,ratak,
5574      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
5575      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
5576       delthec=thetai-thet_pred_mean
5577       delthe0=thetai-theta0i
5578 C "Thank you" to MAPLE (probably spared one day of hand-differentiation).
5579       t3 = thetai-thet_pred_mean
5580       t6 = t3**2
5581       t9 = term1
5582       t12 = t3*sigcsq
5583       t14 = t12+t6*sigsqtc
5584       t16 = 1.0d0
5585       t21 = thetai-theta0i
5586       t23 = t21**2
5587       t26 = term2
5588       t27 = t21*t26
5589       t32 = termexp
5590       t40 = t32**2
5591       E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9
5592      & -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40
5593      & *(-t12*t9-ak*sig0inv*t27)
5594       return
5595       end
5596 #else
5597 C--------------------------------------------------------------------------
5598       subroutine ebend(etheta)
5599 C
5600 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
5601 C angles gamma and its derivatives in consecutive thetas and gammas.
5602 C ab initio-derived potentials from
5603 c Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203
5604 C
5605       implicit real*8 (a-h,o-z)
5606       include 'DIMENSIONS'
5607       include 'COMMON.LOCAL'
5608       include 'COMMON.GEO'
5609       include 'COMMON.INTERACT'
5610       include 'COMMON.DERIV'
5611       include 'COMMON.VAR'
5612       include 'COMMON.CHAIN'
5613       include 'COMMON.IOUNITS'
5614       include 'COMMON.NAMES'
5615       include 'COMMON.FFIELD'
5616       include 'COMMON.CONTROL'
5617       double precision coskt(mmaxtheterm),sinkt(mmaxtheterm),
5618      & cosph1(maxsingle),sinph1(maxsingle),cosph2(maxsingle),
5619      & sinph2(maxsingle),cosph1ph2(maxdouble,maxdouble),
5620      & sinph1ph2(maxdouble,maxdouble)
5621       logical lprn /.false./, lprn1 /.false./
5622       etheta=0.0D0
5623       do i=ithet_start,ithet_end
5624 c        print *,i,itype(i-1),itype(i),itype(i-2)
5625         if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
5626      &  .or.itype(i).eq.ntyp1) cycle
5627 C In current verion the ALL DUMMY ATOM POTENTIALS ARE OFF
5628
5629         if (iabs(itype(i+1)).eq.20) iblock=2
5630         if (iabs(itype(i+1)).ne.20) iblock=1
5631         dethetai=0.0d0
5632         dephii=0.0d0
5633         dephii1=0.0d0
5634         theti2=0.5d0*theta(i)
5635         ityp2=ithetyp((itype(i-1)))
5636         do k=1,nntheterm
5637           coskt(k)=dcos(k*theti2)
5638           sinkt(k)=dsin(k*theti2)
5639         enddo
5640         if (i.gt.3 .and. itype(i-3).ne.ntyp1) then
5641 #ifdef OSF
5642           phii=phi(i)
5643           if (phii.ne.phii) phii=150.0
5644 #else
5645           phii=phi(i)
5646 #endif
5647           ityp1=ithetyp((itype(i-2)))
5648 C propagation of chirality for glycine type
5649           do k=1,nsingle
5650             cosph1(k)=dcos(k*phii)
5651             sinph1(k)=dsin(k*phii)
5652           enddo
5653         else
5654           phii=0.0d0
5655           ityp1=nthetyp+1
5656           do k=1,nsingle
5657             cosph1(k)=0.0d0
5658             sinph1(k)=0.0d0
5659           enddo
5660         endif
5661         if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
5662 #ifdef OSF
5663           phii1=phi(i+1)
5664           if (phii1.ne.phii1) phii1=150.0
5665           phii1=pinorm(phii1)
5666 #else
5667           phii1=phi(i+1)
5668 #endif
5669           ityp3=ithetyp((itype(i)))
5670           do k=1,nsingle
5671             cosph2(k)=dcos(k*phii1)
5672             sinph2(k)=dsin(k*phii1)
5673           enddo
5674         else
5675           phii1=0.0d0
5676           ityp3=nthetyp+1
5677           do k=1,nsingle
5678             cosph2(k)=0.0d0
5679             sinph2(k)=0.0d0
5680           enddo
5681         endif
5682         ethetai=aa0thet(ityp1,ityp2,ityp3,iblock)
5683         do k=1,ndouble
5684           do l=1,k-1
5685             ccl=cosph1(l)*cosph2(k-l)
5686             ssl=sinph1(l)*sinph2(k-l)
5687             scl=sinph1(l)*cosph2(k-l)
5688             csl=cosph1(l)*sinph2(k-l)
5689             cosph1ph2(l,k)=ccl-ssl
5690             cosph1ph2(k,l)=ccl+ssl
5691             sinph1ph2(l,k)=scl+csl
5692             sinph1ph2(k,l)=scl-csl
5693           enddo
5694         enddo
5695         if (lprn) then
5696         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,
5697      &    " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
5698         write (iout,*) "coskt and sinkt"
5699         do k=1,nntheterm
5700           write (iout,*) k,coskt(k),sinkt(k)
5701         enddo
5702         endif
5703         do k=1,ntheterm
5704           ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3,iblock)*sinkt(k)
5705           dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3,iblock)
5706      &      *coskt(k)
5707           if (lprn)
5708      &    write (iout,*) "k",k,"
5709      &     aathet",aathet(k,ityp1,ityp2,ityp3,iblock),
5710      &     " ethetai",ethetai
5711         enddo
5712         if (lprn) then
5713         write (iout,*) "cosph and sinph"
5714         do k=1,nsingle
5715           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
5716         enddo
5717         write (iout,*) "cosph1ph2 and sinph2ph2"
5718         do k=2,ndouble
5719           do l=1,k-1
5720             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),
5721      &         sinph1ph2(l,k),sinph1ph2(k,l)
5722           enddo
5723         enddo
5724         write(iout,*) "ethetai",ethetai
5725         endif
5726         do m=1,ntheterm2
5727           do k=1,nsingle
5728             aux=bbthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)
5729      &         +ccthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k)
5730      &         +ddthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)
5731      &         +eethet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k)
5732             ethetai=ethetai+sinkt(m)*aux
5733             dethetai=dethetai+0.5d0*m*aux*coskt(m)
5734             dephii=dephii+k*sinkt(m)*(
5735      &          ccthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)-
5736      &          bbthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k))
5737             dephii1=dephii1+k*sinkt(m)*(
5738      &          eethet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)-
5739      &          ddthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k))
5740             if (lprn)
5741      &      write (iout,*) "m",m," k",k," bbthet",
5742      &         bbthet(k,m,ityp1,ityp2,ityp3,iblock)," ccthet",
5743      &         ccthet(k,m,ityp1,ityp2,ityp3,iblock)," ddthet",
5744      &         ddthet(k,m,ityp1,ityp2,ityp3,iblock)," eethet",
5745      &         eethet(k,m,ityp1,ityp2,ityp3,iblock)," ethetai",ethetai
5746           enddo
5747         enddo
5748         if (lprn)
5749      &  write(iout,*) "ethetai",ethetai
5750         do m=1,ntheterm3
5751           do k=2,ndouble
5752             do l=1,k-1
5753               aux=ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
5754      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l)+
5755      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
5756      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)
5757               ethetai=ethetai+sinkt(m)*aux
5758               dethetai=dethetai+0.5d0*m*coskt(m)*aux
5759               dephii=dephii+l*sinkt(m)*(
5760      &           -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)-
5761      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
5762      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
5763      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
5764               dephii1=dephii1+(k-l)*sinkt(m)*(
5765      &           -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
5766      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
5767      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)-
5768      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
5769               if (lprn) then
5770               write (iout,*) "m",m," k",k," l",l," ffthet",
5771      &            ffthet(l,k,m,ityp1,ityp2,ityp3,iblock),
5772      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)," ggthet",
5773      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock),
5774      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock),
5775      &            " ethetai",ethetai
5776               write (iout,*) cosph1ph2(l,k)*sinkt(m),
5777      &            cosph1ph2(k,l)*sinkt(m),
5778      &            sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
5779               endif
5780             enddo
5781           enddo
5782         enddo
5783 10      continue
5784 c        lprn1=.true.
5785         if (lprn1)
5786      &    write (iout,'(i2,3f8.1,9h ethetai ,f10.5)')
5787      &   i,theta(i)*rad2deg,phii*rad2deg,
5788      &   phii1*rad2deg,ethetai
5789 c        lprn1=.false.
5790         etheta=etheta+ethetai
5791         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
5792         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
5793         gloc(nphi+i-2,icg)=wang*dethetai+gloc(nphi+i-2,icg)
5794       enddo
5795       return
5796       end
5797 #endif
5798 #ifdef CRYST_SC
5799 c-----------------------------------------------------------------------------
5800       subroutine esc(escloc)
5801 C Calculate the local energy of a side chain and its derivatives in the
5802 C corresponding virtual-bond valence angles THETA and the spherical angles
5803 C ALPHA and OMEGA.
5804       implicit real*8 (a-h,o-z)
5805       include 'DIMENSIONS'
5806       include 'COMMON.GEO'
5807       include 'COMMON.LOCAL'
5808       include 'COMMON.VAR'
5809       include 'COMMON.INTERACT'
5810       include 'COMMON.DERIV'
5811       include 'COMMON.CHAIN'
5812       include 'COMMON.IOUNITS'
5813       include 'COMMON.NAMES'
5814       include 'COMMON.FFIELD'
5815       include 'COMMON.CONTROL'
5816       double precision x(3),dersc(3),xemp(3),dersc0(3),dersc1(3),
5817      &     ddersc0(3),ddummy(3),xtemp(3),temp(3)
5818       common /sccalc/ time11,time12,time112,theti,it,nlobit
5819       delta=0.02d0*pi
5820       escloc=0.0D0
5821 c     write (iout,'(a)') 'ESC'
5822       do i=loc_start,loc_end
5823         it=itype(i)
5824         if (it.eq.ntyp1) cycle
5825         if (it.eq.10) goto 1
5826         nlobit=nlob(iabs(it))
5827 c       print *,'i=',i,' it=',it,' nlobit=',nlobit
5828 c       write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
5829         theti=theta(i+1)-pipol
5830         x(1)=dtan(theti)
5831         x(2)=alph(i)
5832         x(3)=omeg(i)
5833
5834         if (x(2).gt.pi-delta) then
5835           xtemp(1)=x(1)
5836           xtemp(2)=pi-delta
5837           xtemp(3)=x(3)
5838           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
5839           xtemp(2)=pi
5840           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
5841           call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),
5842      &        escloci,dersc(2))
5843           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
5844      &        ddersc0(1),dersc(1))
5845           call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),
5846      &        ddersc0(3),dersc(3))
5847           xtemp(2)=pi-delta
5848           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
5849           xtemp(2)=pi
5850           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
5851           call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,
5852      &            dersc0(2),esclocbi,dersc02)
5853           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
5854      &            dersc12,dersc01)
5855           call splinthet(x(2),0.5d0*delta,ss,ssd)
5856           dersc0(1)=dersc01
5857           dersc0(2)=dersc02
5858           dersc0(3)=0.0d0
5859           do k=1,3
5860             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
5861           enddo
5862           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
5863 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
5864 c    &             esclocbi,ss,ssd
5865           escloci=ss*escloci+(1.0d0-ss)*esclocbi
5866 c         escloci=esclocbi
5867 c         write (iout,*) escloci
5868         else if (x(2).lt.delta) then
5869           xtemp(1)=x(1)
5870           xtemp(2)=delta
5871           xtemp(3)=x(3)
5872           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
5873           xtemp(2)=0.0d0
5874           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
5875           call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),
5876      &        escloci,dersc(2))
5877           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
5878      &        ddersc0(1),dersc(1))
5879           call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),
5880      &        ddersc0(3),dersc(3))
5881           xtemp(2)=delta
5882           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
5883           xtemp(2)=0.0d0
5884           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
5885           call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,
5886      &            dersc0(2),esclocbi,dersc02)
5887           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
5888      &            dersc12,dersc01)
5889           dersc0(1)=dersc01
5890           dersc0(2)=dersc02
5891           dersc0(3)=0.0d0
5892           call splinthet(x(2),0.5d0*delta,ss,ssd)
5893           do k=1,3
5894             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
5895           enddo
5896           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
5897 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
5898 c    &             esclocbi,ss,ssd
5899           escloci=ss*escloci+(1.0d0-ss)*esclocbi
5900 c         write (iout,*) escloci
5901         else
5902           call enesc(x,escloci,dersc,ddummy,.false.)
5903         endif
5904
5905         escloc=escloc+escloci
5906         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
5907      &     'escloc',i,escloci
5908 c       write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
5909
5910         gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
5911      &   wscloc*dersc(1)
5912         gloc(ialph(i,1),icg)=wscloc*dersc(2)
5913         gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
5914     1   continue
5915       enddo
5916       return
5917       end
5918 C---------------------------------------------------------------------------
5919       subroutine enesc(x,escloci,dersc,ddersc,mixed)
5920       implicit real*8 (a-h,o-z)
5921       include 'DIMENSIONS'
5922       include 'COMMON.GEO'
5923       include 'COMMON.LOCAL'
5924       include 'COMMON.IOUNITS'
5925       common /sccalc/ time11,time12,time112,theti,it,nlobit
5926       double precision x(3),z(3),Ax(3,maxlob,-1:1),dersc(3),ddersc(3)
5927       double precision contr(maxlob,-1:1)
5928       logical mixed
5929 c       write (iout,*) 'it=',it,' nlobit=',nlobit
5930         escloc_i=0.0D0
5931         do j=1,3
5932           dersc(j)=0.0D0
5933           if (mixed) ddersc(j)=0.0d0
5934         enddo
5935         x3=x(3)
5936
5937 C Because of periodicity of the dependence of the SC energy in omega we have
5938 C to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
5939 C To avoid underflows, first compute & store the exponents.
5940
5941         do iii=-1,1
5942
5943           x(3)=x3+iii*dwapi
5944
5945           do j=1,nlobit
5946             do k=1,3
5947               z(k)=x(k)-censc(k,j,it)
5948             enddo
5949             do k=1,3
5950               Axk=0.0D0
5951               do l=1,3
5952                 Axk=Axk+gaussc(l,k,j,it)*z(l)
5953               enddo
5954               Ax(k,j,iii)=Axk
5955             enddo
5956             expfac=0.0D0
5957             do k=1,3
5958               expfac=expfac+Ax(k,j,iii)*z(k)
5959             enddo
5960             contr(j,iii)=expfac
5961           enddo ! j
5962
5963         enddo ! iii
5964
5965         x(3)=x3
5966 C As in the case of ebend, we want to avoid underflows in exponentiation and
5967 C subsequent NaNs and INFs in energy calculation.
5968 C Find the largest exponent
5969         emin=contr(1,-1)
5970         do iii=-1,1
5971           do j=1,nlobit
5972             if (emin.gt.contr(j,iii)) emin=contr(j,iii)
5973           enddo
5974         enddo
5975         emin=0.5D0*emin
5976 cd      print *,'it=',it,' emin=',emin
5977
5978 C Compute the contribution to SC energy and derivatives
5979         do iii=-1,1
5980
5981           do j=1,nlobit
5982 #ifdef OSF
5983             adexp=bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin
5984             if(adexp.ne.adexp) adexp=1.0
5985             expfac=dexp(adexp)
5986 #else
5987             expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin)
5988 #endif
5989 cd          print *,'j=',j,' expfac=',expfac
5990             escloc_i=escloc_i+expfac
5991             do k=1,3
5992               dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
5993             enddo
5994             if (mixed) then
5995               do k=1,3,2
5996                 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii)
5997      &            +gaussc(k,2,j,it))*expfac
5998               enddo
5999             endif
6000           enddo
6001
6002         enddo ! iii
6003
6004         dersc(1)=dersc(1)/cos(theti)**2
6005         ddersc(1)=ddersc(1)/cos(theti)**2
6006         ddersc(3)=ddersc(3)
6007
6008         escloci=-(dlog(escloc_i)-emin)
6009         do j=1,3
6010           dersc(j)=dersc(j)/escloc_i
6011         enddo
6012         if (mixed) then
6013           do j=1,3,2
6014             ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
6015           enddo
6016         endif
6017       return
6018       end
6019 C------------------------------------------------------------------------------
6020       subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
6021       implicit real*8 (a-h,o-z)
6022       include 'DIMENSIONS'
6023       include 'COMMON.GEO'
6024       include 'COMMON.LOCAL'
6025       include 'COMMON.IOUNITS'
6026       common /sccalc/ time11,time12,time112,theti,it,nlobit
6027       double precision x(3),z(3),Ax(3,maxlob),dersc(3)
6028       double precision contr(maxlob)
6029       logical mixed
6030
6031       escloc_i=0.0D0
6032
6033       do j=1,3
6034         dersc(j)=0.0D0
6035       enddo
6036
6037       do j=1,nlobit
6038         do k=1,2
6039           z(k)=x(k)-censc(k,j,it)
6040         enddo
6041         z(3)=dwapi
6042         do k=1,3
6043           Axk=0.0D0
6044           do l=1,3
6045             Axk=Axk+gaussc(l,k,j,it)*z(l)
6046           enddo
6047           Ax(k,j)=Axk
6048         enddo
6049         expfac=0.0D0
6050         do k=1,3
6051           expfac=expfac+Ax(k,j)*z(k)
6052         enddo
6053         contr(j)=expfac
6054       enddo ! j
6055
6056 C As in the case of ebend, we want to avoid underflows in exponentiation and
6057 C subsequent NaNs and INFs in energy calculation.
6058 C Find the largest exponent
6059       emin=contr(1)
6060       do j=1,nlobit
6061         if (emin.gt.contr(j)) emin=contr(j)
6062       enddo
6063       emin=0.5D0*emin
6064
6065 C Compute the contribution to SC energy and derivatives
6066
6067       dersc12=0.0d0
6068       do j=1,nlobit
6069         expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j)+emin)
6070         escloc_i=escloc_i+expfac
6071         do k=1,2
6072           dersc(k)=dersc(k)+Ax(k,j)*expfac
6073         enddo
6074         if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j)
6075      &            +gaussc(1,2,j,it))*expfac
6076         dersc(3)=0.0d0
6077       enddo
6078
6079       dersc(1)=dersc(1)/cos(theti)**2
6080       dersc12=dersc12/cos(theti)**2
6081       escloci=-(dlog(escloc_i)-emin)
6082       do j=1,2
6083         dersc(j)=dersc(j)/escloc_i
6084       enddo
6085       if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
6086       return
6087       end
6088 #else
6089 c----------------------------------------------------------------------------------
6090       subroutine esc(escloc)
6091 C Calculate the local energy of a side chain and its derivatives in the
6092 C corresponding virtual-bond valence angles THETA and the spherical angles
6093 C ALPHA and OMEGA derived from AM1 all-atom calculations.
6094 C added by Urszula Kozlowska. 07/11/2007
6095 C
6096       implicit real*8 (a-h,o-z)
6097       include 'DIMENSIONS'
6098       include 'COMMON.GEO'
6099       include 'COMMON.LOCAL'
6100       include 'COMMON.VAR'
6101       include 'COMMON.SCROT'
6102       include 'COMMON.INTERACT'
6103       include 'COMMON.DERIV'
6104       include 'COMMON.CHAIN'
6105       include 'COMMON.IOUNITS'
6106       include 'COMMON.NAMES'
6107       include 'COMMON.FFIELD'
6108       include 'COMMON.CONTROL'
6109       include 'COMMON.VECTORS'
6110       double precision x_prime(3),y_prime(3),z_prime(3)
6111      &    , sumene,dsc_i,dp2_i,x(65),
6112      &     xx,yy,zz,sumene1,sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6,
6113      &    de_dxx,de_dyy,de_dzz,de_dt
6114       double precision s1_t,s1_6_t,s2_t,s2_6_t
6115       double precision
6116      & dXX_Ci1(3),dYY_Ci1(3),dZZ_Ci1(3),dXX_Ci(3),
6117      & dYY_Ci(3),dZZ_Ci(3),dXX_XYZ(3),dYY_XYZ(3),dZZ_XYZ(3),
6118      & dt_dCi(3),dt_dCi1(3)
6119       common /sccalc/ time11,time12,time112,theti,it,nlobit
6120       delta=0.02d0*pi
6121       escloc=0.0D0
6122       do i=loc_start,loc_end
6123         if (itype(i).eq.ntyp1) cycle
6124         costtab(i+1) =dcos(theta(i+1))
6125         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
6126         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
6127         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
6128         cosfac2=0.5d0/(1.0d0+costtab(i+1))
6129         cosfac=dsqrt(cosfac2)
6130         sinfac2=0.5d0/(1.0d0-costtab(i+1))
6131         sinfac=dsqrt(sinfac2)
6132         it=iabs(itype(i))
6133         if (it.eq.10) goto 1
6134 c
6135 C  Compute the axes of tghe local cartesian coordinates system; store in
6136 c   x_prime, y_prime and z_prime
6137 c
6138         do j=1,3
6139           x_prime(j) = 0.00
6140           y_prime(j) = 0.00
6141           z_prime(j) = 0.00
6142         enddo
6143 C        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
6144 C     &   dc_norm(3,i+nres)
6145         do j = 1,3
6146           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
6147           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
6148         enddo
6149         do j = 1,3
6150           z_prime(j) = -uz(j,i-1)*dsign(1.0d0,dfloat(itype(i)))
6151         enddo
6152 c       write (2,*) "i",i
6153 c       write (2,*) "x_prime",(x_prime(j),j=1,3)
6154 c       write (2,*) "y_prime",(y_prime(j),j=1,3)
6155 c       write (2,*) "z_prime",(z_prime(j),j=1,3)
6156 c       write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
6157 c      & " xy",scalar(x_prime(1),y_prime(1)),
6158 c      & " xz",scalar(x_prime(1),z_prime(1)),
6159 c      & " yy",scalar(y_prime(1),y_prime(1)),
6160 c      & " yz",scalar(y_prime(1),z_prime(1)),
6161 c      & " zz",scalar(z_prime(1),z_prime(1))
6162 c
6163 C Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
6164 C to local coordinate system. Store in xx, yy, zz.
6165 c
6166         xx=0.0d0
6167         yy=0.0d0
6168         zz=0.0d0
6169         do j = 1,3
6170           xx = xx + x_prime(j)*dc_norm(j,i+nres)
6171           yy = yy + y_prime(j)*dc_norm(j,i+nres)
6172           zz = zz + z_prime(j)*dc_norm(j,i+nres)
6173         enddo
6174
6175         xxtab(i)=xx
6176         yytab(i)=yy
6177         zztab(i)=zz
6178 C
6179 C Compute the energy of the ith side cbain
6180 C
6181 c        write (2,*) "xx",xx," yy",yy," zz",zz
6182         it=iabs(itype(i))
6183         do j = 1,65
6184           x(j) = sc_parmin(j,it)
6185         enddo
6186 #ifdef CHECK_COORD
6187 Cc diagnostics - remove later
6188         xx1 = dcos(alph(2))
6189         yy1 = dsin(alph(2))*dcos(omeg(2))
6190         zz1 = -dsign(1.0,dfloat(itype(i)))*dsin(alph(2))*dsin(omeg(2))
6191         write(2,'(3f8.1,3f9.3,1x,3f9.3)')
6192      &    alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,
6193      &    xx1,yy1,zz1
6194 C,"  --- ", xx_w,yy_w,zz_w
6195 c end diagnostics
6196 #endif
6197         sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
6198      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
6199      &   + x(10)*yy*zz
6200         sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
6201      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
6202      & + x(20)*yy*zz
6203         sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
6204      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
6205      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
6206      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
6207      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
6208      &  +x(40)*xx*yy*zz
6209         sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
6210      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
6211      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
6212      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
6213      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
6214      &  +x(60)*xx*yy*zz
6215         dsc_i   = 0.743d0+x(61)
6216         dp2_i   = 1.9d0+x(62)
6217         dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
6218      &          *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
6219         dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
6220      &          *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
6221         s1=(1+x(63))/(0.1d0 + dscp1)
6222         s1_6=(1+x(64))/(0.1d0 + dscp1**6)
6223         s2=(1+x(65))/(0.1d0 + dscp2)
6224         s2_6=(1+x(65))/(0.1d0 + dscp2**6)
6225         sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6)
6226      & + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
6227 c        write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
6228 c     &   sumene4,
6229 c     &   dscp1,dscp2,sumene
6230 c        sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6231         escloc = escloc + sumene
6232 c        write (2,*) "i",i," escloc",sumene,escloc,it,itype(i)
6233 c     & ,zz,xx,yy
6234 c#define DEBUG
6235 #ifdef DEBUG
6236 C
6237 C This section to check the numerical derivatives of the energy of ith side
6238 C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
6239 C #define DEBUG in the code to turn it on.
6240 C
6241         write (2,*) "sumene               =",sumene
6242         aincr=1.0d-7
6243         xxsave=xx
6244         xx=xx+aincr
6245         write (2,*) xx,yy,zz
6246         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6247         de_dxx_num=(sumenep-sumene)/aincr
6248         xx=xxsave
6249         write (2,*) "xx+ sumene from enesc=",sumenep
6250         yysave=yy
6251         yy=yy+aincr
6252         write (2,*) xx,yy,zz
6253         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6254         de_dyy_num=(sumenep-sumene)/aincr
6255         yy=yysave
6256         write (2,*) "yy+ sumene from enesc=",sumenep
6257         zzsave=zz
6258         zz=zz+aincr
6259         write (2,*) xx,yy,zz
6260         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6261         de_dzz_num=(sumenep-sumene)/aincr
6262         zz=zzsave
6263         write (2,*) "zz+ sumene from enesc=",sumenep
6264         costsave=cost2tab(i+1)
6265         sintsave=sint2tab(i+1)
6266         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
6267         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
6268         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6269         de_dt_num=(sumenep-sumene)/aincr
6270         write (2,*) " t+ sumene from enesc=",sumenep
6271         cost2tab(i+1)=costsave
6272         sint2tab(i+1)=sintsave
6273 C End of diagnostics section.
6274 #endif
6275 C
6276 C Compute the gradient of esc
6277 C
6278 c        zz=zz*dsign(1.0,dfloat(itype(i)))
6279         pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
6280         pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
6281         pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
6282         pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
6283         pom_dx=dsc_i*dp2_i*cost2tab(i+1)
6284         pom_dy=dsc_i*dp2_i*sint2tab(i+1)
6285         pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
6286         pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
6287         pom1=(sumene3*sint2tab(i+1)+sumene1)
6288      &     *(pom_s1/dscp1+pom_s16*dscp1**4)
6289         pom2=(sumene4*cost2tab(i+1)+sumene2)
6290      &     *(pom_s2/dscp2+pom_s26*dscp2**4)
6291         sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
6292         sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2
6293      &  +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2)
6294      &  +x(40)*yy*zz
6295         sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
6296         sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2
6297      &  +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2)
6298      &  +x(60)*yy*zz
6299         de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6)
6300      &        +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6)
6301      &        +(pom1+pom2)*pom_dx
6302 #ifdef DEBUG
6303         write(2,*), "de_dxx = ", de_dxx,de_dxx_num,itype(i)
6304 #endif
6305 C
6306         sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
6307         sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2
6308      &  +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2)
6309      &  +x(40)*xx*zz
6310         sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
6311         sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz
6312      &  +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz
6313      &  +x(59)*zz**2 +x(60)*xx*zz
6314         de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6)
6315      &        +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6)
6316      &        +(pom1-pom2)*pom_dy
6317 #ifdef DEBUG
6318         write(2,*), "de_dyy = ", de_dyy,de_dyy_num,itype(i)
6319 #endif
6320 C
6321         de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy
6322      &  +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx
6323      &  +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6)
6324      &  +(x(4) + 2*x(7)*zz+  x(8)*xx + x(10)*yy)*(s1+s1_6)
6325      &  +(x(44)+2*x(47)*zz +x(48)*xx   +x(50)*yy  +3*x(53)*zz**2
6326      &  +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy
6327      &  +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6)
6328      &  + ( x(14) + 2*x(17)*zz+  x(18)*xx + x(20)*yy)*(s2+s2_6)
6329 #ifdef DEBUG
6330         write(2,*), "de_dzz = ", de_dzz,de_dzz_num,itype(i)
6331 #endif
6332 C
6333         de_dt =  0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6)
6334      &  -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6)
6335      &  +pom1*pom_dt1+pom2*pom_dt2
6336 #ifdef DEBUG
6337         write(2,*), "de_dt = ", de_dt,de_dt_num,itype(i)
6338 #endif
6339 c#undef DEBUG
6340 c
6341 C
6342        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
6343        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
6344        cosfac2xx=cosfac2*xx
6345        sinfac2yy=sinfac2*yy
6346        do k = 1,3
6347          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))*
6348      &      vbld_inv(i+1)
6349          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))*
6350      &      vbld_inv(i)
6351          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
6352          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
6353 c         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
6354 c     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
6355 c         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
6356 c     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
6357          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
6358          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
6359          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
6360          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
6361          dZZ_Ci1(k)=0.0d0
6362          dZZ_Ci(k)=0.0d0
6363          do j=1,3
6364            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)
6365      &     *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
6366            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)
6367      &     *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
6368          enddo
6369
6370          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
6371          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
6372          dZZ_XYZ(k)=vbld_inv(i+nres)*
6373      &   (z_prime(k)-zz*dC_norm(k,i+nres))
6374 c
6375          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
6376          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
6377        enddo
6378
6379        do k=1,3
6380          dXX_Ctab(k,i)=dXX_Ci(k)
6381          dXX_C1tab(k,i)=dXX_Ci1(k)
6382          dYY_Ctab(k,i)=dYY_Ci(k)
6383          dYY_C1tab(k,i)=dYY_Ci1(k)
6384          dZZ_Ctab(k,i)=dZZ_Ci(k)
6385          dZZ_C1tab(k,i)=dZZ_Ci1(k)
6386          dXX_XYZtab(k,i)=dXX_XYZ(k)
6387          dYY_XYZtab(k,i)=dYY_XYZ(k)
6388          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
6389        enddo
6390
6391        do k = 1,3
6392 c         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
6393 c     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
6394 c         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
6395 c     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
6396 c         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
6397 c     &    dt_dci(k)
6398 c         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
6399 c     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
6400          gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k)
6401      &    +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
6402          gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k)
6403      &    +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
6404          gsclocx(k,i)=                 de_dxx*dxx_XYZ(k)
6405      &    +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
6406        enddo
6407 c       write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
6408 c     &  (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
6409
6410 C to check gradient call subroutine check_grad
6411
6412     1 continue
6413       enddo
6414       return
6415       end
6416 c------------------------------------------------------------------------------
6417       double precision function enesc(x,xx,yy,zz,cost2,sint2)
6418       implicit none
6419       double precision x(65),xx,yy,zz,cost2,sint2,sumene1,sumene2,
6420      & sumene3,sumene4,sumene,dsc_i,dp2_i,dscp1,dscp2,s1,s1_6,s2,s2_6
6421       sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
6422      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
6423      &   + x(10)*yy*zz
6424       sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
6425      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
6426      & + x(20)*yy*zz
6427       sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
6428      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
6429      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
6430      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
6431      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
6432      &  +x(40)*xx*yy*zz
6433       sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
6434      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
6435      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
6436      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
6437      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
6438      &  +x(60)*xx*yy*zz
6439       dsc_i   = 0.743d0+x(61)
6440       dp2_i   = 1.9d0+x(62)
6441       dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
6442      &          *(xx*cost2+yy*sint2))
6443       dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
6444      &          *(xx*cost2-yy*sint2))
6445       s1=(1+x(63))/(0.1d0 + dscp1)
6446       s1_6=(1+x(64))/(0.1d0 + dscp1**6)
6447       s2=(1+x(65))/(0.1d0 + dscp2)
6448       s2_6=(1+x(65))/(0.1d0 + dscp2**6)
6449       sumene = ( sumene3*sint2 + sumene1)*(s1+s1_6)
6450      & + (sumene4*cost2 +sumene2)*(s2+s2_6)
6451       enesc=sumene
6452       return
6453       end
6454 #endif
6455 c------------------------------------------------------------------------------
6456       subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
6457 C
6458 C This procedure calculates two-body contact function g(rij) and its derivative:
6459 C
6460 C           eps0ij                                     !       x < -1
6461 C g(rij) =  esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5)  ! -1 =< x =< 1
6462 C            0                                         !       x > 1
6463 C
6464 C where x=(rij-r0ij)/delta
6465 C
6466 C rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
6467 C
6468       implicit none
6469       double precision rij,r0ij,eps0ij,fcont,fprimcont
6470       double precision x,x2,x4,delta
6471 c     delta=0.02D0*r0ij
6472 c      delta=0.2D0*r0ij
6473       x=(rij-r0ij)/delta
6474       if (x.lt.-1.0D0) then
6475         fcont=eps0ij
6476         fprimcont=0.0D0
6477       else if (x.le.1.0D0) then
6478         x2=x*x
6479         x4=x2*x2
6480         fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
6481         fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
6482       else
6483         fcont=0.0D0
6484         fprimcont=0.0D0
6485       endif
6486       return
6487       end
6488 c------------------------------------------------------------------------------
6489       subroutine splinthet(theti,delta,ss,ssder)
6490       implicit real*8 (a-h,o-z)
6491       include 'DIMENSIONS'
6492       include 'COMMON.VAR'
6493       include 'COMMON.GEO'
6494       thetup=pi-delta
6495       thetlow=delta
6496       if (theti.gt.pipol) then
6497         call gcont(theti,thetup,1.0d0,delta,ss,ssder)
6498       else
6499         call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
6500         ssder=-ssder
6501       endif
6502       return
6503       end
6504 c------------------------------------------------------------------------------
6505       subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
6506       implicit none
6507       double precision x,x0,delta,f0,f1,fprim0,f,fprim
6508       double precision ksi,ksi2,ksi3,a1,a2,a3
6509       a1=fprim0*delta/(f1-f0)
6510       a2=3.0d0-2.0d0*a1
6511       a3=a1-2.0d0
6512       ksi=(x-x0)/delta
6513       ksi2=ksi*ksi
6514       ksi3=ksi2*ksi
6515       f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
6516       fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
6517       return
6518       end
6519 c------------------------------------------------------------------------------
6520       subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
6521       implicit none
6522       double precision x,x0,delta,f0x,f1x,fprim0x,fx
6523       double precision ksi,ksi2,ksi3,a1,a2,a3
6524       ksi=(x-x0)/delta
6525       ksi2=ksi*ksi
6526       ksi3=ksi2*ksi
6527       a1=fprim0x*delta
6528       a2=3*(f1x-f0x)-2*fprim0x*delta
6529       a3=fprim0x*delta-2*(f1x-f0x)
6530       fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
6531       return
6532       end
6533 C-----------------------------------------------------------------------------
6534 #ifdef CRYST_TOR
6535 C-----------------------------------------------------------------------------
6536       subroutine etor(etors,edihcnstr)
6537       implicit real*8 (a-h,o-z)
6538       include 'DIMENSIONS'
6539       include 'COMMON.VAR'
6540       include 'COMMON.GEO'
6541       include 'COMMON.LOCAL'
6542       include 'COMMON.TORSION'
6543       include 'COMMON.INTERACT'
6544       include 'COMMON.DERIV'
6545       include 'COMMON.CHAIN'
6546       include 'COMMON.NAMES'
6547       include 'COMMON.IOUNITS'
6548       include 'COMMON.FFIELD'
6549       include 'COMMON.TORCNSTR'
6550       include 'COMMON.CONTROL'
6551       logical lprn
6552 C Set lprn=.true. for debugging
6553       lprn=.false.
6554 c      lprn=.true.
6555       etors=0.0D0
6556       do i=iphi_start,iphi_end
6557       etors_ii=0.0D0
6558         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
6559      &      .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
6560         itori=itortyp(itype(i-2))
6561         itori1=itortyp(itype(i-1))
6562         phii=phi(i)
6563         gloci=0.0D0
6564 C Proline-Proline pair is a special case...
6565         if (itori.eq.3 .and. itori1.eq.3) then
6566           if (phii.gt.-dwapi3) then
6567             cosphi=dcos(3*phii)
6568             fac=1.0D0/(1.0D0-cosphi)
6569             etorsi=v1(1,3,3)*fac
6570             etorsi=etorsi+etorsi
6571             etors=etors+etorsi-v1(1,3,3)
6572             if (energy_dec) etors_ii=etors_ii+etorsi-v1(1,3,3)
6573             gloci=gloci-3*fac*etorsi*dsin(3*phii)
6574           endif
6575           do j=1,3
6576             v1ij=v1(j+1,itori,itori1)
6577             v2ij=v2(j+1,itori,itori1)
6578             cosphi=dcos(j*phii)
6579             sinphi=dsin(j*phii)
6580             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
6581             if (energy_dec) etors_ii=etors_ii+
6582      &                              v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
6583             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
6584           enddo
6585         else
6586           do j=1,nterm_old
6587             v1ij=v1(j,itori,itori1)
6588             v2ij=v2(j,itori,itori1)
6589             cosphi=dcos(j*phii)
6590             sinphi=dsin(j*phii)
6591             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
6592             if (energy_dec) etors_ii=etors_ii+
6593      &                  v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
6594             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
6595           enddo
6596         endif
6597         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
6598              'etor',i,etors_ii
6599         if (lprn)
6600      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
6601      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
6602      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
6603         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
6604 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
6605       enddo
6606 ! 6/20/98 - dihedral angle constraints
6607       edihcnstr=0.0d0
6608       do i=1,ndih_constr
6609         itori=idih_constr(i)
6610         phii=phi(itori)
6611         difi=phii-phi0(i)
6612         if (difi.gt.drange(i)) then
6613           difi=difi-drange(i)
6614           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
6615           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
6616         else if (difi.lt.-drange(i)) then
6617           difi=difi+drange(i)
6618           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
6619           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
6620         endif
6621 !        write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii,
6622 !     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
6623       enddo
6624 !      write (iout,*) 'edihcnstr',edihcnstr
6625       return
6626       end
6627 c------------------------------------------------------------------------------
6628       subroutine etor_d(etors_d)
6629       etors_d=0.0d0
6630       return
6631       end
6632 c----------------------------------------------------------------------------
6633 #else
6634       subroutine etor(etors,edihcnstr)
6635       implicit real*8 (a-h,o-z)
6636       include 'DIMENSIONS'
6637       include 'COMMON.VAR'
6638       include 'COMMON.GEO'
6639       include 'COMMON.LOCAL'
6640       include 'COMMON.TORSION'
6641       include 'COMMON.INTERACT'
6642       include 'COMMON.DERIV'
6643       include 'COMMON.CHAIN'
6644       include 'COMMON.NAMES'
6645       include 'COMMON.IOUNITS'
6646       include 'COMMON.FFIELD'
6647       include 'COMMON.TORCNSTR'
6648       include 'COMMON.CONTROL'
6649       logical lprn
6650 C Set lprn=.true. for debugging
6651       lprn=.false.
6652 c     lprn=.true.
6653       etors=0.0D0
6654       do i=iphi_start,iphi_end
6655 C ANY TWO ARE DUMMY ATOMS in row CYCLE
6656 c        if (((itype(i-3).eq.ntyp1).and.(itype(i-2).eq.ntyp1)).or.
6657 c     &      ((itype(i-2).eq.ntyp1).and.(itype(i-1).eq.ntyp1))  .or.
6658 c     &      ((itype(i-1).eq.ntyp1).and.(itype(i).eq.ntyp1))) cycle
6659         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
6660      &      .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
6661 C In current verion the ALL DUMMY ATOM POTENTIALS ARE OFF
6662 C For introducing the NH3+ and COO- group please check the etor_d for reference
6663 C and guidance
6664         etors_ii=0.0D0
6665          if (iabs(itype(i)).eq.20) then
6666          iblock=2
6667          else
6668          iblock=1
6669          endif
6670         itori=itortyp(itype(i-2))
6671         itori1=itortyp(itype(i-1))
6672         phii=phi(i)
6673         gloci=0.0D0
6674 C Regular cosine and sine terms
6675         do j=1,nterm(itori,itori1,iblock)
6676           v1ij=v1(j,itori,itori1,iblock)
6677           v2ij=v2(j,itori,itori1,iblock)
6678           cosphi=dcos(j*phii)
6679           sinphi=dsin(j*phii)
6680           etors=etors+v1ij*cosphi+v2ij*sinphi
6681           if (energy_dec) etors_ii=etors_ii+
6682      &                v1ij*cosphi+v2ij*sinphi
6683           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
6684         enddo
6685 C Lorentz terms
6686 C                         v1
6687 C  E = SUM ----------------------------------- - v1
6688 C          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
6689 C
6690         cosphi=dcos(0.5d0*phii)
6691         sinphi=dsin(0.5d0*phii)
6692         do j=1,nlor(itori,itori1,iblock)
6693           vl1ij=vlor1(j,itori,itori1)
6694           vl2ij=vlor2(j,itori,itori1)
6695           vl3ij=vlor3(j,itori,itori1)
6696           pom=vl2ij*cosphi+vl3ij*sinphi
6697           pom1=1.0d0/(pom*pom+1.0d0)
6698           etors=etors+vl1ij*pom1
6699           if (energy_dec) etors_ii=etors_ii+
6700      &                vl1ij*pom1
6701           pom=-pom*pom1*pom1
6702           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
6703         enddo
6704 C Subtract the constant term
6705         etors=etors-v0(itori,itori1,iblock)
6706           if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
6707      &         'etor',i,etors_ii-v0(itori,itori1,iblock)
6708         if (lprn)
6709      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
6710      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
6711      &  (v1(j,itori,itori1,iblock),j=1,6),
6712      &  (v2(j,itori,itori1,iblock),j=1,6)
6713         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
6714 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
6715       enddo
6716 ! 6/20/98 - dihedral angle constraints
6717       edihcnstr=0.0d0
6718 c      do i=1,ndih_constr
6719       do i=idihconstr_start,idihconstr_end
6720         itori=idih_constr(i)
6721         phii=phi(itori)
6722         difi=pinorm(phii-phi0(i))
6723         if (difi.gt.drange(i)) then
6724           difi=difi-drange(i)
6725           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
6726           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
6727         else if (difi.lt.-drange(i)) then
6728           difi=difi+drange(i)
6729           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
6730           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
6731         else
6732           difi=0.0
6733         endif
6734 cd        write (iout,'(2i5,4f8.3,2e14.5)') i,itori,rad2deg*phii,
6735 cd     &    rad2deg*phi0(i),  rad2deg*drange(i),
6736 cd     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
6737       enddo
6738 cd       write (iout,*) 'edihcnstr',edihcnstr
6739       return
6740       end
6741 c----------------------------------------------------------------------------
6742       subroutine etor_d(etors_d)
6743 C 6/23/01 Compute double torsional energy
6744       implicit real*8 (a-h,o-z)
6745       include 'DIMENSIONS'
6746       include 'COMMON.VAR'
6747       include 'COMMON.GEO'
6748       include 'COMMON.LOCAL'
6749       include 'COMMON.TORSION'
6750       include 'COMMON.INTERACT'
6751       include 'COMMON.DERIV'
6752       include 'COMMON.CHAIN'
6753       include 'COMMON.NAMES'
6754       include 'COMMON.IOUNITS'
6755       include 'COMMON.FFIELD'
6756       include 'COMMON.TORCNSTR'
6757       logical lprn
6758 C Set lprn=.true. for debugging
6759       lprn=.false.
6760 c     lprn=.true.
6761       etors_d=0.0D0
6762 c      write(iout,*) "a tu??"
6763       do i=iphid_start,iphid_end
6764 C ANY TWO ARE DUMMY ATOMS in row CYCLE
6765 C        if (((itype(i-3).eq.ntyp1).and.(itype(i-2).eq.ntyp1)).or.
6766 C     &      ((itype(i-2).eq.ntyp1).and.(itype(i-1).eq.ntyp1)).or.
6767 C     &      ((itype(i-1).eq.ntyp1).and.(itype(i).eq.ntyp1))  .or.
6768 C     &      ((itype(i).eq.ntyp1).and.(itype(i+1).eq.ntyp1))) cycle
6769          if ((itype(i-2).eq.ntyp1).or.itype(i-3).eq.ntyp1.or.
6770      &  (itype(i-1).eq.ntyp1).or.(itype(i).eq.ntyp1).or.
6771      &  (itype(i+1).eq.ntyp1)) cycle
6772 C In current verion the ALL DUMMY ATOM POTENTIALS ARE OFF
6773         itori=itortyp(itype(i-2))
6774         itori1=itortyp(itype(i-1))
6775         itori2=itortyp(itype(i))
6776         phii=phi(i)
6777         phii1=phi(i+1)
6778         gloci1=0.0D0
6779         gloci2=0.0D0
6780         iblock=1
6781         if (iabs(itype(i+1)).eq.20) iblock=2
6782 C Iblock=2 Proline type
6783 C ADASKO: WHEN PARAMETERS FOR THIS TYPE OF BLOCKING GROUP IS READY UNCOMMENT
6784 C CHECK WEATHER THERE IS NECCESITY FOR iblock=3 for COO-
6785 C        if (itype(i+1).eq.ntyp1) iblock=3
6786 C The problem of NH3+ group can be resolved by adding new parameters please note if there
6787 C IS or IS NOT need for this
6788 C IF Yes uncomment below and add to parmread.F appropriate changes and to v1cij and so on
6789 C        is (itype(i-3).eq.ntyp1) ntblock=2
6790 C        ntblock is N-terminal blocking group
6791
6792 C Regular cosine and sine terms
6793         do j=1,ntermd_1(itori,itori1,itori2,iblock)
6794 C Example of changes for NH3+ blocking group
6795 C       do j=1,ntermd_1(itori,itori1,itori2,iblock,ntblock)
6796 C          v1cij=v1c(1,j,itori,itori1,itori2,iblock,ntblock)
6797           v1cij=v1c(1,j,itori,itori1,itori2,iblock)
6798           v1sij=v1s(1,j,itori,itori1,itori2,iblock)
6799           v2cij=v1c(2,j,itori,itori1,itori2,iblock)
6800           v2sij=v1s(2,j,itori,itori1,itori2,iblock)
6801           cosphi1=dcos(j*phii)
6802           sinphi1=dsin(j*phii)
6803           cosphi2=dcos(j*phii1)
6804           sinphi2=dsin(j*phii1)
6805           etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+
6806      &     v2cij*cosphi2+v2sij*sinphi2
6807           gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
6808           gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
6809         enddo
6810         do k=2,ntermd_2(itori,itori1,itori2,iblock)
6811           do l=1,k-1
6812             v1cdij = v2c(k,l,itori,itori1,itori2,iblock)
6813             v2cdij = v2c(l,k,itori,itori1,itori2,iblock)
6814             v1sdij = v2s(k,l,itori,itori1,itori2,iblock)
6815             v2sdij = v2s(l,k,itori,itori1,itori2,iblock)
6816             cosphi1p2=dcos(l*phii+(k-l)*phii1)
6817             cosphi1m2=dcos(l*phii-(k-l)*phii1)
6818             sinphi1p2=dsin(l*phii+(k-l)*phii1)
6819             sinphi1m2=dsin(l*phii-(k-l)*phii1)
6820             etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+
6821      &        v1sdij*sinphi1p2+v2sdij*sinphi1m2
6822             gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2
6823      &        -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
6824             gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2
6825      &        -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
6826           enddo
6827         enddo
6828         gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*gloci1
6829         gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*gloci2
6830       enddo
6831       return
6832       end
6833 #endif
6834 c------------------------------------------------------------------------------
6835       subroutine eback_sc_corr(esccor)
6836 c 7/21/2007 Correlations between the backbone-local and side-chain-local
6837 c        conformational states; temporarily implemented as differences
6838 c        between UNRES torsional potentials (dependent on three types of
6839 c        residues) and the torsional potentials dependent on all 20 types
6840 c        of residues computed from AM1  energy surfaces of terminally-blocked
6841 c        amino-acid residues.
6842       implicit real*8 (a-h,o-z)
6843       include 'DIMENSIONS'
6844       include 'COMMON.VAR'
6845       include 'COMMON.GEO'
6846       include 'COMMON.LOCAL'
6847       include 'COMMON.TORSION'
6848       include 'COMMON.SCCOR'
6849       include 'COMMON.INTERACT'
6850       include 'COMMON.DERIV'
6851       include 'COMMON.CHAIN'
6852       include 'COMMON.NAMES'
6853       include 'COMMON.IOUNITS'
6854       include 'COMMON.FFIELD'
6855       include 'COMMON.CONTROL'
6856       logical lprn
6857 C Set lprn=.true. for debugging
6858       lprn=.false.
6859 c      lprn=.true.
6860 c      write (iout,*) "EBACK_SC_COR",itau_start,itau_end
6861       esccor=0.0D0
6862       do i=itau_start,itau_end
6863         if ((itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)) cycle
6864         esccor_ii=0.0D0
6865         isccori=isccortyp(itype(i-2))
6866         isccori1=isccortyp(itype(i-1))
6867 c      write (iout,*) "EBACK_SC_COR",i,nterm_sccor(isccori,isccori1)
6868         phii=phi(i)
6869         do intertyp=1,3 !intertyp
6870 cc Added 09 May 2012 (Adasko)
6871 cc  Intertyp means interaction type of backbone mainchain correlation:
6872 c   1 = SC...Ca...Ca...Ca
6873 c   2 = Ca...Ca...Ca...SC
6874 c   3 = SC...Ca...Ca...SCi
6875         gloci=0.0D0
6876         if (((intertyp.eq.3).and.((itype(i-2).eq.10).or.
6877      &      (itype(i-1).eq.10).or.(itype(i-2).eq.ntyp1).or.
6878      &      (itype(i-1).eq.ntyp1)))
6879      &    .or. ((intertyp.eq.1).and.((itype(i-2).eq.10)
6880      &     .or.(itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)
6881      &     .or.(itype(i).eq.ntyp1)))
6882      &    .or.((intertyp.eq.2).and.((itype(i-1).eq.10).or.
6883      &      (itype(i-1).eq.ntyp1).or.(itype(i-2).eq.ntyp1).or.
6884      &      (itype(i-3).eq.ntyp1)))) cycle
6885         if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1).eq.ntyp1)) cycle
6886         if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres).eq.ntyp1))
6887      & cycle
6888        do j=1,nterm_sccor(isccori,isccori1)
6889           v1ij=v1sccor(j,intertyp,isccori,isccori1)
6890           v2ij=v2sccor(j,intertyp,isccori,isccori1)
6891           cosphi=dcos(j*tauangle(intertyp,i))
6892           sinphi=dsin(j*tauangle(intertyp,i))
6893           esccor=esccor+v1ij*cosphi+v2ij*sinphi
6894           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
6895         enddo
6896 c      write (iout,*) "EBACK_SC_COR",i,v1ij*cosphi+v2ij*sinphi,intertyp
6897         gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci
6898         if (lprn)
6899      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
6900      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,isccori,isccori1,
6901      &  (v1sccor(j,intertyp,isccori,isccori1),j=1,6)
6902      & ,(v2sccor(j,intertyp,isccori,isccori1),j=1,6)
6903         gsccor_loc(i-3)=gsccor_loc(i-3)+gloci
6904        enddo !intertyp
6905       enddo
6906
6907       return
6908       end
6909 c----------------------------------------------------------------------------
6910       subroutine multibody(ecorr)
6911 C This subroutine calculates multi-body contributions to energy following
6912 C the idea of Skolnick et al. If side chains I and J make a contact and
6913 C at the same time side chains I+1 and J+1 make a contact, an extra
6914 C contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
6915       implicit real*8 (a-h,o-z)
6916       include 'DIMENSIONS'
6917       include 'COMMON.IOUNITS'
6918       include 'COMMON.DERIV'
6919       include 'COMMON.INTERACT'
6920       include 'COMMON.CONTACTS'
6921       double precision gx(3),gx1(3)
6922       logical lprn
6923
6924 C Set lprn=.true. for debugging
6925       lprn=.false.
6926
6927       if (lprn) then
6928         write (iout,'(a)') 'Contact function values:'
6929         do i=nnt,nct-2
6930           write (iout,'(i2,20(1x,i2,f10.5))')
6931      &        i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
6932         enddo
6933       endif
6934       ecorr=0.0D0
6935       do i=nnt,nct
6936         do j=1,3
6937           gradcorr(j,i)=0.0D0
6938           gradxorr(j,i)=0.0D0
6939         enddo
6940       enddo
6941       do i=nnt,nct-2
6942
6943         DO ISHIFT = 3,4
6944
6945         i1=i+ishift
6946         num_conti=num_cont(i)
6947         num_conti1=num_cont(i1)
6948         do jj=1,num_conti
6949           j=jcont(jj,i)
6950           do kk=1,num_conti1
6951             j1=jcont(kk,i1)
6952             if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
6953 cd          write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6954 cd   &                   ' ishift=',ishift
6955 C Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
6956 C The system gains extra energy.
6957               ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
6958             endif   ! j1==j+-ishift
6959           enddo     ! kk
6960         enddo       ! jj
6961
6962         ENDDO ! ISHIFT
6963
6964       enddo         ! i
6965       return
6966       end
6967 c------------------------------------------------------------------------------
6968       double precision function esccorr(i,j,k,l,jj,kk)
6969       implicit real*8 (a-h,o-z)
6970       include 'DIMENSIONS'
6971       include 'COMMON.IOUNITS'
6972       include 'COMMON.DERIV'
6973       include 'COMMON.INTERACT'
6974       include 'COMMON.CONTACTS'
6975       double precision gx(3),gx1(3)
6976       logical lprn
6977       lprn=.false.
6978       eij=facont(jj,i)
6979       ekl=facont(kk,k)
6980 cd    write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
6981 C Calculate the multi-body contribution to energy.
6982 C Calculate multi-body contributions to the gradient.
6983 cd    write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
6984 cd   & k,l,(gacont(m,kk,k),m=1,3)
6985       do m=1,3
6986         gx(m) =ekl*gacont(m,jj,i)
6987         gx1(m)=eij*gacont(m,kk,k)
6988         gradxorr(m,i)=gradxorr(m,i)-gx(m)
6989         gradxorr(m,j)=gradxorr(m,j)+gx(m)
6990         gradxorr(m,k)=gradxorr(m,k)-gx1(m)
6991         gradxorr(m,l)=gradxorr(m,l)+gx1(m)
6992       enddo
6993       do m=i,j-1
6994         do ll=1,3
6995           gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
6996         enddo
6997       enddo
6998       do m=k,l-1
6999         do ll=1,3
7000           gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
7001         enddo
7002       enddo
7003       esccorr=-eij*ekl
7004       return
7005       end
7006 c------------------------------------------------------------------------------
7007       subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
7008 C This subroutine calculates multi-body contributions to hydrogen-bonding
7009       implicit real*8 (a-h,o-z)
7010       include 'DIMENSIONS'
7011       include 'COMMON.IOUNITS'
7012 #ifdef MPI
7013       include "mpif.h"
7014       parameter (max_cont=maxconts)
7015       parameter (max_dim=26)
7016       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
7017       double precision zapas(max_dim,maxconts,max_fg_procs),
7018      &  zapas_recv(max_dim,maxconts,max_fg_procs)
7019       common /przechowalnia/ zapas
7020       integer status(MPI_STATUS_SIZE),req(maxconts*2),
7021      &  status_array(MPI_STATUS_SIZE,maxconts*2)
7022 #endif
7023       include 'COMMON.SETUP'
7024       include 'COMMON.FFIELD'
7025       include 'COMMON.DERIV'
7026       include 'COMMON.INTERACT'
7027       include 'COMMON.CONTACTS'
7028       include 'COMMON.CONTROL'
7029       include 'COMMON.LOCAL'
7030       double precision gx(3),gx1(3),time00
7031       logical lprn,ldone
7032
7033 C Set lprn=.true. for debugging
7034       lprn=.false.
7035 #ifdef MPI
7036       n_corr=0
7037       n_corr1=0
7038       if (nfgtasks.le.1) goto 30
7039       if (lprn) then
7040         write (iout,'(a)') 'Contact function values before RECEIVE:'
7041         do i=nnt,nct-2
7042           write (iout,'(2i3,50(1x,i2,f5.2))')
7043      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
7044      &    j=1,num_cont_hb(i))
7045         enddo
7046       endif
7047       call flush(iout)
7048       do i=1,ntask_cont_from
7049         ncont_recv(i)=0
7050       enddo
7051       do i=1,ntask_cont_to
7052         ncont_sent(i)=0
7053       enddo
7054 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
7055 c     & ntask_cont_to
7056 C Make the list of contacts to send to send to other procesors
7057 c      write (iout,*) "limits",max0(iturn4_end-1,iatel_s),iturn3_end
7058 c      call flush(iout)
7059       do i=iturn3_start,iturn3_end
7060 c        write (iout,*) "make contact list turn3",i," num_cont",
7061 c     &    num_cont_hb(i)
7062         call add_hb_contact(i,i+2,iturn3_sent_local(1,i))
7063       enddo
7064       do i=iturn4_start,iturn4_end
7065 c        write (iout,*) "make contact list turn4",i," num_cont",
7066 c     &   num_cont_hb(i)
7067         call add_hb_contact(i,i+3,iturn4_sent_local(1,i))
7068       enddo
7069       do ii=1,nat_sent
7070         i=iat_sent(ii)
7071 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
7072 c     &    num_cont_hb(i)
7073         do j=1,num_cont_hb(i)
7074         do k=1,4
7075           jjc=jcont_hb(j,i)
7076           iproc=iint_sent_local(k,jjc,ii)
7077 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
7078           if (iproc.gt.0) then
7079             ncont_sent(iproc)=ncont_sent(iproc)+1
7080             nn=ncont_sent(iproc)
7081             zapas(1,nn,iproc)=i
7082             zapas(2,nn,iproc)=jjc
7083             zapas(3,nn,iproc)=facont_hb(j,i)
7084             zapas(4,nn,iproc)=ees0p(j,i)
7085             zapas(5,nn,iproc)=ees0m(j,i)
7086             zapas(6,nn,iproc)=gacont_hbr(1,j,i)
7087             zapas(7,nn,iproc)=gacont_hbr(2,j,i)
7088             zapas(8,nn,iproc)=gacont_hbr(3,j,i)
7089             zapas(9,nn,iproc)=gacontm_hb1(1,j,i)
7090             zapas(10,nn,iproc)=gacontm_hb1(2,j,i)
7091             zapas(11,nn,iproc)=gacontm_hb1(3,j,i)
7092             zapas(12,nn,iproc)=gacontp_hb1(1,j,i)
7093             zapas(13,nn,iproc)=gacontp_hb1(2,j,i)
7094             zapas(14,nn,iproc)=gacontp_hb1(3,j,i)
7095             zapas(15,nn,iproc)=gacontm_hb2(1,j,i)
7096             zapas(16,nn,iproc)=gacontm_hb2(2,j,i)
7097             zapas(17,nn,iproc)=gacontm_hb2(3,j,i)
7098             zapas(18,nn,iproc)=gacontp_hb2(1,j,i)
7099             zapas(19,nn,iproc)=gacontp_hb2(2,j,i)
7100             zapas(20,nn,iproc)=gacontp_hb2(3,j,i)
7101             zapas(21,nn,iproc)=gacontm_hb3(1,j,i)
7102             zapas(22,nn,iproc)=gacontm_hb3(2,j,i)
7103             zapas(23,nn,iproc)=gacontm_hb3(3,j,i)
7104             zapas(24,nn,iproc)=gacontp_hb3(1,j,i)
7105             zapas(25,nn,iproc)=gacontp_hb3(2,j,i)
7106             zapas(26,nn,iproc)=gacontp_hb3(3,j,i)
7107           endif
7108         enddo
7109         enddo
7110       enddo
7111       if (lprn) then
7112       write (iout,*)
7113      &  "Numbers of contacts to be sent to other processors",
7114      &  (ncont_sent(i),i=1,ntask_cont_to)
7115       write (iout,*) "Contacts sent"
7116       do ii=1,ntask_cont_to
7117         nn=ncont_sent(ii)
7118         iproc=itask_cont_to(ii)
7119         write (iout,*) nn," contacts to processor",iproc,
7120      &   " of CONT_TO_COMM group"
7121         do i=1,nn
7122           write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
7123         enddo
7124       enddo
7125       call flush(iout)
7126       endif
7127       CorrelType=477
7128       CorrelID=fg_rank+1
7129       CorrelType1=478
7130       CorrelID1=nfgtasks+fg_rank+1
7131       ireq=0
7132 C Receive the numbers of needed contacts from other processors
7133       do ii=1,ntask_cont_from
7134         iproc=itask_cont_from(ii)
7135         ireq=ireq+1
7136         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
7137      &    FG_COMM,req(ireq),IERR)
7138       enddo
7139 c      write (iout,*) "IRECV ended"
7140 c      call flush(iout)
7141 C Send the number of contacts needed by other processors
7142       do ii=1,ntask_cont_to
7143         iproc=itask_cont_to(ii)
7144         ireq=ireq+1
7145         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
7146      &    FG_COMM,req(ireq),IERR)
7147       enddo
7148 c      write (iout,*) "ISEND ended"
7149 c      write (iout,*) "number of requests (nn)",ireq
7150       call flush(iout)
7151       if (ireq.gt.0)
7152      &  call MPI_Waitall(ireq,req,status_array,ierr)
7153 c      write (iout,*)
7154 c     &  "Numbers of contacts to be received from other processors",
7155 c     &  (ncont_recv(i),i=1,ntask_cont_from)
7156 c      call flush(iout)
7157 C Receive contacts
7158       ireq=0
7159       do ii=1,ntask_cont_from
7160         iproc=itask_cont_from(ii)
7161         nn=ncont_recv(ii)
7162 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
7163 c     &   " of CONT_TO_COMM group"
7164         call flush(iout)
7165         if (nn.gt.0) then
7166           ireq=ireq+1
7167           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
7168      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
7169 c          write (iout,*) "ireq,req",ireq,req(ireq)
7170         endif
7171       enddo
7172 C Send the contacts to processors that need them
7173       do ii=1,ntask_cont_to
7174         iproc=itask_cont_to(ii)
7175         nn=ncont_sent(ii)
7176 c        write (iout,*) nn," contacts to processor",iproc,
7177 c     &   " of CONT_TO_COMM group"
7178         if (nn.gt.0) then
7179           ireq=ireq+1
7180           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
7181      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
7182 c          write (iout,*) "ireq,req",ireq,req(ireq)
7183 c          do i=1,nn
7184 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
7185 c          enddo
7186         endif
7187       enddo
7188 c      write (iout,*) "number of requests (contacts)",ireq
7189 c      write (iout,*) "req",(req(i),i=1,4)
7190 c      call flush(iout)
7191       if (ireq.gt.0)
7192      & call MPI_Waitall(ireq,req,status_array,ierr)
7193       do iii=1,ntask_cont_from
7194         iproc=itask_cont_from(iii)
7195         nn=ncont_recv(iii)
7196         if (lprn) then
7197         write (iout,*) "Received",nn," contacts from processor",iproc,
7198      &   " of CONT_FROM_COMM group"
7199         call flush(iout)
7200         do i=1,nn
7201           write(iout,'(2f5.0,4f10.5)')(zapas_recv(j,i,iii),j=1,5)
7202         enddo
7203         call flush(iout)
7204         endif
7205         do i=1,nn
7206           ii=zapas_recv(1,i,iii)
7207 c Flag the received contacts to prevent double-counting
7208           jj=-zapas_recv(2,i,iii)
7209 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
7210 c          call flush(iout)
7211           nnn=num_cont_hb(ii)+1
7212           num_cont_hb(ii)=nnn
7213           jcont_hb(nnn,ii)=jj
7214           facont_hb(nnn,ii)=zapas_recv(3,i,iii)
7215           ees0p(nnn,ii)=zapas_recv(4,i,iii)
7216           ees0m(nnn,ii)=zapas_recv(5,i,iii)
7217           gacont_hbr(1,nnn,ii)=zapas_recv(6,i,iii)
7218           gacont_hbr(2,nnn,ii)=zapas_recv(7,i,iii)
7219           gacont_hbr(3,nnn,ii)=zapas_recv(8,i,iii)
7220           gacontm_hb1(1,nnn,ii)=zapas_recv(9,i,iii)
7221           gacontm_hb1(2,nnn,ii)=zapas_recv(10,i,iii)
7222           gacontm_hb1(3,nnn,ii)=zapas_recv(11,i,iii)
7223           gacontp_hb1(1,nnn,ii)=zapas_recv(12,i,iii)
7224           gacontp_hb1(2,nnn,ii)=zapas_recv(13,i,iii)
7225           gacontp_hb1(3,nnn,ii)=zapas_recv(14,i,iii)
7226           gacontm_hb2(1,nnn,ii)=zapas_recv(15,i,iii)
7227           gacontm_hb2(2,nnn,ii)=zapas_recv(16,i,iii)
7228           gacontm_hb2(3,nnn,ii)=zapas_recv(17,i,iii)
7229           gacontp_hb2(1,nnn,ii)=zapas_recv(18,i,iii)
7230           gacontp_hb2(2,nnn,ii)=zapas_recv(19,i,iii)
7231           gacontp_hb2(3,nnn,ii)=zapas_recv(20,i,iii)
7232           gacontm_hb3(1,nnn,ii)=zapas_recv(21,i,iii)
7233           gacontm_hb3(2,nnn,ii)=zapas_recv(22,i,iii)
7234           gacontm_hb3(3,nnn,ii)=zapas_recv(23,i,iii)
7235           gacontp_hb3(1,nnn,ii)=zapas_recv(24,i,iii)
7236           gacontp_hb3(2,nnn,ii)=zapas_recv(25,i,iii)
7237           gacontp_hb3(3,nnn,ii)=zapas_recv(26,i,iii)
7238         enddo
7239       enddo
7240       call flush(iout)
7241       if (lprn) then
7242         write (iout,'(a)') 'Contact function values after receive:'
7243         do i=nnt,nct-2
7244           write (iout,'(2i3,50(1x,i3,f5.2))')
7245      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
7246      &    j=1,num_cont_hb(i))
7247         enddo
7248         call flush(iout)
7249       endif
7250    30 continue
7251 #endif
7252       if (lprn) then
7253         write (iout,'(a)') 'Contact function values:'
7254         do i=nnt,nct-2
7255           write (iout,'(2i3,50(1x,i3,f5.2))')
7256      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
7257      &    j=1,num_cont_hb(i))
7258         enddo
7259       endif
7260       ecorr=0.0D0
7261 C Remove the loop below after debugging !!!
7262       do i=nnt,nct
7263         do j=1,3
7264           gradcorr(j,i)=0.0D0
7265           gradxorr(j,i)=0.0D0
7266         enddo
7267       enddo
7268 C Calculate the local-electrostatic correlation terms
7269       do i=min0(iatel_s,iturn4_start),max0(iatel_e,iturn3_end)
7270         i1=i+1
7271         num_conti=num_cont_hb(i)
7272         num_conti1=num_cont_hb(i+1)
7273         do jj=1,num_conti
7274           j=jcont_hb(jj,i)
7275           jp=iabs(j)
7276           do kk=1,num_conti1
7277             j1=jcont_hb(kk,i1)
7278             jp1=iabs(j1)
7279 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
7280 c     &         ' jj=',jj,' kk=',kk
7281             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
7282      &          .or. j.lt.0 .and. j1.gt.0) .and.
7283      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
7284 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
7285 C The system gains extra energy.
7286               ecorr=ecorr+ehbcorr(i,jp,i+1,jp1,jj,kk,0.72D0,0.32D0)
7287               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
7288      &            'ecorrh',i,j,ehbcorr(i,j,i+1,j1,jj,kk,0.72D0,0.32D0)
7289               n_corr=n_corr+1
7290             else if (j1.eq.j) then
7291 C Contacts I-J and I-(J+1) occur simultaneously.
7292 C The system loses extra energy.
7293 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
7294             endif
7295           enddo ! kk
7296           do kk=1,num_conti
7297             j1=jcont_hb(kk,i)
7298 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
7299 c    &         ' jj=',jj,' kk=',kk
7300             if (j1.eq.j+1) then
7301 C Contacts I-J and (I+1)-J occur simultaneously.
7302 C The system loses extra energy.
7303 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
7304             endif ! j1==j+1
7305           enddo ! kk
7306         enddo ! jj
7307       enddo ! i
7308       return
7309       end
7310 c------------------------------------------------------------------------------
7311       subroutine add_hb_contact(ii,jj,itask)
7312       implicit real*8 (a-h,o-z)
7313       include "DIMENSIONS"
7314       include "COMMON.IOUNITS"
7315       integer max_cont
7316       integer max_dim
7317       parameter (max_cont=maxconts)
7318       parameter (max_dim=26)
7319       include "COMMON.CONTACTS"
7320       double precision zapas(max_dim,maxconts,max_fg_procs),
7321      &  zapas_recv(max_dim,maxconts,max_fg_procs)
7322       common /przechowalnia/ zapas
7323       integer i,j,ii,jj,iproc,itask(4),nn
7324 c      write (iout,*) "itask",itask
7325       do i=1,2
7326         iproc=itask(i)
7327         if (iproc.gt.0) then
7328           do j=1,num_cont_hb(ii)
7329             jjc=jcont_hb(j,ii)
7330 c            write (iout,*) "i",ii," j",jj," jjc",jjc
7331             if (jjc.eq.jj) then
7332               ncont_sent(iproc)=ncont_sent(iproc)+1
7333               nn=ncont_sent(iproc)
7334               zapas(1,nn,iproc)=ii
7335               zapas(2,nn,iproc)=jjc
7336               zapas(3,nn,iproc)=facont_hb(j,ii)
7337               zapas(4,nn,iproc)=ees0p(j,ii)
7338               zapas(5,nn,iproc)=ees0m(j,ii)
7339               zapas(6,nn,iproc)=gacont_hbr(1,j,ii)
7340               zapas(7,nn,iproc)=gacont_hbr(2,j,ii)
7341               zapas(8,nn,iproc)=gacont_hbr(3,j,ii)
7342               zapas(9,nn,iproc)=gacontm_hb1(1,j,ii)
7343               zapas(10,nn,iproc)=gacontm_hb1(2,j,ii)
7344               zapas(11,nn,iproc)=gacontm_hb1(3,j,ii)
7345               zapas(12,nn,iproc)=gacontp_hb1(1,j,ii)
7346               zapas(13,nn,iproc)=gacontp_hb1(2,j,ii)
7347               zapas(14,nn,iproc)=gacontp_hb1(3,j,ii)
7348               zapas(15,nn,iproc)=gacontm_hb2(1,j,ii)
7349               zapas(16,nn,iproc)=gacontm_hb2(2,j,ii)
7350               zapas(17,nn,iproc)=gacontm_hb2(3,j,ii)
7351               zapas(18,nn,iproc)=gacontp_hb2(1,j,ii)
7352               zapas(19,nn,iproc)=gacontp_hb2(2,j,ii)
7353               zapas(20,nn,iproc)=gacontp_hb2(3,j,ii)
7354               zapas(21,nn,iproc)=gacontm_hb3(1,j,ii)
7355               zapas(22,nn,iproc)=gacontm_hb3(2,j,ii)
7356               zapas(23,nn,iproc)=gacontm_hb3(3,j,ii)
7357               zapas(24,nn,iproc)=gacontp_hb3(1,j,ii)
7358               zapas(25,nn,iproc)=gacontp_hb3(2,j,ii)
7359               zapas(26,nn,iproc)=gacontp_hb3(3,j,ii)
7360               exit
7361             endif
7362           enddo
7363         endif
7364       enddo
7365       return
7366       end
7367 c------------------------------------------------------------------------------
7368       subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,
7369      &  n_corr1)
7370 C This subroutine calculates multi-body contributions to hydrogen-bonding
7371       implicit real*8 (a-h,o-z)
7372       include 'DIMENSIONS'
7373       include 'COMMON.IOUNITS'
7374 #ifdef MPI
7375       include "mpif.h"
7376       parameter (max_cont=maxconts)
7377       parameter (max_dim=70)
7378       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
7379       double precision zapas(max_dim,maxconts,max_fg_procs),
7380      &  zapas_recv(max_dim,maxconts,max_fg_procs)
7381       common /przechowalnia/ zapas
7382       integer status(MPI_STATUS_SIZE),req(maxconts*2),
7383      &  status_array(MPI_STATUS_SIZE,maxconts*2)
7384 #endif
7385       include 'COMMON.SETUP'
7386       include 'COMMON.FFIELD'
7387       include 'COMMON.DERIV'
7388       include 'COMMON.LOCAL'
7389       include 'COMMON.INTERACT'
7390       include 'COMMON.CONTACTS'
7391       include 'COMMON.CHAIN'
7392       include 'COMMON.CONTROL'
7393       double precision gx(3),gx1(3)
7394       integer num_cont_hb_old(maxres)
7395       logical lprn,ldone
7396       double precision eello4,eello5,eelo6,eello_turn6
7397       external eello4,eello5,eello6,eello_turn6
7398 C Set lprn=.true. for debugging
7399       lprn=.false.
7400       eturn6=0.0d0
7401 #ifdef MPI
7402       do i=1,nres
7403         num_cont_hb_old(i)=num_cont_hb(i)
7404       enddo
7405       n_corr=0
7406       n_corr1=0
7407       if (nfgtasks.le.1) goto 30
7408       if (lprn) then
7409         write (iout,'(a)') 'Contact function values before RECEIVE:'
7410         do i=nnt,nct-2
7411           write (iout,'(2i3,50(1x,i2,f5.2))')
7412      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
7413      &    j=1,num_cont_hb(i))
7414         enddo
7415       endif
7416       call flush(iout)
7417       do i=1,ntask_cont_from
7418         ncont_recv(i)=0
7419       enddo
7420       do i=1,ntask_cont_to
7421         ncont_sent(i)=0
7422       enddo
7423 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
7424 c     & ntask_cont_to
7425 C Make the list of contacts to send to send to other procesors
7426       do i=iturn3_start,iturn3_end
7427 c        write (iout,*) "make contact list turn3",i," num_cont",
7428 c     &    num_cont_hb(i)
7429         call add_hb_contact_eello(i,i+2,iturn3_sent_local(1,i))
7430       enddo
7431       do i=iturn4_start,iturn4_end
7432 c        write (iout,*) "make contact list turn4",i," num_cont",
7433 c     &   num_cont_hb(i)
7434         call add_hb_contact_eello(i,i+3,iturn4_sent_local(1,i))
7435       enddo
7436       do ii=1,nat_sent
7437         i=iat_sent(ii)
7438 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
7439 c     &    num_cont_hb(i)
7440         do j=1,num_cont_hb(i)
7441         do k=1,4
7442           jjc=jcont_hb(j,i)
7443           iproc=iint_sent_local(k,jjc,ii)
7444 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
7445           if (iproc.ne.0) then
7446             ncont_sent(iproc)=ncont_sent(iproc)+1
7447             nn=ncont_sent(iproc)
7448             zapas(1,nn,iproc)=i
7449             zapas(2,nn,iproc)=jjc
7450             zapas(3,nn,iproc)=d_cont(j,i)
7451             ind=3
7452             do kk=1,3
7453               ind=ind+1
7454               zapas(ind,nn,iproc)=grij_hb_cont(kk,j,i)
7455             enddo
7456             do kk=1,2
7457               do ll=1,2
7458                 ind=ind+1
7459                 zapas(ind,nn,iproc)=a_chuj(ll,kk,j,i)
7460               enddo
7461             enddo
7462             do jj=1,5
7463               do kk=1,3
7464                 do ll=1,2
7465                   do mm=1,2
7466                     ind=ind+1
7467                     zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,i)
7468                   enddo
7469                 enddo
7470               enddo
7471             enddo
7472           endif
7473         enddo
7474         enddo
7475       enddo
7476       if (lprn) then
7477       write (iout,*)
7478      &  "Numbers of contacts to be sent to other processors",
7479      &  (ncont_sent(i),i=1,ntask_cont_to)
7480       write (iout,*) "Contacts sent"
7481       do ii=1,ntask_cont_to
7482         nn=ncont_sent(ii)
7483         iproc=itask_cont_to(ii)
7484         write (iout,*) nn," contacts to processor",iproc,
7485      &   " of CONT_TO_COMM group"
7486         do i=1,nn
7487           write(iout,'(2f5.0,10f10.5)')(zapas(j,i,ii),j=1,10)
7488         enddo
7489       enddo
7490       call flush(iout)
7491       endif
7492       CorrelType=477
7493       CorrelID=fg_rank+1
7494       CorrelType1=478
7495       CorrelID1=nfgtasks+fg_rank+1
7496       ireq=0
7497 C Receive the numbers of needed contacts from other processors
7498       do ii=1,ntask_cont_from
7499         iproc=itask_cont_from(ii)
7500         ireq=ireq+1
7501         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
7502      &    FG_COMM,req(ireq),IERR)
7503       enddo
7504 c      write (iout,*) "IRECV ended"
7505 c      call flush(iout)
7506 C Send the number of contacts needed by other processors
7507       do ii=1,ntask_cont_to
7508         iproc=itask_cont_to(ii)
7509         ireq=ireq+1
7510         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
7511      &    FG_COMM,req(ireq),IERR)
7512       enddo
7513 c      write (iout,*) "ISEND ended"
7514 c      write (iout,*) "number of requests (nn)",ireq
7515       call flush(iout)
7516       if (ireq.gt.0)
7517      &  call MPI_Waitall(ireq,req,status_array,ierr)
7518 c      write (iout,*)
7519 c     &  "Numbers of contacts to be received from other processors",
7520 c     &  (ncont_recv(i),i=1,ntask_cont_from)
7521 c      call flush(iout)
7522 C Receive contacts
7523       ireq=0
7524       do ii=1,ntask_cont_from
7525         iproc=itask_cont_from(ii)
7526         nn=ncont_recv(ii)
7527 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
7528 c     &   " of CONT_TO_COMM group"
7529         call flush(iout)
7530         if (nn.gt.0) then
7531           ireq=ireq+1
7532           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
7533      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
7534 c          write (iout,*) "ireq,req",ireq,req(ireq)
7535         endif
7536       enddo
7537 C Send the contacts to processors that need them
7538       do ii=1,ntask_cont_to
7539         iproc=itask_cont_to(ii)
7540         nn=ncont_sent(ii)
7541 c        write (iout,*) nn," contacts to processor",iproc,
7542 c     &   " of CONT_TO_COMM group"
7543         if (nn.gt.0) then
7544           ireq=ireq+1
7545           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
7546      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
7547 c          write (iout,*) "ireq,req",ireq,req(ireq)
7548 c          do i=1,nn
7549 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
7550 c          enddo
7551         endif
7552       enddo
7553 c      write (iout,*) "number of requests (contacts)",ireq
7554 c      write (iout,*) "req",(req(i),i=1,4)
7555 c      call flush(iout)
7556       if (ireq.gt.0)
7557      & call MPI_Waitall(ireq,req,status_array,ierr)
7558       do iii=1,ntask_cont_from
7559         iproc=itask_cont_from(iii)
7560         nn=ncont_recv(iii)
7561         if (lprn) then
7562         write (iout,*) "Received",nn," contacts from processor",iproc,
7563      &   " of CONT_FROM_COMM group"
7564         call flush(iout)
7565         do i=1,nn
7566           write(iout,'(2f5.0,10f10.5)')(zapas_recv(j,i,iii),j=1,10)
7567         enddo
7568         call flush(iout)
7569         endif
7570         do i=1,nn
7571           ii=zapas_recv(1,i,iii)
7572 c Flag the received contacts to prevent double-counting
7573           jj=-zapas_recv(2,i,iii)
7574 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
7575 c          call flush(iout)
7576           nnn=num_cont_hb(ii)+1
7577           num_cont_hb(ii)=nnn
7578           jcont_hb(nnn,ii)=jj
7579           d_cont(nnn,ii)=zapas_recv(3,i,iii)
7580           ind=3
7581           do kk=1,3
7582             ind=ind+1
7583             grij_hb_cont(kk,nnn,ii)=zapas_recv(ind,i,iii)
7584           enddo
7585           do kk=1,2
7586             do ll=1,2
7587               ind=ind+1
7588               a_chuj(ll,kk,nnn,ii)=zapas_recv(ind,i,iii)
7589             enddo
7590           enddo
7591           do jj=1,5
7592             do kk=1,3
7593               do ll=1,2
7594                 do mm=1,2
7595                   ind=ind+1
7596                   a_chuj_der(mm,ll,kk,jj,nnn,ii)=zapas_recv(ind,i,iii)
7597                 enddo
7598               enddo
7599             enddo
7600           enddo
7601         enddo
7602       enddo
7603       call flush(iout)
7604       if (lprn) then
7605         write (iout,'(a)') 'Contact function values after receive:'
7606         do i=nnt,nct-2
7607           write (iout,'(2i3,50(1x,i3,5f6.3))')
7608      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
7609      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
7610         enddo
7611         call flush(iout)
7612       endif
7613    30 continue
7614 #endif
7615       if (lprn) then
7616         write (iout,'(a)') 'Contact function values:'
7617         do i=nnt,nct-2
7618           write (iout,'(2i3,50(1x,i2,5f6.3))')
7619      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
7620      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
7621         enddo
7622       endif
7623       ecorr=0.0D0
7624       ecorr5=0.0d0
7625       ecorr6=0.0d0
7626 C Remove the loop below after debugging !!!
7627       do i=nnt,nct
7628         do j=1,3
7629           gradcorr(j,i)=0.0D0
7630           gradxorr(j,i)=0.0D0
7631         enddo
7632       enddo
7633 C Calculate the dipole-dipole interaction energies
7634       if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
7635       do i=iatel_s,iatel_e+1
7636         num_conti=num_cont_hb(i)
7637         do jj=1,num_conti
7638           j=jcont_hb(jj,i)
7639 #ifdef MOMENT
7640           call dipole(i,j,jj)
7641 #endif
7642         enddo
7643       enddo
7644       endif
7645 C Calculate the local-electrostatic correlation terms
7646 c                write (iout,*) "gradcorr5 in eello5 before loop"
7647 c                do iii=1,nres
7648 c                  write (iout,'(i5,3f10.5)')
7649 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
7650 c                enddo
7651       do i=min0(iatel_s,iturn4_start),max0(iatel_e+1,iturn3_end+1)
7652 c        write (iout,*) "corr loop i",i
7653         i1=i+1
7654         num_conti=num_cont_hb(i)
7655         num_conti1=num_cont_hb(i+1)
7656         do jj=1,num_conti
7657           j=jcont_hb(jj,i)
7658           jp=iabs(j)
7659           do kk=1,num_conti1
7660             j1=jcont_hb(kk,i1)
7661             jp1=iabs(j1)
7662 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
7663 c     &         ' jj=',jj,' kk=',kk
7664 c            if (j1.eq.j+1 .or. j1.eq.j-1) then
7665             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
7666      &          .or. j.lt.0 .and. j1.gt.0) .and.
7667      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
7668 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
7669 C The system gains extra energy.
7670               n_corr=n_corr+1
7671               sqd1=dsqrt(d_cont(jj,i))
7672               sqd2=dsqrt(d_cont(kk,i1))
7673               sred_geom = sqd1*sqd2
7674               IF (sred_geom.lt.cutoff_corr) THEN
7675                 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,
7676      &            ekont,fprimcont)
7677 cd               write (iout,*) 'i=',i,' j=',jp,' i1=',i1,' j1=',jp1,
7678 cd     &         ' jj=',jj,' kk=',kk
7679                 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
7680                 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
7681                 do l=1,3
7682                   g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
7683                   g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
7684                 enddo
7685                 n_corr1=n_corr1+1
7686 cd               write (iout,*) 'sred_geom=',sred_geom,
7687 cd     &          ' ekont=',ekont,' fprim=',fprimcont,
7688 cd     &          ' fac_prim1',fac_prim1,' fac_prim2',fac_prim2
7689 cd               write (iout,*) "g_contij",g_contij
7690 cd               write (iout,*) "grij_hb_cont i",grij_hb_cont(:,jj,i)
7691 cd               write (iout,*) "grij_hb_cont i1",grij_hb_cont(:,jj,i1)
7692                 call calc_eello(i,jp,i+1,jp1,jj,kk)
7693                 if (wcorr4.gt.0.0d0)
7694      &            ecorr=ecorr+eello4(i,jp,i+1,jp1,jj,kk)
7695                   if (energy_dec.and.wcorr4.gt.0.0d0)
7696      1                 write (iout,'(a6,4i5,0pf7.3)')
7697      2                'ecorr4',i,j,i+1,j1,eello4(i,jp,i+1,jp1,jj,kk)
7698 c                write (iout,*) "gradcorr5 before eello5"
7699 c                do iii=1,nres
7700 c                  write (iout,'(i5,3f10.5)')
7701 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
7702 c                enddo
7703                 if (wcorr5.gt.0.0d0)
7704      &            ecorr5=ecorr5+eello5(i,jp,i+1,jp1,jj,kk)
7705 c                write (iout,*) "gradcorr5 after eello5"
7706 c                do iii=1,nres
7707 c                  write (iout,'(i5,3f10.5)')
7708 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
7709 c                enddo
7710                   if (energy_dec.and.wcorr5.gt.0.0d0)
7711      1                 write (iout,'(a6,4i5,0pf7.3)')
7712      2                'ecorr5',i,j,i+1,j1,eello5(i,jp,i+1,jp1,jj,kk)
7713 cd                write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
7714 cd                write(2,*)'ijkl',i,jp,i+1,jp1
7715                 if (wcorr6.gt.0.0d0 .and. (jp.ne.i+4 .or. jp1.ne.i+3
7716      &               .or. wturn6.eq.0.0d0))then
7717 cd                  write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
7718                   ecorr6=ecorr6+eello6(i,jp,i+1,jp1,jj,kk)
7719                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
7720      1                'ecorr6',i,j,i+1,j1,eello6(i,jp,i+1,jp1,jj,kk)
7721 cd                write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
7722 cd     &            'ecorr6=',ecorr6
7723 cd                write (iout,'(4e15.5)') sred_geom,
7724 cd     &          dabs(eello4(i,jp,i+1,jp1,jj,kk)),
7725 cd     &          dabs(eello5(i,jp,i+1,jp1,jj,kk)),
7726 cd     &          dabs(eello6(i,jp,i+1,jp1,jj,kk))
7727                 else if (wturn6.gt.0.0d0
7728      &            .and. (jp.eq.i+4 .and. jp1.eq.i+3)) then
7729 cd                  write (iout,*) '******eturn6: i,j,i+1,j1',i,jip,i+1,jp1
7730                   eturn6=eturn6+eello_turn6(i,jj,kk)
7731                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
7732      1                 'eturn6',i,j,i+1,j1,eello_turn6(i,jj,kk)
7733 cd                  write (2,*) 'multibody_eello:eturn6',eturn6
7734                 endif
7735               ENDIF
7736 1111          continue
7737             endif
7738           enddo ! kk
7739         enddo ! jj
7740       enddo ! i
7741       do i=1,nres
7742         num_cont_hb(i)=num_cont_hb_old(i)
7743       enddo
7744 c                write (iout,*) "gradcorr5 in eello5"
7745 c                do iii=1,nres
7746 c                  write (iout,'(i5,3f10.5)')
7747 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
7748 c                enddo
7749       return
7750       end
7751 c------------------------------------------------------------------------------
7752       subroutine add_hb_contact_eello(ii,jj,itask)
7753       implicit real*8 (a-h,o-z)
7754       include "DIMENSIONS"
7755       include "COMMON.IOUNITS"
7756       integer max_cont
7757       integer max_dim
7758       parameter (max_cont=maxconts)
7759       parameter (max_dim=70)
7760       include "COMMON.CONTACTS"
7761       double precision zapas(max_dim,maxconts,max_fg_procs),
7762      &  zapas_recv(max_dim,maxconts,max_fg_procs)
7763       common /przechowalnia/ zapas
7764       integer i,j,ii,jj,iproc,itask(4),nn
7765 c      write (iout,*) "itask",itask
7766       do i=1,2
7767         iproc=itask(i)
7768         if (iproc.gt.0) then
7769           do j=1,num_cont_hb(ii)
7770             jjc=jcont_hb(j,ii)
7771 c            write (iout,*) "send turns i",ii," j",jj," jjc",jjc
7772             if (jjc.eq.jj) then
7773               ncont_sent(iproc)=ncont_sent(iproc)+1
7774               nn=ncont_sent(iproc)
7775               zapas(1,nn,iproc)=ii
7776               zapas(2,nn,iproc)=jjc
7777               zapas(3,nn,iproc)=d_cont(j,ii)
7778               ind=3
7779               do kk=1,3
7780                 ind=ind+1
7781                 zapas(ind,nn,iproc)=grij_hb_cont(kk,j,ii)
7782               enddo
7783               do kk=1,2
7784                 do ll=1,2
7785                   ind=ind+1
7786                   zapas(ind,nn,iproc)=a_chuj(ll,kk,j,ii)
7787                 enddo
7788               enddo
7789               do jj=1,5
7790                 do kk=1,3
7791                   do ll=1,2
7792                     do mm=1,2
7793                       ind=ind+1
7794                       zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,ii)
7795                     enddo
7796                   enddo
7797                 enddo
7798               enddo
7799               exit
7800             endif
7801           enddo
7802         endif
7803       enddo
7804       return
7805       end
7806 c------------------------------------------------------------------------------
7807       double precision function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
7808       implicit real*8 (a-h,o-z)
7809       include 'DIMENSIONS'
7810       include 'COMMON.IOUNITS'
7811       include 'COMMON.DERIV'
7812       include 'COMMON.INTERACT'
7813       include 'COMMON.CONTACTS'
7814       double precision gx(3),gx1(3)
7815       logical lprn
7816       lprn=.false.
7817       eij=facont_hb(jj,i)
7818       ekl=facont_hb(kk,k)
7819       ees0pij=ees0p(jj,i)
7820       ees0pkl=ees0p(kk,k)
7821       ees0mij=ees0m(jj,i)
7822       ees0mkl=ees0m(kk,k)
7823       ekont=eij*ekl
7824       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
7825 cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
7826 C Following 4 lines for diagnostics.
7827 cd    ees0pkl=0.0D0
7828 cd    ees0pij=1.0D0
7829 cd    ees0mkl=0.0D0
7830 cd    ees0mij=1.0D0
7831 c      write (iout,'(2(a,2i3,a,f10.5,a,2f10.5),a,f10.5,a,$)')
7832 c     & 'Contacts ',i,j,
7833 c     & ' eij',eij,' eesij',ees0pij,ees0mij,' and ',k,l
7834 c     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' energy=',ekont*ees,
7835 c     & 'gradcorr_long'
7836 C Calculate the multi-body contribution to energy.
7837 c      ecorr=ecorr+ekont*ees
7838 C Calculate multi-body contributions to the gradient.
7839       coeffpees0pij=coeffp*ees0pij
7840       coeffmees0mij=coeffm*ees0mij
7841       coeffpees0pkl=coeffp*ees0pkl
7842       coeffmees0mkl=coeffm*ees0mkl
7843       do ll=1,3
7844 cgrad        ghalfi=ees*ekl*gacont_hbr(ll,jj,i)
7845         gradcorr(ll,i)=gradcorr(ll,i)!+0.5d0*ghalfi
7846      &  -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+
7847      &  coeffmees0mkl*gacontm_hb1(ll,jj,i))
7848         gradcorr(ll,j)=gradcorr(ll,j)!+0.5d0*ghalfi
7849      &  -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+
7850      &  coeffmees0mkl*gacontm_hb2(ll,jj,i))
7851 cgrad        ghalfk=ees*eij*gacont_hbr(ll,kk,k)
7852         gradcorr(ll,k)=gradcorr(ll,k)!+0.5d0*ghalfk
7853      &  -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+
7854      &  coeffmees0mij*gacontm_hb1(ll,kk,k))
7855         gradcorr(ll,l)=gradcorr(ll,l)!+0.5d0*ghalfk
7856      &  -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+
7857      &  coeffmees0mij*gacontm_hb2(ll,kk,k))
7858         gradlongij=ees*ekl*gacont_hbr(ll,jj,i)-
7859      &     ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+
7860      &     coeffmees0mkl*gacontm_hb3(ll,jj,i))
7861         gradcorr_long(ll,j)=gradcorr_long(ll,j)+gradlongij
7862         gradcorr_long(ll,i)=gradcorr_long(ll,i)-gradlongij
7863         gradlongkl=ees*eij*gacont_hbr(ll,kk,k)-
7864      &     ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+
7865      &     coeffmees0mij*gacontm_hb3(ll,kk,k))
7866         gradcorr_long(ll,l)=gradcorr_long(ll,l)+gradlongkl
7867         gradcorr_long(ll,k)=gradcorr_long(ll,k)-gradlongkl
7868 c        write (iout,'(2f10.5,2x,$)') gradlongij,gradlongkl
7869       enddo
7870 c      write (iout,*)
7871 cgrad      do m=i+1,j-1
7872 cgrad        do ll=1,3
7873 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
7874 cgrad     &     ees*ekl*gacont_hbr(ll,jj,i)-
7875 cgrad     &     ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
7876 cgrad     &     coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
7877 cgrad        enddo
7878 cgrad      enddo
7879 cgrad      do m=k+1,l-1
7880 cgrad        do ll=1,3
7881 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
7882 cgrad     &     ees*eij*gacont_hbr(ll,kk,k)-
7883 cgrad     &     ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
7884 cgrad     &     coeffm*ees0mij*gacontm_hb3(ll,kk,k))
7885 cgrad        enddo
7886 cgrad      enddo
7887 c      write (iout,*) "ehbcorr",ekont*ees
7888       ehbcorr=ekont*ees
7889       return
7890       end
7891 #ifdef MOMENT
7892 C---------------------------------------------------------------------------
7893       subroutine dipole(i,j,jj)
7894       implicit real*8 (a-h,o-z)
7895       include 'DIMENSIONS'
7896       include 'COMMON.IOUNITS'
7897       include 'COMMON.CHAIN'
7898       include 'COMMON.FFIELD'
7899       include 'COMMON.DERIV'
7900       include 'COMMON.INTERACT'
7901       include 'COMMON.CONTACTS'
7902       include 'COMMON.TORSION'
7903       include 'COMMON.VAR'
7904       include 'COMMON.GEO'
7905       dimension dipi(2,2),dipj(2,2),dipderi(2),dipderj(2),auxvec(2),
7906      &  auxmat(2,2)
7907       iti1 = itortyp(itype(i+1))
7908       if (j.lt.nres-1) then
7909         itj1 = itortyp(itype(j+1))
7910       else
7911         itj1=ntortyp
7912       endif
7913       do iii=1,2
7914         dipi(iii,1)=Ub2(iii,i)
7915         dipderi(iii)=Ub2der(iii,i)
7916         dipi(iii,2)=b1(iii,i+1)
7917         dipj(iii,1)=Ub2(iii,j)
7918         dipderj(iii)=Ub2der(iii,j)
7919         dipj(iii,2)=b1(iii,j+1)
7920       enddo
7921       kkk=0
7922       do iii=1,2
7923         call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
7924         do jjj=1,2
7925           kkk=kkk+1
7926           dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
7927         enddo
7928       enddo
7929       do kkk=1,5
7930         do lll=1,3
7931           mmm=0
7932           do iii=1,2
7933             call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),
7934      &        auxvec(1))
7935             do jjj=1,2
7936               mmm=mmm+1
7937               dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
7938             enddo
7939           enddo
7940         enddo
7941       enddo
7942       call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
7943       call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
7944       do iii=1,2
7945         dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
7946       enddo
7947       call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
7948       do iii=1,2
7949         dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
7950       enddo
7951       return
7952       end
7953 #endif
7954 C---------------------------------------------------------------------------
7955       subroutine calc_eello(i,j,k,l,jj,kk)
7956 C
7957 C This subroutine computes matrices and vectors needed to calculate
7958 C the fourth-, fifth-, and sixth-order local-electrostatic terms.
7959 C
7960       implicit real*8 (a-h,o-z)
7961       include 'DIMENSIONS'
7962       include 'COMMON.IOUNITS'
7963       include 'COMMON.CHAIN'
7964       include 'COMMON.DERIV'
7965       include 'COMMON.INTERACT'
7966       include 'COMMON.CONTACTS'
7967       include 'COMMON.TORSION'
7968       include 'COMMON.VAR'
7969       include 'COMMON.GEO'
7970       include 'COMMON.FFIELD'
7971       double precision aa1(2,2),aa2(2,2),aa1t(2,2),aa2t(2,2),
7972      &  aa1tder(2,2,3,5),aa2tder(2,2,3,5),auxmat(2,2)
7973       logical lprn
7974       common /kutas/ lprn
7975 cd      write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
7976 cd     & ' jj=',jj,' kk=',kk
7977 cd      if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
7978 cd      write (iout,*) "a_chujij",((a_chuj(iii,jjj,jj,i),iii=1,2),jjj=1,2)
7979 cd      write (iout,*) "a_chujkl",((a_chuj(iii,jjj,kk,k),iii=1,2),jjj=1,2)
7980       do iii=1,2
7981         do jjj=1,2
7982           aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
7983           aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
7984         enddo
7985       enddo
7986       call transpose2(aa1(1,1),aa1t(1,1))
7987       call transpose2(aa2(1,1),aa2t(1,1))
7988       do kkk=1,5
7989         do lll=1,3
7990           call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),
7991      &      aa1tder(1,1,lll,kkk))
7992           call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),
7993      &      aa2tder(1,1,lll,kkk))
7994         enddo
7995       enddo
7996       if (l.eq.j+1) then
7997 C parallel orientation of the two CA-CA-CA frames.
7998         if (i.gt.1) then
7999           iti=itortyp(itype(i))
8000         else
8001           iti=ntortyp
8002         endif
8003         itk1=itortyp(itype(k+1))
8004         itj=itortyp(itype(j))
8005         if (l.lt.nres-1) then
8006           itl1=itortyp(itype(l+1))
8007         else
8008           itl1=ntortyp
8009         endif
8010 C A1 kernel(j+1) A2T
8011 cd        do iii=1,2
8012 cd          write (iout,'(3f10.5,5x,3f10.5)')
8013 cd     &     (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
8014 cd        enddo
8015         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
8016      &   aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),
8017      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
8018 C Following matrices are needed only for 6-th order cumulants
8019         IF (wcorr6.gt.0.0d0) THEN
8020         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
8021      &   aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),
8022      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
8023         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
8024      &   aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),
8025      &   Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
8026      &   ADtEAderx(1,1,1,1,1,1))
8027         lprn=.false.
8028         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
8029      &   aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),
8030      &   DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
8031      &   ADtEA1derx(1,1,1,1,1,1))
8032         ENDIF
8033 C End 6-th order cumulants
8034 cd        lprn=.false.
8035 cd        if (lprn) then
8036 cd        write (2,*) 'In calc_eello6'
8037 cd        do iii=1,2
8038 cd          write (2,*) 'iii=',iii
8039 cd          do kkk=1,5
8040 cd            write (2,*) 'kkk=',kkk
8041 cd            do jjj=1,2
8042 cd              write (2,'(3(2f10.5),5x)')
8043 cd     &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
8044 cd            enddo
8045 cd          enddo
8046 cd        enddo
8047 cd        endif
8048         call transpose2(EUgder(1,1,k),auxmat(1,1))
8049         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
8050         call transpose2(EUg(1,1,k),auxmat(1,1))
8051         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
8052         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
8053         do iii=1,2
8054           do kkk=1,5
8055             do lll=1,3
8056               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
8057      &          EAEAderx(1,1,lll,kkk,iii,1))
8058             enddo
8059           enddo
8060         enddo
8061 C A1T kernel(i+1) A2
8062         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
8063      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),
8064      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
8065 C Following matrices are needed only for 6-th order cumulants
8066         IF (wcorr6.gt.0.0d0) THEN
8067         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
8068      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),
8069      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
8070         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
8071      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),
8072      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
8073      &   ADtEAderx(1,1,1,1,1,2))
8074         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
8075      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),
8076      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
8077      &   ADtEA1derx(1,1,1,1,1,2))
8078         ENDIF
8079 C End 6-th order cumulants
8080         call transpose2(EUgder(1,1,l),auxmat(1,1))
8081         call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
8082         call transpose2(EUg(1,1,l),auxmat(1,1))
8083         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
8084         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
8085         do iii=1,2
8086           do kkk=1,5
8087             do lll=1,3
8088               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
8089      &          EAEAderx(1,1,lll,kkk,iii,2))
8090             enddo
8091           enddo
8092         enddo
8093 C AEAb1 and AEAb2
8094 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
8095 C They are needed only when the fifth- or the sixth-order cumulants are
8096 C indluded.
8097         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
8098         call transpose2(AEA(1,1,1),auxmat(1,1))
8099         call matvec2(auxmat(1,1),b1(1,i),AEAb1(1,1,1))
8100         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
8101         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
8102         call transpose2(AEAderg(1,1,1),auxmat(1,1))
8103         call matvec2(auxmat(1,1),b1(1,i),AEAb1derg(1,1,1))
8104         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
8105         call matvec2(AEA(1,1,1),b1(1,k+1),AEAb1(1,2,1))
8106         call matvec2(AEAderg(1,1,1),b1(1,k+1),AEAb1derg(1,2,1))
8107         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
8108         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
8109         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
8110         call transpose2(AEA(1,1,2),auxmat(1,1))
8111         call matvec2(auxmat(1,1),b1(1,j),AEAb1(1,1,2))
8112         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
8113         call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
8114         call transpose2(AEAderg(1,1,2),auxmat(1,1))
8115         call matvec2(auxmat(1,1),b1(1,j),AEAb1derg(1,1,2))
8116         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
8117         call matvec2(AEA(1,1,2),b1(1,l+1),AEAb1(1,2,2))
8118         call matvec2(AEAderg(1,1,2),b1(1,l+1),AEAb1derg(1,2,2))
8119         call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
8120         call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
8121         call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
8122 C Calculate the Cartesian derivatives of the vectors.
8123         do iii=1,2
8124           do kkk=1,5
8125             do lll=1,3
8126               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
8127               call matvec2(auxmat(1,1),b1(1,i),
8128      &          AEAb1derx(1,lll,kkk,iii,1,1))
8129               call matvec2(auxmat(1,1),Ub2(1,i),
8130      &          AEAb2derx(1,lll,kkk,iii,1,1))
8131               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
8132      &          AEAb1derx(1,lll,kkk,iii,2,1))
8133               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
8134      &          AEAb2derx(1,lll,kkk,iii,2,1))
8135               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
8136               call matvec2(auxmat(1,1),b1(1,j),
8137      &          AEAb1derx(1,lll,kkk,iii,1,2))
8138               call matvec2(auxmat(1,1),Ub2(1,j),
8139      &          AEAb2derx(1,lll,kkk,iii,1,2))
8140               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,l+1),
8141      &          AEAb1derx(1,lll,kkk,iii,2,2))
8142               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),
8143      &          AEAb2derx(1,lll,kkk,iii,2,2))
8144             enddo
8145           enddo
8146         enddo
8147         ENDIF
8148 C End vectors
8149       else
8150 C Antiparallel orientation of the two CA-CA-CA frames.
8151         if (i.gt.1) then
8152           iti=itortyp(itype(i))
8153         else
8154           iti=ntortyp
8155         endif
8156         itk1=itortyp(itype(k+1))
8157         itl=itortyp(itype(l))
8158         itj=itortyp(itype(j))
8159         if (j.lt.nres-1) then
8160           itj1=itortyp(itype(j+1))
8161         else
8162           itj1=ntortyp
8163         endif
8164 C A2 kernel(j-1)T A1T
8165         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
8166      &   aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),
8167      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
8168 C Following matrices are needed only for 6-th order cumulants
8169         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
8170      &     j.eq.i+4 .and. l.eq.i+3)) THEN
8171         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
8172      &   aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),
8173      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
8174         call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
8175      &   aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),
8176      &   Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
8177      &   ADtEAderx(1,1,1,1,1,1))
8178         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
8179      &   aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),
8180      &   DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
8181      &   ADtEA1derx(1,1,1,1,1,1))
8182         ENDIF
8183 C End 6-th order cumulants
8184         call transpose2(EUgder(1,1,k),auxmat(1,1))
8185         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
8186         call transpose2(EUg(1,1,k),auxmat(1,1))
8187         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
8188         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
8189         do iii=1,2
8190           do kkk=1,5
8191             do lll=1,3
8192               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
8193      &          EAEAderx(1,1,lll,kkk,iii,1))
8194             enddo
8195           enddo
8196         enddo
8197 C A2T kernel(i+1)T A1
8198         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
8199      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),
8200      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
8201 C Following matrices are needed only for 6-th order cumulants
8202         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
8203      &     j.eq.i+4 .and. l.eq.i+3)) THEN
8204         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
8205      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),
8206      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
8207         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
8208      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),
8209      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
8210      &   ADtEAderx(1,1,1,1,1,2))
8211         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
8212      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),
8213      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
8214      &   ADtEA1derx(1,1,1,1,1,2))
8215         ENDIF
8216 C End 6-th order cumulants
8217         call transpose2(EUgder(1,1,j),auxmat(1,1))
8218         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
8219         call transpose2(EUg(1,1,j),auxmat(1,1))
8220         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
8221         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
8222         do iii=1,2
8223           do kkk=1,5
8224             do lll=1,3
8225               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
8226      &          EAEAderx(1,1,lll,kkk,iii,2))
8227             enddo
8228           enddo
8229         enddo
8230 C AEAb1 and AEAb2
8231 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
8232 C They are needed only when the fifth- or the sixth-order cumulants are
8233 C indluded.
8234         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or.
8235      &    (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
8236         call transpose2(AEA(1,1,1),auxmat(1,1))
8237         call matvec2(auxmat(1,1),b1(1,i),AEAb1(1,1,1))
8238         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
8239         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
8240         call transpose2(AEAderg(1,1,1),auxmat(1,1))
8241         call matvec2(auxmat(1,1),b1(1,i),AEAb1derg(1,1,1))
8242         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
8243         call matvec2(AEA(1,1,1),b1(1,k+1),AEAb1(1,2,1))
8244         call matvec2(AEAderg(1,1,1),b1(1,k+1),AEAb1derg(1,2,1))
8245         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
8246         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
8247         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
8248         call transpose2(AEA(1,1,2),auxmat(1,1))
8249         call matvec2(auxmat(1,1),b1(1,j+1),AEAb1(1,1,2))
8250         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
8251         call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
8252         call transpose2(AEAderg(1,1,2),auxmat(1,1))
8253         call matvec2(auxmat(1,1),b1(1,l),AEAb1(1,1,2))
8254         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
8255         call matvec2(AEA(1,1,2),b1(1,j+1),AEAb1(1,2,2))
8256         call matvec2(AEAderg(1,1,2),b1(1,j+1),AEAb1derg(1,2,2))
8257         call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
8258         call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
8259         call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
8260 C Calculate the Cartesian derivatives of the vectors.
8261         do iii=1,2
8262           do kkk=1,5
8263             do lll=1,3
8264               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
8265               call matvec2(auxmat(1,1),b1(1,i),
8266      &          AEAb1derx(1,lll,kkk,iii,1,1))
8267               call matvec2(auxmat(1,1),Ub2(1,i),
8268      &          AEAb2derx(1,lll,kkk,iii,1,1))
8269               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
8270      &          AEAb1derx(1,lll,kkk,iii,2,1))
8271               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
8272      &          AEAb2derx(1,lll,kkk,iii,2,1))
8273               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
8274               call matvec2(auxmat(1,1),b1(1,l),
8275      &          AEAb1derx(1,lll,kkk,iii,1,2))
8276               call matvec2(auxmat(1,1),Ub2(1,l),
8277      &          AEAb2derx(1,lll,kkk,iii,1,2))
8278               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,j+1),
8279      &          AEAb1derx(1,lll,kkk,iii,2,2))
8280               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),
8281      &          AEAb2derx(1,lll,kkk,iii,2,2))
8282             enddo
8283           enddo
8284         enddo
8285         ENDIF
8286 C End vectors
8287       endif
8288       return
8289       end
8290 C---------------------------------------------------------------------------
8291       subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,
8292      &  KK,KKderg,AKA,AKAderg,AKAderx)
8293       implicit none
8294       integer nderg
8295       logical transp
8296       double precision aa1(2,2),aa2t(2,2),aa1derx(2,2,3,5),
8297      &  aa2tderx(2,2,3,5),KK(2,2),KKderg(2,2,nderg),AKA(2,2),
8298      &  AKAderg(2,2,nderg),AKAderx(2,2,3,5,2)
8299       integer iii,kkk,lll
8300       integer jjj,mmm
8301       logical lprn
8302       common /kutas/ lprn
8303       call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
8304       do iii=1,nderg
8305         call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,
8306      &    AKAderg(1,1,iii))
8307       enddo
8308 cd      if (lprn) write (2,*) 'In kernel'
8309       do kkk=1,5
8310 cd        if (lprn) write (2,*) 'kkk=',kkk
8311         do lll=1,3
8312           call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),
8313      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
8314 cd          if (lprn) then
8315 cd            write (2,*) 'lll=',lll
8316 cd            write (2,*) 'iii=1'
8317 cd            do jjj=1,2
8318 cd              write (2,'(3(2f10.5),5x)')
8319 cd     &        (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
8320 cd            enddo
8321 cd          endif
8322           call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),
8323      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
8324 cd          if (lprn) then
8325 cd            write (2,*) 'lll=',lll
8326 cd            write (2,*) 'iii=2'
8327 cd            do jjj=1,2
8328 cd              write (2,'(3(2f10.5),5x)')
8329 cd     &        (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
8330 cd            enddo
8331 cd          endif
8332         enddo
8333       enddo
8334       return
8335       end
8336 C---------------------------------------------------------------------------
8337       double precision function eello4(i,j,k,l,jj,kk)
8338       implicit real*8 (a-h,o-z)
8339       include 'DIMENSIONS'
8340       include 'COMMON.IOUNITS'
8341       include 'COMMON.CHAIN'
8342       include 'COMMON.DERIV'
8343       include 'COMMON.INTERACT'
8344       include 'COMMON.CONTACTS'
8345       include 'COMMON.TORSION'
8346       include 'COMMON.VAR'
8347       include 'COMMON.GEO'
8348       double precision pizda(2,2),ggg1(3),ggg2(3)
8349 cd      if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
8350 cd        eello4=0.0d0
8351 cd        return
8352 cd      endif
8353 cd      print *,'eello4:',i,j,k,l,jj,kk
8354 cd      write (2,*) 'i',i,' j',j,' k',k,' l',l
8355 cd      call checkint4(i,j,k,l,jj,kk,eel4_num)
8356 cold      eij=facont_hb(jj,i)
8357 cold      ekl=facont_hb(kk,k)
8358 cold      ekont=eij*ekl
8359       eel4=-EAEA(1,1,1)-EAEA(2,2,1)
8360 cd      eel41=-EAEA(1,1,2)-EAEA(2,2,2)
8361       gcorr_loc(k-1)=gcorr_loc(k-1)
8362      &   -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
8363       if (l.eq.j+1) then
8364         gcorr_loc(l-1)=gcorr_loc(l-1)
8365      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
8366       else
8367         gcorr_loc(j-1)=gcorr_loc(j-1)
8368      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
8369       endif
8370       do iii=1,2
8371         do kkk=1,5
8372           do lll=1,3
8373             derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1)
8374      &                        -EAEAderx(2,2,lll,kkk,iii,1)
8375 cd            derx(lll,kkk,iii)=0.0d0
8376           enddo
8377         enddo
8378       enddo
8379 cd      gcorr_loc(l-1)=0.0d0
8380 cd      gcorr_loc(j-1)=0.0d0
8381 cd      gcorr_loc(k-1)=0.0d0
8382 cd      eel4=1.0d0
8383 cd      write (iout,*)'Contacts have occurred for peptide groups',
8384 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l,
8385 cd     &  ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
8386       if (j.lt.nres-1) then
8387         j1=j+1
8388         j2=j-1
8389       else
8390         j1=j-1
8391         j2=j-2
8392       endif
8393       if (l.lt.nres-1) then
8394         l1=l+1
8395         l2=l-1
8396       else
8397         l1=l-1
8398         l2=l-2
8399       endif
8400       do ll=1,3
8401 cgrad        ggg1(ll)=eel4*g_contij(ll,1)
8402 cgrad        ggg2(ll)=eel4*g_contij(ll,2)
8403         glongij=eel4*g_contij(ll,1)+ekont*derx(ll,1,1)
8404         glongkl=eel4*g_contij(ll,2)+ekont*derx(ll,1,2)
8405 cgrad        ghalf=0.5d0*ggg1(ll)
8406         gradcorr(ll,i)=gradcorr(ll,i)+ekont*derx(ll,2,1)
8407         gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
8408         gradcorr(ll,j)=gradcorr(ll,j)+ekont*derx(ll,4,1)
8409         gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
8410         gradcorr_long(ll,j)=gradcorr_long(ll,j)+glongij
8411         gradcorr_long(ll,i)=gradcorr_long(ll,i)-glongij
8412 cgrad        ghalf=0.5d0*ggg2(ll)
8413         gradcorr(ll,k)=gradcorr(ll,k)+ekont*derx(ll,2,2)
8414         gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
8415         gradcorr(ll,l)=gradcorr(ll,l)+ekont*derx(ll,4,2)
8416         gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
8417         gradcorr_long(ll,l)=gradcorr_long(ll,l)+glongkl
8418         gradcorr_long(ll,k)=gradcorr_long(ll,k)-glongkl
8419       enddo
8420 cgrad      do m=i+1,j-1
8421 cgrad        do ll=1,3
8422 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
8423 cgrad        enddo
8424 cgrad      enddo
8425 cgrad      do m=k+1,l-1
8426 cgrad        do ll=1,3
8427 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
8428 cgrad        enddo
8429 cgrad      enddo
8430 cgrad      do m=i+2,j2
8431 cgrad        do ll=1,3
8432 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
8433 cgrad        enddo
8434 cgrad      enddo
8435 cgrad      do m=k+2,l2
8436 cgrad        do ll=1,3
8437 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
8438 cgrad        enddo
8439 cgrad      enddo
8440 cd      do iii=1,nres-3
8441 cd        write (2,*) iii,gcorr_loc(iii)
8442 cd      enddo
8443       eello4=ekont*eel4
8444 cd      write (2,*) 'ekont',ekont
8445 cd      write (iout,*) 'eello4',ekont*eel4
8446       return
8447       end
8448 C---------------------------------------------------------------------------
8449       double precision function eello5(i,j,k,l,jj,kk)
8450       implicit real*8 (a-h,o-z)
8451       include 'DIMENSIONS'
8452       include 'COMMON.IOUNITS'
8453       include 'COMMON.CHAIN'
8454       include 'COMMON.DERIV'
8455       include 'COMMON.INTERACT'
8456       include 'COMMON.CONTACTS'
8457       include 'COMMON.TORSION'
8458       include 'COMMON.VAR'
8459       include 'COMMON.GEO'
8460       double precision pizda(2,2),auxmat(2,2),auxmat1(2,2),vv(2)
8461       double precision ggg1(3),ggg2(3)
8462 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8463 C                                                                              C
8464 C                            Parallel chains                                   C
8465 C                                                                              C
8466 C          o             o                   o             o                   C
8467 C         /l\           / \             \   / \           / \   /              C
8468 C        /   \         /   \             \ /   \         /   \ /               C
8469 C       j| o |l1       | o |              o| o |         | o |o                C
8470 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
8471 C      \i/   \         /   \ /             /   \         /   \                 C
8472 C       o    k1             o                                                  C
8473 C         (I)          (II)                (III)          (IV)                 C
8474 C                                                                              C
8475 C      eello5_1        eello5_2            eello5_3       eello5_4             C
8476 C                                                                              C
8477 C                            Antiparallel chains                               C
8478 C                                                                              C
8479 C          o             o                   o             o                   C
8480 C         /j\           / \             \   / \           / \   /              C
8481 C        /   \         /   \             \ /   \         /   \ /               C
8482 C      j1| o |l        | o |              o| o |         | o |o                C
8483 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
8484 C      \i/   \         /   \ /             /   \         /   \                 C
8485 C       o     k1            o                                                  C
8486 C         (I)          (II)                (III)          (IV)                 C
8487 C                                                                              C
8488 C      eello5_1        eello5_2            eello5_3       eello5_4             C
8489 C                                                                              C
8490 C o denotes a local interaction, vertical lines an electrostatic interaction.  C
8491 C                                                                              C
8492 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8493 cd      if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
8494 cd        eello5=0.0d0
8495 cd        return
8496 cd      endif
8497 cd      write (iout,*)
8498 cd     &   'EELLO5: Contacts have occurred for peptide groups',i,j,
8499 cd     &   ' and',k,l
8500       itk=itortyp(itype(k))
8501       itl=itortyp(itype(l))
8502       itj=itortyp(itype(j))
8503       eello5_1=0.0d0
8504       eello5_2=0.0d0
8505       eello5_3=0.0d0
8506       eello5_4=0.0d0
8507 cd      call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
8508 cd     &   eel5_3_num,eel5_4_num)
8509       do iii=1,2
8510         do kkk=1,5
8511           do lll=1,3
8512             derx(lll,kkk,iii)=0.0d0
8513           enddo
8514         enddo
8515       enddo
8516 cd      eij=facont_hb(jj,i)
8517 cd      ekl=facont_hb(kk,k)
8518 cd      ekont=eij*ekl
8519 cd      write (iout,*)'Contacts have occurred for peptide groups',
8520 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l
8521 cd      goto 1111
8522 C Contribution from the graph I.
8523 cd      write (2,*) 'AEA  ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
8524 cd      write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
8525       call transpose2(EUg(1,1,k),auxmat(1,1))
8526       call matmat2(AEA(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       eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k))
8530      & +0.5d0*scalar2(vv(1),Dtobr2(1,i))
8531 C Explicit gradient in virtual-dihedral angles.
8532       if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1)
8533      & +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k))
8534      & +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
8535       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8536       call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
8537       vv(1)=pizda(1,1)-pizda(2,2)
8538       vv(2)=pizda(1,2)+pizda(2,1)
8539       g_corr5_loc(k-1)=g_corr5_loc(k-1)
8540      & +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k))
8541      & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
8542       call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
8543       vv(1)=pizda(1,1)-pizda(2,2)
8544       vv(2)=pizda(1,2)+pizda(2,1)
8545       if (l.eq.j+1) then
8546         if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1)
8547      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
8548      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
8549       else
8550         if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1)
8551      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
8552      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
8553       endif
8554 C Cartesian gradient
8555       do iii=1,2
8556         do kkk=1,5
8557           do lll=1,3
8558             call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),
8559      &        pizda(1,1))
8560             vv(1)=pizda(1,1)-pizda(2,2)
8561             vv(2)=pizda(1,2)+pizda(2,1)
8562             derx(lll,kkk,iii)=derx(lll,kkk,iii)
8563      &       +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k))
8564      &       +0.5d0*scalar2(vv(1),Dtobr2(1,i))
8565           enddo
8566         enddo
8567       enddo
8568 c      goto 1112
8569 c1111  continue
8570 C Contribution from graph II
8571       call transpose2(EE(1,1,itk),auxmat(1,1))
8572       call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
8573       vv(1)=pizda(1,1)+pizda(2,2)
8574       vv(2)=pizda(2,1)-pizda(1,2)
8575       eello5_2=scalar2(AEAb1(1,2,1),b1(1,k))
8576      & -0.5d0*scalar2(vv(1),Ctobr(1,k))
8577 C Explicit gradient in virtual-dihedral angles.
8578       g_corr5_loc(k-1)=g_corr5_loc(k-1)
8579      & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
8580       call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
8581       vv(1)=pizda(1,1)+pizda(2,2)
8582       vv(2)=pizda(2,1)-pizda(1,2)
8583       if (l.eq.j+1) then
8584         g_corr5_loc(l-1)=g_corr5_loc(l-1)
8585      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,k))
8586      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
8587       else
8588         g_corr5_loc(j-1)=g_corr5_loc(j-1)
8589      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,k))
8590      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
8591       endif
8592 C Cartesian gradient
8593       do iii=1,2
8594         do kkk=1,5
8595           do lll=1,3
8596             call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
8597      &        pizda(1,1))
8598             vv(1)=pizda(1,1)+pizda(2,2)
8599             vv(2)=pizda(2,1)-pizda(1,2)
8600             derx(lll,kkk,iii)=derx(lll,kkk,iii)
8601      &       +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,k))
8602      &       -0.5d0*scalar2(vv(1),Ctobr(1,k))
8603           enddo
8604         enddo
8605       enddo
8606 cd      goto 1112
8607 cd1111  continue
8608       if (l.eq.j+1) then
8609 cd        goto 1110
8610 C Parallel orientation
8611 C Contribution from graph III
8612         call transpose2(EUg(1,1,l),auxmat(1,1))
8613         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
8614         vv(1)=pizda(1,1)-pizda(2,2)
8615         vv(2)=pizda(1,2)+pizda(2,1)
8616         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l))
8617      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j))
8618 C Explicit gradient in virtual-dihedral angles.
8619         g_corr5_loc(j-1)=g_corr5_loc(j-1)
8620      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l))
8621      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
8622         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
8623         vv(1)=pizda(1,1)-pizda(2,2)
8624         vv(2)=pizda(1,2)+pizda(2,1)
8625         g_corr5_loc(k-1)=g_corr5_loc(k-1)
8626      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l))
8627      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
8628         call transpose2(EUgder(1,1,l),auxmat1(1,1))
8629         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
8630         vv(1)=pizda(1,1)-pizda(2,2)
8631         vv(2)=pizda(1,2)+pizda(2,1)
8632         g_corr5_loc(l-1)=g_corr5_loc(l-1)
8633      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l))
8634      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
8635 C Cartesian gradient
8636         do iii=1,2
8637           do kkk=1,5
8638             do lll=1,3
8639               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
8640      &          pizda(1,1))
8641               vv(1)=pizda(1,1)-pizda(2,2)
8642               vv(2)=pizda(1,2)+pizda(2,1)
8643               derx(lll,kkk,iii)=derx(lll,kkk,iii)
8644      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l))
8645      &         +0.5d0*scalar2(vv(1),Dtobr2(1,j))
8646             enddo
8647           enddo
8648         enddo
8649 cd        goto 1112
8650 C Contribution from graph IV
8651 cd1110    continue
8652         call transpose2(EE(1,1,itl),auxmat(1,1))
8653         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
8654         vv(1)=pizda(1,1)+pizda(2,2)
8655         vv(2)=pizda(2,1)-pizda(1,2)
8656         eello5_4=scalar2(AEAb1(1,2,2),b1(1,l))
8657      &   -0.5d0*scalar2(vv(1),Ctobr(1,l))
8658 C Explicit gradient in virtual-dihedral angles.
8659         g_corr5_loc(l-1)=g_corr5_loc(l-1)
8660      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
8661         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
8662         vv(1)=pizda(1,1)+pizda(2,2)
8663         vv(2)=pizda(2,1)-pizda(1,2)
8664         g_corr5_loc(k-1)=g_corr5_loc(k-1)
8665      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,l))
8666      &   -0.5d0*scalar2(vv(1),Ctobr(1,l)))
8667 C Cartesian gradient
8668         do iii=1,2
8669           do kkk=1,5
8670             do lll=1,3
8671               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
8672      &          pizda(1,1))
8673               vv(1)=pizda(1,1)+pizda(2,2)
8674               vv(2)=pizda(2,1)-pizda(1,2)
8675               derx(lll,kkk,iii)=derx(lll,kkk,iii)
8676      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,l))
8677      &         -0.5d0*scalar2(vv(1),Ctobr(1,l))
8678             enddo
8679           enddo
8680         enddo
8681       else
8682 C Antiparallel orientation
8683 C Contribution from graph III
8684 c        goto 1110
8685         call transpose2(EUg(1,1,j),auxmat(1,1))
8686         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
8687         vv(1)=pizda(1,1)-pizda(2,2)
8688         vv(2)=pizda(1,2)+pizda(2,1)
8689         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j))
8690      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l))
8691 C Explicit gradient in virtual-dihedral angles.
8692         g_corr5_loc(l-1)=g_corr5_loc(l-1)
8693      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j))
8694      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
8695         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
8696         vv(1)=pizda(1,1)-pizda(2,2)
8697         vv(2)=pizda(1,2)+pizda(2,1)
8698         g_corr5_loc(k-1)=g_corr5_loc(k-1)
8699      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j))
8700      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
8701         call transpose2(EUgder(1,1,j),auxmat1(1,1))
8702         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
8703         vv(1)=pizda(1,1)-pizda(2,2)
8704         vv(2)=pizda(1,2)+pizda(2,1)
8705         g_corr5_loc(j-1)=g_corr5_loc(j-1)
8706      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j))
8707      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
8708 C Cartesian gradient
8709         do iii=1,2
8710           do kkk=1,5
8711             do lll=1,3
8712               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
8713      &          pizda(1,1))
8714               vv(1)=pizda(1,1)-pizda(2,2)
8715               vv(2)=pizda(1,2)+pizda(2,1)
8716               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
8717      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j))
8718      &         +0.5d0*scalar2(vv(1),Dtobr2(1,l))
8719             enddo
8720           enddo
8721         enddo
8722 cd        goto 1112
8723 C Contribution from graph IV
8724 1110    continue
8725         call transpose2(EE(1,1,itj),auxmat(1,1))
8726         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
8727         vv(1)=pizda(1,1)+pizda(2,2)
8728         vv(2)=pizda(2,1)-pizda(1,2)
8729         eello5_4=scalar2(AEAb1(1,2,2),b1(1,j))
8730      &   -0.5d0*scalar2(vv(1),Ctobr(1,j))
8731 C Explicit gradient in virtual-dihedral angles.
8732         g_corr5_loc(j-1)=g_corr5_loc(j-1)
8733      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
8734         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
8735         vv(1)=pizda(1,1)+pizda(2,2)
8736         vv(2)=pizda(2,1)-pizda(1,2)
8737         g_corr5_loc(k-1)=g_corr5_loc(k-1)
8738      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,j))
8739      &   -0.5d0*scalar2(vv(1),Ctobr(1,j)))
8740 C Cartesian gradient
8741         do iii=1,2
8742           do kkk=1,5
8743             do lll=1,3
8744               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
8745      &          pizda(1,1))
8746               vv(1)=pizda(1,1)+pizda(2,2)
8747               vv(2)=pizda(2,1)-pizda(1,2)
8748               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
8749      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,j))
8750      &         -0.5d0*scalar2(vv(1),Ctobr(1,j))
8751             enddo
8752           enddo
8753         enddo
8754       endif
8755 1112  continue
8756       eel5=eello5_1+eello5_2+eello5_3+eello5_4
8757 cd      if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
8758 cd        write (2,*) 'ijkl',i,j,k,l
8759 cd        write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
8760 cd     &     ' eello5_3',eello5_3,' eello5_4',eello5_4
8761 cd      endif
8762 cd      write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
8763 cd      write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
8764 cd      write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
8765 cd      write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
8766       if (j.lt.nres-1) then
8767         j1=j+1
8768         j2=j-1
8769       else
8770         j1=j-1
8771         j2=j-2
8772       endif
8773       if (l.lt.nres-1) then
8774         l1=l+1
8775         l2=l-1
8776       else
8777         l1=l-1
8778         l2=l-2
8779       endif
8780 cd      eij=1.0d0
8781 cd      ekl=1.0d0
8782 cd      ekont=1.0d0
8783 cd      write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
8784 C 2/11/08 AL Gradients over DC's connecting interacting sites will be
8785 C        summed up outside the subrouine as for the other subroutines
8786 C        handling long-range interactions. The old code is commented out
8787 C        with "cgrad" to keep track of changes.
8788       do ll=1,3
8789 cgrad        ggg1(ll)=eel5*g_contij(ll,1)
8790 cgrad        ggg2(ll)=eel5*g_contij(ll,2)
8791         gradcorr5ij=eel5*g_contij(ll,1)+ekont*derx(ll,1,1)
8792         gradcorr5kl=eel5*g_contij(ll,2)+ekont*derx(ll,1,2)
8793 c        write (iout,'(a,3i3,a,5f8.3,2i3,a,5f8.3,a,f8.3)')
8794 c     &   "ecorr5",ll,i,j," derx",derx(ll,2,1),derx(ll,3,1),derx(ll,4,1),
8795 c     &   derx(ll,5,1),k,l," derx",derx(ll,2,2),derx(ll,3,2),
8796 c     &   derx(ll,4,2),derx(ll,5,2)," ekont",ekont
8797 c        write (iout,'(a,3i3,a,3f8.3,2i3,a,3f8.3)')
8798 c     &   "ecorr5",ll,i,j," gradcorr5",g_contij(ll,1),derx(ll,1,1),
8799 c     &   gradcorr5ij,
8800 c     &   k,l," gradcorr5",g_contij(ll,2),derx(ll,1,2),gradcorr5kl
8801 cold        ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
8802 cgrad        ghalf=0.5d0*ggg1(ll)
8803 cd        ghalf=0.0d0
8804         gradcorr5(ll,i)=gradcorr5(ll,i)+ekont*derx(ll,2,1)
8805         gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
8806         gradcorr5(ll,j)=gradcorr5(ll,j)+ekont*derx(ll,4,1)
8807         gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
8808         gradcorr5_long(ll,j)=gradcorr5_long(ll,j)+gradcorr5ij
8809         gradcorr5_long(ll,i)=gradcorr5_long(ll,i)-gradcorr5ij
8810 cold        ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
8811 cgrad        ghalf=0.5d0*ggg2(ll)
8812 cd        ghalf=0.0d0
8813         gradcorr5(ll,k)=gradcorr5(ll,k)+ghalf+ekont*derx(ll,2,2)
8814         gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
8815         gradcorr5(ll,l)=gradcorr5(ll,l)+ghalf+ekont*derx(ll,4,2)
8816         gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
8817         gradcorr5_long(ll,l)=gradcorr5_long(ll,l)+gradcorr5kl
8818         gradcorr5_long(ll,k)=gradcorr5_long(ll,k)-gradcorr5kl
8819       enddo
8820 cd      goto 1112
8821 cgrad      do m=i+1,j-1
8822 cgrad        do ll=1,3
8823 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
8824 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
8825 cgrad        enddo
8826 cgrad      enddo
8827 cgrad      do m=k+1,l-1
8828 cgrad        do ll=1,3
8829 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
8830 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
8831 cgrad        enddo
8832 cgrad      enddo
8833 c1112  continue
8834 cgrad      do m=i+2,j2
8835 cgrad        do ll=1,3
8836 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
8837 cgrad        enddo
8838 cgrad      enddo
8839 cgrad      do m=k+2,l2
8840 cgrad        do ll=1,3
8841 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
8842 cgrad        enddo
8843 cgrad      enddo
8844 cd      do iii=1,nres-3
8845 cd        write (2,*) iii,g_corr5_loc(iii)
8846 cd      enddo
8847       eello5=ekont*eel5
8848 cd      write (2,*) 'ekont',ekont
8849 cd      write (iout,*) 'eello5',ekont*eel5
8850       return
8851       end
8852 c--------------------------------------------------------------------------
8853       double precision function eello6(i,j,k,l,jj,kk)
8854       implicit real*8 (a-h,o-z)
8855       include 'DIMENSIONS'
8856       include 'COMMON.IOUNITS'
8857       include 'COMMON.CHAIN'
8858       include 'COMMON.DERIV'
8859       include 'COMMON.INTERACT'
8860       include 'COMMON.CONTACTS'
8861       include 'COMMON.TORSION'
8862       include 'COMMON.VAR'
8863       include 'COMMON.GEO'
8864       include 'COMMON.FFIELD'
8865       double precision ggg1(3),ggg2(3)
8866 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
8867 cd        eello6=0.0d0
8868 cd        return
8869 cd      endif
8870 cd      write (iout,*)
8871 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
8872 cd     &   ' and',k,l
8873       eello6_1=0.0d0
8874       eello6_2=0.0d0
8875       eello6_3=0.0d0
8876       eello6_4=0.0d0
8877       eello6_5=0.0d0
8878       eello6_6=0.0d0
8879 cd      call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
8880 cd     &   eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
8881       do iii=1,2
8882         do kkk=1,5
8883           do lll=1,3
8884             derx(lll,kkk,iii)=0.0d0
8885           enddo
8886         enddo
8887       enddo
8888 cd      eij=facont_hb(jj,i)
8889 cd      ekl=facont_hb(kk,k)
8890 cd      ekont=eij*ekl
8891 cd      eij=1.0d0
8892 cd      ekl=1.0d0
8893 cd      ekont=1.0d0
8894       if (l.eq.j+1) then
8895         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
8896         eello6_2=eello6_graph1(j,i,l,k,2,.false.)
8897         eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
8898         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
8899         eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
8900         eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
8901       else
8902         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
8903         eello6_2=eello6_graph1(l,k,j,i,2,.true.)
8904         eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
8905         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
8906         if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
8907           eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
8908         else
8909           eello6_5=0.0d0
8910         endif
8911         eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
8912       endif
8913 C If turn contributions are considered, they will be handled separately.
8914       eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
8915 cd      write(iout,*) 'eello6_1',eello6_1!,' eel6_1_num',16*eel6_1_num
8916 cd      write(iout,*) 'eello6_2',eello6_2!,' eel6_2_num',16*eel6_2_num
8917 cd      write(iout,*) 'eello6_3',eello6_3!,' eel6_3_num',16*eel6_3_num
8918 cd      write(iout,*) 'eello6_4',eello6_4!,' eel6_4_num',16*eel6_4_num
8919 cd      write(iout,*) 'eello6_5',eello6_5!,' eel6_5_num',16*eel6_5_num
8920 cd      write(iout,*) 'eello6_6',eello6_6!,' eel6_6_num',16*eel6_6_num
8921 cd      goto 1112
8922       if (j.lt.nres-1) then
8923         j1=j+1
8924         j2=j-1
8925       else
8926         j1=j-1
8927         j2=j-2
8928       endif
8929       if (l.lt.nres-1) then
8930         l1=l+1
8931         l2=l-1
8932       else
8933         l1=l-1
8934         l2=l-2
8935       endif
8936       do ll=1,3
8937 cgrad        ggg1(ll)=eel6*g_contij(ll,1)
8938 cgrad        ggg2(ll)=eel6*g_contij(ll,2)
8939 cold        ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
8940 cgrad        ghalf=0.5d0*ggg1(ll)
8941 cd        ghalf=0.0d0
8942         gradcorr6ij=eel6*g_contij(ll,1)+ekont*derx(ll,1,1)
8943         gradcorr6kl=eel6*g_contij(ll,2)+ekont*derx(ll,1,2)
8944         gradcorr6(ll,i)=gradcorr6(ll,i)+ekont*derx(ll,2,1)
8945         gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
8946         gradcorr6(ll,j)=gradcorr6(ll,j)+ekont*derx(ll,4,1)
8947         gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
8948         gradcorr6_long(ll,j)=gradcorr6_long(ll,j)+gradcorr6ij
8949         gradcorr6_long(ll,i)=gradcorr6_long(ll,i)-gradcorr6ij
8950 cgrad        ghalf=0.5d0*ggg2(ll)
8951 cold        ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
8952 cd        ghalf=0.0d0
8953         gradcorr6(ll,k)=gradcorr6(ll,k)+ekont*derx(ll,2,2)
8954         gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
8955         gradcorr6(ll,l)=gradcorr6(ll,l)+ekont*derx(ll,4,2)
8956         gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
8957         gradcorr6_long(ll,l)=gradcorr6_long(ll,l)+gradcorr6kl
8958         gradcorr6_long(ll,k)=gradcorr6_long(ll,k)-gradcorr6kl
8959       enddo
8960 cd      goto 1112
8961 cgrad      do m=i+1,j-1
8962 cgrad        do ll=1,3
8963 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
8964 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
8965 cgrad        enddo
8966 cgrad      enddo
8967 cgrad      do m=k+1,l-1
8968 cgrad        do ll=1,3
8969 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
8970 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
8971 cgrad        enddo
8972 cgrad      enddo
8973 cgrad1112  continue
8974 cgrad      do m=i+2,j2
8975 cgrad        do ll=1,3
8976 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
8977 cgrad        enddo
8978 cgrad      enddo
8979 cgrad      do m=k+2,l2
8980 cgrad        do ll=1,3
8981 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
8982 cgrad        enddo
8983 cgrad      enddo
8984 cd      do iii=1,nres-3
8985 cd        write (2,*) iii,g_corr6_loc(iii)
8986 cd      enddo
8987       eello6=ekont*eel6
8988 cd      write (2,*) 'ekont',ekont
8989 cd      write (iout,*) 'eello6',ekont*eel6
8990       return
8991       end
8992 c--------------------------------------------------------------------------
8993       double precision function eello6_graph1(i,j,k,l,imat,swap)
8994       implicit real*8 (a-h,o-z)
8995       include 'DIMENSIONS'
8996       include 'COMMON.IOUNITS'
8997       include 'COMMON.CHAIN'
8998       include 'COMMON.DERIV'
8999       include 'COMMON.INTERACT'
9000       include 'COMMON.CONTACTS'
9001       include 'COMMON.TORSION'
9002       include 'COMMON.VAR'
9003       include 'COMMON.GEO'
9004       double precision vv(2),vv1(2),pizda(2,2),auxmat(2,2),pizda1(2,2)
9005       logical swap
9006       logical lprn
9007       common /kutas/ lprn
9008 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9009 C                                                                              C
9010 C      Parallel       Antiparallel                                             C
9011 C                                                                              C
9012 C          o             o                                                     C
9013 C         /l\           /j\                                                    C
9014 C        /   \         /   \                                                   C
9015 C       /| o |         | o |\                                                  C
9016 C     \ j|/k\|  /   \  |/k\|l /                                                C
9017 C      \ /   \ /     \ /   \ /                                                 C
9018 C       o     o       o     o                                                  C
9019 C       i             i                                                        C
9020 C                                                                              C
9021 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9022       itk=itortyp(itype(k))
9023       s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
9024       s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
9025       s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
9026       call transpose2(EUgC(1,1,k),auxmat(1,1))
9027       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
9028       vv1(1)=pizda1(1,1)-pizda1(2,2)
9029       vv1(2)=pizda1(1,2)+pizda1(2,1)
9030       s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
9031       vv(1)=AEAb1(1,2,imat)*b1(1,k)-AEAb1(2,2,imat)*b1(2,k)
9032       vv(2)=AEAb1(1,2,imat)*b1(2,k)+AEAb1(2,2,imat)*b1(1,k)
9033       s5=scalar2(vv(1),Dtobr2(1,i))
9034 cd      write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
9035       eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
9036       if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1)
9037      & -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i))
9038      & -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k))
9039      & +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k))
9040      & +0.5d0*scalar2(vv1(1),Dtobr2der(1,i))
9041      & +scalar2(vv(1),Dtobr2der(1,i)))
9042       call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
9043       vv1(1)=pizda1(1,1)-pizda1(2,2)
9044       vv1(2)=pizda1(1,2)+pizda1(2,1)
9045       vv(1)=AEAb1derg(1,2,imat)*b1(1,k)-AEAb1derg(2,2,imat)*b1(2,k)
9046       vv(2)=AEAb1derg(1,2,imat)*b1(2,k)+AEAb1derg(2,2,imat)*b1(1,k)
9047       if (l.eq.j+1) then
9048         g_corr6_loc(l-1)=g_corr6_loc(l-1)
9049      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
9050      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
9051      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
9052      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
9053       else
9054         g_corr6_loc(j-1)=g_corr6_loc(j-1)
9055      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
9056      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
9057      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
9058      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
9059       endif
9060       call transpose2(EUgCder(1,1,k),auxmat(1,1))
9061       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
9062       vv1(1)=pizda1(1,1)-pizda1(2,2)
9063       vv1(2)=pizda1(1,2)+pizda1(2,1)
9064       if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1)
9065      & +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k))
9066      & +scalar2(AEAb2(1,1,imat),CUgb2der(1,k))
9067      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
9068       do iii=1,2
9069         if (swap) then
9070           ind=3-iii
9071         else
9072           ind=iii
9073         endif
9074         do kkk=1,5
9075           do lll=1,3
9076             s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
9077             s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
9078             s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
9079             call transpose2(EUgC(1,1,k),auxmat(1,1))
9080             call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
9081      &        pizda1(1,1))
9082             vv1(1)=pizda1(1,1)-pizda1(2,2)
9083             vv1(2)=pizda1(1,2)+pizda1(2,1)
9084             s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
9085             vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,k)
9086      &       -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,k)
9087             vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,k)
9088      &       +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,k)
9089             s5=scalar2(vv(1),Dtobr2(1,i))
9090             derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
9091           enddo
9092         enddo
9093       enddo
9094       return
9095       end
9096 c----------------------------------------------------------------------------
9097       double precision function eello6_graph2(i,j,k,l,jj,kk,swap)
9098       implicit real*8 (a-h,o-z)
9099       include 'DIMENSIONS'
9100       include 'COMMON.IOUNITS'
9101       include 'COMMON.CHAIN'
9102       include 'COMMON.DERIV'
9103       include 'COMMON.INTERACT'
9104       include 'COMMON.CONTACTS'
9105       include 'COMMON.TORSION'
9106       include 'COMMON.VAR'
9107       include 'COMMON.GEO'
9108       logical swap
9109       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
9110      & auxvec1(2),auxvec2(2),auxmat1(2,2)
9111       logical lprn
9112       common /kutas/ lprn
9113 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9114 C                                                                              C
9115 C      Parallel       Antiparallel                                             C
9116 C                                                                              C
9117 C          o             o                                                     C
9118 C     \   /l\           /j\   /                                                C
9119 C      \ /   \         /   \ /                                                 C
9120 C       o| o |         | o |o                                                  C
9121 C     \ j|/k\|      \  |/k\|l                                                  C
9122 C      \ /   \       \ /   \                                                   C
9123 C       o             o                                                        C
9124 C       i             i                                                        C
9125 C                                                                              C
9126 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9127 cd      write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
9128 C AL 7/4/01 s1 would occur in the sixth-order moment,
9129 C           but not in a cluster cumulant
9130 #ifdef MOMENT
9131       s1=dip(1,jj,i)*dip(1,kk,k)
9132 #endif
9133       call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
9134       s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
9135       call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
9136       s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
9137       call transpose2(EUg(1,1,k),auxmat(1,1))
9138       call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
9139       vv(1)=pizda(1,1)-pizda(2,2)
9140       vv(2)=pizda(1,2)+pizda(2,1)
9141       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
9142 cd      write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
9143 #ifdef MOMENT
9144       eello6_graph2=-(s1+s2+s3+s4)
9145 #else
9146       eello6_graph2=-(s2+s3+s4)
9147 #endif
9148 c      eello6_graph2=-s3
9149 C Derivatives in gamma(i-1)
9150       if (i.gt.1) then
9151 #ifdef MOMENT
9152         s1=dipderg(1,jj,i)*dip(1,kk,k)
9153 #endif
9154         s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
9155         call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
9156         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
9157         s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
9158 #ifdef MOMENT
9159         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
9160 #else
9161         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
9162 #endif
9163 c        g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
9164       endif
9165 C Derivatives in gamma(k-1)
9166 #ifdef MOMENT
9167       s1=dip(1,jj,i)*dipderg(1,kk,k)
9168 #endif
9169       call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
9170       s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
9171       call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
9172       s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
9173       call transpose2(EUgder(1,1,k),auxmat1(1,1))
9174       call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
9175       vv(1)=pizda(1,1)-pizda(2,2)
9176       vv(2)=pizda(1,2)+pizda(2,1)
9177       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
9178 #ifdef MOMENT
9179       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
9180 #else
9181       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
9182 #endif
9183 c      g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
9184 C Derivatives in gamma(j-1) or gamma(l-1)
9185       if (j.gt.1) then
9186 #ifdef MOMENT
9187         s1=dipderg(3,jj,i)*dip(1,kk,k)
9188 #endif
9189         call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
9190         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
9191         s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
9192         call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
9193         vv(1)=pizda(1,1)-pizda(2,2)
9194         vv(2)=pizda(1,2)+pizda(2,1)
9195         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
9196 #ifdef MOMENT
9197         if (swap) then
9198           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
9199         else
9200           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
9201         endif
9202 #endif
9203         g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
9204 c        g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
9205       endif
9206 C Derivatives in gamma(l-1) or gamma(j-1)
9207       if (l.gt.1) then
9208 #ifdef MOMENT
9209         s1=dip(1,jj,i)*dipderg(3,kk,k)
9210 #endif
9211         call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
9212         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
9213         call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
9214         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
9215         call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
9216         vv(1)=pizda(1,1)-pizda(2,2)
9217         vv(2)=pizda(1,2)+pizda(2,1)
9218         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
9219 #ifdef MOMENT
9220         if (swap) then
9221           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
9222         else
9223           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
9224         endif
9225 #endif
9226         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
9227 c        g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
9228       endif
9229 C Cartesian derivatives.
9230       if (lprn) then
9231         write (2,*) 'In eello6_graph2'
9232         do iii=1,2
9233           write (2,*) 'iii=',iii
9234           do kkk=1,5
9235             write (2,*) 'kkk=',kkk
9236             do jjj=1,2
9237               write (2,'(3(2f10.5),5x)')
9238      &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
9239             enddo
9240           enddo
9241         enddo
9242       endif
9243       do iii=1,2
9244         do kkk=1,5
9245           do lll=1,3
9246 #ifdef MOMENT
9247             if (iii.eq.1) then
9248               s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
9249             else
9250               s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
9251             endif
9252 #endif
9253             call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),
9254      &        auxvec(1))
9255             s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
9256             call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),
9257      &        auxvec(1))
9258             s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
9259             call transpose2(EUg(1,1,k),auxmat(1,1))
9260             call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),
9261      &        pizda(1,1))
9262             vv(1)=pizda(1,1)-pizda(2,2)
9263             vv(2)=pizda(1,2)+pizda(2,1)
9264             s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
9265 cd            write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
9266 #ifdef MOMENT
9267             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
9268 #else
9269             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
9270 #endif
9271             if (swap) then
9272               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
9273             else
9274               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
9275             endif
9276           enddo
9277         enddo
9278       enddo
9279       return
9280       end
9281 c----------------------------------------------------------------------------
9282       double precision function eello6_graph3(i,j,k,l,jj,kk,swap)
9283       implicit real*8 (a-h,o-z)
9284       include 'DIMENSIONS'
9285       include 'COMMON.IOUNITS'
9286       include 'COMMON.CHAIN'
9287       include 'COMMON.DERIV'
9288       include 'COMMON.INTERACT'
9289       include 'COMMON.CONTACTS'
9290       include 'COMMON.TORSION'
9291       include 'COMMON.VAR'
9292       include 'COMMON.GEO'
9293       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2)
9294       logical swap
9295 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9296 C                                                                              C
9297 C      Parallel       Antiparallel                                             C
9298 C                                                                              C
9299 C          o             o                                                     C
9300 C         /l\   /   \   /j\                                                    C
9301 C        /   \ /     \ /   \                                                   C
9302 C       /| o |o       o| o |\                                                  C
9303 C       j|/k\|  /      |/k\|l /                                                C
9304 C        /   \ /       /   \ /                                                 C
9305 C       /     o       /     o                                                  C
9306 C       i             i                                                        C
9307 C                                                                              C
9308 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9309 C
9310 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
9311 C           energy moment and not to the cluster cumulant.
9312       iti=itortyp(itype(i))
9313       if (j.lt.nres-1) then
9314         itj1=itortyp(itype(j+1))
9315       else
9316         itj1=ntortyp
9317       endif
9318       itk=itortyp(itype(k))
9319       itk1=itortyp(itype(k+1))
9320       if (l.lt.nres-1) then
9321         itl1=itortyp(itype(l+1))
9322       else
9323         itl1=ntortyp
9324       endif
9325 #ifdef MOMENT
9326       s1=dip(4,jj,i)*dip(4,kk,k)
9327 #endif
9328       call matvec2(AECA(1,1,1),b1(1,k+1),auxvec(1))
9329       s2=0.5d0*scalar2(b1(1,k),auxvec(1))
9330       call matvec2(AECA(1,1,2),b1(1,l+1),auxvec(1))
9331       s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
9332       call transpose2(EE(1,1,itk),auxmat(1,1))
9333       call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
9334       vv(1)=pizda(1,1)+pizda(2,2)
9335       vv(2)=pizda(2,1)-pizda(1,2)
9336       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
9337 cd      write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4,
9338 cd     & "sum",-(s2+s3+s4)
9339 #ifdef MOMENT
9340       eello6_graph3=-(s1+s2+s3+s4)
9341 #else
9342       eello6_graph3=-(s2+s3+s4)
9343 #endif
9344 c      eello6_graph3=-s4
9345 C Derivatives in gamma(k-1)
9346       call matvec2(AECAderg(1,1,2),b1(1,l+1),auxvec(1))
9347       s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
9348       s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
9349       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
9350 C Derivatives in gamma(l-1)
9351       call matvec2(AECAderg(1,1,1),b1(1,k+1),auxvec(1))
9352       s2=0.5d0*scalar2(b1(1,k),auxvec(1))
9353       call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
9354       vv(1)=pizda(1,1)+pizda(2,2)
9355       vv(2)=pizda(2,1)-pizda(1,2)
9356       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
9357       g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
9358 C Cartesian derivatives.
9359       do iii=1,2
9360         do kkk=1,5
9361           do lll=1,3
9362 #ifdef MOMENT
9363             if (iii.eq.1) then
9364               s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
9365             else
9366               s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
9367             endif
9368 #endif
9369             call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
9370      &        auxvec(1))
9371             s2=0.5d0*scalar2(b1(1,k),auxvec(1))
9372             call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,l+1),
9373      &        auxvec(1))
9374             s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
9375             call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),
9376      &        pizda(1,1))
9377             vv(1)=pizda(1,1)+pizda(2,2)
9378             vv(2)=pizda(2,1)-pizda(1,2)
9379             s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
9380 #ifdef MOMENT
9381             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
9382 #else
9383             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
9384 #endif
9385             if (swap) then
9386               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
9387             else
9388               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
9389             endif
9390 c            derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
9391           enddo
9392         enddo
9393       enddo
9394       return
9395       end
9396 c----------------------------------------------------------------------------
9397       double precision function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
9398       implicit real*8 (a-h,o-z)
9399       include 'DIMENSIONS'
9400       include 'COMMON.IOUNITS'
9401       include 'COMMON.CHAIN'
9402       include 'COMMON.DERIV'
9403       include 'COMMON.INTERACT'
9404       include 'COMMON.CONTACTS'
9405       include 'COMMON.TORSION'
9406       include 'COMMON.VAR'
9407       include 'COMMON.GEO'
9408       include 'COMMON.FFIELD'
9409       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
9410      & auxvec1(2),auxmat1(2,2)
9411       logical swap
9412 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9413 C                                                                              C
9414 C      Parallel       Antiparallel                                             C
9415 C                                                                              C
9416 C          o             o                                                     C
9417 C         /l\   /   \   /j\                                                    C
9418 C        /   \ /     \ /   \                                                   C
9419 C       /| o |o       o| o |\                                                  C
9420 C     \ j|/k\|      \  |/k\|l                                                  C
9421 C      \ /   \       \ /   \                                                   C
9422 C       o     \       o     \                                                  C
9423 C       i             i                                                        C
9424 C                                                                              C
9425 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9426 C
9427 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
9428 C           energy moment and not to the cluster cumulant.
9429 cd      write (2,*) 'eello_graph4: wturn6',wturn6
9430       iti=itortyp(itype(i))
9431       itj=itortyp(itype(j))
9432       if (j.lt.nres-1) then
9433         itj1=itortyp(itype(j+1))
9434       else
9435         itj1=ntortyp
9436       endif
9437       itk=itortyp(itype(k))
9438       if (k.lt.nres-1) then
9439         itk1=itortyp(itype(k+1))
9440       else
9441         itk1=ntortyp
9442       endif
9443       itl=itortyp(itype(l))
9444       if (l.lt.nres-1) then
9445         itl1=itortyp(itype(l+1))
9446       else
9447         itl1=ntortyp
9448       endif
9449 cd      write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
9450 cd      write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
9451 cd     & ' itl',itl,' itl1',itl1
9452 #ifdef MOMENT
9453       if (imat.eq.1) then
9454         s1=dip(3,jj,i)*dip(3,kk,k)
9455       else
9456         s1=dip(2,jj,j)*dip(2,kk,l)
9457       endif
9458 #endif
9459       call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
9460       s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
9461       if (j.eq.l+1) then
9462         call matvec2(ADtEA1(1,1,3-imat),b1(1,j+1),auxvec1(1))
9463         s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
9464       else
9465         call matvec2(ADtEA1(1,1,3-imat),b1(1,l+1),auxvec1(1))
9466         s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
9467       endif
9468       call transpose2(EUg(1,1,k),auxmat(1,1))
9469       call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
9470       vv(1)=pizda(1,1)-pizda(2,2)
9471       vv(2)=pizda(2,1)+pizda(1,2)
9472       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9473 cd      write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
9474 #ifdef MOMENT
9475       eello6_graph4=-(s1+s2+s3+s4)
9476 #else
9477       eello6_graph4=-(s2+s3+s4)
9478 #endif
9479 C Derivatives in gamma(i-1)
9480       if (i.gt.1) then
9481 #ifdef MOMENT
9482         if (imat.eq.1) then
9483           s1=dipderg(2,jj,i)*dip(3,kk,k)
9484         else
9485           s1=dipderg(4,jj,j)*dip(2,kk,l)
9486         endif
9487 #endif
9488         s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
9489         if (j.eq.l+1) then
9490           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,j+1),auxvec1(1))
9491           s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
9492         else
9493           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,l+1),auxvec1(1))
9494           s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
9495         endif
9496         s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
9497         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
9498 cd          write (2,*) 'turn6 derivatives'
9499 #ifdef MOMENT
9500           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
9501 #else
9502           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
9503 #endif
9504         else
9505 #ifdef MOMENT
9506           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
9507 #else
9508           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
9509 #endif
9510         endif
9511       endif
9512 C Derivatives in gamma(k-1)
9513 #ifdef MOMENT
9514       if (imat.eq.1) then
9515         s1=dip(3,jj,i)*dipderg(2,kk,k)
9516       else
9517         s1=dip(2,jj,j)*dipderg(4,kk,l)
9518       endif
9519 #endif
9520       call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
9521       s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
9522       if (j.eq.l+1) then
9523         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,j+1),auxvec1(1))
9524         s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
9525       else
9526         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,l+1),auxvec1(1))
9527         s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
9528       endif
9529       call transpose2(EUgder(1,1,k),auxmat1(1,1))
9530       call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
9531       vv(1)=pizda(1,1)-pizda(2,2)
9532       vv(2)=pizda(2,1)+pizda(1,2)
9533       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9534       if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
9535 #ifdef MOMENT
9536         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
9537 #else
9538         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
9539 #endif
9540       else
9541 #ifdef MOMENT
9542         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
9543 #else
9544         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
9545 #endif
9546       endif
9547 C Derivatives in gamma(j-1) or gamma(l-1)
9548       if (l.eq.j+1 .and. l.gt.1) then
9549         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
9550         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
9551         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
9552         vv(1)=pizda(1,1)-pizda(2,2)
9553         vv(2)=pizda(2,1)+pizda(1,2)
9554         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9555         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
9556       else if (j.gt.1) then
9557         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
9558         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
9559         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
9560         vv(1)=pizda(1,1)-pizda(2,2)
9561         vv(2)=pizda(2,1)+pizda(1,2)
9562         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9563         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
9564           gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
9565         else
9566           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
9567         endif
9568       endif
9569 C Cartesian derivatives.
9570       do iii=1,2
9571         do kkk=1,5
9572           do lll=1,3
9573 #ifdef MOMENT
9574             if (iii.eq.1) then
9575               if (imat.eq.1) then
9576                 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
9577               else
9578                 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
9579               endif
9580             else
9581               if (imat.eq.1) then
9582                 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
9583               else
9584                 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
9585               endif
9586             endif
9587 #endif
9588             call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),
9589      &        auxvec(1))
9590             s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
9591             if (j.eq.l+1) then
9592               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
9593      &          b1(1,j+1),auxvec(1))
9594               s3=-0.5d0*scalar2(b1(1,j),auxvec(1))
9595             else
9596               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
9597      &          b1(1,l+1),auxvec(1))
9598               s3=-0.5d0*scalar2(b1(1,l),auxvec(1))
9599             endif
9600             call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
9601      &        pizda(1,1))
9602             vv(1)=pizda(1,1)-pizda(2,2)
9603             vv(2)=pizda(2,1)+pizda(1,2)
9604             s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9605             if (swap) then
9606               if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
9607 #ifdef MOMENT
9608                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
9609      &             -(s1+s2+s4)
9610 #else
9611                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
9612      &             -(s2+s4)
9613 #endif
9614                 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
9615               else
9616 #ifdef MOMENT
9617                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
9618 #else
9619                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
9620 #endif
9621                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
9622               endif
9623             else
9624 #ifdef MOMENT
9625               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
9626 #else
9627               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
9628 #endif
9629               if (l.eq.j+1) then
9630                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
9631               else
9632                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
9633               endif
9634             endif
9635           enddo
9636         enddo
9637       enddo
9638       return
9639       end
9640 c----------------------------------------------------------------------------
9641       double precision function eello_turn6(i,jj,kk)
9642       implicit real*8 (a-h,o-z)
9643       include 'DIMENSIONS'
9644       include 'COMMON.IOUNITS'
9645       include 'COMMON.CHAIN'
9646       include 'COMMON.DERIV'
9647       include 'COMMON.INTERACT'
9648       include 'COMMON.CONTACTS'
9649       include 'COMMON.TORSION'
9650       include 'COMMON.VAR'
9651       include 'COMMON.GEO'
9652       double precision vtemp1(2),vtemp2(2),vtemp3(2),vtemp4(2),
9653      &  atemp(2,2),auxmat(2,2),achuj_temp(2,2),gtemp(2,2),gvec(2),
9654      &  ggg1(3),ggg2(3)
9655       double precision vtemp1d(2),vtemp2d(2),vtemp3d(2),vtemp4d(2),
9656      &  atempd(2,2),auxmatd(2,2),achuj_tempd(2,2),gtempd(2,2),gvecd(2)
9657 C 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
9658 C           the respective energy moment and not to the cluster cumulant.
9659       s1=0.0d0
9660       s8=0.0d0
9661       s13=0.0d0
9662 c
9663       eello_turn6=0.0d0
9664       j=i+4
9665       k=i+1
9666       l=i+3
9667       iti=itortyp(itype(i))
9668       itk=itortyp(itype(k))
9669       itk1=itortyp(itype(k+1))
9670       itl=itortyp(itype(l))
9671       itj=itortyp(itype(j))
9672 cd      write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
9673 cd      write (2,*) 'i',i,' k',k,' j',j,' l',l
9674 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
9675 cd        eello6=0.0d0
9676 cd        return
9677 cd      endif
9678 cd      write (iout,*)
9679 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
9680 cd     &   ' and',k,l
9681 cd      call checkint_turn6(i,jj,kk,eel_turn6_num)
9682       do iii=1,2
9683         do kkk=1,5
9684           do lll=1,3
9685             derx_turn(lll,kkk,iii)=0.0d0
9686           enddo
9687         enddo
9688       enddo
9689 cd      eij=1.0d0
9690 cd      ekl=1.0d0
9691 cd      ekont=1.0d0
9692       eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
9693 cd      eello6_5=0.0d0
9694 cd      write (2,*) 'eello6_5',eello6_5
9695 #ifdef MOMENT
9696       call transpose2(AEA(1,1,1),auxmat(1,1))
9697       call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
9698       ss1=scalar2(Ub2(1,i+2),b1(1,l))
9699       s1 = (auxmat(1,1)+auxmat(2,2))*ss1
9700 #endif
9701       call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1(1))
9702       call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
9703       s2 = scalar2(b1(1,k),vtemp1(1))
9704 #ifdef MOMENT
9705       call transpose2(AEA(1,1,2),atemp(1,1))
9706       call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
9707       call matvec2(Ug2(1,1,i+2),dd(1,1,itk1),vtemp2(1))
9708       s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
9709 #endif
9710       call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
9711       call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
9712       s12 = scalar2(Ub2(1,i+2),vtemp3(1))
9713 #ifdef MOMENT
9714       call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
9715       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
9716       call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
9717       call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
9718       ss13 = scalar2(b1(1,k),vtemp4(1))
9719       s13 = (gtemp(1,1)+gtemp(2,2))*ss13
9720 #endif
9721 c      write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
9722 c      s1=0.0d0
9723 c      s2=0.0d0
9724 c      s8=0.0d0
9725 c      s12=0.0d0
9726 c      s13=0.0d0
9727       eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
9728 C Derivatives in gamma(i+2)
9729       s1d =0.0d0
9730       s8d =0.0d0
9731 #ifdef MOMENT
9732       call transpose2(AEA(1,1,1),auxmatd(1,1))
9733       call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
9734       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
9735       call transpose2(AEAderg(1,1,2),atempd(1,1))
9736       call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
9737       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
9738 #endif
9739       call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
9740       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
9741       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
9742 c      s1d=0.0d0
9743 c      s2d=0.0d0
9744 c      s8d=0.0d0
9745 c      s12d=0.0d0
9746 c      s13d=0.0d0
9747       gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
9748 C Derivatives in gamma(i+3)
9749 #ifdef MOMENT
9750       call transpose2(AEA(1,1,1),auxmatd(1,1))
9751       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
9752       ss1d=scalar2(Ub2der(1,i+2),b1(1,l))
9753       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
9754 #endif
9755       call matvec2(EUgder(1,1,i+2),b1(1,l),vtemp1d(1))
9756       call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
9757       s2d = scalar2(b1(1,k),vtemp1d(1))
9758 #ifdef MOMENT
9759       call matvec2(Ug2der(1,1,i+2),dd(1,1,itk1),vtemp2d(1))
9760       s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2d(1))
9761 #endif
9762       s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
9763 #ifdef MOMENT
9764       call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
9765       call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
9766       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
9767 #endif
9768 c      s1d=0.0d0
9769 c      s2d=0.0d0
9770 c      s8d=0.0d0
9771 c      s12d=0.0d0
9772 c      s13d=0.0d0
9773 #ifdef MOMENT
9774       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
9775      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
9776 #else
9777       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
9778      &               -0.5d0*ekont*(s2d+s12d)
9779 #endif
9780 C Derivatives in gamma(i+4)
9781       call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
9782       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
9783       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
9784 #ifdef MOMENT
9785       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
9786       call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
9787       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
9788 #endif
9789 c      s1d=0.0d0
9790 c      s2d=0.0d0
9791 c      s8d=0.0d0
9792 C      s12d=0.0d0
9793 c      s13d=0.0d0
9794 #ifdef MOMENT
9795       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
9796 #else
9797       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
9798 #endif
9799 C Derivatives in gamma(i+5)
9800 #ifdef MOMENT
9801       call transpose2(AEAderg(1,1,1),auxmatd(1,1))
9802       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
9803       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
9804 #endif
9805       call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1d(1))
9806       call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
9807       s2d = scalar2(b1(1,k),vtemp1d(1))
9808 #ifdef MOMENT
9809       call transpose2(AEA(1,1,2),atempd(1,1))
9810       call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
9811       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
9812 #endif
9813       call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
9814       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
9815 #ifdef MOMENT
9816       call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
9817       ss13d = scalar2(b1(1,k),vtemp4d(1))
9818       s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
9819 #endif
9820 c      s1d=0.0d0
9821 c      s2d=0.0d0
9822 c      s8d=0.0d0
9823 c      s12d=0.0d0
9824 c      s13d=0.0d0
9825 #ifdef MOMENT
9826       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
9827      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
9828 #else
9829       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
9830      &               -0.5d0*ekont*(s2d+s12d)
9831 #endif
9832 C Cartesian derivatives
9833       do iii=1,2
9834         do kkk=1,5
9835           do lll=1,3
9836 #ifdef MOMENT
9837             call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
9838             call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
9839             s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
9840 #endif
9841             call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1(1))
9842             call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),
9843      &          vtemp1d(1))
9844             s2d = scalar2(b1(1,k),vtemp1d(1))
9845 #ifdef MOMENT
9846             call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
9847             call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
9848             s8d = -(atempd(1,1)+atempd(2,2))*
9849      &           scalar2(cc(1,1,itl),vtemp2(1))
9850 #endif
9851             call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),
9852      &           auxmatd(1,1))
9853             call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
9854             s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
9855 c      s1d=0.0d0
9856 c      s2d=0.0d0
9857 c      s8d=0.0d0
9858 c      s12d=0.0d0
9859 c      s13d=0.0d0
9860 #ifdef MOMENT
9861             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
9862      &        - 0.5d0*(s1d+s2d)
9863 #else
9864             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
9865      &        - 0.5d0*s2d
9866 #endif
9867 #ifdef MOMENT
9868             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
9869      &        - 0.5d0*(s8d+s12d)
9870 #else
9871             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
9872      &        - 0.5d0*s12d
9873 #endif
9874           enddo
9875         enddo
9876       enddo
9877 #ifdef MOMENT
9878       do kkk=1,5
9879         do lll=1,3
9880           call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),
9881      &      achuj_tempd(1,1))
9882           call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
9883           call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
9884           s13d=(gtempd(1,1)+gtempd(2,2))*ss13
9885           derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
9886           call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),
9887      &      vtemp4d(1))
9888           ss13d = scalar2(b1(1,k),vtemp4d(1))
9889           s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
9890           derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
9891         enddo
9892       enddo
9893 #endif
9894 cd      write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
9895 cd     &  16*eel_turn6_num
9896 cd      goto 1112
9897       if (j.lt.nres-1) then
9898         j1=j+1
9899         j2=j-1
9900       else
9901         j1=j-1
9902         j2=j-2
9903       endif
9904       if (l.lt.nres-1) then
9905         l1=l+1
9906         l2=l-1
9907       else
9908         l1=l-1
9909         l2=l-2
9910       endif
9911       do ll=1,3
9912 cgrad        ggg1(ll)=eel_turn6*g_contij(ll,1)
9913 cgrad        ggg2(ll)=eel_turn6*g_contij(ll,2)
9914 cgrad        ghalf=0.5d0*ggg1(ll)
9915 cd        ghalf=0.0d0
9916         gturn6ij=eel_turn6*g_contij(ll,1)+ekont*derx_turn(ll,1,1)
9917         gturn6kl=eel_turn6*g_contij(ll,2)+ekont*derx_turn(ll,1,2)
9918         gcorr6_turn(ll,i)=gcorr6_turn(ll,i)!+ghalf
9919      &    +ekont*derx_turn(ll,2,1)
9920         gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
9921         gcorr6_turn(ll,j)=gcorr6_turn(ll,j)!+ghalf
9922      &    +ekont*derx_turn(ll,4,1)
9923         gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
9924         gcorr6_turn_long(ll,j)=gcorr6_turn_long(ll,j)+gturn6ij
9925         gcorr6_turn_long(ll,i)=gcorr6_turn_long(ll,i)-gturn6ij
9926 cgrad        ghalf=0.5d0*ggg2(ll)
9927 cd        ghalf=0.0d0
9928         gcorr6_turn(ll,k)=gcorr6_turn(ll,k)!+ghalf
9929      &    +ekont*derx_turn(ll,2,2)
9930         gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
9931         gcorr6_turn(ll,l)=gcorr6_turn(ll,l)!+ghalf
9932      &    +ekont*derx_turn(ll,4,2)
9933         gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
9934         gcorr6_turn_long(ll,l)=gcorr6_turn_long(ll,l)+gturn6kl
9935         gcorr6_turn_long(ll,k)=gcorr6_turn_long(ll,k)-gturn6kl
9936       enddo
9937 cd      goto 1112
9938 cgrad      do m=i+1,j-1
9939 cgrad        do ll=1,3
9940 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
9941 cgrad        enddo
9942 cgrad      enddo
9943 cgrad      do m=k+1,l-1
9944 cgrad        do ll=1,3
9945 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
9946 cgrad        enddo
9947 cgrad      enddo
9948 cgrad1112  continue
9949 cgrad      do m=i+2,j2
9950 cgrad        do ll=1,3
9951 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
9952 cgrad        enddo
9953 cgrad      enddo
9954 cgrad      do m=k+2,l2
9955 cgrad        do ll=1,3
9956 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
9957 cgrad        enddo
9958 cgrad      enddo
9959 cd      do iii=1,nres-3
9960 cd        write (2,*) iii,g_corr6_loc(iii)
9961 cd      enddo
9962       eello_turn6=ekont*eel_turn6
9963 cd      write (2,*) 'ekont',ekont
9964 cd      write (2,*) 'eel_turn6',ekont*eel_turn6
9965       return
9966       end
9967
9968 C-----------------------------------------------------------------------------
9969       double precision function scalar(u,v)
9970 !DIR$ INLINEALWAYS scalar
9971 #ifndef OSF
9972 cDEC$ ATTRIBUTES FORCEINLINE::scalar
9973 #endif
9974       implicit none
9975       double precision u(3),v(3)
9976 cd      double precision sc
9977 cd      integer i
9978 cd      sc=0.0d0
9979 cd      do i=1,3
9980 cd        sc=sc+u(i)*v(i)
9981 cd      enddo
9982 cd      scalar=sc
9983
9984       scalar=u(1)*v(1)+u(2)*v(2)+u(3)*v(3)
9985       return
9986       end
9987 crc-------------------------------------------------
9988       SUBROUTINE MATVEC2(A1,V1,V2)
9989 !DIR$ INLINEALWAYS MATVEC2
9990 #ifndef OSF
9991 cDEC$ ATTRIBUTES FORCEINLINE::MATVEC2
9992 #endif
9993       implicit real*8 (a-h,o-z)
9994       include 'DIMENSIONS'
9995       DIMENSION A1(2,2),V1(2),V2(2)
9996 c      DO 1 I=1,2
9997 c        VI=0.0
9998 c        DO 3 K=1,2
9999 c    3     VI=VI+A1(I,K)*V1(K)
10000 c        Vaux(I)=VI
10001 c    1 CONTINUE
10002
10003       vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
10004       vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
10005
10006       v2(1)=vaux1
10007       v2(2)=vaux2
10008       END
10009 C---------------------------------------
10010       SUBROUTINE MATMAT2(A1,A2,A3)
10011 #ifndef OSF
10012 cDEC$ ATTRIBUTES FORCEINLINE::MATMAT2
10013 #endif
10014       implicit real*8 (a-h,o-z)
10015       include 'DIMENSIONS'
10016       DIMENSION A1(2,2),A2(2,2),A3(2,2)
10017 c      DIMENSION AI3(2,2)
10018 c        DO  J=1,2
10019 c          A3IJ=0.0
10020 c          DO K=1,2
10021 c           A3IJ=A3IJ+A1(I,K)*A2(K,J)
10022 c          enddo
10023 c          A3(I,J)=A3IJ
10024 c       enddo
10025 c      enddo
10026
10027       ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
10028       ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
10029       ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
10030       ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
10031
10032       A3(1,1)=AI3_11
10033       A3(2,1)=AI3_21
10034       A3(1,2)=AI3_12
10035       A3(2,2)=AI3_22
10036       END
10037
10038 c-------------------------------------------------------------------------
10039       double precision function scalar2(u,v)
10040 !DIR$ INLINEALWAYS scalar2
10041       implicit none
10042       double precision u(2),v(2)
10043       double precision sc
10044       integer i
10045       scalar2=u(1)*v(1)+u(2)*v(2)
10046       return
10047       end
10048
10049 C-----------------------------------------------------------------------------
10050
10051       subroutine transpose2(a,at)
10052 !DIR$ INLINEALWAYS transpose2
10053 #ifndef OSF
10054 cDEC$ ATTRIBUTES FORCEINLINE::transpose2
10055 #endif
10056       implicit none
10057       double precision a(2,2),at(2,2)
10058       at(1,1)=a(1,1)
10059       at(1,2)=a(2,1)
10060       at(2,1)=a(1,2)
10061       at(2,2)=a(2,2)
10062       return
10063       end
10064 c--------------------------------------------------------------------------
10065       subroutine transpose(n,a,at)
10066       implicit none
10067       integer n,i,j
10068       double precision a(n,n),at(n,n)
10069       do i=1,n
10070         do j=1,n
10071           at(j,i)=a(i,j)
10072         enddo
10073       enddo
10074       return
10075       end
10076 C---------------------------------------------------------------------------
10077       subroutine prodmat3(a1,a2,kk,transp,prod)
10078 !DIR$ INLINEALWAYS prodmat3
10079 #ifndef OSF
10080 cDEC$ ATTRIBUTES FORCEINLINE::prodmat3
10081 #endif
10082       implicit none
10083       integer i,j
10084       double precision a1(2,2),a2(2,2),a2t(2,2),kk(2,2),prod(2,2)
10085       logical transp
10086 crc      double precision auxmat(2,2),prod_(2,2)
10087
10088       if (transp) then
10089 crc        call transpose2(kk(1,1),auxmat(1,1))
10090 crc        call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
10091 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
10092
10093            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1)
10094      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
10095            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2)
10096      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
10097            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1)
10098      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
10099            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2)
10100      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
10101
10102       else
10103 crc        call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
10104 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
10105
10106            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1)
10107      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
10108            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2)
10109      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
10110            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1)
10111      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
10112            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2)
10113      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
10114
10115       endif
10116 c      call transpose2(a2(1,1),a2t(1,1))
10117
10118 crc      print *,transp
10119 crc      print *,((prod_(i,j),i=1,2),j=1,2)
10120 crc      print *,((prod(i,j),i=1,2),j=1,2)
10121
10122       return
10123       end
10124 CCC----------------------------------------------
10125       subroutine Eliptransfer(eliptran)
10126       implicit real*8 (a-h,o-z)
10127       include 'DIMENSIONS'
10128       include 'COMMON.GEO'
10129       include 'COMMON.VAR'
10130       include 'COMMON.LOCAL'
10131       include 'COMMON.CHAIN'
10132       include 'COMMON.DERIV'
10133       include 'COMMON.NAMES'
10134       include 'COMMON.INTERACT'
10135       include 'COMMON.IOUNITS'
10136       include 'COMMON.CALC'
10137       include 'COMMON.CONTROL'
10138       include 'COMMON.SPLITELE'
10139       include 'COMMON.SBRIDGE'
10140 C this is done by Adasko
10141 C      print *,"wchodze"
10142 C structure of box:
10143 C      water
10144 C--bordliptop-- buffore starts
10145 C--bufliptop--- here true lipid starts
10146 C      lipid
10147 C--buflipbot--- lipid ends buffore starts
10148 C--bordlipbot--buffore ends
10149       eliptran=0.0
10150       do i=ilip_start,ilip_end
10151 C       do i=1,1
10152         if (itype(i).eq.ntyp1) cycle
10153
10154         positi=(mod(((c(3,i)+c(3,i+1))/2.0d0),boxzsize))
10155         if (positi.le.0) positi=positi+boxzsize
10156 C        print *,i
10157 C first for peptide groups
10158 c for each residue check if it is in lipid or lipid water border area
10159        if ((positi.gt.bordlipbot)
10160      &.and.(positi.lt.bordliptop)) then
10161 C the energy transfer exist
10162         if (positi.lt.buflipbot) then
10163 C what fraction I am in
10164          fracinbuf=1.0d0-
10165      &        ((positi-bordlipbot)/lipbufthick)
10166 C lipbufthick is thickenes of lipid buffore
10167          sslip=sscalelip(fracinbuf)
10168          ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
10169          eliptran=eliptran+sslip*pepliptran
10170          gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
10171          gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
10172 C         gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
10173
10174 C        print *,"doing sccale for lower part"
10175 C         print *,i,sslip,fracinbuf,ssgradlip
10176         elseif (positi.gt.bufliptop) then
10177          fracinbuf=1.0d0-((bordliptop-positi)/lipbufthick)
10178          sslip=sscalelip(fracinbuf)
10179          ssgradlip=sscagradlip(fracinbuf)/lipbufthick
10180          eliptran=eliptran+sslip*pepliptran
10181          gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
10182          gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
10183 C         gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
10184 C          print *, "doing sscalefor top part"
10185 C         print *,i,sslip,fracinbuf,ssgradlip
10186         else
10187          eliptran=eliptran+pepliptran
10188 C         print *,"I am in true lipid"
10189         endif
10190 C       else
10191 C       eliptran=elpitran+0.0 ! I am in water
10192        endif
10193        enddo
10194 C       print *, "nic nie bylo w lipidzie?"
10195 C now multiply all by the peptide group transfer factor
10196 C       eliptran=eliptran*pepliptran
10197 C now the same for side chains
10198 CV       do i=1,1
10199        do i=ilip_start,ilip_end
10200         if (itype(i).eq.ntyp1) cycle
10201         positi=(mod(c(3,i+nres),boxzsize))
10202         if (positi.le.0) positi=positi+boxzsize
10203 C       print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop
10204 c for each residue check if it is in lipid or lipid water border area
10205 C       respos=mod(c(3,i+nres),boxzsize)
10206 C       print *,positi,bordlipbot,buflipbot
10207        if ((positi.gt.bordlipbot)
10208      & .and.(positi.lt.bordliptop)) then
10209 C the energy transfer exist
10210         if (positi.lt.buflipbot) then
10211          fracinbuf=1.0d0-
10212      &     ((positi-bordlipbot)/lipbufthick)
10213 C lipbufthick is thickenes of lipid buffore
10214          sslip=sscalelip(fracinbuf)
10215          ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
10216          eliptran=eliptran+sslip*liptranene(itype(i))
10217          gliptranx(3,i)=gliptranx(3,i)
10218      &+ssgradlip*liptranene(itype(i))
10219          gliptranc(3,i-1)= gliptranc(3,i-1)
10220      &+ssgradlip*liptranene(itype(i))
10221 C         print *,"doing sccale for lower part"
10222         elseif (positi.gt.bufliptop) then
10223          fracinbuf=1.0d0-
10224      &((bordliptop-positi)/lipbufthick)
10225          sslip=sscalelip(fracinbuf)
10226          ssgradlip=sscagradlip(fracinbuf)/lipbufthick
10227          eliptran=eliptran+sslip*liptranene(itype(i))
10228          gliptranx(3,i)=gliptranx(3,i)
10229      &+ssgradlip*liptranene(itype(i))
10230          gliptranc(3,i-1)= gliptranc(3,i-1)
10231      &+ssgradlip*liptranene(itype(i))
10232 C          print *, "doing sscalefor top part",sslip,fracinbuf
10233         else
10234          eliptran=eliptran+liptranene(itype(i))
10235 C         print *,"I am in true lipid"
10236         endif
10237         endif ! if in lipid or buffor
10238 C       else
10239 C       eliptran=elpitran+0.0 ! I am in water
10240        enddo
10241        return
10242        end
10243 C---------------------------------------------------------
10244 C AFM soubroutine for constant force
10245        subroutine AFMforce(Eafmforce)
10246        implicit real*8 (a-h,o-z)
10247       include 'DIMENSIONS'
10248       include 'COMMON.GEO'
10249       include 'COMMON.VAR'
10250       include 'COMMON.LOCAL'
10251       include 'COMMON.CHAIN'
10252       include 'COMMON.DERIV'
10253       include 'COMMON.NAMES'
10254       include 'COMMON.INTERACT'
10255       include 'COMMON.IOUNITS'
10256       include 'COMMON.CALC'
10257       include 'COMMON.CONTROL'
10258       include 'COMMON.SPLITELE'
10259       include 'COMMON.SBRIDGE'
10260       real*8 diffafm(3)
10261       dist=0.0d0
10262       Eafmforce=0.0d0
10263       do i=1,3
10264       diffafm(i)=c(i,afmend)-c(i,afmbeg)
10265       dist=dist+diffafm(i)**2
10266       enddo
10267       dist=dsqrt(dist)
10268       Eafmforce=-forceAFMconst*(dist-distafminit)
10269       do i=1,3
10270       gradafm(i,afmend-1)=-forceAFMconst*diffafm(i)/dist
10271       gradafm(i,afmbeg-1)=forceAFMconst*diffafm(i)/dist
10272       enddo
10273 C      print *,'AFM',Eafmforce
10274       return
10275       end
10276