source/unres/src_MD-M/energy_p_new_barrier.F

   1       subroutine etotal(energia)
   2       implicit real*8 (a-h,o-z)
   3       include 'DIMENSIONS'
   4 #ifndef ISNAN
   5       external proc_proc
   6 #ifdef WINPGI
   7 cMS$ATTRIBUTES C ::  proc_proc
   8 #endif
   9 #endif
  10 #ifdef MPI
  11       include "mpif.h"
  12       double precision weights_(n_ene)
  13 #endif
  14       include 'COMMON.SETUP'
  15       include 'COMMON.IOUNITS'
  16       double precision energia(0:n_ene)
  17       include 'COMMON.LOCAL'
  18       include 'COMMON.FFIELD'
  19       include 'COMMON.DERIV'
  20       include 'COMMON.INTERACT'
  21       include 'COMMON.SBRIDGE'
  22       include 'COMMON.CHAIN'
  23       include 'COMMON.VAR'
  24       include 'COMMON.MD'
  25       include 'COMMON.CONTROL'
  26       include 'COMMON.TIME1'
  27       include 'COMMON.SPLITELE'
  28 #ifdef MPI
  29 c      print*,"ETOTAL Processor",fg_rank," absolute rank",myrank,
  30 c     & " nfgtasks",nfgtasks
  31       if (nfgtasks.gt.1) then
  32         time00=MPI_Wtime()
  33 C FG slaves call the following matching MPI_Bcast in ERGASTULUM
  34         if (fg_rank.eq.0) then
  35           call MPI_Bcast(0,1,MPI_INTEGER,king,FG_COMM,IERROR)
  36 c          print *,"Processor",myrank," BROADCAST iorder"
  37 C FG master sets up the WEIGHTS_ array which will be broadcast to the
  38 C FG slaves as WEIGHTS array.
  39           weights_(1)=wsc
  40           weights_(2)=wscp
  41           weights_(3)=welec
  42           weights_(4)=wcorr
  43           weights_(5)=wcorr5
  44           weights_(6)=wcorr6
  45           weights_(7)=wel_loc
  46           weights_(8)=wturn3
  47           weights_(9)=wturn4
  48           weights_(10)=wturn6
  49           weights_(11)=wang
  50           weights_(12)=wscloc
  51           weights_(13)=wtor
  52           weights_(14)=wtor_d
  53           weights_(15)=wstrain
  54           weights_(16)=wvdwpp
  55           weights_(17)=wbond
  56           weights_(18)=scal14
  57           weights_(21)=wsccor
  58 C FG Master broadcasts the WEIGHTS_ array
  59           call MPI_Bcast(weights_(1),n_ene,
  60      &        MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
  61         else
  62 C FG slaves receive the WEIGHTS array
  63           call MPI_Bcast(weights(1),n_ene,
  64      &        MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
  65           wsc=weights(1)
  66           wscp=weights(2)
  67           welec=weights(3)
  68           wcorr=weights(4)
  69           wcorr5=weights(5)
  70           wcorr6=weights(6)
  71           wel_loc=weights(7)
  72           wturn3=weights(8)
  73           wturn4=weights(9)
  74           wturn6=weights(10)
  75           wang=weights(11)
  76           wscloc=weights(12)
  77           wtor=weights(13)
  78           wtor_d=weights(14)
  79           wstrain=weights(15)
  80           wvdwpp=weights(16)
  81           wbond=weights(17)
  82           scal14=weights(18)
  83           wsccor=weights(21)
  84         endif
  85         time_Bcast=time_Bcast+MPI_Wtime()-time00
  86         time_Bcastw=time_Bcastw+MPI_Wtime()-time00
  87 c        call chainbuild_cart
  88       endif
  89 c      print *,'Processor',myrank,' calling etotal ipot=',ipot
  90 c      print *,'Processor',myrank,' nnt=',nnt,' nct=',nct
  91 #else
  92 c      if (modecalc.eq.12.or.modecalc.eq.14) then
  93 c        call int_from_cart1(.false.)
  94 c      endif
  95 #endif
  96 #ifdef TIMING
  97       time00=MPI_Wtime()
  98 #endif
  99 C
 100 C Compute the side-chain and electrostatic interaction energy
 101 C
 102 C      print *,ipot
 103       goto (101,102,103,104,105,106) ipot
 104 C Lennard-Jones potential.
 105   101 call elj(evdw)
 106 cd    print '(a)','Exit ELJ'
 107       goto 107
 108 C Lennard-Jones-Kihara potential (shifted).
 109   102 call eljk(evdw)
 110       goto 107
 111 C Berne-Pechukas potential (dilated LJ, angular dependence).
 112   103 call ebp(evdw)
 113       goto 107
 114 C Gay-Berne potential (shifted LJ, angular dependence).
 115   104 call egb(evdw)
 116 C      print *,"bylem w egb"
 117       goto 107
 118 C Gay-Berne-Vorobjev potential (shifted LJ, angular dependence).
 119   105 call egbv(evdw)
 120       goto 107
 121 C Soft-sphere potential
 122   106 call e_softsphere(evdw)
 123 C
 124 C Calculate electrostatic (H-bonding) energy of the main chain.
 125 C
 126   107 continue
 127 cmc
 128 cmc Sep-06: egb takes care of dynamic ss bonds too
 129 cmc
 130 c      if (dyn_ss) call dyn_set_nss
 131
 132 c      print *,"Processor",myrank," computed USCSC"
 133 #ifdef TIMING
 134       time01=MPI_Wtime()
 135 #endif
 136       call vec_and_deriv
 137 #ifdef TIMING
 138       time_vec=time_vec+MPI_Wtime()-time01
 139 #endif
 140 C Introduction of shielding effect first for each peptide group
 141 C the shielding factor is set this factor is describing how each
 142 C peptide group is shielded by side-chains
 143 C the matrix - shield_fac(i) the i index describe the ith between i and i+1
 144       if (shield_mode.gt.0) then
 145        call set_shield_fac
 146       endif
 147 c      print *,"Processor",myrank," left VEC_AND_DERIV"
 148       if (ipot.lt.6) then
 149 #ifdef SPLITELE
 150          if (welec.gt.0d0.or.wvdwpp.gt.0d0.or.wel_loc.gt.0d0.or.
 151      &       wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0
 152      &       .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0
 153      &       .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
 154 #else
 155          if (welec.gt.0d0.or.wel_loc.gt.0d0.or.
 156      &       wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0
 157      &       .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0
 158      &       .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
 159 #endif
 160             call eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
 161          else
 162             ees=0.0d0
 163             evdw1=0.0d0
 164             eel_loc=0.0d0
 165             eello_turn3=0.0d0
 166             eello_turn4=0.0d0
 167          endif
 168       else
 169         write (iout,*) "Soft-spheer ELEC potential"
 170 c        call eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,
 171 c     &   eello_turn4)
 172       endif
 173 c      print *,"Processor",myrank," computed UELEC"
 174 C
 175 C Calculate excluded-volume interaction energy between peptide groups
 176 C and side chains.
 177 C
 178       if (ipot.lt.6) then
 179        if(wscp.gt.0d0) then
 180         call escp(evdw2,evdw2_14)
 181        else
 182         evdw2=0
 183         evdw2_14=0
 184        endif
 185       else
 186 c        write (iout,*) "Soft-sphere SCP potential"
 187         call escp_soft_sphere(evdw2,evdw2_14)
 188       endif
 189 c
 190 c Calculate the bond-stretching energy
 191 c
 192       call ebond(estr)
 193 C
 194 C Calculate the disulfide-bridge and other energy and the contributions
 195 C from other distance constraints.
 196 cd    print *,'Calling EHPB'
 197       call edis(ehpb)
 198 cd    print *,'EHPB exitted succesfully.'
 199 C
 200 C Calculate the virtual-bond-angle energy.
 201 C
 202       if (wang.gt.0d0) then
 203         call ebend(ebe,ethetacnstr)
 204       else
 205         ebe=0
 206         ethetacnstr=0
 207       endif
 208 c      print *,"Processor",myrank," computed UB"
 209 C
 210 C Calculate the SC local energy.
 211 C
 212 C      print *,"TU DOCHODZE?"
 213       call esc(escloc)
 214 c      print *,"Processor",myrank," computed USC"
 215 C
 216 C Calculate the virtual-bond torsional energy.
 217 C
 218 cd    print *,'nterm=',nterm
 219       if (wtor.gt.0) then
 220        call etor(etors,edihcnstr)
 221       else
 222        etors=0
 223        edihcnstr=0
 224       endif
 225 c      print *,"Processor",myrank," computed Utor"
 226 C
 227 C 6/23/01 Calculate double-torsional energy
 228 C
 229       if (wtor_d.gt.0) then
 230        call etor_d(etors_d)
 231       else
 232        etors_d=0
 233       endif
 234 c      print *,"Processor",myrank," computed Utord"
 235 C
 236 C 21/5/07 Calculate local sicdechain correlation energy
 237 C
 238       if (wsccor.gt.0.0d0) then
 239         call eback_sc_corr(esccor)
 240       else
 241         esccor=0.0d0
 242       endif
 243 C      print *,"PRZED MULIt"
 244 c      print *,"Processor",myrank," computed Usccorr"
 245 C
 246 C 12/1/95 Multi-body terms
 247 C
 248       n_corr=0
 249       n_corr1=0
 250       if ((wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0
 251      &    .or. wturn6.gt.0.0d0) .and. ipot.lt.6) then
 252          call multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1)
 253 cd         write(2,*)'multibody_eello n_corr=',n_corr,' n_corr1=',n_corr1,
 254 cd     &" ecorr",ecorr," ecorr5",ecorr5," ecorr6",ecorr6," eturn6",eturn6
 255       else
 256          ecorr=0.0d0
 257          ecorr5=0.0d0
 258          ecorr6=0.0d0
 259          eturn6=0.0d0
 260       endif
 261       if ((wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) .and. ipot.lt.6) then
 262          call multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
 263 cd         write (iout,*) "multibody_hb ecorr",ecorr
 264       endif
 265 c      print *,"Processor",myrank," computed Ucorr"
 266 C
 267 C If performing constraint dynamics, call the constraint energy
 268 C  after the equilibration time
 269       if(usampl.and.totT.gt.eq_time) then
 270          call EconstrQ
 271          call Econstr_back
 272       else
 273          Uconst=0.0d0
 274          Uconst_back=0.0d0
 275       endif
 276 C 01/27/2015 added by adasko
 277 C the energy component below is energy transfer into lipid environment
 278 C based on partition function
 279 C      print *,"przed lipidami"
 280       if (wliptran.gt.0) then
 281         call Eliptransfer(eliptran)
 282       endif
 283 C      print *,"za lipidami"
 284       if (AFMlog.gt.0) then
 285         call AFMforce(Eafmforce)
 286       else if (selfguide.gt.0) then
 287         call AFMvel(Eafmforce)
 288       endif
 289 #ifdef TIMING
 290       time_enecalc=time_enecalc+MPI_Wtime()-time00
 291 #endif
 292 c      print *,"Processor",myrank," computed Uconstr"
 293 #ifdef TIMING
 294       time00=MPI_Wtime()
 295 #endif
 296 c
 297 C Sum the energies
 298 C
 299       energia(1)=evdw
 300 #ifdef SCP14
 301       energia(2)=evdw2-evdw2_14
 302       energia(18)=evdw2_14
 303 #else
 304       energia(2)=evdw2
 305       energia(18)=0.0d0
 306 #endif
 307 #ifdef SPLITELE
 308       energia(3)=ees
 309       energia(16)=evdw1
 310 #else
 311       energia(3)=ees+evdw1
 312       energia(16)=0.0d0
 313 #endif
 314       energia(4)=ecorr
 315       energia(5)=ecorr5
 316       energia(6)=ecorr6
 317       energia(7)=eel_loc
 318       energia(8)=eello_turn3
 319       energia(9)=eello_turn4
 320       energia(10)=eturn6
 321       energia(11)=ebe
 322       energia(12)=escloc
 323       energia(13)=etors
 324       energia(14)=etors_d
 325       energia(15)=ehpb
 326       energia(19)=edihcnstr
 327       energia(17)=estr
 328       energia(20)=Uconst+Uconst_back
 329       energia(21)=esccor
 330       energia(22)=eliptran
 331       energia(23)=Eafmforce
 332       energia(24)=ethetacnstr
 333 c    Here are the energies showed per procesor if the are more processors
 334 c    per molecule then we sum it up in sum_energy subroutine
 335 c      print *," Processor",myrank," calls SUM_ENERGY"
 336       call sum_energy(energia,.true.)
 337       if (dyn_ss) call dyn_set_nss
 338 c      print *," Processor",myrank," left SUM_ENERGY"
 339 #ifdef TIMING
 340       time_sumene=time_sumene+MPI_Wtime()-time00
 341 #endif
 342       return
 343       end
 344 c-------------------------------------------------------------------------------
 345       subroutine sum_energy(energia,reduce)
 346       implicit real*8 (a-h,o-z)
 347       include 'DIMENSIONS'
 348 #ifndef ISNAN
 349       external proc_proc
 350 #ifdef WINPGI
 351 cMS$ATTRIBUTES C ::  proc_proc
 352 #endif
 353 #endif
 354 #ifdef MPI
 355       include "mpif.h"
 356 #endif
 357       include 'COMMON.SETUP'
 358       include 'COMMON.IOUNITS'
 359       double precision energia(0:n_ene),enebuff(0:n_ene+1)
 360       include 'COMMON.FFIELD'
 361       include 'COMMON.DERIV'
 362       include 'COMMON.INTERACT'
 363       include 'COMMON.SBRIDGE'
 364       include 'COMMON.CHAIN'
 365       include 'COMMON.VAR'
 366       include 'COMMON.CONTROL'
 367       include 'COMMON.TIME1'
 368       logical reduce
 369 #ifdef MPI
 370       if (nfgtasks.gt.1 .and. reduce) then
 371 #ifdef DEBUG
 372         write (iout,*) "energies before REDUCE"
 373         call enerprint(energia)
 374         call flush(iout)
 375 #endif
 376         do i=0,n_ene
 377           enebuff(i)=energia(i)
 378         enddo
 379         time00=MPI_Wtime()
 380         call MPI_Barrier(FG_COMM,IERR)
 381         time_barrier_e=time_barrier_e+MPI_Wtime()-time00
 382         time00=MPI_Wtime()
 383         call MPI_Reduce(enebuff(0),energia(0),n_ene+1,
 384      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 385 #ifdef DEBUG
 386         write (iout,*) "energies after REDUCE"
 387         call enerprint(energia)
 388         call flush(iout)
 389 #endif
 390         time_Reduce=time_Reduce+MPI_Wtime()-time00
 391       endif
 392       if (fg_rank.eq.0) then
 393 #endif
 394       evdw=energia(1)
 395 #ifdef SCP14
 396       evdw2=energia(2)+energia(18)
 397       evdw2_14=energia(18)
 398 #else
 399       evdw2=energia(2)
 400 #endif
 401 #ifdef SPLITELE
 402       ees=energia(3)
 403       evdw1=energia(16)
 404 #else
 405       ees=energia(3)
 406       evdw1=0.0d0
 407 #endif
 408       ecorr=energia(4)
 409       ecorr5=energia(5)
 410       ecorr6=energia(6)
 411       eel_loc=energia(7)
 412       eello_turn3=energia(8)
 413       eello_turn4=energia(9)
 414       eturn6=energia(10)
 415       ebe=energia(11)
 416       escloc=energia(12)
 417       etors=energia(13)
 418       etors_d=energia(14)
 419       ehpb=energia(15)
 420       edihcnstr=energia(19)
 421       estr=energia(17)
 422       Uconst=energia(20)
 423       esccor=energia(21)
 424       eliptran=energia(22)
 425       Eafmforce=energia(23)
 426       ethetacnstr=energia(24)
 427 #ifdef SPLITELE
 428       etot=wsc*evdw+wscp*evdw2+welec*ees+wvdwpp*evdw1
 429      & +wang*ebe+wtor*etors+wscloc*escloc
 430      & +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5
 431      & +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3
 432      & +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d
 433      & +wbond*estr+Uconst+wsccor*esccor+wliptran*eliptran+Eafmforce
 434      & +ethetacnstr
 435 #else
 436       etot=wsc*evdw+wscp*evdw2+welec*(ees+evdw1)
 437      & +wang*ebe+wtor*etors+wscloc*escloc
 438      & +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5
 439      & +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3
 440      & +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d
 441      & +wbond*estr+Uconst+wsccor*esccor+wliptran*eliptran
 442      & +Eafmforce
 443      & +ethetacnstr
 444 #endif
 445       energia(0)=etot
 446 c detecting NaNQ
 447 #ifdef ISNAN
 448 #ifdef AIX
 449       if (isnan(etot).ne.0) energia(0)=1.0d+99
 450 #else
 451       if (isnan(etot)) energia(0)=1.0d+99
 452 #endif
 453 #else
 454       i=0
 455 #ifdef WINPGI
 456       idumm=proc_proc(etot,i)
 457 #else
 458       call proc_proc(etot,i)
 459 #endif
 460       if(i.eq.1)energia(0)=1.0d+99
 461 #endif
 462 #ifdef MPI
 463       endif
 464 #endif
 465       return
 466       end
 467 c-------------------------------------------------------------------------------
 468       subroutine sum_gradient
 469       implicit real*8 (a-h,o-z)
 470       include 'DIMENSIONS'
 471 #ifndef ISNAN
 472       external proc_proc
 473 #ifdef WINPGI
 474 cMS$ATTRIBUTES C ::  proc_proc
 475 #endif
 476 #endif
 477 #ifdef MPI
 478       include 'mpif.h'
 479 #endif
 480       double precision gradbufc(3,-1:maxres),gradbufx(3,-1:maxres),
 481      & glocbuf(4*maxres),gradbufc_sum(3,-1:maxres)
 482      & ,gloc_scbuf(3,-1:maxres)
 483       include 'COMMON.SETUP'
 484       include 'COMMON.IOUNITS'
 485       include 'COMMON.FFIELD'
 486       include 'COMMON.DERIV'
 487       include 'COMMON.INTERACT'
 488       include 'COMMON.SBRIDGE'
 489       include 'COMMON.CHAIN'
 490       include 'COMMON.VAR'
 491       include 'COMMON.CONTROL'
 492       include 'COMMON.TIME1'
 493       include 'COMMON.MAXGRAD'
 494       include 'COMMON.SCCOR'
 495 #ifdef TIMING
 496       time01=MPI_Wtime()
 497 #endif
 498 #ifdef DEBUG
 499       write (iout,*) "sum_gradient gvdwc, gvdwx"
 500       do i=1,nres
 501         write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)')
 502      &   i,(gvdwx(j,i),j=1,3),(gvdwc(j,i),j=1,3)
 503       enddo
 504       call flush(iout)
 505 #endif
 506 #ifdef MPI
 507 C FG slaves call the following matching MPI_Bcast in ERGASTULUM
 508         if (nfgtasks.gt.1 .and. fg_rank.eq.0)
 509      &    call MPI_Bcast(1,1,MPI_INTEGER,king,FG_COMM,IERROR)
 510 #endif
 511 C
 512 C 9/29/08 AL Transform parts of gradients in site coordinates to the gradient
 513 C            in virtual-bond-vector coordinates
 514 C
 515 #ifdef DEBUG
 516 c      write (iout,*) "gel_loc gel_loc_long and gel_loc_loc"
 517 c      do i=1,nres-1
 518 c        write (iout,'(i5,3f10.5,2x,3f10.5,2x,f10.5)')
 519 c     &   i,(gel_loc(j,i),j=1,3),(gel_loc_long(j,i),j=1,3),gel_loc_loc(i)
 520 c      enddo
 521 c      write (iout,*) "gel_loc_tur3 gel_loc_turn4"
 522 c      do i=1,nres-1
 523 c        write (iout,'(i5,3f10.5,2x,f10.5)')
 524 c     &  i,(gcorr4_turn(j,i),j=1,3),gel_loc_turn4(i)
 525 c      enddo
 526       write (iout,*) "gradcorr5 gradcorr5_long gradcorr5_loc"
 527       do i=1,nres
 528         write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)')
 529      &   i,(gradcorr5(j,i),j=1,3),(gradcorr5_long(j,i),j=1,3),
 530      &   g_corr5_loc(i)
 531       enddo
 532       call flush(iout)
 533 #endif
 534 #ifdef SPLITELE
 535       do i=0,nct
 536         do j=1,3
 537           gradbufc(j,i)=wsc*gvdwc(j,i)+
 538      &                wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+
 539      &                welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+
 540      &                wel_loc*gel_loc_long(j,i)+
 541      &                wcorr*gradcorr_long(j,i)+
 542      &                wcorr5*gradcorr5_long(j,i)+
 543      &                wcorr6*gradcorr6_long(j,i)+
 544      &                wturn6*gcorr6_turn_long(j,i)+
 545      &                wstrain*ghpbc(j,i)
 546      &                +wliptran*gliptranc(j,i)
 547      &                +gradafm(j,i)
 548
 549         enddo
 550       enddo
 551 #else
 552       do i=0,nct
 553         do j=1,3
 554           gradbufc(j,i)=wsc*gvdwc(j,i)+
 555      &                wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+
 556      &                welec*gelc_long(j,i)+
 557      &                wbond*gradb(j,i)+
 558      &                wel_loc*gel_loc_long(j,i)+
 559      &                wcorr*gradcorr_long(j,i)+
 560      &                wcorr5*gradcorr5_long(j,i)+
 561      &                wcorr6*gradcorr6_long(j,i)+
 562      &                wturn6*gcorr6_turn_long(j,i)+
 563      &                wstrain*ghpbc(j,i)
 564      &                +wliptran*gliptranc(j,i)
 565      &                +gradafm(j,i)
 566
 567         enddo
 568       enddo
 569 #endif
 570 #ifdef MPI
 571       if (nfgtasks.gt.1) then
 572       time00=MPI_Wtime()
 573 #ifdef DEBUG
 574       write (iout,*) "gradbufc before allreduce"
 575       do i=1,nres
 576         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 577       enddo
 578       call flush(iout)
 579 #endif
 580       do i=0,nres
 581         do j=1,3
 582           gradbufc_sum(j,i)=gradbufc(j,i)
 583         enddo
 584       enddo
 585 c      call MPI_AllReduce(gradbufc(1,1),gradbufc_sum(1,1),3*nres,
 586 c     &    MPI_DOUBLE_PRECISION,MPI_SUM,FG_COMM,IERR)
 587 c      time_reduce=time_reduce+MPI_Wtime()-time00
 588 #ifdef DEBUG
 589 c      write (iout,*) "gradbufc_sum after allreduce"
 590 c      do i=1,nres
 591 c        write (iout,'(i3,3f10.5)') i,(gradbufc_sum(j,i),j=1,3)
 592 c      enddo
 593 c      call flush(iout)
 594 #endif
 595 #ifdef TIMING
 596 c      time_allreduce=time_allreduce+MPI_Wtime()-time00
 597 #endif
 598       do i=nnt,nres
 599         do k=1,3
 600           gradbufc(k,i)=0.0d0
 601         enddo
 602       enddo
 603 #ifdef DEBUG
 604       write (iout,*) "igrad_start",igrad_start," igrad_end",igrad_end
 605       write (iout,*) (i," jgrad_start",jgrad_start(i),
 606      &                  " jgrad_end  ",jgrad_end(i),
 607      &                  i=igrad_start,igrad_end)
 608 #endif
 609 c
 610 c Obsolete and inefficient code; we can make the effort O(n) and, therefore,
 611 c do not parallelize this part.
 612 c
 613 c      do i=igrad_start,igrad_end
 614 c        do j=jgrad_start(i),jgrad_end(i)
 615 c          do k=1,3
 616 c            gradbufc(k,i)=gradbufc(k,i)+gradbufc_sum(k,j)
 617 c          enddo
 618 c        enddo
 619 c      enddo
 620       do j=1,3
 621         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
 622       enddo
 623       do i=nres-2,-1,-1
 624         do j=1,3
 625           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
 626         enddo
 627       enddo
 628 #ifdef DEBUG
 629       write (iout,*) "gradbufc after summing"
 630       do i=1,nres
 631         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 632       enddo
 633       call flush(iout)
 634 #endif
 635       else
 636 #endif
 637 #ifdef DEBUG
 638       write (iout,*) "gradbufc"
 639       do i=1,nres
 640         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 641       enddo
 642       call flush(iout)
 643 #endif
 644       do i=-1,nres
 645         do j=1,3
 646           gradbufc_sum(j,i)=gradbufc(j,i)
 647           gradbufc(j,i)=0.0d0
 648         enddo
 649       enddo
 650       do j=1,3
 651         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
 652       enddo
 653       do i=nres-2,-1,-1
 654         do j=1,3
 655           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
 656         enddo
 657       enddo
 658 c      do i=nnt,nres-1
 659 c        do k=1,3
 660 c          gradbufc(k,i)=0.0d0
 661 c        enddo
 662 c        do j=i+1,nres
 663 c          do k=1,3
 664 c            gradbufc(k,i)=gradbufc(k,i)+gradbufc(k,j)
 665 c          enddo
 666 c        enddo
 667 c      enddo
 668 #ifdef DEBUG
 669       write (iout,*) "gradbufc after summing"
 670       do i=1,nres
 671         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 672       enddo
 673       call flush(iout)
 674 #endif
 675 #ifdef MPI
 676       endif
 677 #endif
 678       do k=1,3
 679         gradbufc(k,nres)=0.0d0
 680       enddo
 681       do i=-1,nct
 682         do j=1,3
 683 #ifdef SPLITELE
 684           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+
 685      &                wel_loc*gel_loc(j,i)+
 686      &                0.5d0*(wscp*gvdwc_scpp(j,i)+
 687      &                welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+
 688      &                wel_loc*gel_loc_long(j,i)+
 689      &                wcorr*gradcorr_long(j,i)+
 690      &                wcorr5*gradcorr5_long(j,i)+
 691      &                wcorr6*gradcorr6_long(j,i)+
 692      &                wturn6*gcorr6_turn_long(j,i))+
 693      &                wbond*gradb(j,i)+
 694      &                wcorr*gradcorr(j,i)+
 695      &                wturn3*gcorr3_turn(j,i)+
 696      &                wturn4*gcorr4_turn(j,i)+
 697      &                wcorr5*gradcorr5(j,i)+
 698      &                wcorr6*gradcorr6(j,i)+
 699      &                wturn6*gcorr6_turn(j,i)+
 700      &                wsccor*gsccorc(j,i)
 701      &               +wscloc*gscloc(j,i)
 702      &               +wliptran*gliptranc(j,i)
 703      &                +gradafm(j,i)
 704 #else
 705           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+
 706      &                wel_loc*gel_loc(j,i)+
 707      &                0.5d0*(wscp*gvdwc_scpp(j,i)+
 708      &                welec*gelc_long(j,i)
 709      &                wel_loc*gel_loc_long(j,i)+
 710      &                wcorr*gcorr_long(j,i)+
 711      &                wcorr5*gradcorr5_long(j,i)+
 712      &                wcorr6*gradcorr6_long(j,i)+
 713      &                wturn6*gcorr6_turn_long(j,i))+
 714      &                wbond*gradb(j,i)+
 715      &                wcorr*gradcorr(j,i)+
 716      &                wturn3*gcorr3_turn(j,i)+
 717      &                wturn4*gcorr4_turn(j,i)+
 718      &                wcorr5*gradcorr5(j,i)+
 719      &                wcorr6*gradcorr6(j,i)+
 720      &                wturn6*gcorr6_turn(j,i)+
 721      &                wsccor*gsccorc(j,i)
 722      &               +wscloc*gscloc(j,i)
 723      &               +wliptran*gliptranc(j,i)
 724      &                +gradafm(j,i)
 725
 726 #endif
 727           gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+
 728      &                  wbond*gradbx(j,i)+
 729      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
 730      &                  wsccor*gsccorx(j,i)
 731      &                 +wscloc*gsclocx(j,i)
 732      &                 +wliptran*gliptranx(j,i)
 733         enddo
 734       enddo
 735 #ifdef DEBUG
 736       write (iout,*) "gloc before adding corr"
 737       do i=1,4*nres
 738         write (iout,*) i,gloc(i,icg)
 739       enddo
 740 #endif
 741       do i=1,nres-3
 742         gloc(i,icg)=gloc(i,icg)+wcorr*gcorr_loc(i)
 743      &   +wcorr5*g_corr5_loc(i)
 744      &   +wcorr6*g_corr6_loc(i)
 745      &   +wturn4*gel_loc_turn4(i)
 746      &   +wturn3*gel_loc_turn3(i)
 747      &   +wturn6*gel_loc_turn6(i)
 748      &   +wel_loc*gel_loc_loc(i)
 749       enddo
 750 #ifdef DEBUG
 751       write (iout,*) "gloc after adding corr"
 752       do i=1,4*nres
 753         write (iout,*) i,gloc(i,icg)
 754       enddo
 755 #endif
 756 #ifdef MPI
 757       if (nfgtasks.gt.1) then
 758         do j=1,3
 759           do i=1,nres
 760             gradbufc(j,i)=gradc(j,i,icg)
 761             gradbufx(j,i)=gradx(j,i,icg)
 762           enddo
 763         enddo
 764         do i=1,4*nres
 765           glocbuf(i)=gloc(i,icg)
 766         enddo
 767 c#define DEBUG
 768 #ifdef DEBUG
 769       write (iout,*) "gloc_sc before reduce"
 770       do i=1,nres
 771        do j=1,1
 772         write (iout,*) i,j,gloc_sc(j,i,icg)
 773        enddo
 774       enddo
 775 #endif
 776 c#undef DEBUG
 777         do i=1,nres
 778          do j=1,3
 779           gloc_scbuf(j,i)=gloc_sc(j,i,icg)
 780          enddo
 781         enddo
 782         time00=MPI_Wtime()
 783         call MPI_Barrier(FG_COMM,IERR)
 784         time_barrier_g=time_barrier_g+MPI_Wtime()-time00
 785         time00=MPI_Wtime()
 786         call MPI_Reduce(gradbufc(1,1),gradc(1,1,icg),3*nres,
 787      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 788         call MPI_Reduce(gradbufx(1,1),gradx(1,1,icg),3*nres,
 789      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 790         call MPI_Reduce(glocbuf(1),gloc(1,icg),4*nres,
 791      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 792         time_reduce=time_reduce+MPI_Wtime()-time00
 793         call MPI_Reduce(gloc_scbuf(1,1),gloc_sc(1,1,icg),3*nres,
 794      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 795         time_reduce=time_reduce+MPI_Wtime()-time00
 796 c#define DEBUG
 797 #ifdef DEBUG
 798       write (iout,*) "gloc_sc after reduce"
 799       do i=1,nres
 800        do j=1,1
 801         write (iout,*) i,j,gloc_sc(j,i,icg)
 802        enddo
 803       enddo
 804 #endif
 805 c#undef DEBUG
 806 #ifdef DEBUG
 807       write (iout,*) "gloc after reduce"
 808       do i=1,4*nres
 809         write (iout,*) i,gloc(i,icg)
 810       enddo
 811 #endif
 812       endif
 813 #endif
 814       if (gnorm_check) then
 815 c
 816 c Compute the maximum elements of the gradient
 817 c
 818       gvdwc_max=0.0d0
 819       gvdwc_scp_max=0.0d0
 820       gelc_max=0.0d0
 821       gvdwpp_max=0.0d0
 822       gradb_max=0.0d0
 823       ghpbc_max=0.0d0
 824       gradcorr_max=0.0d0
 825       gel_loc_max=0.0d0
 826       gcorr3_turn_max=0.0d0
 827       gcorr4_turn_max=0.0d0
 828       gradcorr5_max=0.0d0
 829       gradcorr6_max=0.0d0
 830       gcorr6_turn_max=0.0d0
 831       gsccorc_max=0.0d0
 832       gscloc_max=0.0d0
 833       gvdwx_max=0.0d0
 834       gradx_scp_max=0.0d0
 835       ghpbx_max=0.0d0
 836       gradxorr_max=0.0d0
 837       gsccorx_max=0.0d0
 838       gsclocx_max=0.0d0
 839       do i=1,nct
 840         gvdwc_norm=dsqrt(scalar(gvdwc(1,i),gvdwc(1,i)))
 841         if (gvdwc_norm.gt.gvdwc_max) gvdwc_max=gvdwc_norm
 842         gvdwc_scp_norm=dsqrt(scalar(gvdwc_scp(1,i),gvdwc_scp(1,i)))
 843         if (gvdwc_scp_norm.gt.gvdwc_scp_max)
 844      &   gvdwc_scp_max=gvdwc_scp_norm
 845         gelc_norm=dsqrt(scalar(gelc(1,i),gelc(1,i)))
 846         if (gelc_norm.gt.gelc_max) gelc_max=gelc_norm
 847         gvdwpp_norm=dsqrt(scalar(gvdwpp(1,i),gvdwpp(1,i)))
 848         if (gvdwpp_norm.gt.gvdwpp_max) gvdwpp_max=gvdwpp_norm
 849         gradb_norm=dsqrt(scalar(gradb(1,i),gradb(1,i)))
 850         if (gradb_norm.gt.gradb_max) gradb_max=gradb_norm
 851         ghpbc_norm=dsqrt(scalar(ghpbc(1,i),ghpbc(1,i)))
 852         if (ghpbc_norm.gt.ghpbc_max) ghpbc_max=ghpbc_norm
 853         gradcorr_norm=dsqrt(scalar(gradcorr(1,i),gradcorr(1,i)))
 854         if (gradcorr_norm.gt.gradcorr_max) gradcorr_max=gradcorr_norm
 855         gel_loc_norm=dsqrt(scalar(gel_loc(1,i),gel_loc(1,i)))
 856         if (gel_loc_norm.gt.gel_loc_max) gel_loc_max=gel_loc_norm
 857         gcorr3_turn_norm=dsqrt(scalar(gcorr3_turn(1,i),
 858      &    gcorr3_turn(1,i)))
 859         if (gcorr3_turn_norm.gt.gcorr3_turn_max)
 860      &    gcorr3_turn_max=gcorr3_turn_norm
 861         gcorr4_turn_norm=dsqrt(scalar(gcorr4_turn(1,i),
 862      &    gcorr4_turn(1,i)))
 863         if (gcorr4_turn_norm.gt.gcorr4_turn_max)
 864      &    gcorr4_turn_max=gcorr4_turn_norm
 865         gradcorr5_norm=dsqrt(scalar(gradcorr5(1,i),gradcorr5(1,i)))
 866         if (gradcorr5_norm.gt.gradcorr5_max)
 867      &    gradcorr5_max=gradcorr5_norm
 868         gradcorr6_norm=dsqrt(scalar(gradcorr6(1,i),gradcorr6(1,i)))
 869         if (gradcorr6_norm.gt.gradcorr6_max) gcorr6_max=gradcorr6_norm
 870         gcorr6_turn_norm=dsqrt(scalar(gcorr6_turn(1,i),
 871      &    gcorr6_turn(1,i)))
 872         if (gcorr6_turn_norm.gt.gcorr6_turn_max)
 873      &    gcorr6_turn_max=gcorr6_turn_norm
 874         gsccorr_norm=dsqrt(scalar(gsccorc(1,i),gsccorc(1,i)))
 875         if (gsccorr_norm.gt.gsccorr_max) gsccorr_max=gsccorr_norm
 876         gscloc_norm=dsqrt(scalar(gscloc(1,i),gscloc(1,i)))
 877         if (gscloc_norm.gt.gscloc_max) gscloc_max=gscloc_norm
 878         gvdwx_norm=dsqrt(scalar(gvdwx(1,i),gvdwx(1,i)))
 879         if (gvdwx_norm.gt.gvdwx_max) gvdwx_max=gvdwx_norm
 880         gradx_scp_norm=dsqrt(scalar(gradx_scp(1,i),gradx_scp(1,i)))
 881         if (gradx_scp_norm.gt.gradx_scp_max)
 882      &    gradx_scp_max=gradx_scp_norm
 883         ghpbx_norm=dsqrt(scalar(ghpbx(1,i),ghpbx(1,i)))
 884         if (ghpbx_norm.gt.ghpbx_max) ghpbx_max=ghpbx_norm
 885         gradxorr_norm=dsqrt(scalar(gradxorr(1,i),gradxorr(1,i)))
 886         if (gradxorr_norm.gt.gradxorr_max) gradxorr_max=gradxorr_norm
 887         gsccorrx_norm=dsqrt(scalar(gsccorx(1,i),gsccorx(1,i)))
 888         if (gsccorrx_norm.gt.gsccorrx_max) gsccorrx_max=gsccorrx_norm
 889         gsclocx_norm=dsqrt(scalar(gsclocx(1,i),gsclocx(1,i)))
 890         if (gsclocx_norm.gt.gsclocx_max) gsclocx_max=gsclocx_norm
 891       enddo
 892       if (gradout) then
 893 #ifdef AIX
 894         open(istat,file=statname,position="append")
 895 #else
 896         open(istat,file=statname,access="append")
 897 #endif
 898         write (istat,'(1h#,21f10.2)') gvdwc_max,gvdwc_scp_max,
 899      &     gelc_max,gvdwpp_max,gradb_max,ghpbc_max,
 900      &     gradcorr_max,gel_loc_max,gcorr3_turn_max,gcorr4_turn_max,
 901      &     gradcorr5_max,gradcorr6_max,gcorr6_turn_max,gsccorc_max,
 902      &     gscloc_max,gvdwx_max,gradx_scp_max,ghpbx_max,gradxorr_max,
 903      &     gsccorx_max,gsclocx_max
 904         close(istat)
 905         if (gvdwc_max.gt.1.0d4) then
 906           write (iout,*) "gvdwc gvdwx gradb gradbx"
 907           do i=nnt,nct
 908             write(iout,'(i5,4(3f10.2,5x))') i,(gvdwc(j,i),gvdwx(j,i),
 909      &        gradb(j,i),gradbx(j,i),j=1,3)
 910           enddo
 911           call pdbout(0.0d0,'cipiszcze',iout)
 912           call flush(iout)
 913         endif
 914       endif
 915       endif
 916 #ifdef DEBUG
 917       write (iout,*) "gradc gradx gloc"
 918       do i=1,nres
 919         write (iout,'(i5,3f10.5,5x,3f10.5,5x,f10.5)')
 920      &   i,(gradc(j,i,icg),j=1,3),(gradx(j,i,icg),j=1,3),gloc(i,icg)
 921       enddo
 922 #endif
 923 #ifdef TIMING
 924       time_sumgradient=time_sumgradient+MPI_Wtime()-time01
 925 #endif
 926       return
 927       end
 928 c-------------------------------------------------------------------------------
 929       subroutine rescale_weights(t_bath)
 930       implicit real*8 (a-h,o-z)
 931       include 'DIMENSIONS'
 932       include 'COMMON.IOUNITS'
 933       include 'COMMON.FFIELD'
 934       include 'COMMON.SBRIDGE'
 935       double precision kfac /2.4d0/
 936       double precision x,x2,x3,x4,x5,licznik /1.12692801104297249644/
 937 c      facT=temp0/t_bath
 938 c      facT=2*temp0/(t_bath+temp0)
 939       if (rescale_mode.eq.0) then
 940         facT=1.0d0
 941         facT2=1.0d0
 942         facT3=1.0d0
 943         facT4=1.0d0
 944         facT5=1.0d0
 945       else if (rescale_mode.eq.1) then
 946         facT=kfac/(kfac-1.0d0+t_bath/temp0)
 947         facT2=kfac**2/(kfac**2-1.0d0+(t_bath/temp0)**2)
 948         facT3=kfac**3/(kfac**3-1.0d0+(t_bath/temp0)**3)
 949         facT4=kfac**4/(kfac**4-1.0d0+(t_bath/temp0)**4)
 950         facT5=kfac**5/(kfac**5-1.0d0+(t_bath/temp0)**5)
 951       else if (rescale_mode.eq.2) then
 952         x=t_bath/temp0
 953         x2=x*x
 954         x3=x2*x
 955         x4=x3*x
 956         x5=x4*x
 957         facT=licznik/dlog(dexp(x)+dexp(-x))
 958         facT2=licznik/dlog(dexp(x2)+dexp(-x2))
 959         facT3=licznik/dlog(dexp(x3)+dexp(-x3))
 960         facT4=licznik/dlog(dexp(x4)+dexp(-x4))
 961         facT5=licznik/dlog(dexp(x5)+dexp(-x5))
 962       else
 963         write (iout,*) "Wrong RESCALE_MODE",rescale_mode
 964         write (*,*) "Wrong RESCALE_MODE",rescale_mode
 965 #ifdef MPI
 966        call MPI_Finalize(MPI_COMM_WORLD,IERROR)
 967 #endif
 968        stop 555
 969       endif
 970       welec=weights(3)*fact
 971       wcorr=weights(4)*fact3
 972       wcorr5=weights(5)*fact4
 973       wcorr6=weights(6)*fact5
 974       wel_loc=weights(7)*fact2
 975       wturn3=weights(8)*fact2
 976       wturn4=weights(9)*fact3
 977       wturn6=weights(10)*fact5
 978       wtor=weights(13)*fact
 979       wtor_d=weights(14)*fact2
 980       wsccor=weights(21)*fact
 981
 982       return
 983       end
 984 C------------------------------------------------------------------------
 985       subroutine enerprint(energia)
 986       implicit real*8 (a-h,o-z)
 987       include 'DIMENSIONS'
 988       include 'COMMON.IOUNITS'
 989       include 'COMMON.FFIELD'
 990       include 'COMMON.SBRIDGE'
 991       include 'COMMON.MD'
 992       double precision energia(0:n_ene)
 993       etot=energia(0)
 994       evdw=energia(1)
 995       evdw2=energia(2)
 996 #ifdef SCP14
 997       evdw2=energia(2)+energia(18)
 998 #else
 999       evdw2=energia(2)
1000 #endif
1001       ees=energia(3)
1002 #ifdef SPLITELE
1003       evdw1=energia(16)
1004 #endif
1005       ecorr=energia(4)
1006       ecorr5=energia(5)
1007       ecorr6=energia(6)
1008       eel_loc=energia(7)
1009       eello_turn3=energia(8)
1010       eello_turn4=energia(9)
1011       eello_turn6=energia(10)
1012       ebe=energia(11)
1013       escloc=energia(12)
1014       etors=energia(13)
1015       etors_d=energia(14)
1016       ehpb=energia(15)
1017       edihcnstr=energia(19)
1018       estr=energia(17)
1019       Uconst=energia(20)
1020       esccor=energia(21)
1021       eliptran=energia(22)
1022       Eafmforce=energia(23)
1023       ethetacnstr=energia(24)
1024 #ifdef SPLITELE
1025       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,evdw1,wvdwpp,
1026      &  estr,wbond,ebe,wang,
1027      &  escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,
1028      &  ecorr,wcorr,
1029      &  ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,
1030      &  eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccro,edihcnstr,
1031      &  ethetacnstr,ebr*nss,Uconst,eliptran,wliptran,Eafmforc,
1032      &  etot
1033    10 format (/'Virtual-chain energies:'//
1034      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
1035      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
1036      & 'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/
1037      & 'EVDWPP=',1pE16.6,' WEIGHT=',1pD16.6,' (p-p VDW)'/
1038      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
1039      & 'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
1040      & 'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
1041      & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
1042      & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
1043      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6,
1044      & ' (SS bridges & dist. cnstr.)'/
1045      & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1046      & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1047      & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1048      & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
1049      & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
1050      & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
1051      & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
1052      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
1053      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
1054      & 'ETHETC= ',1pE16.6,' (valence angle constraints)'/
1055      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
1056      & 'UCONST= ',1pE16.6,' (Constraint energy)'/
1057      & 'ELT=',1pE16.6, ' WEIGHT=',1pD16.6,' (Lipid transfer energy)'/
1058      & 'EAFM=  ',1pE16.6,' (atomic-force microscopy)'/
1059      & 'ETOT=  ',1pE16.6,' (total)')
1060
1061 #else
1062       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,
1063      &  estr,wbond,ebe,wang,
1064      &  escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,
1065      &  ecorr,wcorr,
1066      &  ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,
1067      &  eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccro,edihcnstr,
1068      &  ethetacnstr,ebr*nss,Uconst,eliptran,wliptran,Eafmforc,
1069      &  etot
1070    10 format (/'Virtual-chain energies:'//
1071      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
1072      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
1073      & 'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/
1074      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
1075      & 'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
1076      & 'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
1077      & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
1078      & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
1079      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6,
1080      & ' (SS bridges & dist. cnstr.)'/
1081      & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1082      & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1083      & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1084      & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
1085      & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
1086      & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
1087      & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
1088      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
1089      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
1090      & 'ETHETC= ',1pE16.6,' (valence angle constraints)'/
1091      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
1092      & 'UCONST=',1pE16.6,' (Constraint energy)'/
1093      & 'ELT=',1pE16.6, ' WEIGHT=',1pD16.6,' (Lipid transfer energy)'/
1094      & 'EAFM=  ',1pE16.6,' (atomic-force microscopy)'/
1095      & 'ETOT=  ',1pE16.6,' (total)')
1096 #endif
1097       return
1098       end
1099 C-----------------------------------------------------------------------
1100       subroutine elj(evdw)
1101 C
1102 C This subroutine calculates the interaction energy of nonbonded side chains
1103 C assuming the LJ potential of interaction.
1104 C
1105       implicit real*8 (a-h,o-z)
1106       include 'DIMENSIONS'
1107       parameter (accur=1.0d-10)
1108       include 'COMMON.GEO'
1109       include 'COMMON.VAR'
1110       include 'COMMON.LOCAL'
1111       include 'COMMON.CHAIN'
1112       include 'COMMON.DERIV'
1113       include 'COMMON.INTERACT'
1114       include 'COMMON.TORSION'
1115       include 'COMMON.SBRIDGE'
1116       include 'COMMON.NAMES'
1117       include 'COMMON.IOUNITS'
1118       include 'COMMON.CONTACTS'
1119       dimension gg(3)
1120 c      write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
1121       evdw=0.0D0
1122       do i=iatsc_s,iatsc_e
1123         itypi=iabs(itype(i))
1124         if (itypi.eq.ntyp1) cycle
1125         itypi1=iabs(itype(i+1))
1126         xi=c(1,nres+i)
1127         yi=c(2,nres+i)
1128         zi=c(3,nres+i)
1129 C Change 12/1/95
1130         num_conti=0
1131 C
1132 C Calculate SC interaction energy.
1133 C
1134         do iint=1,nint_gr(i)
1135 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
1136 cd   &                  'iend=',iend(i,iint)
1137           do j=istart(i,iint),iend(i,iint)
1138             itypj=iabs(itype(j))
1139             if (itypj.eq.ntyp1) cycle
1140             xj=c(1,nres+j)-xi
1141             yj=c(2,nres+j)-yi
1142             zj=c(3,nres+j)-zi
1143 C Change 12/1/95 to calculate four-body interactions
1144             rij=xj*xj+yj*yj+zj*zj
1145             rrij=1.0D0/rij
1146 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
1147             eps0ij=eps(itypi,itypj)
1148             fac=rrij**expon2
1149 C have you changed here?
1150             e1=fac*fac*aa
1151             e2=fac*bb
1152             evdwij=e1+e2
1153 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1154 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1155 cd          write (iout,'(2(a3,i3,2x),6(1pd12.4)/2(3(1pd12.4),5x)/)')
1156 cd   &        restyp(itypi),i,restyp(itypj),j,a(itypi,itypj),
1157 cd   &        bb(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,epsi,sigm,
1158 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1159             evdw=evdw+evdwij
1160 C
1161 C Calculate the components of the gradient in DC and X
1162 C
1163             fac=-rrij*(e1+evdwij)
1164             gg(1)=xj*fac
1165             gg(2)=yj*fac
1166             gg(3)=zj*fac
1167             do k=1,3
1168               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1169               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1170               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1171               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1172             enddo
1173 cgrad            do k=i,j-1
1174 cgrad              do l=1,3
1175 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1176 cgrad              enddo
1177 cgrad            enddo
1178 C
1179 C 12/1/95, revised on 5/20/97
1180 C
1181 C Calculate the contact function. The ith column of the array JCONT will
1182 C contain the numbers of atoms that make contacts with the atom I (of numbers
1183 C greater than I). The arrays FACONT and GACONT will contain the values of
1184 C the contact function and its derivative.
1185 C
1186 C Uncomment next line, if the correlation interactions include EVDW explicitly.
1187 c           if (j.gt.i+1 .and. evdwij.le.0.0D0) then
1188 C Uncomment next line, if the correlation interactions are contact function only
1189             if (j.gt.i+1.and. eps0ij.gt.0.0D0) then
1190               rij=dsqrt(rij)
1191               sigij=sigma(itypi,itypj)
1192               r0ij=rs0(itypi,itypj)
1193 C
1194 C Check whether the SC's are not too far to make a contact.
1195 C
1196               rcut=1.5d0*r0ij
1197               call gcont(rij,rcut,1.0d0,0.2d0*rcut,fcont,fprimcont)
1198 C Add a new contact, if the SC's are close enough, but not too close (r<sigma).
1199 C
1200               if (fcont.gt.0.0D0) then
1201 C If the SC-SC distance if close to sigma, apply spline.
1202 cAdam           call gcont(-rij,-1.03d0*sigij,2.0d0*sigij,1.0d0,
1203 cAdam &             fcont1,fprimcont1)
1204 cAdam           fcont1=1.0d0-fcont1
1205 cAdam           if (fcont1.gt.0.0d0) then
1206 cAdam             fprimcont=fprimcont*fcont1+fcont*fprimcont1
1207 cAdam             fcont=fcont*fcont1
1208 cAdam           endif
1209 C Uncomment following 4 lines to have the geometric average of the epsilon0's
1210 cga             eps0ij=1.0d0/dsqrt(eps0ij)
1211 cga             do k=1,3
1212 cga               gg(k)=gg(k)*eps0ij
1213 cga             enddo
1214 cga             eps0ij=-evdwij*eps0ij
1215 C Uncomment for AL's type of SC correlation interactions.
1216 cadam           eps0ij=-evdwij
1217                 num_conti=num_conti+1
1218                 jcont(num_conti,i)=j
1219                 facont(num_conti,i)=fcont*eps0ij
1220                 fprimcont=eps0ij*fprimcont/rij
1221                 fcont=expon*fcont
1222 cAdam           gacont(1,num_conti,i)=-fprimcont*xj+fcont*gg(1)
1223 cAdam           gacont(2,num_conti,i)=-fprimcont*yj+fcont*gg(2)
1224 cAdam           gacont(3,num_conti,i)=-fprimcont*zj+fcont*gg(3)
1225 C Uncomment following 3 lines for Skolnick's type of SC correlation.
1226                 gacont(1,num_conti,i)=-fprimcont*xj
1227                 gacont(2,num_conti,i)=-fprimcont*yj
1228                 gacont(3,num_conti,i)=-fprimcont*zj
1229 cd              write (iout,'(2i5,2f10.5)') i,j,rij,facont(num_conti,i)
1230 cd              write (iout,'(2i3,3f10.5)')
1231 cd   &           i,j,(gacont(kk,num_conti,i),kk=1,3)
1232               endif
1233             endif
1234           enddo      ! j
1235         enddo        ! iint
1236 C Change 12/1/95
1237         num_cont(i)=num_conti
1238       enddo          ! i
1239       do i=1,nct
1240         do j=1,3
1241           gvdwc(j,i)=expon*gvdwc(j,i)
1242           gvdwx(j,i)=expon*gvdwx(j,i)
1243         enddo
1244       enddo
1245 C******************************************************************************
1246 C
1247 C                              N O T E !!!
1248 C
1249 C To save time, the factor of EXPON has been extracted from ALL components
1250 C of GVDWC and GRADX. Remember to multiply them by this factor before further
1251 C use!
1252 C
1253 C******************************************************************************
1254       return
1255       end
1256 C-----------------------------------------------------------------------------
1257       subroutine eljk(evdw)
1258 C
1259 C This subroutine calculates the interaction energy of nonbonded side chains
1260 C assuming the LJK potential of interaction.
1261 C
1262       implicit real*8 (a-h,o-z)
1263       include 'DIMENSIONS'
1264       include 'COMMON.GEO'
1265       include 'COMMON.VAR'
1266       include 'COMMON.LOCAL'
1267       include 'COMMON.CHAIN'
1268       include 'COMMON.DERIV'
1269       include 'COMMON.INTERACT'
1270       include 'COMMON.IOUNITS'
1271       include 'COMMON.NAMES'
1272       dimension gg(3)
1273       logical scheck
1274 c     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
1275       evdw=0.0D0
1276       do i=iatsc_s,iatsc_e
1277         itypi=iabs(itype(i))
1278         if (itypi.eq.ntyp1) cycle
1279         itypi1=iabs(itype(i+1))
1280         xi=c(1,nres+i)
1281         yi=c(2,nres+i)
1282         zi=c(3,nres+i)
1283 C
1284 C Calculate SC interaction energy.
1285 C
1286         do iint=1,nint_gr(i)
1287           do j=istart(i,iint),iend(i,iint)
1288             itypj=iabs(itype(j))
1289             if (itypj.eq.ntyp1) cycle
1290             xj=c(1,nres+j)-xi
1291             yj=c(2,nres+j)-yi
1292             zj=c(3,nres+j)-zi
1293             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1294             fac_augm=rrij**expon
1295             e_augm=augm(itypi,itypj)*fac_augm
1296             r_inv_ij=dsqrt(rrij)
1297             rij=1.0D0/r_inv_ij
1298             r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
1299             fac=r_shift_inv**expon
1300 C have you changed here?
1301             e1=fac*fac*aa
1302             e2=fac*bb
1303             evdwij=e_augm+e1+e2
1304 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1305 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1306 cd          write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
1307 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
1308 cd   &        bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
1309 cd   &        sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
1310 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1311             evdw=evdw+evdwij
1312 C
1313 C Calculate the components of the gradient in DC and X
1314 C
1315             fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
1316             gg(1)=xj*fac
1317             gg(2)=yj*fac
1318             gg(3)=zj*fac
1319             do k=1,3
1320               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1321               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1322               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1323               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1324             enddo
1325 cgrad            do k=i,j-1
1326 cgrad              do l=1,3
1327 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1328 cgrad              enddo
1329 cgrad            enddo
1330           enddo      ! j
1331         enddo        ! iint
1332       enddo          ! i
1333       do i=1,nct
1334         do j=1,3
1335           gvdwc(j,i)=expon*gvdwc(j,i)
1336           gvdwx(j,i)=expon*gvdwx(j,i)
1337         enddo
1338       enddo
1339       return
1340       end
1341 C-----------------------------------------------------------------------------
1342       subroutine ebp(evdw)
1343 C
1344 C This subroutine calculates the interaction energy of nonbonded side chains
1345 C assuming the Berne-Pechukas potential of interaction.
1346 C
1347       implicit real*8 (a-h,o-z)
1348       include 'DIMENSIONS'
1349       include 'COMMON.GEO'
1350       include 'COMMON.VAR'
1351       include 'COMMON.LOCAL'
1352       include 'COMMON.CHAIN'
1353       include 'COMMON.DERIV'
1354       include 'COMMON.NAMES'
1355       include 'COMMON.INTERACT'
1356       include 'COMMON.IOUNITS'
1357       include 'COMMON.CALC'
1358       common /srutu/ icall
1359 c     double precision rrsave(maxdim)
1360       logical lprn
1361       evdw=0.0D0
1362 c     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
1363       evdw=0.0D0
1364 c     if (icall.eq.0) then
1365 c       lprn=.true.
1366 c     else
1367         lprn=.false.
1368 c     endif
1369       ind=0
1370       do i=iatsc_s,iatsc_e
1371         itypi=iabs(itype(i))
1372         if (itypi.eq.ntyp1) cycle
1373         itypi1=iabs(itype(i+1))
1374         xi=c(1,nres+i)
1375         yi=c(2,nres+i)
1376         zi=c(3,nres+i)
1377         dxi=dc_norm(1,nres+i)
1378         dyi=dc_norm(2,nres+i)
1379         dzi=dc_norm(3,nres+i)
1380 c        dsci_inv=dsc_inv(itypi)
1381         dsci_inv=vbld_inv(i+nres)
1382 C
1383 C Calculate SC interaction energy.
1384 C
1385         do iint=1,nint_gr(i)
1386           do j=istart(i,iint),iend(i,iint)
1387             ind=ind+1
1388             itypj=iabs(itype(j))
1389             if (itypj.eq.ntyp1) cycle
1390 c            dscj_inv=dsc_inv(itypj)
1391             dscj_inv=vbld_inv(j+nres)
1392             chi1=chi(itypi,itypj)
1393             chi2=chi(itypj,itypi)
1394             chi12=chi1*chi2
1395             chip1=chip(itypi)
1396             chip2=chip(itypj)
1397             chip12=chip1*chip2
1398             alf1=alp(itypi)
1399             alf2=alp(itypj)
1400             alf12=0.5D0*(alf1+alf2)
1401 C For diagnostics only!!!
1402 c           chi1=0.0D0
1403 c           chi2=0.0D0
1404 c           chi12=0.0D0
1405 c           chip1=0.0D0
1406 c           chip2=0.0D0
1407 c           chip12=0.0D0
1408 c           alf1=0.0D0
1409 c           alf2=0.0D0
1410 c           alf12=0.0D0
1411             xj=c(1,nres+j)-xi
1412             yj=c(2,nres+j)-yi
1413             zj=c(3,nres+j)-zi
1414             dxj=dc_norm(1,nres+j)
1415             dyj=dc_norm(2,nres+j)
1416             dzj=dc_norm(3,nres+j)
1417             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1418 cd          if (icall.eq.0) then
1419 cd            rrsave(ind)=rrij
1420 cd          else
1421 cd            rrij=rrsave(ind)
1422 cd          endif
1423             rij=dsqrt(rrij)
1424 C Calculate the angle-dependent terms of energy & contributions to derivatives.
1425             call sc_angular
1426 C Calculate whole angle-dependent part of epsilon and contributions
1427 C to its derivatives
1428 C have you changed here?
1429             fac=(rrij*sigsq)**expon2
1430             e1=fac*fac*aa
1431             e2=fac*bb
1432             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1433             eps2der=evdwij*eps3rt
1434             eps3der=evdwij*eps2rt
1435             evdwij=evdwij*eps2rt*eps3rt
1436             evdw=evdw+evdwij
1437             if (lprn) then
1438             sigm=dabs(aa/bb)**(1.0D0/6.0D0)
1439             epsi=bb**2/aa
1440 cd            write (iout,'(2(a3,i3,2x),15(0pf7.3))')
1441 cd     &        restyp(itypi),i,restyp(itypj),j,
1442 cd     &        epsi,sigm,chi1,chi2,chip1,chip2,
1443 cd     &        eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
1444 cd     &        om1,om2,om12,1.0D0/dsqrt(rrij),
1445 cd     &        evdwij
1446             endif
1447 C Calculate gradient components.
1448             e1=e1*eps1*eps2rt**2*eps3rt**2
1449             fac=-expon*(e1+evdwij)
1450             sigder=fac/sigsq
1451             fac=rrij*fac
1452 C Calculate radial part of the gradient
1453             gg(1)=xj*fac
1454             gg(2)=yj*fac
1455             gg(3)=zj*fac
1456 C Calculate the angular part of the gradient and sum add the contributions
1457 C to the appropriate components of the Cartesian gradient.
1458             call sc_grad
1459           enddo      ! j
1460         enddo        ! iint
1461       enddo          ! i
1462 c     stop
1463       return
1464       end
1465 C-----------------------------------------------------------------------------
1466       subroutine egb(evdw)
1467 C
1468 C This subroutine calculates the interaction energy of nonbonded side chains
1469 C assuming the Gay-Berne potential of interaction.
1470 C
1471       implicit real*8 (a-h,o-z)
1472       include 'DIMENSIONS'
1473       include 'COMMON.GEO'
1474       include 'COMMON.VAR'
1475       include 'COMMON.LOCAL'
1476       include 'COMMON.CHAIN'
1477       include 'COMMON.DERIV'
1478       include 'COMMON.NAMES'
1479       include 'COMMON.INTERACT'
1480       include 'COMMON.IOUNITS'
1481       include 'COMMON.CALC'
1482       include 'COMMON.CONTROL'
1483       include 'COMMON.SPLITELE'
1484       include 'COMMON.SBRIDGE'
1485       logical lprn
1486       integer xshift,yshift,zshift
1487
1488       evdw=0.0D0
1489 ccccc      energy_dec=.false.
1490 C      print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1491       evdw=0.0D0
1492       lprn=.false.
1493 c     if (icall.eq.0) lprn=.false.
1494       ind=0
1495 C the loop over all 27 posible neigbours (for xshift=0,yshift=0,zshift=0
1496 C we have the original box)
1497 C      do xshift=-1,1
1498 C      do yshift=-1,1
1499 C      do zshift=-1,1
1500       do i=iatsc_s,iatsc_e
1501         itypi=iabs(itype(i))
1502         if (itypi.eq.ntyp1) cycle
1503         itypi1=iabs(itype(i+1))
1504         xi=c(1,nres+i)
1505         yi=c(2,nres+i)
1506         zi=c(3,nres+i)
1507 C Return atom into box, boxxsize is size of box in x dimension
1508 c  134   continue
1509 c        if (xi.gt.((xshift+0.5d0)*boxxsize)) xi=xi-boxxsize
1510 c        if (xi.lt.((xshift-0.5d0)*boxxsize)) xi=xi+boxxsize
1511 C Condition for being inside the proper box
1512 c        if ((xi.gt.((xshift+0.5d0)*boxxsize)).or.
1513 c     &       (xi.lt.((xshift-0.5d0)*boxxsize))) then
1514 c        go to 134
1515 c        endif
1516 c  135   continue
1517 c        if (yi.gt.((yshift+0.5d0)*boxysize)) yi=yi-boxysize
1518 c        if (yi.lt.((yshift-0.5d0)*boxysize)) yi=yi+boxysize
1519 C Condition for being inside the proper box
1520 c        if ((yi.gt.((yshift+0.5d0)*boxysize)).or.
1521 c     &       (yi.lt.((yshift-0.5d0)*boxysize))) then
1522 c        go to 135
1523 c        endif
1524 c  136   continue
1525 c        if (zi.gt.((zshift+0.5d0)*boxzsize)) zi=zi-boxzsize
1526 c        if (zi.lt.((zshift-0.5d0)*boxzsize)) zi=zi+boxzsize
1527 C Condition for being inside the proper box
1528 c        if ((zi.gt.((zshift+0.5d0)*boxzsize)).or.
1529 c     &       (zi.lt.((zshift-0.5d0)*boxzsize))) then
1530 c        go to 136
1531 c        endif
1532           xi=mod(xi,boxxsize)
1533           if (xi.lt.0) xi=xi+boxxsize
1534           yi=mod(yi,boxysize)
1535           if (yi.lt.0) yi=yi+boxysize
1536           zi=mod(zi,boxzsize)
1537           if (zi.lt.0) zi=zi+boxzsize
1538 C define scaling factor for lipids
1539
1540 C        if (positi.le.0) positi=positi+boxzsize
1541 C        print *,i
1542 C first for peptide groups
1543 c for each residue check if it is in lipid or lipid water border area
1544        if ((zi.gt.bordlipbot)
1545      &.and.(zi.lt.bordliptop)) then
1546 C the energy transfer exist
1547         if (zi.lt.buflipbot) then
1548 C what fraction I am in
1549          fracinbuf=1.0d0-
1550      &        ((zi-bordlipbot)/lipbufthick)
1551 C lipbufthick is thickenes of lipid buffore
1552          sslipi=sscalelip(fracinbuf)
1553          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
1554         elseif (zi.gt.bufliptop) then
1555          fracinbuf=1.0d0-((bordliptop-zi)/lipbufthick)
1556          sslipi=sscalelip(fracinbuf)
1557          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
1558         else
1559          sslipi=1.0d0
1560          ssgradlipi=0.0
1561         endif
1562        else
1563          sslipi=0.0d0
1564          ssgradlipi=0.0
1565        endif
1566
1567 C          xi=xi+xshift*boxxsize
1568 C          yi=yi+yshift*boxysize
1569 C          zi=zi+zshift*boxzsize
1570
1571         dxi=dc_norm(1,nres+i)
1572         dyi=dc_norm(2,nres+i)
1573         dzi=dc_norm(3,nres+i)
1574 c        dsci_inv=dsc_inv(itypi)
1575         dsci_inv=vbld_inv(i+nres)
1576 c        write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)
1577 c        write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi
1578 C
1579 C Calculate SC interaction energy.
1580 C
1581         do iint=1,nint_gr(i)
1582           do j=istart(i,iint),iend(i,iint)
1583             IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN
1584
1585 c              write(iout,*) "PRZED ZWYKLE", evdwij
1586               call dyn_ssbond_ene(i,j,evdwij)
1587 c              write(iout,*) "PO ZWYKLE", evdwij
1588
1589               evdw=evdw+evdwij
1590               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)')
1591      &                        'evdw',i,j,evdwij,' ss'
1592 C triple bond artifac removal
1593              do k=j+1,iend(i,iint)
1594 C search over all next residues
1595               if (dyn_ss_mask(k)) then
1596 C check if they are cysteins
1597 C              write(iout,*) 'k=',k
1598
1599 c              write(iout,*) "PRZED TRI", evdwij
1600                evdwij_przed_tri=evdwij
1601               call triple_ssbond_ene(i,j,k,evdwij)
1602 c               if(evdwij_przed_tri.ne.evdwij) then
1603 c                 write (iout,*) "TRI:", evdwij, evdwij_przed_tri
1604 c               endif
1605
1606 c              write(iout,*) "PO TRI", evdwij
1607 C call the energy function that removes the artifical triple disulfide
1608 C bond the soubroutine is located in ssMD.F
1609               evdw=evdw+evdwij
1610               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)')
1611      &                        'evdw',i,j,evdwij,'tss'
1612               endif!dyn_ss_mask(k)
1613              enddo! k
1614             ELSE
1615             ind=ind+1
1616             itypj=iabs(itype(j))
1617             if (itypj.eq.ntyp1) cycle
1618 c            dscj_inv=dsc_inv(itypj)
1619             dscj_inv=vbld_inv(j+nres)
1620 c            write (iout,*) "j",j,dsc_inv(itypj),dscj_inv,
1621 c     &       1.0d0/vbld(j+nres)
1622 c            write (iout,*) "i",i," j", j," itype",itype(i),itype(j)
1623             sig0ij=sigma(itypi,itypj)
1624             chi1=chi(itypi,itypj)
1625             chi2=chi(itypj,itypi)
1626             chi12=chi1*chi2
1627             chip1=chip(itypi)
1628             chip2=chip(itypj)
1629             chip12=chip1*chip2
1630             alf1=alp(itypi)
1631             alf2=alp(itypj)
1632             alf12=0.5D0*(alf1+alf2)
1633 C For diagnostics only!!!
1634 c           chi1=0.0D0
1635 c           chi2=0.0D0
1636 c           chi12=0.0D0
1637 c           chip1=0.0D0
1638 c           chip2=0.0D0
1639 c           chip12=0.0D0
1640 c           alf1=0.0D0
1641 c           alf2=0.0D0
1642 c           alf12=0.0D0
1643             xj=c(1,nres+j)
1644             yj=c(2,nres+j)
1645             zj=c(3,nres+j)
1646 C Return atom J into box the original box
1647 c  137   continue
1648 c        if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
1649 c        if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
1650 C Condition for being inside the proper box
1651 c        if ((xj.gt.((0.5d0)*boxxsize)).or.
1652 c     &       (xj.lt.((-0.5d0)*boxxsize))) then
1653 c        go to 137
1654 c        endif
1655 c  138   continue
1656 c        if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
1657 c        if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
1658 C Condition for being inside the proper box
1659 c        if ((yj.gt.((0.5d0)*boxysize)).or.
1660 c     &       (yj.lt.((-0.5d0)*boxysize))) then
1661 c        go to 138
1662 c        endif
1663 c  139   continue
1664 c        if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
1665 c        if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
1666 C Condition for being inside the proper box
1667 c        if ((zj.gt.((0.5d0)*boxzsize)).or.
1668 c     &       (zj.lt.((-0.5d0)*boxzsize))) then
1669 c        go to 139
1670 c        endif
1671           xj=mod(xj,boxxsize)
1672           if (xj.lt.0) xj=xj+boxxsize
1673           yj=mod(yj,boxysize)
1674           if (yj.lt.0) yj=yj+boxysize
1675           zj=mod(zj,boxzsize)
1676           if (zj.lt.0) zj=zj+boxzsize
1677        if ((zj.gt.bordlipbot)
1678      &.and.(zj.lt.bordliptop)) then
1679 C the energy transfer exist
1680         if (zj.lt.buflipbot) then
1681 C what fraction I am in
1682          fracinbuf=1.0d0-
1683      &        ((zj-bordlipbot)/lipbufthick)
1684 C lipbufthick is thickenes of lipid buffore
1685          sslipj=sscalelip(fracinbuf)
1686          ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
1687         elseif (zj.gt.bufliptop) then
1688          fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
1689          sslipj=sscalelip(fracinbuf)
1690          ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
1691         else
1692          sslipj=1.0d0
1693          ssgradlipj=0.0
1694         endif
1695        else
1696          sslipj=0.0d0
1697          ssgradlipj=0.0
1698        endif
1699       aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
1700      &  +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1701       bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
1702      &  +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1703 C      if (aa.ne.aa_aq(itypi,itypj)) write(63,'(2e10.5)')
1704 C     &(aa-aa_aq(itypi,itypj)),(bb-bb_aq(itypi,itypj))
1705 C      if (ssgradlipj.gt.0.0d0) print *,"??WTF??"
1706 C      print *,sslipi,sslipj,bordlipbot,zi,zj
1707       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
1708       xj_safe=xj
1709       yj_safe=yj
1710       zj_safe=zj
1711       subchap=0
1712       do xshift=-1,1
1713       do yshift=-1,1
1714       do zshift=-1,1
1715           xj=xj_safe+xshift*boxxsize
1716           yj=yj_safe+yshift*boxysize
1717           zj=zj_safe+zshift*boxzsize
1718           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
1719           if(dist_temp.lt.dist_init) then
1720             dist_init=dist_temp
1721             xj_temp=xj
1722             yj_temp=yj
1723             zj_temp=zj
1724             subchap=1
1725           endif
1726        enddo
1727        enddo
1728        enddo
1729        if (subchap.eq.1) then
1730           xj=xj_temp-xi
1731           yj=yj_temp-yi
1732           zj=zj_temp-zi
1733        else
1734           xj=xj_safe-xi
1735           yj=yj_safe-yi
1736           zj=zj_safe-zi
1737        endif
1738             dxj=dc_norm(1,nres+j)
1739             dyj=dc_norm(2,nres+j)
1740             dzj=dc_norm(3,nres+j)
1741 C            xj=xj-xi
1742 C            yj=yj-yi
1743 C            zj=zj-zi
1744 c            write (iout,*) "dcnorj",dxi*dxi+dyi*dyi+dzi*dzi
1745 c            write (iout,*) "j",j," dc_norm",
1746 c     &       dc_norm(1,nres+j),dc_norm(2,nres+j),dc_norm(3,nres+j)
1747             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1748             rij=dsqrt(rrij)
1749             sss=sscale((1.0d0/rij)/sigma(itypi,itypj))
1750             sssgrad=sscagrad((1.0d0/rij)/sigma(itypi,itypj))
1751
1752 c            write (iout,'(a7,4f8.3)')
1753 c    &      "ssscale",sss,((1.0d0/rij)/sigma(itypi,itypj)),r_cut,rlamb
1754             if (sss.gt.0.0d0) then
1755 C Calculate angle-dependent terms of energy and contributions to their
1756 C derivatives.
1757             call sc_angular
1758             sigsq=1.0D0/sigsq
1759             sig=sig0ij*dsqrt(sigsq)
1760             rij_shift=1.0D0/rij-sig+sig0ij
1761 c for diagnostics; uncomment
1762 c            rij_shift=1.2*sig0ij
1763 C I hate to put IF's in the loops, but here don't have another choice!!!!
1764             if (rij_shift.le.0.0D0) then
1765               evdw=1.0D20
1766 cd              write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1767 cd     &        restyp(itypi),i,restyp(itypj),j,
1768 cd     &        rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq)
1769               return
1770             endif
1771             sigder=-sig*sigsq
1772 c---------------------------------------------------------------
1773             rij_shift=1.0D0/rij_shift
1774             fac=rij_shift**expon
1775 C here to start with
1776 C            if (c(i,3).gt.
1777             faclip=fac
1778             e1=fac*fac*aa
1779             e2=fac*bb
1780             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1781             eps2der=evdwij*eps3rt
1782             eps3der=evdwij*eps2rt
1783 C       write(63,'(2i3,2e10.3,2f10.5)') i,j,aa,bb, evdwij,
1784 C     &((sslipi+sslipj)/2.0d0+
1785 C     &(2.0d0-sslipi-sslipj)/2.0d0)
1786 c            write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt,
1787 c     &        " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2
1788             evdwij=evdwij*eps2rt*eps3rt
1789             evdw=evdw+evdwij*sss
1790             if (lprn) then
1791             sigm=dabs(aa/bb)**(1.0D0/6.0D0)
1792             epsi=bb**2/aa
1793             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1794      &        restyp(itypi),i,restyp(itypj),j,
1795      &        epsi,sigm,chi1,chi2,chip1,chip2,
1796      &        eps1,eps2rt**2,eps3rt**2,sig,sig0ij,
1797      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1798      &        evdwij
1799             endif
1800
1801             if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
1802      &                        'evdw',i,j,evdwij
1803
1804 C Calculate gradient components.
1805             e1=e1*eps1*eps2rt**2*eps3rt**2
1806             fac=-expon*(e1+evdwij)*rij_shift
1807             sigder=fac*sigder
1808             fac=rij*fac
1809 c            print '(2i4,6f8.4)',i,j,sss,sssgrad*
1810 c     &      evdwij,fac,sigma(itypi,itypj),expon
1811             fac=fac+evdwij/sss*sssgrad/sigma(itypi,itypj)*rij
1812 c            fac=0.0d0
1813 C Calculate the radial part of the gradient
1814             gg_lipi(3)=eps1*(eps2rt*eps2rt)
1815      &*(eps3rt*eps3rt)*sss/2.0d0*(faclip*faclip*
1816      & (aa_lip(itypi,itypj)-aa_aq(itypi,itypj))
1817      &+faclip*(bb_lip(itypi,itypj)-bb_aq(itypi,itypj)))
1818             gg_lipj(3)=ssgradlipj*gg_lipi(3)
1819             gg_lipi(3)=gg_lipi(3)*ssgradlipi
1820 C            gg_lipi(3)=0.0d0
1821 C            gg_lipj(3)=0.0d0
1822             gg(1)=xj*fac
1823             gg(2)=yj*fac
1824             gg(3)=zj*fac
1825 C Calculate angular part of the gradient.
1826             call sc_grad
1827             endif
1828             ENDIF    ! dyn_ss
1829           enddo      ! j
1830         enddo        ! iint
1831       enddo          ! i
1832 C      enddo          ! zshift
1833 C      enddo          ! yshift
1834 C      enddo          ! xshift
1835 c      write (iout,*) "Number of loop steps in EGB:",ind
1836 cccc      energy_dec=.false.
1837       return
1838       end
1839 C-----------------------------------------------------------------------------
1840       subroutine egbv(evdw)
1841 C
1842 C This subroutine calculates the interaction energy of nonbonded side chains
1843 C assuming the Gay-Berne-Vorobjev potential of interaction.
1844 C
1845       implicit real*8 (a-h,o-z)
1846       include 'DIMENSIONS'
1847       include 'COMMON.GEO'
1848       include 'COMMON.VAR'
1849       include 'COMMON.LOCAL'
1850       include 'COMMON.CHAIN'
1851       include 'COMMON.DERIV'
1852       include 'COMMON.NAMES'
1853       include 'COMMON.INTERACT'
1854       include 'COMMON.IOUNITS'
1855       include 'COMMON.CALC'
1856       common /srutu/ icall
1857       logical lprn
1858       evdw=0.0D0
1859 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1860       evdw=0.0D0
1861       lprn=.false.
1862 c     if (icall.eq.0) lprn=.true.
1863       ind=0
1864       do i=iatsc_s,iatsc_e
1865         itypi=iabs(itype(i))
1866         if (itypi.eq.ntyp1) cycle
1867         itypi1=iabs(itype(i+1))
1868         xi=c(1,nres+i)
1869         yi=c(2,nres+i)
1870         zi=c(3,nres+i)
1871           xi=mod(xi,boxxsize)
1872           if (xi.lt.0) xi=xi+boxxsize
1873           yi=mod(yi,boxysize)
1874           if (yi.lt.0) yi=yi+boxysize
1875           zi=mod(zi,boxzsize)
1876           if (zi.lt.0) zi=zi+boxzsize
1877 C define scaling factor for lipids
1878
1879 C        if (positi.le.0) positi=positi+boxzsize
1880 C        print *,i
1881 C first for peptide groups
1882 c for each residue check if it is in lipid or lipid water border area
1883        if ((zi.gt.bordlipbot)
1884      &.and.(zi.lt.bordliptop)) then
1885 C the energy transfer exist
1886         if (zi.lt.buflipbot) then
1887 C what fraction I am in
1888          fracinbuf=1.0d0-
1889      &        ((zi-bordlipbot)/lipbufthick)
1890 C lipbufthick is thickenes of lipid buffore
1891          sslipi=sscalelip(fracinbuf)
1892          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
1893         elseif (zi.gt.bufliptop) then
1894          fracinbuf=1.0d0-((bordliptop-zi)/lipbufthick)
1895          sslipi=sscalelip(fracinbuf)
1896          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
1897         else
1898          sslipi=1.0d0
1899          ssgradlipi=0.0
1900         endif
1901        else
1902          sslipi=0.0d0
1903          ssgradlipi=0.0
1904        endif
1905
1906         dxi=dc_norm(1,nres+i)
1907         dyi=dc_norm(2,nres+i)
1908         dzi=dc_norm(3,nres+i)
1909 c        dsci_inv=dsc_inv(itypi)
1910         dsci_inv=vbld_inv(i+nres)
1911 C
1912 C Calculate SC interaction energy.
1913 C
1914         do iint=1,nint_gr(i)
1915           do j=istart(i,iint),iend(i,iint)
1916             ind=ind+1
1917             itypj=iabs(itype(j))
1918             if (itypj.eq.ntyp1) cycle
1919 c            dscj_inv=dsc_inv(itypj)
1920             dscj_inv=vbld_inv(j+nres)
1921             sig0ij=sigma(itypi,itypj)
1922             r0ij=r0(itypi,itypj)
1923             chi1=chi(itypi,itypj)
1924             chi2=chi(itypj,itypi)
1925             chi12=chi1*chi2
1926             chip1=chip(itypi)
1927             chip2=chip(itypj)
1928             chip12=chip1*chip2
1929             alf1=alp(itypi)
1930             alf2=alp(itypj)
1931             alf12=0.5D0*(alf1+alf2)
1932 C For diagnostics only!!!
1933 c           chi1=0.0D0
1934 c           chi2=0.0D0
1935 c           chi12=0.0D0
1936 c           chip1=0.0D0
1937 c           chip2=0.0D0
1938 c           chip12=0.0D0
1939 c           alf1=0.0D0
1940 c           alf2=0.0D0
1941 c           alf12=0.0D0
1942 C            xj=c(1,nres+j)-xi
1943 C            yj=c(2,nres+j)-yi
1944 C            zj=c(3,nres+j)-zi
1945           xj=mod(xj,boxxsize)
1946           if (xj.lt.0) xj=xj+boxxsize
1947           yj=mod(yj,boxysize)
1948           if (yj.lt.0) yj=yj+boxysize
1949           zj=mod(zj,boxzsize)
1950           if (zj.lt.0) zj=zj+boxzsize
1951        if ((zj.gt.bordlipbot)
1952      &.and.(zj.lt.bordliptop)) then
1953 C the energy transfer exist
1954         if (zj.lt.buflipbot) then
1955 C what fraction I am in
1956          fracinbuf=1.0d0-
1957      &        ((zj-bordlipbot)/lipbufthick)
1958 C lipbufthick is thickenes of lipid buffore
1959          sslipj=sscalelip(fracinbuf)
1960          ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
1961         elseif (zj.gt.bufliptop) then
1962          fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
1963          sslipj=sscalelip(fracinbuf)
1964          ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
1965         else
1966          sslipj=1.0d0
1967          ssgradlipj=0.0
1968         endif
1969        else
1970          sslipj=0.0d0
1971          ssgradlipj=0.0
1972        endif
1973       aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
1974      &  +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1975       bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
1976      &  +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1977 C      if (aa.ne.aa_aq(itypi,itypj)) write(63,'2e10.5')
1978 C     &(aa-aa_aq(itypi,itypj)),(bb-bb_aq(itypi,itypj))
1979       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
1980       xj_safe=xj
1981       yj_safe=yj
1982       zj_safe=zj
1983       subchap=0
1984       do xshift=-1,1
1985       do yshift=-1,1
1986       do zshift=-1,1
1987           xj=xj_safe+xshift*boxxsize
1988           yj=yj_safe+yshift*boxysize
1989           zj=zj_safe+zshift*boxzsize
1990           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
1991           if(dist_temp.lt.dist_init) then
1992             dist_init=dist_temp
1993             xj_temp=xj
1994             yj_temp=yj
1995             zj_temp=zj
1996             subchap=1
1997           endif
1998        enddo
1999        enddo
2000        enddo
2001        if (subchap.eq.1) then
2002           xj=xj_temp-xi
2003           yj=yj_temp-yi
2004           zj=zj_temp-zi
2005        else
2006           xj=xj_safe-xi
2007           yj=yj_safe-yi
2008           zj=zj_safe-zi
2009        endif
2010             dxj=dc_norm(1,nres+j)
2011             dyj=dc_norm(2,nres+j)
2012             dzj=dc_norm(3,nres+j)
2013             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
2014             rij=dsqrt(rrij)
2015 C Calculate angle-dependent terms of energy and contributions to their
2016 C derivatives.
2017             call sc_angular
2018             sigsq=1.0D0/sigsq
2019             sig=sig0ij*dsqrt(sigsq)
2020             rij_shift=1.0D0/rij-sig+r0ij
2021 C I hate to put IF's in the loops, but here don't have another choice!!!!
2022             if (rij_shift.le.0.0D0) then
2023               evdw=1.0D20
2024               return
2025             endif
2026             sigder=-sig*sigsq
2027 c---------------------------------------------------------------
2028             rij_shift=1.0D0/rij_shift
2029             fac=rij_shift**expon
2030             e1=fac*fac*aa
2031             e2=fac*bb
2032             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
2033             eps2der=evdwij*eps3rt
2034             eps3der=evdwij*eps2rt
2035             fac_augm=rrij**expon
2036             e_augm=augm(itypi,itypj)*fac_augm
2037             evdwij=evdwij*eps2rt*eps3rt
2038             evdw=evdw+evdwij+e_augm
2039             if (lprn) then
2040             sigm=dabs(aa/bb)**(1.0D0/6.0D0)
2041             epsi=bb**2/aa
2042             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
2043      &        restyp(itypi),i,restyp(itypj),j,
2044      &        epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),
2045      &        chi1,chi2,chip1,chip2,
2046      &        eps1,eps2rt**2,eps3rt**2,
2047      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
2048      &        evdwij+e_augm
2049             endif
2050 C Calculate gradient components.
2051             e1=e1*eps1*eps2rt**2*eps3rt**2
2052             fac=-expon*(e1+evdwij)*rij_shift
2053             sigder=fac*sigder
2054             fac=rij*fac-2*expon*rrij*e_augm
2055             fac=fac+evdwij/sss*sssgrad/sigma(itypi,itypj)*rij
2056 C Calculate the radial part of the gradient
2057             gg(1)=xj*fac
2058             gg(2)=yj*fac
2059             gg(3)=zj*fac
2060 C Calculate angular part of the gradient.
2061             call sc_grad
2062           enddo      ! j
2063         enddo        ! iint
2064       enddo          ! i
2065       end
2066 C-----------------------------------------------------------------------------
2067       subroutine sc_angular
2068 C Calculate eps1,eps2,eps3,sigma, and parts of their derivatives in om1,om2,
2069 C om12. Called by ebp, egb, and egbv.
2070       implicit none
2071       include 'COMMON.CALC'
2072       include 'COMMON.IOUNITS'
2073       erij(1)=xj*rij
2074       erij(2)=yj*rij
2075       erij(3)=zj*rij
2076       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
2077       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
2078       om12=dxi*dxj+dyi*dyj+dzi*dzj
2079       chiom12=chi12*om12
2080 C Calculate eps1(om12) and its derivative in om12
2081       faceps1=1.0D0-om12*chiom12
2082       faceps1_inv=1.0D0/faceps1
2083       eps1=dsqrt(faceps1_inv)
2084 C Following variable is eps1*deps1/dom12
2085       eps1_om12=faceps1_inv*chiom12
2086 c diagnostics only
2087 c      faceps1_inv=om12
2088 c      eps1=om12
2089 c      eps1_om12=1.0d0
2090 c      write (iout,*) "om12",om12," eps1",eps1
2091 C Calculate sigma(om1,om2,om12) and the derivatives of sigma**2 in om1,om2,
2092 C and om12.
2093       om1om2=om1*om2
2094       chiom1=chi1*om1
2095       chiom2=chi2*om2
2096       facsig=om1*chiom1+om2*chiom2-2.0D0*om1om2*chiom12
2097       sigsq=1.0D0-facsig*faceps1_inv
2098       sigsq_om1=(chiom1-chiom12*om2)*faceps1_inv
2099       sigsq_om2=(chiom2-chiom12*om1)*faceps1_inv
2100       sigsq_om12=-chi12*(om1om2*faceps1-om12*facsig)*faceps1_inv**2
2101 c diagnostics only
2102 c      sigsq=1.0d0
2103 c      sigsq_om1=0.0d0
2104 c      sigsq_om2=0.0d0
2105 c      sigsq_om12=0.0d0
2106 c      write (iout,*) "chiom1",chiom1," chiom2",chiom2," chiom12",chiom12
2107 c      write (iout,*) "faceps1",faceps1," faceps1_inv",faceps1_inv,
2108 c     &    " eps1",eps1
2109 C Calculate eps2 and its derivatives in om1, om2, and om12.
2110       chipom1=chip1*om1
2111       chipom2=chip2*om2
2112       chipom12=chip12*om12
2113       facp=1.0D0-om12*chipom12
2114       facp_inv=1.0D0/facp
2115       facp1=om1*chipom1+om2*chipom2-2.0D0*om1om2*chipom12
2116 c      write (iout,*) "chipom1",chipom1," chipom2",chipom2,
2117 c     &  " chipom12",chipom12," facp",facp," facp_inv",facp_inv
2118 C Following variable is the square root of eps2
2119       eps2rt=1.0D0-facp1*facp_inv
2120 C Following three variables are the derivatives of the square root of eps
2121 C in om1, om2, and om12.
2122       eps2rt_om1=-4.0D0*(chipom1-chipom12*om2)*facp_inv
2123       eps2rt_om2=-4.0D0*(chipom2-chipom12*om1)*facp_inv
2124       eps2rt_om12=4.0D0*chip12*(om1om2*facp-om12*facp1)*facp_inv**2
2125 C Evaluate the "asymmetric" factor in the VDW constant, eps3
2126       eps3rt=1.0D0-alf1*om1+alf2*om2-alf12*om12
2127 c      write (iout,*) "eps2rt",eps2rt," eps3rt",eps3rt
2128 c      write (iout,*) "eps2rt_om1",eps2rt_om1," eps2rt_om2",eps2rt_om2,
2129 c     &  " eps2rt_om12",eps2rt_om12
2130 C Calculate whole angle-dependent part of epsilon and contributions
2131 C to its derivatives
2132       return
2133       end
2134 C----------------------------------------------------------------------------
2135       subroutine sc_grad
2136       implicit real*8 (a-h,o-z)
2137       include 'DIMENSIONS'
2138       include 'COMMON.CHAIN'
2139       include 'COMMON.DERIV'
2140       include 'COMMON.CALC'
2141       include 'COMMON.IOUNITS'
2142       double precision dcosom1(3),dcosom2(3)
2143 cc      print *,'sss=',sss
2144       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
2145       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
2146       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12
2147      &     -2.0D0*alf12*eps3der+sigder*sigsq_om12
2148 c diagnostics only
2149 c      eom1=0.0d0
2150 c      eom2=0.0d0
2151 c      eom12=evdwij*eps1_om12
2152 c end diagnostics
2153 c      write (iout,*) "eps2der",eps2der," eps3der",eps3der,
2154 c     &  " sigder",sigder
2155 c      write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12
2156 c      write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12
2157       do k=1,3
2158         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
2159         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
2160       enddo
2161       do k=1,3
2162         gg(k)=(gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k))*sss
2163       enddo
2164 c      write (iout,*) "gg",(gg(k),k=1,3)
2165       do k=1,3
2166         gvdwx(k,i)=gvdwx(k,i)-gg(k)+gg_lipi(k)
2167      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
2168      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv*sss
2169         gvdwx(k,j)=gvdwx(k,j)+gg(k)+gg_lipj(k)
2170      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
2171      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv*sss
2172 c        write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
2173 c     &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
2174 c        write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
2175 c     &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
2176       enddo
2177 C
2178 C Calculate the components of the gradient in DC and X
2179 C
2180 cgrad      do k=i,j-1
2181 cgrad        do l=1,3
2182 cgrad          gvdwc(l,k)=gvdwc(l,k)+gg(l)
2183 cgrad        enddo
2184 cgrad      enddo
2185       do l=1,3
2186         gvdwc(l,i)=gvdwc(l,i)-gg(l)+gg_lipi(l)
2187         gvdwc(l,j)=gvdwc(l,j)+gg(l)+gg_lipj(l)
2188       enddo
2189       return
2190       end
2191 C-----------------------------------------------------------------------
2192       subroutine e_softsphere(evdw)
2193 C
2194 C This subroutine calculates the interaction energy of nonbonded side chains
2195 C assuming the LJ potential of interaction.
2196 C
2197       implicit real*8 (a-h,o-z)
2198       include 'DIMENSIONS'
2199       parameter (accur=1.0d-10)
2200       include 'COMMON.GEO'
2201       include 'COMMON.VAR'
2202       include 'COMMON.LOCAL'
2203       include 'COMMON.CHAIN'
2204       include 'COMMON.DERIV'
2205       include 'COMMON.INTERACT'
2206       include 'COMMON.TORSION'
2207       include 'COMMON.SBRIDGE'
2208       include 'COMMON.NAMES'
2209       include 'COMMON.IOUNITS'
2210       include 'COMMON.CONTACTS'
2211       dimension gg(3)
2212 cd    print *,'Entering Esoft_sphere nnt=',nnt,' nct=',nct
2213       evdw=0.0D0
2214       do i=iatsc_s,iatsc_e
2215         itypi=iabs(itype(i))
2216         if (itypi.eq.ntyp1) cycle
2217         itypi1=iabs(itype(i+1))
2218         xi=c(1,nres+i)
2219         yi=c(2,nres+i)
2220         zi=c(3,nres+i)
2221 C
2222 C Calculate SC interaction energy.
2223 C
2224         do iint=1,nint_gr(i)
2225 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
2226 cd   &                  'iend=',iend(i,iint)
2227           do j=istart(i,iint),iend(i,iint)
2228             itypj=iabs(itype(j))
2229             if (itypj.eq.ntyp1) cycle
2230             xj=c(1,nres+j)-xi
2231             yj=c(2,nres+j)-yi
2232             zj=c(3,nres+j)-zi
2233             rij=xj*xj+yj*yj+zj*zj
2234 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
2235             r0ij=r0(itypi,itypj)
2236             r0ijsq=r0ij*r0ij
2237 c            print *,i,j,r0ij,dsqrt(rij)
2238             if (rij.lt.r0ijsq) then
2239               evdwij=0.25d0*(rij-r0ijsq)**2
2240               fac=rij-r0ijsq
2241             else
2242               evdwij=0.0d0
2243               fac=0.0d0
2244             endif
2245             evdw=evdw+evdwij
2246 C
2247 C Calculate the components of the gradient in DC and X
2248 C
2249             gg(1)=xj*fac
2250             gg(2)=yj*fac
2251             gg(3)=zj*fac
2252             do k=1,3
2253               gvdwx(k,i)=gvdwx(k,i)-gg(k)
2254               gvdwx(k,j)=gvdwx(k,j)+gg(k)
2255               gvdwc(k,i)=gvdwc(k,i)-gg(k)
2256               gvdwc(k,j)=gvdwc(k,j)+gg(k)
2257             enddo
2258 cgrad            do k=i,j-1
2259 cgrad              do l=1,3
2260 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
2261 cgrad              enddo
2262 cgrad            enddo
2263           enddo ! j
2264         enddo ! iint
2265       enddo ! i
2266       return
2267       end
2268 C--------------------------------------------------------------------------
2269       subroutine eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,
2270      &              eello_turn4)
2271 C
2272 C Soft-sphere potential of p-p interaction
2273 C
2274       implicit real*8 (a-h,o-z)
2275       include 'DIMENSIONS'
2276       include 'COMMON.CONTROL'
2277       include 'COMMON.IOUNITS'
2278       include 'COMMON.GEO'
2279       include 'COMMON.VAR'
2280       include 'COMMON.LOCAL'
2281       include 'COMMON.CHAIN'
2282       include 'COMMON.DERIV'
2283       include 'COMMON.INTERACT'
2284       include 'COMMON.CONTACTS'
2285       include 'COMMON.TORSION'
2286       include 'COMMON.VECTORS'
2287       include 'COMMON.FFIELD'
2288       dimension ggg(3)
2289 C      write(iout,*) 'In EELEC_soft_sphere'
2290       ees=0.0D0
2291       evdw1=0.0D0
2292       eel_loc=0.0d0
2293       eello_turn3=0.0d0
2294       eello_turn4=0.0d0
2295       ind=0
2296       do i=iatel_s,iatel_e
2297         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
2298         dxi=dc(1,i)
2299         dyi=dc(2,i)
2300         dzi=dc(3,i)
2301         xmedi=c(1,i)+0.5d0*dxi
2302         ymedi=c(2,i)+0.5d0*dyi
2303         zmedi=c(3,i)+0.5d0*dzi
2304           xmedi=mod(xmedi,boxxsize)
2305           if (xmedi.lt.0) xmedi=xmedi+boxxsize
2306           ymedi=mod(ymedi,boxysize)
2307           if (ymedi.lt.0) ymedi=ymedi+boxysize
2308           zmedi=mod(zmedi,boxzsize)
2309           if (zmedi.lt.0) zmedi=zmedi+boxzsize
2310         num_conti=0
2311 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
2312         do j=ielstart(i),ielend(i)
2313           if (itype(j).eq.ntyp1 .or. itype(j+1).eq.ntyp1) cycle
2314           ind=ind+1
2315           iteli=itel(i)
2316           itelj=itel(j)
2317           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
2318           r0ij=rpp(iteli,itelj)
2319           r0ijsq=r0ij*r0ij
2320           dxj=dc(1,j)
2321           dyj=dc(2,j)
2322           dzj=dc(3,j)
2323           xj=c(1,j)+0.5D0*dxj
2324           yj=c(2,j)+0.5D0*dyj
2325           zj=c(3,j)+0.5D0*dzj
2326           xj=mod(xj,boxxsize)
2327           if (xj.lt.0) xj=xj+boxxsize
2328           yj=mod(yj,boxysize)
2329           if (yj.lt.0) yj=yj+boxysize
2330           zj=mod(zj,boxzsize)
2331           if (zj.lt.0) zj=zj+boxzsize
2332       dist_init=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
2333       xj_safe=xj
2334       yj_safe=yj
2335       zj_safe=zj
2336       isubchap=0
2337       do xshift=-1,1
2338       do yshift=-1,1
2339       do zshift=-1,1
2340           xj=xj_safe+xshift*boxxsize
2341           yj=yj_safe+yshift*boxysize
2342           zj=zj_safe+zshift*boxzsize
2343           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
2344           if(dist_temp.lt.dist_init) then
2345             dist_init=dist_temp
2346             xj_temp=xj
2347             yj_temp=yj
2348             zj_temp=zj
2349             isubchap=1
2350           endif
2351        enddo
2352        enddo
2353        enddo
2354        if (isubchap.eq.1) then
2355           xj=xj_temp-xmedi
2356           yj=yj_temp-ymedi
2357           zj=zj_temp-zmedi
2358        else
2359           xj=xj_safe-xmedi
2360           yj=yj_safe-ymedi
2361           zj=zj_safe-zmedi
2362        endif
2363           rij=xj*xj+yj*yj+zj*zj
2364             sss=sscale(sqrt(rij))
2365             sssgrad=sscagrad(sqrt(rij))
2366           if (rij.lt.r0ijsq) then
2367             evdw1ij=0.25d0*(rij-r0ijsq)**2
2368             fac=rij-r0ijsq
2369           else
2370             evdw1ij=0.0d0
2371             fac=0.0d0
2372           endif
2373           evdw1=evdw1+evdw1ij*sss
2374 C
2375 C Calculate contributions to the Cartesian gradient.
2376 C
2377           ggg(1)=fac*xj*sssgrad
2378           ggg(2)=fac*yj*sssgrad
2379           ggg(3)=fac*zj*sssgrad
2380           do k=1,3
2381             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
2382             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
2383           enddo
2384 *
2385 * Loop over residues i+1 thru j-1.
2386 *
2387 cgrad          do k=i+1,j-1
2388 cgrad            do l=1,3
2389 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
2390 cgrad            enddo
2391 cgrad          enddo
2392         enddo ! j
2393       enddo   ! i
2394 cgrad      do i=nnt,nct-1
2395 cgrad        do k=1,3
2396 cgrad          gelc(k,i)=gelc(k,i)+0.5d0*gelc(k,i)
2397 cgrad        enddo
2398 cgrad        do j=i+1,nct-1
2399 cgrad          do k=1,3
2400 cgrad            gelc(k,i)=gelc(k,i)+gelc(k,j)
2401 cgrad          enddo
2402 cgrad        enddo
2403 cgrad      enddo
2404       return
2405       end
2406 c------------------------------------------------------------------------------
2407       subroutine vec_and_deriv
2408       implicit real*8 (a-h,o-z)
2409       include 'DIMENSIONS'
2410 #ifdef MPI
2411       include 'mpif.h'
2412 #endif
2413       include 'COMMON.IOUNITS'
2414       include 'COMMON.GEO'
2415       include 'COMMON.VAR'
2416       include 'COMMON.LOCAL'
2417       include 'COMMON.CHAIN'
2418       include 'COMMON.VECTORS'
2419       include 'COMMON.SETUP'
2420       include 'COMMON.TIME1'
2421       dimension uyder(3,3,2),uzder(3,3,2),vbld_inv_temp(2)
2422 C Compute the local reference systems. For reference system (i), the
2423 C X-axis points from CA(i) to CA(i+1), the Y axis is in the
2424 C CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
2425 #ifdef PARVEC
2426       do i=ivec_start,ivec_end
2427 #else
2428       do i=1,nres-1
2429 #endif
2430           if (i.eq.nres-1) then
2431 C Case of the last full residue
2432 C Compute the Z-axis
2433             call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
2434             costh=dcos(pi-theta(nres))
2435             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2436             do k=1,3
2437               uz(k,i)=fac*uz(k,i)
2438             enddo
2439 C Compute the derivatives of uz
2440             uzder(1,1,1)= 0.0d0
2441             uzder(2,1,1)=-dc_norm(3,i-1)
2442             uzder(3,1,1)= dc_norm(2,i-1)
2443             uzder(1,2,1)= dc_norm(3,i-1)
2444             uzder(2,2,1)= 0.0d0
2445             uzder(3,2,1)=-dc_norm(1,i-1)
2446             uzder(1,3,1)=-dc_norm(2,i-1)
2447             uzder(2,3,1)= dc_norm(1,i-1)
2448             uzder(3,3,1)= 0.0d0
2449             uzder(1,1,2)= 0.0d0
2450             uzder(2,1,2)= dc_norm(3,i)
2451             uzder(3,1,2)=-dc_norm(2,i)
2452             uzder(1,2,2)=-dc_norm(3,i)
2453             uzder(2,2,2)= 0.0d0
2454             uzder(3,2,2)= dc_norm(1,i)
2455             uzder(1,3,2)= dc_norm(2,i)
2456             uzder(2,3,2)=-dc_norm(1,i)
2457             uzder(3,3,2)= 0.0d0
2458 C Compute the Y-axis
2459             facy=fac
2460             do k=1,3
2461               uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
2462             enddo
2463 C Compute the derivatives of uy
2464             do j=1,3
2465               do k=1,3
2466                 uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i)
2467      &                        -dc_norm(k,i)*dc_norm(j,i-1)
2468                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2469               enddo
2470               uyder(j,j,1)=uyder(j,j,1)-costh
2471               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2472             enddo
2473             do j=1,2
2474               do k=1,3
2475                 do l=1,3
2476                   uygrad(l,k,j,i)=uyder(l,k,j)
2477                   uzgrad(l,k,j,i)=uzder(l,k,j)
2478                 enddo
2479               enddo
2480             enddo
2481             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2482             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2483             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2484             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2485           else
2486 C Other residues
2487 C Compute the Z-axis
2488             call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
2489             costh=dcos(pi-theta(i+2))
2490             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2491             do k=1,3
2492               uz(k,i)=fac*uz(k,i)
2493             enddo
2494 C Compute the derivatives of uz
2495             uzder(1,1,1)= 0.0d0
2496             uzder(2,1,1)=-dc_norm(3,i+1)
2497             uzder(3,1,1)= dc_norm(2,i+1)
2498             uzder(1,2,1)= dc_norm(3,i+1)
2499             uzder(2,2,1)= 0.0d0
2500             uzder(3,2,1)=-dc_norm(1,i+1)
2501             uzder(1,3,1)=-dc_norm(2,i+1)
2502             uzder(2,3,1)= dc_norm(1,i+1)
2503             uzder(3,3,1)= 0.0d0
2504             uzder(1,1,2)= 0.0d0
2505             uzder(2,1,2)= dc_norm(3,i)
2506             uzder(3,1,2)=-dc_norm(2,i)
2507             uzder(1,2,2)=-dc_norm(3,i)
2508             uzder(2,2,2)= 0.0d0
2509             uzder(3,2,2)= dc_norm(1,i)
2510             uzder(1,3,2)= dc_norm(2,i)
2511             uzder(2,3,2)=-dc_norm(1,i)
2512             uzder(3,3,2)= 0.0d0
2513 C Compute the Y-axis
2514             facy=fac
2515             do k=1,3
2516               uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
2517             enddo
2518 C Compute the derivatives of uy
2519             do j=1,3
2520               do k=1,3
2521                 uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i)
2522      &                        -dc_norm(k,i)*dc_norm(j,i+1)
2523                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2524               enddo
2525               uyder(j,j,1)=uyder(j,j,1)-costh
2526               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2527             enddo
2528             do j=1,2
2529               do k=1,3
2530                 do l=1,3
2531                   uygrad(l,k,j,i)=uyder(l,k,j)
2532                   uzgrad(l,k,j,i)=uzder(l,k,j)
2533                 enddo
2534               enddo
2535             enddo
2536             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2537             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2538             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2539             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2540           endif
2541       enddo
2542       do i=1,nres-1
2543         vbld_inv_temp(1)=vbld_inv(i+1)
2544         if (i.lt.nres-1) then
2545           vbld_inv_temp(2)=vbld_inv(i+2)
2546           else
2547           vbld_inv_temp(2)=vbld_inv(i)
2548           endif
2549         do j=1,2
2550           do k=1,3
2551             do l=1,3
2552               uygrad(l,k,j,i)=vbld_inv_temp(j)*uygrad(l,k,j,i)
2553               uzgrad(l,k,j,i)=vbld_inv_temp(j)*uzgrad(l,k,j,i)
2554             enddo
2555           enddo
2556         enddo
2557       enddo
2558 #if defined(PARVEC) && defined(MPI)
2559       if (nfgtasks1.gt.1) then
2560         time00=MPI_Wtime()
2561 c        print *,"Processor",fg_rank1,kolor1," ivec_start",ivec_start,
2562 c     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks1-1),
2563 c     &   " ivec_count",(ivec_count(i),i=0,nfgtasks1-1)
2564         call MPI_Allgatherv(uy(1,ivec_start),ivec_count(fg_rank1),
2565      &   MPI_UYZ,uy(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
2566      &   FG_COMM1,IERR)
2567         call MPI_Allgatherv(uz(1,ivec_start),ivec_count(fg_rank1),
2568      &   MPI_UYZ,uz(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
2569      &   FG_COMM1,IERR)
2570         call MPI_Allgatherv(uygrad(1,1,1,ivec_start),
2571      &   ivec_count(fg_rank1),MPI_UYZGRAD,uygrad(1,1,1,1),ivec_count(0),
2572      &   ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2573         call MPI_Allgatherv(uzgrad(1,1,1,ivec_start),
2574      &   ivec_count(fg_rank1),MPI_UYZGRAD,uzgrad(1,1,1,1),ivec_count(0),
2575      &   ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2576         time_gather=time_gather+MPI_Wtime()-time00
2577       endif
2578 c      if (fg_rank.eq.0) then
2579 c        write (iout,*) "Arrays UY and UZ"
2580 c        do i=1,nres-1
2581 c          write (iout,'(i5,3f10.5,5x,3f10.5)') i,(uy(k,i),k=1,3),
2582 c     &     (uz(k,i),k=1,3)
2583 c        enddo
2584 c      endif
2585 #endif
2586       return
2587       end
2588 C-----------------------------------------------------------------------------
2589       subroutine check_vecgrad
2590       implicit real*8 (a-h,o-z)
2591       include 'DIMENSIONS'
2592       include 'COMMON.IOUNITS'
2593       include 'COMMON.GEO'
2594       include 'COMMON.VAR'
2595       include 'COMMON.LOCAL'
2596       include 'COMMON.CHAIN'
2597       include 'COMMON.VECTORS'
2598       dimension uygradt(3,3,2,maxres),uzgradt(3,3,2,maxres)
2599       dimension uyt(3,maxres),uzt(3,maxres)
2600       dimension uygradn(3,3,2),uzgradn(3,3,2),erij(3)
2601       double precision delta /1.0d-7/
2602       call vec_and_deriv
2603 cd      do i=1,nres
2604 crc          write(iout,'(2i5,2(3f10.5,5x))') i,1,dc_norm(:,i)
2605 crc          write(iout,'(2i5,2(3f10.5,5x))') i,2,uy(:,i)
2606 crc          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,uz(:,i)
2607 cd          write(iout,'(2i5,2(3f10.5,5x))') i,1,
2608 cd     &     (dc_norm(if90,i),if90=1,3)
2609 cd          write(iout,'(2i5,2(3f10.5,5x))') i,2,(uy(if90,i),if90=1,3)
2610 cd          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,(uz(if90,i),if90=1,3)
2611 cd          write(iout,'(a)')
2612 cd      enddo
2613       do i=1,nres
2614         do j=1,2
2615           do k=1,3
2616             do l=1,3
2617               uygradt(l,k,j,i)=uygrad(l,k,j,i)
2618               uzgradt(l,k,j,i)=uzgrad(l,k,j,i)
2619             enddo
2620           enddo
2621         enddo
2622       enddo
2623       call vec_and_deriv
2624       do i=1,nres
2625         do j=1,3
2626           uyt(j,i)=uy(j,i)
2627           uzt(j,i)=uz(j,i)
2628         enddo
2629       enddo
2630       do i=1,nres
2631 cd        write (iout,*) 'i=',i
2632         do k=1,3
2633           erij(k)=dc_norm(k,i)
2634         enddo
2635         do j=1,3
2636           do k=1,3
2637             dc_norm(k,i)=erij(k)
2638           enddo
2639           dc_norm(j,i)=dc_norm(j,i)+delta
2640 c          fac=dsqrt(scalar(dc_norm(1,i),dc_norm(1,i)))
2641 c          do k=1,3
2642 c            dc_norm(k,i)=dc_norm(k,i)/fac
2643 c          enddo
2644 c          write (iout,*) (dc_norm(k,i),k=1,3)
2645 c          write (iout,*) (erij(k),k=1,3)
2646           call vec_and_deriv
2647           do k=1,3
2648             uygradn(k,j,1)=(uy(k,i)-uyt(k,i))/delta
2649             uygradn(k,j,2)=(uy(k,i-1)-uyt(k,i-1))/delta
2650             uzgradn(k,j,1)=(uz(k,i)-uzt(k,i))/delta
2651             uzgradn(k,j,2)=(uz(k,i-1)-uzt(k,i-1))/delta
2652           enddo
2653 c          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2654 c     &      j,(uzgradt(k,j,1,i),k=1,3),(uzgradn(k,j,1),k=1,3),
2655 c     &      (uzgradt(k,j,2,i-1),k=1,3),(uzgradn(k,j,2),k=1,3)
2656         enddo
2657         do k=1,3
2658           dc_norm(k,i)=erij(k)
2659         enddo
2660 cd        do k=1,3
2661 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2662 cd     &      k,(uygradt(k,l,1,i),l=1,3),(uygradn(k,l,1),l=1,3),
2663 cd     &      (uygradt(k,l,2,i-1),l=1,3),(uygradn(k,l,2),l=1,3)
2664 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2665 cd     &      k,(uzgradt(k,l,1,i),l=1,3),(uzgradn(k,l,1),l=1,3),
2666 cd     &      (uzgradt(k,l,2,i-1),l=1,3),(uzgradn(k,l,2),l=1,3)
2667 cd          write (iout,'(a)')
2668 cd        enddo
2669       enddo
2670       return
2671       end
2672 C--------------------------------------------------------------------------
2673       subroutine set_matrices
2674       implicit real*8 (a-h,o-z)
2675       include 'DIMENSIONS'
2676 #ifdef MPI
2677       include "mpif.h"
2678       include "COMMON.SETUP"
2679       integer IERR
2680       integer status(MPI_STATUS_SIZE)
2681 #endif
2682       include 'COMMON.IOUNITS'
2683       include 'COMMON.GEO'
2684       include 'COMMON.VAR'
2685       include 'COMMON.LOCAL'
2686       include 'COMMON.CHAIN'
2687       include 'COMMON.DERIV'
2688       include 'COMMON.INTERACT'
2689       include 'COMMON.CONTACTS'
2690       include 'COMMON.TORSION'
2691       include 'COMMON.VECTORS'
2692       include 'COMMON.FFIELD'
2693       double precision auxvec(2),auxmat(2,2)
2694 C
2695 C Compute the virtual-bond-torsional-angle dependent quantities needed
2696 C to calculate the el-loc multibody terms of various order.
2697 C
2698 c      write(iout,*) 'nphi=',nphi,nres
2699 #ifdef PARMAT
2700       do i=ivec_start+2,ivec_end+2
2701 #else
2702       do i=3,nres+1
2703 #endif
2704 #ifdef NEWCORR
2705         if (i.gt. nnt+2 .and. i.lt.nct+2) then
2706           iti = itortyp(itype(i-2))
2707         else
2708           iti=ntortyp+1
2709         endif
2710 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2711         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2712           iti1 = itortyp(itype(i-1))
2713         else
2714           iti1=ntortyp+1
2715         endif
2716 c        write(iout,*),i
2717         b1(1,i-2)=bnew1(1,1,iti)*dsin(theta(i-1)/2.0)
2718      &           +bnew1(2,1,iti)*dsin(theta(i-1))
2719      &           +bnew1(3,1,iti)*dcos(theta(i-1)/2.0)
2720         gtb1(1,i-2)=bnew1(1,1,iti)*dcos(theta(i-1)/2.0d0)/2.0d0
2721      &             +bnew1(2,1,iti)*dcos(theta(i-1))
2722      &             -bnew1(3,1,iti)*dsin(theta(i-1)/2.0d0)/2.0d0
2723 c     &           +bnew1(3,1,iti)*sin(alpha(i))*cos(beta(i))
2724 c     &*(cos(theta(i)/2.0)
2725         b2(1,i-2)=bnew2(1,1,iti)*dsin(theta(i-1)/2.0)
2726      &           +bnew2(2,1,iti)*dsin(theta(i-1))
2727      &           +bnew2(3,1,iti)*dcos(theta(i-1)/2.0)
2728 c     &           +bnew2(3,1,iti)*sin(alpha(i))*cos(beta(i))
2729 c     &*(cos(theta(i)/2.0)
2730         gtb2(1,i-2)=bnew2(1,1,iti)*dcos(theta(i-1)/2.0d0)/2.0d0
2731      &             +bnew2(2,1,iti)*dcos(theta(i-1))
2732      &             -bnew2(3,1,iti)*dsin(theta(i-1)/2.0d0)/2.0d0
2733 c        if (ggb1(1,i).eq.0.0d0) then
2734 c        write(iout,*) 'i=',i,ggb1(1,i),
2735 c     &bnew1(1,1,iti)*cos(theta(i)/2.0)/2.0,
2736 c     &bnew1(2,1,iti)*cos(theta(i)),
2737 c     &bnew1(3,1,iti)*sin(theta(i)/2.0)/2.0
2738 c        endif
2739         b1(2,i-2)=bnew1(1,2,iti)
2740         gtb1(2,i-2)=0.0
2741         b2(2,i-2)=bnew2(1,2,iti)
2742         gtb2(2,i-2)=0.0
2743         EE(1,1,i-2)=eenew(1,iti)*dcos(theta(i-1))
2744         EE(1,2,i-2)=eeold(1,2,iti)
2745         EE(2,1,i-2)=eeold(2,1,iti)
2746         EE(2,2,i-2)=eeold(2,2,iti)
2747         gtEE(1,1,i-2)=-eenew(1,iti)*dsin(theta(i-1))
2748         gtEE(1,2,i-2)=0.0d0
2749         gtEE(2,2,i-2)=0.0d0
2750         gtEE(2,1,i-2)=0.0d0
2751 c        EE(2,2,iti)=0.0d0
2752 c        EE(1,2,iti)=0.5d0*eenew(1,iti)
2753 c        EE(2,1,iti)=0.5d0*eenew(1,iti)
2754 c        b1(2,iti)=bnew1(1,2,iti)*sin(alpha(i))*sin(beta(i))
2755 c        b2(2,iti)=bnew2(1,2,iti)*sin(alpha(i))*sin(beta(i))
2756        b1tilde(1,i-2)=b1(1,i-2)
2757        b1tilde(2,i-2)=-b1(2,i-2)
2758        b2tilde(1,i-2)=b2(1,i-2)
2759        b2tilde(2,i-2)=-b2(2,i-2)
2760 c       write (iout,*) 'i=',i-2,gtb1(2,i-2),gtb1(1,i-2)
2761 c       write(iout,*)  'b1=',b1(1,i-2)
2762 c       write (iout,*) 'theta=', theta(i-1)
2763        enddo
2764 #else
2765         b1(1,i-2)=b(3,iti)
2766         b1(2,i-2)=b(5,iti)
2767         b2(1,i-2)=b(2,iti)
2768         b2(2,i-2)=b(4,iti)
2769        b1tilde(1,i-2)=b1(1,i-2)
2770        b1tilde(2,i-2)=-b1(2,i-2)
2771        b2tilde(1,i-2)=b2(1,i-2)
2772        b2tilde(2,i-2)=-b2(2,i-2)
2773         EE(1,2,i-2)=eeold(1,2,iti)
2774         EE(2,1,i-2)=eeold(2,1,iti)
2775         EE(2,2,i-2)=eeold(2,2,iti)
2776         EE(1,1,i-2)=eeold(1,1,iti)
2777       enddo
2778 #endif
2779 #ifdef PARMAT
2780       do i=ivec_start+2,ivec_end+2
2781 #else
2782       do i=3,nres+1
2783 #endif
2784         if (i .lt. nres+1) then
2785           sin1=dsin(phi(i))
2786           cos1=dcos(phi(i))
2787           sintab(i-2)=sin1
2788           costab(i-2)=cos1
2789           obrot(1,i-2)=cos1
2790           obrot(2,i-2)=sin1
2791           sin2=dsin(2*phi(i))
2792           cos2=dcos(2*phi(i))
2793           sintab2(i-2)=sin2
2794           costab2(i-2)=cos2
2795           obrot2(1,i-2)=cos2
2796           obrot2(2,i-2)=sin2
2797           Ug(1,1,i-2)=-cos1
2798           Ug(1,2,i-2)=-sin1
2799           Ug(2,1,i-2)=-sin1
2800           Ug(2,2,i-2)= cos1
2801           Ug2(1,1,i-2)=-cos2
2802           Ug2(1,2,i-2)=-sin2
2803           Ug2(2,1,i-2)=-sin2
2804           Ug2(2,2,i-2)= cos2
2805         else
2806           costab(i-2)=1.0d0
2807           sintab(i-2)=0.0d0
2808           obrot(1,i-2)=1.0d0
2809           obrot(2,i-2)=0.0d0
2810           obrot2(1,i-2)=0.0d0
2811           obrot2(2,i-2)=0.0d0
2812           Ug(1,1,i-2)=1.0d0
2813           Ug(1,2,i-2)=0.0d0
2814           Ug(2,1,i-2)=0.0d0
2815           Ug(2,2,i-2)=1.0d0
2816           Ug2(1,1,i-2)=0.0d0
2817           Ug2(1,2,i-2)=0.0d0
2818           Ug2(2,1,i-2)=0.0d0
2819           Ug2(2,2,i-2)=0.0d0
2820         endif
2821         if (i .gt. 3 .and. i .lt. nres+1) then
2822           obrot_der(1,i-2)=-sin1
2823           obrot_der(2,i-2)= cos1
2824           Ugder(1,1,i-2)= sin1
2825           Ugder(1,2,i-2)=-cos1
2826           Ugder(2,1,i-2)=-cos1
2827           Ugder(2,2,i-2)=-sin1
2828           dwacos2=cos2+cos2
2829           dwasin2=sin2+sin2
2830           obrot2_der(1,i-2)=-dwasin2
2831           obrot2_der(2,i-2)= dwacos2
2832           Ug2der(1,1,i-2)= dwasin2
2833           Ug2der(1,2,i-2)=-dwacos2
2834           Ug2der(2,1,i-2)=-dwacos2
2835           Ug2der(2,2,i-2)=-dwasin2
2836         else
2837           obrot_der(1,i-2)=0.0d0
2838           obrot_der(2,i-2)=0.0d0
2839           Ugder(1,1,i-2)=0.0d0
2840           Ugder(1,2,i-2)=0.0d0
2841           Ugder(2,1,i-2)=0.0d0
2842           Ugder(2,2,i-2)=0.0d0
2843           obrot2_der(1,i-2)=0.0d0
2844           obrot2_der(2,i-2)=0.0d0
2845           Ug2der(1,1,i-2)=0.0d0
2846           Ug2der(1,2,i-2)=0.0d0
2847           Ug2der(2,1,i-2)=0.0d0
2848           Ug2der(2,2,i-2)=0.0d0
2849         endif
2850 c        if (i.gt. iatel_s+2 .and. i.lt.iatel_e+5) then
2851         if (i.gt. nnt+2 .and. i.lt.nct+2) then
2852           iti = itortyp(itype(i-2))
2853         else
2854           iti=ntortyp
2855         endif
2856 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2857         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2858           iti1 = itortyp(itype(i-1))
2859         else
2860           iti1=ntortyp
2861         endif
2862 cd        write (iout,*) '*******i',i,' iti1',iti
2863 cd        write (iout,*) 'b1',b1(:,iti)
2864 cd        write (iout,*) 'b2',b2(:,iti)
2865 cd        write (iout,*) 'Ug',Ug(:,:,i-2)
2866 c        if (i .gt. iatel_s+2) then
2867         if (i .gt. nnt+2) then
2868           call matvec2(Ug(1,1,i-2),b2(1,i-2),Ub2(1,i-2))
2869 #ifdef NEWCORR
2870           call matvec2(Ug(1,1,i-2),gtb2(1,i-2),gUb2(1,i-2))
2871 c          write (iout,*) Ug(1,1,i-2),gtb2(1,i-2),gUb2(1,i-2),"chuj"
2872 #endif
2873 c          write(iout,*) "co jest kurwa", iti, EE(1,1,iti),EE(2,1,iti),
2874 c     &    EE(1,2,iti),EE(2,2,iti)
2875           call matmat2(EE(1,1,i-2),Ug(1,1,i-2),EUg(1,1,i-2))
2876           call matmat2(gtEE(1,1,i-2),Ug(1,1,i-2),gtEUg(1,1,i-2))
2877 c          write(iout,*) "Macierz EUG",
2878 c     &    eug(1,1,i-2),eug(1,2,i-2),eug(2,1,i-2),
2879 c     &    eug(2,2,i-2)
2880           if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2881      &    then
2882           call matmat2(CC(1,1,iti),Ug(1,1,i-2),CUg(1,1,i-2))
2883           call matmat2(DD(1,1,iti),Ug(1,1,i-2),DUg(1,1,i-2))
2884           call matmat2(Dtilde(1,1,iti),Ug2(1,1,i-2),DtUg2(1,1,i-2))
2885           call matvec2(Ctilde(1,1,iti1),obrot(1,i-2),Ctobr(1,i-2))
2886           call matvec2(Dtilde(1,1,iti),obrot2(1,i-2),Dtobr2(1,i-2))
2887           endif
2888         else
2889           do k=1,2
2890             Ub2(k,i-2)=0.0d0
2891             Ctobr(k,i-2)=0.0d0
2892             Dtobr2(k,i-2)=0.0d0
2893             do l=1,2
2894               EUg(l,k,i-2)=0.0d0
2895               CUg(l,k,i-2)=0.0d0
2896               DUg(l,k,i-2)=0.0d0
2897               DtUg2(l,k,i-2)=0.0d0
2898             enddo
2899           enddo
2900         endif
2901         call matvec2(Ugder(1,1,i-2),b2(1,i-2),Ub2der(1,i-2))
2902         call matmat2(EE(1,1,i-2),Ugder(1,1,i-2),EUgder(1,1,i-2))
2903         do k=1,2
2904           muder(k,i-2)=Ub2der(k,i-2)
2905         enddo
2906 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2907         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2908           if (itype(i-1).le.ntyp) then
2909             iti1 = itortyp(itype(i-1))
2910           else
2911             iti1=ntortyp
2912           endif
2913         else
2914           iti1=ntortyp
2915         endif
2916         do k=1,2
2917           mu(k,i-2)=Ub2(k,i-2)+b1(k,i-1)
2918         enddo
2919 c        write (iout,*) 'mu ',mu(:,i-2),i-2
2920 cd        write (iout,*) 'mu1',mu1(:,i-2)
2921 cd        write (iout,*) 'mu2',mu2(:,i-2)
2922         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
2923      &  then
2924         call matmat2(CC(1,1,iti1),Ugder(1,1,i-2),CUgder(1,1,i-2))
2925         call matmat2(DD(1,1,iti),Ugder(1,1,i-2),DUgder(1,1,i-2))
2926         call matmat2(Dtilde(1,1,iti),Ug2der(1,1,i-2),DtUg2der(1,1,i-2))
2927         call matvec2(Ctilde(1,1,iti1),obrot_der(1,i-2),Ctobrder(1,i-2))
2928         call matvec2(Dtilde(1,1,iti),obrot2_der(1,i-2),Dtobr2der(1,i-2))
2929 C Vectors and matrices dependent on a single virtual-bond dihedral.
2930         call matvec2(DD(1,1,iti),b1tilde(1,i-1),auxvec(1))
2931         call matvec2(Ug2(1,1,i-2),auxvec(1),Ug2Db1t(1,i-2))
2932         call matvec2(Ug2der(1,1,i-2),auxvec(1),Ug2Db1tder(1,i-2))
2933         call matvec2(CC(1,1,iti1),Ub2(1,i-2),CUgb2(1,i-2))
2934         call matvec2(CC(1,1,iti1),Ub2der(1,i-2),CUgb2der(1,i-2))
2935         call matmat2(EUg(1,1,i-2),CC(1,1,iti1),EUgC(1,1,i-2))
2936         call matmat2(EUgder(1,1,i-2),CC(1,1,iti1),EUgCder(1,1,i-2))
2937         call matmat2(EUg(1,1,i-2),DD(1,1,iti1),EUgD(1,1,i-2))
2938         call matmat2(EUgder(1,1,i-2),DD(1,1,iti1),EUgDder(1,1,i-2))
2939         endif
2940       enddo
2941 C Matrices dependent on two consecutive virtual-bond dihedrals.
2942 C The order of matrices is from left to right.
2943       if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
2944      &then
2945 c      do i=max0(ivec_start,2),ivec_end
2946       do i=2,nres-1
2947         call matmat2(DtUg2(1,1,i-1),EUg(1,1,i),DtUg2EUg(1,1,i))
2948         call matmat2(DtUg2der(1,1,i-1),EUg(1,1,i),DtUg2EUgder(1,1,1,i))
2949         call matmat2(DtUg2(1,1,i-1),EUgder(1,1,i),DtUg2EUgder(1,1,2,i))
2950         call transpose2(DtUg2(1,1,i-1),auxmat(1,1))
2951         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUg(1,1,i))
2952         call matmat2(auxmat(1,1),EUgder(1,1,i),Ug2DtEUgder(1,1,2,i))
2953         call transpose2(DtUg2der(1,1,i-1),auxmat(1,1))
2954         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUgder(1,1,1,i))
2955       enddo
2956       endif
2957 #if defined(MPI) && defined(PARMAT)
2958 #ifdef DEBUG
2959 c      if (fg_rank.eq.0) then
2960         write (iout,*) "Arrays UG and UGDER before GATHER"
2961         do i=1,nres-1
2962           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2963      &     ((ug(l,k,i),l=1,2),k=1,2),
2964      &     ((ugder(l,k,i),l=1,2),k=1,2)
2965         enddo
2966         write (iout,*) "Arrays UG2 and UG2DER"
2967         do i=1,nres-1
2968           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2969      &     ((ug2(l,k,i),l=1,2),k=1,2),
2970      &     ((ug2der(l,k,i),l=1,2),k=1,2)
2971         enddo
2972         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
2973         do i=1,nres-1
2974           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2975      &     (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
2976      &     (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
2977         enddo
2978         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
2979         do i=1,nres-1
2980           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2981      &     costab(i),sintab(i),costab2(i),sintab2(i)
2982         enddo
2983         write (iout,*) "Array MUDER"
2984         do i=1,nres-1
2985           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
2986         enddo
2987 c      endif
2988 #endif
2989       if (nfgtasks.gt.1) then
2990         time00=MPI_Wtime()
2991 c        write(iout,*)"Processor",fg_rank,kolor," ivec_start",ivec_start,
2992 c     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks-1),
2993 c     &   " ivec_count",(ivec_count(i),i=0,nfgtasks-1)
2994 #ifdef MATGATHER
2995         call MPI_Allgatherv(Ub2(1,ivec_start),ivec_count(fg_rank1),
2996      &   MPI_MU,Ub2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2997      &   FG_COMM1,IERR)
2998         call MPI_Allgatherv(Ub2der(1,ivec_start),ivec_count(fg_rank1),
2999      &   MPI_MU,Ub2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3000      &   FG_COMM1,IERR)
3001         call MPI_Allgatherv(mu(1,ivec_start),ivec_count(fg_rank1),
3002      &   MPI_MU,mu(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3003      &   FG_COMM1,IERR)
3004         call MPI_Allgatherv(muder(1,ivec_start),ivec_count(fg_rank1),
3005      &   MPI_MU,muder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3006      &   FG_COMM1,IERR)
3007         call MPI_Allgatherv(Eug(1,1,ivec_start),ivec_count(fg_rank1),
3008      &   MPI_MAT1,Eug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3009      &   FG_COMM1,IERR)
3010         call MPI_Allgatherv(Eugder(1,1,ivec_start),ivec_count(fg_rank1),
3011      &   MPI_MAT1,Eugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3012      &   FG_COMM1,IERR)
3013         call MPI_Allgatherv(costab(ivec_start),ivec_count(fg_rank1),
3014      &   MPI_DOUBLE_PRECISION,costab(1),ivec_count(0),ivec_displ(0),
3015      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3016         call MPI_Allgatherv(sintab(ivec_start),ivec_count(fg_rank1),
3017      &   MPI_DOUBLE_PRECISION,sintab(1),ivec_count(0),ivec_displ(0),
3018      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3019         call MPI_Allgatherv(costab2(ivec_start),ivec_count(fg_rank1),
3020      &   MPI_DOUBLE_PRECISION,costab2(1),ivec_count(0),ivec_displ(0),
3021      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3022         call MPI_Allgatherv(sintab2(ivec_start),ivec_count(fg_rank1),
3023      &   MPI_DOUBLE_PRECISION,sintab2(1),ivec_count(0),ivec_displ(0),
3024      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3025         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
3026      &  then
3027         call MPI_Allgatherv(Ctobr(1,ivec_start),ivec_count(fg_rank1),
3028      &   MPI_MU,Ctobr(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3029      &   FG_COMM1,IERR)
3030         call MPI_Allgatherv(Ctobrder(1,ivec_start),ivec_count(fg_rank1),
3031      &   MPI_MU,Ctobrder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3032      &   FG_COMM1,IERR)
3033         call MPI_Allgatherv(Dtobr2(1,ivec_start),ivec_count(fg_rank1),
3034      &   MPI_MU,Dtobr2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3035      &   FG_COMM1,IERR)
3036        call MPI_Allgatherv(Dtobr2der(1,ivec_start),ivec_count(fg_rank1),
3037      &   MPI_MU,Dtobr2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3038      &   FG_COMM1,IERR)
3039         call MPI_Allgatherv(Ug2Db1t(1,ivec_start),ivec_count(fg_rank1),
3040      &   MPI_MU,Ug2Db1t(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3041      &   FG_COMM1,IERR)
3042         call MPI_Allgatherv(Ug2Db1tder(1,ivec_start),
3043      &   ivec_count(fg_rank1),
3044      &   MPI_MU,Ug2Db1tder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3045      &   FG_COMM1,IERR)
3046         call MPI_Allgatherv(CUgb2(1,ivec_start),ivec_count(fg_rank1),
3047      &   MPI_MU,CUgb2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3048      &   FG_COMM1,IERR)
3049         call MPI_Allgatherv(CUgb2der(1,ivec_start),ivec_count(fg_rank1),
3050      &   MPI_MU,CUgb2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3051      &   FG_COMM1,IERR)
3052         call MPI_Allgatherv(Cug(1,1,ivec_start),ivec_count(fg_rank1),
3053      &   MPI_MAT1,Cug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3054      &   FG_COMM1,IERR)
3055         call MPI_Allgatherv(Cugder(1,1,ivec_start),ivec_count(fg_rank1),
3056      &   MPI_MAT1,Cugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3057      &   FG_COMM1,IERR)
3058         call MPI_Allgatherv(Dug(1,1,ivec_start),ivec_count(fg_rank1),
3059      &   MPI_MAT1,Dug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3060      &   FG_COMM1,IERR)
3061         call MPI_Allgatherv(Dugder(1,1,ivec_start),ivec_count(fg_rank1),
3062      &   MPI_MAT1,Dugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3063      &   FG_COMM1,IERR)
3064         call MPI_Allgatherv(Dtug2(1,1,ivec_start),ivec_count(fg_rank1),
3065      &   MPI_MAT1,Dtug2(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3066      &   FG_COMM1,IERR)
3067         call MPI_Allgatherv(Dtug2der(1,1,ivec_start),
3068      &   ivec_count(fg_rank1),
3069      &   MPI_MAT1,Dtug2der(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3070      &   FG_COMM1,IERR)
3071         call MPI_Allgatherv(EugC(1,1,ivec_start),ivec_count(fg_rank1),
3072      &   MPI_MAT1,EugC(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3073      &   FG_COMM1,IERR)
3074        call MPI_Allgatherv(EugCder(1,1,ivec_start),ivec_count(fg_rank1),
3075      &   MPI_MAT1,EugCder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3076      &   FG_COMM1,IERR)
3077         call MPI_Allgatherv(EugD(1,1,ivec_start),ivec_count(fg_rank1),
3078      &   MPI_MAT1,EugD(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3079      &   FG_COMM1,IERR)
3080        call MPI_Allgatherv(EugDder(1,1,ivec_start),ivec_count(fg_rank1),
3081      &   MPI_MAT1,EugDder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3082      &   FG_COMM1,IERR)
3083         call MPI_Allgatherv(DtUg2EUg(1,1,ivec_start),
3084      &   ivec_count(fg_rank1),
3085      &   MPI_MAT1,DtUg2EUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3086      &   FG_COMM1,IERR)
3087         call MPI_Allgatherv(Ug2DtEUg(1,1,ivec_start),
3088      &   ivec_count(fg_rank1),
3089      &   MPI_MAT1,Ug2DtEUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3090      &   FG_COMM1,IERR)
3091         call MPI_Allgatherv(DtUg2EUgder(1,1,1,ivec_start),
3092      &   ivec_count(fg_rank1),
3093      &   MPI_MAT2,DtUg2EUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
3094      &   MPI_MAT2,FG_COMM1,IERR)
3095         call MPI_Allgatherv(Ug2DtEUgder(1,1,1,ivec_start),
3096      &   ivec_count(fg_rank1),
3097      &   MPI_MAT2,Ug2DtEUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
3098      &   MPI_MAT2,FG_COMM1,IERR)
3099         endif
3100 #else
3101 c Passes matrix info through the ring
3102       isend=fg_rank1
3103       irecv=fg_rank1-1
3104       if (irecv.lt.0) irecv=nfgtasks1-1
3105       iprev=irecv
3106       inext=fg_rank1+1
3107       if (inext.ge.nfgtasks1) inext=0
3108       do i=1,nfgtasks1-1
3109 c        write (iout,*) "isend",isend," irecv",irecv
3110 c        call flush(iout)
3111         lensend=lentyp(isend)
3112         lenrecv=lentyp(irecv)
3113 c        write (iout,*) "lensend",lensend," lenrecv",lenrecv
3114 c        call MPI_SENDRECV(ug(1,1,ivec_displ(isend)+1),1,
3115 c     &   MPI_ROTAT1(lensend),inext,2200+isend,
3116 c     &   ug(1,1,ivec_displ(irecv)+1),1,MPI_ROTAT1(lenrecv),
3117 c     &   iprev,2200+irecv,FG_COMM,status,IERR)
3118 c        write (iout,*) "Gather ROTAT1"
3119 c        call flush(iout)
3120 c        call MPI_SENDRECV(obrot(1,ivec_displ(isend)+1),1,
3121 c     &   MPI_ROTAT2(lensend),inext,3300+isend,
3122 c     &   obrot(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
3123 c     &   iprev,3300+irecv,FG_COMM,status,IERR)
3124 c        write (iout,*) "Gather ROTAT2"
3125 c        call flush(iout)
3126         call MPI_SENDRECV(costab(ivec_displ(isend)+1),1,
3127      &   MPI_ROTAT_OLD(lensend),inext,4400+isend,
3128      &   costab(ivec_displ(irecv)+1),1,MPI_ROTAT_OLD(lenrecv),
3129      &   iprev,4400+irecv,FG_COMM,status,IERR)
3130 c        write (iout,*) "Gather ROTAT_OLD"
3131 c        call flush(iout)
3132         call MPI_SENDRECV(mu(1,ivec_displ(isend)+1),1,
3133      &   MPI_PRECOMP11(lensend),inext,5500+isend,
3134      &   mu(1,ivec_displ(irecv)+1),1,MPI_PRECOMP11(lenrecv),
3135      &   iprev,5500+irecv,FG_COMM,status,IERR)
3136 c        write (iout,*) "Gather PRECOMP11"
3137 c        call flush(iout)
3138         call MPI_SENDRECV(Eug(1,1,ivec_displ(isend)+1),1,
3139      &   MPI_PRECOMP12(lensend),inext,6600+isend,
3140      &   Eug(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP12(lenrecv),
3141      &   iprev,6600+irecv,FG_COMM,status,IERR)
3142 c        write (iout,*) "Gather PRECOMP12"
3143 c        call flush(iout)
3144         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
3145      &  then
3146         call MPI_SENDRECV(ug2db1t(1,ivec_displ(isend)+1),1,
3147      &   MPI_ROTAT2(lensend),inext,7700+isend,
3148      &   ug2db1t(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
3149      &   iprev,7700+irecv,FG_COMM,status,IERR)
3150 c        write (iout,*) "Gather PRECOMP21"
3151 c        call flush(iout)
3152         call MPI_SENDRECV(EUgC(1,1,ivec_displ(isend)+1),1,
3153      &   MPI_PRECOMP22(lensend),inext,8800+isend,
3154      &   EUgC(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP22(lenrecv),
3155      &   iprev,8800+irecv,FG_COMM,status,IERR)
3156 c        write (iout,*) "Gather PRECOMP22"
3157 c        call flush(iout)
3158         call MPI_SENDRECV(Ug2DtEUgder(1,1,1,ivec_displ(isend)+1),1,
3159      &   MPI_PRECOMP23(lensend),inext,9900+isend,
3160      &   Ug2DtEUgder(1,1,1,ivec_displ(irecv)+1),1,
3161      &   MPI_PRECOMP23(lenrecv),
3162      &   iprev,9900+irecv,FG_COMM,status,IERR)
3163 c        write (iout,*) "Gather PRECOMP23"
3164 c        call flush(iout)
3165         endif
3166         isend=irecv
3167         irecv=irecv-1
3168         if (irecv.lt.0) irecv=nfgtasks1-1
3169       enddo
3170 #endif
3171         time_gather=time_gather+MPI_Wtime()-time00
3172       endif
3173 #ifdef DEBUG
3174 c      if (fg_rank.eq.0) then
3175         write (iout,*) "Arrays UG and UGDER"
3176         do i=1,nres-1
3177           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3178      &     ((ug(l,k,i),l=1,2),k=1,2),
3179      &     ((ugder(l,k,i),l=1,2),k=1,2)
3180         enddo
3181         write (iout,*) "Arrays UG2 and UG2DER"
3182         do i=1,nres-1
3183           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3184      &     ((ug2(l,k,i),l=1,2),k=1,2),
3185      &     ((ug2der(l,k,i),l=1,2),k=1,2)
3186         enddo
3187         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
3188         do i=1,nres-1
3189           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3190      &     (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
3191      &     (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
3192         enddo
3193         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
3194         do i=1,nres-1
3195           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3196      &     costab(i),sintab(i),costab2(i),sintab2(i)
3197         enddo
3198         write (iout,*) "Array MUDER"
3199         do i=1,nres-1
3200           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
3201         enddo
3202 c      endif
3203 #endif
3204 #endif
3205 cd      do i=1,nres
3206 cd        iti = itortyp(itype(i))
3207 cd        write (iout,*) i
3208 cd        do j=1,2
3209 cd        write (iout,'(2f10.5,5x,2f10.5,5x,2f10.5)')
3210 cd     &  (EE(j,k,iti),k=1,2),(Ug(j,k,i),k=1,2),(EUg(j,k,i),k=1,2)
3211 cd        enddo
3212 cd      enddo
3213       return
3214       end
3215 C--------------------------------------------------------------------------
3216       subroutine eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
3217 C
3218 C This subroutine calculates the average interaction energy and its gradient
3219 C in the virtual-bond vectors between non-adjacent peptide groups, based on
3220 C the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
3221 C The potential depends both on the distance of peptide-group centers and on
3222 C the orientation of the CA-CA virtual bonds.
3223 C
3224       implicit real*8 (a-h,o-z)
3225 #ifdef MPI
3226       include 'mpif.h'
3227 #endif
3228       include 'DIMENSIONS'
3229       include 'COMMON.CONTROL'
3230       include 'COMMON.SETUP'
3231       include 'COMMON.IOUNITS'
3232       include 'COMMON.GEO'
3233       include 'COMMON.VAR'
3234       include 'COMMON.LOCAL'
3235       include 'COMMON.CHAIN'
3236       include 'COMMON.DERIV'
3237       include 'COMMON.INTERACT'
3238       include 'COMMON.CONTACTS'
3239       include 'COMMON.TORSION'
3240       include 'COMMON.VECTORS'
3241       include 'COMMON.FFIELD'
3242       include 'COMMON.TIME1'
3243       include 'COMMON.SPLITELE'
3244       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
3245      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
3246       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
3247      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4),gmuij(4)
3248       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3249      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3250      &    num_conti,j1,j2
3251 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
3252 #ifdef MOMENT
3253       double precision scal_el /1.0d0/
3254 #else
3255       double precision scal_el /0.5d0/
3256 #endif
3257 C 12/13/98
3258 C 13-go grudnia roku pamietnego...
3259       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
3260      &                   0.0d0,1.0d0,0.0d0,
3261      &                   0.0d0,0.0d0,1.0d0/
3262 cd      write(iout,*) 'In EELEC'
3263 cd      do i=1,nloctyp
3264 cd        write(iout,*) 'Type',i
3265 cd        write(iout,*) 'B1',B1(:,i)
3266 cd        write(iout,*) 'B2',B2(:,i)
3267 cd        write(iout,*) 'CC',CC(:,:,i)
3268 cd        write(iout,*) 'DD',DD(:,:,i)
3269 cd        write(iout,*) 'EE',EE(:,:,i)
3270 cd      enddo
3271 cd      call check_vecgrad
3272 cd      stop
3273       if (icheckgrad.eq.1) then
3274         do i=1,nres-1
3275           fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
3276           do k=1,3
3277             dc_norm(k,i)=dc(k,i)*fac
3278           enddo
3279 c          write (iout,*) 'i',i,' fac',fac
3280         enddo
3281       endif
3282       if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
3283      &    .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or.
3284      &    wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
3285 c        call vec_and_deriv
3286 #ifdef TIMING
3287         time01=MPI_Wtime()
3288 #endif
3289         call set_matrices
3290 #ifdef TIMING
3291         time_mat=time_mat+MPI_Wtime()-time01
3292 #endif
3293       endif
3294 cd      do i=1,nres-1
3295 cd        write (iout,*) 'i=',i
3296 cd        do k=1,3
3297 cd        write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
3298 cd        enddo
3299 cd        do k=1,3
3300 cd          write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
3301 cd     &     uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
3302 cd        enddo
3303 cd      enddo
3304       t_eelecij=0.0d0
3305       ees=0.0D0
3306       evdw1=0.0D0
3307       eel_loc=0.0d0
3308       eello_turn3=0.0d0
3309       eello_turn4=0.0d0
3310       ind=0
3311       do i=1,nres
3312         num_cont_hb(i)=0
3313       enddo
3314 cd      print '(a)','Enter EELEC'
3315 cd      write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
3316       do i=1,nres
3317         gel_loc_loc(i)=0.0d0
3318         gcorr_loc(i)=0.0d0
3319       enddo
3320 c
3321 c
3322 c 9/27/08 AL Split the interaction loop to ensure load balancing of turn terms
3323 C
3324 C Loop over i,i+2 and i,i+3 pairs of the peptide groups
3325 C
3326 C 14/01/2014 TURN3,TUNR4 does no go under periodic boundry condition
3327       do i=iturn3_start,iturn3_end
3328         if (i.le.1) cycle
3329 C        write(iout,*) "tu jest i",i
3330         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
3331 C changes suggested by Ana to avoid out of bounds
3332      & .or.((i+4).gt.nres)
3333      & .or.((i-1).le.0)
3334 C end of changes by Ana
3335      &  .or. itype(i+2).eq.ntyp1
3336      &  .or. itype(i+3).eq.ntyp1) cycle
3337         if(i.gt.1)then
3338           if(itype(i-1).eq.ntyp1)cycle
3339         end if
3340         if(i.LT.nres-3)then
3341           if (itype(i+4).eq.ntyp1) cycle
3342         end if
3343         dxi=dc(1,i)
3344         dyi=dc(2,i)
3345         dzi=dc(3,i)
3346         dx_normi=dc_norm(1,i)
3347         dy_normi=dc_norm(2,i)
3348         dz_normi=dc_norm(3,i)
3349         xmedi=c(1,i)+0.5d0*dxi
3350         ymedi=c(2,i)+0.5d0*dyi
3351         zmedi=c(3,i)+0.5d0*dzi
3352           xmedi=mod(xmedi,boxxsize)
3353           if (xmedi.lt.0) xmedi=xmedi+boxxsize
3354           ymedi=mod(ymedi,boxysize)
3355           if (ymedi.lt.0) ymedi=ymedi+boxysize
3356           zmedi=mod(zmedi,boxzsize)
3357           if (zmedi.lt.0) zmedi=zmedi+boxzsize
3358         num_conti=0
3359         call eelecij(i,i+2,ees,evdw1,eel_loc)
3360         if (wturn3.gt.0.0d0) call eturn3(i,eello_turn3)
3361         num_cont_hb(i)=num_conti
3362       enddo
3363       do i=iturn4_start,iturn4_end
3364         if (i.le.1) cycle
3365         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
3366 C changes suggested by Ana to avoid out of bounds
3367      & .or.((i+5).gt.nres)
3368      & .or.((i-1).le.0)
3369 C end of changes suggested by Ana
3370      &    .or. itype(i+3).eq.ntyp1
3371      &    .or. itype(i+4).eq.ntyp1
3372      &    .or. itype(i+5).eq.ntyp1
3373      &    .or. itype(i).eq.ntyp1
3374      &    .or. itype(i-1).eq.ntyp1
3375      &                             ) cycle
3376         dxi=dc(1,i)
3377         dyi=dc(2,i)
3378         dzi=dc(3,i)
3379         dx_normi=dc_norm(1,i)
3380         dy_normi=dc_norm(2,i)
3381         dz_normi=dc_norm(3,i)
3382         xmedi=c(1,i)+0.5d0*dxi
3383         ymedi=c(2,i)+0.5d0*dyi
3384         zmedi=c(3,i)+0.5d0*dzi
3385 C Return atom into box, boxxsize is size of box in x dimension
3386 c  194   continue
3387 c        if (xmedi.gt.((0.5d0)*boxxsize)) xmedi=xmedi-boxxsize
3388 c        if (xmedi.lt.((-0.5d0)*boxxsize)) xmedi=xmedi+boxxsize
3389 C Condition for being inside the proper box
3390 c        if ((xmedi.gt.((0.5d0)*boxxsize)).or.
3391 c     &       (xmedi.lt.((-0.5d0)*boxxsize))) then
3392 c        go to 194
3393 c        endif
3394 c  195   continue
3395 c        if (ymedi.gt.((0.5d0)*boxysize)) ymedi=ymedi-boxysize
3396 c        if (ymedi.lt.((-0.5d0)*boxysize)) ymedi=ymedi+boxysize
3397 C Condition for being inside the proper box
3398 c        if ((ymedi.gt.((0.5d0)*boxysize)).or.
3399 c     &       (ymedi.lt.((-0.5d0)*boxysize))) then
3400 c        go to 195
3401 c        endif
3402 c  196   continue
3403 c        if (zmedi.gt.((0.5d0)*boxzsize)) zmedi=zmedi-boxzsize
3404 c        if (zmedi.lt.((-0.5d0)*boxzsize)) zmedi=zmedi+boxzsize
3405 C Condition for being inside the proper box
3406 c        if ((zmedi.gt.((0.5d0)*boxzsize)).or.
3407 c     &       (zmedi.lt.((-0.5d0)*boxzsize))) then
3408 c        go to 196
3409 c        endif
3410           xmedi=mod(xmedi,boxxsize)
3411           if (xmedi.lt.0) xmedi=xmedi+boxxsize
3412           ymedi=mod(ymedi,boxysize)
3413           if (ymedi.lt.0) ymedi=ymedi+boxysize
3414           zmedi=mod(zmedi,boxzsize)
3415           if (zmedi.lt.0) zmedi=zmedi+boxzsize
3416
3417         num_conti=num_cont_hb(i)
3418 c        write(iout,*) "JESTEM W PETLI"
3419         call eelecij(i,i+3,ees,evdw1,eel_loc)
3420         if (wturn4.gt.0.0d0 .and. itype(i+2).ne.ntyp1)
3421      &   call eturn4(i,eello_turn4)
3422         num_cont_hb(i)=num_conti
3423       enddo   ! i
3424 C Loop over all neighbouring boxes
3425 C      do xshift=-1,1
3426 C      do yshift=-1,1
3427 C      do zshift=-1,1
3428 c
3429 c Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
3430 c
3431       do i=iatel_s,iatel_e
3432         if (i.le.1) cycle
3433         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
3434 C changes suggested by Ana to avoid out of bounds
3435      & .or.((i+2).gt.nres)
3436      & .or.((i-1).le.0)
3437 C end of changes by Ana
3438      &  .or. itype(i+2).eq.ntyp1
3439      &  .or. itype(i-1).eq.ntyp1
3440      &                ) cycle
3441         dxi=dc(1,i)
3442         dyi=dc(2,i)
3443         dzi=dc(3,i)
3444         dx_normi=dc_norm(1,i)
3445         dy_normi=dc_norm(2,i)
3446         dz_normi=dc_norm(3,i)
3447         xmedi=c(1,i)+0.5d0*dxi
3448         ymedi=c(2,i)+0.5d0*dyi
3449         zmedi=c(3,i)+0.5d0*dzi
3450           xmedi=mod(xmedi,boxxsize)
3451           if (xmedi.lt.0) xmedi=xmedi+boxxsize
3452           ymedi=mod(ymedi,boxysize)
3453           if (ymedi.lt.0) ymedi=ymedi+boxysize
3454           zmedi=mod(zmedi,boxzsize)
3455           if (zmedi.lt.0) zmedi=zmedi+boxzsize
3456 C          xmedi=xmedi+xshift*boxxsize
3457 C          ymedi=ymedi+yshift*boxysize
3458 C          zmedi=zmedi+zshift*boxzsize
3459
3460 C Return tom into box, boxxsize is size of box in x dimension
3461 c  164   continue
3462 c        if (xmedi.gt.((xshift+0.5d0)*boxxsize)) xmedi=xmedi-boxxsize
3463 c        if (xmedi.lt.((xshift-0.5d0)*boxxsize)) xmedi=xmedi+boxxsize
3464 C Condition for being inside the proper box
3465 c        if ((xmedi.gt.((xshift+0.5d0)*boxxsize)).or.
3466 c     &       (xmedi.lt.((xshift-0.5d0)*boxxsize))) then
3467 c        go to 164
3468 c        endif
3469 c  165   continue
3470 c        if (ymedi.gt.((yshift+0.5d0)*boxysize)) ymedi=ymedi-boxysize
3471 c        if (ymedi.lt.((yshift-0.5d0)*boxysize)) ymedi=ymedi+boxysize
3472 C Condition for being inside the proper box
3473 c        if ((ymedi.gt.((yshift+0.5d0)*boxysize)).or.
3474 c     &       (ymedi.lt.((yshift-0.5d0)*boxysize))) then
3475 c        go to 165
3476 c        endif
3477 c  166   continue
3478 c        if (zmedi.gt.((zshift+0.5d0)*boxzsize)) zmedi=zmedi-boxzsize
3479 c        if (zmedi.lt.((zshift-0.5d0)*boxzsize)) zmedi=zmedi+boxzsize
3480 cC Condition for being inside the proper box
3481 c        if ((zmedi.gt.((zshift+0.5d0)*boxzsize)).or.
3482 c     &       (zmedi.lt.((zshift-0.5d0)*boxzsize))) then
3483 c        go to 166
3484 c        endif
3485
3486 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
3487         num_conti=num_cont_hb(i)
3488         do j=ielstart(i),ielend(i)
3489 C          write (iout,*) i,j
3490          if (j.le.1) cycle
3491           if (itype(j).eq.ntyp1.or. itype(j+1).eq.ntyp1
3492 C changes suggested by Ana to avoid out of bounds
3493      & .or.((j+2).gt.nres)
3494      & .or.((j-1).le.0)
3495 C end of changes by Ana
3496      & .or.itype(j+2).eq.ntyp1
3497      & .or.itype(j-1).eq.ntyp1
3498      &) cycle
3499           call eelecij(i,j,ees,evdw1,eel_loc)
3500         enddo ! j
3501         num_cont_hb(i)=num_conti
3502       enddo   ! i
3503 C     enddo   ! zshift
3504 C      enddo   ! yshift
3505 C      enddo   ! xshift
3506
3507 c      write (iout,*) "Number of loop steps in EELEC:",ind
3508 cd      do i=1,nres
3509 cd        write (iout,'(i3,3f10.5,5x,3f10.5)')
3510 cd     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
3511 cd      enddo
3512 c 12/7/99 Adam eello_turn3 will be considered as a separate energy term
3513 ccc      eel_loc=eel_loc+eello_turn3
3514 cd      print *,"Processor",fg_rank," t_eelecij",t_eelecij
3515       return
3516       end
3517 C-------------------------------------------------------------------------------
3518       subroutine eelecij(i,j,ees,evdw1,eel_loc)
3519       implicit real*8 (a-h,o-z)
3520       include 'DIMENSIONS'
3521 #ifdef MPI
3522       include "mpif.h"
3523 #endif
3524       include 'COMMON.CONTROL'
3525       include 'COMMON.IOUNITS'
3526       include 'COMMON.GEO'
3527       include 'COMMON.VAR'
3528       include 'COMMON.LOCAL'
3529       include 'COMMON.CHAIN'
3530       include 'COMMON.DERIV'
3531       include 'COMMON.INTERACT'
3532       include 'COMMON.CONTACTS'
3533       include 'COMMON.TORSION'
3534       include 'COMMON.VECTORS'
3535       include 'COMMON.FFIELD'
3536       include 'COMMON.TIME1'
3537       include 'COMMON.SPLITELE'
3538       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
3539      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
3540       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
3541      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4),gmuij1(4),gmuji1(4),
3542      &    gmuij2(4),gmuji2(4)
3543       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3544      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3545      &    num_conti,j1,j2
3546 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
3547 #ifdef MOMENT
3548       double precision scal_el /1.0d0/
3549 #else
3550       double precision scal_el /0.5d0/
3551 #endif
3552 C 12/13/98
3553 C 13-go grudnia roku pamietnego...
3554       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
3555      &                   0.0d0,1.0d0,0.0d0,
3556      &                   0.0d0,0.0d0,1.0d0/
3557 c          time00=MPI_Wtime()
3558 cd      write (iout,*) "eelecij",i,j
3559 c          ind=ind+1
3560           iteli=itel(i)
3561           itelj=itel(j)
3562           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
3563           aaa=app(iteli,itelj)
3564           bbb=bpp(iteli,itelj)
3565           ael6i=ael6(iteli,itelj)
3566           ael3i=ael3(iteli,itelj)
3567           dxj=dc(1,j)
3568           dyj=dc(2,j)
3569           dzj=dc(3,j)
3570           dx_normj=dc_norm(1,j)
3571           dy_normj=dc_norm(2,j)
3572           dz_normj=dc_norm(3,j)
3573 C          xj=c(1,j)+0.5D0*dxj-xmedi
3574 C          yj=c(2,j)+0.5D0*dyj-ymedi
3575 C          zj=c(3,j)+0.5D0*dzj-zmedi
3576           xj=c(1,j)+0.5D0*dxj
3577           yj=c(2,j)+0.5D0*dyj
3578           zj=c(3,j)+0.5D0*dzj
3579           xj=mod(xj,boxxsize)
3580           if (xj.lt.0) xj=xj+boxxsize
3581           yj=mod(yj,boxysize)
3582           if (yj.lt.0) yj=yj+boxysize
3583           zj=mod(zj,boxzsize)
3584           if (zj.lt.0) zj=zj+boxzsize
3585           if ((zj.lt.0).or.(xj.lt.0).or.(yj.lt.0)) write (*,*) "CHUJ"
3586       dist_init=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
3587       xj_safe=xj
3588       yj_safe=yj
3589       zj_safe=zj
3590       isubchap=0
3591       do xshift=-1,1
3592       do yshift=-1,1
3593       do zshift=-1,1
3594           xj=xj_safe+xshift*boxxsize
3595           yj=yj_safe+yshift*boxysize
3596           zj=zj_safe+zshift*boxzsize
3597           dist_temp=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
3598           if(dist_temp.lt.dist_init) then
3599             dist_init=dist_temp
3600             xj_temp=xj
3601             yj_temp=yj
3602             zj_temp=zj
3603             isubchap=1
3604           endif
3605        enddo
3606        enddo
3607        enddo
3608        if (isubchap.eq.1) then
3609           xj=xj_temp-xmedi
3610           yj=yj_temp-ymedi
3611           zj=zj_temp-zmedi
3612        else
3613           xj=xj_safe-xmedi
3614           yj=yj_safe-ymedi
3615           zj=zj_safe-zmedi
3616        endif
3617 C        if ((i+3).lt.j) then !this condition keeps for turn3 and turn4 not subject to PBC
3618 c  174   continue
3619 c        if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
3620 c        if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
3621 C Condition for being inside the proper box
3622 c        if ((xj.gt.((0.5d0)*boxxsize)).or.
3623 c     &       (xj.lt.((-0.5d0)*boxxsize))) then
3624 c        go to 174
3625 c        endif
3626 c  175   continue
3627 c        if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
3628 c        if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
3629 C Condition for being inside the proper box
3630 c        if ((yj.gt.((0.5d0)*boxysize)).or.
3631 c     &       (yj.lt.((-0.5d0)*boxysize))) then
3632 c        go to 175
3633 c        endif
3634 c  176   continue
3635 c        if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
3636 c        if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
3637 C Condition for being inside the proper box
3638 c        if ((zj.gt.((0.5d0)*boxzsize)).or.
3639 c     &       (zj.lt.((-0.5d0)*boxzsize))) then
3640 c        go to 176
3641 c        endif
3642 C        endif !endPBC condintion
3643 C        xj=xj-xmedi
3644 C        yj=yj-ymedi
3645 C        zj=zj-zmedi
3646           rij=xj*xj+yj*yj+zj*zj
3647
3648             sss=sscale(sqrt(rij))
3649             sssgrad=sscagrad(sqrt(rij))
3650 c            if (sss.gt.0.0d0) then
3651           rrmij=1.0D0/rij
3652           rij=dsqrt(rij)
3653           rmij=1.0D0/rij
3654           r3ij=rrmij*rmij
3655           r6ij=r3ij*r3ij
3656           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
3657           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
3658           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
3659           fac=cosa-3.0D0*cosb*cosg
3660           ev1=aaa*r6ij*r6ij
3661 c 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
3662           if (j.eq.i+2) ev1=scal_el*ev1
3663           ev2=bbb*r6ij
3664           fac3=ael6i*r6ij
3665           fac4=ael3i*r3ij
3666           evdwij=(ev1+ev2)
3667           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
3668           el2=fac4*fac
3669 C MARYSIA
3670           eesij=(el1+el2)
3671 C 12/26/95 - for the evaluation of multi-body H-bonding interactions
3672           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
3673           ees=ees+eesij
3674           evdw1=evdw1+evdwij*sss
3675 cd          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
3676 cd     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
3677 cd     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
3678 cd     &      xmedi,ymedi,zmedi,xj,yj,zj
3679
3680           if (energy_dec) then
3681               write (iout,'(a6,2i5,0pf7.3,2i5,2e11.3)')
3682      &'evdw1',i,j,evdwij
3683      &,iteli,itelj,aaa,evdw1
3684               write (iout,'(a6,2i5,0pf7.3)') 'ees',i,j,eesij
3685           endif
3686
3687 C
3688 C Calculate contributions to the Cartesian gradient.
3689 C
3690 #ifdef SPLITELE
3691           facvdw=-6*rrmij*(ev1+evdwij)*sss
3692           facel=-3*rrmij*(el1+eesij)
3693           fac1=fac
3694           erij(1)=xj*rmij
3695           erij(2)=yj*rmij
3696           erij(3)=zj*rmij
3697 *
3698 * Radial derivatives. First process both termini of the fragment (i,j)
3699 *
3700           ggg(1)=facel*xj
3701           ggg(2)=facel*yj
3702           ggg(3)=facel*zj
3703 c          do k=1,3
3704 c            ghalf=0.5D0*ggg(k)
3705 c            gelc(k,i)=gelc(k,i)+ghalf
3706 c            gelc(k,j)=gelc(k,j)+ghalf
3707 c          enddo
3708 c 9/28/08 AL Gradient compotents will be summed only at the end
3709           do k=1,3
3710             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
3711             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
3712           enddo
3713 *
3714 * Loop over residues i+1 thru j-1.
3715 *
3716 cgrad          do k=i+1,j-1
3717 cgrad            do l=1,3
3718 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3719 cgrad            enddo
3720 cgrad          enddo
3721           if (sss.gt.0.0) then
3722           ggg(1)=facvdw*xj+sssgrad*rmij*evdwij*xj
3723           ggg(2)=facvdw*yj+sssgrad*rmij*evdwij*yj
3724           ggg(3)=facvdw*zj+sssgrad*rmij*evdwij*zj
3725           else
3726           ggg(1)=0.0
3727           ggg(2)=0.0
3728           ggg(3)=0.0
3729           endif
3730 c          do k=1,3
3731 c            ghalf=0.5D0*ggg(k)
3732 c            gvdwpp(k,i)=gvdwpp(k,i)+ghalf
3733 c            gvdwpp(k,j)=gvdwpp(k,j)+ghalf
3734 c          enddo
3735 c 9/28/08 AL Gradient compotents will be summed only at the end
3736           do k=1,3
3737             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
3738             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
3739           enddo
3740 *
3741 * Loop over residues i+1 thru j-1.
3742 *
3743 cgrad          do k=i+1,j-1
3744 cgrad            do l=1,3
3745 cgrad              gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
3746 cgrad            enddo
3747 cgrad          enddo
3748 #else
3749 C MARYSIA
3750           facvdw=(ev1+evdwij)*sss
3751           facel=(el1+eesij)
3752           fac1=fac
3753           fac=-3*rrmij*(facvdw+facvdw+facel)
3754           erij(1)=xj*rmij
3755           erij(2)=yj*rmij
3756           erij(3)=zj*rmij
3757 *
3758 * Radial derivatives. First process both termini of the fragment (i,j)
3759 *
3760           ggg(1)=fac*xj
3761           ggg(2)=fac*yj
3762           ggg(3)=fac*zj
3763 c          do k=1,3
3764 c            ghalf=0.5D0*ggg(k)
3765 c            gelc(k,i)=gelc(k,i)+ghalf
3766 c            gelc(k,j)=gelc(k,j)+ghalf
3767 c          enddo
3768 c 9/28/08 AL Gradient compotents will be summed only at the end
3769           do k=1,3
3770             gelc_long(k,j)=gelc(k,j)+ggg(k)
3771             gelc_long(k,i)=gelc(k,i)-ggg(k)
3772           enddo
3773 *
3774 * Loop over residues i+1 thru j-1.
3775 *
3776 cgrad          do k=i+1,j-1
3777 cgrad            do l=1,3
3778 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3779 cgrad            enddo
3780 cgrad          enddo
3781 c 9/28/08 AL Gradient compotents will be summed only at the end
3782           ggg(1)=facvdw*xj+sssgrad*rmij*evdwij*xj
3783           ggg(2)=facvdw*yj+sssgrad*rmij*evdwij*yj
3784           ggg(3)=facvdw*zj+sssgrad*rmij*evdwij*zj
3785           do k=1,3
3786             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
3787             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
3788           enddo
3789 #endif
3790 *
3791 * Angular part
3792 *
3793           ecosa=2.0D0*fac3*fac1+fac4
3794           fac4=-3.0D0*fac4
3795           fac3=-6.0D0*fac3
3796           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
3797           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
3798           do k=1,3
3799             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
3800             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
3801           enddo
3802 cd        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
3803 cd   &          (dcosg(k),k=1,3)
3804           do k=1,3
3805             ggg(k)=ecosb*dcosb(k)+ecosg*dcosg(k)
3806           enddo
3807 c          do k=1,3
3808 c            ghalf=0.5D0*ggg(k)
3809 c            gelc(k,i)=gelc(k,i)+ghalf
3810 c     &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
3811 c     &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3812 c            gelc(k,j)=gelc(k,j)+ghalf
3813 c     &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
3814 c     &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3815 c          enddo
3816 cgrad          do k=i+1,j-1
3817 cgrad            do l=1,3
3818 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3819 cgrad            enddo
3820 cgrad          enddo
3821           do k=1,3
3822             gelc(k,i)=gelc(k,i)
3823      &           +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
3824      &           + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3825             gelc(k,j)=gelc(k,j)
3826      &           +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
3827      &           + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3828             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
3829             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
3830           enddo
3831 C MARYSIA
3832 c          endif !sscale
3833           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
3834      &        .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0
3835      &        .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
3836 C
3837 C 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
3838 C   energy of a peptide unit is assumed in the form of a second-order
3839 C   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
3840 C   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
3841 C   are computed for EVERY pair of non-contiguous peptide groups.
3842 C
3843
3844           if (j.lt.nres-1) then
3845             j1=j+1
3846             j2=j-1
3847           else
3848             j1=j-1
3849             j2=j-2
3850           endif
3851           kkk=0
3852           lll=0
3853           do k=1,2
3854             do l=1,2
3855               kkk=kkk+1
3856               muij(kkk)=mu(k,i)*mu(l,j)
3857 c              write(iout,*) 'mumu=', mu(k,i),mu(l,j),i,j,k,l
3858 #ifdef NEWCORR
3859              gmuij1(kkk)=gtb1(k,i+1)*mu(l,j)
3860 c             write(iout,*) 'k=',k,i,gtb1(k,i+1),gtb1(k,i+1)*mu(l,j)
3861              gmuij2(kkk)=gUb2(k,i)*mu(l,j)
3862              gmuji1(kkk)=mu(k,i)*gtb1(l,j+1)
3863 c             write(iout,*) 'l=',l,j,gtb1(l,j+1),gtb1(l,j+1)*mu(k,i)
3864              gmuji2(kkk)=mu(k,i)*gUb2(l,j)
3865 #endif
3866             enddo
3867           enddo
3868 cd         write (iout,*) 'EELEC: i',i,' j',j
3869 cd          write (iout,*) 'j',j,' j1',j1,' j2',j2
3870 cd          write(iout,*) 'muij',muij
3871           ury=scalar(uy(1,i),erij)
3872           urz=scalar(uz(1,i),erij)
3873           vry=scalar(uy(1,j),erij)
3874           vrz=scalar(uz(1,j),erij)
3875           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
3876           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
3877           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
3878           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
3879           fac=dsqrt(-ael6i)*r3ij
3880           a22=a22*fac
3881           a23=a23*fac
3882           a32=a32*fac
3883           a33=a33*fac
3884 cd          write (iout,'(4i5,4f10.5)')
3885 cd     &     i,itortyp(itype(i)),j,itortyp(itype(j)),a22,a23,a32,a33
3886 cd          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
3887 cd          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') uy(:,i),uz(:,i),
3888 cd     &      uy(:,j),uz(:,j)
3889 cd          write (iout,'(4f10.5)')
3890 cd     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
3891 cd     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
3892 cd          write (iout,'(4f10.5)') ury,urz,vry,vrz
3893 cd           write (iout,'(9f10.5/)')
3894 cd     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
3895 C Derivatives of the elements of A in virtual-bond vectors
3896           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
3897           do k=1,3
3898             uryg(k,1)=scalar(erder(1,k),uy(1,i))
3899             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
3900             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
3901             urzg(k,1)=scalar(erder(1,k),uz(1,i))
3902             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
3903             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
3904             vryg(k,1)=scalar(erder(1,k),uy(1,j))
3905             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
3906             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
3907             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
3908             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
3909             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
3910           enddo
3911 C Compute radial contributions to the gradient
3912           facr=-3.0d0*rrmij
3913           a22der=a22*facr
3914           a23der=a23*facr
3915           a32der=a32*facr
3916           a33der=a33*facr
3917           agg(1,1)=a22der*xj
3918           agg(2,1)=a22der*yj
3919           agg(3,1)=a22der*zj
3920           agg(1,2)=a23der*xj
3921           agg(2,2)=a23der*yj
3922           agg(3,2)=a23der*zj
3923           agg(1,3)=a32der*xj
3924           agg(2,3)=a32der*yj
3925           agg(3,3)=a32der*zj
3926           agg(1,4)=a33der*xj
3927           agg(2,4)=a33der*yj
3928           agg(3,4)=a33der*zj
3929 C Add the contributions coming from er
3930           fac3=-3.0d0*fac
3931           do k=1,3
3932             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
3933             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
3934             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
3935             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
3936           enddo
3937           do k=1,3
3938 C Derivatives in DC(i)
3939 cgrad            ghalf1=0.5d0*agg(k,1)
3940 cgrad            ghalf2=0.5d0*agg(k,2)
3941 cgrad            ghalf3=0.5d0*agg(k,3)
3942 cgrad            ghalf4=0.5d0*agg(k,4)
3943             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j))
3944      &      -3.0d0*uryg(k,2)*vry)!+ghalf1
3945             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j))
3946      &      -3.0d0*uryg(k,2)*vrz)!+ghalf2
3947             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j))
3948      &      -3.0d0*urzg(k,2)*vry)!+ghalf3
3949             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j))
3950      &      -3.0d0*urzg(k,2)*vrz)!+ghalf4
3951 C Derivatives in DC(i+1)
3952             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j))
3953      &      -3.0d0*uryg(k,3)*vry)!+agg(k,1)
3954             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j))
3955      &      -3.0d0*uryg(k,3)*vrz)!+agg(k,2)
3956             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j))
3957      &      -3.0d0*urzg(k,3)*vry)!+agg(k,3)
3958             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j))
3959      &      -3.0d0*urzg(k,3)*vrz)!+agg(k,4)
3960 C Derivatives in DC(j)
3961             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i))
3962      &      -3.0d0*vryg(k,2)*ury)!+ghalf1
3963             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i))
3964      &      -3.0d0*vrzg(k,2)*ury)!+ghalf2
3965             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i))
3966      &      -3.0d0*vryg(k,2)*urz)!+ghalf3
3967             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i))
3968      &      -3.0d0*vrzg(k,2)*urz)!+ghalf4
3969 C Derivatives in DC(j+1) or DC(nres-1)
3970             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i))
3971      &      -3.0d0*vryg(k,3)*ury)
3972             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i))
3973      &      -3.0d0*vrzg(k,3)*ury)
3974             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i))
3975      &      -3.0d0*vryg(k,3)*urz)
3976             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i))
3977      &      -3.0d0*vrzg(k,3)*urz)
3978 cgrad            if (j.eq.nres-1 .and. i.lt.j-2) then
3979 cgrad              do l=1,4
3980 cgrad                aggj1(k,l)=aggj1(k,l)+agg(k,l)
3981 cgrad              enddo
3982 cgrad            endif
3983           enddo
3984           acipa(1,1)=a22
3985           acipa(1,2)=a23
3986           acipa(2,1)=a32
3987           acipa(2,2)=a33
3988           a22=-a22
3989           a23=-a23
3990           do l=1,2
3991             do k=1,3
3992               agg(k,l)=-agg(k,l)
3993               aggi(k,l)=-aggi(k,l)
3994               aggi1(k,l)=-aggi1(k,l)
3995               aggj(k,l)=-aggj(k,l)
3996               aggj1(k,l)=-aggj1(k,l)
3997             enddo
3998           enddo
3999           if (j.lt.nres-1) then
4000             a22=-a22
4001             a32=-a32
4002             do l=1,3,2
4003               do k=1,3
4004                 agg(k,l)=-agg(k,l)
4005                 aggi(k,l)=-aggi(k,l)
4006                 aggi1(k,l)=-aggi1(k,l)
4007                 aggj(k,l)=-aggj(k,l)
4008                 aggj1(k,l)=-aggj1(k,l)
4009               enddo
4010             enddo
4011           else
4012             a22=-a22
4013             a23=-a23
4014             a32=-a32
4015             a33=-a33
4016             do l=1,4
4017               do k=1,3
4018                 agg(k,l)=-agg(k,l)
4019                 aggi(k,l)=-aggi(k,l)
4020                 aggi1(k,l)=-aggi1(k,l)
4021                 aggj(k,l)=-aggj(k,l)
4022                 aggj1(k,l)=-aggj1(k,l)
4023               enddo
4024             enddo
4025           endif
4026           ENDIF ! WCORR
4027           IF (wel_loc.gt.0.0d0) THEN
4028 C Contribution to the local-electrostatic energy coming from the i-j pair
4029           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3)
4030      &     +a33*muij(4)
4031 c          write (iout,*) 'i',i,' j',j,itype(i),itype(j),
4032 c     &                     ' eel_loc_ij',eel_loc_ij
4033 c          write(iout,*) 'muije=',muij(1),muij(2),muij(3),muij(4)
4034 C Calculate patrial derivative for theta angle
4035 #ifdef NEWCORR
4036          geel_loc_ij=a22*gmuij1(1)
4037      &     +a23*gmuij1(2)
4038      &     +a32*gmuij1(3)
4039      &     +a33*gmuij1(4)
4040 c         write(iout,*) "derivative over thatai"
4041 c         write(iout,*) a22*gmuij1(1), a23*gmuij1(2) ,a32*gmuij1(3),
4042 c     &   a33*gmuij1(4)
4043          gloc(nphi+i,icg)=gloc(nphi+i,icg)+
4044      &      geel_loc_ij*wel_loc
4045 c         write(iout,*) "derivative over thatai-1"
4046 c         write(iout,*) a22*gmuij2(1), a23*gmuij2(2) ,a32*gmuij2(3),
4047 c     &   a33*gmuij2(4)
4048          geel_loc_ij=
4049      &     a22*gmuij2(1)
4050      &     +a23*gmuij2(2)
4051      &     +a32*gmuij2(3)
4052      &     +a33*gmuij2(4)
4053          gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
4054      &      geel_loc_ij*wel_loc
4055 c  Derivative over j residue
4056          geel_loc_ji=a22*gmuji1(1)
4057      &     +a23*gmuji1(2)
4058      &     +a32*gmuji1(3)
4059      &     +a33*gmuji1(4)
4060 c         write(iout,*) "derivative over thataj"
4061 c         write(iout,*) a22*gmuji1(1), a23*gmuji1(2) ,a32*gmuji1(3),
4062 c     &   a33*gmuji1(4)
4063
4064         gloc(nphi+j,icg)=gloc(nphi+j,icg)+
4065      &      geel_loc_ji*wel_loc
4066          geel_loc_ji=
4067      &     +a22*gmuji2(1)
4068      &     +a23*gmuji2(2)
4069      &     +a32*gmuji2(3)
4070      &     +a33*gmuji2(4)
4071 c         write(iout,*) "derivative over thataj-1"
4072 c         write(iout,*) a22*gmuji2(1), a23*gmuji2(2) ,a32*gmuji2(3),
4073 c     &   a33*gmuji2(4)
4074          gloc(nphi+j-1,icg)=gloc(nphi+j-1,icg)+
4075      &      geel_loc_ji*wel_loc
4076 #endif
4077 cd          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
4078
4079           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
4080      &            'eelloc',i,j,eel_loc_ij
4081 c           if (eel_loc_ij.ne.0)
4082 c     &      write (iout,'(a4,2i4,8f9.5)')'chuj',
4083 c     &     i,j,a22,muij(1),a23,muij(2),a32,muij(3),a33,muij(4)
4084
4085           eel_loc=eel_loc+eel_loc_ij
4086 C Partial derivatives in virtual-bond dihedral angles gamma
4087           if (i.gt.1)
4088      &    gel_loc_loc(i-1)=gel_loc_loc(i-1)+
4089      &            a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j)
4090      &           +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j)
4091           gel_loc_loc(j-1)=gel_loc_loc(j-1)+
4092      &            a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j)
4093      &           +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j)
4094 C Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
4095           do l=1,3
4096             ggg(l)=agg(l,1)*muij(1)+
4097      &          agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4)
4098             gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l)
4099             gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l)
4100 cgrad            ghalf=0.5d0*ggg(l)
4101 cgrad            gel_loc(l,i)=gel_loc(l,i)+ghalf
4102 cgrad            gel_loc(l,j)=gel_loc(l,j)+ghalf
4103           enddo
4104 cgrad          do k=i+1,j2
4105 cgrad            do l=1,3
4106 cgrad              gel_loc(l,k)=gel_loc(l,k)+ggg(l)
4107 cgrad            enddo
4108 cgrad          enddo
4109 C Remaining derivatives of eello
4110           do l=1,3
4111             gel_loc(l,i)=gel_loc(l,i)+(aggi(l,1)*muij(1)+
4112      &        aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4))
4113             gel_loc(l,i+1)=gel_loc(l,i+1)+(aggi1(l,1)*muij(1)+
4114      &     aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4))
4115             gel_loc(l,j)=gel_loc(l,j)+(aggj(l,1)*muij(1)+
4116      &       aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4))
4117             gel_loc(l,j1)=gel_loc(l,j1)+(aggj1(l,1)*muij(1)+
4118      &     aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4))
4119           enddo
4120           ENDIF
4121 C Change 12/26/95 to calculate four-body contributions to H-bonding energy
4122 c          if (j.gt.i+1 .and. num_conti.le.maxconts) then
4123           if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0
4124      &       .and. num_conti.le.maxconts) then
4125 c            write (iout,*) i,j," entered corr"
4126 C
4127 C Calculate the contact function. The ith column of the array JCONT will
4128 C contain the numbers of atoms that make contacts with the atom I (of numbers
4129 C greater than I). The arrays FACONT and GACONT will contain the values of
4130 C the contact function and its derivative.
4131 c           r0ij=1.02D0*rpp(iteli,itelj)
4132 c           r0ij=1.11D0*rpp(iteli,itelj)
4133             r0ij=2.20D0*rpp(iteli,itelj)
4134 c           r0ij=1.55D0*rpp(iteli,itelj)
4135             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
4136             if (fcont.gt.0.0D0) then
4137               num_conti=num_conti+1
4138               if (num_conti.gt.maxconts) then
4139                 write (iout,*) 'WARNING - max. # of contacts exceeded;',
4140      &                         ' will skip next contacts for this conf.'
4141               else
4142                 jcont_hb(num_conti,i)=j
4143 cd                write (iout,*) "i",i," j",j," num_conti",num_conti,
4144 cd     &           " jcont_hb",jcont_hb(num_conti,i)
4145                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.
4146      &          wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
4147 C 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
4148 C  terms.
4149                 d_cont(num_conti,i)=rij
4150 cd                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
4151 C     --- Electrostatic-interaction matrix ---
4152                 a_chuj(1,1,num_conti,i)=a22
4153                 a_chuj(1,2,num_conti,i)=a23
4154                 a_chuj(2,1,num_conti,i)=a32
4155                 a_chuj(2,2,num_conti,i)=a33
4156 C     --- Gradient of rij
4157                 do kkk=1,3
4158                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
4159                 enddo
4160                 kkll=0
4161                 do k=1,2
4162                   do l=1,2
4163                     kkll=kkll+1
4164                     do m=1,3
4165                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
4166                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
4167                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
4168                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
4169                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
4170                     enddo
4171                   enddo
4172                 enddo
4173                 ENDIF
4174                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
4175 C Calculate contact energies
4176                 cosa4=4.0D0*cosa
4177                 wij=cosa-3.0D0*cosb*cosg
4178                 cosbg1=cosb+cosg
4179                 cosbg2=cosb-cosg
4180 c               fac3=dsqrt(-ael6i)/r0ij**3
4181                 fac3=dsqrt(-ael6i)*r3ij
4182 c                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
4183                 ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
4184                 if (ees0tmp.gt.0) then
4185                   ees0pij=dsqrt(ees0tmp)
4186                 else
4187                   ees0pij=0
4188                 endif
4189 c                ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
4190                 ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
4191                 if (ees0tmp.gt.0) then
4192                   ees0mij=dsqrt(ees0tmp)
4193                 else
4194                   ees0mij=0
4195                 endif
4196 c               ees0mij=0.0D0
4197                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij)
4198                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij)
4199 C Diagnostics. Comment out or remove after debugging!
4200 c               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
4201 c               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
4202 c               ees0m(num_conti,i)=0.0D0
4203 C End diagnostics.
4204 c               write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
4205 c    & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
4206 C Angular derivatives of the contact function
4207                 ees0pij1=fac3/ees0pij
4208                 ees0mij1=fac3/ees0mij
4209                 fac3p=-3.0D0*fac3*rrmij
4210                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
4211                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
4212 c               ees0mij1=0.0D0
4213                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
4214                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
4215                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
4216                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
4217                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
4218                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
4219                 ecosap=ecosa1+ecosa2
4220                 ecosbp=ecosb1+ecosb2
4221                 ecosgp=ecosg1+ecosg2
4222                 ecosam=ecosa1-ecosa2
4223                 ecosbm=ecosb1-ecosb2
4224                 ecosgm=ecosg1-ecosg2
4225 C Diagnostics
4226 c               ecosap=ecosa1
4227 c               ecosbp=ecosb1
4228 c               ecosgp=ecosg1
4229 c               ecosam=0.0D0
4230 c               ecosbm=0.0D0
4231 c               ecosgm=0.0D0
4232 C End diagnostics
4233                 facont_hb(num_conti,i)=fcont
4234                 fprimcont=fprimcont/rij
4235 cd              facont_hb(num_conti,i)=1.0D0
4236 C Following line is for diagnostics.
4237 cd              fprimcont=0.0D0
4238                 do k=1,3
4239                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
4240                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
4241                 enddo
4242                 do k=1,3
4243                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
4244                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
4245                 enddo
4246                 gggp(1)=gggp(1)+ees0pijp*xj
4247                 gggp(2)=gggp(2)+ees0pijp*yj
4248                 gggp(3)=gggp(3)+ees0pijp*zj
4249                 gggm(1)=gggm(1)+ees0mijp*xj
4250                 gggm(2)=gggm(2)+ees0mijp*yj
4251                 gggm(3)=gggm(3)+ees0mijp*zj
4252 C Derivatives due to the contact function
4253                 gacont_hbr(1,num_conti,i)=fprimcont*xj
4254                 gacont_hbr(2,num_conti,i)=fprimcont*yj
4255                 gacont_hbr(3,num_conti,i)=fprimcont*zj
4256                 do k=1,3
4257 c
4258 c 10/24/08 cgrad and ! comments indicate the parts of the code removed
4259 c          following the change of gradient-summation algorithm.
4260 c
4261 cgrad                  ghalfp=0.5D0*gggp(k)
4262 cgrad                  ghalfm=0.5D0*gggm(k)
4263                   gacontp_hb1(k,num_conti,i)=!ghalfp
4264      &              +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i))
4265      &              + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
4266                   gacontp_hb2(k,num_conti,i)=!ghalfp
4267      &              +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j))
4268      &              + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
4269                   gacontp_hb3(k,num_conti,i)=gggp(k)
4270                   gacontm_hb1(k,num_conti,i)=!ghalfm
4271      &              +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i))
4272      &              + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
4273                   gacontm_hb2(k,num_conti,i)=!ghalfm
4274      &              +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j))
4275      &              + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
4276                   gacontm_hb3(k,num_conti,i)=gggm(k)
4277                 enddo
4278 C Diagnostics. Comment out or remove after debugging!
4279 cdiag           do k=1,3
4280 cdiag             gacontp_hb1(k,num_conti,i)=0.0D0
4281 cdiag             gacontp_hb2(k,num_conti,i)=0.0D0
4282 cdiag             gacontp_hb3(k,num_conti,i)=0.0D0
4283 cdiag             gacontm_hb1(k,num_conti,i)=0.0D0
4284 cdiag             gacontm_hb2(k,num_conti,i)=0.0D0
4285 cdiag             gacontm_hb3(k,num_conti,i)=0.0D0
4286 cdiag           enddo
4287               ENDIF ! wcorr
4288               endif  ! num_conti.le.maxconts
4289             endif  ! fcont.gt.0
4290           endif    ! j.gt.i+1
4291           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
4292             do k=1,4
4293               do l=1,3
4294                 ghalf=0.5d0*agg(l,k)
4295                 aggi(l,k)=aggi(l,k)+ghalf
4296                 aggi1(l,k)=aggi1(l,k)+agg(l,k)
4297                 aggj(l,k)=aggj(l,k)+ghalf
4298               enddo
4299             enddo
4300             if (j.eq.nres-1 .and. i.lt.j-2) then
4301               do k=1,4
4302                 do l=1,3
4303                   aggj1(l,k)=aggj1(l,k)+agg(l,k)
4304                 enddo
4305               enddo
4306             endif
4307           endif
4308 c          t_eelecij=t_eelecij+MPI_Wtime()-time00
4309       return
4310       end
4311 C-----------------------------------------------------------------------------
4312       subroutine eturn3(i,eello_turn3)
4313 C Third- and fourth-order contributions from turns
4314       implicit real*8 (a-h,o-z)
4315       include 'DIMENSIONS'
4316       include 'COMMON.IOUNITS'
4317       include 'COMMON.GEO'
4318       include 'COMMON.VAR'
4319       include 'COMMON.LOCAL'
4320       include 'COMMON.CHAIN'
4321       include 'COMMON.DERIV'
4322       include 'COMMON.INTERACT'
4323       include 'COMMON.CONTACTS'
4324       include 'COMMON.TORSION'
4325       include 'COMMON.VECTORS'
4326       include 'COMMON.FFIELD'
4327       include 'COMMON.CONTROL'
4328       dimension ggg(3)
4329       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
4330      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
4331      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2),gpizda1(2,2),
4332      &  gpizda2(2,2),auxgmat1(2,2),auxgmatt1(2,2),
4333      &  auxgmat2(2,2),auxgmatt2(2,2)
4334       double precision agg(3,4),aggi(3,4),aggi1(3,4),
4335      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
4336       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
4337      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
4338      &    num_conti,j1,j2
4339       j=i+2
4340 c      write (iout,*) "eturn3",i,j,j1,j2
4341       a_temp(1,1)=a22
4342       a_temp(1,2)=a23
4343       a_temp(2,1)=a32
4344       a_temp(2,2)=a33
4345 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4346 C
4347 C               Third-order contributions
4348 C
4349 C                 (i+2)o----(i+3)
4350 C                      | |
4351 C                      | |
4352 C                 (i+1)o----i
4353 C
4354 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4355 cd        call checkint_turn3(i,a_temp,eello_turn3_num)
4356         call matmat2(EUg(1,1,i+1),EUg(1,1,i+2),auxmat(1,1))
4357 c auxalary matices for theta gradient
4358 c auxalary matrix for i+1 and constant i+2
4359         call matmat2(gtEUg(1,1,i+1),EUg(1,1,i+2),auxgmat1(1,1))
4360 c auxalary matrix for i+2 and constant i+1
4361         call matmat2(EUg(1,1,i+1),gtEUg(1,1,i+2),auxgmat2(1,1))
4362         call transpose2(auxmat(1,1),auxmat1(1,1))
4363         call transpose2(auxgmat1(1,1),auxgmatt1(1,1))
4364         call transpose2(auxgmat2(1,1),auxgmatt2(1,1))
4365         call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4366         call matmat2(a_temp(1,1),auxgmatt1(1,1),gpizda1(1,1))
4367         call matmat2(a_temp(1,1),auxgmatt2(1,1),gpizda2(1,1))
4368         eello_turn3=eello_turn3+0.5d0*(pizda(1,1)+pizda(2,2))
4369 C Derivatives in theta
4370         gloc(nphi+i,icg)=gloc(nphi+i,icg)
4371      &  +0.5d0*(gpizda1(1,1)+gpizda1(2,2))*wturn3
4372         gloc(nphi+i+1,icg)=gloc(nphi+i+1,icg)
4373      &  +0.5d0*(gpizda2(1,1)+gpizda2(2,2))*wturn3
4374
4375         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
4376      &          'eturn3',i,j,0.5d0*(pizda(1,1)+pizda(2,2))
4377 cd        write (2,*) 'i,',i,' j',j,'eello_turn3',
4378 cd     &    0.5d0*(pizda(1,1)+pizda(2,2)),
4379 cd     &    ' eello_turn3_num',4*eello_turn3_num
4380 C Derivatives in gamma(i)
4381         call matmat2(EUgder(1,1,i+1),EUg(1,1,i+2),auxmat2(1,1))
4382         call transpose2(auxmat2(1,1),auxmat3(1,1))
4383         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
4384         gel_loc_turn3(i)=gel_loc_turn3(i)+0.5d0*(pizda(1,1)+pizda(2,2))
4385 C Derivatives in gamma(i+1)
4386         call matmat2(EUg(1,1,i+1),EUgder(1,1,i+2),auxmat2(1,1))
4387         call transpose2(auxmat2(1,1),auxmat3(1,1))
4388         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
4389         gel_loc_turn3(i+1)=gel_loc_turn3(i+1)
4390      &    +0.5d0*(pizda(1,1)+pizda(2,2))
4391 C Cartesian derivatives
4392         do l=1,3
4393 c            ghalf1=0.5d0*agg(l,1)
4394 c            ghalf2=0.5d0*agg(l,2)
4395 c            ghalf3=0.5d0*agg(l,3)
4396 c            ghalf4=0.5d0*agg(l,4)
4397           a_temp(1,1)=aggi(l,1)!+ghalf1
4398           a_temp(1,2)=aggi(l,2)!+ghalf2
4399           a_temp(2,1)=aggi(l,3)!+ghalf3
4400           a_temp(2,2)=aggi(l,4)!+ghalf4
4401           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4402           gcorr3_turn(l,i)=gcorr3_turn(l,i)
4403      &      +0.5d0*(pizda(1,1)+pizda(2,2))
4404           a_temp(1,1)=aggi1(l,1)!+agg(l,1)
4405           a_temp(1,2)=aggi1(l,2)!+agg(l,2)
4406           a_temp(2,1)=aggi1(l,3)!+agg(l,3)
4407           a_temp(2,2)=aggi1(l,4)!+agg(l,4)
4408           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4409           gcorr3_turn(l,i+1)=gcorr3_turn(l,i+1)
4410      &      +0.5d0*(pizda(1,1)+pizda(2,2))
4411           a_temp(1,1)=aggj(l,1)!+ghalf1
4412           a_temp(1,2)=aggj(l,2)!+ghalf2
4413           a_temp(2,1)=aggj(l,3)!+ghalf3
4414           a_temp(2,2)=aggj(l,4)!+ghalf4
4415           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4416           gcorr3_turn(l,j)=gcorr3_turn(l,j)
4417      &      +0.5d0*(pizda(1,1)+pizda(2,2))
4418           a_temp(1,1)=aggj1(l,1)
4419           a_temp(1,2)=aggj1(l,2)
4420           a_temp(2,1)=aggj1(l,3)
4421           a_temp(2,2)=aggj1(l,4)
4422           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4423           gcorr3_turn(l,j1)=gcorr3_turn(l,j1)
4424      &      +0.5d0*(pizda(1,1)+pizda(2,2))
4425         enddo
4426       return
4427       end
4428 C-------------------------------------------------------------------------------
4429       subroutine eturn4(i,eello_turn4)
4430 C Third- and fourth-order contributions from turns
4431       implicit real*8 (a-h,o-z)
4432       include 'DIMENSIONS'
4433       include 'COMMON.IOUNITS'
4434       include 'COMMON.GEO'
4435       include 'COMMON.VAR'
4436       include 'COMMON.LOCAL'
4437       include 'COMMON.CHAIN'
4438       include 'COMMON.DERIV'
4439       include 'COMMON.INTERACT'
4440       include 'COMMON.CONTACTS'
4441       include 'COMMON.TORSION'
4442       include 'COMMON.VECTORS'
4443       include 'COMMON.FFIELD'
4444       include 'COMMON.CONTROL'
4445       dimension ggg(3)
4446       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
4447      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
4448      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2),auxgvec(2),
4449      &  auxgEvec1(2),auxgEvec2(2),auxgEvec3(2),
4450      &  gte1t(2,2),gte2t(2,2),gte3t(2,2),
4451      &  gte1a(2,2),gtae3(2,2),gtae3e2(2,2), ae3gte2(2,2),
4452      &  gtEpizda1(2,2),gtEpizda2(2,2),gtEpizda3(2,2)
4453       double precision agg(3,4),aggi(3,4),aggi1(3,4),
4454      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
4455       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
4456      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
4457      &    num_conti,j1,j2
4458       j=i+3
4459 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4460 C
4461 C               Fourth-order contributions
4462 C
4463 C                 (i+3)o----(i+4)
4464 C                     /  |
4465 C               (i+2)o   |
4466 C                     \  |
4467 C                 (i+1)o----i
4468 C
4469 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4470 cd        call checkint_turn4(i,a_temp,eello_turn4_num)
4471 c        write (iout,*) "eturn4 i",i," j",j," j1",j1," j2",j2
4472 c        write(iout,*)"WCHODZE W PROGRAM"
4473         a_temp(1,1)=a22
4474         a_temp(1,2)=a23
4475         a_temp(2,1)=a32
4476         a_temp(2,2)=a33
4477         iti1=itortyp(itype(i+1))
4478         iti2=itortyp(itype(i+2))
4479         iti3=itortyp(itype(i+3))
4480 c        write(iout,*) "iti1",iti1," iti2",iti2," iti3",iti3
4481         call transpose2(EUg(1,1,i+1),e1t(1,1))
4482         call transpose2(Eug(1,1,i+2),e2t(1,1))
4483         call transpose2(Eug(1,1,i+3),e3t(1,1))
4484 C Ematrix derivative in theta
4485         call transpose2(gtEUg(1,1,i+1),gte1t(1,1))
4486         call transpose2(gtEug(1,1,i+2),gte2t(1,1))
4487         call transpose2(gtEug(1,1,i+3),gte3t(1,1))
4488         call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4489 c       eta1 in derivative theta
4490         call matmat2(gte1t(1,1),a_temp(1,1),gte1a(1,1))
4491         call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4492 c       auxgvec is derivative of Ub2 so i+3 theta
4493         call matvec2(e1a(1,1),gUb2(1,i+3),auxgvec(1))
4494 c       auxalary matrix of E i+1
4495         call matvec2(gte1a(1,1),Ub2(1,i+3),auxgEvec1(1))
4496 c        s1=0.0
4497 c        gs1=0.0
4498         s1=scalar2(b1(1,i+2),auxvec(1))
4499 c derivative of theta i+2 with constant i+3
4500         gs23=scalar2(gtb1(1,i+2),auxvec(1))
4501 c derivative of theta i+2 with constant i+2
4502         gs32=scalar2(b1(1,i+2),auxgvec(1))
4503 c derivative of E matix in theta of i+1
4504         gsE13=scalar2(b1(1,i+2),auxgEvec1(1))
4505
4506         call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4507 c       ea31 in derivative theta
4508         call matmat2(a_temp(1,1),gte3t(1,1),gtae3(1,1))
4509         call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4510 c auxilary matrix auxgvec of Ub2 with constant E matirx
4511         call matvec2(ae3(1,1),gUb2(1,i+2),auxgvec(1))
4512 c auxilary matrix auxgEvec1 of E matix with Ub2 constant
4513         call matvec2(gtae3(1,1),Ub2(1,i+2),auxgEvec3(1))
4514
4515 c        s2=0.0
4516 c        gs2=0.0
4517         s2=scalar2(b1(1,i+1),auxvec(1))
4518 c derivative of theta i+1 with constant i+3
4519         gs13=scalar2(gtb1(1,i+1),auxvec(1))
4520 c derivative of theta i+2 with constant i+1
4521         gs21=scalar2(b1(1,i+1),auxgvec(1))
4522 c derivative of theta i+3 with constant i+1
4523         gsE31=scalar2(b1(1,i+1),auxgEvec3(1))
4524 c        write(iout,*) gs1,gs2,'i=',i,auxgvec(1),gUb2(1,i+2),gtb1(1,i+2),
4525 c     &  gtb1(1,i+1)
4526         call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4527 c two derivatives over diffetent matrices
4528 c gtae3e2 is derivative over i+3
4529         call matmat2(gtae3(1,1),e2t(1,1),gtae3e2(1,1))
4530 c ae3gte2 is derivative over i+2
4531         call matmat2(ae3(1,1),gte2t(1,1),ae3gte2(1,1))
4532         call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4533 c three possible derivative over theta E matices
4534 c i+1
4535         call matmat2(ae3e2(1,1),gte1t(1,1),gtEpizda1(1,1))
4536 c i+2
4537         call matmat2(ae3gte2(1,1),e1t(1,1),gtEpizda2(1,1))
4538 c i+3
4539         call matmat2(gtae3e2(1,1),e1t(1,1),gtEpizda3(1,1))
4540         s3=0.5d0*(pizda(1,1)+pizda(2,2))
4541
4542         gsEE1=0.5d0*(gtEpizda1(1,1)+gtEpizda1(2,2))
4543         gsEE2=0.5d0*(gtEpizda2(1,1)+gtEpizda2(2,2))
4544         gsEE3=0.5d0*(gtEpizda3(1,1)+gtEpizda3(2,2))
4545
4546         eello_turn4=eello_turn4-(s1+s2+s3)
4547 c             write(iout,*)'chujOWO', auxvec(1),b1(1,iti2)
4548         if (energy_dec) write (iout,'(a6,2i5,0pf7.3,3f7.3)')
4549      &      'eturn4',i,j,-(s1+s2+s3),s1,s2,s3
4550 cd        write (2,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
4551 cd     &    ' eello_turn4_num',8*eello_turn4_num
4552 #ifdef NEWCORR
4553         gloc(nphi+i,icg)=gloc(nphi+i,icg)
4554      &                  -(gs13+gsE13+gsEE1)*wturn4
4555         gloc(nphi+i+1,icg)= gloc(nphi+i+1,icg)
4556      &                    -(gs23+gs21+gsEE2)*wturn4
4557         gloc(nphi+i+2,icg)= gloc(nphi+i+2,icg)
4558      &                    -(gs32+gsE31+gsEE3)*wturn4
4559 c         gloc(nphi+i+1,icg)=gloc(nphi+i+1,icg)-
4560 c     &   gs2
4561 #endif
4562         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
4563      &      'eturn4',i,j,-(s1+s2+s3)
4564 c        write (iout,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
4565 c     &    ' eello_turn4_num',8*eello_turn4_num
4566 C Derivatives in gamma(i)
4567         call transpose2(EUgder(1,1,i+1),e1tder(1,1))
4568         call matmat2(e1tder(1,1),a_temp(1,1),auxmat(1,1))
4569         call matvec2(auxmat(1,1),Ub2(1,i+3),auxvec(1))
4570         s1=scalar2(b1(1,i+2),auxvec(1))
4571         call matmat2(ae3e2(1,1),e1tder(1,1),pizda(1,1))
4572         s3=0.5d0*(pizda(1,1)+pizda(2,2))
4573         gel_loc_turn4(i)=gel_loc_turn4(i)-(s1+s3)
4574 C Derivatives in gamma(i+1)
4575         call transpose2(EUgder(1,1,i+2),e2tder(1,1))
4576         call matvec2(ae3(1,1),Ub2der(1,i+2),auxvec(1))
4577         s2=scalar2(b1(1,i+1),auxvec(1))
4578         call matmat2(ae3(1,1),e2tder(1,1),auxmat(1,1))
4579         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
4580         s3=0.5d0*(pizda(1,1)+pizda(2,2))
4581         gel_loc_turn4(i+1)=gel_loc_turn4(i+1)-(s2+s3)
4582 C Derivatives in gamma(i+2)
4583         call transpose2(EUgder(1,1,i+3),e3tder(1,1))
4584         call matvec2(e1a(1,1),Ub2der(1,i+3),auxvec(1))
4585         s1=scalar2(b1(1,i+2),auxvec(1))
4586         call matmat2(a_temp(1,1),e3tder(1,1),auxmat(1,1))
4587         call matvec2(auxmat(1,1),Ub2(1,i+2),auxvec(1))
4588         s2=scalar2(b1(1,i+1),auxvec(1))
4589         call matmat2(auxmat(1,1),e2t(1,1),auxmat3(1,1))
4590         call matmat2(auxmat3(1,1),e1t(1,1),pizda(1,1))
4591         s3=0.5d0*(pizda(1,1)+pizda(2,2))
4592         gel_loc_turn4(i+2)=gel_loc_turn4(i+2)-(s1+s2+s3)
4593 C Cartesian derivatives
4594 C Derivatives of this turn contributions in DC(i+2)
4595         if (j.lt.nres-1) then
4596           do l=1,3
4597             a_temp(1,1)=agg(l,1)
4598             a_temp(1,2)=agg(l,2)
4599             a_temp(2,1)=agg(l,3)
4600             a_temp(2,2)=agg(l,4)
4601             call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4602             call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4603             s1=scalar2(b1(1,i+2),auxvec(1))
4604             call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4605             call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4606             s2=scalar2(b1(1,i+1),auxvec(1))
4607             call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4608             call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4609             s3=0.5d0*(pizda(1,1)+pizda(2,2))
4610             ggg(l)=-(s1+s2+s3)
4611             gcorr4_turn(l,i+2)=gcorr4_turn(l,i+2)-(s1+s2+s3)
4612           enddo
4613         endif
4614 C Remaining derivatives of this turn contribution
4615         do l=1,3
4616           a_temp(1,1)=aggi(l,1)
4617           a_temp(1,2)=aggi(l,2)
4618           a_temp(2,1)=aggi(l,3)
4619           a_temp(2,2)=aggi(l,4)
4620           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4621           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4622           s1=scalar2(b1(1,i+2),auxvec(1))
4623           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4624           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4625           s2=scalar2(b1(1,i+1),auxvec(1))
4626           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4627           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4628           s3=0.5d0*(pizda(1,1)+pizda(2,2))
4629           gcorr4_turn(l,i)=gcorr4_turn(l,i)-(s1+s2+s3)
4630           a_temp(1,1)=aggi1(l,1)
4631           a_temp(1,2)=aggi1(l,2)
4632           a_temp(2,1)=aggi1(l,3)
4633           a_temp(2,2)=aggi1(l,4)
4634           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4635           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4636           s1=scalar2(b1(1,i+2),auxvec(1))
4637           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4638           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4639           s2=scalar2(b1(1,i+1),auxvec(1))
4640           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4641           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4642           s3=0.5d0*(pizda(1,1)+pizda(2,2))
4643           gcorr4_turn(l,i+1)=gcorr4_turn(l,i+1)-(s1+s2+s3)
4644           a_temp(1,1)=aggj(l,1)
4645           a_temp(1,2)=aggj(l,2)
4646           a_temp(2,1)=aggj(l,3)
4647           a_temp(2,2)=aggj(l,4)
4648           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4649           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4650           s1=scalar2(b1(1,i+2),auxvec(1))
4651           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4652           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4653           s2=scalar2(b1(1,i+1),auxvec(1))
4654           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4655           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4656           s3=0.5d0*(pizda(1,1)+pizda(2,2))
4657           gcorr4_turn(l,j)=gcorr4_turn(l,j)-(s1+s2+s3)
4658           a_temp(1,1)=aggj1(l,1)
4659           a_temp(1,2)=aggj1(l,2)
4660           a_temp(2,1)=aggj1(l,3)
4661           a_temp(2,2)=aggj1(l,4)
4662           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4663           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4664           s1=scalar2(b1(1,i+2),auxvec(1))
4665           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4666           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4667           s2=scalar2(b1(1,i+1),auxvec(1))
4668           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4669           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4670           s3=0.5d0*(pizda(1,1)+pizda(2,2))
4671 c          write (iout,*) "s1",s1," s2",s2," s3",s3," s1+s2+s3",s1+s2+s3
4672           gcorr4_turn(l,j1)=gcorr4_turn(l,j1)-(s1+s2+s3)
4673         enddo
4674       return
4675       end
4676 C-----------------------------------------------------------------------------
4677       subroutine vecpr(u,v,w)
4678       implicit real*8(a-h,o-z)
4679       dimension u(3),v(3),w(3)
4680       w(1)=u(2)*v(3)-u(3)*v(2)
4681       w(2)=-u(1)*v(3)+u(3)*v(1)
4682       w(3)=u(1)*v(2)-u(2)*v(1)
4683       return
4684       end
4685 C-----------------------------------------------------------------------------
4686       subroutine unormderiv(u,ugrad,unorm,ungrad)
4687 C This subroutine computes the derivatives of a normalized vector u, given
4688 C the derivatives computed without normalization conditions, ugrad. Returns
4689 C ungrad.
4690       implicit none
4691       double precision u(3),ugrad(3,3),unorm,ungrad(3,3)
4692       double precision vec(3)
4693       double precision scalar
4694       integer i,j
4695 c      write (2,*) 'ugrad',ugrad
4696 c      write (2,*) 'u',u
4697       do i=1,3
4698         vec(i)=scalar(ugrad(1,i),u(1))
4699       enddo
4700 c      write (2,*) 'vec',vec
4701       do i=1,3
4702         do j=1,3
4703           ungrad(j,i)=(ugrad(j,i)-u(j)*vec(i))*unorm
4704         enddo
4705       enddo
4706 c      write (2,*) 'ungrad',ungrad
4707       return
4708       end
4709 C-----------------------------------------------------------------------------
4710       subroutine escp_soft_sphere(evdw2,evdw2_14)
4711 C
4712 C This subroutine calculates the excluded-volume interaction energy between
4713 C peptide-group centers and side chains and its gradient in virtual-bond and
4714 C side-chain vectors.
4715 C
4716       implicit real*8 (a-h,o-z)
4717       include 'DIMENSIONS'
4718       include 'COMMON.GEO'
4719       include 'COMMON.VAR'
4720       include 'COMMON.LOCAL'
4721       include 'COMMON.CHAIN'
4722       include 'COMMON.DERIV'
4723       include 'COMMON.INTERACT'
4724       include 'COMMON.FFIELD'
4725       include 'COMMON.IOUNITS'
4726       include 'COMMON.CONTROL'
4727       dimension ggg(3)
4728       evdw2=0.0D0
4729       evdw2_14=0.0d0
4730       r0_scp=4.5d0
4731 cd    print '(a)','Enter ESCP'
4732 cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
4733 C      do xshift=-1,1
4734 C      do yshift=-1,1
4735 C      do zshift=-1,1
4736       do i=iatscp_s,iatscp_e
4737         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
4738         iteli=itel(i)
4739         xi=0.5D0*(c(1,i)+c(1,i+1))
4740         yi=0.5D0*(c(2,i)+c(2,i+1))
4741         zi=0.5D0*(c(3,i)+c(3,i+1))
4742 C Return atom into box, boxxsize is size of box in x dimension
4743 c  134   continue
4744 c        if (xi.gt.((xshift+0.5d0)*boxxsize)) xi=xi-boxxsize
4745 c        if (xi.lt.((xshift-0.5d0)*boxxsize)) xi=xi+boxxsize
4746 C Condition for being inside the proper box
4747 c        if ((xi.gt.((xshift+0.5d0)*boxxsize)).or.
4748 c     &       (xi.lt.((xshift-0.5d0)*boxxsize))) then
4749 c        go to 134
4750 c        endif
4751 c  135   continue
4752 c        if (yi.gt.((yshift+0.5d0)*boxysize)) yi=yi-boxysize
4753 c        if (yi.lt.((yshift-0.5d0)*boxysize)) yi=yi+boxysize
4754 C Condition for being inside the proper box
4755 c        if ((yi.gt.((yshift+0.5d0)*boxysize)).or.
4756 c     &       (yi.lt.((yshift-0.5d0)*boxysize))) then
4757 c        go to 135
4758 c c       endif
4759 c  136   continue
4760 c        if (zi.gt.((zshift+0.5d0)*boxzsize)) zi=zi-boxzsize
4761 c        if (zi.lt.((zshift-0.5d0)*boxzsize)) zi=zi+boxzsize
4762 cC Condition for being inside the proper box
4763 c        if ((zi.gt.((zshift+0.5d0)*boxzsize)).or.
4764 c     &       (zi.lt.((zshift-0.5d0)*boxzsize))) then
4765 c        go to 136
4766 c        endif
4767           xi=mod(xi,boxxsize)
4768           if (xi.lt.0) xi=xi+boxxsize
4769           yi=mod(yi,boxysize)
4770           if (yi.lt.0) yi=yi+boxysize
4771           zi=mod(zi,boxzsize)
4772           if (zi.lt.0) zi=zi+boxzsize
4773 C          xi=xi+xshift*boxxsize
4774 C          yi=yi+yshift*boxysize
4775 C          zi=zi+zshift*boxzsize
4776         do iint=1,nscp_gr(i)
4777
4778         do j=iscpstart(i,iint),iscpend(i,iint)
4779           if (itype(j).eq.ntyp1) cycle
4780           itypj=iabs(itype(j))
4781 C Uncomment following three lines for SC-p interactions
4782 c         xj=c(1,nres+j)-xi
4783 c         yj=c(2,nres+j)-yi
4784 c         zj=c(3,nres+j)-zi
4785 C Uncomment following three lines for Ca-p interactions
4786           xj=c(1,j)
4787           yj=c(2,j)
4788           zj=c(3,j)
4789 c  174   continue
4790 c        if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
4791 c        if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
4792 C Condition for being inside the proper box
4793 c        if ((xj.gt.((0.5d0)*boxxsize)).or.
4794 c     &       (xj.lt.((-0.5d0)*boxxsize))) then
4795 c        go to 174
4796 c        endif
4797 c  175   continue
4798 c        if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
4799 c        if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
4800 cC Condition for being inside the proper box
4801 c        if ((yj.gt.((0.5d0)*boxysize)).or.
4802 c     &       (yj.lt.((-0.5d0)*boxysize))) then
4803 c        go to 175
4804 c        endif
4805 c  176   continue
4806 c        if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
4807 c        if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
4808 C Condition for being inside the proper box
4809 c        if ((zj.gt.((0.5d0)*boxzsize)).or.
4810 c     &       (zj.lt.((-0.5d0)*boxzsize))) then
4811 c        go to 176
4812           xj=mod(xj,boxxsize)
4813           if (xj.lt.0) xj=xj+boxxsize
4814           yj=mod(yj,boxysize)
4815           if (yj.lt.0) yj=yj+boxysize
4816           zj=mod(zj,boxzsize)
4817           if (zj.lt.0) zj=zj+boxzsize
4818       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
4819       xj_safe=xj
4820       yj_safe=yj
4821       zj_safe=zj
4822       subchap=0
4823       do xshift=-1,1
4824       do yshift=-1,1
4825       do zshift=-1,1
4826           xj=xj_safe+xshift*boxxsize
4827           yj=yj_safe+yshift*boxysize
4828           zj=zj_safe+zshift*boxzsize
4829           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
4830           if(dist_temp.lt.dist_init) then
4831             dist_init=dist_temp
4832             xj_temp=xj
4833             yj_temp=yj
4834             zj_temp=zj
4835             subchap=1
4836           endif
4837        enddo
4838        enddo
4839        enddo
4840        if (subchap.eq.1) then
4841           xj=xj_temp-xi
4842           yj=yj_temp-yi
4843           zj=zj_temp-zi
4844        else
4845           xj=xj_safe-xi
4846           yj=yj_safe-yi
4847           zj=zj_safe-zi
4848        endif
4849 c c       endif
4850 C          xj=xj-xi
4851 C          yj=yj-yi
4852 C          zj=zj-zi
4853           rij=xj*xj+yj*yj+zj*zj
4854
4855           r0ij=r0_scp
4856           r0ijsq=r0ij*r0ij
4857           if (rij.lt.r0ijsq) then
4858             evdwij=0.25d0*(rij-r0ijsq)**2
4859             fac=rij-r0ijsq
4860           else
4861             evdwij=0.0d0
4862             fac=0.0d0
4863           endif
4864           evdw2=evdw2+evdwij
4865 C
4866 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
4867 C
4868           ggg(1)=xj*fac
4869           ggg(2)=yj*fac
4870           ggg(3)=zj*fac
4871 cgrad          if (j.lt.i) then
4872 cd          write (iout,*) 'j<i'
4873 C Uncomment following three lines for SC-p interactions
4874 c           do k=1,3
4875 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
4876 c           enddo
4877 cgrad          else
4878 cd          write (iout,*) 'j>i'
4879 cgrad            do k=1,3
4880 cgrad              ggg(k)=-ggg(k)
4881 C Uncomment following line for SC-p interactions
4882 c             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
4883 cgrad            enddo
4884 cgrad          endif
4885 cgrad          do k=1,3
4886 cgrad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
4887 cgrad          enddo
4888 cgrad          kstart=min0(i+1,j)
4889 cgrad          kend=max0(i-1,j-1)
4890 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
4891 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
4892 cgrad          do k=kstart,kend
4893 cgrad            do l=1,3
4894 cgrad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
4895 cgrad            enddo
4896 cgrad          enddo
4897           do k=1,3
4898             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
4899             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
4900           enddo
4901         enddo
4902
4903         enddo ! iint
4904       enddo ! i
4905 C      enddo !zshift
4906 C      enddo !yshift
4907 C      enddo !xshift
4908       return
4909       end
4910 C-----------------------------------------------------------------------------
4911       subroutine escp(evdw2,evdw2_14)
4912 C
4913 C This subroutine calculates the excluded-volume interaction energy between
4914 C peptide-group centers and side chains and its gradient in virtual-bond and
4915 C side-chain vectors.
4916 C
4917       implicit real*8 (a-h,o-z)
4918       include 'DIMENSIONS'
4919       include 'COMMON.GEO'
4920       include 'COMMON.VAR'
4921       include 'COMMON.LOCAL'
4922       include 'COMMON.CHAIN'
4923       include 'COMMON.DERIV'
4924       include 'COMMON.INTERACT'
4925       include 'COMMON.FFIELD'
4926       include 'COMMON.IOUNITS'
4927       include 'COMMON.CONTROL'
4928       include 'COMMON.SPLITELE'
4929       dimension ggg(3)
4930       evdw2=0.0D0
4931       evdw2_14=0.0d0
4932 c        print *,boxxsize,boxysize,boxzsize,'wymiary pudla'
4933 cd    print '(a)','Enter ESCP'
4934 cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
4935 C      do xshift=-1,1
4936 C      do yshift=-1,1
4937 C      do zshift=-1,1
4938       do i=iatscp_s,iatscp_e
4939         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
4940         iteli=itel(i)
4941         xi=0.5D0*(c(1,i)+c(1,i+1))
4942         yi=0.5D0*(c(2,i)+c(2,i+1))
4943         zi=0.5D0*(c(3,i)+c(3,i+1))
4944           xi=mod(xi,boxxsize)
4945           if (xi.lt.0) xi=xi+boxxsize
4946           yi=mod(yi,boxysize)
4947           if (yi.lt.0) yi=yi+boxysize
4948           zi=mod(zi,boxzsize)
4949           if (zi.lt.0) zi=zi+boxzsize
4950 c          xi=xi+xshift*boxxsize
4951 c          yi=yi+yshift*boxysize
4952 c          zi=zi+zshift*boxzsize
4953 c        print *,xi,yi,zi,'polozenie i'
4954 C Return atom into box, boxxsize is size of box in x dimension
4955 c  134   continue
4956 c        if (xi.gt.((xshift+0.5d0)*boxxsize)) xi=xi-boxxsize
4957 c        if (xi.lt.((xshift-0.5d0)*boxxsize)) xi=xi+boxxsize
4958 C Condition for being inside the proper box
4959 c        if ((xi.gt.((xshift+0.5d0)*boxxsize)).or.
4960 c     &       (xi.lt.((xshift-0.5d0)*boxxsize))) then
4961 c        go to 134
4962 c        endif
4963 c  135   continue
4964 c          print *,xi,boxxsize,"pierwszy"
4965
4966 c        if (yi.gt.((yshift+0.5d0)*boxysize)) yi=yi-boxysize
4967 c        if (yi.lt.((yshift-0.5d0)*boxysize)) yi=yi+boxysize
4968 C Condition for being inside the proper box
4969 c        if ((yi.gt.((yshift+0.5d0)*boxysize)).or.
4970 c     &       (yi.lt.((yshift-0.5d0)*boxysize))) then
4971 c        go to 135
4972 c        endif
4973 c  136   continue
4974 c        if (zi.gt.((zshift+0.5d0)*boxzsize)) zi=zi-boxzsize
4975 c        if (zi.lt.((zshift-0.5d0)*boxzsize)) zi=zi+boxzsize
4976 C Condition for being inside the proper box
4977 c        if ((zi.gt.((zshift+0.5d0)*boxzsize)).or.
4978 c     &       (zi.lt.((zshift-0.5d0)*boxzsize))) then
4979 c        go to 136
4980 c        endif
4981         do iint=1,nscp_gr(i)
4982
4983         do j=iscpstart(i,iint),iscpend(i,iint)
4984           itypj=iabs(itype(j))
4985           if (itypj.eq.ntyp1) cycle
4986 C Uncomment following three lines for SC-p interactions
4987 c         xj=c(1,nres+j)-xi
4988 c         yj=c(2,nres+j)-yi
4989 c         zj=c(3,nres+j)-zi
4990 C Uncomment following three lines for Ca-p interactions
4991           xj=c(1,j)
4992           yj=c(2,j)
4993           zj=c(3,j)
4994           xj=mod(xj,boxxsize)
4995           if (xj.lt.0) xj=xj+boxxsize
4996           yj=mod(yj,boxysize)
4997           if (yj.lt.0) yj=yj+boxysize
4998           zj=mod(zj,boxzsize)
4999           if (zj.lt.0) zj=zj+boxzsize
5000 c  174   continue
5001 c        if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
5002 c        if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
5003 C Condition for being inside the proper box
5004 c        if ((xj.gt.((0.5d0)*boxxsize)).or.
5005 c     &       (xj.lt.((-0.5d0)*boxxsize))) then
5006 c        go to 174
5007 c        endif
5008 c  175   continue
5009 c        if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
5010 c        if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
5011 cC Condition for being inside the proper box
5012 c        if ((yj.gt.((0.5d0)*boxysize)).or.
5013 c     &       (yj.lt.((-0.5d0)*boxysize))) then
5014 c        go to 175
5015 c        endif
5016 c  176   continue
5017 c        if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
5018 c        if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
5019 C Condition for being inside the proper box
5020 c        if ((zj.gt.((0.5d0)*boxzsize)).or.
5021 c     &       (zj.lt.((-0.5d0)*boxzsize))) then
5022 c        go to 176
5023 c        endif
5024 CHERE IS THE CALCULATION WHICH MIRROR IMAGE IS THE CLOSEST ONE
5025       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
5026       xj_safe=xj
5027       yj_safe=yj
5028       zj_safe=zj
5029       subchap=0
5030       do xshift=-1,1
5031       do yshift=-1,1
5032       do zshift=-1,1
5033           xj=xj_safe+xshift*boxxsize
5034           yj=yj_safe+yshift*boxysize
5035           zj=zj_safe+zshift*boxzsize
5036           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
5037           if(dist_temp.lt.dist_init) then
5038             dist_init=dist_temp
5039             xj_temp=xj
5040             yj_temp=yj
5041             zj_temp=zj
5042             subchap=1
5043           endif
5044        enddo
5045        enddo
5046        enddo
5047        if (subchap.eq.1) then
5048           xj=xj_temp-xi
5049           yj=yj_temp-yi
5050           zj=zj_temp-zi
5051        else
5052           xj=xj_safe-xi
5053           yj=yj_safe-yi
5054           zj=zj_safe-zi
5055        endif
5056 c          print *,xj,yj,zj,'polozenie j'
5057           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
5058 c          print *,rrij
5059           sss=sscale(1.0d0/(dsqrt(rrij)))
5060 c          print *,r_cut,1.0d0/dsqrt(rrij),sss,'tu patrz'
5061 c          if (sss.eq.0) print *,'czasem jest OK'
5062           if (sss.le.0.0d0) cycle
5063           sssgrad=sscagrad(1.0d0/(dsqrt(rrij)))
5064           fac=rrij**expon2
5065           e1=fac*fac*aad(itypj,iteli)
5066           e2=fac*bad(itypj,iteli)
5067           if (iabs(j-i) .le. 2) then
5068             e1=scal14*e1
5069             e2=scal14*e2
5070             evdw2_14=evdw2_14+(e1+e2)*sss
5071           endif
5072           evdwij=e1+e2
5073           evdw2=evdw2+evdwij*sss
5074           if (energy_dec) write (iout,'(a6,2i5,0pf7.3,2i3,3e11.3)')
5075      &        'evdw2',i,j,evdwij,iteli,itypj,fac,aad(itypj,iteli),
5076      &       bad(itypj,iteli)
5077 C
5078 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
5079 C
5080           fac=-(evdwij+e1)*rrij*sss
5081           fac=fac+(evdwij)*sssgrad*dsqrt(rrij)/expon
5082           ggg(1)=xj*fac
5083           ggg(2)=yj*fac
5084           ggg(3)=zj*fac
5085 cgrad          if (j.lt.i) then
5086 cd          write (iout,*) 'j<i'
5087 C Uncomment following three lines for SC-p interactions
5088 c           do k=1,3
5089 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
5090 c           enddo
5091 cgrad          else
5092 cd          write (iout,*) 'j>i'
5093 cgrad            do k=1,3
5094 cgrad              ggg(k)=-ggg(k)
5095 C Uncomment following line for SC-p interactions
5096 ccgrad             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
5097 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
5098 cgrad            enddo
5099 cgrad          endif
5100 cgrad          do k=1,3
5101 cgrad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
5102 cgrad          enddo
5103 cgrad          kstart=min0(i+1,j)
5104 cgrad          kend=max0(i-1,j-1)
5105 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
5106 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
5107 cgrad          do k=kstart,kend
5108 cgrad            do l=1,3
5109 cgrad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
5110 cgrad            enddo
5111 cgrad          enddo
5112           do k=1,3
5113             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
5114             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
5115           enddo
5116 c        endif !endif for sscale cutoff
5117         enddo ! j
5118
5119         enddo ! iint
5120       enddo ! i
5121 c      enddo !zshift
5122 c      enddo !yshift
5123 c      enddo !xshift
5124       do i=1,nct
5125         do j=1,3
5126           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
5127           gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
5128           gradx_scp(j,i)=expon*gradx_scp(j,i)
5129         enddo
5130       enddo
5131 C******************************************************************************
5132 C
5133 C                              N O T E !!!
5134 C
5135 C To save time the factor EXPON has been extracted from ALL components
5136 C of GVDWC and GRADX. Remember to multiply them by this factor before further
5137 C use!
5138 C
5139 C******************************************************************************
5140       return
5141       end
5142 C--------------------------------------------------------------------------
5143       subroutine edis(ehpb)
5144 C
5145 C Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors.
5146 C
5147       implicit real*8 (a-h,o-z)
5148       include 'DIMENSIONS'
5149       include 'COMMON.SBRIDGE'
5150       include 'COMMON.CHAIN'
5151       include 'COMMON.DERIV'
5152       include 'COMMON.VAR'
5153       include 'COMMON.INTERACT'
5154       include 'COMMON.IOUNITS'
5155       include 'COMMON.CONTROL'
5156       dimension ggg(3)
5157       ehpb=0.0D0
5158       do i=1,3
5159        ggg(i)=0.0d0
5160       enddo
5161 C      write (iout,*) ,"link_end",link_end,constr_dist
5162 cd      write(iout,*)'edis: nhpb=',nhpb,' fbr=',fbr
5163 cd      write(iout,*)'link_start=',link_start,' link_end=',link_end
5164       if (link_end.eq.0) return
5165       do i=link_start,link_end
5166 C If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a
5167 C CA-CA distance used in regularization of structure.
5168         ii=ihpb(i)
5169         jj=jhpb(i)
5170 C iii and jjj point to the residues for which the distance is assigned.
5171         if (ii.gt.nres) then
5172           iii=ii-nres
5173           jjj=jj-nres
5174         else
5175           iii=ii
5176           jjj=jj
5177         endif
5178 c        write (iout,*) "i",i," ii",ii," iii",iii," jj",jj," jjj",jjj,
5179 c     &    dhpb(i),dhpb1(i),forcon(i)
5180 C 24/11/03 AL: SS bridges handled separately because of introducing a specific
5181 C    distance and angle dependent SS bond potential.
5182 C        if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and.
5183 C     & iabs(itype(jjj)).eq.1) then
5184 cmc        if (ii.gt.nres .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then
5185 C 18/07/06 MC: Use the convention that the first nss pairs are SS bonds
5186         if (.not.dyn_ss .and. i.le.nss) then
5187 C 15/02/13 CC dynamic SSbond - additional check
5188          if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and.
5189      & iabs(itype(jjj)).eq.1) then
5190           call ssbond_ene(iii,jjj,eij)
5191           ehpb=ehpb+2*eij
5192          endif
5193 cd          write (iout,*) "eij",eij
5194 cd   &   ' waga=',waga,' fac=',fac
5195         else if (ii.gt.nres .and. jj.gt.nres) then
5196 c Restraints from contact prediction
5197           dd=dist(ii,jj)
5198           if (constr_dist.eq.11) then
5199             ehpb=ehpb+fordepth(i)**4.0d0
5200      &          *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i))
5201             fac=fordepth(i)**4.0d0
5202      &          *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd
5203           if (energy_dec) write (iout,'(a6,2i5,3f8.3)') "edisl",ii,jj,
5204      &    ehpb,fordepth(i),dd
5205            else
5206           if (dhpb1(i).gt.0.0d0) then
5207             ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
5208             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
5209 c            write (iout,*) "beta nmr",
5210 c     &        dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
5211           else
5212             dd=dist(ii,jj)
5213             rdis=dd-dhpb(i)
5214 C Get the force constant corresponding to this distance.
5215             waga=forcon(i)
5216 C Calculate the contribution to energy.
5217             ehpb=ehpb+waga*rdis*rdis
5218 c            write (iout,*) "beta reg",dd,waga*rdis*rdis
5219 C
5220 C Evaluate gradient.
5221 C
5222             fac=waga*rdis/dd
5223           endif
5224           endif
5225           do j=1,3
5226             ggg(j)=fac*(c(j,jj)-c(j,ii))
5227           enddo
5228           do j=1,3
5229             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
5230             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
5231           enddo
5232           do k=1,3
5233             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
5234             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
5235           enddo
5236         else
5237 C Calculate the distance between the two points and its difference from the
5238 C target distance.
5239           dd=dist(ii,jj)
5240           if (constr_dist.eq.11) then
5241             ehpb=ehpb+fordepth(i)**4.0d0
5242      &           *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i))
5243             fac=fordepth(i)**4.0d0
5244      &           *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd
5245           if (energy_dec) write (iout,'(a6,2i5,3f8.3)') "edisl",ii,jj,
5246      &    ehpb,fordepth(i),dd
5247            else
5248           if (dhpb1(i).gt.0.0d0) then
5249             ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
5250             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
5251 c            write (iout,*) "alph nmr",
5252 c     &        dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
5253           else
5254             rdis=dd-dhpb(i)
5255 C Get the force constant corresponding to this distance.
5256             waga=forcon(i)
5257 C Calculate the contribution to energy.
5258             ehpb=ehpb+waga*rdis*rdis
5259 c            write (iout,*) "alpha reg",dd,waga*rdis*rdis
5260 C
5261 C Evaluate gradient.
5262 C
5263             fac=waga*rdis/dd
5264           endif
5265           endif
5266             do j=1,3
5267               ggg(j)=fac*(c(j,jj)-c(j,ii))
5268             enddo
5269 cd      print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
5270 C If this is a SC-SC distance, we need to calculate the contributions to the
5271 C Cartesian gradient in the SC vectors (ghpbx).
5272           if (iii.lt.ii) then
5273           do j=1,3
5274             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
5275             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
5276           enddo
5277           endif
5278 cgrad        do j=iii,jjj-1
5279 cgrad          do k=1,3
5280 cgrad            ghpbc(k,j)=ghpbc(k,j)+ggg(k)
5281 cgrad          enddo
5282 cgrad        enddo
5283           do k=1,3
5284             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
5285             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
5286           enddo
5287         endif
5288       enddo
5289       if (constr_dist.ne.11) ehpb=0.5D0*ehpb
5290       return
5291       end
5292 C--------------------------------------------------------------------------
5293       subroutine ssbond_ene(i,j,eij)
5294 C
5295 C Calculate the distance and angle dependent SS-bond potential energy
5296 C using a free-energy function derived based on RHF/6-31G** ab initio
5297 C calculations of diethyl disulfide.
5298 C
5299 C A. Liwo and U. Kozlowska, 11/24/03
5300 C
5301       implicit real*8 (a-h,o-z)
5302       include 'DIMENSIONS'
5303       include 'COMMON.SBRIDGE'
5304       include 'COMMON.CHAIN'
5305       include 'COMMON.DERIV'
5306       include 'COMMON.LOCAL'
5307       include 'COMMON.INTERACT'
5308       include 'COMMON.VAR'
5309       include 'COMMON.IOUNITS'
5310       double precision erij(3),dcosom1(3),dcosom2(3),gg(3)
5311       itypi=iabs(itype(i))
5312       xi=c(1,nres+i)
5313       yi=c(2,nres+i)
5314       zi=c(3,nres+i)
5315       dxi=dc_norm(1,nres+i)
5316       dyi=dc_norm(2,nres+i)
5317       dzi=dc_norm(3,nres+i)
5318 c      dsci_inv=dsc_inv(itypi)
5319       dsci_inv=vbld_inv(nres+i)
5320       itypj=iabs(itype(j))
5321 c      dscj_inv=dsc_inv(itypj)
5322       dscj_inv=vbld_inv(nres+j)
5323       xj=c(1,nres+j)-xi
5324       yj=c(2,nres+j)-yi
5325       zj=c(3,nres+j)-zi
5326       dxj=dc_norm(1,nres+j)
5327       dyj=dc_norm(2,nres+j)
5328       dzj=dc_norm(3,nres+j)
5329       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
5330       rij=dsqrt(rrij)
5331       erij(1)=xj*rij
5332       erij(2)=yj*rij
5333       erij(3)=zj*rij
5334       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
5335       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
5336       om12=dxi*dxj+dyi*dyj+dzi*dzj
5337       do k=1,3
5338         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
5339         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
5340       enddo
5341       rij=1.0d0/rij
5342       deltad=rij-d0cm
5343       deltat1=1.0d0-om1
5344       deltat2=1.0d0+om2
5345       deltat12=om2-om1+2.0d0
5346       cosphi=om12-om1*om2
5347       eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2)
5348      &  +akct*deltad*deltat12
5349      &  +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi+ebr
5350 c      write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth,
5351 c     &  " akct",akct," deltad",deltad," deltat",deltat1,deltat2,
5352 c     &  " deltat12",deltat12," eij",eij
5353       ed=2*akcm*deltad+akct*deltat12
5354       pom1=akct*deltad
5355       pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
5356       eom1=-2*akth*deltat1-pom1-om2*pom2
5357       eom2= 2*akth*deltat2+pom1-om1*pom2
5358       eom12=pom2
5359       do k=1,3
5360         ggk=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
5361         ghpbx(k,i)=ghpbx(k,i)-ggk
5362      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
5363      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
5364         ghpbx(k,j)=ghpbx(k,j)+ggk
5365      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
5366      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
5367         ghpbc(k,i)=ghpbc(k,i)-ggk
5368         ghpbc(k,j)=ghpbc(k,j)+ggk
5369       enddo
5370 C
5371 C Calculate the components of the gradient in DC and X
5372 C
5373 cgrad      do k=i,j-1
5374 cgrad        do l=1,3
5375 cgrad          ghpbc(l,k)=ghpbc(l,k)+gg(l)
5376 cgrad        enddo
5377 cgrad      enddo
5378       return
5379       end
5380 C--------------------------------------------------------------------------
5381       subroutine ebond(estr)
5382 c
5383 c Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
5384 c
5385       implicit real*8 (a-h,o-z)
5386       include 'DIMENSIONS'
5387       include 'COMMON.LOCAL'
5388       include 'COMMON.GEO'
5389       include 'COMMON.INTERACT'
5390       include 'COMMON.DERIV'
5391       include 'COMMON.VAR'
5392       include 'COMMON.CHAIN'
5393       include 'COMMON.IOUNITS'
5394       include 'COMMON.NAMES'
5395       include 'COMMON.FFIELD'
5396       include 'COMMON.CONTROL'
5397       include 'COMMON.SETUP'
5398       double precision u(3),ud(3)
5399       estr=0.0d0
5400       estr1=0.0d0
5401       do i=ibondp_start,ibondp_end
5402         if (itype(i-1).eq.ntyp1 .and. itype(i).eq.ntyp1) cycle
5403 c          estr1=estr1+gnmr1(vbld(i),-1.0d0,distchainmax)
5404 c          do j=1,3
5405 c          gradb(j,i-1)=gnmr1prim(vbld(i),-1.0d0,distchainmax)
5406 c     &      *dc(j,i-1)/vbld(i)
5407 c          enddo
5408 c          if (energy_dec) write(iout,*)
5409 c     &       "estr1",i,gnmr1(vbld(i),-1.0d0,distchainmax)
5410 c        else
5411 C       Checking if it involves dummy (NH3+ or COO-) group
5412          if (itype(i-1).eq.ntyp1 .or. itype(i).eq.ntyp1) then
5413 C YES   vbldpDUM is the equlibrium length of spring for Dummy atom
5414         diff = vbld(i)-vbldpDUM
5415          else
5416 C NO    vbldp0 is the equlibrium lenght of spring for peptide group
5417         diff = vbld(i)-vbldp0
5418          endif
5419         if (energy_dec)    write (iout,'(a7,i5,4f7.3)')
5420      &     "estr bb",i,vbld(i),vbldp0,diff,AKP*diff*diff
5421         estr=estr+diff*diff
5422         do j=1,3
5423           gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)
5424         enddo
5425 c        write (iout,'(i5,3f10.5)') i,(gradb(j,i-1),j=1,3)
5426 c        endif
5427       enddo
5428       estr=0.5d0*AKP*estr+estr1
5429 c
5430 c 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included
5431 c
5432       do i=ibond_start,ibond_end
5433         iti=iabs(itype(i))
5434         if (iti.ne.10 .and. iti.ne.ntyp1) then
5435           nbi=nbondterm(iti)
5436           if (nbi.eq.1) then
5437             diff=vbld(i+nres)-vbldsc0(1,iti)
5438             if (energy_dec)  write (iout,*)
5439      &      "estr sc",i,iti,vbld(i+nres),vbldsc0(1,iti),diff,
5440      &      AKSC(1,iti),AKSC(1,iti)*diff*diff
5441             estr=estr+0.5d0*AKSC(1,iti)*diff*diff
5442             do j=1,3
5443               gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
5444             enddo
5445           else
5446             do j=1,nbi
5447               diff=vbld(i+nres)-vbldsc0(j,iti)
5448               ud(j)=aksc(j,iti)*diff
5449               u(j)=abond0(j,iti)+0.5d0*ud(j)*diff
5450             enddo
5451             uprod=u(1)
5452             do j=2,nbi
5453               uprod=uprod*u(j)
5454             enddo
5455             usum=0.0d0
5456             usumsqder=0.0d0
5457             do j=1,nbi
5458               uprod1=1.0d0
5459               uprod2=1.0d0
5460               do k=1,nbi
5461                 if (k.ne.j) then
5462                   uprod1=uprod1*u(k)
5463                   uprod2=uprod2*u(k)*u(k)
5464                 endif
5465               enddo
5466               usum=usum+uprod1
5467               usumsqder=usumsqder+ud(j)*uprod2
5468             enddo
5469             estr=estr+uprod/usum
5470             do j=1,3
5471              gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
5472             enddo
5473           endif
5474         endif
5475       enddo
5476       return
5477       end
5478 #ifdef CRYST_THETA
5479 C--------------------------------------------------------------------------
5480       subroutine ebend(etheta,ethetacnstr)
5481 C
5482 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
5483 C angles gamma and its derivatives in consecutive thetas and gammas.
5484 C
5485       implicit real*8 (a-h,o-z)
5486       include 'DIMENSIONS'
5487       include 'COMMON.LOCAL'
5488       include 'COMMON.GEO'
5489       include 'COMMON.INTERACT'
5490       include 'COMMON.DERIV'
5491       include 'COMMON.VAR'
5492       include 'COMMON.CHAIN'
5493       include 'COMMON.IOUNITS'
5494       include 'COMMON.NAMES'
5495       include 'COMMON.FFIELD'
5496       include 'COMMON.CONTROL'
5497       include 'COMMON.TORCNSTR'
5498       common /calcthet/ term1,term2,termm,diffak,ratak,
5499      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
5500      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
5501       double precision y(2),z(2)
5502       delta=0.02d0*pi
5503 c      time11=dexp(-2*time)
5504 c      time12=1.0d0
5505       etheta=0.0D0
5506 c     write (*,'(a,i2)') 'EBEND ICG=',icg
5507       do i=ithet_start,ithet_end
5508         if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
5509      &  .or.itype(i).eq.ntyp1) cycle
5510 C Zero the energy function and its derivative at 0 or pi.
5511         call splinthet(theta(i),0.5d0*delta,ss,ssd)
5512         it=itype(i-1)
5513         ichir1=isign(1,itype(i-2))
5514         ichir2=isign(1,itype(i))
5515          if (itype(i-2).eq.10) ichir1=isign(1,itype(i-1))
5516          if (itype(i).eq.10) ichir2=isign(1,itype(i-1))
5517          if (itype(i-1).eq.10) then
5518           itype1=isign(10,itype(i-2))
5519           ichir11=isign(1,itype(i-2))
5520           ichir12=isign(1,itype(i-2))
5521           itype2=isign(10,itype(i))
5522           ichir21=isign(1,itype(i))
5523           ichir22=isign(1,itype(i))
5524          endif
5525
5526         if (i.gt.3 .and. itype(i-3).ne.ntyp1) then
5527 #ifdef OSF
5528           phii=phi(i)
5529           if (phii.ne.phii) phii=150.0
5530 #else
5531           phii=phi(i)
5532 #endif
5533           y(1)=dcos(phii)
5534           y(2)=dsin(phii)
5535         else
5536           y(1)=0.0D0
5537           y(2)=0.0D0
5538         endif
5539         if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
5540 #ifdef OSF
5541           phii1=phi(i+1)
5542           if (phii1.ne.phii1) phii1=150.0
5543           phii1=pinorm(phii1)
5544           z(1)=cos(phii1)
5545 #else
5546           phii1=phi(i+1)
5547 #endif
5548           z(1)=dcos(phii1)
5549           z(2)=dsin(phii1)
5550         else
5551           z(1)=0.0D0
5552           z(2)=0.0D0
5553         endif
5554 C Calculate the "mean" value of theta from the part of the distribution
5555 C dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2).
5556 C In following comments this theta will be referred to as t_c.
5557         thet_pred_mean=0.0d0
5558         do k=1,2
5559             athetk=athet(k,it,ichir1,ichir2)
5560             bthetk=bthet(k,it,ichir1,ichir2)
5561           if (it.eq.10) then
5562              athetk=athet(k,itype1,ichir11,ichir12)
5563              bthetk=bthet(k,itype2,ichir21,ichir22)
5564           endif
5565          thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k)
5566 c         write(iout,*) 'chuj tu', y(k),z(k)
5567         enddo
5568         dthett=thet_pred_mean*ssd
5569         thet_pred_mean=thet_pred_mean*ss+a0thet(it)
5570 C Derivatives of the "mean" values in gamma1 and gamma2.
5571         dthetg1=(-athet(1,it,ichir1,ichir2)*y(2)
5572      &+athet(2,it,ichir1,ichir2)*y(1))*ss
5573          dthetg2=(-bthet(1,it,ichir1,ichir2)*z(2)
5574      &          +bthet(2,it,ichir1,ichir2)*z(1))*ss
5575          if (it.eq.10) then
5576       dthetg1=(-athet(1,itype1,ichir11,ichir12)*y(2)
5577      &+athet(2,itype1,ichir11,ichir12)*y(1))*ss
5578         dthetg2=(-bthet(1,itype2,ichir21,ichir22)*z(2)
5579      &         +bthet(2,itype2,ichir21,ichir22)*z(1))*ss
5580          endif
5581         if (theta(i).gt.pi-delta) then
5582           call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,
5583      &         E_tc0)
5584           call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0)
5585           call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
5586           call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,
5587      &        E_theta)
5588           call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,
5589      &        E_tc)
5590         else if (theta(i).lt.delta) then
5591           call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0)
5592           call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
5593           call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,
5594      &        E_theta)
5595           call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0)
5596           call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,
5597      &        E_tc)
5598         else
5599           call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,
5600      &        E_theta,E_tc)
5601         endif
5602         etheta=etheta+ethetai
5603         if (energy_dec) write (iout,'(a6,i5,0pf7.3,f7.3,i5)')
5604      &      'ebend',i,ethetai,theta(i),itype(i)
5605         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1
5606         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2
5607         gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)+gloc(nphi+i-2,icg)
5608       enddo
5609       ethetacnstr=0.0d0
5610 C      print *,ithetaconstr_start,ithetaconstr_end,"TU"
5611       do i=ithetaconstr_start,ithetaconstr_end
5612         itheta=itheta_constr(i)
5613         thetiii=theta(itheta)
5614         difi=pinorm(thetiii-theta_constr0(i))
5615         if (difi.gt.theta_drange(i)) then
5616           difi=difi-theta_drange(i)
5617           ethetacnstr=ethetcnstr+0.25d0*for_thet_constr(i)*difi**4
5618           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
5619      &    +for_thet_constr(i)*difi**3
5620         else if (difi.lt.-drange(i)) then
5621           difi=difi+drange(i)
5622           ethetacnstr=ethetcnstr+0.25d0*for_thet_constr(i)*difi**4
5623           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
5624      &    +for_thet_constr(i)*difi**3
5625         else
5626           difi=0.0
5627         endif
5628        if (energy_dec) then
5629         write (iout,'(a6,2i5,4f8.3,2e14.5)') "ethetc",
5630      &    i,itheta,rad2deg*thetiii,
5631      &    rad2deg*theta_constr0(i),  rad2deg*theta_drange(i),
5632      &    rad2deg*difi,0.25d0*for_thet_constr(i)*difi**4,
5633      &    gloc(itheta+nphi-2,icg)
5634         endif
5635       enddo
5636
5637 C Ufff.... We've done all this!!!
5638       return
5639       end
5640 C---------------------------------------------------------------------------
5641       subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,
5642      &     E_tc)
5643       implicit real*8 (a-h,o-z)
5644       include 'DIMENSIONS'
5645       include 'COMMON.LOCAL'
5646       include 'COMMON.IOUNITS'
5647       common /calcthet/ term1,term2,termm,diffak,ratak,
5648      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
5649      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
5650 C Calculate the contributions to both Gaussian lobes.
5651 C 6/6/97 - Deform the Gaussians using the factor of 1/(1+time)
5652 C The "polynomial part" of the "standard deviation" of this part of
5653 C the distributioni.
5654 ccc        write (iout,*) thetai,thet_pred_mean
5655         sig=polthet(3,it)
5656         do j=2,0,-1
5657           sig=sig*thet_pred_mean+polthet(j,it)
5658         enddo
5659 C Derivative of the "interior part" of the "standard deviation of the"
5660 C gamma-dependent Gaussian lobe in t_c.
5661         sigtc=3*polthet(3,it)
5662         do j=2,1,-1
5663           sigtc=sigtc*thet_pred_mean+j*polthet(j,it)
5664         enddo
5665         sigtc=sig*sigtc
5666 C Set the parameters of both Gaussian lobes of the distribution.
5667 C "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc)
5668         fac=sig*sig+sigc0(it)
5669         sigcsq=fac+fac
5670         sigc=1.0D0/sigcsq
5671 C Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c
5672         sigsqtc=-4.0D0*sigcsq*sigtc
5673 c       print *,i,sig,sigtc,sigsqtc
5674 C Following variable (sigtc) is d[sigma(t_c)]/dt_c
5675         sigtc=-sigtc/(fac*fac)
5676 C Following variable is sigma(t_c)**(-2)
5677         sigcsq=sigcsq*sigcsq
5678         sig0i=sig0(it)
5679         sig0inv=1.0D0/sig0i**2
5680         delthec=thetai-thet_pred_mean
5681         delthe0=thetai-theta0i
5682         term1=-0.5D0*sigcsq*delthec*delthec
5683         term2=-0.5D0*sig0inv*delthe0*delthe0
5684 C        write (iout,*)'term1',term1,term2,sigcsq,delthec,sig0inv,delthe0
5685 C Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and
5686 C NaNs in taking the logarithm. We extract the largest exponent which is added
5687 C to the energy (this being the log of the distribution) at the end of energy
5688 C term evaluation for this virtual-bond angle.
5689         if (term1.gt.term2) then
5690           termm=term1
5691           term2=dexp(term2-termm)
5692           term1=1.0d0
5693         else
5694           termm=term2
5695           term1=dexp(term1-termm)
5696           term2=1.0d0
5697         endif
5698 C The ratio between the gamma-independent and gamma-dependent lobes of
5699 C the distribution is a Gaussian function of thet_pred_mean too.
5700         diffak=gthet(2,it)-thet_pred_mean
5701         ratak=diffak/gthet(3,it)**2
5702         ak=dexp(gthet(1,it)-0.5D0*diffak*ratak)
5703 C Let's differentiate it in thet_pred_mean NOW.
5704         aktc=ak*ratak
5705 C Now put together the distribution terms to make complete distribution.
5706         termexp=term1+ak*term2
5707         termpre=sigc+ak*sig0i
5708 C Contribution of the bending energy from this theta is just the -log of
5709 C the sum of the contributions from the two lobes and the pre-exponential
5710 C factor. Simple enough, isn't it?
5711         ethetai=(-dlog(termexp)-termm+dlog(termpre))
5712 C       write (iout,*) 'termexp',termexp,termm,termpre,i
5713 C NOW the derivatives!!!
5714 C 6/6/97 Take into account the deformation.
5715         E_theta=(delthec*sigcsq*term1
5716      &       +ak*delthe0*sig0inv*term2)/termexp
5717         E_tc=((sigtc+aktc*sig0i)/termpre
5718      &      -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+
5719      &       aktc*term2)/termexp)
5720       return
5721       end
5722 c-----------------------------------------------------------------------------
5723       subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)
5724       implicit real*8 (a-h,o-z)
5725       include 'DIMENSIONS'
5726       include 'COMMON.LOCAL'
5727       include 'COMMON.IOUNITS'
5728       common /calcthet/ term1,term2,termm,diffak,ratak,
5729      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
5730      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
5731       delthec=thetai-thet_pred_mean
5732       delthe0=thetai-theta0i
5733 C "Thank you" to MAPLE (probably spared one day of hand-differentiation).
5734       t3 = thetai-thet_pred_mean
5735       t6 = t3**2
5736       t9 = term1
5737       t12 = t3*sigcsq
5738       t14 = t12+t6*sigsqtc
5739       t16 = 1.0d0
5740       t21 = thetai-theta0i
5741       t23 = t21**2
5742       t26 = term2
5743       t27 = t21*t26
5744       t32 = termexp
5745       t40 = t32**2
5746       E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9
5747      & -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40
5748      & *(-t12*t9-ak*sig0inv*t27)
5749       return
5750       end
5751 #else
5752 C--------------------------------------------------------------------------
5753       subroutine ebend(etheta,ethetacnstr)
5754 C
5755 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
5756 C angles gamma and its derivatives in consecutive thetas and gammas.
5757 C ab initio-derived potentials from
5758 c Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203
5759 C
5760       implicit real*8 (a-h,o-z)
5761       include 'DIMENSIONS'
5762       include 'COMMON.LOCAL'
5763       include 'COMMON.GEO'
5764       include 'COMMON.INTERACT'
5765       include 'COMMON.DERIV'
5766       include 'COMMON.VAR'
5767       include 'COMMON.CHAIN'
5768       include 'COMMON.IOUNITS'
5769       include 'COMMON.NAMES'
5770       include 'COMMON.FFIELD'
5771       include 'COMMON.CONTROL'
5772       include 'COMMON.TORCNSTR'
5773       double precision coskt(mmaxtheterm),sinkt(mmaxtheterm),
5774      & cosph1(maxsingle),sinph1(maxsingle),cosph2(maxsingle),
5775      & sinph2(maxsingle),cosph1ph2(maxdouble,maxdouble),
5776      & sinph1ph2(maxdouble,maxdouble)
5777       logical lprn /.false./, lprn1 /.false./
5778       etheta=0.0D0
5779       do i=ithet_start,ithet_end
5780 c        print *,i,itype(i-1),itype(i),itype(i-2)
5781         if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
5782      &  .or.itype(i).eq.ntyp1) cycle
5783 C        print *,i,theta(i)
5784         if (iabs(itype(i+1)).eq.20) iblock=2
5785         if (iabs(itype(i+1)).ne.20) iblock=1
5786         dethetai=0.0d0
5787         dephii=0.0d0
5788         dephii1=0.0d0
5789         theti2=0.5d0*theta(i)
5790         ityp2=ithetyp((itype(i-1)))
5791         do k=1,nntheterm
5792           coskt(k)=dcos(k*theti2)
5793           sinkt(k)=dsin(k*theti2)
5794         enddo
5795 C        print *,ethetai
5796         if (i.gt.3 .and. itype(i-3).ne.ntyp1) then
5797 #ifdef OSF
5798           phii=phi(i)
5799           if (phii.ne.phii) phii=150.0
5800 #else
5801           phii=phi(i)
5802 #endif
5803           ityp1=ithetyp((itype(i-2)))
5804 C propagation of chirality for glycine type
5805           do k=1,nsingle
5806             cosph1(k)=dcos(k*phii)
5807             sinph1(k)=dsin(k*phii)
5808           enddo
5809         else
5810           phii=0.0d0
5811           do k=1,nsingle
5812           ityp1=ithetyp((itype(i-2)))
5813             cosph1(k)=0.0d0
5814             sinph1(k)=0.0d0
5815           enddo
5816         endif
5817         if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
5818 #ifdef OSF
5819           phii1=phi(i+1)
5820           if (phii1.ne.phii1) phii1=150.0
5821           phii1=pinorm(phii1)
5822 #else
5823           phii1=phi(i+1)
5824 #endif
5825           ityp3=ithetyp((itype(i)))
5826           do k=1,nsingle
5827             cosph2(k)=dcos(k*phii1)
5828             sinph2(k)=dsin(k*phii1)
5829           enddo
5830         else
5831           phii1=0.0d0
5832           ityp3=ithetyp((itype(i)))
5833           do k=1,nsingle
5834             cosph2(k)=0.0d0
5835             sinph2(k)=0.0d0
5836           enddo
5837         endif
5838         ethetai=aa0thet(ityp1,ityp2,ityp3,iblock)
5839         do k=1,ndouble
5840           do l=1,k-1
5841             ccl=cosph1(l)*cosph2(k-l)
5842             ssl=sinph1(l)*sinph2(k-l)
5843             scl=sinph1(l)*cosph2(k-l)
5844             csl=cosph1(l)*sinph2(k-l)
5845             cosph1ph2(l,k)=ccl-ssl
5846             cosph1ph2(k,l)=ccl+ssl
5847             sinph1ph2(l,k)=scl+csl
5848             sinph1ph2(k,l)=scl-csl
5849           enddo
5850         enddo
5851         if (lprn) then
5852         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,
5853      &    " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
5854         write (iout,*) "coskt and sinkt"
5855         do k=1,nntheterm
5856           write (iout,*) k,coskt(k),sinkt(k)
5857         enddo
5858         endif
5859         do k=1,ntheterm
5860           ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3,iblock)*sinkt(k)
5861           dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3,iblock)
5862      &      *coskt(k)
5863           if (lprn)
5864      &    write (iout,*) "k",k,"
5865      &     aathet",aathet(k,ityp1,ityp2,ityp3,iblock),
5866      &     " ethetai",ethetai
5867         enddo
5868         if (lprn) then
5869         write (iout,*) "cosph and sinph"
5870         do k=1,nsingle
5871           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
5872         enddo
5873         write (iout,*) "cosph1ph2 and sinph2ph2"
5874         do k=2,ndouble
5875           do l=1,k-1
5876             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),
5877      &         sinph1ph2(l,k),sinph1ph2(k,l)
5878           enddo
5879         enddo
5880         write(iout,*) "ethetai",ethetai
5881         endif
5882 C       print *,ethetai
5883         do m=1,ntheterm2
5884           do k=1,nsingle
5885             aux=bbthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)
5886      &         +ccthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k)
5887      &         +ddthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)
5888      &         +eethet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k)
5889             ethetai=ethetai+sinkt(m)*aux
5890             dethetai=dethetai+0.5d0*m*aux*coskt(m)
5891             dephii=dephii+k*sinkt(m)*(
5892      &          ccthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)-
5893      &          bbthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k))
5894             dephii1=dephii1+k*sinkt(m)*(
5895      &          eethet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)-
5896      &          ddthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k))
5897             if (lprn)
5898      &      write (iout,*) "m",m," k",k," bbthet",
5899      &         bbthet(k,m,ityp1,ityp2,ityp3,iblock)," ccthet",
5900      &         ccthet(k,m,ityp1,ityp2,ityp3,iblock)," ddthet",
5901      &         ddthet(k,m,ityp1,ityp2,ityp3,iblock)," eethet",
5902      &         eethet(k,m,ityp1,ityp2,ityp3,iblock)," ethetai",ethetai
5903 C        print *,"tu",cosph1(k),sinph1(k),cosph2(k),sinph2(k)
5904           enddo
5905         enddo
5906 C        print *,"cosph1", (cosph1(k), k=1,nsingle)
5907 C        print *,"cosph2", (cosph2(k), k=1,nsingle)
5908 C        print *,"sinph1", (sinph1(k), k=1,nsingle)
5909 C        print *,"sinph2", (sinph2(k), k=1,nsingle)
5910         if (lprn)
5911      &  write(iout,*) "ethetai",ethetai
5912 C        print *,"tu",cosph1(k),sinph1(k),cosph2(k),sinph2(k)
5913         do m=1,ntheterm3
5914           do k=2,ndouble
5915             do l=1,k-1
5916               aux=ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
5917      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l)+
5918      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
5919      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)
5920               ethetai=ethetai+sinkt(m)*aux
5921               dethetai=dethetai+0.5d0*m*coskt(m)*aux
5922               dephii=dephii+l*sinkt(m)*(
5923      &           -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)-
5924      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
5925      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
5926      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
5927               dephii1=dephii1+(k-l)*sinkt(m)*(
5928      &           -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
5929      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
5930      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)-
5931      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
5932               if (lprn) then
5933               write (iout,*) "m",m," k",k," l",l," ffthet",
5934      &            ffthet(l,k,m,ityp1,ityp2,ityp3,iblock),
5935      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)," ggthet",
5936      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock),
5937      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock),
5938      &            " ethetai",ethetai
5939               write (iout,*) cosph1ph2(l,k)*sinkt(m),
5940      &            cosph1ph2(k,l)*sinkt(m),
5941      &            sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
5942               endif
5943             enddo
5944           enddo
5945         enddo
5946 10      continue
5947 c        lprn1=.true.
5948 C        print *,ethetai
5949         if (lprn1)
5950      &    write (iout,'(i2,3f8.1,9h ethetai ,f10.5)')
5951      &   i,theta(i)*rad2deg,phii*rad2deg,
5952      &   phii1*rad2deg,ethetai
5953 c        lprn1=.false.
5954         etheta=etheta+ethetai
5955         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
5956         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
5957         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)+wang*dethetai
5958       enddo
5959 C now constrains
5960       ethetacnstr=0.0d0
5961 C      print *,ithetaconstr_start,ithetaconstr_end,"TU"
5962       do i=ithetaconstr_start,ithetaconstr_end
5963         itheta=itheta_constr(i)
5964         thetiii=theta(itheta)
5965         difi=pinorm(thetiii-theta_constr0(i))
5966         if (difi.gt.theta_drange(i)) then
5967           difi=difi-theta_drange(i)
5968           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
5969           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
5970      &    +for_thet_constr(i)*difi**3
5971         else if (difi.lt.-drange(i)) then
5972           difi=difi+drange(i)
5973           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
5974           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
5975      &    +for_thet_constr(i)*difi**3
5976         else
5977           difi=0.0
5978         endif
5979        if (energy_dec) then
5980         write (iout,'(a6,2i5,4f8.3,2e14.5)') "ethetc",
5981      &    i,itheta,rad2deg*thetiii,
5982      &    rad2deg*theta_constr0(i),  rad2deg*theta_drange(i),
5983      &    rad2deg*difi,0.25d0*for_thet_constr(i)*difi**4,
5984      &    gloc(itheta+nphi-2,icg)
5985         endif
5986       enddo
5987
5988       return
5989       end
5990 #endif
5991 #ifdef CRYST_SC
5992 c-----------------------------------------------------------------------------
5993       subroutine esc(escloc)
5994 C Calculate the local energy of a side chain and its derivatives in the
5995 C corresponding virtual-bond valence angles THETA and the spherical angles
5996 C ALPHA and OMEGA.
5997       implicit real*8 (a-h,o-z)
5998       include 'DIMENSIONS'
5999       include 'COMMON.GEO'
6000       include 'COMMON.LOCAL'
6001       include 'COMMON.VAR'
6002       include 'COMMON.INTERACT'
6003       include 'COMMON.DERIV'
6004       include 'COMMON.CHAIN'
6005       include 'COMMON.IOUNITS'
6006       include 'COMMON.NAMES'
6007       include 'COMMON.FFIELD'
6008       include 'COMMON.CONTROL'
6009       double precision x(3),dersc(3),xemp(3),dersc0(3),dersc1(3),
6010      &     ddersc0(3),ddummy(3),xtemp(3),temp(3)
6011       common /sccalc/ time11,time12,time112,theti,it,nlobit
6012       delta=0.02d0*pi
6013       escloc=0.0D0
6014 c     write (iout,'(a)') 'ESC'
6015       do i=loc_start,loc_end
6016         it=itype(i)
6017         if (it.eq.ntyp1) cycle
6018         if (it.eq.10) goto 1
6019         nlobit=nlob(iabs(it))
6020 c       print *,'i=',i,' it=',it,' nlobit=',nlobit
6021 c       write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
6022         theti=theta(i+1)-pipol
6023         x(1)=dtan(theti)
6024         x(2)=alph(i)
6025         x(3)=omeg(i)
6026
6027         if (x(2).gt.pi-delta) then
6028           xtemp(1)=x(1)
6029           xtemp(2)=pi-delta
6030           xtemp(3)=x(3)
6031           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
6032           xtemp(2)=pi
6033           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
6034           call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),
6035      &        escloci,dersc(2))
6036           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
6037      &        ddersc0(1),dersc(1))
6038           call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),
6039      &        ddersc0(3),dersc(3))
6040           xtemp(2)=pi-delta
6041           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
6042           xtemp(2)=pi
6043           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
6044           call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,
6045      &            dersc0(2),esclocbi,dersc02)
6046           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
6047      &            dersc12,dersc01)
6048           call splinthet(x(2),0.5d0*delta,ss,ssd)
6049           dersc0(1)=dersc01
6050           dersc0(2)=dersc02
6051           dersc0(3)=0.0d0
6052           do k=1,3
6053             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
6054           enddo
6055           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
6056 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
6057 c    &             esclocbi,ss,ssd
6058           escloci=ss*escloci+(1.0d0-ss)*esclocbi
6059 c         escloci=esclocbi
6060 c         write (iout,*) escloci
6061         else if (x(2).lt.delta) then
6062           xtemp(1)=x(1)
6063           xtemp(2)=delta
6064           xtemp(3)=x(3)
6065           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
6066           xtemp(2)=0.0d0
6067           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
6068           call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),
6069      &        escloci,dersc(2))
6070           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
6071      &        ddersc0(1),dersc(1))
6072           call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),
6073      &        ddersc0(3),dersc(3))
6074           xtemp(2)=delta
6075           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
6076           xtemp(2)=0.0d0
6077           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
6078           call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,
6079      &            dersc0(2),esclocbi,dersc02)
6080           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
6081      &            dersc12,dersc01)
6082           dersc0(1)=dersc01
6083           dersc0(2)=dersc02
6084           dersc0(3)=0.0d0
6085           call splinthet(x(2),0.5d0*delta,ss,ssd)
6086           do k=1,3
6087             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
6088           enddo
6089           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
6090 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
6091 c    &             esclocbi,ss,ssd
6092           escloci=ss*escloci+(1.0d0-ss)*esclocbi
6093 c         write (iout,*) escloci
6094         else
6095           call enesc(x,escloci,dersc,ddummy,.false.)
6096         endif
6097
6098         escloc=escloc+escloci
6099         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
6100      &     'escloc',i,escloci
6101 c       write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
6102
6103         gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
6104      &   wscloc*dersc(1)
6105         gloc(ialph(i,1),icg)=wscloc*dersc(2)
6106         gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
6107     1   continue
6108       enddo
6109       return
6110       end
6111 C---------------------------------------------------------------------------
6112       subroutine enesc(x,escloci,dersc,ddersc,mixed)
6113       implicit real*8 (a-h,o-z)
6114       include 'DIMENSIONS'
6115       include 'COMMON.GEO'
6116       include 'COMMON.LOCAL'
6117       include 'COMMON.IOUNITS'
6118       common /sccalc/ time11,time12,time112,theti,it,nlobit
6119       double precision x(3),z(3),Ax(3,maxlob,-1:1),dersc(3),ddersc(3)
6120       double precision contr(maxlob,-1:1)
6121       logical mixed
6122 c       write (iout,*) 'it=',it,' nlobit=',nlobit
6123         escloc_i=0.0D0
6124         do j=1,3
6125           dersc(j)=0.0D0
6126           if (mixed) ddersc(j)=0.0d0
6127         enddo
6128         x3=x(3)
6129
6130 C Because of periodicity of the dependence of the SC energy in omega we have
6131 C to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
6132 C To avoid underflows, first compute & store the exponents.
6133
6134         do iii=-1,1
6135
6136           x(3)=x3+iii*dwapi
6137
6138           do j=1,nlobit
6139             do k=1,3
6140               z(k)=x(k)-censc(k,j,it)
6141             enddo
6142             do k=1,3
6143               Axk=0.0D0
6144               do l=1,3
6145                 Axk=Axk+gaussc(l,k,j,it)*z(l)
6146               enddo
6147               Ax(k,j,iii)=Axk
6148             enddo
6149             expfac=0.0D0
6150             do k=1,3
6151               expfac=expfac+Ax(k,j,iii)*z(k)
6152             enddo
6153             contr(j,iii)=expfac
6154           enddo ! j
6155
6156         enddo ! iii
6157
6158         x(3)=x3
6159 C As in the case of ebend, we want to avoid underflows in exponentiation and
6160 C subsequent NaNs and INFs in energy calculation.
6161 C Find the largest exponent
6162         emin=contr(1,-1)
6163         do iii=-1,1
6164           do j=1,nlobit
6165             if (emin.gt.contr(j,iii)) emin=contr(j,iii)
6166           enddo
6167         enddo
6168         emin=0.5D0*emin
6169 cd      print *,'it=',it,' emin=',emin
6170
6171 C Compute the contribution to SC energy and derivatives
6172         do iii=-1,1
6173
6174           do j=1,nlobit
6175 #ifdef OSF
6176             adexp=bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin
6177             if(adexp.ne.adexp) adexp=1.0
6178             expfac=dexp(adexp)
6179 #else
6180             expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin)
6181 #endif
6182 cd          print *,'j=',j,' expfac=',expfac
6183             escloc_i=escloc_i+expfac
6184             do k=1,3
6185               dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
6186             enddo
6187             if (mixed) then
6188               do k=1,3,2
6189                 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii)
6190      &            +gaussc(k,2,j,it))*expfac
6191               enddo
6192             endif
6193           enddo
6194
6195         enddo ! iii
6196
6197         dersc(1)=dersc(1)/cos(theti)**2
6198         ddersc(1)=ddersc(1)/cos(theti)**2
6199         ddersc(3)=ddersc(3)
6200
6201         escloci=-(dlog(escloc_i)-emin)
6202         do j=1,3
6203           dersc(j)=dersc(j)/escloc_i
6204         enddo
6205         if (mixed) then
6206           do j=1,3,2
6207             ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
6208           enddo
6209         endif
6210       return
6211       end
6212 C------------------------------------------------------------------------------
6213       subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
6214       implicit real*8 (a-h,o-z)
6215       include 'DIMENSIONS'
6216       include 'COMMON.GEO'
6217       include 'COMMON.LOCAL'
6218       include 'COMMON.IOUNITS'
6219       common /sccalc/ time11,time12,time112,theti,it,nlobit
6220       double precision x(3),z(3),Ax(3,maxlob),dersc(3)
6221       double precision contr(maxlob)
6222       logical mixed
6223
6224       escloc_i=0.0D0
6225
6226       do j=1,3
6227         dersc(j)=0.0D0
6228       enddo
6229
6230       do j=1,nlobit
6231         do k=1,2
6232           z(k)=x(k)-censc(k,j,it)
6233         enddo
6234         z(3)=dwapi
6235         do k=1,3
6236           Axk=0.0D0
6237           do l=1,3
6238             Axk=Axk+gaussc(l,k,j,it)*z(l)
6239           enddo
6240           Ax(k,j)=Axk
6241         enddo
6242         expfac=0.0D0
6243         do k=1,3
6244           expfac=expfac+Ax(k,j)*z(k)
6245         enddo
6246         contr(j)=expfac
6247       enddo ! j
6248
6249 C As in the case of ebend, we want to avoid underflows in exponentiation and
6250 C subsequent NaNs and INFs in energy calculation.
6251 C Find the largest exponent
6252       emin=contr(1)
6253       do j=1,nlobit
6254         if (emin.gt.contr(j)) emin=contr(j)
6255       enddo
6256       emin=0.5D0*emin
6257
6258 C Compute the contribution to SC energy and derivatives
6259
6260       dersc12=0.0d0
6261       do j=1,nlobit
6262         expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j)+emin)
6263         escloc_i=escloc_i+expfac
6264         do k=1,2
6265           dersc(k)=dersc(k)+Ax(k,j)*expfac
6266         enddo
6267         if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j)
6268      &            +gaussc(1,2,j,it))*expfac
6269         dersc(3)=0.0d0
6270       enddo
6271
6272       dersc(1)=dersc(1)/cos(theti)**2
6273       dersc12=dersc12/cos(theti)**2
6274       escloci=-(dlog(escloc_i)-emin)
6275       do j=1,2
6276         dersc(j)=dersc(j)/escloc_i
6277       enddo
6278       if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
6279       return
6280       end
6281 #else
6282 c----------------------------------------------------------------------------------
6283       subroutine esc(escloc)
6284 C Calculate the local energy of a side chain and its derivatives in the
6285 C corresponding virtual-bond valence angles THETA and the spherical angles
6286 C ALPHA and OMEGA derived from AM1 all-atom calculations.
6287 C added by Urszula Kozlowska. 07/11/2007
6288 C
6289       implicit real*8 (a-h,o-z)
6290       include 'DIMENSIONS'
6291       include 'COMMON.GEO'
6292       include 'COMMON.LOCAL'
6293       include 'COMMON.VAR'
6294       include 'COMMON.SCROT'
6295       include 'COMMON.INTERACT'
6296       include 'COMMON.DERIV'
6297       include 'COMMON.CHAIN'
6298       include 'COMMON.IOUNITS'
6299       include 'COMMON.NAMES'
6300       include 'COMMON.FFIELD'
6301       include 'COMMON.CONTROL'
6302       include 'COMMON.VECTORS'
6303       double precision x_prime(3),y_prime(3),z_prime(3)
6304      &    , sumene,dsc_i,dp2_i,x(65),
6305      &     xx,yy,zz,sumene1,sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6,
6306      &    de_dxx,de_dyy,de_dzz,de_dt
6307       double precision s1_t,s1_6_t,s2_t,s2_6_t
6308       double precision
6309      & dXX_Ci1(3),dYY_Ci1(3),dZZ_Ci1(3),dXX_Ci(3),
6310      & dYY_Ci(3),dZZ_Ci(3),dXX_XYZ(3),dYY_XYZ(3),dZZ_XYZ(3),
6311      & dt_dCi(3),dt_dCi1(3)
6312       common /sccalc/ time11,time12,time112,theti,it,nlobit
6313       delta=0.02d0*pi
6314       escloc=0.0D0
6315       do i=loc_start,loc_end
6316         if (itype(i).eq.ntyp1) cycle
6317         costtab(i+1) =dcos(theta(i+1))
6318         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
6319         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
6320         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
6321         cosfac2=0.5d0/(1.0d0+costtab(i+1))
6322         cosfac=dsqrt(cosfac2)
6323         sinfac2=0.5d0/(1.0d0-costtab(i+1))
6324         sinfac=dsqrt(sinfac2)
6325         it=iabs(itype(i))
6326         if (it.eq.10) goto 1
6327 c
6328 C  Compute the axes of tghe local cartesian coordinates system; store in
6329 c   x_prime, y_prime and z_prime
6330 c
6331         do j=1,3
6332           x_prime(j) = 0.00
6333           y_prime(j) = 0.00
6334           z_prime(j) = 0.00
6335         enddo
6336 C        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
6337 C     &   dc_norm(3,i+nres)
6338         do j = 1,3
6339           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
6340           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
6341         enddo
6342         do j = 1,3
6343           z_prime(j) = -uz(j,i-1)*dsign(1.0d0,dfloat(itype(i)))
6344         enddo
6345 c       write (2,*) "i",i
6346 c       write (2,*) "x_prime",(x_prime(j),j=1,3)
6347 c       write (2,*) "y_prime",(y_prime(j),j=1,3)
6348 c       write (2,*) "z_prime",(z_prime(j),j=1,3)
6349 c       write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
6350 c      & " xy",scalar(x_prime(1),y_prime(1)),
6351 c      & " xz",scalar(x_prime(1),z_prime(1)),
6352 c      & " yy",scalar(y_prime(1),y_prime(1)),
6353 c      & " yz",scalar(y_prime(1),z_prime(1)),
6354 c      & " zz",scalar(z_prime(1),z_prime(1))
6355 c
6356 C Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
6357 C to local coordinate system. Store in xx, yy, zz.
6358 c
6359         xx=0.0d0
6360         yy=0.0d0
6361         zz=0.0d0
6362         do j = 1,3
6363           xx = xx + x_prime(j)*dc_norm(j,i+nres)
6364           yy = yy + y_prime(j)*dc_norm(j,i+nres)
6365           zz = zz + z_prime(j)*dc_norm(j,i+nres)
6366         enddo
6367
6368         xxtab(i)=xx
6369         yytab(i)=yy
6370         zztab(i)=zz
6371 C
6372 C Compute the energy of the ith side cbain
6373 C
6374 c        write (2,*) "xx",xx," yy",yy," zz",zz
6375         it=iabs(itype(i))
6376         do j = 1,65
6377           x(j) = sc_parmin(j,it)
6378         enddo
6379 #ifdef CHECK_COORD
6380 Cc diagnostics - remove later
6381         xx1 = dcos(alph(2))
6382         yy1 = dsin(alph(2))*dcos(omeg(2))
6383         zz1 = -dsign(1.0,dfloat(itype(i)))*dsin(alph(2))*dsin(omeg(2))
6384         write(2,'(3f8.1,3f9.3,1x,3f9.3)')
6385      &    alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,
6386      &    xx1,yy1,zz1
6387 C,"  --- ", xx_w,yy_w,zz_w
6388 c end diagnostics
6389 #endif
6390         sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
6391      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
6392      &   + x(10)*yy*zz
6393         sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
6394      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
6395      & + x(20)*yy*zz
6396         sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
6397      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
6398      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
6399      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
6400      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
6401      &  +x(40)*xx*yy*zz
6402         sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
6403      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
6404      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
6405      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
6406      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
6407      &  +x(60)*xx*yy*zz
6408         dsc_i   = 0.743d0+x(61)
6409         dp2_i   = 1.9d0+x(62)
6410         dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
6411      &          *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
6412         dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
6413      &          *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
6414         s1=(1+x(63))/(0.1d0 + dscp1)
6415         s1_6=(1+x(64))/(0.1d0 + dscp1**6)
6416         s2=(1+x(65))/(0.1d0 + dscp2)
6417         s2_6=(1+x(65))/(0.1d0 + dscp2**6)
6418         sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6)
6419      & + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
6420 c        write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
6421 c     &   sumene4,
6422 c     &   dscp1,dscp2,sumene
6423 c        sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6424         escloc = escloc + sumene
6425 c        write (2,*) "i",i," escloc",sumene,escloc,it,itype(i)
6426 c     & ,zz,xx,yy
6427 c#define DEBUG
6428 #ifdef DEBUG
6429 C
6430 C This section to check the numerical derivatives of the energy of ith side
6431 C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
6432 C #define DEBUG in the code to turn it on.
6433 C
6434         write (2,*) "sumene               =",sumene
6435         aincr=1.0d-7
6436         xxsave=xx
6437         xx=xx+aincr
6438         write (2,*) xx,yy,zz
6439         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6440         de_dxx_num=(sumenep-sumene)/aincr
6441         xx=xxsave
6442         write (2,*) "xx+ sumene from enesc=",sumenep
6443         yysave=yy
6444         yy=yy+aincr
6445         write (2,*) xx,yy,zz
6446         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6447         de_dyy_num=(sumenep-sumene)/aincr
6448         yy=yysave
6449         write (2,*) "yy+ sumene from enesc=",sumenep
6450         zzsave=zz
6451         zz=zz+aincr
6452         write (2,*) xx,yy,zz
6453         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6454         de_dzz_num=(sumenep-sumene)/aincr
6455         zz=zzsave
6456         write (2,*) "zz+ sumene from enesc=",sumenep
6457         costsave=cost2tab(i+1)
6458         sintsave=sint2tab(i+1)
6459         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
6460         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
6461         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6462         de_dt_num=(sumenep-sumene)/aincr
6463         write (2,*) " t+ sumene from enesc=",sumenep
6464         cost2tab(i+1)=costsave
6465         sint2tab(i+1)=sintsave
6466 C End of diagnostics section.
6467 #endif
6468 C
6469 C Compute the gradient of esc
6470 C
6471 c        zz=zz*dsign(1.0,dfloat(itype(i)))
6472         pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
6473         pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
6474         pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
6475         pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
6476         pom_dx=dsc_i*dp2_i*cost2tab(i+1)
6477         pom_dy=dsc_i*dp2_i*sint2tab(i+1)
6478         pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
6479         pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
6480         pom1=(sumene3*sint2tab(i+1)+sumene1)
6481      &     *(pom_s1/dscp1+pom_s16*dscp1**4)
6482         pom2=(sumene4*cost2tab(i+1)+sumene2)
6483      &     *(pom_s2/dscp2+pom_s26*dscp2**4)
6484         sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
6485         sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2
6486      &  +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2)
6487      &  +x(40)*yy*zz
6488         sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
6489         sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2
6490      &  +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2)
6491      &  +x(60)*yy*zz
6492         de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6)
6493      &        +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6)
6494      &        +(pom1+pom2)*pom_dx
6495 #ifdef DEBUG
6496         write(2,*), "de_dxx = ", de_dxx,de_dxx_num,itype(i)
6497 #endif
6498 C
6499         sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
6500         sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2
6501      &  +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2)
6502      &  +x(40)*xx*zz
6503         sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
6504         sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz
6505      &  +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz
6506      &  +x(59)*zz**2 +x(60)*xx*zz
6507         de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6)
6508      &        +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6)
6509      &        +(pom1-pom2)*pom_dy
6510 #ifdef DEBUG
6511         write(2,*), "de_dyy = ", de_dyy,de_dyy_num,itype(i)
6512 #endif
6513 C
6514         de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy
6515      &  +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx
6516      &  +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6)
6517      &  +(x(4) + 2*x(7)*zz+  x(8)*xx + x(10)*yy)*(s1+s1_6)
6518      &  +(x(44)+2*x(47)*zz +x(48)*xx   +x(50)*yy  +3*x(53)*zz**2
6519      &  +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy
6520      &  +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6)
6521      &  + ( x(14) + 2*x(17)*zz+  x(18)*xx + x(20)*yy)*(s2+s2_6)
6522 #ifdef DEBUG
6523         write(2,*), "de_dzz = ", de_dzz,de_dzz_num,itype(i)
6524 #endif
6525 C
6526         de_dt =  0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6)
6527      &  -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6)
6528      &  +pom1*pom_dt1+pom2*pom_dt2
6529 #ifdef DEBUG
6530         write(2,*), "de_dt = ", de_dt,de_dt_num,itype(i)
6531 #endif
6532 c#undef DEBUG
6533 c
6534 C
6535        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
6536        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
6537        cosfac2xx=cosfac2*xx
6538        sinfac2yy=sinfac2*yy
6539        do k = 1,3
6540          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))*
6541      &      vbld_inv(i+1)
6542          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))*
6543      &      vbld_inv(i)
6544          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
6545          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
6546 c         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
6547 c     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
6548 c         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
6549 c     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
6550          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
6551          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
6552          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
6553          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
6554          dZZ_Ci1(k)=0.0d0
6555          dZZ_Ci(k)=0.0d0
6556          do j=1,3
6557            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)
6558      &     *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
6559            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)
6560      &     *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
6561          enddo
6562
6563          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
6564          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
6565          dZZ_XYZ(k)=vbld_inv(i+nres)*
6566      &   (z_prime(k)-zz*dC_norm(k,i+nres))
6567 c
6568          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
6569          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
6570        enddo
6571
6572        do k=1,3
6573          dXX_Ctab(k,i)=dXX_Ci(k)
6574          dXX_C1tab(k,i)=dXX_Ci1(k)
6575          dYY_Ctab(k,i)=dYY_Ci(k)
6576          dYY_C1tab(k,i)=dYY_Ci1(k)
6577          dZZ_Ctab(k,i)=dZZ_Ci(k)
6578          dZZ_C1tab(k,i)=dZZ_Ci1(k)
6579          dXX_XYZtab(k,i)=dXX_XYZ(k)
6580          dYY_XYZtab(k,i)=dYY_XYZ(k)
6581          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
6582        enddo
6583
6584        do k = 1,3
6585 c         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
6586 c     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
6587 c         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
6588 c     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
6589 c         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
6590 c     &    dt_dci(k)
6591 c         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
6592 c     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
6593          gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k)
6594      &    +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
6595          gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k)
6596      &    +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
6597          gsclocx(k,i)=                 de_dxx*dxx_XYZ(k)
6598      &    +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
6599        enddo
6600 c       write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
6601 c     &  (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
6602
6603 C to check gradient call subroutine check_grad
6604
6605     1 continue
6606       enddo
6607       return
6608       end
6609 c------------------------------------------------------------------------------
6610       double precision function enesc(x,xx,yy,zz,cost2,sint2)
6611       implicit none
6612       double precision x(65),xx,yy,zz,cost2,sint2,sumene1,sumene2,
6613      & sumene3,sumene4,sumene,dsc_i,dp2_i,dscp1,dscp2,s1,s1_6,s2,s2_6
6614       sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
6615      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
6616      &   + x(10)*yy*zz
6617       sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
6618      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
6619      & + x(20)*yy*zz
6620       sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
6621      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
6622      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
6623      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
6624      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
6625      &  +x(40)*xx*yy*zz
6626       sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
6627      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
6628      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
6629      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
6630      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
6631      &  +x(60)*xx*yy*zz
6632       dsc_i   = 0.743d0+x(61)
6633       dp2_i   = 1.9d0+x(62)
6634       dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
6635      &          *(xx*cost2+yy*sint2))
6636       dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
6637      &          *(xx*cost2-yy*sint2))
6638       s1=(1+x(63))/(0.1d0 + dscp1)
6639       s1_6=(1+x(64))/(0.1d0 + dscp1**6)
6640       s2=(1+x(65))/(0.1d0 + dscp2)
6641       s2_6=(1+x(65))/(0.1d0 + dscp2**6)
6642       sumene = ( sumene3*sint2 + sumene1)*(s1+s1_6)
6643      & + (sumene4*cost2 +sumene2)*(s2+s2_6)
6644       enesc=sumene
6645       return
6646       end
6647 #endif
6648 c------------------------------------------------------------------------------
6649       subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
6650 C
6651 C This procedure calculates two-body contact function g(rij) and its derivative:
6652 C
6653 C           eps0ij                                     !       x < -1
6654 C g(rij) =  esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5)  ! -1 =< x =< 1
6655 C            0                                         !       x > 1
6656 C
6657 C where x=(rij-r0ij)/delta
6658 C
6659 C rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
6660 C
6661       implicit none
6662       double precision rij,r0ij,eps0ij,fcont,fprimcont
6663       double precision x,x2,x4,delta
6664 c     delta=0.02D0*r0ij
6665 c      delta=0.2D0*r0ij
6666       x=(rij-r0ij)/delta
6667       if (x.lt.-1.0D0) then
6668         fcont=eps0ij
6669         fprimcont=0.0D0
6670       else if (x.le.1.0D0) then
6671         x2=x*x
6672         x4=x2*x2
6673         fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
6674         fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
6675       else
6676         fcont=0.0D0
6677         fprimcont=0.0D0
6678       endif
6679       return
6680       end
6681 c------------------------------------------------------------------------------
6682       subroutine splinthet(theti,delta,ss,ssder)
6683       implicit real*8 (a-h,o-z)
6684       include 'DIMENSIONS'
6685       include 'COMMON.VAR'
6686       include 'COMMON.GEO'
6687       thetup=pi-delta
6688       thetlow=delta
6689       if (theti.gt.pipol) then
6690         call gcont(theti,thetup,1.0d0,delta,ss,ssder)
6691       else
6692         call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
6693         ssder=-ssder
6694       endif
6695       return
6696       end
6697 c------------------------------------------------------------------------------
6698       subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
6699       implicit none
6700       double precision x,x0,delta,f0,f1,fprim0,f,fprim
6701       double precision ksi,ksi2,ksi3,a1,a2,a3
6702       a1=fprim0*delta/(f1-f0)
6703       a2=3.0d0-2.0d0*a1
6704       a3=a1-2.0d0
6705       ksi=(x-x0)/delta
6706       ksi2=ksi*ksi
6707       ksi3=ksi2*ksi
6708       f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
6709       fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
6710       return
6711       end
6712 c------------------------------------------------------------------------------
6713       subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
6714       implicit none
6715       double precision x,x0,delta,f0x,f1x,fprim0x,fx
6716       double precision ksi,ksi2,ksi3,a1,a2,a3
6717       ksi=(x-x0)/delta
6718       ksi2=ksi*ksi
6719       ksi3=ksi2*ksi
6720       a1=fprim0x*delta
6721       a2=3*(f1x-f0x)-2*fprim0x*delta
6722       a3=fprim0x*delta-2*(f1x-f0x)
6723       fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
6724       return
6725       end
6726 C-----------------------------------------------------------------------------
6727 #ifdef CRYST_TOR
6728 C-----------------------------------------------------------------------------
6729       subroutine etor(etors,edihcnstr)
6730       implicit real*8 (a-h,o-z)
6731       include 'DIMENSIONS'
6732       include 'COMMON.VAR'
6733       include 'COMMON.GEO'
6734       include 'COMMON.LOCAL'
6735       include 'COMMON.TORSION'
6736       include 'COMMON.INTERACT'
6737       include 'COMMON.DERIV'
6738       include 'COMMON.CHAIN'
6739       include 'COMMON.NAMES'
6740       include 'COMMON.IOUNITS'
6741       include 'COMMON.FFIELD'
6742       include 'COMMON.TORCNSTR'
6743       include 'COMMON.CONTROL'
6744       logical lprn
6745 C Set lprn=.true. for debugging
6746       lprn=.false.
6747 c      lprn=.true.
6748       etors=0.0D0
6749       do i=iphi_start,iphi_end
6750       etors_ii=0.0D0
6751         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
6752      &      .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
6753         itori=itortyp(itype(i-2))
6754         itori1=itortyp(itype(i-1))
6755         phii=phi(i)
6756         gloci=0.0D0
6757 C Proline-Proline pair is a special case...
6758         if (itori.eq.3 .and. itori1.eq.3) then
6759           if (phii.gt.-dwapi3) then
6760             cosphi=dcos(3*phii)
6761             fac=1.0D0/(1.0D0-cosphi)
6762             etorsi=v1(1,3,3)*fac
6763             etorsi=etorsi+etorsi
6764             etors=etors+etorsi-v1(1,3,3)
6765             if (energy_dec) etors_ii=etors_ii+etorsi-v1(1,3,3)
6766             gloci=gloci-3*fac*etorsi*dsin(3*phii)
6767           endif
6768           do j=1,3
6769             v1ij=v1(j+1,itori,itori1)
6770             v2ij=v2(j+1,itori,itori1)
6771             cosphi=dcos(j*phii)
6772             sinphi=dsin(j*phii)
6773             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
6774             if (energy_dec) etors_ii=etors_ii+
6775      &                              v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
6776             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
6777           enddo
6778         else
6779           do j=1,nterm_old
6780             v1ij=v1(j,itori,itori1)
6781             v2ij=v2(j,itori,itori1)
6782             cosphi=dcos(j*phii)
6783             sinphi=dsin(j*phii)
6784             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
6785             if (energy_dec) etors_ii=etors_ii+
6786      &                  v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
6787             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
6788           enddo
6789         endif
6790         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
6791              'etor',i,etors_ii
6792         if (lprn)
6793      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
6794      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
6795      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
6796         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
6797 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
6798       enddo
6799 ! 6/20/98 - dihedral angle constraints
6800       edihcnstr=0.0d0
6801       do i=1,ndih_constr
6802         itori=idih_constr(i)
6803         phii=phi(itori)
6804         difi=phii-phi0(i)
6805         if (difi.gt.drange(i)) then
6806           difi=difi-drange(i)
6807           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
6808           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
6809         else if (difi.lt.-drange(i)) then
6810           difi=difi+drange(i)
6811           edihcnstr=edihcnstr+0.25d0*ftors(i)**difi**4
6812           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
6813         endif
6814 !        write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii,
6815 !     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
6816       enddo
6817 !      write (iout,*) 'edihcnstr',edihcnstr
6818       return
6819       end
6820 c------------------------------------------------------------------------------
6821       subroutine etor_d(etors_d)
6822       etors_d=0.0d0
6823       return
6824       end
6825 c----------------------------------------------------------------------------
6826 #else
6827       subroutine etor(etors,edihcnstr)
6828       implicit real*8 (a-h,o-z)
6829       include 'DIMENSIONS'
6830       include 'COMMON.VAR'
6831       include 'COMMON.GEO'
6832       include 'COMMON.LOCAL'
6833       include 'COMMON.TORSION'
6834       include 'COMMON.INTERACT'
6835       include 'COMMON.DERIV'
6836       include 'COMMON.CHAIN'
6837       include 'COMMON.NAMES'
6838       include 'COMMON.IOUNITS'
6839       include 'COMMON.FFIELD'
6840       include 'COMMON.TORCNSTR'
6841       include 'COMMON.CONTROL'
6842       logical lprn
6843 C Set lprn=.true. for debugging
6844       lprn=.false.
6845 c     lprn=.true.
6846       etors=0.0D0
6847       do i=iphi_start,iphi_end
6848 C ANY TWO ARE DUMMY ATOMS in row CYCLE
6849 c        if (((itype(i-3).eq.ntyp1).and.(itype(i-2).eq.ntyp1)).or.
6850 c     &      ((itype(i-2).eq.ntyp1).and.(itype(i-1).eq.ntyp1))  .or.
6851 c     &      ((itype(i-1).eq.ntyp1).and.(itype(i).eq.ntyp1))) cycle
6852         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
6853      &      .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
6854 C In current verion the ALL DUMMY ATOM POTENTIALS ARE OFF
6855 C For introducing the NH3+ and COO- group please check the etor_d for reference
6856 C and guidance
6857         etors_ii=0.0D0
6858          if (iabs(itype(i)).eq.20) then
6859          iblock=2
6860          else
6861          iblock=1
6862          endif
6863         itori=itortyp(itype(i-2))
6864         itori1=itortyp(itype(i-1))
6865         phii=phi(i)
6866         gloci=0.0D0
6867 C Regular cosine and sine terms
6868         do j=1,nterm(itori,itori1,iblock)
6869           v1ij=v1(j,itori,itori1,iblock)
6870           v2ij=v2(j,itori,itori1,iblock)
6871           cosphi=dcos(j*phii)
6872           sinphi=dsin(j*phii)
6873           etors=etors+v1ij*cosphi+v2ij*sinphi
6874           if (energy_dec) etors_ii=etors_ii+
6875      &                v1ij*cosphi+v2ij*sinphi
6876           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
6877         enddo
6878 C Lorentz terms
6879 C                         v1
6880 C  E = SUM ----------------------------------- - v1
6881 C          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
6882 C
6883         cosphi=dcos(0.5d0*phii)
6884         sinphi=dsin(0.5d0*phii)
6885         do j=1,nlor(itori,itori1,iblock)
6886           vl1ij=vlor1(j,itori,itori1)
6887           vl2ij=vlor2(j,itori,itori1)
6888           vl3ij=vlor3(j,itori,itori1)
6889           pom=vl2ij*cosphi+vl3ij*sinphi
6890           pom1=1.0d0/(pom*pom+1.0d0)
6891           etors=etors+vl1ij*pom1
6892           if (energy_dec) etors_ii=etors_ii+
6893      &                vl1ij*pom1
6894           pom=-pom*pom1*pom1
6895           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
6896         enddo
6897 C Subtract the constant term
6898         etors=etors-v0(itori,itori1,iblock)
6899           if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
6900      &         'etor',i,etors_ii-v0(itori,itori1,iblock)
6901         if (lprn)
6902      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
6903      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
6904      &  (v1(j,itori,itori1,iblock),j=1,6),
6905      &  (v2(j,itori,itori1,iblock),j=1,6)
6906         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
6907 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
6908       enddo
6909 ! 6/20/98 - dihedral angle constraints
6910       edihcnstr=0.0d0
6911 c      do i=1,ndih_constr
6912       do i=idihconstr_start,idihconstr_end
6913         itori=idih_constr(i)
6914         phii=phi(itori)
6915         difi=pinorm(phii-phi0(i))
6916         if (difi.gt.drange(i)) then
6917           difi=difi-drange(i)
6918           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
6919           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
6920         else if (difi.lt.-drange(i)) then
6921           difi=difi+drange(i)
6922           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
6923           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
6924         else
6925           difi=0.0
6926         endif
6927        if (energy_dec) then
6928         write (iout,'(a6,2i5,4f8.3,2e14.5)') "edihc",
6929      &    i,itori,rad2deg*phii,
6930      &    rad2deg*phi0(i),  rad2deg*drange(i),
6931      &    rad2deg*difi,0.25d0*ftors(i)*difi**4,gloc(itori-3,icg)
6932         endif
6933       enddo
6934 cd       write (iout,*) 'edihcnstr',edihcnstr
6935       return
6936       end
6937 c----------------------------------------------------------------------------
6938       subroutine etor_d(etors_d)
6939 C 6/23/01 Compute double torsional energy
6940       implicit real*8 (a-h,o-z)
6941       include 'DIMENSIONS'
6942       include 'COMMON.VAR'
6943       include 'COMMON.GEO'
6944       include 'COMMON.LOCAL'
6945       include 'COMMON.TORSION'
6946       include 'COMMON.INTERACT'
6947       include 'COMMON.DERIV'
6948       include 'COMMON.CHAIN'
6949       include 'COMMON.NAMES'
6950       include 'COMMON.IOUNITS'
6951       include 'COMMON.FFIELD'
6952       include 'COMMON.TORCNSTR'
6953       logical lprn
6954 C Set lprn=.true. for debugging
6955       lprn=.false.
6956 c     lprn=.true.
6957       etors_d=0.0D0
6958 c      write(iout,*) "a tu??"
6959       do i=iphid_start,iphid_end
6960 C ANY TWO ARE DUMMY ATOMS in row CYCLE
6961 C        if (((itype(i-3).eq.ntyp1).and.(itype(i-2).eq.ntyp1)).or.
6962 C     &      ((itype(i-2).eq.ntyp1).and.(itype(i-1).eq.ntyp1)).or.
6963 C     &      ((itype(i-1).eq.ntyp1).and.(itype(i).eq.ntyp1))  .or.
6964 C     &      ((itype(i).eq.ntyp1).and.(itype(i+1).eq.ntyp1))) cycle
6965          if ((itype(i-2).eq.ntyp1).or.itype(i-3).eq.ntyp1.or.
6966      &  (itype(i-1).eq.ntyp1).or.(itype(i).eq.ntyp1).or.
6967      &  (itype(i+1).eq.ntyp1)) cycle
6968 C In current verion the ALL DUMMY ATOM POTENTIALS ARE OFF
6969         itori=itortyp(itype(i-2))
6970         itori1=itortyp(itype(i-1))
6971         itori2=itortyp(itype(i))
6972         phii=phi(i)
6973         phii1=phi(i+1)
6974         gloci1=0.0D0
6975         gloci2=0.0D0
6976         iblock=1
6977         if (iabs(itype(i+1)).eq.20) iblock=2
6978 C Iblock=2 Proline type
6979 C ADASKO: WHEN PARAMETERS FOR THIS TYPE OF BLOCKING GROUP IS READY UNCOMMENT
6980 C CHECK WEATHER THERE IS NECCESITY FOR iblock=3 for COO-
6981 C        if (itype(i+1).eq.ntyp1) iblock=3
6982 C The problem of NH3+ group can be resolved by adding new parameters please note if there
6983 C IS or IS NOT need for this
6984 C IF Yes uncomment below and add to parmread.F appropriate changes and to v1cij and so on
6985 C        is (itype(i-3).eq.ntyp1) ntblock=2
6986 C        ntblock is N-terminal blocking group
6987
6988 C Regular cosine and sine terms
6989         do j=1,ntermd_1(itori,itori1,itori2,iblock)
6990 C Example of changes for NH3+ blocking group
6991 C       do j=1,ntermd_1(itori,itori1,itori2,iblock,ntblock)
6992 C          v1cij=v1c(1,j,itori,itori1,itori2,iblock,ntblock)
6993           v1cij=v1c(1,j,itori,itori1,itori2,iblock)
6994           v1sij=v1s(1,j,itori,itori1,itori2,iblock)
6995           v2cij=v1c(2,j,itori,itori1,itori2,iblock)
6996           v2sij=v1s(2,j,itori,itori1,itori2,iblock)
6997           cosphi1=dcos(j*phii)
6998           sinphi1=dsin(j*phii)
6999           cosphi2=dcos(j*phii1)
7000           sinphi2=dsin(j*phii1)
7001           etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+
7002      &     v2cij*cosphi2+v2sij*sinphi2
7003           gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
7004           gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
7005         enddo
7006         do k=2,ntermd_2(itori,itori1,itori2,iblock)
7007           do l=1,k-1
7008             v1cdij = v2c(k,l,itori,itori1,itori2,iblock)
7009             v2cdij = v2c(l,k,itori,itori1,itori2,iblock)
7010             v1sdij = v2s(k,l,itori,itori1,itori2,iblock)
7011             v2sdij = v2s(l,k,itori,itori1,itori2,iblock)
7012             cosphi1p2=dcos(l*phii+(k-l)*phii1)
7013             cosphi1m2=dcos(l*phii-(k-l)*phii1)
7014             sinphi1p2=dsin(l*phii+(k-l)*phii1)
7015             sinphi1m2=dsin(l*phii-(k-l)*phii1)
7016             etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+
7017      &        v1sdij*sinphi1p2+v2sdij*sinphi1m2
7018             gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2
7019      &        -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
7020             gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2
7021      &        -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
7022           enddo
7023         enddo
7024         gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*gloci1
7025         gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*gloci2
7026       enddo
7027       return
7028       end
7029 #endif
7030 c------------------------------------------------------------------------------
7031       subroutine eback_sc_corr(esccor)
7032 c 7/21/2007 Correlations between the backbone-local and side-chain-local
7033 c        conformational states; temporarily implemented as differences
7034 c        between UNRES torsional potentials (dependent on three types of
7035 c        residues) and the torsional potentials dependent on all 20 types
7036 c        of residues computed from AM1  energy surfaces of terminally-blocked
7037 c        amino-acid residues.
7038       implicit real*8 (a-h,o-z)
7039       include 'DIMENSIONS'
7040       include 'COMMON.VAR'
7041       include 'COMMON.GEO'
7042       include 'COMMON.LOCAL'
7043       include 'COMMON.TORSION'
7044       include 'COMMON.SCCOR'
7045       include 'COMMON.INTERACT'
7046       include 'COMMON.DERIV'
7047       include 'COMMON.CHAIN'
7048       include 'COMMON.NAMES'
7049       include 'COMMON.IOUNITS'
7050       include 'COMMON.FFIELD'
7051       include 'COMMON.CONTROL'
7052       logical lprn
7053 C Set lprn=.true. for debugging
7054       lprn=.false.
7055 c      lprn=.true.
7056 c      write (iout,*) "EBACK_SC_COR",itau_start,itau_end
7057       esccor=0.0D0
7058       do i=itau_start,itau_end
7059         if ((itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)) cycle
7060         esccor_ii=0.0D0
7061         isccori=isccortyp(itype(i-2))
7062         isccori1=isccortyp(itype(i-1))
7063 c      write (iout,*) "EBACK_SC_COR",i,nterm_sccor(isccori,isccori1)
7064         phii=phi(i)
7065         do intertyp=1,3 !intertyp
7066 cc Added 09 May 2012 (Adasko)
7067 cc  Intertyp means interaction type of backbone mainchain correlation:
7068 c   1 = SC...Ca...Ca...Ca
7069 c   2 = Ca...Ca...Ca...SC
7070 c   3 = SC...Ca...Ca...SCi
7071         gloci=0.0D0
7072         if (((intertyp.eq.3).and.((itype(i-2).eq.10).or.
7073      &      (itype(i-1).eq.10).or.(itype(i-2).eq.ntyp1).or.
7074      &      (itype(i-1).eq.ntyp1)))
7075      &    .or. ((intertyp.eq.1).and.((itype(i-2).eq.10)
7076      &     .or.(itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)
7077      &     .or.(itype(i).eq.ntyp1)))
7078      &    .or.((intertyp.eq.2).and.((itype(i-1).eq.10).or.
7079      &      (itype(i-1).eq.ntyp1).or.(itype(i-2).eq.ntyp1).or.
7080      &      (itype(i-3).eq.ntyp1)))) cycle
7081         if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1).eq.ntyp1)) cycle
7082         if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres).eq.ntyp1))
7083      & cycle
7084        do j=1,nterm_sccor(isccori,isccori1)
7085           v1ij=v1sccor(j,intertyp,isccori,isccori1)
7086           v2ij=v2sccor(j,intertyp,isccori,isccori1)
7087           cosphi=dcos(j*tauangle(intertyp,i))
7088           sinphi=dsin(j*tauangle(intertyp,i))
7089           esccor=esccor+v1ij*cosphi+v2ij*sinphi
7090           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7091         enddo
7092 c      write (iout,*) "EBACK_SC_COR",i,v1ij*cosphi+v2ij*sinphi,intertyp
7093         gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci
7094         if (lprn)
7095      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
7096      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,isccori,isccori1,
7097      &  (v1sccor(j,intertyp,isccori,isccori1),j=1,6)
7098      & ,(v2sccor(j,intertyp,isccori,isccori1),j=1,6)
7099         gsccor_loc(i-3)=gsccor_loc(i-3)+gloci
7100        enddo !intertyp
7101       enddo
7102
7103       return
7104       end
7105 c----------------------------------------------------------------------------
7106       subroutine multibody(ecorr)
7107 C This subroutine calculates multi-body contributions to energy following
7108 C the idea of Skolnick et al. If side chains I and J make a contact and
7109 C at the same time side chains I+1 and J+1 make a contact, an extra
7110 C contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
7111       implicit real*8 (a-h,o-z)
7112       include 'DIMENSIONS'
7113       include 'COMMON.IOUNITS'
7114       include 'COMMON.DERIV'
7115       include 'COMMON.INTERACT'
7116       include 'COMMON.CONTACTS'
7117       double precision gx(3),gx1(3)
7118       logical lprn
7119
7120 C Set lprn=.true. for debugging
7121       lprn=.false.
7122
7123       if (lprn) then
7124         write (iout,'(a)') 'Contact function values:'
7125         do i=nnt,nct-2
7126           write (iout,'(i2,20(1x,i2,f10.5))')
7127      &        i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
7128         enddo
7129       endif
7130       ecorr=0.0D0
7131       do i=nnt,nct
7132         do j=1,3
7133           gradcorr(j,i)=0.0D0
7134           gradxorr(j,i)=0.0D0
7135         enddo
7136       enddo
7137       do i=nnt,nct-2
7138
7139         DO ISHIFT = 3,4
7140
7141         i1=i+ishift
7142         num_conti=num_cont(i)
7143         num_conti1=num_cont(i1)
7144         do jj=1,num_conti
7145           j=jcont(jj,i)
7146           do kk=1,num_conti1
7147             j1=jcont(kk,i1)
7148             if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
7149 cd          write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
7150 cd   &                   ' ishift=',ishift
7151 C Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
7152 C The system gains extra energy.
7153               ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
7154             endif   ! j1==j+-ishift
7155           enddo     ! kk
7156         enddo       ! jj
7157
7158         ENDDO ! ISHIFT
7159
7160       enddo         ! i
7161       return
7162       end
7163 c------------------------------------------------------------------------------
7164       double precision function esccorr(i,j,k,l,jj,kk)
7165       implicit real*8 (a-h,o-z)
7166       include 'DIMENSIONS'
7167       include 'COMMON.IOUNITS'
7168       include 'COMMON.DERIV'
7169       include 'COMMON.INTERACT'
7170       include 'COMMON.CONTACTS'
7171       double precision gx(3),gx1(3)
7172       logical lprn
7173       lprn=.false.
7174       eij=facont(jj,i)
7175       ekl=facont(kk,k)
7176 cd    write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
7177 C Calculate the multi-body contribution to energy.
7178 C Calculate multi-body contributions to the gradient.
7179 cd    write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
7180 cd   & k,l,(gacont(m,kk,k),m=1,3)
7181       do m=1,3
7182         gx(m) =ekl*gacont(m,jj,i)
7183         gx1(m)=eij*gacont(m,kk,k)
7184         gradxorr(m,i)=gradxorr(m,i)-gx(m)
7185         gradxorr(m,j)=gradxorr(m,j)+gx(m)
7186         gradxorr(m,k)=gradxorr(m,k)-gx1(m)
7187         gradxorr(m,l)=gradxorr(m,l)+gx1(m)
7188       enddo
7189       do m=i,j-1
7190         do ll=1,3
7191           gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
7192         enddo
7193       enddo
7194       do m=k,l-1
7195         do ll=1,3
7196           gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
7197         enddo
7198       enddo
7199       esccorr=-eij*ekl
7200       return
7201       end
7202 c------------------------------------------------------------------------------
7203       subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
7204 C This subroutine calculates multi-body contributions to hydrogen-bonding
7205       implicit real*8 (a-h,o-z)
7206       include 'DIMENSIONS'
7207       include 'COMMON.IOUNITS'
7208 #ifdef MPI
7209       include "mpif.h"
7210       parameter (max_cont=maxconts)
7211       parameter (max_dim=26)
7212       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
7213       double precision zapas(max_dim,maxconts,max_fg_procs),
7214      &  zapas_recv(max_dim,maxconts,max_fg_procs)
7215       common /przechowalnia/ zapas
7216       integer status(MPI_STATUS_SIZE),req(maxconts*2),
7217      &  status_array(MPI_STATUS_SIZE,maxconts*2)
7218 #endif
7219       include 'COMMON.SETUP'
7220       include 'COMMON.FFIELD'
7221       include 'COMMON.DERIV'
7222       include 'COMMON.INTERACT'
7223       include 'COMMON.CONTACTS'
7224       include 'COMMON.CONTROL'
7225       include 'COMMON.LOCAL'
7226       double precision gx(3),gx1(3),time00
7227       logical lprn,ldone
7228
7229 C Set lprn=.true. for debugging
7230       lprn=.false.
7231 #ifdef MPI
7232       n_corr=0
7233       n_corr1=0
7234       if (nfgtasks.le.1) goto 30
7235       if (lprn) then
7236         write (iout,'(a)') 'Contact function values before RECEIVE:'
7237         do i=nnt,nct-2
7238           write (iout,'(2i3,50(1x,i2,f5.2))')
7239      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
7240      &    j=1,num_cont_hb(i))
7241         enddo
7242       endif
7243       call flush(iout)
7244       do i=1,ntask_cont_from
7245         ncont_recv(i)=0
7246       enddo
7247       do i=1,ntask_cont_to
7248         ncont_sent(i)=0
7249       enddo
7250 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
7251 c     & ntask_cont_to
7252 C Make the list of contacts to send to send to other procesors
7253 c      write (iout,*) "limits",max0(iturn4_end-1,iatel_s),iturn3_end
7254 c      call flush(iout)
7255       do i=iturn3_start,iturn3_end
7256 c        write (iout,*) "make contact list turn3",i," num_cont",
7257 c     &    num_cont_hb(i)
7258         call add_hb_contact(i,i+2,iturn3_sent_local(1,i))
7259       enddo
7260       do i=iturn4_start,iturn4_end
7261 c        write (iout,*) "make contact list turn4",i," num_cont",
7262 c     &   num_cont_hb(i)
7263         call add_hb_contact(i,i+3,iturn4_sent_local(1,i))
7264       enddo
7265       do ii=1,nat_sent
7266         i=iat_sent(ii)
7267 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
7268 c     &    num_cont_hb(i)
7269         do j=1,num_cont_hb(i)
7270         do k=1,4
7271           jjc=jcont_hb(j,i)
7272           iproc=iint_sent_local(k,jjc,ii)
7273 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
7274           if (iproc.gt.0) then
7275             ncont_sent(iproc)=ncont_sent(iproc)+1
7276             nn=ncont_sent(iproc)
7277             zapas(1,nn,iproc)=i
7278             zapas(2,nn,iproc)=jjc
7279             zapas(3,nn,iproc)=facont_hb(j,i)
7280             zapas(4,nn,iproc)=ees0p(j,i)
7281             zapas(5,nn,iproc)=ees0m(j,i)
7282             zapas(6,nn,iproc)=gacont_hbr(1,j,i)
7283             zapas(7,nn,iproc)=gacont_hbr(2,j,i)
7284             zapas(8,nn,iproc)=gacont_hbr(3,j,i)
7285             zapas(9,nn,iproc)=gacontm_hb1(1,j,i)
7286             zapas(10,nn,iproc)=gacontm_hb1(2,j,i)
7287             zapas(11,nn,iproc)=gacontm_hb1(3,j,i)
7288             zapas(12,nn,iproc)=gacontp_hb1(1,j,i)
7289             zapas(13,nn,iproc)=gacontp_hb1(2,j,i)
7290             zapas(14,nn,iproc)=gacontp_hb1(3,j,i)
7291             zapas(15,nn,iproc)=gacontm_hb2(1,j,i)
7292             zapas(16,nn,iproc)=gacontm_hb2(2,j,i)
7293             zapas(17,nn,iproc)=gacontm_hb2(3,j,i)
7294             zapas(18,nn,iproc)=gacontp_hb2(1,j,i)
7295             zapas(19,nn,iproc)=gacontp_hb2(2,j,i)
7296             zapas(20,nn,iproc)=gacontp_hb2(3,j,i)
7297             zapas(21,nn,iproc)=gacontm_hb3(1,j,i)
7298             zapas(22,nn,iproc)=gacontm_hb3(2,j,i)
7299             zapas(23,nn,iproc)=gacontm_hb3(3,j,i)
7300             zapas(24,nn,iproc)=gacontp_hb3(1,j,i)
7301             zapas(25,nn,iproc)=gacontp_hb3(2,j,i)
7302             zapas(26,nn,iproc)=gacontp_hb3(3,j,i)
7303           endif
7304         enddo
7305         enddo
7306       enddo
7307       if (lprn) then
7308       write (iout,*)
7309      &  "Numbers of contacts to be sent to other processors",
7310      &  (ncont_sent(i),i=1,ntask_cont_to)
7311       write (iout,*) "Contacts sent"
7312       do ii=1,ntask_cont_to
7313         nn=ncont_sent(ii)
7314         iproc=itask_cont_to(ii)
7315         write (iout,*) nn," contacts to processor",iproc,
7316      &   " of CONT_TO_COMM group"
7317         do i=1,nn
7318           write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
7319         enddo
7320       enddo
7321       call flush(iout)
7322       endif
7323       CorrelType=477
7324       CorrelID=fg_rank+1
7325       CorrelType1=478
7326       CorrelID1=nfgtasks+fg_rank+1
7327       ireq=0
7328 C Receive the numbers of needed contacts from other processors
7329       do ii=1,ntask_cont_from
7330         iproc=itask_cont_from(ii)
7331         ireq=ireq+1
7332         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
7333      &    FG_COMM,req(ireq),IERR)
7334       enddo
7335 c      write (iout,*) "IRECV ended"
7336 c      call flush(iout)
7337 C Send the number of contacts needed by other processors
7338       do ii=1,ntask_cont_to
7339         iproc=itask_cont_to(ii)
7340         ireq=ireq+1
7341         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
7342      &    FG_COMM,req(ireq),IERR)
7343       enddo
7344 c      write (iout,*) "ISEND ended"
7345 c      write (iout,*) "number of requests (nn)",ireq
7346       call flush(iout)
7347       if (ireq.gt.0)
7348      &  call MPI_Waitall(ireq,req,status_array,ierr)
7349 c      write (iout,*)
7350 c     &  "Numbers of contacts to be received from other processors",
7351 c     &  (ncont_recv(i),i=1,ntask_cont_from)
7352 c      call flush(iout)
7353 C Receive contacts
7354       ireq=0
7355       do ii=1,ntask_cont_from
7356         iproc=itask_cont_from(ii)
7357         nn=ncont_recv(ii)
7358 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
7359 c     &   " of CONT_TO_COMM group"
7360         call flush(iout)
7361         if (nn.gt.0) then
7362           ireq=ireq+1
7363           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
7364      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
7365 c          write (iout,*) "ireq,req",ireq,req(ireq)
7366         endif
7367       enddo
7368 C Send the contacts to processors that need them
7369       do ii=1,ntask_cont_to
7370         iproc=itask_cont_to(ii)
7371         nn=ncont_sent(ii)
7372 c        write (iout,*) nn," contacts to processor",iproc,
7373 c     &   " of CONT_TO_COMM group"
7374         if (nn.gt.0) then
7375           ireq=ireq+1
7376           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
7377      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
7378 c          write (iout,*) "ireq,req",ireq,req(ireq)
7379 c          do i=1,nn
7380 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
7381 c          enddo
7382         endif
7383       enddo
7384 c      write (iout,*) "number of requests (contacts)",ireq
7385 c      write (iout,*) "req",(req(i),i=1,4)
7386 c      call flush(iout)
7387       if (ireq.gt.0)
7388      & call MPI_Waitall(ireq,req,status_array,ierr)
7389       do iii=1,ntask_cont_from
7390         iproc=itask_cont_from(iii)
7391         nn=ncont_recv(iii)
7392         if (lprn) then
7393         write (iout,*) "Received",nn," contacts from processor",iproc,
7394      &   " of CONT_FROM_COMM group"
7395         call flush(iout)
7396         do i=1,nn
7397           write(iout,'(2f5.0,4f10.5)')(zapas_recv(j,i,iii),j=1,5)
7398         enddo
7399         call flush(iout)
7400         endif
7401         do i=1,nn
7402           ii=zapas_recv(1,i,iii)
7403 c Flag the received contacts to prevent double-counting
7404           jj=-zapas_recv(2,i,iii)
7405 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
7406 c          call flush(iout)
7407           nnn=num_cont_hb(ii)+1
7408           num_cont_hb(ii)=nnn
7409           jcont_hb(nnn,ii)=jj
7410           facont_hb(nnn,ii)=zapas_recv(3,i,iii)
7411           ees0p(nnn,ii)=zapas_recv(4,i,iii)
7412           ees0m(nnn,ii)=zapas_recv(5,i,iii)
7413           gacont_hbr(1,nnn,ii)=zapas_recv(6,i,iii)
7414           gacont_hbr(2,nnn,ii)=zapas_recv(7,i,iii)
7415           gacont_hbr(3,nnn,ii)=zapas_recv(8,i,iii)
7416           gacontm_hb1(1,nnn,ii)=zapas_recv(9,i,iii)
7417           gacontm_hb1(2,nnn,ii)=zapas_recv(10,i,iii)
7418           gacontm_hb1(3,nnn,ii)=zapas_recv(11,i,iii)
7419           gacontp_hb1(1,nnn,ii)=zapas_recv(12,i,iii)
7420           gacontp_hb1(2,nnn,ii)=zapas_recv(13,i,iii)
7421           gacontp_hb1(3,nnn,ii)=zapas_recv(14,i,iii)
7422           gacontm_hb2(1,nnn,ii)=zapas_recv(15,i,iii)
7423           gacontm_hb2(2,nnn,ii)=zapas_recv(16,i,iii)
7424           gacontm_hb2(3,nnn,ii)=zapas_recv(17,i,iii)
7425           gacontp_hb2(1,nnn,ii)=zapas_recv(18,i,iii)
7426           gacontp_hb2(2,nnn,ii)=zapas_recv(19,i,iii)
7427           gacontp_hb2(3,nnn,ii)=zapas_recv(20,i,iii)
7428           gacontm_hb3(1,nnn,ii)=zapas_recv(21,i,iii)
7429           gacontm_hb3(2,nnn,ii)=zapas_recv(22,i,iii)
7430           gacontm_hb3(3,nnn,ii)=zapas_recv(23,i,iii)
7431           gacontp_hb3(1,nnn,ii)=zapas_recv(24,i,iii)
7432           gacontp_hb3(2,nnn,ii)=zapas_recv(25,i,iii)
7433           gacontp_hb3(3,nnn,ii)=zapas_recv(26,i,iii)
7434         enddo
7435       enddo
7436       call flush(iout)
7437       if (lprn) then
7438         write (iout,'(a)') 'Contact function values after receive:'
7439         do i=nnt,nct-2
7440           write (iout,'(2i3,50(1x,i3,f5.2))')
7441      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
7442      &    j=1,num_cont_hb(i))
7443         enddo
7444         call flush(iout)
7445       endif
7446    30 continue
7447 #endif
7448       if (lprn) then
7449         write (iout,'(a)') 'Contact function values:'
7450         do i=nnt,nct-2
7451           write (iout,'(2i3,50(1x,i3,f5.2))')
7452      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
7453      &    j=1,num_cont_hb(i))
7454         enddo
7455       endif
7456       ecorr=0.0D0
7457 C Remove the loop below after debugging !!!
7458       do i=nnt,nct
7459         do j=1,3
7460           gradcorr(j,i)=0.0D0
7461           gradxorr(j,i)=0.0D0
7462         enddo
7463       enddo
7464 C Calculate the local-electrostatic correlation terms
7465       do i=min0(iatel_s,iturn4_start),max0(iatel_e,iturn3_end)
7466         i1=i+1
7467         num_conti=num_cont_hb(i)
7468         num_conti1=num_cont_hb(i+1)
7469         do jj=1,num_conti
7470           j=jcont_hb(jj,i)
7471           jp=iabs(j)
7472           do kk=1,num_conti1
7473             j1=jcont_hb(kk,i1)
7474             jp1=iabs(j1)
7475 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
7476 c     &         ' jj=',jj,' kk=',kk
7477             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
7478      &          .or. j.lt.0 .and. j1.gt.0) .and.
7479      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
7480 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
7481 C The system gains extra energy.
7482               ecorr=ecorr+ehbcorr(i,jp,i+1,jp1,jj,kk,0.72D0,0.32D0)
7483               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
7484      &            'ecorrh',i,j,ehbcorr(i,j,i+1,j1,jj,kk,0.72D0,0.32D0)
7485               n_corr=n_corr+1
7486             else if (j1.eq.j) then
7487 C Contacts I-J and I-(J+1) occur simultaneously.
7488 C The system loses extra energy.
7489 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
7490             endif
7491           enddo ! kk
7492           do kk=1,num_conti
7493             j1=jcont_hb(kk,i)
7494 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
7495 c    &         ' jj=',jj,' kk=',kk
7496             if (j1.eq.j+1) then
7497 C Contacts I-J and (I+1)-J occur simultaneously.
7498 C The system loses extra energy.
7499 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
7500             endif ! j1==j+1
7501           enddo ! kk
7502         enddo ! jj
7503       enddo ! i
7504       return
7505       end
7506 c------------------------------------------------------------------------------
7507       subroutine add_hb_contact(ii,jj,itask)
7508       implicit real*8 (a-h,o-z)
7509       include "DIMENSIONS"
7510       include "COMMON.IOUNITS"
7511       integer max_cont
7512       integer max_dim
7513       parameter (max_cont=maxconts)
7514       parameter (max_dim=26)
7515       include "COMMON.CONTACTS"
7516       double precision zapas(max_dim,maxconts,max_fg_procs),
7517      &  zapas_recv(max_dim,maxconts,max_fg_procs)
7518       common /przechowalnia/ zapas
7519       integer i,j,ii,jj,iproc,itask(4),nn
7520 c      write (iout,*) "itask",itask
7521       do i=1,2
7522         iproc=itask(i)
7523         if (iproc.gt.0) then
7524           do j=1,num_cont_hb(ii)
7525             jjc=jcont_hb(j,ii)
7526 c            write (iout,*) "i",ii," j",jj," jjc",jjc
7527             if (jjc.eq.jj) then
7528               ncont_sent(iproc)=ncont_sent(iproc)+1
7529               nn=ncont_sent(iproc)
7530               zapas(1,nn,iproc)=ii
7531               zapas(2,nn,iproc)=jjc
7532               zapas(3,nn,iproc)=facont_hb(j,ii)
7533               zapas(4,nn,iproc)=ees0p(j,ii)
7534               zapas(5,nn,iproc)=ees0m(j,ii)
7535               zapas(6,nn,iproc)=gacont_hbr(1,j,ii)
7536               zapas(7,nn,iproc)=gacont_hbr(2,j,ii)
7537               zapas(8,nn,iproc)=gacont_hbr(3,j,ii)
7538               zapas(9,nn,iproc)=gacontm_hb1(1,j,ii)
7539               zapas(10,nn,iproc)=gacontm_hb1(2,j,ii)
7540               zapas(11,nn,iproc)=gacontm_hb1(3,j,ii)
7541               zapas(12,nn,iproc)=gacontp_hb1(1,j,ii)
7542               zapas(13,nn,iproc)=gacontp_hb1(2,j,ii)
7543               zapas(14,nn,iproc)=gacontp_hb1(3,j,ii)
7544               zapas(15,nn,iproc)=gacontm_hb2(1,j,ii)
7545               zapas(16,nn,iproc)=gacontm_hb2(2,j,ii)
7546               zapas(17,nn,iproc)=gacontm_hb2(3,j,ii)
7547               zapas(18,nn,iproc)=gacontp_hb2(1,j,ii)
7548               zapas(19,nn,iproc)=gacontp_hb2(2,j,ii)
7549               zapas(20,nn,iproc)=gacontp_hb2(3,j,ii)
7550               zapas(21,nn,iproc)=gacontm_hb3(1,j,ii)
7551               zapas(22,nn,iproc)=gacontm_hb3(2,j,ii)
7552               zapas(23,nn,iproc)=gacontm_hb3(3,j,ii)
7553               zapas(24,nn,iproc)=gacontp_hb3(1,j,ii)
7554               zapas(25,nn,iproc)=gacontp_hb3(2,j,ii)
7555               zapas(26,nn,iproc)=gacontp_hb3(3,j,ii)
7556               exit
7557             endif
7558           enddo
7559         endif
7560       enddo
7561       return
7562       end
7563 c------------------------------------------------------------------------------
7564       subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,
7565      &  n_corr1)
7566 C This subroutine calculates multi-body contributions to hydrogen-bonding
7567       implicit real*8 (a-h,o-z)
7568       include 'DIMENSIONS'
7569       include 'COMMON.IOUNITS'
7570 #ifdef MPI
7571       include "mpif.h"
7572       parameter (max_cont=maxconts)
7573       parameter (max_dim=70)
7574       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
7575       double precision zapas(max_dim,maxconts,max_fg_procs),
7576      &  zapas_recv(max_dim,maxconts,max_fg_procs)
7577       common /przechowalnia/ zapas
7578       integer status(MPI_STATUS_SIZE),req(maxconts*2),
7579      &  status_array(MPI_STATUS_SIZE,maxconts*2)
7580 #endif
7581       include 'COMMON.SETUP'
7582       include 'COMMON.FFIELD'
7583       include 'COMMON.DERIV'
7584       include 'COMMON.LOCAL'
7585       include 'COMMON.INTERACT'
7586       include 'COMMON.CONTACTS'
7587       include 'COMMON.CHAIN'
7588       include 'COMMON.CONTROL'
7589       double precision gx(3),gx1(3)
7590       integer num_cont_hb_old(maxres)
7591       logical lprn,ldone
7592       double precision eello4,eello5,eelo6,eello_turn6
7593       external eello4,eello5,eello6,eello_turn6
7594 C Set lprn=.true. for debugging
7595       lprn=.false.
7596       eturn6=0.0d0
7597 #ifdef MPI
7598       do i=1,nres
7599         num_cont_hb_old(i)=num_cont_hb(i)
7600       enddo
7601       n_corr=0
7602       n_corr1=0
7603       if (nfgtasks.le.1) goto 30
7604       if (lprn) then
7605         write (iout,'(a)') 'Contact function values before RECEIVE:'
7606         do i=nnt,nct-2
7607           write (iout,'(2i3,50(1x,i2,f5.2))')
7608      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
7609      &    j=1,num_cont_hb(i))
7610         enddo
7611       endif
7612       call flush(iout)
7613       do i=1,ntask_cont_from
7614         ncont_recv(i)=0
7615       enddo
7616       do i=1,ntask_cont_to
7617         ncont_sent(i)=0
7618       enddo
7619 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
7620 c     & ntask_cont_to
7621 C Make the list of contacts to send to send to other procesors
7622       do i=iturn3_start,iturn3_end
7623 c        write (iout,*) "make contact list turn3",i," num_cont",
7624 c     &    num_cont_hb(i)
7625         call add_hb_contact_eello(i,i+2,iturn3_sent_local(1,i))
7626       enddo
7627       do i=iturn4_start,iturn4_end
7628 c        write (iout,*) "make contact list turn4",i," num_cont",
7629 c     &   num_cont_hb(i)
7630         call add_hb_contact_eello(i,i+3,iturn4_sent_local(1,i))
7631       enddo
7632       do ii=1,nat_sent
7633         i=iat_sent(ii)
7634 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
7635 c     &    num_cont_hb(i)
7636         do j=1,num_cont_hb(i)
7637         do k=1,4
7638           jjc=jcont_hb(j,i)
7639           iproc=iint_sent_local(k,jjc,ii)
7640 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
7641           if (iproc.ne.0) then
7642             ncont_sent(iproc)=ncont_sent(iproc)+1
7643             nn=ncont_sent(iproc)
7644             zapas(1,nn,iproc)=i
7645             zapas(2,nn,iproc)=jjc
7646             zapas(3,nn,iproc)=d_cont(j,i)
7647             ind=3
7648             do kk=1,3
7649               ind=ind+1
7650               zapas(ind,nn,iproc)=grij_hb_cont(kk,j,i)
7651             enddo
7652             do kk=1,2
7653               do ll=1,2
7654                 ind=ind+1
7655                 zapas(ind,nn,iproc)=a_chuj(ll,kk,j,i)
7656               enddo
7657             enddo
7658             do jj=1,5
7659               do kk=1,3
7660                 do ll=1,2
7661                   do mm=1,2
7662                     ind=ind+1
7663                     zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,i)
7664                   enddo
7665                 enddo
7666               enddo
7667             enddo
7668           endif
7669         enddo
7670         enddo
7671       enddo
7672       if (lprn) then
7673       write (iout,*)
7674      &  "Numbers of contacts to be sent to other processors",
7675      &  (ncont_sent(i),i=1,ntask_cont_to)
7676       write (iout,*) "Contacts sent"
7677       do ii=1,ntask_cont_to
7678         nn=ncont_sent(ii)
7679         iproc=itask_cont_to(ii)
7680         write (iout,*) nn," contacts to processor",iproc,
7681      &   " of CONT_TO_COMM group"
7682         do i=1,nn
7683           write(iout,'(2f5.0,10f10.5)')(zapas(j,i,ii),j=1,10)
7684         enddo
7685       enddo
7686       call flush(iout)
7687       endif
7688       CorrelType=477
7689       CorrelID=fg_rank+1
7690       CorrelType1=478
7691       CorrelID1=nfgtasks+fg_rank+1
7692       ireq=0
7693 C Receive the numbers of needed contacts from other processors
7694       do ii=1,ntask_cont_from
7695         iproc=itask_cont_from(ii)
7696         ireq=ireq+1
7697         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
7698      &    FG_COMM,req(ireq),IERR)
7699       enddo
7700 c      write (iout,*) "IRECV ended"
7701 c      call flush(iout)
7702 C Send the number of contacts needed by other processors
7703       do ii=1,ntask_cont_to
7704         iproc=itask_cont_to(ii)
7705         ireq=ireq+1
7706         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
7707      &    FG_COMM,req(ireq),IERR)
7708       enddo
7709 c      write (iout,*) "ISEND ended"
7710 c      write (iout,*) "number of requests (nn)",ireq
7711       call flush(iout)
7712       if (ireq.gt.0)
7713      &  call MPI_Waitall(ireq,req,status_array,ierr)
7714 c      write (iout,*)
7715 c     &  "Numbers of contacts to be received from other processors",
7716 c     &  (ncont_recv(i),i=1,ntask_cont_from)
7717 c      call flush(iout)
7718 C Receive contacts
7719       ireq=0
7720       do ii=1,ntask_cont_from
7721         iproc=itask_cont_from(ii)
7722         nn=ncont_recv(ii)
7723 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
7724 c     &   " of CONT_TO_COMM group"
7725         call flush(iout)
7726         if (nn.gt.0) then
7727           ireq=ireq+1
7728           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
7729      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
7730 c          write (iout,*) "ireq,req",ireq,req(ireq)
7731         endif
7732       enddo
7733 C Send the contacts to processors that need them
7734       do ii=1,ntask_cont_to
7735         iproc=itask_cont_to(ii)
7736         nn=ncont_sent(ii)
7737 c        write (iout,*) nn," contacts to processor",iproc,
7738 c     &   " of CONT_TO_COMM group"
7739         if (nn.gt.0) then
7740           ireq=ireq+1
7741           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
7742      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
7743 c          write (iout,*) "ireq,req",ireq,req(ireq)
7744 c          do i=1,nn
7745 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
7746 c          enddo
7747         endif
7748       enddo
7749 c      write (iout,*) "number of requests (contacts)",ireq
7750 c      write (iout,*) "req",(req(i),i=1,4)
7751 c      call flush(iout)
7752       if (ireq.gt.0)
7753      & call MPI_Waitall(ireq,req,status_array,ierr)
7754       do iii=1,ntask_cont_from
7755         iproc=itask_cont_from(iii)
7756         nn=ncont_recv(iii)
7757         if (lprn) then
7758         write (iout,*) "Received",nn," contacts from processor",iproc,
7759      &   " of CONT_FROM_COMM group"
7760         call flush(iout)
7761         do i=1,nn
7762           write(iout,'(2f5.0,10f10.5)')(zapas_recv(j,i,iii),j=1,10)
7763         enddo
7764         call flush(iout)
7765         endif
7766         do i=1,nn
7767           ii=zapas_recv(1,i,iii)
7768 c Flag the received contacts to prevent double-counting
7769           jj=-zapas_recv(2,i,iii)
7770 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
7771 c          call flush(iout)
7772           nnn=num_cont_hb(ii)+1
7773           num_cont_hb(ii)=nnn
7774           jcont_hb(nnn,ii)=jj
7775           d_cont(nnn,ii)=zapas_recv(3,i,iii)
7776           ind=3
7777           do kk=1,3
7778             ind=ind+1
7779             grij_hb_cont(kk,nnn,ii)=zapas_recv(ind,i,iii)
7780           enddo
7781           do kk=1,2
7782             do ll=1,2
7783               ind=ind+1
7784               a_chuj(ll,kk,nnn,ii)=zapas_recv(ind,i,iii)
7785             enddo
7786           enddo
7787           do jj=1,5
7788             do kk=1,3
7789               do ll=1,2
7790                 do mm=1,2
7791                   ind=ind+1
7792                   a_chuj_der(mm,ll,kk,jj,nnn,ii)=zapas_recv(ind,i,iii)
7793                 enddo
7794               enddo
7795             enddo
7796           enddo
7797         enddo
7798       enddo
7799       call flush(iout)
7800       if (lprn) then
7801         write (iout,'(a)') 'Contact function values after receive:'
7802         do i=nnt,nct-2
7803           write (iout,'(2i3,50(1x,i3,5f6.3))')
7804      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
7805      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
7806         enddo
7807         call flush(iout)
7808       endif
7809    30 continue
7810 #endif
7811       if (lprn) then
7812         write (iout,'(a)') 'Contact function values:'
7813         do i=nnt,nct-2
7814           write (iout,'(2i3,50(1x,i2,5f6.3))')
7815      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
7816      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
7817         enddo
7818       endif
7819       ecorr=0.0D0
7820       ecorr5=0.0d0
7821       ecorr6=0.0d0
7822 C Remove the loop below after debugging !!!
7823       do i=nnt,nct
7824         do j=1,3
7825           gradcorr(j,i)=0.0D0
7826           gradxorr(j,i)=0.0D0
7827         enddo
7828       enddo
7829 C Calculate the dipole-dipole interaction energies
7830       if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
7831       do i=iatel_s,iatel_e+1
7832         num_conti=num_cont_hb(i)
7833         do jj=1,num_conti
7834           j=jcont_hb(jj,i)
7835 #ifdef MOMENT
7836           call dipole(i,j,jj)
7837 #endif
7838         enddo
7839       enddo
7840       endif
7841 C Calculate the local-electrostatic correlation terms
7842 c                write (iout,*) "gradcorr5 in eello5 before loop"
7843 c                do iii=1,nres
7844 c                  write (iout,'(i5,3f10.5)')
7845 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
7846 c                enddo
7847       do i=min0(iatel_s,iturn4_start),max0(iatel_e+1,iturn3_end+1)
7848 c        write (iout,*) "corr loop i",i
7849         i1=i+1
7850         num_conti=num_cont_hb(i)
7851         num_conti1=num_cont_hb(i+1)
7852         do jj=1,num_conti
7853           j=jcont_hb(jj,i)
7854           jp=iabs(j)
7855           do kk=1,num_conti1
7856             j1=jcont_hb(kk,i1)
7857             jp1=iabs(j1)
7858 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
7859 c     &         ' jj=',jj,' kk=',kk
7860 c            if (j1.eq.j+1 .or. j1.eq.j-1) then
7861             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
7862      &          .or. j.lt.0 .and. j1.gt.0) .and.
7863      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
7864 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
7865 C The system gains extra energy.
7866               n_corr=n_corr+1
7867               sqd1=dsqrt(d_cont(jj,i))
7868               sqd2=dsqrt(d_cont(kk,i1))
7869               sred_geom = sqd1*sqd2
7870               IF (sred_geom.lt.cutoff_corr) THEN
7871                 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,
7872      &            ekont,fprimcont)
7873 cd               write (iout,*) 'i=',i,' j=',jp,' i1=',i1,' j1=',jp1,
7874 cd     &         ' jj=',jj,' kk=',kk
7875                 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
7876                 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
7877                 do l=1,3
7878                   g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
7879                   g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
7880                 enddo
7881                 n_corr1=n_corr1+1
7882 cd               write (iout,*) 'sred_geom=',sred_geom,
7883 cd     &          ' ekont=',ekont,' fprim=',fprimcont,
7884 cd     &          ' fac_prim1',fac_prim1,' fac_prim2',fac_prim2
7885 cd               write (iout,*) "g_contij",g_contij
7886 cd               write (iout,*) "grij_hb_cont i",grij_hb_cont(:,jj,i)
7887 cd               write (iout,*) "grij_hb_cont i1",grij_hb_cont(:,jj,i1)
7888                 call calc_eello(i,jp,i+1,jp1,jj,kk)
7889                 if (wcorr4.gt.0.0d0)
7890      &            ecorr=ecorr+eello4(i,jp,i+1,jp1,jj,kk)
7891                   if (energy_dec.and.wcorr4.gt.0.0d0)
7892      1                 write (iout,'(a6,4i5,0pf7.3)')
7893      2                'ecorr4',i,j,i+1,j1,eello4(i,jp,i+1,jp1,jj,kk)
7894 c                write (iout,*) "gradcorr5 before eello5"
7895 c                do iii=1,nres
7896 c                  write (iout,'(i5,3f10.5)')
7897 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
7898 c                enddo
7899                 if (wcorr5.gt.0.0d0)
7900      &            ecorr5=ecorr5+eello5(i,jp,i+1,jp1,jj,kk)
7901 c                write (iout,*) "gradcorr5 after eello5"
7902 c                do iii=1,nres
7903 c                  write (iout,'(i5,3f10.5)')
7904 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
7905 c                enddo
7906                   if (energy_dec.and.wcorr5.gt.0.0d0)
7907      1                 write (iout,'(a6,4i5,0pf7.3)')
7908      2                'ecorr5',i,j,i+1,j1,eello5(i,jp,i+1,jp1,jj,kk)
7909 cd                write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
7910 cd                write(2,*)'ijkl',i,jp,i+1,jp1
7911                 if (wcorr6.gt.0.0d0 .and. (jp.ne.i+4 .or. jp1.ne.i+3
7912      &               .or. wturn6.eq.0.0d0))then
7913 cd                  write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
7914                   ecorr6=ecorr6+eello6(i,jp,i+1,jp1,jj,kk)
7915                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
7916      1                'ecorr6',i,j,i+1,j1,eello6(i,jp,i+1,jp1,jj,kk)
7917 cd                write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
7918 cd     &            'ecorr6=',ecorr6
7919 cd                write (iout,'(4e15.5)') sred_geom,
7920 cd     &          dabs(eello4(i,jp,i+1,jp1,jj,kk)),
7921 cd     &          dabs(eello5(i,jp,i+1,jp1,jj,kk)),
7922 cd     &          dabs(eello6(i,jp,i+1,jp1,jj,kk))
7923                 else if (wturn6.gt.0.0d0
7924      &            .and. (jp.eq.i+4 .and. jp1.eq.i+3)) then
7925 cd                  write (iout,*) '******eturn6: i,j,i+1,j1',i,jip,i+1,jp1
7926                   eturn6=eturn6+eello_turn6(i,jj,kk)
7927                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
7928      1                 'eturn6',i,j,i+1,j1,eello_turn6(i,jj,kk)
7929 cd                  write (2,*) 'multibody_eello:eturn6',eturn6
7930                 endif
7931               ENDIF
7932 1111          continue
7933             endif
7934           enddo ! kk
7935         enddo ! jj
7936       enddo ! i
7937       do i=1,nres
7938         num_cont_hb(i)=num_cont_hb_old(i)
7939       enddo
7940 c                write (iout,*) "gradcorr5 in eello5"
7941 c                do iii=1,nres
7942 c                  write (iout,'(i5,3f10.5)')
7943 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
7944 c                enddo
7945       return
7946       end
7947 c------------------------------------------------------------------------------
7948       subroutine add_hb_contact_eello(ii,jj,itask)
7949       implicit real*8 (a-h,o-z)
7950       include "DIMENSIONS"
7951       include "COMMON.IOUNITS"
7952       integer max_cont
7953       integer max_dim
7954       parameter (max_cont=maxconts)
7955       parameter (max_dim=70)
7956       include "COMMON.CONTACTS"
7957       double precision zapas(max_dim,maxconts,max_fg_procs),
7958      &  zapas_recv(max_dim,maxconts,max_fg_procs)
7959       common /przechowalnia/ zapas
7960       integer i,j,ii,jj,iproc,itask(4),nn
7961 c      write (iout,*) "itask",itask
7962       do i=1,2
7963         iproc=itask(i)
7964         if (iproc.gt.0) then
7965           do j=1,num_cont_hb(ii)
7966             jjc=jcont_hb(j,ii)
7967 c            write (iout,*) "send turns i",ii," j",jj," jjc",jjc
7968             if (jjc.eq.jj) then
7969               ncont_sent(iproc)=ncont_sent(iproc)+1
7970               nn=ncont_sent(iproc)
7971               zapas(1,nn,iproc)=ii
7972               zapas(2,nn,iproc)=jjc
7973               zapas(3,nn,iproc)=d_cont(j,ii)
7974               ind=3
7975               do kk=1,3
7976                 ind=ind+1
7977                 zapas(ind,nn,iproc)=grij_hb_cont(kk,j,ii)
7978               enddo
7979               do kk=1,2
7980                 do ll=1,2
7981                   ind=ind+1
7982                   zapas(ind,nn,iproc)=a_chuj(ll,kk,j,ii)
7983                 enddo
7984               enddo
7985               do jj=1,5
7986                 do kk=1,3
7987                   do ll=1,2
7988                     do mm=1,2
7989                       ind=ind+1
7990                       zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,ii)
7991                     enddo
7992                   enddo
7993                 enddo
7994               enddo
7995               exit
7996             endif
7997           enddo
7998         endif
7999       enddo
8000       return
8001       end
8002 c------------------------------------------------------------------------------
8003       double precision function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
8004       implicit real*8 (a-h,o-z)
8005       include 'DIMENSIONS'
8006       include 'COMMON.IOUNITS'
8007       include 'COMMON.DERIV'
8008       include 'COMMON.INTERACT'
8009       include 'COMMON.CONTACTS'
8010       double precision gx(3),gx1(3)
8011       logical lprn
8012       lprn=.false.
8013       eij=facont_hb(jj,i)
8014       ekl=facont_hb(kk,k)
8015       ees0pij=ees0p(jj,i)
8016       ees0pkl=ees0p(kk,k)
8017       ees0mij=ees0m(jj,i)
8018       ees0mkl=ees0m(kk,k)
8019       ekont=eij*ekl
8020       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
8021 cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
8022 C Following 4 lines for diagnostics.
8023 cd    ees0pkl=0.0D0
8024 cd    ees0pij=1.0D0
8025 cd    ees0mkl=0.0D0
8026 cd    ees0mij=1.0D0
8027 c      write (iout,'(2(a,2i3,a,f10.5,a,2f10.5),a,f10.5,a,$)')
8028 c     & 'Contacts ',i,j,
8029 c     & ' eij',eij,' eesij',ees0pij,ees0mij,' and ',k,l
8030 c     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' energy=',ekont*ees,
8031 c     & 'gradcorr_long'
8032 C Calculate the multi-body contribution to energy.
8033 c      ecorr=ecorr+ekont*ees
8034 C Calculate multi-body contributions to the gradient.
8035       coeffpees0pij=coeffp*ees0pij
8036       coeffmees0mij=coeffm*ees0mij
8037       coeffpees0pkl=coeffp*ees0pkl
8038       coeffmees0mkl=coeffm*ees0mkl
8039       do ll=1,3
8040 cgrad        ghalfi=ees*ekl*gacont_hbr(ll,jj,i)
8041         gradcorr(ll,i)=gradcorr(ll,i)!+0.5d0*ghalfi
8042      &  -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+
8043      &  coeffmees0mkl*gacontm_hb1(ll,jj,i))
8044         gradcorr(ll,j)=gradcorr(ll,j)!+0.5d0*ghalfi
8045      &  -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+
8046      &  coeffmees0mkl*gacontm_hb2(ll,jj,i))
8047 cgrad        ghalfk=ees*eij*gacont_hbr(ll,kk,k)
8048         gradcorr(ll,k)=gradcorr(ll,k)!+0.5d0*ghalfk
8049      &  -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+
8050      &  coeffmees0mij*gacontm_hb1(ll,kk,k))
8051         gradcorr(ll,l)=gradcorr(ll,l)!+0.5d0*ghalfk
8052      &  -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+
8053      &  coeffmees0mij*gacontm_hb2(ll,kk,k))
8054         gradlongij=ees*ekl*gacont_hbr(ll,jj,i)-
8055      &     ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+
8056      &     coeffmees0mkl*gacontm_hb3(ll,jj,i))
8057         gradcorr_long(ll,j)=gradcorr_long(ll,j)+gradlongij
8058         gradcorr_long(ll,i)=gradcorr_long(ll,i)-gradlongij
8059         gradlongkl=ees*eij*gacont_hbr(ll,kk,k)-
8060      &     ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+
8061      &     coeffmees0mij*gacontm_hb3(ll,kk,k))
8062         gradcorr_long(ll,l)=gradcorr_long(ll,l)+gradlongkl
8063         gradcorr_long(ll,k)=gradcorr_long(ll,k)-gradlongkl
8064 c        write (iout,'(2f10.5,2x,$)') gradlongij,gradlongkl
8065       enddo
8066 c      write (iout,*)
8067 cgrad      do m=i+1,j-1
8068 cgrad        do ll=1,3
8069 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
8070 cgrad     &     ees*ekl*gacont_hbr(ll,jj,i)-
8071 cgrad     &     ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
8072 cgrad     &     coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
8073 cgrad        enddo
8074 cgrad      enddo
8075 cgrad      do m=k+1,l-1
8076 cgrad        do ll=1,3
8077 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
8078 cgrad     &     ees*eij*gacont_hbr(ll,kk,k)-
8079 cgrad     &     ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
8080 cgrad     &     coeffm*ees0mij*gacontm_hb3(ll,kk,k))
8081 cgrad        enddo
8082 cgrad      enddo
8083 c      write (iout,*) "ehbcorr",ekont*ees
8084       ehbcorr=ekont*ees
8085       return
8086       end
8087 #ifdef MOMENT
8088 C---------------------------------------------------------------------------
8089       subroutine dipole(i,j,jj)
8090       implicit real*8 (a-h,o-z)
8091       include 'DIMENSIONS'
8092       include 'COMMON.IOUNITS'
8093       include 'COMMON.CHAIN'
8094       include 'COMMON.FFIELD'
8095       include 'COMMON.DERIV'
8096       include 'COMMON.INTERACT'
8097       include 'COMMON.CONTACTS'
8098       include 'COMMON.TORSION'
8099       include 'COMMON.VAR'
8100       include 'COMMON.GEO'
8101       dimension dipi(2,2),dipj(2,2),dipderi(2),dipderj(2),auxvec(2),
8102      &  auxmat(2,2)
8103       iti1 = itortyp(itype(i+1))
8104       if (j.lt.nres-1) then
8105         itj1 = itortyp(itype(j+1))
8106       else
8107         itj1=ntortyp
8108       endif
8109       do iii=1,2
8110         dipi(iii,1)=Ub2(iii,i)
8111         dipderi(iii)=Ub2der(iii,i)
8112         dipi(iii,2)=b1(iii,i+1)
8113         dipj(iii,1)=Ub2(iii,j)
8114         dipderj(iii)=Ub2der(iii,j)
8115         dipj(iii,2)=b1(iii,j+1)
8116       enddo
8117       kkk=0
8118       do iii=1,2
8119         call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
8120         do jjj=1,2
8121           kkk=kkk+1
8122           dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
8123         enddo
8124       enddo
8125       do kkk=1,5
8126         do lll=1,3
8127           mmm=0
8128           do iii=1,2
8129             call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),
8130      &        auxvec(1))
8131             do jjj=1,2
8132               mmm=mmm+1
8133               dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
8134             enddo
8135           enddo
8136         enddo
8137       enddo
8138       call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
8139       call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
8140       do iii=1,2
8141         dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
8142       enddo
8143       call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
8144       do iii=1,2
8145         dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
8146       enddo
8147       return
8148       end
8149 #endif
8150 C---------------------------------------------------------------------------
8151       subroutine calc_eello(i,j,k,l,jj,kk)
8152 C
8153 C This subroutine computes matrices and vectors needed to calculate
8154 C the fourth-, fifth-, and sixth-order local-electrostatic terms.
8155 C
8156       implicit real*8 (a-h,o-z)
8157       include 'DIMENSIONS'
8158       include 'COMMON.IOUNITS'
8159       include 'COMMON.CHAIN'
8160       include 'COMMON.DERIV'
8161       include 'COMMON.INTERACT'
8162       include 'COMMON.CONTACTS'
8163       include 'COMMON.TORSION'
8164       include 'COMMON.VAR'
8165       include 'COMMON.GEO'
8166       include 'COMMON.FFIELD'
8167       double precision aa1(2,2),aa2(2,2),aa1t(2,2),aa2t(2,2),
8168      &  aa1tder(2,2,3,5),aa2tder(2,2,3,5),auxmat(2,2)
8169       logical lprn
8170       common /kutas/ lprn
8171 cd      write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
8172 cd     & ' jj=',jj,' kk=',kk
8173 cd      if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
8174 cd      write (iout,*) "a_chujij",((a_chuj(iii,jjj,jj,i),iii=1,2),jjj=1,2)
8175 cd      write (iout,*) "a_chujkl",((a_chuj(iii,jjj,kk,k),iii=1,2),jjj=1,2)
8176       do iii=1,2
8177         do jjj=1,2
8178           aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
8179           aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
8180         enddo
8181       enddo
8182       call transpose2(aa1(1,1),aa1t(1,1))
8183       call transpose2(aa2(1,1),aa2t(1,1))
8184       do kkk=1,5
8185         do lll=1,3
8186           call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),
8187      &      aa1tder(1,1,lll,kkk))
8188           call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),
8189      &      aa2tder(1,1,lll,kkk))
8190         enddo
8191       enddo
8192       if (l.eq.j+1) then
8193 C parallel orientation of the two CA-CA-CA frames.
8194         if (i.gt.1) then
8195           iti=itortyp(itype(i))
8196         else
8197           iti=ntortyp
8198         endif
8199         itk1=itortyp(itype(k+1))
8200         itj=itortyp(itype(j))
8201         if (l.lt.nres-1) then
8202           itl1=itortyp(itype(l+1))
8203         else
8204           itl1=ntortyp
8205         endif
8206 C A1 kernel(j+1) A2T
8207 cd        do iii=1,2
8208 cd          write (iout,'(3f10.5,5x,3f10.5)')
8209 cd     &     (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
8210 cd        enddo
8211         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
8212      &   aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),
8213      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
8214 C Following matrices are needed only for 6-th order cumulants
8215         IF (wcorr6.gt.0.0d0) THEN
8216         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
8217      &   aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),
8218      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
8219         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
8220      &   aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),
8221      &   Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
8222      &   ADtEAderx(1,1,1,1,1,1))
8223         lprn=.false.
8224         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
8225      &   aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),
8226      &   DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
8227      &   ADtEA1derx(1,1,1,1,1,1))
8228         ENDIF
8229 C End 6-th order cumulants
8230 cd        lprn=.false.
8231 cd        if (lprn) then
8232 cd        write (2,*) 'In calc_eello6'
8233 cd        do iii=1,2
8234 cd          write (2,*) 'iii=',iii
8235 cd          do kkk=1,5
8236 cd            write (2,*) 'kkk=',kkk
8237 cd            do jjj=1,2
8238 cd              write (2,'(3(2f10.5),5x)')
8239 cd     &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
8240 cd            enddo
8241 cd          enddo
8242 cd        enddo
8243 cd        endif
8244         call transpose2(EUgder(1,1,k),auxmat(1,1))
8245         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
8246         call transpose2(EUg(1,1,k),auxmat(1,1))
8247         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
8248         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
8249         do iii=1,2
8250           do kkk=1,5
8251             do lll=1,3
8252               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
8253      &          EAEAderx(1,1,lll,kkk,iii,1))
8254             enddo
8255           enddo
8256         enddo
8257 C A1T kernel(i+1) A2
8258         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
8259      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),
8260      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
8261 C Following matrices are needed only for 6-th order cumulants
8262         IF (wcorr6.gt.0.0d0) THEN
8263         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
8264      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),
8265      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
8266         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
8267      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),
8268      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
8269      &   ADtEAderx(1,1,1,1,1,2))
8270         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
8271      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),
8272      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
8273      &   ADtEA1derx(1,1,1,1,1,2))
8274         ENDIF
8275 C End 6-th order cumulants
8276         call transpose2(EUgder(1,1,l),auxmat(1,1))
8277         call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
8278         call transpose2(EUg(1,1,l),auxmat(1,1))
8279         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
8280         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
8281         do iii=1,2
8282           do kkk=1,5
8283             do lll=1,3
8284               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
8285      &          EAEAderx(1,1,lll,kkk,iii,2))
8286             enddo
8287           enddo
8288         enddo
8289 C AEAb1 and AEAb2
8290 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
8291 C They are needed only when the fifth- or the sixth-order cumulants are
8292 C indluded.
8293         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
8294         call transpose2(AEA(1,1,1),auxmat(1,1))
8295         call matvec2(auxmat(1,1),b1(1,i),AEAb1(1,1,1))
8296         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
8297         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
8298         call transpose2(AEAderg(1,1,1),auxmat(1,1))
8299         call matvec2(auxmat(1,1),b1(1,i),AEAb1derg(1,1,1))
8300         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
8301         call matvec2(AEA(1,1,1),b1(1,k+1),AEAb1(1,2,1))
8302         call matvec2(AEAderg(1,1,1),b1(1,k+1),AEAb1derg(1,2,1))
8303         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
8304         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
8305         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
8306         call transpose2(AEA(1,1,2),auxmat(1,1))
8307         call matvec2(auxmat(1,1),b1(1,j),AEAb1(1,1,2))
8308         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
8309         call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
8310         call transpose2(AEAderg(1,1,2),auxmat(1,1))
8311         call matvec2(auxmat(1,1),b1(1,j),AEAb1derg(1,1,2))
8312         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
8313         call matvec2(AEA(1,1,2),b1(1,l+1),AEAb1(1,2,2))
8314         call matvec2(AEAderg(1,1,2),b1(1,l+1),AEAb1derg(1,2,2))
8315         call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
8316         call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
8317         call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
8318 C Calculate the Cartesian derivatives of the vectors.
8319         do iii=1,2
8320           do kkk=1,5
8321             do lll=1,3
8322               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
8323               call matvec2(auxmat(1,1),b1(1,i),
8324      &          AEAb1derx(1,lll,kkk,iii,1,1))
8325               call matvec2(auxmat(1,1),Ub2(1,i),
8326      &          AEAb2derx(1,lll,kkk,iii,1,1))
8327               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
8328      &          AEAb1derx(1,lll,kkk,iii,2,1))
8329               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
8330      &          AEAb2derx(1,lll,kkk,iii,2,1))
8331               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
8332               call matvec2(auxmat(1,1),b1(1,j),
8333      &          AEAb1derx(1,lll,kkk,iii,1,2))
8334               call matvec2(auxmat(1,1),Ub2(1,j),
8335      &          AEAb2derx(1,lll,kkk,iii,1,2))
8336               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,l+1),
8337      &          AEAb1derx(1,lll,kkk,iii,2,2))
8338               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),
8339      &          AEAb2derx(1,lll,kkk,iii,2,2))
8340             enddo
8341           enddo
8342         enddo
8343         ENDIF
8344 C End vectors
8345       else
8346 C Antiparallel orientation of the two CA-CA-CA frames.
8347         if (i.gt.1) then
8348           iti=itortyp(itype(i))
8349         else
8350           iti=ntortyp
8351         endif
8352         itk1=itortyp(itype(k+1))
8353         itl=itortyp(itype(l))
8354         itj=itortyp(itype(j))
8355         if (j.lt.nres-1) then
8356           itj1=itortyp(itype(j+1))
8357         else
8358           itj1=ntortyp
8359         endif
8360 C A2 kernel(j-1)T A1T
8361         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
8362      &   aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),
8363      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
8364 C Following matrices are needed only for 6-th order cumulants
8365         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
8366      &     j.eq.i+4 .and. l.eq.i+3)) THEN
8367         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
8368      &   aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),
8369      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
8370         call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
8371      &   aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),
8372      &   Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
8373      &   ADtEAderx(1,1,1,1,1,1))
8374         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
8375      &   aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),
8376      &   DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
8377      &   ADtEA1derx(1,1,1,1,1,1))
8378         ENDIF
8379 C End 6-th order cumulants
8380         call transpose2(EUgder(1,1,k),auxmat(1,1))
8381         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
8382         call transpose2(EUg(1,1,k),auxmat(1,1))
8383         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
8384         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
8385         do iii=1,2
8386           do kkk=1,5
8387             do lll=1,3
8388               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
8389      &          EAEAderx(1,1,lll,kkk,iii,1))
8390             enddo
8391           enddo
8392         enddo
8393 C A2T kernel(i+1)T A1
8394         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
8395      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),
8396      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
8397 C Following matrices are needed only for 6-th order cumulants
8398         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
8399      &     j.eq.i+4 .and. l.eq.i+3)) THEN
8400         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
8401      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),
8402      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
8403         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
8404      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),
8405      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
8406      &   ADtEAderx(1,1,1,1,1,2))
8407         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
8408      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),
8409      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
8410      &   ADtEA1derx(1,1,1,1,1,2))
8411         ENDIF
8412 C End 6-th order cumulants
8413         call transpose2(EUgder(1,1,j),auxmat(1,1))
8414         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
8415         call transpose2(EUg(1,1,j),auxmat(1,1))
8416         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
8417         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
8418         do iii=1,2
8419           do kkk=1,5
8420             do lll=1,3
8421               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
8422      &          EAEAderx(1,1,lll,kkk,iii,2))
8423             enddo
8424           enddo
8425         enddo
8426 C AEAb1 and AEAb2
8427 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
8428 C They are needed only when the fifth- or the sixth-order cumulants are
8429 C indluded.
8430         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or.
8431      &    (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
8432         call transpose2(AEA(1,1,1),auxmat(1,1))
8433         call matvec2(auxmat(1,1),b1(1,i),AEAb1(1,1,1))
8434         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
8435         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
8436         call transpose2(AEAderg(1,1,1),auxmat(1,1))
8437         call matvec2(auxmat(1,1),b1(1,i),AEAb1derg(1,1,1))
8438         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
8439         call matvec2(AEA(1,1,1),b1(1,k+1),AEAb1(1,2,1))
8440         call matvec2(AEAderg(1,1,1),b1(1,k+1),AEAb1derg(1,2,1))
8441         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
8442         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
8443         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
8444         call transpose2(AEA(1,1,2),auxmat(1,1))
8445         call matvec2(auxmat(1,1),b1(1,j+1),AEAb1(1,1,2))
8446         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
8447         call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
8448         call transpose2(AEAderg(1,1,2),auxmat(1,1))
8449         call matvec2(auxmat(1,1),b1(1,l),AEAb1(1,1,2))
8450         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
8451         call matvec2(AEA(1,1,2),b1(1,j+1),AEAb1(1,2,2))
8452         call matvec2(AEAderg(1,1,2),b1(1,j+1),AEAb1derg(1,2,2))
8453         call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
8454         call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
8455         call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
8456 C Calculate the Cartesian derivatives of the vectors.
8457         do iii=1,2
8458           do kkk=1,5
8459             do lll=1,3
8460               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
8461               call matvec2(auxmat(1,1),b1(1,i),
8462      &          AEAb1derx(1,lll,kkk,iii,1,1))
8463               call matvec2(auxmat(1,1),Ub2(1,i),
8464      &          AEAb2derx(1,lll,kkk,iii,1,1))
8465               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
8466      &          AEAb1derx(1,lll,kkk,iii,2,1))
8467               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
8468      &          AEAb2derx(1,lll,kkk,iii,2,1))
8469               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
8470               call matvec2(auxmat(1,1),b1(1,l),
8471      &          AEAb1derx(1,lll,kkk,iii,1,2))
8472               call matvec2(auxmat(1,1),Ub2(1,l),
8473      &          AEAb2derx(1,lll,kkk,iii,1,2))
8474               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,j+1),
8475      &          AEAb1derx(1,lll,kkk,iii,2,2))
8476               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),
8477      &          AEAb2derx(1,lll,kkk,iii,2,2))
8478             enddo
8479           enddo
8480         enddo
8481         ENDIF
8482 C End vectors
8483       endif
8484       return
8485       end
8486 C---------------------------------------------------------------------------
8487       subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,
8488      &  KK,KKderg,AKA,AKAderg,AKAderx)
8489       implicit none
8490       integer nderg
8491       logical transp
8492       double precision aa1(2,2),aa2t(2,2),aa1derx(2,2,3,5),
8493      &  aa2tderx(2,2,3,5),KK(2,2),KKderg(2,2,nderg),AKA(2,2),
8494      &  AKAderg(2,2,nderg),AKAderx(2,2,3,5,2)
8495       integer iii,kkk,lll
8496       integer jjj,mmm
8497       logical lprn
8498       common /kutas/ lprn
8499       call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
8500       do iii=1,nderg
8501         call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,
8502      &    AKAderg(1,1,iii))
8503       enddo
8504 cd      if (lprn) write (2,*) 'In kernel'
8505       do kkk=1,5
8506 cd        if (lprn) write (2,*) 'kkk=',kkk
8507         do lll=1,3
8508           call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),
8509      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
8510 cd          if (lprn) then
8511 cd            write (2,*) 'lll=',lll
8512 cd            write (2,*) 'iii=1'
8513 cd            do jjj=1,2
8514 cd              write (2,'(3(2f10.5),5x)')
8515 cd     &        (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
8516 cd            enddo
8517 cd          endif
8518           call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),
8519      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
8520 cd          if (lprn) then
8521 cd            write (2,*) 'lll=',lll
8522 cd            write (2,*) 'iii=2'
8523 cd            do jjj=1,2
8524 cd              write (2,'(3(2f10.5),5x)')
8525 cd     &        (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
8526 cd            enddo
8527 cd          endif
8528         enddo
8529       enddo
8530       return
8531       end
8532 C---------------------------------------------------------------------------
8533       double precision function eello4(i,j,k,l,jj,kk)
8534       implicit real*8 (a-h,o-z)
8535       include 'DIMENSIONS'
8536       include 'COMMON.IOUNITS'
8537       include 'COMMON.CHAIN'
8538       include 'COMMON.DERIV'
8539       include 'COMMON.INTERACT'
8540       include 'COMMON.CONTACTS'
8541       include 'COMMON.TORSION'
8542       include 'COMMON.VAR'
8543       include 'COMMON.GEO'
8544       double precision pizda(2,2),ggg1(3),ggg2(3)
8545 cd      if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
8546 cd        eello4=0.0d0
8547 cd        return
8548 cd      endif
8549 cd      print *,'eello4:',i,j,k,l,jj,kk
8550 cd      write (2,*) 'i',i,' j',j,' k',k,' l',l
8551 cd      call checkint4(i,j,k,l,jj,kk,eel4_num)
8552 cold      eij=facont_hb(jj,i)
8553 cold      ekl=facont_hb(kk,k)
8554 cold      ekont=eij*ekl
8555       eel4=-EAEA(1,1,1)-EAEA(2,2,1)
8556 cd      eel41=-EAEA(1,1,2)-EAEA(2,2,2)
8557       gcorr_loc(k-1)=gcorr_loc(k-1)
8558      &   -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
8559       if (l.eq.j+1) then
8560         gcorr_loc(l-1)=gcorr_loc(l-1)
8561      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
8562       else
8563         gcorr_loc(j-1)=gcorr_loc(j-1)
8564      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
8565       endif
8566       do iii=1,2
8567         do kkk=1,5
8568           do lll=1,3
8569             derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1)
8570      &                        -EAEAderx(2,2,lll,kkk,iii,1)
8571 cd            derx(lll,kkk,iii)=0.0d0
8572           enddo
8573         enddo
8574       enddo
8575 cd      gcorr_loc(l-1)=0.0d0
8576 cd      gcorr_loc(j-1)=0.0d0
8577 cd      gcorr_loc(k-1)=0.0d0
8578 cd      eel4=1.0d0
8579 cd      write (iout,*)'Contacts have occurred for peptide groups',
8580 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l,
8581 cd     &  ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
8582       if (j.lt.nres-1) then
8583         j1=j+1
8584         j2=j-1
8585       else
8586         j1=j-1
8587         j2=j-2
8588       endif
8589       if (l.lt.nres-1) then
8590         l1=l+1
8591         l2=l-1
8592       else
8593         l1=l-1
8594         l2=l-2
8595       endif
8596       do ll=1,3
8597 cgrad        ggg1(ll)=eel4*g_contij(ll,1)
8598 cgrad        ggg2(ll)=eel4*g_contij(ll,2)
8599         glongij=eel4*g_contij(ll,1)+ekont*derx(ll,1,1)
8600         glongkl=eel4*g_contij(ll,2)+ekont*derx(ll,1,2)
8601 cgrad        ghalf=0.5d0*ggg1(ll)
8602         gradcorr(ll,i)=gradcorr(ll,i)+ekont*derx(ll,2,1)
8603         gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
8604         gradcorr(ll,j)=gradcorr(ll,j)+ekont*derx(ll,4,1)
8605         gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
8606         gradcorr_long(ll,j)=gradcorr_long(ll,j)+glongij
8607         gradcorr_long(ll,i)=gradcorr_long(ll,i)-glongij
8608 cgrad        ghalf=0.5d0*ggg2(ll)
8609         gradcorr(ll,k)=gradcorr(ll,k)+ekont*derx(ll,2,2)
8610         gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
8611         gradcorr(ll,l)=gradcorr(ll,l)+ekont*derx(ll,4,2)
8612         gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
8613         gradcorr_long(ll,l)=gradcorr_long(ll,l)+glongkl
8614         gradcorr_long(ll,k)=gradcorr_long(ll,k)-glongkl
8615       enddo
8616 cgrad      do m=i+1,j-1
8617 cgrad        do ll=1,3
8618 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
8619 cgrad        enddo
8620 cgrad      enddo
8621 cgrad      do m=k+1,l-1
8622 cgrad        do ll=1,3
8623 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
8624 cgrad        enddo
8625 cgrad      enddo
8626 cgrad      do m=i+2,j2
8627 cgrad        do ll=1,3
8628 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
8629 cgrad        enddo
8630 cgrad      enddo
8631 cgrad      do m=k+2,l2
8632 cgrad        do ll=1,3
8633 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
8634 cgrad        enddo
8635 cgrad      enddo
8636 cd      do iii=1,nres-3
8637 cd        write (2,*) iii,gcorr_loc(iii)
8638 cd      enddo
8639       eello4=ekont*eel4
8640 cd      write (2,*) 'ekont',ekont
8641 cd      write (iout,*) 'eello4',ekont*eel4
8642       return
8643       end
8644 C---------------------------------------------------------------------------
8645       double precision function eello5(i,j,k,l,jj,kk)
8646       implicit real*8 (a-h,o-z)
8647       include 'DIMENSIONS'
8648       include 'COMMON.IOUNITS'
8649       include 'COMMON.CHAIN'
8650       include 'COMMON.DERIV'
8651       include 'COMMON.INTERACT'
8652       include 'COMMON.CONTACTS'
8653       include 'COMMON.TORSION'
8654       include 'COMMON.VAR'
8655       include 'COMMON.GEO'
8656       double precision pizda(2,2),auxmat(2,2),auxmat1(2,2),vv(2)
8657       double precision ggg1(3),ggg2(3)
8658 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8659 C                                                                              C
8660 C                            Parallel chains                                   C
8661 C                                                                              C
8662 C          o             o                   o             o                   C
8663 C         /l\           / \             \   / \           / \   /              C
8664 C        /   \         /   \             \ /   \         /   \ /               C
8665 C       j| o |l1       | o |              o| o |         | o |o                C
8666 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
8667 C      \i/   \         /   \ /             /   \         /   \                 C
8668 C       o    k1             o                                                  C
8669 C         (I)          (II)                (III)          (IV)                 C
8670 C                                                                              C
8671 C      eello5_1        eello5_2            eello5_3       eello5_4             C
8672 C                                                                              C
8673 C                            Antiparallel chains                               C
8674 C                                                                              C
8675 C          o             o                   o             o                   C
8676 C         /j\           / \             \   / \           / \   /              C
8677 C        /   \         /   \             \ /   \         /   \ /               C
8678 C      j1| o |l        | o |              o| o |         | o |o                C
8679 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
8680 C      \i/   \         /   \ /             /   \         /   \                 C
8681 C       o     k1            o                                                  C
8682 C         (I)          (II)                (III)          (IV)                 C
8683 C                                                                              C
8684 C      eello5_1        eello5_2            eello5_3       eello5_4             C
8685 C                                                                              C
8686 C o denotes a local interaction, vertical lines an electrostatic interaction.  C
8687 C                                                                              C
8688 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8689 cd      if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
8690 cd        eello5=0.0d0
8691 cd        return
8692 cd      endif
8693 cd      write (iout,*)
8694 cd     &   'EELLO5: Contacts have occurred for peptide groups',i,j,
8695 cd     &   ' and',k,l
8696       itk=itortyp(itype(k))
8697       itl=itortyp(itype(l))
8698       itj=itortyp(itype(j))
8699       eello5_1=0.0d0
8700       eello5_2=0.0d0
8701       eello5_3=0.0d0
8702       eello5_4=0.0d0
8703 cd      call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
8704 cd     &   eel5_3_num,eel5_4_num)
8705       do iii=1,2
8706         do kkk=1,5
8707           do lll=1,3
8708             derx(lll,kkk,iii)=0.0d0
8709           enddo
8710         enddo
8711       enddo
8712 cd      eij=facont_hb(jj,i)
8713 cd      ekl=facont_hb(kk,k)
8714 cd      ekont=eij*ekl
8715 cd      write (iout,*)'Contacts have occurred for peptide groups',
8716 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l
8717 cd      goto 1111
8718 C Contribution from the graph I.
8719 cd      write (2,*) 'AEA  ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
8720 cd      write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
8721       call transpose2(EUg(1,1,k),auxmat(1,1))
8722       call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
8723       vv(1)=pizda(1,1)-pizda(2,2)
8724       vv(2)=pizda(1,2)+pizda(2,1)
8725       eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k))
8726      & +0.5d0*scalar2(vv(1),Dtobr2(1,i))
8727 C Explicit gradient in virtual-dihedral angles.
8728       if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1)
8729      & +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k))
8730      & +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
8731       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8732       call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
8733       vv(1)=pizda(1,1)-pizda(2,2)
8734       vv(2)=pizda(1,2)+pizda(2,1)
8735       g_corr5_loc(k-1)=g_corr5_loc(k-1)
8736      & +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k))
8737      & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
8738       call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
8739       vv(1)=pizda(1,1)-pizda(2,2)
8740       vv(2)=pizda(1,2)+pizda(2,1)
8741       if (l.eq.j+1) then
8742         if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1)
8743      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
8744      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
8745       else
8746         if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1)
8747      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
8748      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
8749       endif
8750 C Cartesian gradient
8751       do iii=1,2
8752         do kkk=1,5
8753           do lll=1,3
8754             call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),
8755      &        pizda(1,1))
8756             vv(1)=pizda(1,1)-pizda(2,2)
8757             vv(2)=pizda(1,2)+pizda(2,1)
8758             derx(lll,kkk,iii)=derx(lll,kkk,iii)
8759      &       +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k))
8760      &       +0.5d0*scalar2(vv(1),Dtobr2(1,i))
8761           enddo
8762         enddo
8763       enddo
8764 c      goto 1112
8765 c1111  continue
8766 C Contribution from graph II
8767       call transpose2(EE(1,1,itk),auxmat(1,1))
8768       call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
8769       vv(1)=pizda(1,1)+pizda(2,2)
8770       vv(2)=pizda(2,1)-pizda(1,2)
8771       eello5_2=scalar2(AEAb1(1,2,1),b1(1,k))
8772      & -0.5d0*scalar2(vv(1),Ctobr(1,k))
8773 C Explicit gradient in virtual-dihedral angles.
8774       g_corr5_loc(k-1)=g_corr5_loc(k-1)
8775      & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
8776       call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
8777       vv(1)=pizda(1,1)+pizda(2,2)
8778       vv(2)=pizda(2,1)-pizda(1,2)
8779       if (l.eq.j+1) then
8780         g_corr5_loc(l-1)=g_corr5_loc(l-1)
8781      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,k))
8782      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
8783       else
8784         g_corr5_loc(j-1)=g_corr5_loc(j-1)
8785      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,k))
8786      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
8787       endif
8788 C Cartesian gradient
8789       do iii=1,2
8790         do kkk=1,5
8791           do lll=1,3
8792             call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
8793      &        pizda(1,1))
8794             vv(1)=pizda(1,1)+pizda(2,2)
8795             vv(2)=pizda(2,1)-pizda(1,2)
8796             derx(lll,kkk,iii)=derx(lll,kkk,iii)
8797      &       +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,k))
8798      &       -0.5d0*scalar2(vv(1),Ctobr(1,k))
8799           enddo
8800         enddo
8801       enddo
8802 cd      goto 1112
8803 cd1111  continue
8804       if (l.eq.j+1) then
8805 cd        goto 1110
8806 C Parallel orientation
8807 C Contribution from graph III
8808         call transpose2(EUg(1,1,l),auxmat(1,1))
8809         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
8810         vv(1)=pizda(1,1)-pizda(2,2)
8811         vv(2)=pizda(1,2)+pizda(2,1)
8812         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l))
8813      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j))
8814 C Explicit gradient in virtual-dihedral angles.
8815         g_corr5_loc(j-1)=g_corr5_loc(j-1)
8816      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l))
8817      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
8818         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
8819         vv(1)=pizda(1,1)-pizda(2,2)
8820         vv(2)=pizda(1,2)+pizda(2,1)
8821         g_corr5_loc(k-1)=g_corr5_loc(k-1)
8822      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l))
8823      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
8824         call transpose2(EUgder(1,1,l),auxmat1(1,1))
8825         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
8826         vv(1)=pizda(1,1)-pizda(2,2)
8827         vv(2)=pizda(1,2)+pizda(2,1)
8828         g_corr5_loc(l-1)=g_corr5_loc(l-1)
8829      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l))
8830      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
8831 C Cartesian gradient
8832         do iii=1,2
8833           do kkk=1,5
8834             do lll=1,3
8835               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
8836      &          pizda(1,1))
8837               vv(1)=pizda(1,1)-pizda(2,2)
8838               vv(2)=pizda(1,2)+pizda(2,1)
8839               derx(lll,kkk,iii)=derx(lll,kkk,iii)
8840      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l))
8841      &         +0.5d0*scalar2(vv(1),Dtobr2(1,j))
8842             enddo
8843           enddo
8844         enddo
8845 cd        goto 1112
8846 C Contribution from graph IV
8847 cd1110    continue
8848         call transpose2(EE(1,1,itl),auxmat(1,1))
8849         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
8850         vv(1)=pizda(1,1)+pizda(2,2)
8851         vv(2)=pizda(2,1)-pizda(1,2)
8852         eello5_4=scalar2(AEAb1(1,2,2),b1(1,l))
8853      &   -0.5d0*scalar2(vv(1),Ctobr(1,l))
8854 C Explicit gradient in virtual-dihedral angles.
8855         g_corr5_loc(l-1)=g_corr5_loc(l-1)
8856      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
8857         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
8858         vv(1)=pizda(1,1)+pizda(2,2)
8859         vv(2)=pizda(2,1)-pizda(1,2)
8860         g_corr5_loc(k-1)=g_corr5_loc(k-1)
8861      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,l))
8862      &   -0.5d0*scalar2(vv(1),Ctobr(1,l)))
8863 C Cartesian gradient
8864         do iii=1,2
8865           do kkk=1,5
8866             do lll=1,3
8867               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
8868      &          pizda(1,1))
8869               vv(1)=pizda(1,1)+pizda(2,2)
8870               vv(2)=pizda(2,1)-pizda(1,2)
8871               derx(lll,kkk,iii)=derx(lll,kkk,iii)
8872      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,l))
8873      &         -0.5d0*scalar2(vv(1),Ctobr(1,l))
8874             enddo
8875           enddo
8876         enddo
8877       else
8878 C Antiparallel orientation
8879 C Contribution from graph III
8880 c        goto 1110
8881         call transpose2(EUg(1,1,j),auxmat(1,1))
8882         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
8883         vv(1)=pizda(1,1)-pizda(2,2)
8884         vv(2)=pizda(1,2)+pizda(2,1)
8885         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j))
8886      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l))
8887 C Explicit gradient in virtual-dihedral angles.
8888         g_corr5_loc(l-1)=g_corr5_loc(l-1)
8889      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j))
8890      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
8891         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
8892         vv(1)=pizda(1,1)-pizda(2,2)
8893         vv(2)=pizda(1,2)+pizda(2,1)
8894         g_corr5_loc(k-1)=g_corr5_loc(k-1)
8895      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j))
8896      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
8897         call transpose2(EUgder(1,1,j),auxmat1(1,1))
8898         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
8899         vv(1)=pizda(1,1)-pizda(2,2)
8900         vv(2)=pizda(1,2)+pizda(2,1)
8901         g_corr5_loc(j-1)=g_corr5_loc(j-1)
8902      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j))
8903      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
8904 C Cartesian gradient
8905         do iii=1,2
8906           do kkk=1,5
8907             do lll=1,3
8908               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
8909      &          pizda(1,1))
8910               vv(1)=pizda(1,1)-pizda(2,2)
8911               vv(2)=pizda(1,2)+pizda(2,1)
8912               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
8913      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j))
8914      &         +0.5d0*scalar2(vv(1),Dtobr2(1,l))
8915             enddo
8916           enddo
8917         enddo
8918 cd        goto 1112
8919 C Contribution from graph IV
8920 1110    continue
8921         call transpose2(EE(1,1,itj),auxmat(1,1))
8922         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
8923         vv(1)=pizda(1,1)+pizda(2,2)
8924         vv(2)=pizda(2,1)-pizda(1,2)
8925         eello5_4=scalar2(AEAb1(1,2,2),b1(1,j))
8926      &   -0.5d0*scalar2(vv(1),Ctobr(1,j))
8927 C Explicit gradient in virtual-dihedral angles.
8928         g_corr5_loc(j-1)=g_corr5_loc(j-1)
8929      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
8930         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
8931         vv(1)=pizda(1,1)+pizda(2,2)
8932         vv(2)=pizda(2,1)-pizda(1,2)
8933         g_corr5_loc(k-1)=g_corr5_loc(k-1)
8934      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,j))
8935      &   -0.5d0*scalar2(vv(1),Ctobr(1,j)))
8936 C Cartesian gradient
8937         do iii=1,2
8938           do kkk=1,5
8939             do lll=1,3
8940               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
8941      &          pizda(1,1))
8942               vv(1)=pizda(1,1)+pizda(2,2)
8943               vv(2)=pizda(2,1)-pizda(1,2)
8944               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
8945      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,j))
8946      &         -0.5d0*scalar2(vv(1),Ctobr(1,j))
8947             enddo
8948           enddo
8949         enddo
8950       endif
8951 1112  continue
8952       eel5=eello5_1+eello5_2+eello5_3+eello5_4
8953 cd      if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
8954 cd        write (2,*) 'ijkl',i,j,k,l
8955 cd        write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
8956 cd     &     ' eello5_3',eello5_3,' eello5_4',eello5_4
8957 cd      endif
8958 cd      write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
8959 cd      write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
8960 cd      write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
8961 cd      write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
8962       if (j.lt.nres-1) then
8963         j1=j+1
8964         j2=j-1
8965       else
8966         j1=j-1
8967         j2=j-2
8968       endif
8969       if (l.lt.nres-1) then
8970         l1=l+1
8971         l2=l-1
8972       else
8973         l1=l-1
8974         l2=l-2
8975       endif
8976 cd      eij=1.0d0
8977 cd      ekl=1.0d0
8978 cd      ekont=1.0d0
8979 cd      write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
8980 C 2/11/08 AL Gradients over DC's connecting interacting sites will be
8981 C        summed up outside the subrouine as for the other subroutines
8982 C        handling long-range interactions. The old code is commented out
8983 C        with "cgrad" to keep track of changes.
8984       do ll=1,3
8985 cgrad        ggg1(ll)=eel5*g_contij(ll,1)
8986 cgrad        ggg2(ll)=eel5*g_contij(ll,2)
8987         gradcorr5ij=eel5*g_contij(ll,1)+ekont*derx(ll,1,1)
8988         gradcorr5kl=eel5*g_contij(ll,2)+ekont*derx(ll,1,2)
8989 c        write (iout,'(a,3i3,a,5f8.3,2i3,a,5f8.3,a,f8.3)')
8990 c     &   "ecorr5",ll,i,j," derx",derx(ll,2,1),derx(ll,3,1),derx(ll,4,1),
8991 c     &   derx(ll,5,1),k,l," derx",derx(ll,2,2),derx(ll,3,2),
8992 c     &   derx(ll,4,2),derx(ll,5,2)," ekont",ekont
8993 c        write (iout,'(a,3i3,a,3f8.3,2i3,a,3f8.3)')
8994 c     &   "ecorr5",ll,i,j," gradcorr5",g_contij(ll,1),derx(ll,1,1),
8995 c     &   gradcorr5ij,
8996 c     &   k,l," gradcorr5",g_contij(ll,2),derx(ll,1,2),gradcorr5kl
8997 cold        ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
8998 cgrad        ghalf=0.5d0*ggg1(ll)
8999 cd        ghalf=0.0d0
9000         gradcorr5(ll,i)=gradcorr5(ll,i)+ekont*derx(ll,2,1)
9001         gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
9002         gradcorr5(ll,j)=gradcorr5(ll,j)+ekont*derx(ll,4,1)
9003         gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
9004         gradcorr5_long(ll,j)=gradcorr5_long(ll,j)+gradcorr5ij
9005         gradcorr5_long(ll,i)=gradcorr5_long(ll,i)-gradcorr5ij
9006 cold        ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
9007 cgrad        ghalf=0.5d0*ggg2(ll)
9008 cd        ghalf=0.0d0
9009         gradcorr5(ll,k)=gradcorr5(ll,k)+ekont*derx(ll,2,2)
9010         gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
9011         gradcorr5(ll,l)=gradcorr5(ll,l)+ekont*derx(ll,4,2)
9012         gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
9013         gradcorr5_long(ll,l)=gradcorr5_long(ll,l)+gradcorr5kl
9014         gradcorr5_long(ll,k)=gradcorr5_long(ll,k)-gradcorr5kl
9015       enddo
9016 cd      goto 1112
9017 cgrad      do m=i+1,j-1
9018 cgrad        do ll=1,3
9019 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
9020 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
9021 cgrad        enddo
9022 cgrad      enddo
9023 cgrad      do m=k+1,l-1
9024 cgrad        do ll=1,3
9025 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
9026 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
9027 cgrad        enddo
9028 cgrad      enddo
9029 c1112  continue
9030 cgrad      do m=i+2,j2
9031 cgrad        do ll=1,3
9032 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
9033 cgrad        enddo
9034 cgrad      enddo
9035 cgrad      do m=k+2,l2
9036 cgrad        do ll=1,3
9037 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
9038 cgrad        enddo
9039 cgrad      enddo
9040 cd      do iii=1,nres-3
9041 cd        write (2,*) iii,g_corr5_loc(iii)
9042 cd      enddo
9043       eello5=ekont*eel5
9044 cd      write (2,*) 'ekont',ekont
9045 cd      write (iout,*) 'eello5',ekont*eel5
9046       return
9047       end
9048 c--------------------------------------------------------------------------
9049       double precision function eello6(i,j,k,l,jj,kk)
9050       implicit real*8 (a-h,o-z)
9051       include 'DIMENSIONS'
9052       include 'COMMON.IOUNITS'
9053       include 'COMMON.CHAIN'
9054       include 'COMMON.DERIV'
9055       include 'COMMON.INTERACT'
9056       include 'COMMON.CONTACTS'
9057       include 'COMMON.TORSION'
9058       include 'COMMON.VAR'
9059       include 'COMMON.GEO'
9060       include 'COMMON.FFIELD'
9061       double precision ggg1(3),ggg2(3)
9062 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
9063 cd        eello6=0.0d0
9064 cd        return
9065 cd      endif
9066 cd      write (iout,*)
9067 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
9068 cd     &   ' and',k,l
9069       eello6_1=0.0d0
9070       eello6_2=0.0d0
9071       eello6_3=0.0d0
9072       eello6_4=0.0d0
9073       eello6_5=0.0d0
9074       eello6_6=0.0d0
9075 cd      call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
9076 cd     &   eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
9077       do iii=1,2
9078         do kkk=1,5
9079           do lll=1,3
9080             derx(lll,kkk,iii)=0.0d0
9081           enddo
9082         enddo
9083       enddo
9084 cd      eij=facont_hb(jj,i)
9085 cd      ekl=facont_hb(kk,k)
9086 cd      ekont=eij*ekl
9087 cd      eij=1.0d0
9088 cd      ekl=1.0d0
9089 cd      ekont=1.0d0
9090       if (l.eq.j+1) then
9091         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
9092         eello6_2=eello6_graph1(j,i,l,k,2,.false.)
9093         eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
9094         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
9095         eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
9096         eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
9097       else
9098         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
9099         eello6_2=eello6_graph1(l,k,j,i,2,.true.)
9100         eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
9101         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
9102         if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
9103           eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
9104         else
9105           eello6_5=0.0d0
9106         endif
9107         eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
9108       endif
9109 C If turn contributions are considered, they will be handled separately.
9110       eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
9111 cd      write(iout,*) 'eello6_1',eello6_1!,' eel6_1_num',16*eel6_1_num
9112 cd      write(iout,*) 'eello6_2',eello6_2!,' eel6_2_num',16*eel6_2_num
9113 cd      write(iout,*) 'eello6_3',eello6_3!,' eel6_3_num',16*eel6_3_num
9114 cd      write(iout,*) 'eello6_4',eello6_4!,' eel6_4_num',16*eel6_4_num
9115 cd      write(iout,*) 'eello6_5',eello6_5!,' eel6_5_num',16*eel6_5_num
9116 cd      write(iout,*) 'eello6_6',eello6_6!,' eel6_6_num',16*eel6_6_num
9117 cd      goto 1112
9118       if (j.lt.nres-1) then
9119         j1=j+1
9120         j2=j-1
9121       else
9122         j1=j-1
9123         j2=j-2
9124       endif
9125       if (l.lt.nres-1) then
9126         l1=l+1
9127         l2=l-1
9128       else
9129         l1=l-1
9130         l2=l-2
9131       endif
9132       do ll=1,3
9133 cgrad        ggg1(ll)=eel6*g_contij(ll,1)
9134 cgrad        ggg2(ll)=eel6*g_contij(ll,2)
9135 cold        ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
9136 cgrad        ghalf=0.5d0*ggg1(ll)
9137 cd        ghalf=0.0d0
9138         gradcorr6ij=eel6*g_contij(ll,1)+ekont*derx(ll,1,1)
9139         gradcorr6kl=eel6*g_contij(ll,2)+ekont*derx(ll,1,2)
9140         gradcorr6(ll,i)=gradcorr6(ll,i)+ekont*derx(ll,2,1)
9141         gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
9142         gradcorr6(ll,j)=gradcorr6(ll,j)+ekont*derx(ll,4,1)
9143         gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
9144         gradcorr6_long(ll,j)=gradcorr6_long(ll,j)+gradcorr6ij
9145         gradcorr6_long(ll,i)=gradcorr6_long(ll,i)-gradcorr6ij
9146 cgrad        ghalf=0.5d0*ggg2(ll)
9147 cold        ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
9148 cd        ghalf=0.0d0
9149         gradcorr6(ll,k)=gradcorr6(ll,k)+ekont*derx(ll,2,2)
9150         gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
9151         gradcorr6(ll,l)=gradcorr6(ll,l)+ekont*derx(ll,4,2)
9152         gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
9153         gradcorr6_long(ll,l)=gradcorr6_long(ll,l)+gradcorr6kl
9154         gradcorr6_long(ll,k)=gradcorr6_long(ll,k)-gradcorr6kl
9155       enddo
9156 cd      goto 1112
9157 cgrad      do m=i+1,j-1
9158 cgrad        do ll=1,3
9159 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
9160 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
9161 cgrad        enddo
9162 cgrad      enddo
9163 cgrad      do m=k+1,l-1
9164 cgrad        do ll=1,3
9165 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
9166 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
9167 cgrad        enddo
9168 cgrad      enddo
9169 cgrad1112  continue
9170 cgrad      do m=i+2,j2
9171 cgrad        do ll=1,3
9172 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
9173 cgrad        enddo
9174 cgrad      enddo
9175 cgrad      do m=k+2,l2
9176 cgrad        do ll=1,3
9177 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
9178 cgrad        enddo
9179 cgrad      enddo
9180 cd      do iii=1,nres-3
9181 cd        write (2,*) iii,g_corr6_loc(iii)
9182 cd      enddo
9183       eello6=ekont*eel6
9184 cd      write (2,*) 'ekont',ekont
9185 cd      write (iout,*) 'eello6',ekont*eel6
9186       return
9187       end
9188 c--------------------------------------------------------------------------
9189       double precision function eello6_graph1(i,j,k,l,imat,swap)
9190       implicit real*8 (a-h,o-z)
9191       include 'DIMENSIONS'
9192       include 'COMMON.IOUNITS'
9193       include 'COMMON.CHAIN'
9194       include 'COMMON.DERIV'
9195       include 'COMMON.INTERACT'
9196       include 'COMMON.CONTACTS'
9197       include 'COMMON.TORSION'
9198       include 'COMMON.VAR'
9199       include 'COMMON.GEO'
9200       double precision vv(2),vv1(2),pizda(2,2),auxmat(2,2),pizda1(2,2)
9201       logical swap
9202       logical lprn
9203       common /kutas/ lprn
9204 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9205 C                                                                              C
9206 C      Parallel       Antiparallel                                             C
9207 C                                                                              C
9208 C          o             o                                                     C
9209 C         /l\           /j\                                                    C
9210 C        /   \         /   \                                                   C
9211 C       /| o |         | o |\                                                  C
9212 C     \ j|/k\|  /   \  |/k\|l /                                                C
9213 C      \ /   \ /     \ /   \ /                                                 C
9214 C       o     o       o     o                                                  C
9215 C       i             i                                                        C
9216 C                                                                              C
9217 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9218       itk=itortyp(itype(k))
9219       s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
9220       s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
9221       s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
9222       call transpose2(EUgC(1,1,k),auxmat(1,1))
9223       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
9224       vv1(1)=pizda1(1,1)-pizda1(2,2)
9225       vv1(2)=pizda1(1,2)+pizda1(2,1)
9226       s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
9227       vv(1)=AEAb1(1,2,imat)*b1(1,k)-AEAb1(2,2,imat)*b1(2,k)
9228       vv(2)=AEAb1(1,2,imat)*b1(2,k)+AEAb1(2,2,imat)*b1(1,k)
9229       s5=scalar2(vv(1),Dtobr2(1,i))
9230 cd      write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
9231       eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
9232       if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1)
9233      & -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i))
9234      & -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k))
9235      & +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k))
9236      & +0.5d0*scalar2(vv1(1),Dtobr2der(1,i))
9237      & +scalar2(vv(1),Dtobr2der(1,i)))
9238       call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
9239       vv1(1)=pizda1(1,1)-pizda1(2,2)
9240       vv1(2)=pizda1(1,2)+pizda1(2,1)
9241       vv(1)=AEAb1derg(1,2,imat)*b1(1,k)-AEAb1derg(2,2,imat)*b1(2,k)
9242       vv(2)=AEAb1derg(1,2,imat)*b1(2,k)+AEAb1derg(2,2,imat)*b1(1,k)
9243       if (l.eq.j+1) then
9244         g_corr6_loc(l-1)=g_corr6_loc(l-1)
9245      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
9246      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
9247      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
9248      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
9249       else
9250         g_corr6_loc(j-1)=g_corr6_loc(j-1)
9251      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
9252      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
9253      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
9254      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
9255       endif
9256       call transpose2(EUgCder(1,1,k),auxmat(1,1))
9257       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
9258       vv1(1)=pizda1(1,1)-pizda1(2,2)
9259       vv1(2)=pizda1(1,2)+pizda1(2,1)
9260       if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1)
9261      & +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k))
9262      & +scalar2(AEAb2(1,1,imat),CUgb2der(1,k))
9263      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
9264       do iii=1,2
9265         if (swap) then
9266           ind=3-iii
9267         else
9268           ind=iii
9269         endif
9270         do kkk=1,5
9271           do lll=1,3
9272             s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
9273             s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
9274             s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
9275             call transpose2(EUgC(1,1,k),auxmat(1,1))
9276             call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
9277      &        pizda1(1,1))
9278             vv1(1)=pizda1(1,1)-pizda1(2,2)
9279             vv1(2)=pizda1(1,2)+pizda1(2,1)
9280             s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
9281             vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,k)
9282      &       -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,k)
9283             vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,k)
9284      &       +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,k)
9285             s5=scalar2(vv(1),Dtobr2(1,i))
9286             derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
9287           enddo
9288         enddo
9289       enddo
9290       return
9291       end
9292 c----------------------------------------------------------------------------
9293       double precision function eello6_graph2(i,j,k,l,jj,kk,swap)
9294       implicit real*8 (a-h,o-z)
9295       include 'DIMENSIONS'
9296       include 'COMMON.IOUNITS'
9297       include 'COMMON.CHAIN'
9298       include 'COMMON.DERIV'
9299       include 'COMMON.INTERACT'
9300       include 'COMMON.CONTACTS'
9301       include 'COMMON.TORSION'
9302       include 'COMMON.VAR'
9303       include 'COMMON.GEO'
9304       logical swap
9305       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
9306      & auxvec1(2),auxvec2(2),auxmat1(2,2)
9307       logical lprn
9308       common /kutas/ lprn
9309 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9310 C                                                                              C
9311 C      Parallel       Antiparallel                                             C
9312 C                                                                              C
9313 C          o             o                                                     C
9314 C     \   /l\           /j\   /                                                C
9315 C      \ /   \         /   \ /                                                 C
9316 C       o| o |         | o |o                                                  C
9317 C     \ j|/k\|      \  |/k\|l                                                  C
9318 C      \ /   \       \ /   \                                                   C
9319 C       o             o                                                        C
9320 C       i             i                                                        C
9321 C                                                                              C
9322 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9323 cd      write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
9324 C AL 7/4/01 s1 would occur in the sixth-order moment,
9325 C           but not in a cluster cumulant
9326 #ifdef MOMENT
9327       s1=dip(1,jj,i)*dip(1,kk,k)
9328 #endif
9329       call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
9330       s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
9331       call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
9332       s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
9333       call transpose2(EUg(1,1,k),auxmat(1,1))
9334       call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
9335       vv(1)=pizda(1,1)-pizda(2,2)
9336       vv(2)=pizda(1,2)+pizda(2,1)
9337       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
9338 cd      write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
9339 #ifdef MOMENT
9340       eello6_graph2=-(s1+s2+s3+s4)
9341 #else
9342       eello6_graph2=-(s2+s3+s4)
9343 #endif
9344 c      eello6_graph2=-s3
9345 C Derivatives in gamma(i-1)
9346       if (i.gt.1) then
9347 #ifdef MOMENT
9348         s1=dipderg(1,jj,i)*dip(1,kk,k)
9349 #endif
9350         s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
9351         call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
9352         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
9353         s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
9354 #ifdef MOMENT
9355         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
9356 #else
9357         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
9358 #endif
9359 c        g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
9360       endif
9361 C Derivatives in gamma(k-1)
9362 #ifdef MOMENT
9363       s1=dip(1,jj,i)*dipderg(1,kk,k)
9364 #endif
9365       call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
9366       s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
9367       call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
9368       s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
9369       call transpose2(EUgder(1,1,k),auxmat1(1,1))
9370       call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
9371       vv(1)=pizda(1,1)-pizda(2,2)
9372       vv(2)=pizda(1,2)+pizda(2,1)
9373       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
9374 #ifdef MOMENT
9375       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
9376 #else
9377       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
9378 #endif
9379 c      g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
9380 C Derivatives in gamma(j-1) or gamma(l-1)
9381       if (j.gt.1) then
9382 #ifdef MOMENT
9383         s1=dipderg(3,jj,i)*dip(1,kk,k)
9384 #endif
9385         call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
9386         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
9387         s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
9388         call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
9389         vv(1)=pizda(1,1)-pizda(2,2)
9390         vv(2)=pizda(1,2)+pizda(2,1)
9391         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
9392 #ifdef MOMENT
9393         if (swap) then
9394           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
9395         else
9396           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
9397         endif
9398 #endif
9399         g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
9400 c        g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
9401       endif
9402 C Derivatives in gamma(l-1) or gamma(j-1)
9403       if (l.gt.1) then
9404 #ifdef MOMENT
9405         s1=dip(1,jj,i)*dipderg(3,kk,k)
9406 #endif
9407         call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
9408         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
9409         call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
9410         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
9411         call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
9412         vv(1)=pizda(1,1)-pizda(2,2)
9413         vv(2)=pizda(1,2)+pizda(2,1)
9414         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
9415 #ifdef MOMENT
9416         if (swap) then
9417           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
9418         else
9419           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
9420         endif
9421 #endif
9422         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
9423 c        g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
9424       endif
9425 C Cartesian derivatives.
9426       if (lprn) then
9427         write (2,*) 'In eello6_graph2'
9428         do iii=1,2
9429           write (2,*) 'iii=',iii
9430           do kkk=1,5
9431             write (2,*) 'kkk=',kkk
9432             do jjj=1,2
9433               write (2,'(3(2f10.5),5x)')
9434      &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
9435             enddo
9436           enddo
9437         enddo
9438       endif
9439       do iii=1,2
9440         do kkk=1,5
9441           do lll=1,3
9442 #ifdef MOMENT
9443             if (iii.eq.1) then
9444               s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
9445             else
9446               s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
9447             endif
9448 #endif
9449             call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),
9450      &        auxvec(1))
9451             s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
9452             call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),
9453      &        auxvec(1))
9454             s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
9455             call transpose2(EUg(1,1,k),auxmat(1,1))
9456             call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),
9457      &        pizda(1,1))
9458             vv(1)=pizda(1,1)-pizda(2,2)
9459             vv(2)=pizda(1,2)+pizda(2,1)
9460             s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
9461 cd            write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
9462 #ifdef MOMENT
9463             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
9464 #else
9465             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
9466 #endif
9467             if (swap) then
9468               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
9469             else
9470               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
9471             endif
9472           enddo
9473         enddo
9474       enddo
9475       return
9476       end
9477 c----------------------------------------------------------------------------
9478       double precision function eello6_graph3(i,j,k,l,jj,kk,swap)
9479       implicit real*8 (a-h,o-z)
9480       include 'DIMENSIONS'
9481       include 'COMMON.IOUNITS'
9482       include 'COMMON.CHAIN'
9483       include 'COMMON.DERIV'
9484       include 'COMMON.INTERACT'
9485       include 'COMMON.CONTACTS'
9486       include 'COMMON.TORSION'
9487       include 'COMMON.VAR'
9488       include 'COMMON.GEO'
9489       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2)
9490       logical swap
9491 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9492 C                                                                              C
9493 C      Parallel       Antiparallel                                             C
9494 C                                                                              C
9495 C          o             o                                                     C
9496 C         /l\   /   \   /j\                                                    C
9497 C        /   \ /     \ /   \                                                   C
9498 C       /| o |o       o| o |\                                                  C
9499 C       j|/k\|  /      |/k\|l /                                                C
9500 C        /   \ /       /   \ /                                                 C
9501 C       /     o       /     o                                                  C
9502 C       i             i                                                        C
9503 C                                                                              C
9504 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9505 C
9506 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
9507 C           energy moment and not to the cluster cumulant.
9508       iti=itortyp(itype(i))
9509       if (j.lt.nres-1) then
9510         itj1=itortyp(itype(j+1))
9511       else
9512         itj1=ntortyp
9513       endif
9514       itk=itortyp(itype(k))
9515       itk1=itortyp(itype(k+1))
9516       if (l.lt.nres-1) then
9517         itl1=itortyp(itype(l+1))
9518       else
9519         itl1=ntortyp
9520       endif
9521 #ifdef MOMENT
9522       s1=dip(4,jj,i)*dip(4,kk,k)
9523 #endif
9524       call matvec2(AECA(1,1,1),b1(1,k+1),auxvec(1))
9525       s2=0.5d0*scalar2(b1(1,k),auxvec(1))
9526       call matvec2(AECA(1,1,2),b1(1,l+1),auxvec(1))
9527       s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
9528       call transpose2(EE(1,1,itk),auxmat(1,1))
9529       call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
9530       vv(1)=pizda(1,1)+pizda(2,2)
9531       vv(2)=pizda(2,1)-pizda(1,2)
9532       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
9533 cd      write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4,
9534 cd     & "sum",-(s2+s3+s4)
9535 #ifdef MOMENT
9536       eello6_graph3=-(s1+s2+s3+s4)
9537 #else
9538       eello6_graph3=-(s2+s3+s4)
9539 #endif
9540 c      eello6_graph3=-s4
9541 C Derivatives in gamma(k-1)
9542       call matvec2(AECAderg(1,1,2),b1(1,l+1),auxvec(1))
9543       s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
9544       s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
9545       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
9546 C Derivatives in gamma(l-1)
9547       call matvec2(AECAderg(1,1,1),b1(1,k+1),auxvec(1))
9548       s2=0.5d0*scalar2(b1(1,k),auxvec(1))
9549       call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
9550       vv(1)=pizda(1,1)+pizda(2,2)
9551       vv(2)=pizda(2,1)-pizda(1,2)
9552       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
9553       g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
9554 C Cartesian derivatives.
9555       do iii=1,2
9556         do kkk=1,5
9557           do lll=1,3
9558 #ifdef MOMENT
9559             if (iii.eq.1) then
9560               s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
9561             else
9562               s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
9563             endif
9564 #endif
9565             call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
9566      &        auxvec(1))
9567             s2=0.5d0*scalar2(b1(1,k),auxvec(1))
9568             call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,l+1),
9569      &        auxvec(1))
9570             s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
9571             call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),
9572      &        pizda(1,1))
9573             vv(1)=pizda(1,1)+pizda(2,2)
9574             vv(2)=pizda(2,1)-pizda(1,2)
9575             s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
9576 #ifdef MOMENT
9577             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
9578 #else
9579             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
9580 #endif
9581             if (swap) then
9582               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
9583             else
9584               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
9585             endif
9586 c            derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
9587           enddo
9588         enddo
9589       enddo
9590       return
9591       end
9592 c----------------------------------------------------------------------------
9593       double precision function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
9594       implicit real*8 (a-h,o-z)
9595       include 'DIMENSIONS'
9596       include 'COMMON.IOUNITS'
9597       include 'COMMON.CHAIN'
9598       include 'COMMON.DERIV'
9599       include 'COMMON.INTERACT'
9600       include 'COMMON.CONTACTS'
9601       include 'COMMON.TORSION'
9602       include 'COMMON.VAR'
9603       include 'COMMON.GEO'
9604       include 'COMMON.FFIELD'
9605       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
9606      & auxvec1(2),auxmat1(2,2)
9607       logical swap
9608 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9609 C                                                                              C
9610 C      Parallel       Antiparallel                                             C
9611 C                                                                              C
9612 C          o             o                                                     C
9613 C         /l\   /   \   /j\                                                    C
9614 C        /   \ /     \ /   \                                                   C
9615 C       /| o |o       o| o |\                                                  C
9616 C     \ j|/k\|      \  |/k\|l                                                  C
9617 C      \ /   \       \ /   \                                                   C
9618 C       o     \       o     \                                                  C
9619 C       i             i                                                        C
9620 C                                                                              C
9621 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9622 C
9623 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
9624 C           energy moment and not to the cluster cumulant.
9625 cd      write (2,*) 'eello_graph4: wturn6',wturn6
9626       iti=itortyp(itype(i))
9627       itj=itortyp(itype(j))
9628       if (j.lt.nres-1) then
9629         itj1=itortyp(itype(j+1))
9630       else
9631         itj1=ntortyp
9632       endif
9633       itk=itortyp(itype(k))
9634       if (k.lt.nres-1) then
9635         itk1=itortyp(itype(k+1))
9636       else
9637         itk1=ntortyp
9638       endif
9639       itl=itortyp(itype(l))
9640       if (l.lt.nres-1) then
9641         itl1=itortyp(itype(l+1))
9642       else
9643         itl1=ntortyp
9644       endif
9645 cd      write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
9646 cd      write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
9647 cd     & ' itl',itl,' itl1',itl1
9648 #ifdef MOMENT
9649       if (imat.eq.1) then
9650         s1=dip(3,jj,i)*dip(3,kk,k)
9651       else
9652         s1=dip(2,jj,j)*dip(2,kk,l)
9653       endif
9654 #endif
9655       call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
9656       s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
9657       if (j.eq.l+1) then
9658         call matvec2(ADtEA1(1,1,3-imat),b1(1,j+1),auxvec1(1))
9659         s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
9660       else
9661         call matvec2(ADtEA1(1,1,3-imat),b1(1,l+1),auxvec1(1))
9662         s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
9663       endif
9664       call transpose2(EUg(1,1,k),auxmat(1,1))
9665       call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
9666       vv(1)=pizda(1,1)-pizda(2,2)
9667       vv(2)=pizda(2,1)+pizda(1,2)
9668       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9669 cd      write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
9670 #ifdef MOMENT
9671       eello6_graph4=-(s1+s2+s3+s4)
9672 #else
9673       eello6_graph4=-(s2+s3+s4)
9674 #endif
9675 C Derivatives in gamma(i-1)
9676       if (i.gt.1) then
9677 #ifdef MOMENT
9678         if (imat.eq.1) then
9679           s1=dipderg(2,jj,i)*dip(3,kk,k)
9680         else
9681           s1=dipderg(4,jj,j)*dip(2,kk,l)
9682         endif
9683 #endif
9684         s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
9685         if (j.eq.l+1) then
9686           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,j+1),auxvec1(1))
9687           s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
9688         else
9689           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,l+1),auxvec1(1))
9690           s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
9691         endif
9692         s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
9693         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
9694 cd          write (2,*) 'turn6 derivatives'
9695 #ifdef MOMENT
9696           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
9697 #else
9698           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
9699 #endif
9700         else
9701 #ifdef MOMENT
9702           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
9703 #else
9704           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
9705 #endif
9706         endif
9707       endif
9708 C Derivatives in gamma(k-1)
9709 #ifdef MOMENT
9710       if (imat.eq.1) then
9711         s1=dip(3,jj,i)*dipderg(2,kk,k)
9712       else
9713         s1=dip(2,jj,j)*dipderg(4,kk,l)
9714       endif
9715 #endif
9716       call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
9717       s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
9718       if (j.eq.l+1) then
9719         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,j+1),auxvec1(1))
9720         s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
9721       else
9722         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,l+1),auxvec1(1))
9723         s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
9724       endif
9725       call transpose2(EUgder(1,1,k),auxmat1(1,1))
9726       call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
9727       vv(1)=pizda(1,1)-pizda(2,2)
9728       vv(2)=pizda(2,1)+pizda(1,2)
9729       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9730       if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
9731 #ifdef MOMENT
9732         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
9733 #else
9734         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
9735 #endif
9736       else
9737 #ifdef MOMENT
9738         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
9739 #else
9740         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
9741 #endif
9742       endif
9743 C Derivatives in gamma(j-1) or gamma(l-1)
9744       if (l.eq.j+1 .and. l.gt.1) then
9745         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
9746         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
9747         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
9748         vv(1)=pizda(1,1)-pizda(2,2)
9749         vv(2)=pizda(2,1)+pizda(1,2)
9750         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9751         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
9752       else if (j.gt.1) then
9753         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
9754         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
9755         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
9756         vv(1)=pizda(1,1)-pizda(2,2)
9757         vv(2)=pizda(2,1)+pizda(1,2)
9758         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9759         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
9760           gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
9761         else
9762           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
9763         endif
9764       endif
9765 C Cartesian derivatives.
9766       do iii=1,2
9767         do kkk=1,5
9768           do lll=1,3
9769 #ifdef MOMENT
9770             if (iii.eq.1) then
9771               if (imat.eq.1) then
9772                 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
9773               else
9774                 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
9775               endif
9776             else
9777               if (imat.eq.1) then
9778                 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
9779               else
9780                 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
9781               endif
9782             endif
9783 #endif
9784             call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),
9785      &        auxvec(1))
9786             s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
9787             if (j.eq.l+1) then
9788               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
9789      &          b1(1,j+1),auxvec(1))
9790               s3=-0.5d0*scalar2(b1(1,j),auxvec(1))
9791             else
9792               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
9793      &          b1(1,l+1),auxvec(1))
9794               s3=-0.5d0*scalar2(b1(1,l),auxvec(1))
9795             endif
9796             call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
9797      &        pizda(1,1))
9798             vv(1)=pizda(1,1)-pizda(2,2)
9799             vv(2)=pizda(2,1)+pizda(1,2)
9800             s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9801             if (swap) then
9802               if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
9803 #ifdef MOMENT
9804                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
9805      &             -(s1+s2+s4)
9806 #else
9807                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
9808      &             -(s2+s4)
9809 #endif
9810                 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
9811               else
9812 #ifdef MOMENT
9813                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
9814 #else
9815                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
9816 #endif
9817                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
9818               endif
9819             else
9820 #ifdef MOMENT
9821               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
9822 #else
9823               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
9824 #endif
9825               if (l.eq.j+1) then
9826                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
9827               else
9828                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
9829               endif
9830             endif
9831           enddo
9832         enddo
9833       enddo
9834       return
9835       end
9836 c----------------------------------------------------------------------------
9837       double precision function eello_turn6(i,jj,kk)
9838       implicit real*8 (a-h,o-z)
9839       include 'DIMENSIONS'
9840       include 'COMMON.IOUNITS'
9841       include 'COMMON.CHAIN'
9842       include 'COMMON.DERIV'
9843       include 'COMMON.INTERACT'
9844       include 'COMMON.CONTACTS'
9845       include 'COMMON.TORSION'
9846       include 'COMMON.VAR'
9847       include 'COMMON.GEO'
9848       double precision vtemp1(2),vtemp2(2),vtemp3(2),vtemp4(2),
9849      &  atemp(2,2),auxmat(2,2),achuj_temp(2,2),gtemp(2,2),gvec(2),
9850      &  ggg1(3),ggg2(3)
9851       double precision vtemp1d(2),vtemp2d(2),vtemp3d(2),vtemp4d(2),
9852      &  atempd(2,2),auxmatd(2,2),achuj_tempd(2,2),gtempd(2,2),gvecd(2)
9853 C 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
9854 C           the respective energy moment and not to the cluster cumulant.
9855       s1=0.0d0
9856       s8=0.0d0
9857       s13=0.0d0
9858 c
9859       eello_turn6=0.0d0
9860       j=i+4
9861       k=i+1
9862       l=i+3
9863       iti=itortyp(itype(i))
9864       itk=itortyp(itype(k))
9865       itk1=itortyp(itype(k+1))
9866       itl=itortyp(itype(l))
9867       itj=itortyp(itype(j))
9868 cd      write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
9869 cd      write (2,*) 'i',i,' k',k,' j',j,' l',l
9870 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
9871 cd        eello6=0.0d0
9872 cd        return
9873 cd      endif
9874 cd      write (iout,*)
9875 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
9876 cd     &   ' and',k,l
9877 cd      call checkint_turn6(i,jj,kk,eel_turn6_num)
9878       do iii=1,2
9879         do kkk=1,5
9880           do lll=1,3
9881             derx_turn(lll,kkk,iii)=0.0d0
9882           enddo
9883         enddo
9884       enddo
9885 cd      eij=1.0d0
9886 cd      ekl=1.0d0
9887 cd      ekont=1.0d0
9888       eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
9889 cd      eello6_5=0.0d0
9890 cd      write (2,*) 'eello6_5',eello6_5
9891 #ifdef MOMENT
9892       call transpose2(AEA(1,1,1),auxmat(1,1))
9893       call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
9894       ss1=scalar2(Ub2(1,i+2),b1(1,l))
9895       s1 = (auxmat(1,1)+auxmat(2,2))*ss1
9896 #endif
9897       call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1(1))
9898       call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
9899       s2 = scalar2(b1(1,k),vtemp1(1))
9900 #ifdef MOMENT
9901       call transpose2(AEA(1,1,2),atemp(1,1))
9902       call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
9903       call matvec2(Ug2(1,1,i+2),dd(1,1,itk1),vtemp2(1))
9904       s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
9905 #endif
9906       call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
9907       call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
9908       s12 = scalar2(Ub2(1,i+2),vtemp3(1))
9909 #ifdef MOMENT
9910       call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
9911       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
9912       call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
9913       call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
9914       ss13 = scalar2(b1(1,k),vtemp4(1))
9915       s13 = (gtemp(1,1)+gtemp(2,2))*ss13
9916 #endif
9917 c      write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
9918 c      s1=0.0d0
9919 c      s2=0.0d0
9920 c      s8=0.0d0
9921 c      s12=0.0d0
9922 c      s13=0.0d0
9923       eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
9924 C Derivatives in gamma(i+2)
9925       s1d =0.0d0
9926       s8d =0.0d0
9927 #ifdef MOMENT
9928       call transpose2(AEA(1,1,1),auxmatd(1,1))
9929       call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
9930       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
9931       call transpose2(AEAderg(1,1,2),atempd(1,1))
9932       call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
9933       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
9934 #endif
9935       call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
9936       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
9937       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
9938 c      s1d=0.0d0
9939 c      s2d=0.0d0
9940 c      s8d=0.0d0
9941 c      s12d=0.0d0
9942 c      s13d=0.0d0
9943       gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
9944 C Derivatives in gamma(i+3)
9945 #ifdef MOMENT
9946       call transpose2(AEA(1,1,1),auxmatd(1,1))
9947       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
9948       ss1d=scalar2(Ub2der(1,i+2),b1(1,l))
9949       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
9950 #endif
9951       call matvec2(EUgder(1,1,i+2),b1(1,l),vtemp1d(1))
9952       call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
9953       s2d = scalar2(b1(1,k),vtemp1d(1))
9954 #ifdef MOMENT
9955       call matvec2(Ug2der(1,1,i+2),dd(1,1,itk1),vtemp2d(1))
9956       s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2d(1))
9957 #endif
9958       s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
9959 #ifdef MOMENT
9960       call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
9961       call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
9962       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
9963 #endif
9964 c      s1d=0.0d0
9965 c      s2d=0.0d0
9966 c      s8d=0.0d0
9967 c      s12d=0.0d0
9968 c      s13d=0.0d0
9969 #ifdef MOMENT
9970       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
9971      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
9972 #else
9973       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
9974      &               -0.5d0*ekont*(s2d+s12d)
9975 #endif
9976 C Derivatives in gamma(i+4)
9977       call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
9978       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
9979       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
9980 #ifdef MOMENT
9981       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
9982       call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
9983       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
9984 #endif
9985 c      s1d=0.0d0
9986 c      s2d=0.0d0
9987 c      s8d=0.0d0
9988 C      s12d=0.0d0
9989 c      s13d=0.0d0
9990 #ifdef MOMENT
9991       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
9992 #else
9993       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
9994 #endif
9995 C Derivatives in gamma(i+5)
9996 #ifdef MOMENT
9997       call transpose2(AEAderg(1,1,1),auxmatd(1,1))
9998       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
9999       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
10000 #endif
10001       call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1d(1))
10002       call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
10003       s2d = scalar2(b1(1,k),vtemp1d(1))
10004 #ifdef MOMENT
10005       call transpose2(AEA(1,1,2),atempd(1,1))
10006       call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
10007       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
10008 #endif
10009       call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
10010       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
10011 #ifdef MOMENT
10012       call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
10013       ss13d = scalar2(b1(1,k),vtemp4d(1))
10014       s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
10015 #endif
10016 c      s1d=0.0d0
10017 c      s2d=0.0d0
10018 c      s8d=0.0d0
10019 c      s12d=0.0d0
10020 c      s13d=0.0d0
10021 #ifdef MOMENT
10022       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
10023      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
10024 #else
10025       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
10026      &               -0.5d0*ekont*(s2d+s12d)
10027 #endif
10028 C Cartesian derivatives
10029       do iii=1,2
10030         do kkk=1,5
10031           do lll=1,3
10032 #ifdef MOMENT
10033             call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
10034             call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
10035             s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
10036 #endif
10037             call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1(1))
10038             call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),
10039      &          vtemp1d(1))
10040             s2d = scalar2(b1(1,k),vtemp1d(1))
10041 #ifdef MOMENT
10042             call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
10043             call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
10044             s8d = -(atempd(1,1)+atempd(2,2))*
10045      &           scalar2(cc(1,1,itl),vtemp2(1))
10046 #endif
10047             call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),
10048      &           auxmatd(1,1))
10049             call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
10050             s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
10051 c      s1d=0.0d0
10052 c      s2d=0.0d0
10053 c      s8d=0.0d0
10054 c      s12d=0.0d0
10055 c      s13d=0.0d0
10056 #ifdef MOMENT
10057             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
10058      &        - 0.5d0*(s1d+s2d)
10059 #else
10060             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
10061      &        - 0.5d0*s2d
10062 #endif
10063 #ifdef MOMENT
10064             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
10065      &        - 0.5d0*(s8d+s12d)
10066 #else
10067             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
10068      &        - 0.5d0*s12d
10069 #endif
10070           enddo
10071         enddo
10072       enddo
10073 #ifdef MOMENT
10074       do kkk=1,5
10075         do lll=1,3
10076           call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),
10077      &      achuj_tempd(1,1))
10078           call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
10079           call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
10080           s13d=(gtempd(1,1)+gtempd(2,2))*ss13
10081           derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
10082           call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),
10083      &      vtemp4d(1))
10084           ss13d = scalar2(b1(1,k),vtemp4d(1))
10085           s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
10086           derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
10087         enddo
10088       enddo
10089 #endif
10090 cd      write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
10091 cd     &  16*eel_turn6_num
10092 cd      goto 1112
10093       if (j.lt.nres-1) then
10094         j1=j+1
10095         j2=j-1
10096       else
10097         j1=j-1
10098         j2=j-2
10099       endif
10100       if (l.lt.nres-1) then
10101         l1=l+1
10102         l2=l-1
10103       else
10104         l1=l-1
10105         l2=l-2
10106       endif
10107       do ll=1,3
10108 cgrad        ggg1(ll)=eel_turn6*g_contij(ll,1)
10109 cgrad        ggg2(ll)=eel_turn6*g_contij(ll,2)
10110 cgrad        ghalf=0.5d0*ggg1(ll)
10111 cd        ghalf=0.0d0
10112         gturn6ij=eel_turn6*g_contij(ll,1)+ekont*derx_turn(ll,1,1)
10113         gturn6kl=eel_turn6*g_contij(ll,2)+ekont*derx_turn(ll,1,2)
10114         gcorr6_turn(ll,i)=gcorr6_turn(ll,i)!+ghalf
10115      &    +ekont*derx_turn(ll,2,1)
10116         gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
10117         gcorr6_turn(ll,j)=gcorr6_turn(ll,j)!+ghalf
10118      &    +ekont*derx_turn(ll,4,1)
10119         gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
10120         gcorr6_turn_long(ll,j)=gcorr6_turn_long(ll,j)+gturn6ij
10121         gcorr6_turn_long(ll,i)=gcorr6_turn_long(ll,i)-gturn6ij
10122 cgrad        ghalf=0.5d0*ggg2(ll)
10123 cd        ghalf=0.0d0
10124         gcorr6_turn(ll,k)=gcorr6_turn(ll,k)!+ghalf
10125      &    +ekont*derx_turn(ll,2,2)
10126         gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
10127         gcorr6_turn(ll,l)=gcorr6_turn(ll,l)!+ghalf
10128      &    +ekont*derx_turn(ll,4,2)
10129         gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
10130         gcorr6_turn_long(ll,l)=gcorr6_turn_long(ll,l)+gturn6kl
10131         gcorr6_turn_long(ll,k)=gcorr6_turn_long(ll,k)-gturn6kl
10132       enddo
10133 cd      goto 1112
10134 cgrad      do m=i+1,j-1
10135 cgrad        do ll=1,3
10136 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
10137 cgrad        enddo
10138 cgrad      enddo
10139 cgrad      do m=k+1,l-1
10140 cgrad        do ll=1,3
10141 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
10142 cgrad        enddo
10143 cgrad      enddo
10144 cgrad1112  continue
10145 cgrad      do m=i+2,j2
10146 cgrad        do ll=1,3
10147 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
10148 cgrad        enddo
10149 cgrad      enddo
10150 cgrad      do m=k+2,l2
10151 cgrad        do ll=1,3
10152 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
10153 cgrad        enddo
10154 cgrad      enddo
10155 cd      do iii=1,nres-3
10156 cd        write (2,*) iii,g_corr6_loc(iii)
10157 cd      enddo
10158       eello_turn6=ekont*eel_turn6
10159 cd      write (2,*) 'ekont',ekont
10160 cd      write (2,*) 'eel_turn6',ekont*eel_turn6
10161       return
10162       end
10163
10164 C-----------------------------------------------------------------------------
10165       double precision function scalar(u,v)
10166 !DIR$ INLINEALWAYS scalar
10167 #ifndef OSF
10168 cDEC$ ATTRIBUTES FORCEINLINE::scalar
10169 #endif
10170       implicit none
10171       double precision u(3),v(3)
10172 cd      double precision sc
10173 cd      integer i
10174 cd      sc=0.0d0
10175 cd      do i=1,3
10176 cd        sc=sc+u(i)*v(i)
10177 cd      enddo
10178 cd      scalar=sc
10179
10180       scalar=u(1)*v(1)+u(2)*v(2)+u(3)*v(3)
10181       return
10182       end
10183 crc-------------------------------------------------
10184       SUBROUTINE MATVEC2(A1,V1,V2)
10185 !DIR$ INLINEALWAYS MATVEC2
10186 #ifndef OSF
10187 cDEC$ ATTRIBUTES FORCEINLINE::MATVEC2
10188 #endif
10189       implicit real*8 (a-h,o-z)
10190       include 'DIMENSIONS'
10191       DIMENSION A1(2,2),V1(2),V2(2)
10192 c      DO 1 I=1,2
10193 c        VI=0.0
10194 c        DO 3 K=1,2
10195 c    3     VI=VI+A1(I,K)*V1(K)
10196 c        Vaux(I)=VI
10197 c    1 CONTINUE
10198
10199       vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
10200       vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
10201
10202       v2(1)=vaux1
10203       v2(2)=vaux2
10204       END
10205 C---------------------------------------
10206       SUBROUTINE MATMAT2(A1,A2,A3)
10207 #ifndef OSF
10208 cDEC$ ATTRIBUTES FORCEINLINE::MATMAT2
10209 #endif
10210       implicit real*8 (a-h,o-z)
10211       include 'DIMENSIONS'
10212       DIMENSION A1(2,2),A2(2,2),A3(2,2)
10213 c      DIMENSION AI3(2,2)
10214 c        DO  J=1,2
10215 c          A3IJ=0.0
10216 c          DO K=1,2
10217 c           A3IJ=A3IJ+A1(I,K)*A2(K,J)
10218 c          enddo
10219 c          A3(I,J)=A3IJ
10220 c       enddo
10221 c      enddo
10222
10223       ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
10224       ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
10225       ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
10226       ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
10227
10228       A3(1,1)=AI3_11
10229       A3(2,1)=AI3_21
10230       A3(1,2)=AI3_12
10231       A3(2,2)=AI3_22
10232       END
10233
10234 c-------------------------------------------------------------------------
10235       double precision function scalar2(u,v)
10236 !DIR$ INLINEALWAYS scalar2
10237       implicit none
10238       double precision u(2),v(2)
10239       double precision sc
10240       integer i
10241       scalar2=u(1)*v(1)+u(2)*v(2)
10242       return
10243       end
10244
10245 C-----------------------------------------------------------------------------
10246
10247       subroutine transpose2(a,at)
10248 !DIR$ INLINEALWAYS transpose2
10249 #ifndef OSF
10250 cDEC$ ATTRIBUTES FORCEINLINE::transpose2
10251 #endif
10252       implicit none
10253       double precision a(2,2),at(2,2)
10254       at(1,1)=a(1,1)
10255       at(1,2)=a(2,1)
10256       at(2,1)=a(1,2)
10257       at(2,2)=a(2,2)
10258       return
10259       end
10260 c--------------------------------------------------------------------------
10261       subroutine transpose(n,a,at)
10262       implicit none
10263       integer n,i,j
10264       double precision a(n,n),at(n,n)
10265       do i=1,n
10266         do j=1,n
10267           at(j,i)=a(i,j)
10268         enddo
10269       enddo
10270       return
10271       end
10272 C---------------------------------------------------------------------------
10273       subroutine prodmat3(a1,a2,kk,transp,prod)
10274 !DIR$ INLINEALWAYS prodmat3
10275 #ifndef OSF
10276 cDEC$ ATTRIBUTES FORCEINLINE::prodmat3
10277 #endif
10278       implicit none
10279       integer i,j
10280       double precision a1(2,2),a2(2,2),a2t(2,2),kk(2,2),prod(2,2)
10281       logical transp
10282 crc      double precision auxmat(2,2),prod_(2,2)
10283
10284       if (transp) then
10285 crc        call transpose2(kk(1,1),auxmat(1,1))
10286 crc        call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
10287 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
10288
10289            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1)
10290      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
10291            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2)
10292      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
10293            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1)
10294      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
10295            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2)
10296      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
10297
10298       else
10299 crc        call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
10300 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
10301
10302            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1)
10303      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
10304            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2)
10305      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
10306            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1)
10307      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
10308            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2)
10309      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
10310
10311       endif
10312 c      call transpose2(a2(1,1),a2t(1,1))
10313
10314 crc      print *,transp
10315 crc      print *,((prod_(i,j),i=1,2),j=1,2)
10316 crc      print *,((prod(i,j),i=1,2),j=1,2)
10317
10318       return
10319       end
10320 CCC----------------------------------------------
10321       subroutine Eliptransfer(eliptran)
10322       implicit real*8 (a-h,o-z)
10323       include 'DIMENSIONS'
10324       include 'COMMON.GEO'
10325       include 'COMMON.VAR'
10326       include 'COMMON.LOCAL'
10327       include 'COMMON.CHAIN'
10328       include 'COMMON.DERIV'
10329       include 'COMMON.NAMES'
10330       include 'COMMON.INTERACT'
10331       include 'COMMON.IOUNITS'
10332       include 'COMMON.CALC'
10333       include 'COMMON.CONTROL'
10334       include 'COMMON.SPLITELE'
10335       include 'COMMON.SBRIDGE'
10336 C this is done by Adasko
10337 C      print *,"wchodze"
10338 C structure of box:
10339 C      water
10340 C--bordliptop-- buffore starts
10341 C--bufliptop--- here true lipid starts
10342 C      lipid
10343 C--buflipbot--- lipid ends buffore starts
10344 C--bordlipbot--buffore ends
10345       eliptran=0.0
10346       do i=ilip_start,ilip_end
10347 C       do i=1,1
10348         if (itype(i).eq.ntyp1) cycle
10349
10350         positi=(mod(((c(3,i)+c(3,i+1))/2.0d0),boxzsize))
10351         if (positi.le.0) positi=positi+boxzsize
10352 C        print *,i
10353 C first for peptide groups
10354 c for each residue check if it is in lipid or lipid water border area
10355        if ((positi.gt.bordlipbot)
10356      &.and.(positi.lt.bordliptop)) then
10357 C the energy transfer exist
10358         if (positi.lt.buflipbot) then
10359 C what fraction I am in
10360          fracinbuf=1.0d0-
10361      &        ((positi-bordlipbot)/lipbufthick)
10362 C lipbufthick is thickenes of lipid buffore
10363          sslip=sscalelip(fracinbuf)
10364          ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
10365          eliptran=eliptran+sslip*pepliptran
10366          gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
10367          gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
10368 C         gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
10369
10370 C        print *,"doing sccale for lower part"
10371 C         print *,i,sslip,fracinbuf,ssgradlip
10372         elseif (positi.gt.bufliptop) then
10373          fracinbuf=1.0d0-((bordliptop-positi)/lipbufthick)
10374          sslip=sscalelip(fracinbuf)
10375          ssgradlip=sscagradlip(fracinbuf)/lipbufthick
10376          eliptran=eliptran+sslip*pepliptran
10377          gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
10378          gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
10379 C         gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
10380 C          print *, "doing sscalefor top part"
10381 C         print *,i,sslip,fracinbuf,ssgradlip
10382         else
10383          eliptran=eliptran+pepliptran
10384 C         print *,"I am in true lipid"
10385         endif
10386 C       else
10387 C       eliptran=elpitran+0.0 ! I am in water
10388        endif
10389        enddo
10390 C       print *, "nic nie bylo w lipidzie?"
10391 C now multiply all by the peptide group transfer factor
10392 C       eliptran=eliptran*pepliptran
10393 C now the same for side chains
10394 CV       do i=1,1
10395        do i=ilip_start,ilip_end
10396         if (itype(i).eq.ntyp1) cycle
10397         positi=(mod(c(3,i+nres),boxzsize))
10398         if (positi.le.0) positi=positi+boxzsize
10399 C       print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop
10400 c for each residue check if it is in lipid or lipid water border area
10401 C       respos=mod(c(3,i+nres),boxzsize)
10402 C       print *,positi,bordlipbot,buflipbot
10403        if ((positi.gt.bordlipbot)
10404      & .and.(positi.lt.bordliptop)) then
10405 C the energy transfer exist
10406         if (positi.lt.buflipbot) then
10407          fracinbuf=1.0d0-
10408      &     ((positi-bordlipbot)/lipbufthick)
10409 C lipbufthick is thickenes of lipid buffore
10410          sslip=sscalelip(fracinbuf)
10411          ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
10412          eliptran=eliptran+sslip*liptranene(itype(i))
10413          gliptranx(3,i)=gliptranx(3,i)
10414      &+ssgradlip*liptranene(itype(i))
10415          gliptranc(3,i-1)= gliptranc(3,i-1)
10416      &+ssgradlip*liptranene(itype(i))
10417 C         print *,"doing sccale for lower part"
10418         elseif (positi.gt.bufliptop) then
10419          fracinbuf=1.0d0-
10420      &((bordliptop-positi)/lipbufthick)
10421          sslip=sscalelip(fracinbuf)
10422          ssgradlip=sscagradlip(fracinbuf)/lipbufthick
10423          eliptran=eliptran+sslip*liptranene(itype(i))
10424          gliptranx(3,i)=gliptranx(3,i)
10425      &+ssgradlip*liptranene(itype(i))
10426          gliptranc(3,i-1)= gliptranc(3,i-1)
10427      &+ssgradlip*liptranene(itype(i))
10428 C          print *, "doing sscalefor top part",sslip,fracinbuf
10429         else
10430          eliptran=eliptran+liptranene(itype(i))
10431 C         print *,"I am in true lipid"
10432         endif
10433         endif ! if in lipid or buffor
10434 C       else
10435 C       eliptran=elpitran+0.0 ! I am in water
10436        enddo
10437        return
10438        end
10439 C---------------------------------------------------------
10440 C AFM soubroutine for constant force
10441        subroutine AFMforce(Eafmforce)
10442        implicit real*8 (a-h,o-z)
10443       include 'DIMENSIONS'
10444       include 'COMMON.GEO'
10445       include 'COMMON.VAR'
10446       include 'COMMON.LOCAL'
10447       include 'COMMON.CHAIN'
10448       include 'COMMON.DERIV'
10449       include 'COMMON.NAMES'
10450       include 'COMMON.INTERACT'
10451       include 'COMMON.IOUNITS'
10452       include 'COMMON.CALC'
10453       include 'COMMON.CONTROL'
10454       include 'COMMON.SPLITELE'
10455       include 'COMMON.SBRIDGE'
10456       real*8 diffafm(3)
10457       dist=0.0d0
10458       Eafmforce=0.0d0
10459       do i=1,3
10460       diffafm(i)=c(i,afmend)-c(i,afmbeg)
10461       dist=dist+diffafm(i)**2
10462       enddo
10463       dist=dsqrt(dist)
10464       Eafmforce=-forceAFMconst*(dist-distafminit)
10465       do i=1,3
10466       gradafm(i,afmend-1)=-forceAFMconst*diffafm(i)/dist
10467       gradafm(i,afmbeg-1)=forceAFMconst*diffafm(i)/dist
10468       enddo
10469 C      print *,'AFM',Eafmforce
10470       return
10471       end
10472 C---------------------------------------------------------
10473 C AFM subroutine with pseudoconstant velocity
10474        subroutine AFMvel(Eafmforce)
10475        implicit real*8 (a-h,o-z)
10476       include 'DIMENSIONS'
10477       include 'COMMON.GEO'
10478       include 'COMMON.VAR'
10479       include 'COMMON.LOCAL'
10480       include 'COMMON.CHAIN'
10481       include 'COMMON.DERIV'
10482       include 'COMMON.NAMES'
10483       include 'COMMON.INTERACT'
10484       include 'COMMON.IOUNITS'
10485       include 'COMMON.CALC'
10486       include 'COMMON.CONTROL'
10487       include 'COMMON.SPLITELE'
10488       include 'COMMON.SBRIDGE'
10489       real*8 diffafm(3)
10490 C Only for check grad COMMENT if not used for checkgrad
10491 C      totT=3.0d0
10492 C--------------------------------------------------------
10493 C      print *,"wchodze"
10494       dist=0.0d0
10495       Eafmforce=0.0d0
10496       do i=1,3
10497       diffafm(i)=c(i,afmend)-c(i,afmbeg)
10498       dist=dist+diffafm(i)**2
10499       enddo
10500       dist=dsqrt(dist)
10501       Eafmforce=0.5d0*forceAFMconst
10502      & *(distafminit+totTafm*velAFMconst-dist)**2
10503 C      Eafmforce=-forceAFMconst*(dist-distafminit)
10504       do i=1,3
10505       gradafm(i,afmend-1)=-forceAFMconst*
10506      &(distafminit+totTafm*velAFMconst-dist)
10507      &*diffafm(i)/dist
10508       gradafm(i,afmbeg-1)=forceAFMconst*
10509      &(distafminit+totTafm*velAFMconst-dist)
10510      &*diffafm(i)/dist
10511       enddo
10512 C      print *,'AFM',Eafmforce,totTafm*velAFMconst,dist
10513       return
10514       end
10515